*> \brief \b DBBCSD * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DBBCSD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, * THETA, PHI, U1, LDU1, U2, LDU2, V1T, LDV1T, * V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, * B22D, B22E, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS * INTEGER INFO, LDU1, LDU2, LDV1T, LDV2T, LWORK, M, P, Q * .. * .. Array Arguments .. * DOUBLE PRECISION B11D( * ), B11E( * ), B12D( * ), B12E( * ), * $ B21D( * ), B21E( * ), B22D( * ), B22E( * ), * $ PHI( * ), THETA( * ), WORK( * ) * DOUBLE PRECISION U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ), * $ V2T( LDV2T, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DBBCSD computes the CS decomposition of an orthogonal matrix in *> bidiagonal-block form, *> *> *> [ B11 | B12 0 0 ] *> [ 0 | 0 -I 0 ] *> X = [----------------] *> [ B21 | B22 0 0 ] *> [ 0 | 0 0 I ] *> *> [ C | -S 0 0 ] *> [ U1 | ] [ 0 | 0 -I 0 ] [ V1 | ]**T *> = [---------] [---------------] [---------] . *> [ | U2 ] [ S | C 0 0 ] [ | V2 ] *> [ 0 | 0 0 I ] *> *> X is M-by-M, its top-left block is P-by-Q, and Q must be no larger *> than P, M-P, or M-Q. (If Q is not the smallest index, then X must be *> transposed and/or permuted. This can be done in constant time using *> the TRANS and SIGNS options. See DORCSD for details.) *> *> The bidiagonal matrices B11, B12, B21, and B22 are represented *> implicitly by angles THETA(1:Q) and PHI(1:Q-1). *> *> The orthogonal matrices U1, U2, V1T, and V2T are input/output. *> The input matrices are pre- or post-multiplied by the appropriate *> singular vector matrices. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBU1 *> \verbatim *> JOBU1 is CHARACTER *> = 'Y': U1 is updated; *> otherwise: U1 is not updated. *> \endverbatim *> *> \param[in] JOBU2 *> \verbatim *> JOBU2 is CHARACTER *> = 'Y': U2 is updated; *> otherwise: U2 is not updated. *> \endverbatim *> *> \param[in] JOBV1T *> \verbatim *> JOBV1T is CHARACTER *> = 'Y': V1T is updated; *> otherwise: V1T is not updated. *> \endverbatim *> *> \param[in] JOBV2T *> \verbatim *> JOBV2T is CHARACTER *> = 'Y': V2T is updated; *> otherwise: V2T is not updated. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER *> = 'T': X, U1, U2, V1T, and V2T are stored in row-major *> order; *> otherwise: X, U1, U2, V1T, and V2T are stored in column- *> major order. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows and columns in X, the orthogonal matrix in *> bidiagonal-block form. *> \endverbatim *> *> \param[in] P *> \verbatim *> P is INTEGER *> The number of rows in the top-left block of X. 0 <= P <= M. *> \endverbatim *> *> \param[in] Q *> \verbatim *> Q is INTEGER *> The number of columns in the top-left block of X. *> 0 <= Q <= MIN(P,M-P,M-Q). *> \endverbatim *> *> \param[in,out] THETA *> \verbatim *> THETA is DOUBLE PRECISION array, dimension (Q) *> On entry, the angles THETA(1),...,THETA(Q) that, along with *> PHI(1), ...,PHI(Q-1), define the matrix in bidiagonal-block *> form. On exit, the angles whose cosines and sines define the *> diagonal blocks in the CS decomposition. *> \endverbatim *> *> \param[in,out] PHI *> \verbatim *> PHI is DOUBLE PRECISION array, dimension (Q-1) *> The angles PHI(1),...,PHI(Q-1) that, along with THETA(1),..., *> THETA(Q), define the matrix in bidiagonal-block form. *> \endverbatim *> *> \param[in,out] U1 *> \verbatim *> U1 is DOUBLE PRECISION array, dimension (LDU1,P) *> On entry, a P-by-P matrix. On exit, U1 is postmultiplied *> by the left singular vector matrix common to [ B11 ; 0 ] and *> [ B12 0 0 ; 0 -I 0 0 ]. *> \endverbatim *> *> \param[in] LDU1 *> \verbatim *> LDU1 is INTEGER *> The leading dimension of the array U1, LDU1 >= MAX(1,P). *> \endverbatim *> *> \param[in,out] U2 *> \verbatim *> U2 is DOUBLE PRECISION array, dimension (LDU2,M-P) *> On entry, an (M-P)-by-(M-P) matrix. On exit, U2 is *> postmultiplied by the left singular vector matrix common to *> [ B21 ; 0 ] and [ B22 0 0 ; 0 0 I ]. *> \endverbatim *> *> \param[in] LDU2 *> \verbatim *> LDU2 is INTEGER *> The leading dimension of the array U2, LDU2 >= MAX(1,M-P). *> \endverbatim *> *> \param[in,out] V1T *> \verbatim *> V1T is DOUBLE PRECISION array, dimension (LDV1T,Q) *> On entry, a Q-by-Q matrix. On exit, V1T is premultiplied *> by the transpose of the right singular vector *> matrix common to [ B11 ; 0 ] and [ B21 ; 0 ]. *> \endverbatim *> *> \param[in] LDV1T *> \verbatim *> LDV1T is INTEGER *> The leading dimension of the array V1T, LDV1T >= MAX(1,Q). *> \endverbatim *> *> \param[in,out] V2T *> \verbatim *> V2T is DOUBLE PRECISION array, dimension (LDV2T,M-Q) *> On entry, an (M-Q)-by-(M-Q) matrix. On exit, V2T is *> premultiplied by the transpose of the right *> singular vector matrix common to [ B12 0 0 ; 0 -I 0 ] and *> [ B22 0 0 ; 0 0 I ]. *> \endverbatim *> *> \param[in] LDV2T *> \verbatim *> LDV2T is INTEGER *> The leading dimension of the array V2T, LDV2T >= MAX(1,M-Q). *> \endverbatim *> *> \param[out] B11D *> \verbatim *> B11D is DOUBLE PRECISION array, dimension (Q) *> When DBBCSD converges, B11D contains the cosines of THETA(1), *> ..., THETA(Q). If DBBCSD fails to converge, then B11D *> contains the diagonal of the partially reduced top-left *> block. *> \endverbatim *> *> \param[out] B11E *> \verbatim *> B11E is DOUBLE PRECISION array, dimension (Q-1) *> When DBBCSD converges, B11E contains zeros. If DBBCSD fails *> to converge, then B11E contains the superdiagonal of the *> partially reduced top-left block. *> \endverbatim *> *> \param[out] B12D *> \verbatim *> B12D is DOUBLE PRECISION array, dimension (Q) *> When DBBCSD converges, B12D contains the negative sines of *> THETA(1), ..., THETA(Q). If DBBCSD fails to converge, then *> B12D contains the diagonal of the partially reduced top-right *> block. *> \endverbatim *> *> \param[out] B12E *> \verbatim *> B12E is DOUBLE PRECISION array, dimension (Q-1) *> When DBBCSD converges, B12E contains zeros. If DBBCSD fails *> to converge, then B12E contains the subdiagonal of the *> partially reduced top-right block. *> \endverbatim *> *> \param[out] B21D *> \verbatim *> B21D is DOUBLE PRECISION array, dimension (Q) *> When DBBCSD converges, B21D contains the negative sines of *> THETA(1), ..., THETA(Q). If DBBCSD fails to converge, then *> B21D contains the diagonal of the partially reduced bottom-left *> block. *> \endverbatim *> *> \param[out] B21E *> \verbatim *> B21E is DOUBLE PRECISION array, dimension (Q-1) *> When DBBCSD converges, B21E contains zeros. If DBBCSD fails *> to converge, then B21E contains the subdiagonal of the *> partially reduced bottom-left block. *> \endverbatim *> *> \param[out] B22D *> \verbatim *> B22D is DOUBLE PRECISION array, dimension (Q) *> When DBBCSD converges, B22D contains the negative sines of *> THETA(1), ..., THETA(Q). If DBBCSD fails to converge, then *> B22D contains the diagonal of the partially reduced bottom-right *> block. *> \endverbatim *> *> \param[out] B22E *> \verbatim *> B22E is DOUBLE PRECISION array, dimension (Q-1) *> When DBBCSD converges, B22E contains zeros. If DBBCSD fails *> to converge, then B22E contains the subdiagonal of the *> partially reduced bottom-right block. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= MAX(1,8*Q). *> *> 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: if DBBCSD did not converge, INFO specifies the number *> of nonzero entries in PHI, and B11D, B11E, etc., *> contain the partially reduced matrix. *> \endverbatim * *> \par Internal Parameters: * ========================= *> *> \verbatim *> TOLMUL DOUBLE PRECISION, default = MAX(10,MIN(100,EPS**(-1/8))) *> TOLMUL controls the convergence criterion of the QR loop. *> Angles THETA(i), PHI(i) are rounded to 0 or PI/2 when they *> are within TOLMUL*EPS of either bound. *> \endverbatim * *> \par References: * ================ *> *> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. *> Algorithms, 50(1):33-65, 2009. * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, $ THETA, PHI, U1, LDU1, U2, LDU2, V1T, LDV1T, $ V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, $ B22D, B22E, WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS INTEGER INFO, LDU1, LDU2, LDV1T, LDV2T, LWORK, M, P, Q * .. * .. Array Arguments .. DOUBLE PRECISION B11D( * ), B11E( * ), B12D( * ), B12E( * ), $ B21D( * ), B21E( * ), B22D( * ), B22E( * ), $ PHI( * ), THETA( * ), WORK( * ) DOUBLE PRECISION U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ), $ V2T( LDV2T, * ) * .. * * =================================================================== * * .. Parameters .. INTEGER MAXITR PARAMETER ( MAXITR = 6 ) DOUBLE PRECISION HUNDRED, MEIGHTH, ONE, PIOVER2, TEN, ZERO PARAMETER ( HUNDRED = 100.0D0, MEIGHTH = -0.125D0, $ ONE = 1.0D0, PIOVER2 = 1.57079632679489662D0, $ TEN = 10.0D0, ZERO = 0.0D0 ) DOUBLE PRECISION NEGONE PARAMETER ( NEGONE = -1.0D0 ) * .. * .. Local Scalars .. LOGICAL COLMAJOR, LQUERY, RESTART11, RESTART12, $ RESTART21, RESTART22, WANTU1, WANTU2, WANTV1T, $ WANTV2T INTEGER I, IMIN, IMAX, ITER, IU1CS, IU1SN, IU2CS, $ IU2SN, IV1TCS, IV1TSN, IV2TCS, IV2TSN, J, $ LWORKMIN, LWORKOPT, MAXIT, MINI DOUBLE PRECISION B11BULGE, B12BULGE, B21BULGE, B22BULGE, DUMMY, $ EPS, MU, NU, R, SIGMA11, SIGMA21, $ TEMP, THETAMAX, THETAMIN, THRESH, TOL, TOLMUL, $ UNFL, X1, X2, Y1, Y2 * * .. External Subroutines .. EXTERNAL DLASR, DSCAL, DSWAP, DLARTGP, DLARTGS, DLAS2, $ XERBLA * .. * .. External Functions .. DOUBLE PRECISION DLAMCH LOGICAL LSAME EXTERNAL LSAME, DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, ATAN2, COS, MAX, MIN, SIN, SQRT * .. * .. Executable Statements .. * * Test input arguments * INFO = 0 LQUERY = LWORK .EQ. -1 WANTU1 = LSAME( JOBU1, 'Y' ) WANTU2 = LSAME( JOBU2, 'Y' ) WANTV1T = LSAME( JOBV1T, 'Y' ) WANTV2T = LSAME( JOBV2T, 'Y' ) COLMAJOR = .NOT. LSAME( TRANS, 'T' ) * IF( M .LT. 0 ) THEN INFO = -6 ELSE IF( P .LT. 0 .OR. P .GT. M ) THEN INFO = -7 ELSE IF( Q .LT. 0 .OR. Q .GT. M ) THEN INFO = -8 ELSE IF( Q .GT. P .OR. Q .GT. M-P .OR. Q .GT. M-Q ) THEN INFO = -8 ELSE IF( WANTU1 .AND. LDU1 .LT. P ) THEN INFO = -12 ELSE IF( WANTU2 .AND. LDU2 .LT. M-P ) THEN INFO = -14 ELSE IF( WANTV1T .AND. LDV1T .LT. Q ) THEN INFO = -16 ELSE IF( WANTV2T .AND. LDV2T .LT. M-Q ) THEN INFO = -18 END IF * * Quick return if Q = 0 * IF( INFO .EQ. 0 .AND. Q .EQ. 0 ) THEN LWORKMIN = 1 WORK(1) = LWORKMIN RETURN END IF * * Compute workspace * IF( INFO .EQ. 0 ) THEN IU1CS = 1 IU1SN = IU1CS + Q IU2CS = IU1SN + Q IU2SN = IU2CS + Q IV1TCS = IU2SN + Q IV1TSN = IV1TCS + Q IV2TCS = IV1TSN + Q IV2TSN = IV2TCS + Q LWORKOPT = IV2TSN + Q - 1 LWORKMIN = LWORKOPT WORK(1) = LWORKOPT IF( LWORK .LT. LWORKMIN .AND. .NOT. LQUERY ) THEN INFO = -28 END IF END IF * IF( INFO .NE. 0 ) THEN CALL XERBLA( 'DBBCSD', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Get machine constants * EPS = DLAMCH( 'Epsilon' ) UNFL = DLAMCH( 'Safe minimum' ) TOLMUL = MAX( TEN, MIN( HUNDRED, EPS**MEIGHTH ) ) TOL = TOLMUL*EPS THRESH = MAX( TOL, MAXITR*Q*Q*UNFL ) * * Test for negligible sines or cosines * DO I = 1, Q IF( THETA(I) .LT. THRESH ) THEN THETA(I) = ZERO ELSE IF( THETA(I) .GT. PIOVER2-THRESH ) THEN THETA(I) = PIOVER2 END IF END DO DO I = 1, Q-1 IF( PHI(I) .LT. THRESH ) THEN PHI(I) = ZERO ELSE IF( PHI(I) .GT. PIOVER2-THRESH ) THEN PHI(I) = PIOVER2 END IF END DO * * Initial deflation * IMAX = Q DO WHILE( IMAX .GT. 1 ) IF( PHI(IMAX-1) .NE. ZERO ) THEN EXIT END IF IMAX = IMAX - 1 END DO IMIN = IMAX - 1 IF ( IMIN .GT. 1 ) THEN DO WHILE( PHI(IMIN-1) .NE. ZERO ) IMIN = IMIN - 1 IF ( IMIN .LE. 1 ) EXIT END DO END IF * * Initialize iteration counter * MAXIT = MAXITR*Q*Q ITER = 0 * * Begin main iteration loop * DO WHILE( IMAX .GT. 1 ) * * Compute the matrix entries * B11D(IMIN) = COS( THETA(IMIN) ) B21D(IMIN) = -SIN( THETA(IMIN) ) DO I = IMIN, IMAX - 1 B11E(I) = -SIN( THETA(I) ) * SIN( PHI(I) ) B11D(I+1) = COS( THETA(I+1) ) * COS( PHI(I) ) B12D(I) = SIN( THETA(I) ) * COS( PHI(I) ) B12E(I) = COS( THETA(I+1) ) * SIN( PHI(I) ) B21E(I) = -COS( THETA(I) ) * SIN( PHI(I) ) B21D(I+1) = -SIN( THETA(I+1) ) * COS( PHI(I) ) B22D(I) = COS( THETA(I) ) * COS( PHI(I) ) B22E(I) = -SIN( THETA(I+1) ) * SIN( PHI(I) ) END DO B12D(IMAX) = SIN( THETA(IMAX) ) B22D(IMAX) = COS( THETA(IMAX) ) * * Abort if not converging; otherwise, increment ITER * IF( ITER .GT. MAXIT ) THEN INFO = 0 DO I = 1, Q IF( PHI(I) .NE. ZERO ) $ INFO = INFO + 1 END DO RETURN END IF * ITER = ITER + IMAX - IMIN * * Compute shifts * THETAMAX = THETA(IMIN) THETAMIN = THETA(IMIN) DO I = IMIN+1, IMAX IF( THETA(I) > THETAMAX ) $ THETAMAX = THETA(I) IF( THETA(I) < THETAMIN ) $ THETAMIN = THETA(I) END DO * IF( THETAMAX .GT. PIOVER2 - THRESH ) THEN * * Zero on diagonals of B11 and B22; induce deflation with a * zero shift * MU = ZERO NU = ONE * ELSE IF( THETAMIN .LT. THRESH ) THEN * * Zero on diagonals of B12 and B22; induce deflation with a * zero shift * MU = ONE NU = ZERO * ELSE * * Compute shifts for B11 and B21 and use the lesser * CALL DLAS2( B11D(IMAX-1), B11E(IMAX-1), B11D(IMAX), SIGMA11, $ DUMMY ) CALL DLAS2( B21D(IMAX-1), B21E(IMAX-1), B21D(IMAX), SIGMA21, $ DUMMY ) * IF( SIGMA11 .LE. SIGMA21 ) THEN MU = SIGMA11 NU = SQRT( ONE - MU**2 ) IF( MU .LT. THRESH ) THEN MU = ZERO NU = ONE END IF ELSE NU = SIGMA21 MU = SQRT( 1.0 - NU**2 ) IF( NU .LT. THRESH ) THEN MU = ONE NU = ZERO END IF END IF END IF * * Rotate to produce bulges in B11 and B21 * IF( MU .LE. NU ) THEN CALL DLARTGS( B11D(IMIN), B11E(IMIN), MU, $ WORK(IV1TCS+IMIN-1), WORK(IV1TSN+IMIN-1) ) ELSE CALL DLARTGS( B21D(IMIN), B21E(IMIN), NU, $ WORK(IV1TCS+IMIN-1), WORK(IV1TSN+IMIN-1) ) END IF * TEMP = WORK(IV1TCS+IMIN-1)*B11D(IMIN) + $ WORK(IV1TSN+IMIN-1)*B11E(IMIN) B11E(IMIN) = WORK(IV1TCS+IMIN-1)*B11E(IMIN) - $ WORK(IV1TSN+IMIN-1)*B11D(IMIN) B11D(IMIN) = TEMP B11BULGE = WORK(IV1TSN+IMIN-1)*B11D(IMIN+1) B11D(IMIN+1) = WORK(IV1TCS+IMIN-1)*B11D(IMIN+1) TEMP = WORK(IV1TCS+IMIN-1)*B21D(IMIN) + $ WORK(IV1TSN+IMIN-1)*B21E(IMIN) B21E(IMIN) = WORK(IV1TCS+IMIN-1)*B21E(IMIN) - $ WORK(IV1TSN+IMIN-1)*B21D(IMIN) B21D(IMIN) = TEMP B21BULGE = WORK(IV1TSN+IMIN-1)*B21D(IMIN+1) B21D(IMIN+1) = WORK(IV1TCS+IMIN-1)*B21D(IMIN+1) * * Compute THETA(IMIN) * THETA( IMIN ) = ATAN2( SQRT( B21D(IMIN)**2+B21BULGE**2 ), $ SQRT( B11D(IMIN)**2+B11BULGE**2 ) ) * * Chase the bulges in B11(IMIN+1,IMIN) and B21(IMIN+1,IMIN) * IF( B11D(IMIN)**2+B11BULGE**2 .GT. THRESH**2 ) THEN CALL DLARTGP( B11BULGE, B11D(IMIN), WORK(IU1SN+IMIN-1), $ WORK(IU1CS+IMIN-1), R ) ELSE IF( MU .LE. NU ) THEN CALL DLARTGS( B11E( IMIN ), B11D( IMIN + 1 ), MU, $ WORK(IU1CS+IMIN-1), WORK(IU1SN+IMIN-1) ) ELSE CALL DLARTGS( B12D( IMIN ), B12E( IMIN ), NU, $ WORK(IU1CS+IMIN-1), WORK(IU1SN+IMIN-1) ) END IF IF( B21D(IMIN)**2+B21BULGE**2 .GT. THRESH**2 ) THEN CALL DLARTGP( B21BULGE, B21D(IMIN), WORK(IU2SN+IMIN-1), $ WORK(IU2CS+IMIN-1), R ) ELSE IF( NU .LT. MU ) THEN CALL DLARTGS( B21E( IMIN ), B21D( IMIN + 1 ), NU, $ WORK(IU2CS+IMIN-1), WORK(IU2SN+IMIN-1) ) ELSE CALL DLARTGS( B22D(IMIN), B22E(IMIN), MU, $ WORK(IU2CS+IMIN-1), WORK(IU2SN+IMIN-1) ) END IF WORK(IU2CS+IMIN-1) = -WORK(IU2CS+IMIN-1) WORK(IU2SN+IMIN-1) = -WORK(IU2SN+IMIN-1) * TEMP = WORK(IU1CS+IMIN-1)*B11E(IMIN) + $ WORK(IU1SN+IMIN-1)*B11D(IMIN+1) B11D(IMIN+1) = WORK(IU1CS+IMIN-1)*B11D(IMIN+1) - $ WORK(IU1SN+IMIN-1)*B11E(IMIN) B11E(IMIN) = TEMP IF( IMAX .GT. IMIN+1 ) THEN B11BULGE = WORK(IU1SN+IMIN-1)*B11E(IMIN+1) B11E(IMIN+1) = WORK(IU1CS+IMIN-1)*B11E(IMIN+1) END IF TEMP = WORK(IU1CS+IMIN-1)*B12D(IMIN) + $ WORK(IU1SN+IMIN-1)*B12E(IMIN) B12E(IMIN) = WORK(IU1CS+IMIN-1)*B12E(IMIN) - $ WORK(IU1SN+IMIN-1)*B12D(IMIN) B12D(IMIN) = TEMP B12BULGE = WORK(IU1SN+IMIN-1)*B12D(IMIN+1) B12D(IMIN+1) = WORK(IU1CS+IMIN-1)*B12D(IMIN+1) TEMP = WORK(IU2CS+IMIN-1)*B21E(IMIN) + $ WORK(IU2SN+IMIN-1)*B21D(IMIN+1) B21D(IMIN+1) = WORK(IU2CS+IMIN-1)*B21D(IMIN+1) - $ WORK(IU2SN+IMIN-1)*B21E(IMIN) B21E(IMIN) = TEMP IF( IMAX .GT. IMIN+1 ) THEN B21BULGE = WORK(IU2SN+IMIN-1)*B21E(IMIN+1) B21E(IMIN+1) = WORK(IU2CS+IMIN-1)*B21E(IMIN+1) END IF TEMP = WORK(IU2CS+IMIN-1)*B22D(IMIN) + $ WORK(IU2SN+IMIN-1)*B22E(IMIN) B22E(IMIN) = WORK(IU2CS+IMIN-1)*B22E(IMIN) - $ WORK(IU2SN+IMIN-1)*B22D(IMIN) B22D(IMIN) = TEMP B22BULGE = WORK(IU2SN+IMIN-1)*B22D(IMIN+1) B22D(IMIN+1) = WORK(IU2CS+IMIN-1)*B22D(IMIN+1) * * Inner loop: chase bulges from B11(IMIN,IMIN+2), * B12(IMIN,IMIN+1), B21(IMIN,IMIN+2), and B22(IMIN,IMIN+1) to * bottom-right * DO I = IMIN+1, IMAX-1 * * Compute PHI(I-1) * X1 = SIN(THETA(I-1))*B11E(I-1) + COS(THETA(I-1))*B21E(I-1) X2 = SIN(THETA(I-1))*B11BULGE + COS(THETA(I-1))*B21BULGE Y1 = SIN(THETA(I-1))*B12D(I-1) + COS(THETA(I-1))*B22D(I-1) Y2 = SIN(THETA(I-1))*B12BULGE + COS(THETA(I-1))*B22BULGE * PHI(I-1) = ATAN2( SQRT(X1**2+X2**2), SQRT(Y1**2+Y2**2) ) * * Determine if there are bulges to chase or if a new direct * summand has been reached * RESTART11 = B11E(I-1)**2 + B11BULGE**2 .LE. THRESH**2 RESTART21 = B21E(I-1)**2 + B21BULGE**2 .LE. THRESH**2 RESTART12 = B12D(I-1)**2 + B12BULGE**2 .LE. THRESH**2 RESTART22 = B22D(I-1)**2 + B22BULGE**2 .LE. THRESH**2 * * If possible, chase bulges from B11(I-1,I+1), B12(I-1,I), * B21(I-1,I+1), and B22(I-1,I). If necessary, restart bulge- * chasing by applying the original shift again. * IF( .NOT. RESTART11 .AND. .NOT. RESTART21 ) THEN CALL DLARTGP( X2, X1, WORK(IV1TSN+I-1), WORK(IV1TCS+I-1), $ R ) ELSE IF( .NOT. RESTART11 .AND. RESTART21 ) THEN CALL DLARTGP( B11BULGE, B11E(I-1), WORK(IV1TSN+I-1), $ WORK(IV1TCS+I-1), R ) ELSE IF( RESTART11 .AND. .NOT. RESTART21 ) THEN CALL DLARTGP( B21BULGE, B21E(I-1), WORK(IV1TSN+I-1), $ WORK(IV1TCS+I-1), R ) ELSE IF( MU .LE. NU ) THEN CALL DLARTGS( B11D(I), B11E(I), MU, WORK(IV1TCS+I-1), $ WORK(IV1TSN+I-1) ) ELSE CALL DLARTGS( B21D(I), B21E(I), NU, WORK(IV1TCS+I-1), $ WORK(IV1TSN+I-1) ) END IF WORK(IV1TCS+I-1) = -WORK(IV1TCS+I-1) WORK(IV1TSN+I-1) = -WORK(IV1TSN+I-1) IF( .NOT. RESTART12 .AND. .NOT. RESTART22 ) THEN CALL DLARTGP( Y2, Y1, WORK(IV2TSN+I-1-1), $ WORK(IV2TCS+I-1-1), R ) ELSE IF( .NOT. RESTART12 .AND. RESTART22 ) THEN CALL DLARTGP( B12BULGE, B12D(I-1), WORK(IV2TSN+I-1-1), $ WORK(IV2TCS+I-1-1), R ) ELSE IF( RESTART12 .AND. .NOT. RESTART22 ) THEN CALL DLARTGP( B22BULGE, B22D(I-1), WORK(IV2TSN+I-1-1), $ WORK(IV2TCS+I-1-1), R ) ELSE IF( NU .LT. MU ) THEN CALL DLARTGS( B12E(I-1), B12D(I), NU, WORK(IV2TCS+I-1-1), $ WORK(IV2TSN+I-1-1) ) ELSE CALL DLARTGS( B22E(I-1), B22D(I), MU, WORK(IV2TCS+I-1-1), $ WORK(IV2TSN+I-1-1) ) END IF * TEMP = WORK(IV1TCS+I-1)*B11D(I) + WORK(IV1TSN+I-1)*B11E(I) B11E(I) = WORK(IV1TCS+I-1)*B11E(I) - $ WORK(IV1TSN+I-1)*B11D(I) B11D(I) = TEMP B11BULGE = WORK(IV1TSN+I-1)*B11D(I+1) B11D(I+1) = WORK(IV1TCS+I-1)*B11D(I+1) TEMP = WORK(IV1TCS+I-1)*B21D(I) + WORK(IV1TSN+I-1)*B21E(I) B21E(I) = WORK(IV1TCS+I-1)*B21E(I) - $ WORK(IV1TSN+I-1)*B21D(I) B21D(I) = TEMP B21BULGE = WORK(IV1TSN+I-1)*B21D(I+1) B21D(I+1) = WORK(IV1TCS+I-1)*B21D(I+1) TEMP = WORK(IV2TCS+I-1-1)*B12E(I-1) + $ WORK(IV2TSN+I-1-1)*B12D(I) B12D(I) = WORK(IV2TCS+I-1-1)*B12D(I) - $ WORK(IV2TSN+I-1-1)*B12E(I-1) B12E(I-1) = TEMP B12BULGE = WORK(IV2TSN+I-1-1)*B12E(I) B12E(I) = WORK(IV2TCS+I-1-1)*B12E(I) TEMP = WORK(IV2TCS+I-1-1)*B22E(I-1) + $ WORK(IV2TSN+I-1-1)*B22D(I) B22D(I) = WORK(IV2TCS+I-1-1)*B22D(I) - $ WORK(IV2TSN+I-1-1)*B22E(I-1) B22E(I-1) = TEMP B22BULGE = WORK(IV2TSN+I-1-1)*B22E(I) B22E(I) = WORK(IV2TCS+I-1-1)*B22E(I) * * Compute THETA(I) * X1 = COS(PHI(I-1))*B11D(I) + SIN(PHI(I-1))*B12E(I-1) X2 = COS(PHI(I-1))*B11BULGE + SIN(PHI(I-1))*B12BULGE Y1 = COS(PHI(I-1))*B21D(I) + SIN(PHI(I-1))*B22E(I-1) Y2 = COS(PHI(I-1))*B21BULGE + SIN(PHI(I-1))*B22BULGE * THETA(I) = ATAN2( SQRT(Y1**2+Y2**2), SQRT(X1**2+X2**2) ) * * Determine if there are bulges to chase or if a new direct * summand has been reached * RESTART11 = B11D(I)**2 + B11BULGE**2 .LE. THRESH**2 RESTART12 = B12E(I-1)**2 + B12BULGE**2 .LE. THRESH**2 RESTART21 = B21D(I)**2 + B21BULGE**2 .LE. THRESH**2 RESTART22 = B22E(I-1)**2 + B22BULGE**2 .LE. THRESH**2 * * If possible, chase bulges from B11(I+1,I), B12(I+1,I-1), * B21(I+1,I), and B22(I+1,I-1). If necessary, restart bulge- * chasing by applying the original shift again. * IF( .NOT. RESTART11 .AND. .NOT. RESTART12 ) THEN CALL DLARTGP( X2, X1, WORK(IU1SN+I-1), WORK(IU1CS+I-1), $ R ) ELSE IF( .NOT. RESTART11 .AND. RESTART12 ) THEN CALL DLARTGP( B11BULGE, B11D(I), WORK(IU1SN+I-1), $ WORK(IU1CS+I-1), R ) ELSE IF( RESTART11 .AND. .NOT. RESTART12 ) THEN CALL DLARTGP( B12BULGE, B12E(I-1), WORK(IU1SN+I-1), $ WORK(IU1CS+I-1), R ) ELSE IF( MU .LE. NU ) THEN CALL DLARTGS( B11E(I), B11D(I+1), MU, WORK(IU1CS+I-1), $ WORK(IU1SN+I-1) ) ELSE CALL DLARTGS( B12D(I), B12E(I), NU, WORK(IU1CS+I-1), $ WORK(IU1SN+I-1) ) END IF IF( .NOT. RESTART21 .AND. .NOT. RESTART22 ) THEN CALL DLARTGP( Y2, Y1, WORK(IU2SN+I-1), WORK(IU2CS+I-1), $ R ) ELSE IF( .NOT. RESTART21 .AND. RESTART22 ) THEN CALL DLARTGP( B21BULGE, B21D(I), WORK(IU2SN+I-1), $ WORK(IU2CS+I-1), R ) ELSE IF( RESTART21 .AND. .NOT. RESTART22 ) THEN CALL DLARTGP( B22BULGE, B22E(I-1), WORK(IU2SN+I-1), $ WORK(IU2CS+I-1), R ) ELSE IF( NU .LT. MU ) THEN CALL DLARTGS( B21E(I), B21E(I+1), NU, WORK(IU2CS+I-1), $ WORK(IU2SN+I-1) ) ELSE CALL DLARTGS( B22D(I), B22E(I), MU, WORK(IU2CS+I-1), $ WORK(IU2SN+I-1) ) END IF WORK(IU2CS+I-1) = -WORK(IU2CS+I-1) WORK(IU2SN+I-1) = -WORK(IU2SN+I-1) * TEMP = WORK(IU1CS+I-1)*B11E(I) + WORK(IU1SN+I-1)*B11D(I+1) B11D(I+1) = WORK(IU1CS+I-1)*B11D(I+1) - $ WORK(IU1SN+I-1)*B11E(I) B11E(I) = TEMP IF( I .LT. IMAX - 1 ) THEN B11BULGE = WORK(IU1SN+I-1)*B11E(I+1) B11E(I+1) = WORK(IU1CS+I-1)*B11E(I+1) END IF TEMP = WORK(IU2CS+I-1)*B21E(I) + WORK(IU2SN+I-1)*B21D(I+1) B21D(I+1) = WORK(IU2CS+I-1)*B21D(I+1) - $ WORK(IU2SN+I-1)*B21E(I) B21E(I) = TEMP IF( I .LT. IMAX - 1 ) THEN B21BULGE = WORK(IU2SN+I-1)*B21E(I+1) B21E(I+1) = WORK(IU2CS+I-1)*B21E(I+1) END IF TEMP = WORK(IU1CS+I-1)*B12D(I) + WORK(IU1SN+I-1)*B12E(I) B12E(I) = WORK(IU1CS+I-1)*B12E(I) - WORK(IU1SN+I-1)*B12D(I) B12D(I) = TEMP B12BULGE = WORK(IU1SN+I-1)*B12D(I+1) B12D(I+1) = WORK(IU1CS+I-1)*B12D(I+1) TEMP = WORK(IU2CS+I-1)*B22D(I) + WORK(IU2SN+I-1)*B22E(I) B22E(I) = WORK(IU2CS+I-1)*B22E(I) - WORK(IU2SN+I-1)*B22D(I) B22D(I) = TEMP B22BULGE = WORK(IU2SN+I-1)*B22D(I+1) B22D(I+1) = WORK(IU2CS+I-1)*B22D(I+1) * END DO * * Compute PHI(IMAX-1) * X1 = SIN(THETA(IMAX-1))*B11E(IMAX-1) + $ COS(THETA(IMAX-1))*B21E(IMAX-1) Y1 = SIN(THETA(IMAX-1))*B12D(IMAX-1) + $ COS(THETA(IMAX-1))*B22D(IMAX-1) Y2 = SIN(THETA(IMAX-1))*B12BULGE + COS(THETA(IMAX-1))*B22BULGE * PHI(IMAX-1) = ATAN2( ABS(X1), SQRT(Y1**2+Y2**2) ) * * Chase bulges from B12(IMAX-1,IMAX) and B22(IMAX-1,IMAX) * RESTART12 = B12D(IMAX-1)**2 + B12BULGE**2 .LE. THRESH**2 RESTART22 = B22D(IMAX-1)**2 + B22BULGE**2 .LE. THRESH**2 * IF( .NOT. RESTART12 .AND. .NOT. RESTART22 ) THEN CALL DLARTGP( Y2, Y1, WORK(IV2TSN+IMAX-1-1), $ WORK(IV2TCS+IMAX-1-1), R ) ELSE IF( .NOT. RESTART12 .AND. RESTART22 ) THEN CALL DLARTGP( B12BULGE, B12D(IMAX-1), WORK(IV2TSN+IMAX-1-1), $ WORK(IV2TCS+IMAX-1-1), R ) ELSE IF( RESTART12 .AND. .NOT. RESTART22 ) THEN CALL DLARTGP( B22BULGE, B22D(IMAX-1), WORK(IV2TSN+IMAX-1-1), $ WORK(IV2TCS+IMAX-1-1), R ) ELSE IF( NU .LT. MU ) THEN CALL DLARTGS( B12E(IMAX-1), B12D(IMAX), NU, $ WORK(IV2TCS+IMAX-1-1), WORK(IV2TSN+IMAX-1-1) ) ELSE CALL DLARTGS( B22E(IMAX-1), B22D(IMAX), MU, $ WORK(IV2TCS+IMAX-1-1), WORK(IV2TSN+IMAX-1-1) ) END IF * TEMP = WORK(IV2TCS+IMAX-1-1)*B12E(IMAX-1) + $ WORK(IV2TSN+IMAX-1-1)*B12D(IMAX) B12D(IMAX) = WORK(IV2TCS+IMAX-1-1)*B12D(IMAX) - $ WORK(IV2TSN+IMAX-1-1)*B12E(IMAX-1) B12E(IMAX-1) = TEMP TEMP = WORK(IV2TCS+IMAX-1-1)*B22E(IMAX-1) + $ WORK(IV2TSN+IMAX-1-1)*B22D(IMAX) B22D(IMAX) = WORK(IV2TCS+IMAX-1-1)*B22D(IMAX) - $ WORK(IV2TSN+IMAX-1-1)*B22E(IMAX-1) B22E(IMAX-1) = TEMP * * Update singular vectors * IF( WANTU1 ) THEN IF( COLMAJOR ) THEN CALL DLASR( 'R', 'V', 'F', P, IMAX-IMIN+1, $ WORK(IU1CS+IMIN-1), WORK(IU1SN+IMIN-1), $ U1(1,IMIN), LDU1 ) ELSE CALL DLASR( 'L', 'V', 'F', IMAX-IMIN+1, P, $ WORK(IU1CS+IMIN-1), WORK(IU1SN+IMIN-1), $ U1(IMIN,1), LDU1 ) END IF END IF IF( WANTU2 ) THEN IF( COLMAJOR ) THEN CALL DLASR( 'R', 'V', 'F', M-P, IMAX-IMIN+1, $ WORK(IU2CS+IMIN-1), WORK(IU2SN+IMIN-1), $ U2(1,IMIN), LDU2 ) ELSE CALL DLASR( 'L', 'V', 'F', IMAX-IMIN+1, M-P, $ WORK(IU2CS+IMIN-1), WORK(IU2SN+IMIN-1), $ U2(IMIN,1), LDU2 ) END IF END IF IF( WANTV1T ) THEN IF( COLMAJOR ) THEN CALL DLASR( 'L', 'V', 'F', IMAX-IMIN+1, Q, $ WORK(IV1TCS+IMIN-1), WORK(IV1TSN+IMIN-1), $ V1T(IMIN,1), LDV1T ) ELSE CALL DLASR( 'R', 'V', 'F', Q, IMAX-IMIN+1, $ WORK(IV1TCS+IMIN-1), WORK(IV1TSN+IMIN-1), $ V1T(1,IMIN), LDV1T ) END IF END IF IF( WANTV2T ) THEN IF( COLMAJOR ) THEN CALL DLASR( 'L', 'V', 'F', IMAX-IMIN+1, M-Q, $ WORK(IV2TCS+IMIN-1), WORK(IV2TSN+IMIN-1), $ V2T(IMIN,1), LDV2T ) ELSE CALL DLASR( 'R', 'V', 'F', M-Q, IMAX-IMIN+1, $ WORK(IV2TCS+IMIN-1), WORK(IV2TSN+IMIN-1), $ V2T(1,IMIN), LDV2T ) END IF END IF * * Fix signs on B11(IMAX-1,IMAX) and B21(IMAX-1,IMAX) * IF( B11E(IMAX-1)+B21E(IMAX-1) .GT. 0 ) THEN B11D(IMAX) = -B11D(IMAX) B21D(IMAX) = -B21D(IMAX) IF( WANTV1T ) THEN IF( COLMAJOR ) THEN CALL DSCAL( Q, NEGONE, V1T(IMAX,1), LDV1T ) ELSE CALL DSCAL( Q, NEGONE, V1T(1,IMAX), 1 ) END IF END IF END IF * * Compute THETA(IMAX) * X1 = COS(PHI(IMAX-1))*B11D(IMAX) + $ SIN(PHI(IMAX-1))*B12E(IMAX-1) Y1 = COS(PHI(IMAX-1))*B21D(IMAX) + $ SIN(PHI(IMAX-1))*B22E(IMAX-1) * THETA(IMAX) = ATAN2( ABS(Y1), ABS(X1) ) * * Fix signs on B11(IMAX,IMAX), B12(IMAX,IMAX-1), B21(IMAX,IMAX), * and B22(IMAX,IMAX-1) * IF( B11D(IMAX)+B12E(IMAX-1) .LT. 0 ) THEN B12D(IMAX) = -B12D(IMAX) IF( WANTU1 ) THEN IF( COLMAJOR ) THEN CALL DSCAL( P, NEGONE, U1(1,IMAX), 1 ) ELSE CALL DSCAL( P, NEGONE, U1(IMAX,1), LDU1 ) END IF END IF END IF IF( B21D(IMAX)+B22E(IMAX-1) .GT. 0 ) THEN B22D(IMAX) = -B22D(IMAX) IF( WANTU2 ) THEN IF( COLMAJOR ) THEN CALL DSCAL( M-P, NEGONE, U2(1,IMAX), 1 ) ELSE CALL DSCAL( M-P, NEGONE, U2(IMAX,1), LDU2 ) END IF END IF END IF * * Fix signs on B12(IMAX,IMAX) and B22(IMAX,IMAX) * IF( B12D(IMAX)+B22D(IMAX) .LT. 0 ) THEN IF( WANTV2T ) THEN IF( COLMAJOR ) THEN CALL DSCAL( M-Q, NEGONE, V2T(IMAX,1), LDV2T ) ELSE CALL DSCAL( M-Q, NEGONE, V2T(1,IMAX), 1 ) END IF END IF END IF * * Test for negligible sines or cosines * DO I = IMIN, IMAX IF( THETA(I) .LT. THRESH ) THEN THETA(I) = ZERO ELSE IF( THETA(I) .GT. PIOVER2-THRESH ) THEN THETA(I) = PIOVER2 END IF END DO DO I = IMIN, IMAX-1 IF( PHI(I) .LT. THRESH ) THEN PHI(I) = ZERO ELSE IF( PHI(I) .GT. PIOVER2-THRESH ) THEN PHI(I) = PIOVER2 END IF END DO * * Deflate * IF (IMAX .GT. 1) THEN DO WHILE( PHI(IMAX-1) .EQ. ZERO ) IMAX = IMAX - 1 IF (IMAX .LE. 1) EXIT END DO END IF IF( IMIN .GT. IMAX - 1 ) $ IMIN = IMAX - 1 IF (IMIN .GT. 1) THEN DO WHILE (PHI(IMIN-1) .NE. ZERO) IMIN = IMIN - 1 IF (IMIN .LE. 1) EXIT END DO END IF * * Repeat main iteration loop * END DO * * Postprocessing: order THETA from least to greatest * DO I = 1, Q * MINI = I THETAMIN = THETA(I) DO J = I+1, Q IF( THETA(J) .LT. THETAMIN ) THEN MINI = J THETAMIN = THETA(J) END IF END DO * IF( MINI .NE. I ) THEN THETA(MINI) = THETA(I) THETA(I) = THETAMIN IF( COLMAJOR ) THEN IF( WANTU1 ) $ CALL DSWAP( P, U1(1,I), 1, U1(1,MINI), 1 ) IF( WANTU2 ) $ CALL DSWAP( M-P, U2(1,I), 1, U2(1,MINI), 1 ) IF( WANTV1T ) $ CALL DSWAP( Q, V1T(I,1), LDV1T, V1T(MINI,1), LDV1T ) IF( WANTV2T ) $ CALL DSWAP( M-Q, V2T(I,1), LDV2T, V2T(MINI,1), $ LDV2T ) ELSE IF( WANTU1 ) $ CALL DSWAP( P, U1(I,1), LDU1, U1(MINI,1), LDU1 ) IF( WANTU2 ) $ CALL DSWAP( M-P, U2(I,1), LDU2, U2(MINI,1), LDU2 ) IF( WANTV1T ) $ CALL DSWAP( Q, V1T(1,I), 1, V1T(1,MINI), 1 ) IF( WANTV2T ) $ CALL DSWAP( M-Q, V2T(1,I), 1, V2T(1,MINI), 1 ) END IF END IF * END DO * RETURN * * End of DBBCSD * END *> \brief \b DBDSDC * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DBDSDC + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ, * WORK, IWORK, INFO ) * * .. 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( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': B is upper bidiagonal. *> = 'L': B is lower bidiagonal. *> \endverbatim *> *> \param[in] COMPQ *> \verbatim *> COMPQ is 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. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix B. N >= 0. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is 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. *> \endverbatim *> *> \param[in,out] E *> \verbatim *> E is 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. *> \endverbatim *> *> \param[out] U *> \verbatim *> U is 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. *> \endverbatim *> *> \param[in] LDU *> \verbatim *> LDU is INTEGER *> The leading dimension of the array U. LDU >= 1. *> If singular vectors are desired, then LDU >= max( 1, N ). *> \endverbatim *> *> \param[out] VT *> \verbatim *> VT is DOUBLE PRECISION array, dimension (LDVT,N) *> If COMPQ = 'I', then: *> On exit, if INFO = 0, VT**T contains the right singular *> vectors of the bidiagonal matrix. *> For other values of COMPQ, VT is not referenced. *> \endverbatim *> *> \param[in] LDVT *> \verbatim *> LDVT is INTEGER *> The leading dimension of the array VT. LDVT >= 1. *> If singular vectors are desired, then LDVT >= max( 1, N ). *> \endverbatim *> *> \param[out] Q *> \verbatim *> Q is 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. *> \endverbatim *> *> \param[out] IQ *> \verbatim *> IQ is 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. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is 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). *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (8*N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: The algorithm failed to compute a singular value. *> The update process of divide and conquer failed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup auxOTHERcomputational * *> \par Contributors: * ================== *> *> Ming Gu and Huan Ren, Computer Science Division, University of *> California at Berkeley, USA *> * ===================================================================== SUBROUTINE DBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ, $ WORK, IWORK, INFO ) * * -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. 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( * ) * .. * * ===================================================================== * 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 IF( ICOMPQ .EQ. 2 ) 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 * Ignore WSTART, instead using WORK( 1 ), since the two vectors * for CS and -SN above are added only if ICOMPQ == 2, * and adding them exceeds documented WORK size of 4*n. CALL DLASDQ( 'U', 0, N, 0, 0, 0, D, E, VT, LDVT, U, LDU, U, $ LDU, WORK( 1 ), 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 = (0.9D+0)*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 ) END IF IF( INFO.NE.0 ) THEN RETURN 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 *> \brief \b DBDSQR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DBDSQR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, * LDU, C, LDC, WORK, INFO ) * * .. 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( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': B is upper bidiagonal; *> = 'L': B is lower bidiagonal. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix B. N >= 0. *> \endverbatim *> *> \param[in] NCVT *> \verbatim *> NCVT is INTEGER *> The number of columns of the matrix VT. NCVT >= 0. *> \endverbatim *> *> \param[in] NRU *> \verbatim *> NRU is INTEGER *> The number of rows of the matrix U. NRU >= 0. *> \endverbatim *> *> \param[in] NCC *> \verbatim *> NCC is INTEGER *> The number of columns of the matrix C. NCC >= 0. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is 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. *> \endverbatim *> *> \param[in,out] E *> \verbatim *> E is 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. *> \endverbatim *> *> \param[in,out] VT *> \verbatim *> VT is 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. *> \endverbatim *> *> \param[in] LDVT *> \verbatim *> LDVT is INTEGER *> The leading dimension of the array VT. *> LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0. *> \endverbatim *> *> \param[in,out] U *> \verbatim *> U is 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. *> \endverbatim *> *> \param[in] LDU *> \verbatim *> LDU is INTEGER *> The leading dimension of the array U. LDU >= max(1,NRU). *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is 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. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. *> LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (4*N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: If INFO = -i, the i-th argument had an illegal value *> > 0: *> if NCVT = NRU = NCC = 0, *> = 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) *> else NCVT = NRU = NCC = 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. *> \endverbatim * *> \par Internal Parameters: * ========================= *> *> \verbatim *> 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. *> *> \endverbatim * *> \par Note: * =========== *> *> \verbatim *> Bug report from Cezary Dendek. *> On March 23rd 2017, the INTEGER variable MAXIT = MAXITR*N**2 is *> removed since it can overflow pretty easily (for N larger or equal *> than 18,919). We instead use MAXITDIVN = MAXITR*N. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, $ LDU, C, LDC, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. 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( * ) * .. * * ===================================================================== * * .. 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, ITERDIVN, J, LL, LLL, M, $ MAXITDIVN, 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 ) * * If INFO equals 2, dqds didn't finish, try to finish * IF( INFO .NE. 2 ) RETURN INFO = 0 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.) * MAXITDIVN = MAXITR*N ITERDIVN = 0 ITER = -1 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.GE.N ) THEN ITER = ITER - N ITERDIVN = ITERDIVN + 1 IF( ITERDIVN.GE.MAXITDIVN ) $ GO TO 200 END IF * * 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 *> \brief \b DDISNA * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DDISNA + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DDISNA( JOB, M, N, D, SEP, INFO ) * * .. Scalar Arguments .. * CHARACTER JOB * INTEGER INFO, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), SEP( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is 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. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> If JOB = 'L' or 'R', the number of columns of the matrix, *> in which case N >= 0. Ignored if JOB = 'E'. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is 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. *> \endverbatim *> *> \param[out] SEP *> \verbatim *> SEP is DOUBLE PRECISION array, dimension (M) if JOB = 'E' *> dimension (min(M,N)) if JOB = 'L' or 'R' *> The reciprocal condition numbers of the vectors. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE DDISNA( JOB, M, N, D, SEP, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER JOB INTEGER INFO, M, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), SEP( * ) * .. * * ===================================================================== * * .. 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 *> \brief \b DGBBRD * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGBBRD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, * LDQ, PT, LDPT, C, LDC, WORK, INFO ) * * .. 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( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGBBRD reduces a real general m-by-n band matrix A to upper *> bidiagonal form B by an orthogonal transformation: Q**T * A * P = B. *> *> The routine computes B, and optionally forms Q or P**T, or computes *> Q**T*C for a given matrix C. *> \endverbatim * * Arguments: * ========== * *> \param[in] VECT *> \verbatim *> VECT is CHARACTER*1 *> Specifies whether or not the matrices Q and P**T are to be *> formed. *> = 'N': do not form Q or P**T; *> = 'Q': form Q only; *> = 'P': form P**T only; *> = 'B': form both. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] NCC *> \verbatim *> NCC is INTEGER *> The number of columns of the matrix C. NCC >= 0. *> \endverbatim *> *> \param[in] KL *> \verbatim *> KL is INTEGER *> The number of subdiagonals of the matrix A. KL >= 0. *> \endverbatim *> *> \param[in] KU *> \verbatim *> KU is INTEGER *> The number of superdiagonals of the matrix A. KU >= 0. *> \endverbatim *> *> \param[in,out] AB *> \verbatim *> AB is 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. *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array A. LDAB >= KL+KU+1. *> \endverbatim *> *> \param[out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (min(M,N)) *> The diagonal elements of the bidiagonal matrix B. *> \endverbatim *> *> \param[out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (min(M,N)-1) *> The superdiagonal elements of the bidiagonal matrix B. *> \endverbatim *> *> \param[out] Q *> \verbatim *> Q is 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. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. *> LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise. *> \endverbatim *> *> \param[out] PT *> \verbatim *> PT is 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. *> \endverbatim *> *> \param[in] LDPT *> \verbatim *> LDPT is INTEGER *> The leading dimension of the array PT. *> LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise. *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (LDC,NCC) *> On entry, an m-by-ncc matrix C. *> On exit, C is overwritten by Q**T*C. *> C is not referenced if NCC = 0. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. *> LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (2*max(M,N)) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGBcomputational * * ===================================================================== SUBROUTINE DGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, $ LDQ, PT, LDPT, C, LDC, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER 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( * ) * .. * * ===================================================================== * * .. 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**T 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**T * 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 *> \brief \b DGBCON * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGBCON + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, * WORK, IWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER NORM * INTEGER INFO, KL, KU, LDAB, N * DOUBLE PRECISION ANORM, RCOND * .. * .. Array Arguments .. * INTEGER IPIV( * ), IWORK( * ) * DOUBLE PRECISION AB( LDAB, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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)) ). *> \endverbatim * * Arguments: * ========== * *> \param[in] NORM *> \verbatim *> NORM is 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. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] KL *> \verbatim *> KL is INTEGER *> The number of subdiagonals within the band of A. KL >= 0. *> \endverbatim *> *> \param[in] KU *> \verbatim *> KU is INTEGER *> The number of superdiagonals within the band of A. KU >= 0. *> \endverbatim *> *> \param[in] AB *> \verbatim *> AB is 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. *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array AB. LDAB >= 2*KL+KU+1. *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N) *> The pivot indices; for 1 <= i <= N, row i of the matrix was *> interchanged with row IPIV(i). *> \endverbatim *> *> \param[in] ANORM *> \verbatim *> ANORM is 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. *> \endverbatim *> *> \param[out] RCOND *> \verbatim *> RCOND is DOUBLE PRECISION *> The reciprocal of the condition number of the matrix A, *> computed as RCOND = 1/(norm(A) * norm(inv(A))). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGBcomputational * * ===================================================================== SUBROUTINE DGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, $ WORK, IWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER NORM INTEGER INFO, KL, KU, LDAB, N DOUBLE PRECISION ANORM, RCOND * .. * .. Array Arguments .. INTEGER IPIV( * ), IWORK( * ) DOUBLE PRECISION AB( LDAB, * ), WORK( * ) * .. * * ===================================================================== * * .. 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**T). * CALL DLATBS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, $ KL+KU, AB, LDAB, WORK, SCALE, WORK( 2*N+1 ), $ INFO ) * * Multiply by inv(L**T). * 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 *> \brief \b DGBEQU * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGBEQU + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, * AMAX, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, KL, KU, LDAB, M, N * DOUBLE PRECISION AMAX, COLCND, ROWCND * .. * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ), C( * ), R( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] KL *> \verbatim *> KL is INTEGER *> The number of subdiagonals within the band of A. KL >= 0. *> \endverbatim *> *> \param[in] KU *> \verbatim *> KU is INTEGER *> The number of superdiagonals within the band of A. KU >= 0. *> \endverbatim *> *> \param[in] AB *> \verbatim *> AB is 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). *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array AB. LDAB >= KL+KU+1. *> \endverbatim *> *> \param[out] R *> \verbatim *> R is DOUBLE PRECISION array, dimension (M) *> If INFO = 0, or INFO > M, R contains the row scale factors *> for A. *> \endverbatim *> *> \param[out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (N) *> If INFO = 0, C contains the column scale factors for A. *> \endverbatim *> *> \param[out] ROWCND *> \verbatim *> ROWCND is 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. *> \endverbatim *> *> \param[out] COLCND *> \verbatim *> COLCND is 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. *> \endverbatim *> *> \param[out] AMAX *> \verbatim *> AMAX is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, and i is *> <= M: the i-th row of A is exactly zero *> > M: the (i-M)-th column of A is exactly zero *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGBcomputational * * ===================================================================== SUBROUTINE DGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, $ AMAX, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N DOUBLE PRECISION AMAX, COLCND, ROWCND * .. * .. Array Arguments .. DOUBLE PRECISION AB( LDAB, * ), C( * ), R( * ) * .. * * ===================================================================== * * .. 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 *> \brief \b DGBEQUB * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGBEQUB + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, * AMAX, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, KL, KU, LDAB, M, N * DOUBLE PRECISION AMAX, COLCND, ROWCND * .. * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ), C( * ), R( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGBEQUB 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 an absolute value of at most *> the radix. *> *> R(i) and C(j) are restricted to be a power of the radix 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. *> *> This routine differs from DGEEQU by restricting the scaling factors *> to a power of the radix. Barring over- and underflow, scaling by *> these factors introduces no additional rounding errors. However, the *> scaled entries' magnitudes are no longer approximately 1 but lie *> between sqrt(radix) and 1/sqrt(radix). *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] KL *> \verbatim *> KL is INTEGER *> The number of subdiagonals within the band of A. KL >= 0. *> \endverbatim *> *> \param[in] KU *> \verbatim *> KU is INTEGER *> The number of superdiagonals within the band of A. KU >= 0. *> \endverbatim *> *> \param[in] AB *> \verbatim *> AB is DOUBLE PRECISION array, dimension (LDAB,N) *> On entry, the matrix A in band storage, 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) *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array A. LDAB >= max(1,M). *> \endverbatim *> *> \param[out] R *> \verbatim *> R is DOUBLE PRECISION array, dimension (M) *> If INFO = 0 or INFO > M, R contains the row scale factors *> for A. *> \endverbatim *> *> \param[out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (N) *> If INFO = 0, C contains the column scale factors for A. *> \endverbatim *> *> \param[out] ROWCND *> \verbatim *> ROWCND is 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. *> \endverbatim *> *> \param[out] COLCND *> \verbatim *> COLCND is 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. *> \endverbatim *> *> \param[out] AMAX *> \verbatim *> AMAX is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, and i is *> <= M: the i-th row of A is exactly zero *> > M: the (i-M)-th column of A is exactly zero *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGBcomputational * * ===================================================================== SUBROUTINE DGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, $ AMAX, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N DOUBLE PRECISION AMAX, COLCND, ROWCND * .. * .. Array Arguments .. DOUBLE PRECISION AB( LDAB, * ), C( * ), R( * ) * .. * * ===================================================================== * * .. 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, RADIX, LOGRDX * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, LOG * .. * .. 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( 'DGBEQUB', -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. Assume SMLNUM is a power of the radix. * SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM RADIX = DLAMCH( 'B' ) LOGRDX = LOG(RADIX) * * 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 DO I = 1, M IF( R( I ).GT.ZERO ) THEN R( I ) = RADIX**INT( LOG( R( I ) ) / LOGRDX ) END IF END DO * * 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 = MAX( J-KU, 1 ), MIN( J+KL, M ) C( J ) = MAX( C( J ), ABS( AB( KD+I-J, J ) )*R( I ) ) 80 CONTINUE IF( C( J ).GT.ZERO ) THEN C( J ) = RADIX**INT( LOG( C( J ) ) / LOGRDX ) END IF 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 DGBEQUB * END *> \brief \b DGBRFS * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGBRFS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, * IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, * INFO ) * * .. 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, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANS *> \verbatim *> TRANS is 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) *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] KL *> \verbatim *> KL is INTEGER *> The number of subdiagonals within the band of A. KL >= 0. *> \endverbatim *> *> \param[in] KU *> \verbatim *> KU is INTEGER *> The number of superdiagonals within the band of A. KU >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrices B and X. NRHS >= 0. *> \endverbatim *> *> \param[in] AB *> \verbatim *> AB is 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). *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array AB. LDAB >= KL+KU+1. *> \endverbatim *> *> \param[in] AFB *> \verbatim *> AFB is 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. *> \endverbatim *> *> \param[in] LDAFB *> \verbatim *> LDAFB is INTEGER *> The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N) *> The pivot indices from DGBTRF; for 1<=i<=N, row i of the *> matrix was interchanged with row IPIV(i). *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> The right hand side matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,NRHS) *> On entry, the solution matrix X, as computed by DGBTRS. *> On exit, the improved solution matrix X. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the array X. LDX >= max(1,N). *> \endverbatim *> *> \param[out] FERR *> \verbatim *> FERR is 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. *> \endverbatim *> *> \param[out] BERR *> \verbatim *> BERR is 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). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * *> \par Internal Parameters: * ========================= *> *> \verbatim *> ITMAX is the maximum number of steps of iterative refinement. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGBcomputational * * ===================================================================== SUBROUTINE DGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, $ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, $ INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER 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, * ) * .. * * ===================================================================== * * .. 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 *> \brief DGBSV computes the solution to system of linear equations A * X = B for GB matrices (simple driver) * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGBSV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS * .. * .. Array Arguments .. * INTEGER IPIV( * ) * DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGBSV computes the solution to a real system of linear equations *> A * X = B, where A is a band matrix of order N with KL subdiagonals *> and KU superdiagonals, and X and B are N-by-NRHS matrices. *> *> The LU decomposition with partial pivoting and row interchanges is *> used to factor A as A = L * U, where L is a product of permutation *> and unit lower triangular matrices with KL subdiagonals, and U is *> upper triangular with KL+KU superdiagonals. The factored form of A *> is then used to solve the system of equations A * X = B. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The number of linear equations, i.e., the order of the *> matrix A. N >= 0. *> \endverbatim *> *> \param[in] KL *> \verbatim *> KL is INTEGER *> The number of subdiagonals within the band of A. KL >= 0. *> \endverbatim *> *> \param[in] KU *> \verbatim *> KU is INTEGER *> The number of superdiagonals within the band of A. KU >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrix B. NRHS >= 0. *> \endverbatim *> *> \param[in,out] AB *> \verbatim *> AB is 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(N,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. *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array AB. LDAB >= 2*KL+KU+1. *> \endverbatim *> *> \param[out] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N) *> The pivot indices that define the permutation matrix P; *> row i of the matrix was interchanged with row IPIV(i). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> On entry, the N-by-NRHS right hand side matrix B. *> On exit, if INFO = 0, the N-by-NRHS solution matrix X. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, U(i,i) is exactly zero. The factorization *> has been completed, but the factor U is exactly *> singular, and the solution has not been computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGBsolve * *> \par Further Details: * ===================== *> *> \verbatim *> *> 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. *> \endverbatim *> * ===================================================================== SUBROUTINE DGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) * .. * * ===================================================================== * * .. External Subroutines .. EXTERNAL DGBTRF, DGBTRS, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( KL.LT.0 ) THEN INFO = -2 ELSE IF( KU.LT.0 ) THEN INFO = -3 ELSE IF( NRHS.LT.0 ) THEN INFO = -4 ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN INFO = -9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGBSV ', -INFO ) RETURN END IF * * Compute the LU factorization of the band matrix A. * CALL DGBTRF( N, N, KL, KU, AB, LDAB, IPIV, INFO ) IF( INFO.EQ.0 ) THEN * * Solve the system A*X = B, overwriting B with X. * CALL DGBTRS( 'No transpose', N, KL, KU, NRHS, AB, LDAB, IPIV, $ B, LDB, INFO ) END IF RETURN * * End of DGBSV * END *> \brief DGBSVX computes the solution to system of linear equations A * X = B for GB matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGBSVX + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, * LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, * RCOND, FERR, BERR, WORK, IWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER EQUED, FACT, TRANS * INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS * DOUBLE PRECISION RCOND * .. * .. Array Arguments .. * INTEGER IPIV( * ), IWORK( * ) * DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), * $ BERR( * ), C( * ), FERR( * ), R( * ), * $ WORK( * ), X( LDX, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGBSVX uses the LU factorization to compute the solution to a real *> system of linear equations A * X = B, A**T * X = B, or A**H * X = B, *> where A is a band matrix of order N with KL subdiagonals and KU *> superdiagonals, and X and B are N-by-NRHS matrices. *> *> Error bounds on the solution and a condition estimate are also *> provided. *> \endverbatim * *> \par Description: * ================= *> *> \verbatim *> *> The following steps are performed by this subroutine: *> *> 1. If FACT = 'E', real scaling factors are computed to equilibrate *> the system: *> TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B *> TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B *> TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B *> Whether or not the system will be equilibrated depends on the *> scaling of the matrix A, but if equilibration is used, A is *> overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') *> or diag(C)*B (if TRANS = 'T' or 'C'). *> *> 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the *> matrix A (after equilibration if FACT = 'E') as *> A = L * U, *> where L is a product of permutation and unit lower triangular *> matrices with KL subdiagonals, and U is upper triangular with *> KL+KU superdiagonals. *> *> 3. 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. *> *> 4. The system of equations is solved for X using the factored form *> of A. *> *> 5. Iterative refinement is applied to improve the computed solution *> matrix and calculate error bounds and backward error estimates *> for it. *> *> 6. If equilibration was used, the matrix X is premultiplied by *> diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so *> that it solves the original system before equilibration. *> \endverbatim * * Arguments: * ========== * *> \param[in] FACT *> \verbatim *> FACT is CHARACTER*1 *> Specifies whether or not the factored form of the matrix A is *> supplied on entry, and if not, whether the matrix A should be *> equilibrated before it is factored. *> = 'F': On entry, AFB and IPIV contain the factored form of *> A. If EQUED is not 'N', the matrix A has been *> equilibrated with scaling factors given by R and C. *> AB, AFB, and IPIV are not modified. *> = 'N': The matrix A will be copied to AFB and factored. *> = 'E': The matrix A will be equilibrated if necessary, then *> copied to AFB and factored. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is 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 (Transpose) *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of linear equations, i.e., the order of the *> matrix A. N >= 0. *> \endverbatim *> *> \param[in] KL *> \verbatim *> KL is INTEGER *> The number of subdiagonals within the band of A. KL >= 0. *> \endverbatim *> *> \param[in] KU *> \verbatim *> KU is INTEGER *> The number of superdiagonals within the band of A. KU >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrices B and X. NRHS >= 0. *> \endverbatim *> *> \param[in,out] AB *> \verbatim *> AB is DOUBLE PRECISION array, dimension (LDAB,N) *> On entry, the matrix A in band storage, 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) *> *> If FACT = 'F' and EQUED is not 'N', then A must have been *> equilibrated by the scaling factors in R and/or C. AB is not *> modified if FACT = 'F' or 'N', or if FACT = 'E' and *> EQUED = 'N' on exit. *> *> On exit, if EQUED .ne. 'N', A is scaled as follows: *> EQUED = 'R': A := diag(R) * A *> EQUED = 'C': A := A * diag(C) *> EQUED = 'B': A := diag(R) * A * diag(C). *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array AB. LDAB >= KL+KU+1. *> \endverbatim *> *> \param[in,out] AFB *> \verbatim *> AFB is DOUBLE PRECISION array, dimension (LDAFB,N) *> If FACT = 'F', then AFB is an input argument and on entry *> contains 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. If EQUED .ne. 'N', then AFB is *> the factored form of the equilibrated matrix A. *> *> If FACT = 'N', then AFB is an output argument and on exit *> returns details of the LU factorization of A. *> *> If FACT = 'E', then AFB is an output argument and on exit *> returns details of the LU factorization of the equilibrated *> matrix A (see the description of AB for the form of the *> equilibrated matrix). *> \endverbatim *> *> \param[in] LDAFB *> \verbatim *> LDAFB is INTEGER *> The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. *> \endverbatim *> *> \param[in,out] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N) *> If FACT = 'F', then IPIV is an input argument and on entry *> contains the pivot indices from the factorization A = L*U *> as computed by DGBTRF; row i of the matrix was interchanged *> with row IPIV(i). *> *> If FACT = 'N', then IPIV is an output argument and on exit *> contains the pivot indices from the factorization A = L*U *> of the original matrix A. *> *> If FACT = 'E', then IPIV is an output argument and on exit *> contains the pivot indices from the factorization A = L*U *> of the equilibrated matrix A. *> \endverbatim *> *> \param[in,out] EQUED *> \verbatim *> EQUED is CHARACTER*1 *> Specifies the form of equilibration that was done. *> = 'N': No equilibration (always true if FACT = 'N'). *> = 'R': Row equilibration, i.e., A has been premultiplied by *> diag(R). *> = 'C': Column equilibration, i.e., A has been postmultiplied *> by diag(C). *> = 'B': Both row and column equilibration, i.e., A has been *> replaced by diag(R) * A * diag(C). *> EQUED is an input argument if FACT = 'F'; otherwise, it is an *> output argument. *> \endverbatim *> *> \param[in,out] R *> \verbatim *> R is DOUBLE PRECISION array, dimension (N) *> The row scale factors for A. If EQUED = 'R' or 'B', A is *> multiplied on the left by diag(R); if EQUED = 'N' or 'C', R *> is not accessed. R is an input argument if FACT = 'F'; *> otherwise, R is an output argument. If FACT = 'F' and *> EQUED = 'R' or 'B', each element of R must be positive. *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (N) *> The column scale factors for A. If EQUED = 'C' or 'B', A is *> multiplied on the right by diag(C); if EQUED = 'N' or 'R', C *> is not accessed. C is an input argument if FACT = 'F'; *> otherwise, C is an output argument. If FACT = 'F' and *> EQUED = 'C' or 'B', each element of C must be positive. *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> On entry, the right hand side matrix B. *> On exit, *> if EQUED = 'N', B is not modified; *> if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by *> diag(R)*B; *> if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is *> overwritten by diag(C)*B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,NRHS) *> If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X *> to the original system of equations. Note that A and B are *> modified on exit if EQUED .ne. 'N', and the solution to the *> equilibrated system is inv(diag(C))*X if TRANS = 'N' and *> EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C' *> and EQUED = 'R' or 'B'. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the array X. LDX >= max(1,N). *> \endverbatim *> *> \param[out] RCOND *> \verbatim *> RCOND is DOUBLE PRECISION *> The estimate of the reciprocal condition number of the matrix *> A after equilibration (if done). 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. *> \endverbatim *> *> \param[out] FERR *> \verbatim *> FERR is 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. *> \endverbatim *> *> \param[out] BERR *> \verbatim *> BERR is 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). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*N) *> On exit, WORK(1) contains the reciprocal pivot growth *> factor norm(A)/norm(U). The "max absolute element" norm is *> used. If WORK(1) is much less than 1, then the stability *> of the LU factorization of the (equilibrated) matrix A *> could be poor. This also means that the solution X, condition *> estimator RCOND, and forward error bound FERR could be *> unreliable. If factorization fails with 0 WORK(1) contains the reciprocal pivot growth factor for the *> leading INFO columns of A. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, and i is *> <= N: U(i,i) is exactly zero. The factorization *> has been completed, 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. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date April 2012 * *> \ingroup doubleGBsolve * * ===================================================================== SUBROUTINE DGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, $ LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, $ RCOND, FERR, BERR, WORK, IWORK, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * April 2012 * * .. Scalar Arguments .. CHARACTER EQUED, FACT, TRANS INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS DOUBLE PRECISION RCOND * .. * .. Array Arguments .. INTEGER IPIV( * ), IWORK( * ) DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), $ BERR( * ), C( * ), FERR( * ), R( * ), $ WORK( * ), X( LDX, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU CHARACTER NORM INTEGER I, INFEQU, J, J1, J2 DOUBLE PRECISION AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN, $ ROWCND, RPVGRW, SMLNUM * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGB, DLANTB EXTERNAL LSAME, DLAMCH, DLANGB, DLANTB * .. * .. External Subroutines .. EXTERNAL DCOPY, DGBCON, DGBEQU, DGBRFS, DGBTRF, DGBTRS, $ DLACPY, DLAQGB, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. Executable Statements .. * INFO = 0 NOFACT = LSAME( FACT, 'N' ) EQUIL = LSAME( FACT, 'E' ) NOTRAN = LSAME( TRANS, 'N' ) IF( NOFACT .OR. EQUIL ) THEN EQUED = 'N' ROWEQU = .FALSE. COLEQU = .FALSE. ELSE ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) SMLNUM = DLAMCH( 'Safe minimum' ) BIGNUM = ONE / SMLNUM END IF * * Test the input parameters. * IF( .NOT.NOFACT .AND. .NOT.EQUIL .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( KL.LT.0 ) THEN INFO = -4 ELSE IF( KU.LT.0 ) THEN INFO = -5 ELSE IF( NRHS.LT.0 ) THEN INFO = -6 ELSE IF( LDAB.LT.KL+KU+1 ) THEN INFO = -8 ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN INFO = -10 ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. $ ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN INFO = -12 ELSE IF( ROWEQU ) THEN RCMIN = BIGNUM RCMAX = ZERO DO 10 J = 1, N RCMIN = MIN( RCMIN, R( J ) ) RCMAX = MAX( RCMAX, R( J ) ) 10 CONTINUE IF( RCMIN.LE.ZERO ) THEN INFO = -13 ELSE IF( N.GT.0 ) THEN ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) ELSE ROWCND = ONE END IF END IF IF( COLEQU .AND. INFO.EQ.0 ) THEN RCMIN = BIGNUM RCMAX = ZERO DO 20 J = 1, N RCMIN = MIN( RCMIN, C( J ) ) RCMAX = MAX( RCMAX, C( J ) ) 20 CONTINUE IF( RCMIN.LE.ZERO ) THEN INFO = -14 ELSE IF( N.GT.0 ) THEN COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) ELSE COLCND = ONE END IF END IF IF( INFO.EQ.0 ) THEN IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -16 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -18 END IF END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGBSVX', -INFO ) RETURN END IF * IF( EQUIL ) THEN * * Compute row and column scalings to equilibrate the matrix A. * CALL DGBEQU( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, $ AMAX, INFEQU ) IF( INFEQU.EQ.0 ) THEN * * Equilibrate the matrix. * CALL DLAQGB( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, $ AMAX, EQUED ) ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) END IF END IF * * Scale the right hand side. * IF( NOTRAN ) THEN IF( ROWEQU ) THEN DO 40 J = 1, NRHS DO 30 I = 1, N B( I, J ) = R( I )*B( I, J ) 30 CONTINUE 40 CONTINUE END IF ELSE IF( COLEQU ) THEN DO 60 J = 1, NRHS DO 50 I = 1, N B( I, J ) = C( I )*B( I, J ) 50 CONTINUE 60 CONTINUE END IF * IF( NOFACT .OR. EQUIL ) THEN * * Compute the LU factorization of the band matrix A. * DO 70 J = 1, N J1 = MAX( J-KU, 1 ) J2 = MIN( J+KL, N ) CALL DCOPY( J2-J1+1, AB( KU+1-J+J1, J ), 1, $ AFB( KL+KU+1-J+J1, J ), 1 ) 70 CONTINUE * CALL DGBTRF( N, N, KL, KU, AFB, LDAFB, IPIV, INFO ) * * Return if INFO is non-zero. * IF( INFO.GT.0 ) THEN * * Compute the reciprocal pivot growth factor of the * leading rank-deficient INFO columns of A. * ANORM = ZERO DO 90 J = 1, INFO DO 80 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 ) ANORM = MAX( ANORM, ABS( AB( I, J ) ) ) 80 CONTINUE 90 CONTINUE RPVGRW = DLANTB( 'M', 'U', 'N', INFO, MIN( INFO-1, KL+KU ), $ AFB( MAX( 1, KL+KU+2-INFO ), 1 ), LDAFB, $ WORK ) IF( RPVGRW.EQ.ZERO ) THEN RPVGRW = ONE ELSE RPVGRW = ANORM / RPVGRW END IF WORK( 1 ) = RPVGRW RCOND = ZERO RETURN END IF END IF * * Compute the norm of the matrix A and the * reciprocal pivot growth factor RPVGRW. * IF( NOTRAN ) THEN NORM = '1' ELSE NORM = 'I' END IF ANORM = DLANGB( NORM, N, KL, KU, AB, LDAB, WORK ) RPVGRW = DLANTB( 'M', 'U', 'N', N, KL+KU, AFB, LDAFB, WORK ) IF( RPVGRW.EQ.ZERO ) THEN RPVGRW = ONE ELSE RPVGRW = DLANGB( 'M', N, KL, KU, AB, LDAB, WORK ) / RPVGRW END IF * * Compute the reciprocal of the condition number of A. * CALL DGBCON( NORM, N, KL, KU, AFB, LDAFB, IPIV, ANORM, RCOND, $ WORK, IWORK, INFO ) * * Compute the solution matrix X. * CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) CALL DGBTRS( TRANS, N, KL, KU, NRHS, AFB, LDAFB, IPIV, X, LDX, $ INFO ) * * Use iterative refinement to improve the computed solution and * compute error bounds and backward error estimates for it. * CALL DGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, $ B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO ) * * Transform the solution matrix X to a solution of the original * system. * IF( NOTRAN ) THEN IF( COLEQU ) THEN DO 110 J = 1, NRHS DO 100 I = 1, N X( I, J ) = C( I )*X( I, J ) 100 CONTINUE 110 CONTINUE DO 120 J = 1, NRHS FERR( J ) = FERR( J ) / COLCND 120 CONTINUE END IF ELSE IF( ROWEQU ) THEN DO 140 J = 1, NRHS DO 130 I = 1, N X( I, J ) = R( I )*X( I, J ) 130 CONTINUE 140 CONTINUE DO 150 J = 1, NRHS FERR( J ) = FERR( J ) / ROWCND 150 CONTINUE END IF * * Set INFO = N+1 if the matrix is singular to working precision. * IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) $ INFO = N + 1 * WORK( 1 ) = RPVGRW RETURN * * End of DGBSVX * END *> \brief \b DGBTF2 computes the LU factorization of a general band matrix using the unblocked version of the algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGBTF2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, KL, KU, LDAB, M, N * .. * .. Array Arguments .. * INTEGER IPIV( * ) * DOUBLE PRECISION AB( LDAB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] KL *> \verbatim *> KL is INTEGER *> The number of subdiagonals within the band of A. KL >= 0. *> \endverbatim *> *> \param[in] KU *> \verbatim *> KU is INTEGER *> The number of superdiagonals within the band of A. KU >= 0. *> \endverbatim *> *> \param[in,out] AB *> \verbatim *> AB is 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. *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array AB. LDAB >= 2*KL+KU+1. *> \endverbatim *> *> \param[out] IPIV *> \verbatim *> IPIV is 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). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = +i, 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. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGBcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> 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. *> \endverbatim *> * ===================================================================== SUBROUTINE DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION AB( LDAB, * ) * .. * * ===================================================================== * * .. 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 *> \brief \b DGBTRF * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGBTRF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, KL, KU, LDAB, M, N * .. * .. Array Arguments .. * INTEGER IPIV( * ) * DOUBLE PRECISION AB( LDAB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] KL *> \verbatim *> KL is INTEGER *> The number of subdiagonals within the band of A. KL >= 0. *> \endverbatim *> *> \param[in] KU *> \verbatim *> KU is INTEGER *> The number of superdiagonals within the band of A. KU >= 0. *> \endverbatim *> *> \param[in,out] AB *> \verbatim *> AB is 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. *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array AB. LDAB >= 2*KL+KU+1. *> \endverbatim *> *> \param[out] IPIV *> \verbatim *> IPIV is 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). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = +i, 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. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGBcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> 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. *> \endverbatim *> * ===================================================================== SUBROUTINE DGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION AB( LDAB, * ) * .. * * ===================================================================== * * .. 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 *> \brief \b DGBTRS * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGBTRS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, * INFO ) * * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS * .. * .. Array Arguments .. * INTEGER IPIV( * ) * DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGBTRS solves a system of linear equations *> A * X = B or A**T * X = B *> with a general band matrix A using the LU factorization computed *> by DGBTRF. *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> Specifies the form of the system of equations. *> = 'N': A * X = B (No transpose) *> = 'T': A**T* X = B (Transpose) *> = 'C': A**T* X = B (Conjugate transpose = Transpose) *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] KL *> \verbatim *> KL is INTEGER *> The number of subdiagonals within the band of A. KL >= 0. *> \endverbatim *> *> \param[in] KU *> \verbatim *> KU is INTEGER *> The number of superdiagonals within the band of A. KU >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrix B. NRHS >= 0. *> \endverbatim *> *> \param[in] AB *> \verbatim *> AB is 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. *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array AB. LDAB >= 2*KL+KU+1. *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N) *> The pivot indices; for 1 <= i <= N, row i of the matrix was *> interchanged with row IPIV(i). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> On entry, the right hand side matrix B. *> On exit, the solution matrix X. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGBcomputational * * ===================================================================== SUBROUTINE DGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, $ INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER TRANS INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) * .. * * ===================================================================== * * .. 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**T*X = B. * DO 30 I = 1, NRHS * * Solve U**T*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**T*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 *> \brief \b DGEBAK * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEBAK + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, * INFO ) * * .. Scalar Arguments .. * CHARACTER JOB, SIDE * INTEGER IHI, ILO, INFO, LDV, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION SCALE( * ), V( LDV, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is 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. *> \endverbatim *> *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'R': V contains right eigenvectors; *> = 'L': V contains left eigenvectors. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of rows of the matrix V. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> The integers ILO and IHI determined by DGEBAL. *> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. *> \endverbatim *> *> \param[in] SCALE *> \verbatim *> SCALE is DOUBLE PRECISION array, dimension (N) *> Details of the permutation and scaling factors, as returned *> by DGEBAL. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of columns of the matrix V. M >= 0. *> \endverbatim *> *> \param[in,out] V *> \verbatim *> V is 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. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the array V. LDV >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEcomputational * * ===================================================================== SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, $ INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER JOB, SIDE INTEGER IHI, ILO, INFO, LDV, M, N * .. * .. Array Arguments .. DOUBLE PRECISION SCALE( * ), V( LDV, * ) * .. * * ===================================================================== * * .. 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 *> \brief \b DGEBAL * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEBAL + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) * * .. Scalar Arguments .. * CHARACTER JOB * INTEGER IHI, ILO, INFO, LDA, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), SCALE( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is 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. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is 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. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> \param[out] IHI *> \verbatim *> IHI is 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. *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> 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 *> \endverbatim *> * ===================================================================== SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) * * -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. CHARACTER JOB INTEGER IHI, ILO, INFO, LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), SCALE( * ) * .. * * ===================================================================== * * .. 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 DISNAN, LSAME INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DNRM2 EXTERNAL DISNAN, LSAME, IDAMAX, DLAMCH, DNRM2 * .. * .. External Subroutines .. EXTERNAL DSCAL, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * 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 = DNRM2( L-K+1, A( K, I ), 1 ) R = DNRM2( L-K+1, A( I, K ), LDA ) 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 IF( DISNAN( C+F+CA+R+G+RA ) ) THEN * * Exit if NaN to avoid infinite loop * INFO = -3 CALL XERBLA( 'DGEBAL', -INFO ) RETURN END IF 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 *> \brief \b DGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEBD2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), * $ TAUQ( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGEBD2 reduces a real general 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows in the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns in the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is 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. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (min(M,N)) *> The diagonal elements of the bidiagonal matrix B: *> D(i) = A(i,i). *> \endverbatim *> *> \param[out] E *> \verbatim *> E is 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. *> \endverbatim *> *> \param[out] TAUQ *> \verbatim *> TAUQ is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors which *> represent the orthogonal matrix Q. See Further Details. *> \endverbatim *> *> \param[out] TAUP *> \verbatim *> TAUP is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors which *> represent the orthogonal matrix P. See Further Details. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (max(M,N)) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> 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**T and G(i) = I - taup * u * u**T *> *> 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**T and G(i) = I - taup * u * u**T *> *> 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). *> \endverbatim *> * ===================================================================== SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), $ TAUQ( * ), WORK( * ) * .. * * ===================================================================== * * .. 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 *> \brief \b DGEBRD * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEBRD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, * INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), * $ TAUQ( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows in the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns in the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is 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. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (min(M,N)) *> The diagonal elements of the bidiagonal matrix B: *> D(i) = A(i,i). *> \endverbatim *> *> \param[out] E *> \verbatim *> E is 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. *> \endverbatim *> *> \param[out] TAUQ *> \verbatim *> TAUQ is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors which *> represent the orthogonal matrix Q. See Further Details. *> \endverbatim *> *> \param[out] TAUP *> \verbatim *> TAUP is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors which *> represent the orthogonal matrix P. See Further Details. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date November 2017 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> 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**T and G(i) = I - taup * u * u**T *> *> 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**T and G(i) = I - taup * u * u**T *> *> 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). *> \endverbatim *> * ===================================================================== SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, $ INFO ) * * -- LAPACK computational routine (version 3.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), $ TAUQ( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB, $ NBMIN, NX, 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**T - X*U**T * 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 *> \brief \b DGECON * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGECON + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, * INFO ) * * .. Scalar Arguments .. * CHARACTER NORM * INTEGER INFO, LDA, N * DOUBLE PRECISION ANORM, RCOND * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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)) ). *> \endverbatim * * Arguments: * ========== * *> \param[in] NORM *> \verbatim *> NORM is 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. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The factors L and U from the factorization A = P*L*U *> as computed by DGETRF. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in] ANORM *> \verbatim *> ANORM is 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. *> \endverbatim *> *> \param[out] RCOND *> \verbatim *> RCOND is DOUBLE PRECISION *> The reciprocal of the condition number of the matrix A, *> computed as RCOND = 1/(norm(A) * norm(inv(A))). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (4*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEcomputational * * ===================================================================== SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, $ INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER NORM INTEGER INFO, LDA, N DOUBLE PRECISION ANORM, RCOND * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * ===================================================================== * * .. 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**T). * CALL DLATRS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, A, $ LDA, WORK, SU, WORK( 3*N+1 ), INFO ) * * Multiply by inv(L**T). * 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 *> \brief \b DGEEQU * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEEQU + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, * INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * DOUBLE PRECISION AMAX, COLCND, ROWCND * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( * ), R( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The M-by-N matrix whose equilibration factors are *> to be computed. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] R *> \verbatim *> R is DOUBLE PRECISION array, dimension (M) *> If INFO = 0 or INFO > M, R contains the row scale factors *> for A. *> \endverbatim *> *> \param[out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (N) *> If INFO = 0, C contains the column scale factors for A. *> \endverbatim *> *> \param[out] ROWCND *> \verbatim *> ROWCND is 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. *> \endverbatim *> *> \param[out] COLCND *> \verbatim *> COLCND is 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. *> \endverbatim *> *> \param[out] AMAX *> \verbatim *> AMAX is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, and i is *> <= M: the i-th row of A is exactly zero *> > M: the (i-M)-th column of A is exactly zero *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEcomputational * * ===================================================================== SUBROUTINE DGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, $ INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N DOUBLE PRECISION AMAX, COLCND, ROWCND * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( * ), R( * ) * .. * * ===================================================================== * * .. 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 *> \brief \b DGEEQUB * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEEQUB + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, * INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * DOUBLE PRECISION AMAX, COLCND, ROWCND * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( * ), R( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGEEQUB 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 an absolute value of at most *> the radix. *> *> R(i) and C(j) are restricted to be a power of the radix 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. *> *> This routine differs from DGEEQU by restricting the scaling factors *> to a power of the radix. Barring over- and underflow, scaling by *> these factors introduces no additional rounding errors. However, the *> scaled entries' magnitudes are no longer approximately 1 but lie *> between sqrt(radix) and 1/sqrt(radix). *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The M-by-N matrix whose equilibration factors are *> to be computed. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] R *> \verbatim *> R is DOUBLE PRECISION array, dimension (M) *> If INFO = 0 or INFO > M, R contains the row scale factors *> for A. *> \endverbatim *> *> \param[out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (N) *> If INFO = 0, C contains the column scale factors for A. *> \endverbatim *> *> \param[out] ROWCND *> \verbatim *> ROWCND is 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. *> \endverbatim *> *> \param[out] COLCND *> \verbatim *> COLCND is 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. *> \endverbatim *> *> \param[out] AMAX *> \verbatim *> AMAX is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, and i is *> <= M: the i-th row of A is exactly zero *> > M: the (i-M)-th column of A is exactly zero *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEcomputational * * ===================================================================== SUBROUTINE DGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, $ INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N DOUBLE PRECISION AMAX, COLCND, ROWCND * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( * ), R( * ) * .. * * ===================================================================== * * .. 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, RADIX, LOGRDX * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, LOG * .. * .. 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( 'DGEEQUB', -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. Assume SMLNUM is a power of the radix. * SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM RADIX = DLAMCH( 'B' ) LOGRDX = LOG( RADIX ) * * 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 DO I = 1, M IF( R( I ).GT.ZERO ) THEN R( I ) = RADIX**INT( LOG( R( I ) ) / LOGRDX ) END IF END DO * * 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 IF( C( J ).GT.ZERO ) THEN C( J ) = RADIX**INT( LOG( C( J ) ) / LOGRDX ) END IF 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 DGEEQUB * END *> \brief DGEES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEES + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI, * VS, LDVS, WORK, LWORK, BWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBVS, SORT * INTEGER INFO, LDA, LDVS, LWORK, N, SDIM * .. * .. Array Arguments .. * LOGICAL BWORK( * ) * DOUBLE PRECISION A( LDA, * ), VS( LDVS, * ), WI( * ), WORK( * ), * $ WR( * ) * .. * .. Function Arguments .. * LOGICAL SELECT * EXTERNAL SELECT * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGEES computes for an N-by-N real nonsymmetric matrix A, the *> eigenvalues, the real Schur form T, and, optionally, the matrix of *> Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T). *> *> Optionally, it also orders the eigenvalues on the diagonal of the *> real Schur form so that selected eigenvalues are at the top left. *> The leading columns of Z then form an orthonormal basis for the *> invariant subspace corresponding to the selected eigenvalues. *> *> A matrix is in real Schur form if it is upper quasi-triangular with *> 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the *> form *> [ a b ] *> [ c a ] *> *> where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc). *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBVS *> \verbatim *> JOBVS is CHARACTER*1 *> = 'N': Schur vectors are not computed; *> = 'V': Schur vectors are computed. *> \endverbatim *> *> \param[in] SORT *> \verbatim *> SORT is CHARACTER*1 *> Specifies whether or not to order the eigenvalues on the *> diagonal of the Schur form. *> = 'N': Eigenvalues are not ordered; *> = 'S': Eigenvalues are ordered (see SELECT). *> \endverbatim *> *> \param[in] SELECT *> \verbatim *> SELECT is a LOGICAL FUNCTION of two DOUBLE PRECISION arguments *> SELECT must be declared EXTERNAL in the calling subroutine. *> If SORT = 'S', SELECT is used to select eigenvalues to sort *> to the top left of the Schur form. *> If SORT = 'N', SELECT is not referenced. *> An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if *> SELECT(WR(j),WI(j)) is true; i.e., if either one of a complex *> conjugate pair of eigenvalues is selected, then both complex *> eigenvalues are selected. *> Note that a selected complex eigenvalue may no longer *> satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since *> ordering may change the value of complex eigenvalues *> (especially if the eigenvalue is ill-conditioned); in this *> case INFO is set to N+2 (see INFO below). *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the N-by-N matrix A. *> On exit, A has been overwritten by its real Schur form T. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] SDIM *> \verbatim *> SDIM is INTEGER *> If SORT = 'N', SDIM = 0. *> If SORT = 'S', SDIM = number of eigenvalues (after sorting) *> for which SELECT is true. (Complex conjugate *> pairs for which SELECT is true for either *> eigenvalue count as 2.) *> \endverbatim *> *> \param[out] WR *> \verbatim *> WR is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] WI *> \verbatim *> WI is DOUBLE PRECISION array, dimension (N) *> WR and WI contain the real and imaginary parts, *> respectively, of the computed eigenvalues in the same order *> that they appear on the diagonal of the output Schur form T. *> Complex conjugate pairs of eigenvalues will appear *> consecutively with the eigenvalue having the positive *> imaginary part first. *> \endverbatim *> *> \param[out] VS *> \verbatim *> VS is DOUBLE PRECISION array, dimension (LDVS,N) *> If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur *> vectors. *> If JOBVS = 'N', VS is not referenced. *> \endverbatim *> *> \param[in] LDVS *> \verbatim *> LDVS is INTEGER *> The leading dimension of the array VS. LDVS >= 1; if *> JOBVS = 'V', LDVS >= N. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) contains the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= max(1,3*N). *> For good performance, LWORK must generally be larger. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error *> message related to LWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] BWORK *> \verbatim *> BWORK is LOGICAL array, dimension (N) *> Not referenced if SORT = 'N'. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: if INFO = i, and i is *> <= N: the QR algorithm failed to compute all the *> eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI *> contain those eigenvalues which have converged; if *> JOBVS = 'V', VS contains the matrix which reduces A *> to its partially converged Schur form. *> = N+1: the eigenvalues could not be reordered because some *> eigenvalues were too close to separate (the problem *> is very ill-conditioned); *> = N+2: after reordering, roundoff changed values of some *> complex eigenvalues so that leading eigenvalues in *> the Schur form no longer satisfy SELECT=.TRUE. This *> could also be caused by underflow due to scaling. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEeigen * * ===================================================================== SUBROUTINE DGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI, $ VS, LDVS, WORK, LWORK, BWORK, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER JOBVS, SORT INTEGER INFO, LDA, LDVS, LWORK, N, SDIM * .. * .. Array Arguments .. LOGICAL BWORK( * ) DOUBLE PRECISION A( LDA, * ), VS( LDVS, * ), WI( * ), WORK( * ), $ WR( * ) * .. * .. Function Arguments .. LOGICAL SELECT EXTERNAL SELECT * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL CURSL, LASTSL, LQUERY, LST2SL, SCALEA, WANTST, $ WANTVS INTEGER HSWORK, I, I1, I2, IBAL, ICOND, IERR, IEVAL, $ IHI, ILO, INXT, IP, ITAU, IWRK, MAXWRK, MINWRK DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, S, SEP, SMLNUM * .. * .. Local Arrays .. INTEGER IDUM( 1 ) DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. EXTERNAL DCOPY, DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLACPY, $ DLABAD, DLASCL, DORGHR, DSWAP, DTRSEN, XERBLA * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE * .. * .. Intrinsic Functions .. INTRINSIC MAX, SQRT * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) WANTVS = LSAME( JOBVS, 'V' ) WANTST = LSAME( SORT, 'S' ) IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN INFO = -1 ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDVS.LT.1 .OR. ( WANTVS .AND. LDVS.LT.N ) ) THEN INFO = -11 END IF * * Compute workspace * (Note: Comments in the code beginning "Workspace:" describe the * minimal amount of workspace needed at that point in the code, * as well as the preferred amount for good performance. * NB refers to the optimal block size for the immediately * following subroutine, as returned by ILAENV. * HSWORK refers to the workspace preferred by DHSEQR, as * calculated below. HSWORK is computed assuming ILO=1 and IHI=N, * the worst case.) * IF( INFO.EQ.0 ) THEN IF( N.EQ.0 ) THEN MINWRK = 1 MAXWRK = 1 ELSE MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 ) MINWRK = 3*N * CALL DHSEQR( 'S', JOBVS, N, 1, N, A, LDA, WR, WI, VS, LDVS, $ WORK, -1, IEVAL ) HSWORK = WORK( 1 ) * IF( .NOT.WANTVS ) THEN MAXWRK = MAX( MAXWRK, N + HSWORK ) ELSE MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1, $ 'DORGHR', ' ', N, 1, N, -1 ) ) MAXWRK = MAX( MAXWRK, N + HSWORK ) END IF END IF WORK( 1 ) = MAXWRK * IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN INFO = -13 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEES ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN SDIM = 0 RETURN END IF * * Get machine constants * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = SQRT( SMLNUM ) / EPS BIGNUM = ONE / SMLNUM * * Scale A if max element outside range [SMLNUM,BIGNUM] * ANRM = DLANGE( 'M', N, N, A, LDA, DUM ) SCALEA = .FALSE. IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN SCALEA = .TRUE. CSCALE = SMLNUM ELSE IF( ANRM.GT.BIGNUM ) THEN SCALEA = .TRUE. CSCALE = BIGNUM END IF IF( SCALEA ) $ CALL DLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR ) * * Permute the matrix to make it more nearly triangular * (Workspace: need N) * IBAL = 1 CALL DGEBAL( 'P', N, A, LDA, ILO, IHI, WORK( IBAL ), IERR ) * * Reduce to upper Hessenberg form * (Workspace: need 3*N, prefer 2*N+N*NB) * ITAU = N + IBAL IWRK = N + ITAU CALL DGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ), $ LWORK-IWRK+1, IERR ) * IF( WANTVS ) THEN * * Copy Householder vectors to VS * CALL DLACPY( 'L', N, N, A, LDA, VS, LDVS ) * * Generate orthogonal matrix in VS * (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) * CALL DORGHR( N, ILO, IHI, VS, LDVS, WORK( ITAU ), WORK( IWRK ), $ LWORK-IWRK+1, IERR ) END IF * SDIM = 0 * * Perform QR iteration, accumulating Schur vectors in VS if desired * (Workspace: need N+1, prefer N+HSWORK (see comments) ) * IWRK = ITAU CALL DHSEQR( 'S', JOBVS, N, ILO, IHI, A, LDA, WR, WI, VS, LDVS, $ WORK( IWRK ), LWORK-IWRK+1, IEVAL ) IF( IEVAL.GT.0 ) $ INFO = IEVAL * * Sort eigenvalues if desired * IF( WANTST .AND. INFO.EQ.0 ) THEN IF( SCALEA ) THEN CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WR, N, IERR ) CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WI, N, IERR ) END IF DO 10 I = 1, N BWORK( I ) = SELECT( WR( I ), WI( I ) ) 10 CONTINUE * * Reorder eigenvalues and transform Schur vectors * (Workspace: none needed) * CALL DTRSEN( 'N', JOBVS, BWORK, N, A, LDA, VS, LDVS, WR, WI, $ SDIM, S, SEP, WORK( IWRK ), LWORK-IWRK+1, IDUM, 1, $ ICOND ) IF( ICOND.GT.0 ) $ INFO = N + ICOND END IF * IF( WANTVS ) THEN * * Undo balancing * (Workspace: need N) * CALL DGEBAK( 'P', 'R', N, ILO, IHI, WORK( IBAL ), N, VS, LDVS, $ IERR ) END IF * IF( SCALEA ) THEN * * Undo scaling for the Schur form of A * CALL DLASCL( 'H', 0, 0, CSCALE, ANRM, N, N, A, LDA, IERR ) CALL DCOPY( N, A, LDA+1, WR, 1 ) IF( CSCALE.EQ.SMLNUM ) THEN * * If scaling back towards underflow, adjust WI if an * offdiagonal element of a 2-by-2 block in the Schur form * underflows. * IF( IEVAL.GT.0 ) THEN I1 = IEVAL + 1 I2 = IHI - 1 CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, $ MAX( ILO-1, 1 ), IERR ) ELSE IF( WANTST ) THEN I1 = 1 I2 = N - 1 ELSE I1 = ILO I2 = IHI - 1 END IF INXT = I1 - 1 DO 20 I = I1, I2 IF( I.LT.INXT ) $ GO TO 20 IF( WI( I ).EQ.ZERO ) THEN INXT = I + 1 ELSE IF( A( I+1, I ).EQ.ZERO ) THEN WI( I ) = ZERO WI( I+1 ) = ZERO ELSE IF( A( I+1, I ).NE.ZERO .AND. A( I, I+1 ).EQ. $ ZERO ) THEN WI( I ) = ZERO WI( I+1 ) = ZERO IF( I.GT.1 ) $ CALL DSWAP( I-1, A( 1, I ), 1, A( 1, I+1 ), 1 ) IF( N.GT.I+1 ) $ CALL DSWAP( N-I-1, A( I, I+2 ), LDA, $ A( I+1, I+2 ), LDA ) IF( WANTVS ) THEN CALL DSWAP( N, VS( 1, I ), 1, VS( 1, I+1 ), 1 ) END IF A( I, I+1 ) = A( I+1, I ) A( I+1, I ) = ZERO END IF INXT = I + 2 END IF 20 CONTINUE END IF * * Undo scaling for the imaginary part of the eigenvalues * CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-IEVAL, 1, $ WI( IEVAL+1 ), MAX( N-IEVAL, 1 ), IERR ) END IF * IF( WANTST .AND. INFO.EQ.0 ) THEN * * Check if reordering successful * LASTSL = .TRUE. LST2SL = .TRUE. SDIM = 0 IP = 0 DO 30 I = 1, N CURSL = SELECT( WR( I ), WI( I ) ) IF( WI( I ).EQ.ZERO ) THEN IF( CURSL ) $ SDIM = SDIM + 1 IP = 0 IF( CURSL .AND. .NOT.LASTSL ) $ INFO = N + 2 ELSE IF( IP.EQ.1 ) THEN * * Last eigenvalue of conjugate pair * CURSL = CURSL .OR. LASTSL LASTSL = CURSL IF( CURSL ) $ SDIM = SDIM + 2 IP = -1 IF( CURSL .AND. .NOT.LST2SL ) $ INFO = N + 2 ELSE * * First eigenvalue of conjugate pair * IP = 1 END IF END IF LST2SL = LASTSL LASTSL = CURSL 30 CONTINUE END IF * WORK( 1 ) = MAXWRK RETURN * * End of DGEES * END *> \brief DGEESX computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEESX + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, * WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, * IWORK, LIWORK, BWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBVS, SENSE, SORT * INTEGER INFO, LDA, LDVS, LIWORK, LWORK, N, SDIM * DOUBLE PRECISION RCONDE, RCONDV * .. * .. Array Arguments .. * LOGICAL BWORK( * ) * INTEGER IWORK( * ) * DOUBLE PRECISION A( LDA, * ), VS( LDVS, * ), WI( * ), WORK( * ), * $ WR( * ) * .. * .. Function Arguments .. * LOGICAL SELECT * EXTERNAL SELECT * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGEESX computes for an N-by-N real nonsymmetric matrix A, the *> eigenvalues, the real Schur form T, and, optionally, the matrix of *> Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T). *> *> Optionally, it also orders the eigenvalues on the diagonal of the *> real Schur form so that selected eigenvalues are at the top left; *> computes a reciprocal condition number for the average of the *> selected eigenvalues (RCONDE); and computes a reciprocal condition *> number for the right invariant subspace corresponding to the *> selected eigenvalues (RCONDV). The leading columns of Z form an *> orthonormal basis for this invariant subspace. *> *> For further explanation of the reciprocal condition numbers RCONDE *> and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where *> these quantities are called s and sep respectively). *> *> A real matrix is in real Schur form if it is upper quasi-triangular *> with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in *> the form *> [ a b ] *> [ c a ] *> *> where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc). *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBVS *> \verbatim *> JOBVS is CHARACTER*1 *> = 'N': Schur vectors are not computed; *> = 'V': Schur vectors are computed. *> \endverbatim *> *> \param[in] SORT *> \verbatim *> SORT is CHARACTER*1 *> Specifies whether or not to order the eigenvalues on the *> diagonal of the Schur form. *> = 'N': Eigenvalues are not ordered; *> = 'S': Eigenvalues are ordered (see SELECT). *> \endverbatim *> *> \param[in] SELECT *> \verbatim *> SELECT is a LOGICAL FUNCTION of two DOUBLE PRECISION arguments *> SELECT must be declared EXTERNAL in the calling subroutine. *> If SORT = 'S', SELECT is used to select eigenvalues to sort *> to the top left of the Schur form. *> If SORT = 'N', SELECT is not referenced. *> An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if *> SELECT(WR(j),WI(j)) is true; i.e., if either one of a *> complex conjugate pair of eigenvalues is selected, then both *> are. Note that a selected complex eigenvalue may no longer *> satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since *> ordering may change the value of complex eigenvalues *> (especially if the eigenvalue is ill-conditioned); in this *> case INFO may be set to N+3 (see INFO below). *> \endverbatim *> *> \param[in] SENSE *> \verbatim *> SENSE is CHARACTER*1 *> Determines which reciprocal condition numbers are computed. *> = 'N': None are computed; *> = 'E': Computed for average of selected eigenvalues only; *> = 'V': Computed for selected right invariant subspace only; *> = 'B': Computed for both. *> If SENSE = 'E', 'V' or 'B', SORT must equal 'S'. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA, N) *> On entry, the N-by-N matrix A. *> On exit, A is overwritten by its real Schur form T. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] SDIM *> \verbatim *> SDIM is INTEGER *> If SORT = 'N', SDIM = 0. *> If SORT = 'S', SDIM = number of eigenvalues (after sorting) *> for which SELECT is true. (Complex conjugate *> pairs for which SELECT is true for either *> eigenvalue count as 2.) *> \endverbatim *> *> \param[out] WR *> \verbatim *> WR is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] WI *> \verbatim *> WI is DOUBLE PRECISION array, dimension (N) *> WR and WI contain the real and imaginary parts, respectively, *> of the computed eigenvalues, in the same order that they *> appear on the diagonal of the output Schur form T. Complex *> conjugate pairs of eigenvalues appear consecutively with the *> eigenvalue having the positive imaginary part first. *> \endverbatim *> *> \param[out] VS *> \verbatim *> VS is DOUBLE PRECISION array, dimension (LDVS,N) *> If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur *> vectors. *> If JOBVS = 'N', VS is not referenced. *> \endverbatim *> *> \param[in] LDVS *> \verbatim *> LDVS is INTEGER *> The leading dimension of the array VS. LDVS >= 1, and if *> JOBVS = 'V', LDVS >= N. *> \endverbatim *> *> \param[out] RCONDE *> \verbatim *> RCONDE is DOUBLE PRECISION *> If SENSE = 'E' or 'B', RCONDE contains the reciprocal *> condition number for the average of the selected eigenvalues. *> Not referenced if SENSE = 'N' or 'V'. *> \endverbatim *> *> \param[out] RCONDV *> \verbatim *> RCONDV is DOUBLE PRECISION *> If SENSE = 'V' or 'B', RCONDV contains the reciprocal *> condition number for the selected right invariant subspace. *> Not referenced if SENSE = 'N' or 'E'. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= max(1,3*N). *> Also, if SENSE = 'E' or 'V' or 'B', *> LWORK >= N+2*SDIM*(N-SDIM), where SDIM is the number of *> selected eigenvalues computed by this routine. Note that *> N+2*SDIM*(N-SDIM) <= N+N*N/2. Note also that an error is only *> returned if LWORK < max(1,3*N), but if SENSE = 'E' or 'V' or *> 'B' this may not be large enough. *> For good performance, LWORK must generally be larger. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates upper bounds on the optimal sizes of the *> arrays WORK and IWORK, returns these values as the first *> entries of the WORK and IWORK arrays, and no error messages *> related to LWORK or LIWORK are issued by XERBLA. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) *> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. *> \endverbatim *> *> \param[in] LIWORK *> \verbatim *> LIWORK is INTEGER *> The dimension of the array IWORK. *> LIWORK >= 1; if SENSE = 'V' or 'B', LIWORK >= SDIM*(N-SDIM). *> Note that SDIM*(N-SDIM) <= N*N/4. Note also that an error is *> only returned if LIWORK < 1, but if SENSE = 'V' or 'B' this *> may not be large enough. *> *> If LIWORK = -1, then a workspace query is assumed; the *> routine only calculates upper bounds on the optimal sizes of *> the arrays WORK and IWORK, returns these values as the first *> entries of the WORK and IWORK arrays, and no error messages *> related to LWORK or LIWORK are issued by XERBLA. *> \endverbatim *> *> \param[out] BWORK *> \verbatim *> BWORK is LOGICAL array, dimension (N) *> Not referenced if SORT = 'N'. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: if INFO = i, and i is *> <= N: the QR algorithm failed to compute all the *> eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI *> contain those eigenvalues which have converged; if *> JOBVS = 'V', VS contains the transformation which *> reduces A to its partially converged Schur form. *> = N+1: the eigenvalues could not be reordered because some *> eigenvalues were too close to separate (the problem *> is very ill-conditioned); *> = N+2: after reordering, roundoff changed values of some *> complex eigenvalues so that leading eigenvalues in *> the Schur form no longer satisfy SELECT=.TRUE. This *> could also be caused by underflow due to scaling. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleGEeigen * * ===================================================================== SUBROUTINE DGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, $ WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, $ IWORK, LIWORK, BWORK, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. CHARACTER JOBVS, SENSE, SORT INTEGER INFO, LDA, LDVS, LIWORK, LWORK, N, SDIM DOUBLE PRECISION RCONDE, RCONDV * .. * .. Array Arguments .. LOGICAL BWORK( * ) INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), VS( LDVS, * ), WI( * ), WORK( * ), $ WR( * ) * .. * .. Function Arguments .. LOGICAL SELECT EXTERNAL SELECT * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL CURSL, LASTSL, LQUERY, LST2SL, SCALEA, WANTSB, $ WANTSE, WANTSN, WANTST, WANTSV, WANTVS INTEGER HSWORK, I, I1, I2, IBAL, ICOND, IERR, IEVAL, $ IHI, ILO, INXT, IP, ITAU, IWRK, LIWRK, LWRK, $ MAXWRK, MINWRK DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, SMLNUM * .. * .. Local Arrays .. DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. EXTERNAL DCOPY, DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLACPY, $ DLASCL, DORGHR, DSWAP, DTRSEN, XERBLA * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL LSAME, ILAENV, DLABAD, DLAMCH, DLANGE * .. * .. Intrinsic Functions .. INTRINSIC MAX, SQRT * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 WANTVS = LSAME( JOBVS, 'V' ) WANTST = LSAME( SORT, 'S' ) WANTSN = LSAME( SENSE, 'N' ) WANTSE = LSAME( SENSE, 'E' ) WANTSV = LSAME( SENSE, 'V' ) WANTSB = LSAME( SENSE, 'B' ) LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) * IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN INFO = -1 ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN INFO = -2 ELSE IF( .NOT.( WANTSN .OR. WANTSE .OR. WANTSV .OR. WANTSB ) .OR. $ ( .NOT.WANTST .AND. .NOT.WANTSN ) ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDVS.LT.1 .OR. ( WANTVS .AND. LDVS.LT.N ) ) THEN INFO = -12 END IF * * Compute workspace * (Note: Comments in the code beginning "RWorkspace:" describe the * minimal amount of real workspace needed at that point in the * code, as well as the preferred amount for good performance. * IWorkspace refers to integer workspace. * NB refers to the optimal block size for the immediately * following subroutine, as returned by ILAENV. * HSWORK refers to the workspace preferred by DHSEQR, as * calculated below. HSWORK is computed assuming ILO=1 and IHI=N, * the worst case. * If SENSE = 'E', 'V' or 'B', then the amount of workspace needed * depends on SDIM, which is computed by the routine DTRSEN later * in the code.) * IF( INFO.EQ.0 ) THEN LIWRK = 1 IF( N.EQ.0 ) THEN MINWRK = 1 LWRK = 1 ELSE MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 ) MINWRK = 3*N * CALL DHSEQR( 'S', JOBVS, N, 1, N, A, LDA, WR, WI, VS, LDVS, $ WORK, -1, IEVAL ) HSWORK = WORK( 1 ) * IF( .NOT.WANTVS ) THEN MAXWRK = MAX( MAXWRK, N + HSWORK ) ELSE MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1, $ 'DORGHR', ' ', N, 1, N, -1 ) ) MAXWRK = MAX( MAXWRK, N + HSWORK ) END IF LWRK = MAXWRK IF( .NOT.WANTSN ) $ LWRK = MAX( LWRK, N + ( N*N )/2 ) IF( WANTSV .OR. WANTSB ) $ LIWRK = ( N*N )/4 END IF IWORK( 1 ) = LIWRK WORK( 1 ) = LWRK * IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN INFO = -16 ELSE IF( LIWORK.LT.1 .AND. .NOT.LQUERY ) THEN INFO = -18 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEESX', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN SDIM = 0 RETURN END IF * * Get machine constants * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = SQRT( SMLNUM ) / EPS BIGNUM = ONE / SMLNUM * * Scale A if max element outside range [SMLNUM,BIGNUM] * ANRM = DLANGE( 'M', N, N, A, LDA, DUM ) SCALEA = .FALSE. IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN SCALEA = .TRUE. CSCALE = SMLNUM ELSE IF( ANRM.GT.BIGNUM ) THEN SCALEA = .TRUE. CSCALE = BIGNUM END IF IF( SCALEA ) $ CALL DLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR ) * * Permute the matrix to make it more nearly triangular * (RWorkspace: need N) * IBAL = 1 CALL DGEBAL( 'P', N, A, LDA, ILO, IHI, WORK( IBAL ), IERR ) * * Reduce to upper Hessenberg form * (RWorkspace: need 3*N, prefer 2*N+N*NB) * ITAU = N + IBAL IWRK = N + ITAU CALL DGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ), $ LWORK-IWRK+1, IERR ) * IF( WANTVS ) THEN * * Copy Householder vectors to VS * CALL DLACPY( 'L', N, N, A, LDA, VS, LDVS ) * * Generate orthogonal matrix in VS * (RWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) * CALL DORGHR( N, ILO, IHI, VS, LDVS, WORK( ITAU ), WORK( IWRK ), $ LWORK-IWRK+1, IERR ) END IF * SDIM = 0 * * Perform QR iteration, accumulating Schur vectors in VS if desired * (RWorkspace: need N+1, prefer N+HSWORK (see comments) ) * IWRK = ITAU CALL DHSEQR( 'S', JOBVS, N, ILO, IHI, A, LDA, WR, WI, VS, LDVS, $ WORK( IWRK ), LWORK-IWRK+1, IEVAL ) IF( IEVAL.GT.0 ) $ INFO = IEVAL * * Sort eigenvalues if desired * IF( WANTST .AND. INFO.EQ.0 ) THEN IF( SCALEA ) THEN CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WR, N, IERR ) CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WI, N, IERR ) END IF DO 10 I = 1, N BWORK( I ) = SELECT( WR( I ), WI( I ) ) 10 CONTINUE * * Reorder eigenvalues, transform Schur vectors, and compute * reciprocal condition numbers * (RWorkspace: if SENSE is not 'N', need N+2*SDIM*(N-SDIM) * otherwise, need N ) * (IWorkspace: if SENSE is 'V' or 'B', need SDIM*(N-SDIM) * otherwise, need 0 ) * CALL DTRSEN( SENSE, JOBVS, BWORK, N, A, LDA, VS, LDVS, WR, WI, $ SDIM, RCONDE, RCONDV, WORK( IWRK ), LWORK-IWRK+1, $ IWORK, LIWORK, ICOND ) IF( .NOT.WANTSN ) $ MAXWRK = MAX( MAXWRK, N+2*SDIM*( N-SDIM ) ) IF( ICOND.EQ.-15 ) THEN * * Not enough real workspace * INFO = -16 ELSE IF( ICOND.EQ.-17 ) THEN * * Not enough integer workspace * INFO = -18 ELSE IF( ICOND.GT.0 ) THEN * * DTRSEN failed to reorder or to restore standard Schur form * INFO = ICOND + N END IF END IF * IF( WANTVS ) THEN * * Undo balancing * (RWorkspace: need N) * CALL DGEBAK( 'P', 'R', N, ILO, IHI, WORK( IBAL ), N, VS, LDVS, $ IERR ) END IF * IF( SCALEA ) THEN * * Undo scaling for the Schur form of A * CALL DLASCL( 'H', 0, 0, CSCALE, ANRM, N, N, A, LDA, IERR ) CALL DCOPY( N, A, LDA+1, WR, 1 ) IF( ( WANTSV .OR. WANTSB ) .AND. INFO.EQ.0 ) THEN DUM( 1 ) = RCONDV CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, 1, 1, DUM, 1, IERR ) RCONDV = DUM( 1 ) END IF IF( CSCALE.EQ.SMLNUM ) THEN * * If scaling back towards underflow, adjust WI if an * offdiagonal element of a 2-by-2 block in the Schur form * underflows. * IF( IEVAL.GT.0 ) THEN I1 = IEVAL + 1 I2 = IHI - 1 CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N, $ IERR ) ELSE IF( WANTST ) THEN I1 = 1 I2 = N - 1 ELSE I1 = ILO I2 = IHI - 1 END IF INXT = I1 - 1 DO 20 I = I1, I2 IF( I.LT.INXT ) $ GO TO 20 IF( WI( I ).EQ.ZERO ) THEN INXT = I + 1 ELSE IF( A( I+1, I ).EQ.ZERO ) THEN WI( I ) = ZERO WI( I+1 ) = ZERO ELSE IF( A( I+1, I ).NE.ZERO .AND. A( I, I+1 ).EQ. $ ZERO ) THEN WI( I ) = ZERO WI( I+1 ) = ZERO IF( I.GT.1 ) $ CALL DSWAP( I-1, A( 1, I ), 1, A( 1, I+1 ), 1 ) IF( N.GT.I+1 ) $ CALL DSWAP( N-I-1, A( I, I+2 ), LDA, $ A( I+1, I+2 ), LDA ) CALL DSWAP( N, VS( 1, I ), 1, VS( 1, I+1 ), 1 ) A( I, I+1 ) = A( I+1, I ) A( I+1, I ) = ZERO END IF INXT = I + 2 END IF 20 CONTINUE END IF CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-IEVAL, 1, $ WI( IEVAL+1 ), MAX( N-IEVAL, 1 ), IERR ) END IF * IF( WANTST .AND. INFO.EQ.0 ) THEN * * Check if reordering successful * LASTSL = .TRUE. LST2SL = .TRUE. SDIM = 0 IP = 0 DO 30 I = 1, N CURSL = SELECT( WR( I ), WI( I ) ) IF( WI( I ).EQ.ZERO ) THEN IF( CURSL ) $ SDIM = SDIM + 1 IP = 0 IF( CURSL .AND. .NOT.LASTSL ) $ INFO = N + 2 ELSE IF( IP.EQ.1 ) THEN * * Last eigenvalue of conjugate pair * CURSL = CURSL .OR. LASTSL LASTSL = CURSL IF( CURSL ) $ SDIM = SDIM + 2 IP = -1 IF( CURSL .AND. .NOT.LST2SL ) $ INFO = N + 2 ELSE * * First eigenvalue of conjugate pair * IP = 1 END IF END IF LST2SL = LASTSL LASTSL = CURSL 30 CONTINUE END IF * WORK( 1 ) = MAXWRK IF( WANTSV .OR. WANTSB ) THEN IWORK( 1 ) = MAX( 1, SDIM*( N-SDIM ) ) ELSE IWORK( 1 ) = 1 END IF * RETURN * * End of DGEESX * END *> \brief DGEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEEV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, * LDVR, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBVL, JOBVR * INTEGER INFO, LDA, LDVL, LDVR, LWORK, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), * $ WI( * ), WORK( * ), WR( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGEEV computes for an N-by-N real nonsymmetric matrix A, the *> eigenvalues and, optionally, the left and/or right eigenvectors. *> *> The right eigenvector v(j) of A satisfies *> A * v(j) = lambda(j) * v(j) *> where lambda(j) is its eigenvalue. *> The left eigenvector u(j) of A satisfies *> u(j)**H * A = lambda(j) * u(j)**H *> where u(j)**H denotes the conjugate-transpose of u(j). *> *> The computed eigenvectors are normalized to have Euclidean norm *> equal to 1 and largest component real. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBVL *> \verbatim *> JOBVL is CHARACTER*1 *> = 'N': left eigenvectors of A are not computed; *> = 'V': left eigenvectors of A are computed. *> \endverbatim *> *> \param[in] JOBVR *> \verbatim *> JOBVR is CHARACTER*1 *> = 'N': right eigenvectors of A are not computed; *> = 'V': right eigenvectors of A are computed. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the N-by-N matrix A. *> On exit, A has been overwritten. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] WR *> \verbatim *> WR is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] WI *> \verbatim *> WI is DOUBLE PRECISION array, dimension (N) *> WR and WI contain the real and imaginary parts, *> respectively, of the computed eigenvalues. Complex *> conjugate pairs of eigenvalues appear consecutively *> with the eigenvalue having the positive imaginary part *> first. *> \endverbatim *> *> \param[out] VL *> \verbatim *> VL is DOUBLE PRECISION array, dimension (LDVL,N) *> If JOBVL = 'V', the left eigenvectors u(j) are stored one *> after another in the columns of VL, in the same order *> as their eigenvalues. *> If JOBVL = 'N', VL is not referenced. *> If the j-th eigenvalue is real, then u(j) = VL(:,j), *> the j-th column of VL. *> If the j-th and (j+1)-st eigenvalues form a complex *> conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and *> u(j+1) = VL(:,j) - i*VL(:,j+1). *> \endverbatim *> *> \param[in] LDVL *> \verbatim *> LDVL is INTEGER *> The leading dimension of the array VL. LDVL >= 1; if *> JOBVL = 'V', LDVL >= N. *> \endverbatim *> *> \param[out] VR *> \verbatim *> VR is DOUBLE PRECISION array, dimension (LDVR,N) *> If JOBVR = 'V', the right eigenvectors v(j) are stored one *> after another in the columns of VR, in the same order *> as their eigenvalues. *> If JOBVR = 'N', VR is not referenced. *> If the j-th eigenvalue is real, then v(j) = VR(:,j), *> the j-th column of VR. *> If the j-th and (j+1)-st eigenvalues form a complex *> conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and *> v(j+1) = VR(:,j) - i*VR(:,j+1). *> \endverbatim *> *> \param[in] LDVR *> \verbatim *> LDVR is INTEGER *> The leading dimension of the array VR. LDVR >= 1; if *> JOBVR = 'V', LDVR >= N. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= max(1,3*N), and *> if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good *> performance, LWORK must generally be larger. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error *> message related to LWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: if INFO = i, the QR algorithm failed to compute all the *> eigenvalues, and no eigenvectors have been computed; *> elements i+1:N of WR and WI contain eigenvalues which *> have converged. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * * @precisions fortran d -> s * *> \ingroup doubleGEeigen * * ===================================================================== SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, $ LDVR, WORK, LWORK, INFO ) implicit none * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR INTEGER INFO, LDA, LDVL, LDVR, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), $ WI( * ), WORK( * ), WR( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, SCALEA, WANTVL, WANTVR CHARACTER SIDE INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, ITAU, IWRK, K, $ LWORK_TREVC, MAXWRK, MINWRK, NOUT DOUBLE PRECISION ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM, $ SN * .. * .. Local Arrays .. LOGICAL SELECT( 1 ) DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. EXTERNAL DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLABAD, DLACPY, $ DLARTG, DLASCL, DORGHR, DROT, DSCAL, DTREVC3, $ XERBLA * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX, ILAENV DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2, DNRM2 EXTERNAL LSAME, IDAMAX, ILAENV, DLAMCH, DLANGE, DLAPY2, $ DNRM2 * .. * .. Intrinsic Functions .. INTRINSIC MAX, SQRT * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) WANTVL = LSAME( JOBVL, 'V' ) WANTVR = LSAME( JOBVR, 'V' ) IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN INFO = -1 ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN INFO = -9 ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN INFO = -11 END IF * * Compute workspace * (Note: Comments in the code beginning "Workspace:" describe the * minimal amount of workspace needed at that point in the code, * as well as the preferred amount for good performance. * NB refers to the optimal block size for the immediately * following subroutine, as returned by ILAENV. * HSWORK refers to the workspace preferred by DHSEQR, as * calculated below. HSWORK is computed assuming ILO=1 and IHI=N, * the worst case.) * IF( INFO.EQ.0 ) THEN IF( N.EQ.0 ) THEN MINWRK = 1 MAXWRK = 1 ELSE MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 ) IF( WANTVL ) THEN MINWRK = 4*N MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1, $ 'DORGHR', ' ', N, 1, N, -1 ) ) CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VL, LDVL, $ WORK, -1, INFO ) HSWORK = INT( WORK(1) ) MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK ) CALL DTREVC3( 'L', 'B', SELECT, N, A, LDA, $ VL, LDVL, VR, LDVR, N, NOUT, $ WORK, -1, IERR ) LWORK_TREVC = INT( WORK(1) ) MAXWRK = MAX( MAXWRK, N + LWORK_TREVC ) MAXWRK = MAX( MAXWRK, 4*N ) ELSE IF( WANTVR ) THEN MINWRK = 4*N MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1, $ 'DORGHR', ' ', N, 1, N, -1 ) ) CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VR, LDVR, $ WORK, -1, INFO ) HSWORK = INT( WORK(1) ) MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK ) CALL DTREVC3( 'R', 'B', SELECT, N, A, LDA, $ VL, LDVL, VR, LDVR, N, NOUT, $ WORK, -1, IERR ) LWORK_TREVC = INT( WORK(1) ) MAXWRK = MAX( MAXWRK, N + LWORK_TREVC ) MAXWRK = MAX( MAXWRK, 4*N ) ELSE MINWRK = 3*N CALL DHSEQR( 'E', 'N', N, 1, N, A, LDA, WR, WI, VR, LDVR, $ WORK, -1, INFO ) HSWORK = INT( WORK(1) ) MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK ) END IF MAXWRK = MAX( MAXWRK, MINWRK ) END IF WORK( 1 ) = MAXWRK * IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN INFO = -13 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEEV ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Get machine constants * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = SQRT( SMLNUM ) / EPS BIGNUM = ONE / SMLNUM * * Scale A if max element outside range [SMLNUM,BIGNUM] * ANRM = DLANGE( 'M', N, N, A, LDA, DUM ) SCALEA = .FALSE. IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN SCALEA = .TRUE. CSCALE = SMLNUM ELSE IF( ANRM.GT.BIGNUM ) THEN SCALEA = .TRUE. CSCALE = BIGNUM END IF IF( SCALEA ) $ CALL DLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR ) * * Balance the matrix * (Workspace: need N) * IBAL = 1 CALL DGEBAL( 'B', N, A, LDA, ILO, IHI, WORK( IBAL ), IERR ) * * Reduce to upper Hessenberg form * (Workspace: need 3*N, prefer 2*N+N*NB) * ITAU = IBAL + N IWRK = ITAU + N CALL DGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ), $ LWORK-IWRK+1, IERR ) * IF( WANTVL ) THEN * * Want left eigenvectors * Copy Householder vectors to VL * SIDE = 'L' CALL DLACPY( 'L', N, N, A, LDA, VL, LDVL ) * * Generate orthogonal matrix in VL * (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) * CALL DORGHR( N, ILO, IHI, VL, LDVL, WORK( ITAU ), WORK( IWRK ), $ LWORK-IWRK+1, IERR ) * * Perform QR iteration, accumulating Schur vectors in VL * (Workspace: need N+1, prefer N+HSWORK (see comments) ) * IWRK = ITAU CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VL, LDVL, $ WORK( IWRK ), LWORK-IWRK+1, INFO ) * IF( WANTVR ) THEN * * Want left and right eigenvectors * Copy Schur vectors to VR * SIDE = 'B' CALL DLACPY( 'F', N, N, VL, LDVL, VR, LDVR ) END IF * ELSE IF( WANTVR ) THEN * * Want right eigenvectors * Copy Householder vectors to VR * SIDE = 'R' CALL DLACPY( 'L', N, N, A, LDA, VR, LDVR ) * * Generate orthogonal matrix in VR * (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) * CALL DORGHR( N, ILO, IHI, VR, LDVR, WORK( ITAU ), WORK( IWRK ), $ LWORK-IWRK+1, IERR ) * * Perform QR iteration, accumulating Schur vectors in VR * (Workspace: need N+1, prefer N+HSWORK (see comments) ) * IWRK = ITAU CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR, $ WORK( IWRK ), LWORK-IWRK+1, INFO ) * ELSE * * Compute eigenvalues only * (Workspace: need N+1, prefer N+HSWORK (see comments) ) * IWRK = ITAU CALL DHSEQR( 'E', 'N', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR, $ WORK( IWRK ), LWORK-IWRK+1, INFO ) END IF * * If INFO .NE. 0 from DHSEQR, then quit * IF( INFO.NE.0 ) $ GO TO 50 * IF( WANTVL .OR. WANTVR ) THEN * * Compute left and/or right eigenvectors * (Workspace: need 4*N, prefer N + N + 2*N*NB) * CALL DTREVC3( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, $ N, NOUT, WORK( IWRK ), LWORK-IWRK+1, IERR ) END IF * IF( WANTVL ) THEN * * Undo balancing of left eigenvectors * (Workspace: need N) * CALL DGEBAK( 'B', 'L', N, ILO, IHI, WORK( IBAL ), N, VL, LDVL, $ IERR ) * * Normalize left eigenvectors and make largest component real * DO 20 I = 1, N IF( WI( I ).EQ.ZERO ) THEN SCL = ONE / DNRM2( N, VL( 1, I ), 1 ) CALL DSCAL( N, SCL, VL( 1, I ), 1 ) ELSE IF( WI( I ).GT.ZERO ) THEN SCL = ONE / DLAPY2( DNRM2( N, VL( 1, I ), 1 ), $ DNRM2( N, VL( 1, I+1 ), 1 ) ) CALL DSCAL( N, SCL, VL( 1, I ), 1 ) CALL DSCAL( N, SCL, VL( 1, I+1 ), 1 ) DO 10 K = 1, N WORK( IWRK+K-1 ) = VL( K, I )**2 + VL( K, I+1 )**2 10 CONTINUE K = IDAMAX( N, WORK( IWRK ), 1 ) CALL DLARTG( VL( K, I ), VL( K, I+1 ), CS, SN, R ) CALL DROT( N, VL( 1, I ), 1, VL( 1, I+1 ), 1, CS, SN ) VL( K, I+1 ) = ZERO END IF 20 CONTINUE END IF * IF( WANTVR ) THEN * * Undo balancing of right eigenvectors * (Workspace: need N) * CALL DGEBAK( 'B', 'R', N, ILO, IHI, WORK( IBAL ), N, VR, LDVR, $ IERR ) * * Normalize right eigenvectors and make largest component real * DO 40 I = 1, N IF( WI( I ).EQ.ZERO ) THEN SCL = ONE / DNRM2( N, VR( 1, I ), 1 ) CALL DSCAL( N, SCL, VR( 1, I ), 1 ) ELSE IF( WI( I ).GT.ZERO ) THEN SCL = ONE / DLAPY2( DNRM2( N, VR( 1, I ), 1 ), $ DNRM2( N, VR( 1, I+1 ), 1 ) ) CALL DSCAL( N, SCL, VR( 1, I ), 1 ) CALL DSCAL( N, SCL, VR( 1, I+1 ), 1 ) DO 30 K = 1, N WORK( IWRK+K-1 ) = VR( K, I )**2 + VR( K, I+1 )**2 30 CONTINUE K = IDAMAX( N, WORK( IWRK ), 1 ) CALL DLARTG( VR( K, I ), VR( K, I+1 ), CS, SN, R ) CALL DROT( N, VR( 1, I ), 1, VR( 1, I+1 ), 1, CS, SN ) VR( K, I+1 ) = ZERO END IF 40 CONTINUE END IF * * Undo scaling if necessary * 50 CONTINUE IF( SCALEA ) THEN CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WR( INFO+1 ), $ MAX( N-INFO, 1 ), IERR ) CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WI( INFO+1 ), $ MAX( N-INFO, 1 ), IERR ) IF( INFO.GT.0 ) THEN CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WR, N, $ IERR ) CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N, $ IERR ) END IF END IF * WORK( 1 ) = MAXWRK RETURN * * End of DGEEV * END *> \brief DGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEEVX + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, * VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, * RCONDE, RCONDV, WORK, LWORK, IWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER BALANC, JOBVL, JOBVR, SENSE * INTEGER IHI, ILO, INFO, LDA, LDVL, LDVR, LWORK, N * DOUBLE PRECISION ABNRM * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION A( LDA, * ), RCONDE( * ), RCONDV( * ), * $ SCALE( * ), VL( LDVL, * ), VR( LDVR, * ), * $ WI( * ), WORK( * ), WR( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGEEVX computes for an N-by-N real nonsymmetric matrix A, the *> eigenvalues and, optionally, the left and/or right eigenvectors. *> *> Optionally also, it computes a balancing transformation to improve *> the conditioning of the eigenvalues and eigenvectors (ILO, IHI, *> SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues *> (RCONDE), and reciprocal condition numbers for the right *> eigenvectors (RCONDV). *> *> The right eigenvector v(j) of A satisfies *> A * v(j) = lambda(j) * v(j) *> where lambda(j) is its eigenvalue. *> The left eigenvector u(j) of A satisfies *> u(j)**H * A = lambda(j) * u(j)**H *> where u(j)**H denotes the conjugate-transpose of u(j). *> *> The computed eigenvectors are normalized to have Euclidean norm *> equal to 1 and largest component real. *> *> Balancing a matrix means permuting the rows and columns to make it *> more nearly upper triangular, and applying a diagonal similarity *> transformation D * A * D**(-1), where D is a diagonal matrix, to *> make its rows and columns closer in norm and the condition numbers *> of its eigenvalues and eigenvectors smaller. The computed *> reciprocal condition numbers correspond to the balanced matrix. *> Permuting rows and columns will not change the condition numbers *> (in exact arithmetic) but diagonal scaling will. For further *> explanation of balancing, see section 4.10.2 of the LAPACK *> Users' Guide. *> \endverbatim * * Arguments: * ========== * *> \param[in] BALANC *> \verbatim *> BALANC is CHARACTER*1 *> Indicates how the input matrix should be diagonally scaled *> and/or permuted to improve the conditioning of its *> eigenvalues. *> = 'N': Do not diagonally scale or permute; *> = 'P': Perform permutations to make the matrix more nearly *> upper triangular. Do not diagonally scale; *> = 'S': Diagonally scale the matrix, i.e. replace A by *> D*A*D**(-1), where D is a diagonal matrix chosen *> to make the rows and columns of A more equal in *> norm. Do not permute; *> = 'B': Both diagonally scale and permute A. *> *> Computed reciprocal condition numbers will be for the matrix *> after balancing and/or permuting. Permuting does not change *> condition numbers (in exact arithmetic), but balancing does. *> \endverbatim *> *> \param[in] JOBVL *> \verbatim *> JOBVL is CHARACTER*1 *> = 'N': left eigenvectors of A are not computed; *> = 'V': left eigenvectors of A are computed. *> If SENSE = 'E' or 'B', JOBVL must = 'V'. *> \endverbatim *> *> \param[in] JOBVR *> \verbatim *> JOBVR is CHARACTER*1 *> = 'N': right eigenvectors of A are not computed; *> = 'V': right eigenvectors of A are computed. *> If SENSE = 'E' or 'B', JOBVR must = 'V'. *> \endverbatim *> *> \param[in] SENSE *> \verbatim *> SENSE is CHARACTER*1 *> Determines which reciprocal condition numbers are computed. *> = 'N': None are computed; *> = 'E': Computed for eigenvalues only; *> = 'V': Computed for right eigenvectors only; *> = 'B': Computed for eigenvalues and right eigenvectors. *> *> If SENSE = 'E' or 'B', both left and right eigenvectors *> must also be computed (JOBVL = 'V' and JOBVR = 'V'). *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the N-by-N matrix A. *> On exit, A has been overwritten. If JOBVL = 'V' or *> JOBVR = 'V', A contains the real Schur form of the balanced *> version of the input matrix A. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] WR *> \verbatim *> WR is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] WI *> \verbatim *> WI is DOUBLE PRECISION array, dimension (N) *> WR and WI contain the real and imaginary parts, *> respectively, of the computed eigenvalues. Complex *> conjugate pairs of eigenvalues will appear consecutively *> with the eigenvalue having the positive imaginary part *> first. *> \endverbatim *> *> \param[out] VL *> \verbatim *> VL is DOUBLE PRECISION array, dimension (LDVL,N) *> If JOBVL = 'V', the left eigenvectors u(j) are stored one *> after another in the columns of VL, in the same order *> as their eigenvalues. *> If JOBVL = 'N', VL is not referenced. *> If the j-th eigenvalue is real, then u(j) = VL(:,j), *> the j-th column of VL. *> If the j-th and (j+1)-st eigenvalues form a complex *> conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and *> u(j+1) = VL(:,j) - i*VL(:,j+1). *> \endverbatim *> *> \param[in] LDVL *> \verbatim *> LDVL is INTEGER *> The leading dimension of the array VL. LDVL >= 1; if *> JOBVL = 'V', LDVL >= N. *> \endverbatim *> *> \param[out] VR *> \verbatim *> VR is DOUBLE PRECISION array, dimension (LDVR,N) *> If JOBVR = 'V', the right eigenvectors v(j) are stored one *> after another in the columns of VR, in the same order *> as their eigenvalues. *> If JOBVR = 'N', VR is not referenced. *> If the j-th eigenvalue is real, then v(j) = VR(:,j), *> the j-th column of VR. *> If the j-th and (j+1)-st eigenvalues form a complex *> conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and *> v(j+1) = VR(:,j) - i*VR(:,j+1). *> \endverbatim *> *> \param[in] LDVR *> \verbatim *> LDVR is INTEGER *> The leading dimension of the array VR. LDVR >= 1, and if *> JOBVR = 'V', LDVR >= N. *> \endverbatim *> *> \param[out] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[out] IHI *> \verbatim *> IHI is INTEGER *> ILO and IHI are integer values determined when A was *> balanced. The balanced A(i,j) = 0 if I > J and *> J = 1,...,ILO-1 or I = IHI+1,...,N. *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is DOUBLE PRECISION array, dimension (N) *> Details of the permutations and scaling factors applied *> when balancing 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. *> \endverbatim *> *> \param[out] ABNRM *> \verbatim *> ABNRM is DOUBLE PRECISION *> The one-norm of the balanced matrix (the maximum *> of the sum of absolute values of elements of any column). *> \endverbatim *> *> \param[out] RCONDE *> \verbatim *> RCONDE is DOUBLE PRECISION array, dimension (N) *> RCONDE(j) is the reciprocal condition number of the j-th *> eigenvalue. *> \endverbatim *> *> \param[out] RCONDV *> \verbatim *> RCONDV is DOUBLE PRECISION array, dimension (N) *> RCONDV(j) is the reciprocal condition number of the j-th *> right eigenvector. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. If SENSE = 'N' or 'E', *> LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V', *> LWORK >= 3*N. If SENSE = 'V' or 'B', LWORK >= N*(N+6). *> For good performance, LWORK must generally be larger. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error *> message related to LWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (2*N-2) *> If SENSE = 'N' or 'E', not referenced. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: if INFO = i, the QR algorithm failed to compute all the *> eigenvalues, and no eigenvectors or condition numbers *> have been computed; elements 1:ILO-1 and i+1:N of WR *> and WI contain eigenvalues which have converged. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * * @precisions fortran d -> s * *> \ingroup doubleGEeigen * * ===================================================================== SUBROUTINE DGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, $ VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, $ RCONDE, RCONDV, WORK, LWORK, IWORK, INFO ) implicit none * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. CHARACTER BALANC, JOBVL, JOBVR, SENSE INTEGER IHI, ILO, INFO, LDA, LDVL, LDVR, LWORK, N DOUBLE PRECISION ABNRM * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), RCONDE( * ), RCONDV( * ), $ SCALE( * ), VL( LDVL, * ), VR( LDVR, * ), $ WI( * ), WORK( * ), WR( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, SCALEA, WANTVL, WANTVR, WNTSNB, WNTSNE, $ WNTSNN, WNTSNV CHARACTER JOB, SIDE INTEGER HSWORK, I, ICOND, IERR, ITAU, IWRK, K, $ LWORK_TREVC, MAXWRK, MINWRK, NOUT DOUBLE PRECISION ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM, $ SN * .. * .. Local Arrays .. LOGICAL SELECT( 1 ) DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. EXTERNAL DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLABAD, DLACPY, $ DLARTG, DLASCL, DORGHR, DROT, DSCAL, DTREVC3, $ DTRSNA, XERBLA * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX, ILAENV DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2, DNRM2 EXTERNAL LSAME, IDAMAX, ILAENV, DLAMCH, DLANGE, DLAPY2, $ DNRM2 * .. * .. Intrinsic Functions .. INTRINSIC MAX, SQRT * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) WANTVL = LSAME( JOBVL, 'V' ) WANTVR = LSAME( JOBVR, 'V' ) WNTSNN = LSAME( SENSE, 'N' ) WNTSNE = LSAME( SENSE, 'E' ) WNTSNV = LSAME( SENSE, 'V' ) WNTSNB = LSAME( SENSE, 'B' ) IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LSAME( BALANC, 'S' ) $ .OR. LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) ) ) $ THEN INFO = -1 ELSE IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN INFO = -2 ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN INFO = -3 ELSE IF( .NOT.( WNTSNN .OR. WNTSNE .OR. WNTSNB .OR. WNTSNV ) .OR. $ ( ( WNTSNE .OR. WNTSNB ) .AND. .NOT.( WANTVL .AND. $ WANTVR ) ) ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN INFO = -11 ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN INFO = -13 END IF * * Compute workspace * (Note: Comments in the code beginning "Workspace:" describe the * minimal amount of workspace needed at that point in the code, * as well as the preferred amount for good performance. * NB refers to the optimal block size for the immediately * following subroutine, as returned by ILAENV. * HSWORK refers to the workspace preferred by DHSEQR, as * calculated below. HSWORK is computed assuming ILO=1 and IHI=N, * the worst case.) * IF( INFO.EQ.0 ) THEN IF( N.EQ.0 ) THEN MINWRK = 1 MAXWRK = 1 ELSE MAXWRK = N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 ) * IF( WANTVL ) THEN CALL DTREVC3( 'L', 'B', SELECT, N, A, LDA, $ VL, LDVL, VR, LDVR, $ N, NOUT, WORK, -1, IERR ) LWORK_TREVC = INT( WORK(1) ) MAXWRK = MAX( MAXWRK, N + LWORK_TREVC ) CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VL, LDVL, $ WORK, -1, INFO ) ELSE IF( WANTVR ) THEN CALL DTREVC3( 'R', 'B', SELECT, N, A, LDA, $ VL, LDVL, VR, LDVR, $ N, NOUT, WORK, -1, IERR ) LWORK_TREVC = INT( WORK(1) ) MAXWRK = MAX( MAXWRK, N + LWORK_TREVC ) CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VR, LDVR, $ WORK, -1, INFO ) ELSE IF( WNTSNN ) THEN CALL DHSEQR( 'E', 'N', N, 1, N, A, LDA, WR, WI, VR, $ LDVR, WORK, -1, INFO ) ELSE CALL DHSEQR( 'S', 'N', N, 1, N, A, LDA, WR, WI, VR, $ LDVR, WORK, -1, INFO ) END IF END IF HSWORK = INT( WORK(1) ) * IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN MINWRK = 2*N IF( .NOT.WNTSNN ) $ MINWRK = MAX( MINWRK, N*N+6*N ) MAXWRK = MAX( MAXWRK, HSWORK ) IF( .NOT.WNTSNN ) $ MAXWRK = MAX( MAXWRK, N*N + 6*N ) ELSE MINWRK = 3*N IF( ( .NOT.WNTSNN ) .AND. ( .NOT.WNTSNE ) ) $ MINWRK = MAX( MINWRK, N*N + 6*N ) MAXWRK = MAX( MAXWRK, HSWORK ) MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'DORGHR', $ ' ', N, 1, N, -1 ) ) IF( ( .NOT.WNTSNN ) .AND. ( .NOT.WNTSNE ) ) $ MAXWRK = MAX( MAXWRK, N*N + 6*N ) MAXWRK = MAX( MAXWRK, 3*N ) END IF MAXWRK = MAX( MAXWRK, MINWRK ) END IF WORK( 1 ) = MAXWRK * IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN INFO = -21 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEEVX', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Get machine constants * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = SQRT( SMLNUM ) / EPS BIGNUM = ONE / SMLNUM * * Scale A if max element outside range [SMLNUM,BIGNUM] * ICOND = 0 ANRM = DLANGE( 'M', N, N, A, LDA, DUM ) SCALEA = .FALSE. IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN SCALEA = .TRUE. CSCALE = SMLNUM ELSE IF( ANRM.GT.BIGNUM ) THEN SCALEA = .TRUE. CSCALE = BIGNUM END IF IF( SCALEA ) $ CALL DLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR ) * * Balance the matrix and compute ABNRM * CALL DGEBAL( BALANC, N, A, LDA, ILO, IHI, SCALE, IERR ) ABNRM = DLANGE( '1', N, N, A, LDA, DUM ) IF( SCALEA ) THEN DUM( 1 ) = ABNRM CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, 1, 1, DUM, 1, IERR ) ABNRM = DUM( 1 ) END IF * * Reduce to upper Hessenberg form * (Workspace: need 2*N, prefer N+N*NB) * ITAU = 1 IWRK = ITAU + N CALL DGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ), $ LWORK-IWRK+1, IERR ) * IF( WANTVL ) THEN * * Want left eigenvectors * Copy Householder vectors to VL * SIDE = 'L' CALL DLACPY( 'L', N, N, A, LDA, VL, LDVL ) * * Generate orthogonal matrix in VL * (Workspace: need 2*N-1, prefer N+(N-1)*NB) * CALL DORGHR( N, ILO, IHI, VL, LDVL, WORK( ITAU ), WORK( IWRK ), $ LWORK-IWRK+1, IERR ) * * Perform QR iteration, accumulating Schur vectors in VL * (Workspace: need 1, prefer HSWORK (see comments) ) * IWRK = ITAU CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VL, LDVL, $ WORK( IWRK ), LWORK-IWRK+1, INFO ) * IF( WANTVR ) THEN * * Want left and right eigenvectors * Copy Schur vectors to VR * SIDE = 'B' CALL DLACPY( 'F', N, N, VL, LDVL, VR, LDVR ) END IF * ELSE IF( WANTVR ) THEN * * Want right eigenvectors * Copy Householder vectors to VR * SIDE = 'R' CALL DLACPY( 'L', N, N, A, LDA, VR, LDVR ) * * Generate orthogonal matrix in VR * (Workspace: need 2*N-1, prefer N+(N-1)*NB) * CALL DORGHR( N, ILO, IHI, VR, LDVR, WORK( ITAU ), WORK( IWRK ), $ LWORK-IWRK+1, IERR ) * * Perform QR iteration, accumulating Schur vectors in VR * (Workspace: need 1, prefer HSWORK (see comments) ) * IWRK = ITAU CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR, $ WORK( IWRK ), LWORK-IWRK+1, INFO ) * ELSE * * Compute eigenvalues only * If condition numbers desired, compute Schur form * IF( WNTSNN ) THEN JOB = 'E' ELSE JOB = 'S' END IF * * (Workspace: need 1, prefer HSWORK (see comments) ) * IWRK = ITAU CALL DHSEQR( JOB, 'N', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR, $ WORK( IWRK ), LWORK-IWRK+1, INFO ) END IF * * If INFO .NE. 0 from DHSEQR, then quit * IF( INFO.NE.0 ) $ GO TO 50 * IF( WANTVL .OR. WANTVR ) THEN * * Compute left and/or right eigenvectors * (Workspace: need 3*N, prefer N + 2*N*NB) * CALL DTREVC3( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, $ N, NOUT, WORK( IWRK ), LWORK-IWRK+1, IERR ) END IF * * Compute condition numbers if desired * (Workspace: need N*N+6*N unless SENSE = 'E') * IF( .NOT.WNTSNN ) THEN CALL DTRSNA( SENSE, 'A', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, $ RCONDE, RCONDV, N, NOUT, WORK( IWRK ), N, IWORK, $ ICOND ) END IF * IF( WANTVL ) THEN * * Undo balancing of left eigenvectors * CALL DGEBAK( BALANC, 'L', N, ILO, IHI, SCALE, N, VL, LDVL, $ IERR ) * * Normalize left eigenvectors and make largest component real * DO 20 I = 1, N IF( WI( I ).EQ.ZERO ) THEN SCL = ONE / DNRM2( N, VL( 1, I ), 1 ) CALL DSCAL( N, SCL, VL( 1, I ), 1 ) ELSE IF( WI( I ).GT.ZERO ) THEN SCL = ONE / DLAPY2( DNRM2( N, VL( 1, I ), 1 ), $ DNRM2( N, VL( 1, I+1 ), 1 ) ) CALL DSCAL( N, SCL, VL( 1, I ), 1 ) CALL DSCAL( N, SCL, VL( 1, I+1 ), 1 ) DO 10 K = 1, N WORK( K ) = VL( K, I )**2 + VL( K, I+1 )**2 10 CONTINUE K = IDAMAX( N, WORK, 1 ) CALL DLARTG( VL( K, I ), VL( K, I+1 ), CS, SN, R ) CALL DROT( N, VL( 1, I ), 1, VL( 1, I+1 ), 1, CS, SN ) VL( K, I+1 ) = ZERO END IF 20 CONTINUE END IF * IF( WANTVR ) THEN * * Undo balancing of right eigenvectors * CALL DGEBAK( BALANC, 'R', N, ILO, IHI, SCALE, N, VR, LDVR, $ IERR ) * * Normalize right eigenvectors and make largest component real * DO 40 I = 1, N IF( WI( I ).EQ.ZERO ) THEN SCL = ONE / DNRM2( N, VR( 1, I ), 1 ) CALL DSCAL( N, SCL, VR( 1, I ), 1 ) ELSE IF( WI( I ).GT.ZERO ) THEN SCL = ONE / DLAPY2( DNRM2( N, VR( 1, I ), 1 ), $ DNRM2( N, VR( 1, I+1 ), 1 ) ) CALL DSCAL( N, SCL, VR( 1, I ), 1 ) CALL DSCAL( N, SCL, VR( 1, I+1 ), 1 ) DO 30 K = 1, N WORK( K ) = VR( K, I )**2 + VR( K, I+1 )**2 30 CONTINUE K = IDAMAX( N, WORK, 1 ) CALL DLARTG( VR( K, I ), VR( K, I+1 ), CS, SN, R ) CALL DROT( N, VR( 1, I ), 1, VR( 1, I+1 ), 1, CS, SN ) VR( K, I+1 ) = ZERO END IF 40 CONTINUE END IF * * Undo scaling if necessary * 50 CONTINUE IF( SCALEA ) THEN CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WR( INFO+1 ), $ MAX( N-INFO, 1 ), IERR ) CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WI( INFO+1 ), $ MAX( N-INFO, 1 ), IERR ) IF( INFO.EQ.0 ) THEN IF( ( WNTSNV .OR. WNTSNB ) .AND. ICOND.EQ.0 ) $ CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, RCONDV, N, $ IERR ) ELSE CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WR, N, $ IERR ) CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N, $ IERR ) END IF END IF * WORK( 1 ) = MAXWRK RETURN * * End of DGEEVX * END *> \brief DGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEGS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR, * ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, * LWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBVSL, JOBVSR * INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), * $ B( LDB, * ), BETA( * ), VSL( LDVSL, * ), * $ VSR( LDVSR, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> This routine is deprecated and has been replaced by routine DGGES. *> *> DGEGS computes the eigenvalues, real Schur form, and, optionally, *> left and or/right Schur vectors of a real matrix pair (A,B). *> Given two square matrices A and B, the generalized real Schur *> factorization has the form *> *> A = Q*S*Z**T, B = Q*T*Z**T *> *> where Q and Z are orthogonal matrices, T is upper triangular, and S *> is an upper quasi-triangular matrix with 1-by-1 and 2-by-2 diagonal *> blocks, the 2-by-2 blocks corresponding to complex conjugate pairs *> of eigenvalues of (A,B). The columns of Q are the left Schur vectors *> and the columns of Z are the right Schur vectors. *> *> If only the eigenvalues of (A,B) are needed, the driver routine *> DGEGV should be used instead. See DGEGV for a description of the *> eigenvalues of the generalized nonsymmetric eigenvalue problem *> (GNEP). *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBVSL *> \verbatim *> JOBVSL is CHARACTER*1 *> = 'N': do not compute the left Schur vectors; *> = 'V': compute the left Schur vectors (returned in VSL). *> \endverbatim *> *> \param[in] JOBVSR *> \verbatim *> JOBVSR is CHARACTER*1 *> = 'N': do not compute the right Schur vectors; *> = 'V': compute the right Schur vectors (returned in VSR). *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A, B, VSL, and VSR. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA, N) *> On entry, the matrix A. *> On exit, the upper quasi-triangular matrix S from the *> generalized real Schur factorization. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB, N) *> On entry, the matrix B. *> On exit, the upper triangular matrix T from the generalized *> real Schur factorization. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] ALPHAR *> \verbatim *> ALPHAR is DOUBLE PRECISION array, dimension (N) *> The real parts of each scalar alpha defining an eigenvalue *> of GNEP. *> \endverbatim *> *> \param[out] ALPHAI *> \verbatim *> ALPHAI is 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). *> \endverbatim *> *> \param[out] BETA *> \verbatim *> BETA is 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. *> \endverbatim *> *> \param[out] VSL *> \verbatim *> VSL is DOUBLE PRECISION array, dimension (LDVSL,N) *> If JOBVSL = 'V', the matrix of left Schur vectors Q. *> Not referenced if JOBVSL = 'N'. *> \endverbatim *> *> \param[in] LDVSL *> \verbatim *> LDVSL is INTEGER *> The leading dimension of the matrix VSL. LDVSL >=1, and *> if JOBVSL = 'V', LDVSL >= N. *> \endverbatim *> *> \param[out] VSR *> \verbatim *> VSR is DOUBLE PRECISION array, dimension (LDVSR,N) *> If JOBVSR = 'V', the matrix of right Schur vectors Z. *> Not referenced if JOBVSR = 'N'. *> \endverbatim *> *> \param[in] LDVSR *> \verbatim *> LDVSR is INTEGER *> The leading dimension of the matrix VSR. LDVSR >= 1, and *> if JOBVSR = 'V', LDVSR >= N. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= max(1,4*N). *> For good performance, LWORK must generally be larger. *> To compute the optimal value of LWORK, call ILAENV to get *> blocksizes (for DGEQRF, DORMQR, and DORGQR.) Then compute: *> NB -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR *> The optimal LWORK is 2*N + N*(NB+1). *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error *> message related to LWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> = 1,...,N: *> The QZ iteration failed. (A,B) are not in Schur *> form, but ALPHAR(j), ALPHAI(j), and BETA(j) should *> be correct for j=INFO+1,...,N. *> > N: errors that usually indicate LAPACK problems: *> =N+1: error return from DGGBAL *> =N+2: error return from DGEQRF *> =N+3: error return from DORMQR *> =N+4: error return from DORGQR *> =N+5: error return from DGGHRD *> =N+6: error return from DHGEQZ (other than failed *> iteration) *> =N+7: error return from DGGBAK (computing VSL) *> =N+8: error return from DGGBAK (computing VSR) *> =N+9: error return from DLASCL (various places) *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEeigen * * ===================================================================== SUBROUTINE DGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR, $ ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, $ LWORK, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER JOBVSL, JOBVSR INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), $ B( LDB, * ), BETA( * ), VSL( LDVSL, * ), $ VSR( LDVSR, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL ILASCL, ILBSCL, ILVSL, ILVSR, LQUERY INTEGER ICOLS, IHI, IINFO, IJOBVL, IJOBVR, ILEFT, ILO, $ IRIGHT, IROWS, ITAU, IWORK, LOPT, LWKMIN, $ LWKOPT, NB, NB1, NB2, NB3 DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, $ SAFMIN, SMLNUM * .. * .. External Subroutines .. EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLACPY, $ DLASCL, DLASET, DORGQR, DORMQR, XERBLA * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE * .. * .. Intrinsic Functions .. INTRINSIC INT, MAX * .. * .. Executable Statements .. * * Decode the input arguments * IF( LSAME( JOBVSL, 'N' ) ) THEN IJOBVL = 1 ILVSL = .FALSE. ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN IJOBVL = 2 ILVSL = .TRUE. ELSE IJOBVL = -1 ILVSL = .FALSE. END IF * IF( LSAME( JOBVSR, 'N' ) ) THEN IJOBVR = 1 ILVSR = .FALSE. ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN IJOBVR = 2 ILVSR = .TRUE. ELSE IJOBVR = -1 ILVSR = .FALSE. END IF * * Test the input arguments * LWKMIN = MAX( 4*N, 1 ) LWKOPT = LWKMIN WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) INFO = 0 IF( IJOBVL.LE.0 ) THEN INFO = -1 ELSE IF( IJOBVR.LE.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN INFO = -12 ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN INFO = -14 ELSE IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN INFO = -16 END IF * IF( INFO.EQ.0 ) THEN NB1 = ILAENV( 1, 'DGEQRF', ' ', N, N, -1, -1 ) NB2 = ILAENV( 1, 'DORMQR', ' ', N, N, N, -1 ) NB3 = ILAENV( 1, 'DORGQR', ' ', N, N, N, -1 ) NB = MAX( NB1, NB2, NB3 ) LOPT = 2*N + N*( NB+1 ) WORK( 1 ) = LOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEGS ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Get machine constants * EPS = DLAMCH( 'E' )*DLAMCH( 'B' ) SAFMIN = DLAMCH( 'S' ) SMLNUM = N*SAFMIN / EPS BIGNUM = ONE / SMLNUM * * Scale A if max element outside range [SMLNUM,BIGNUM] * ANRM = DLANGE( 'M', N, N, A, LDA, WORK ) ILASCL = .FALSE. IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN ANRMTO = SMLNUM ILASCL = .TRUE. ELSE IF( ANRM.GT.BIGNUM ) THEN ANRMTO = BIGNUM ILASCL = .TRUE. END IF * IF( ILASCL ) THEN CALL DLASCL( 'G', -1, -1, ANRM, ANRMTO, N, N, A, LDA, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF END IF * * Scale B if max element outside range [SMLNUM,BIGNUM] * BNRM = DLANGE( 'M', N, N, B, LDB, WORK ) ILBSCL = .FALSE. IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN BNRMTO = SMLNUM ILBSCL = .TRUE. ELSE IF( BNRM.GT.BIGNUM ) THEN BNRMTO = BIGNUM ILBSCL = .TRUE. END IF * IF( ILBSCL ) THEN CALL DLASCL( 'G', -1, -1, BNRM, BNRMTO, N, N, B, LDB, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF END IF * * Permute the matrix to make it more nearly triangular * Workspace layout: (2*N words -- "work..." not actually used) * left_permutation, right_permutation, work... * ILEFT = 1 IRIGHT = N + 1 IWORK = IRIGHT + N CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ), $ WORK( IRIGHT ), WORK( IWORK ), IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 1 GO TO 10 END IF * * Reduce B to triangular form, and initialize VSL and/or VSR * Workspace layout: ("work..." must have at least N words) * left_permutation, right_permutation, tau, work... * IROWS = IHI + 1 - ILO ICOLS = N + 1 - ILO ITAU = IWORK IWORK = ITAU + IROWS CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), $ WORK( IWORK ), LWORK+1-IWORK, IINFO ) IF( IINFO.GE.0 ) $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 ) IF( IINFO.NE.0 ) THEN INFO = N + 2 GO TO 10 END IF * CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWORK ), $ LWORK+1-IWORK, IINFO ) IF( IINFO.GE.0 ) $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 ) IF( IINFO.NE.0 ) THEN INFO = N + 3 GO TO 10 END IF * IF( ILVSL ) THEN CALL DLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL ) CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, $ VSL( ILO+1, ILO ), LDVSL ) CALL DORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL, $ WORK( ITAU ), WORK( IWORK ), LWORK+1-IWORK, $ IINFO ) IF( IINFO.GE.0 ) $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 ) IF( IINFO.NE.0 ) THEN INFO = N + 4 GO TO 10 END IF END IF * IF( ILVSR ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR ) * * Reduce to generalized Hessenberg form * CALL DGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL, $ LDVSL, VSR, LDVSR, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 5 GO TO 10 END IF * * Perform QZ algorithm, computing Schur vectors if desired * Workspace layout: ("work..." must have at least 1 word) * left_permutation, right_permutation, work... * IWORK = ITAU CALL DHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, $ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, $ WORK( IWORK ), LWORK+1-IWORK, IINFO ) IF( IINFO.GE.0 ) $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 ) IF( IINFO.NE.0 ) THEN IF( IINFO.GT.0 .AND. IINFO.LE.N ) THEN INFO = IINFO ELSE IF( IINFO.GT.N .AND. IINFO.LE.2*N ) THEN INFO = IINFO - N ELSE INFO = N + 6 END IF GO TO 10 END IF * * Apply permutation to VSL and VSR * IF( ILVSL ) THEN CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ), $ WORK( IRIGHT ), N, VSL, LDVSL, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 7 GO TO 10 END IF END IF IF( ILVSR ) THEN CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ), $ WORK( IRIGHT ), N, VSR, LDVSR, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 8 GO TO 10 END IF END IF * * Undo scaling * IF( ILASCL ) THEN CALL DLASCL( 'H', -1, -1, ANRMTO, ANRM, N, N, A, LDA, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF CALL DLASCL( 'G', -1, -1, ANRMTO, ANRM, N, 1, ALPHAR, N, $ IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF CALL DLASCL( 'G', -1, -1, ANRMTO, ANRM, N, 1, ALPHAI, N, $ IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF END IF * IF( ILBSCL ) THEN CALL DLASCL( 'U', -1, -1, BNRMTO, BNRM, N, N, B, LDB, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF CALL DLASCL( 'G', -1, -1, BNRMTO, BNRM, N, 1, BETA, N, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF END IF * 10 CONTINUE WORK( 1 ) = LWKOPT * RETURN * * End of DGEGS * END *> \brief DGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEGV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, * BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBVL, JOBVR * INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), * $ B( LDB, * ), BETA( * ), VL( LDVL, * ), * $ VR( LDVR, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> This routine is deprecated and has been replaced by routine DGGEV. *> *> DGEGV computes the eigenvalues and, optionally, the left and/or right *> eigenvectors of a real matrix pair (A,B). *> Given two square matrices A and B, *> the generalized nonsymmetric eigenvalue problem (GNEP) is to find the *> eigenvalues lambda and corresponding (non-zero) eigenvectors x such *> that *> *> A*x = lambda*B*x. *> *> An alternate form is to find the eigenvalues mu and corresponding *> eigenvectors y such that *> *> mu*A*y = B*y. *> *> These two forms are equivalent with mu = 1/lambda and x = y if *> neither lambda nor mu is zero. In order to deal with the case that *> lambda or mu is zero or small, two values alpha and beta are returned *> for each eigenvalue, such that lambda = alpha/beta and *> mu = beta/alpha. *> *> The vectors x and y in the above equations are right eigenvectors of *> the matrix pair (A,B). Vectors u and v satisfying *> *> u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B *> *> are left eigenvectors of (A,B). *> *> Note: this routine performs "full balancing" on A and B *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBVL *> \verbatim *> JOBVL is CHARACTER*1 *> = 'N': do not compute the left generalized eigenvectors; *> = 'V': compute the left generalized eigenvectors (returned *> in VL). *> \endverbatim *> *> \param[in] JOBVR *> \verbatim *> JOBVR is CHARACTER*1 *> = 'N': do not compute the right generalized eigenvectors; *> = 'V': compute the right generalized eigenvectors (returned *> in VR). *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A, B, VL, and VR. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA, N) *> On entry, the matrix A. *> If JOBVL = 'V' or JOBVR = 'V', then on exit A *> contains the real Schur form of A from the generalized Schur *> factorization of the pair (A,B) after balancing. *> If no eigenvectors were computed, then only the diagonal *> blocks from the Schur form will be correct. See DGGHRD and *> DHGEQZ for details. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB, N) *> On entry, the matrix B. *> If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the *> upper triangular matrix obtained from B in the generalized *> Schur factorization of the pair (A,B) after balancing. *> If no eigenvectors were computed, then only those elements of *> B corresponding to the diagonal blocks from the Schur form of *> A will be correct. See DGGHRD and DHGEQZ for details. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] ALPHAR *> \verbatim *> ALPHAR is DOUBLE PRECISION array, dimension (N) *> The real parts of each scalar alpha defining an eigenvalue of *> GNEP. *> \endverbatim *> *> \param[out] ALPHAI *> \verbatim *> ALPHAI is 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). *> \endverbatim *> *> \param[out] BETA *> \verbatim *> BETA is 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. *> \endverbatim *> *> \param[out] VL *> \verbatim *> VL is DOUBLE PRECISION array, dimension (LDVL,N) *> If JOBVL = 'V', the left eigenvectors u(j) are stored *> in the columns of VL, in the same order as their eigenvalues. *> If the j-th eigenvalue is real, then u(j) = VL(:,j). *> If the j-th and (j+1)-st eigenvalues form a complex conjugate *> pair, then *> u(j) = VL(:,j) + i*VL(:,j+1) *> and *> u(j+1) = VL(:,j) - i*VL(:,j+1). *> *> Each eigenvector is scaled so that its largest component has *> abs(real part) + abs(imag. part) = 1, except for eigenvectors *> corresponding to an eigenvalue with alpha = beta = 0, which *> are set to zero. *> Not referenced if JOBVL = 'N'. *> \endverbatim *> *> \param[in] LDVL *> \verbatim *> LDVL is INTEGER *> The leading dimension of the matrix VL. LDVL >= 1, and *> if JOBVL = 'V', LDVL >= N. *> \endverbatim *> *> \param[out] VR *> \verbatim *> VR is DOUBLE PRECISION array, dimension (LDVR,N) *> If JOBVR = 'V', the right eigenvectors x(j) are stored *> in the columns of VR, in the same order as their eigenvalues. *> If the j-th eigenvalue is real, then x(j) = VR(:,j). *> If the j-th and (j+1)-st eigenvalues form a complex conjugate *> pair, then *> x(j) = VR(:,j) + i*VR(:,j+1) *> and *> x(j+1) = VR(:,j) - i*VR(:,j+1). *> *> Each eigenvector is scaled so that its largest component has *> abs(real part) + abs(imag. part) = 1, except for eigenvalues *> corresponding to an eigenvalue with alpha = beta = 0, which *> are set to zero. *> Not referenced if JOBVR = 'N'. *> \endverbatim *> *> \param[in] LDVR *> \verbatim *> LDVR is INTEGER *> The leading dimension of the matrix VR. LDVR >= 1, and *> if JOBVR = 'V', LDVR >= N. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= max(1,8*N). *> For good performance, LWORK must generally be larger. *> To compute the optimal value of LWORK, call ILAENV to get *> blocksizes (for DGEQRF, DORMQR, and DORGQR.) Then compute: *> NB -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR; *> The optimal LWORK is: *> 2*N + MAX( 6*N, N*(NB+1) ). *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error *> message related to LWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> = 1,...,N: *> The QZ iteration failed. No eigenvectors have been *> calculated, but ALPHAR(j), ALPHAI(j), and BETA(j) *> should be correct for j=INFO+1,...,N. *> > N: errors that usually indicate LAPACK problems: *> =N+1: error return from DGGBAL *> =N+2: error return from DGEQRF *> =N+3: error return from DORMQR *> =N+4: error return from DORGQR *> =N+5: error return from DGGHRD *> =N+6: error return from DHGEQZ (other than failed *> iteration) *> =N+7: error return from DTGEVC *> =N+8: error return from DGGBAK (computing VL) *> =N+9: error return from DGGBAK (computing VR) *> =N+10: error return from DLASCL (various calls) *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEeigen * *> \par Further Details: * ===================== *> *> \verbatim *> *> Balancing *> --------- *> *> This driver calls DGGBAL to both permute and scale rows and columns *> of A and B. The permutations PL and PR are chosen so that PL*A*PR *> and PL*B*R will be upper triangular except for the diagonal blocks *> A(i:j,i:j) and B(i:j,i:j), with i and j as close together as *> possible. The diagonal scaling matrices DL and DR are chosen so *> that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to *> one (except for the elements that start out zero.) *> *> After the eigenvalues and eigenvectors of the balanced matrices *> have been computed, DGGBAK transforms the eigenvectors back to what *> they would have been (in perfect arithmetic) if they had not been *> balanced. *> *> Contents of A and B on Exit *> -------- -- - --- - -- ---- *> *> If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or *> both), then on exit the arrays A and B will contain the real Schur *> form[*] of the "balanced" versions of A and B. If no eigenvectors *> are computed, then only the diagonal blocks will be correct. *> *> [*] See DHGEQZ, DGEGS, or read the book "Matrix Computations", *> by Golub & van Loan, pub. by Johns Hopkins U. Press. *> \endverbatim *> * ===================================================================== SUBROUTINE DGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, $ BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), $ B( LDB, * ), BETA( * ), VL( LDVL, * ), $ VR( LDVR, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL ILIMIT, ILV, ILVL, ILVR, LQUERY CHARACTER CHTEMP INTEGER ICOLS, IHI, IINFO, IJOBVL, IJOBVR, ILEFT, ILO, $ IN, IRIGHT, IROWS, ITAU, IWORK, JC, JR, LOPT, $ LWKMIN, LWKOPT, NB, NB1, NB2, NB3 DOUBLE PRECISION ABSAI, ABSAR, ABSB, ANRM, ANRM1, ANRM2, BNRM, $ BNRM1, BNRM2, EPS, ONEPLS, SAFMAX, SAFMIN, $ SALFAI, SALFAR, SBETA, SCALE, TEMP * .. * .. Local Arrays .. LOGICAL LDUMMA( 1 ) * .. * .. External Subroutines .. EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLACPY, $ DLASCL, DLASET, DORGQR, DORMQR, DTGEVC, XERBLA * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE * .. * .. Intrinsic Functions .. INTRINSIC ABS, INT, MAX * .. * .. Executable Statements .. * * Decode the input arguments * IF( LSAME( JOBVL, 'N' ) ) THEN IJOBVL = 1 ILVL = .FALSE. ELSE IF( LSAME( JOBVL, 'V' ) ) THEN IJOBVL = 2 ILVL = .TRUE. ELSE IJOBVL = -1 ILVL = .FALSE. END IF * IF( LSAME( JOBVR, 'N' ) ) THEN IJOBVR = 1 ILVR = .FALSE. ELSE IF( LSAME( JOBVR, 'V' ) ) THEN IJOBVR = 2 ILVR = .TRUE. ELSE IJOBVR = -1 ILVR = .FALSE. END IF ILV = ILVL .OR. ILVR * * Test the input arguments * LWKMIN = MAX( 8*N, 1 ) LWKOPT = LWKMIN WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) INFO = 0 IF( IJOBVL.LE.0 ) THEN INFO = -1 ELSE IF( IJOBVR.LE.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN INFO = -12 ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN INFO = -14 ELSE IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN INFO = -16 END IF * IF( INFO.EQ.0 ) THEN NB1 = ILAENV( 1, 'DGEQRF', ' ', N, N, -1, -1 ) NB2 = ILAENV( 1, 'DORMQR', ' ', N, N, N, -1 ) NB3 = ILAENV( 1, 'DORGQR', ' ', N, N, N, -1 ) NB = MAX( NB1, NB2, NB3 ) LOPT = 2*N + MAX( 6*N, N*( NB+1 ) ) WORK( 1 ) = LOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEGV ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Get machine constants * EPS = DLAMCH( 'E' )*DLAMCH( 'B' ) SAFMIN = DLAMCH( 'S' ) SAFMIN = SAFMIN + SAFMIN SAFMAX = ONE / SAFMIN ONEPLS = ONE + ( 4*EPS ) * * Scale A * ANRM = DLANGE( 'M', N, N, A, LDA, WORK ) ANRM1 = ANRM ANRM2 = ONE IF( ANRM.LT.ONE ) THEN IF( SAFMAX*ANRM.LT.ONE ) THEN ANRM1 = SAFMIN ANRM2 = SAFMAX*ANRM END IF END IF * IF( ANRM.GT.ZERO ) THEN CALL DLASCL( 'G', -1, -1, ANRM, ONE, N, N, A, LDA, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 10 RETURN END IF END IF * * Scale B * BNRM = DLANGE( 'M', N, N, B, LDB, WORK ) BNRM1 = BNRM BNRM2 = ONE IF( BNRM.LT.ONE ) THEN IF( SAFMAX*BNRM.LT.ONE ) THEN BNRM1 = SAFMIN BNRM2 = SAFMAX*BNRM END IF END IF * IF( BNRM.GT.ZERO ) THEN CALL DLASCL( 'G', -1, -1, BNRM, ONE, N, N, B, LDB, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 10 RETURN END IF END IF * * Permute the matrix to make it more nearly triangular * Workspace layout: (8*N words -- "work" requires 6*N words) * left_permutation, right_permutation, work... * ILEFT = 1 IRIGHT = N + 1 IWORK = IRIGHT + N CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ), $ WORK( IRIGHT ), WORK( IWORK ), IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 1 GO TO 120 END IF * * Reduce B to triangular form, and initialize VL and/or VR * Workspace layout: ("work..." must have at least N words) * left_permutation, right_permutation, tau, work... * IROWS = IHI + 1 - ILO IF( ILV ) THEN ICOLS = N + 1 - ILO ELSE ICOLS = IROWS END IF ITAU = IWORK IWORK = ITAU + IROWS CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), $ WORK( IWORK ), LWORK+1-IWORK, IINFO ) IF( IINFO.GE.0 ) $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 ) IF( IINFO.NE.0 ) THEN INFO = N + 2 GO TO 120 END IF * CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWORK ), $ LWORK+1-IWORK, IINFO ) IF( IINFO.GE.0 ) $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 ) IF( IINFO.NE.0 ) THEN INFO = N + 3 GO TO 120 END IF * IF( ILVL ) THEN CALL DLASET( 'Full', N, N, ZERO, ONE, VL, LDVL ) CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, $ VL( ILO+1, ILO ), LDVL ) CALL DORGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL, $ WORK( ITAU ), WORK( IWORK ), LWORK+1-IWORK, $ IINFO ) IF( IINFO.GE.0 ) $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 ) IF( IINFO.NE.0 ) THEN INFO = N + 4 GO TO 120 END IF END IF * IF( ILVR ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, VR, LDVR ) * * Reduce to generalized Hessenberg form * IF( ILV ) THEN * * Eigenvectors requested -- work on whole matrix. * CALL DGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL, $ LDVL, VR, LDVR, IINFO ) ELSE CALL DGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA, $ B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IINFO ) END IF IF( IINFO.NE.0 ) THEN INFO = N + 5 GO TO 120 END IF * * Perform QZ algorithm * Workspace layout: ("work..." must have at least 1 word) * left_permutation, right_permutation, work... * IWORK = ITAU IF( ILV ) THEN CHTEMP = 'S' ELSE CHTEMP = 'E' END IF CALL DHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, $ ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, $ WORK( IWORK ), LWORK+1-IWORK, IINFO ) IF( IINFO.GE.0 ) $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 ) IF( IINFO.NE.0 ) THEN IF( IINFO.GT.0 .AND. IINFO.LE.N ) THEN INFO = IINFO ELSE IF( IINFO.GT.N .AND. IINFO.LE.2*N ) THEN INFO = IINFO - N ELSE INFO = N + 6 END IF GO TO 120 END IF * IF( ILV ) THEN * * Compute Eigenvectors (DTGEVC requires 6*N words of workspace) * IF( ILVL ) THEN IF( ILVR ) THEN CHTEMP = 'B' ELSE CHTEMP = 'L' END IF ELSE CHTEMP = 'R' END IF * CALL DTGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL, LDVL, $ VR, LDVR, N, IN, WORK( IWORK ), IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 7 GO TO 120 END IF * * Undo balancing on VL and VR, rescale * IF( ILVL ) THEN CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ), $ WORK( IRIGHT ), N, VL, LDVL, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 8 GO TO 120 END IF DO 50 JC = 1, N IF( ALPHAI( JC ).LT.ZERO ) $ GO TO 50 TEMP = ZERO IF( ALPHAI( JC ).EQ.ZERO ) THEN DO 10 JR = 1, N TEMP = MAX( TEMP, ABS( VL( JR, JC ) ) ) 10 CONTINUE ELSE DO 20 JR = 1, N TEMP = MAX( TEMP, ABS( VL( JR, JC ) )+ $ ABS( VL( JR, JC+1 ) ) ) 20 CONTINUE END IF IF( TEMP.LT.SAFMIN ) $ GO TO 50 TEMP = ONE / TEMP IF( ALPHAI( JC ).EQ.ZERO ) THEN DO 30 JR = 1, N VL( JR, JC ) = VL( JR, JC )*TEMP 30 CONTINUE ELSE DO 40 JR = 1, N VL( JR, JC ) = VL( JR, JC )*TEMP VL( JR, JC+1 ) = VL( JR, JC+1 )*TEMP 40 CONTINUE END IF 50 CONTINUE END IF IF( ILVR ) THEN CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ), $ WORK( IRIGHT ), N, VR, LDVR, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 GO TO 120 END IF DO 100 JC = 1, N IF( ALPHAI( JC ).LT.ZERO ) $ GO TO 100 TEMP = ZERO IF( ALPHAI( JC ).EQ.ZERO ) THEN DO 60 JR = 1, N TEMP = MAX( TEMP, ABS( VR( JR, JC ) ) ) 60 CONTINUE ELSE DO 70 JR = 1, N TEMP = MAX( TEMP, ABS( VR( JR, JC ) )+ $ ABS( VR( JR, JC+1 ) ) ) 70 CONTINUE END IF IF( TEMP.LT.SAFMIN ) $ GO TO 100 TEMP = ONE / TEMP IF( ALPHAI( JC ).EQ.ZERO ) THEN DO 80 JR = 1, N VR( JR, JC ) = VR( JR, JC )*TEMP 80 CONTINUE ELSE DO 90 JR = 1, N VR( JR, JC ) = VR( JR, JC )*TEMP VR( JR, JC+1 ) = VR( JR, JC+1 )*TEMP 90 CONTINUE END IF 100 CONTINUE END IF * * End of eigenvector calculation * END IF * * Undo scaling in alpha, beta * * Note: this does not give the alpha and beta for the unscaled * problem. * * Un-scaling is limited to avoid underflow in alpha and beta * if they are significant. * DO 110 JC = 1, N ABSAR = ABS( ALPHAR( JC ) ) ABSAI = ABS( ALPHAI( JC ) ) ABSB = ABS( BETA( JC ) ) SALFAR = ANRM*ALPHAR( JC ) SALFAI = ANRM*ALPHAI( JC ) SBETA = BNRM*BETA( JC ) ILIMIT = .FALSE. SCALE = ONE * * Check for significant underflow in ALPHAI * IF( ABS( SALFAI ).LT.SAFMIN .AND. ABSAI.GE. $ MAX( SAFMIN, EPS*ABSAR, EPS*ABSB ) ) THEN ILIMIT = .TRUE. SCALE = ( ONEPLS*SAFMIN / ANRM1 ) / $ MAX( ONEPLS*SAFMIN, ANRM2*ABSAI ) * ELSE IF( SALFAI.EQ.ZERO ) THEN * * If insignificant underflow in ALPHAI, then make the * conjugate eigenvalue real. * IF( ALPHAI( JC ).LT.ZERO .AND. JC.GT.1 ) THEN ALPHAI( JC-1 ) = ZERO ELSE IF( ALPHAI( JC ).GT.ZERO .AND. JC.LT.N ) THEN ALPHAI( JC+1 ) = ZERO END IF END IF * * Check for significant underflow in ALPHAR * IF( ABS( SALFAR ).LT.SAFMIN .AND. ABSAR.GE. $ MAX( SAFMIN, EPS*ABSAI, EPS*ABSB ) ) THEN ILIMIT = .TRUE. SCALE = MAX( SCALE, ( ONEPLS*SAFMIN / ANRM1 ) / $ MAX( ONEPLS*SAFMIN, ANRM2*ABSAR ) ) END IF * * Check for significant underflow in BETA * IF( ABS( SBETA ).LT.SAFMIN .AND. ABSB.GE. $ MAX( SAFMIN, EPS*ABSAR, EPS*ABSAI ) ) THEN ILIMIT = .TRUE. SCALE = MAX( SCALE, ( ONEPLS*SAFMIN / BNRM1 ) / $ MAX( ONEPLS*SAFMIN, BNRM2*ABSB ) ) END IF * * Check for possible overflow when limiting scaling * IF( ILIMIT ) THEN TEMP = ( SCALE*SAFMIN )*MAX( ABS( SALFAR ), ABS( SALFAI ), $ ABS( SBETA ) ) IF( TEMP.GT.ONE ) $ SCALE = SCALE / TEMP IF( SCALE.LT.ONE ) $ ILIMIT = .FALSE. END IF * * Recompute un-scaled ALPHAR, ALPHAI, BETA if necessary. * IF( ILIMIT ) THEN SALFAR = ( SCALE*ALPHAR( JC ) )*ANRM SALFAI = ( SCALE*ALPHAI( JC ) )*ANRM SBETA = ( SCALE*BETA( JC ) )*BNRM END IF ALPHAR( JC ) = SALFAR ALPHAI( JC ) = SALFAI BETA( JC ) = SBETA 110 CONTINUE * 120 CONTINUE WORK( 1 ) = LWKOPT * RETURN * * End of DGEGV * END *> \brief \b DGEHD2 reduces a general square matrix to upper Hessenberg form using an unblocked algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEHD2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) * * .. Scalar Arguments .. * INTEGER IHI, ILO, INFO, LDA, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGEHD2 reduces a real general matrix A to upper Hessenberg form H by *> an orthogonal similarity transformation: Q**T * A * Q = H . *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is 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). *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is 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. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (N-1) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> 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**T *> *> 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). *> \endverbatim *> * ===================================================================== SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. 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 *> \brief \b DGEHRD * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEHRD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * INTEGER IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGEHRD reduces a real general matrix A to upper Hessenberg form H by *> an orthogonal similarity transformation: Q**T * A * Q = H . *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is 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. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is 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. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is 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. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (LWORK) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The length of the array WORK. LWORK >= max(1,N). *> For good performance, LWORK should generally be larger. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error *> message related to LWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> 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**T *> *> 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 (2006). (See DLAHR2.) *> \endverbatim *> * ===================================================================== SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT, TSIZE PARAMETER ( NBMAX = 64, LDT = NBMAX+1, $ TSIZE = LDT*NBMAX ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, $ ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWT, J, LDWORK, LWKOPT, NB, $ NBMIN, NH, NX DOUBLE PRECISION EI * .. * .. 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 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.EQ.0 ) THEN * * Compute the workspace requirements * NB = MIN( NBMAX, ILAENV( 1, 'DGEHRD', ' ', N, ILO, IHI, -1 ) ) LWKOPT = N*NB + TSIZE WORK( 1 ) = LWKOPT 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 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 * IF( LWORK.LT.N*NB+TSIZE ) 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 + TSIZE) ) THEN NB = (LWORK-TSIZE) / 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 * IWT = 1 + N*NB 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**T * which performs the reduction, and also the matrix Y = A*V*T * CALL DLAHR2( IHI, I, IB, A( 1, I ), LDA, TAU( I ), $ WORK( IWT ), LDT, WORK, LDWORK ) * * Apply the block reflector H to A(1:ihi,i+ib:ihi) from the * right, computing A := A - Y * V**T. 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, $ WORK( IWT ), 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 ) = LWKOPT * RETURN * * End of DGEHRD * END *> \brief \b DGEJSV * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEJSV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, * M, N, A, LDA, SVA, U, LDU, V, LDV, * WORK, LWORK, IWORK, INFO ) * * .. Scalar Arguments .. * IMPLICIT NONE * INTEGER INFO, LDA, LDU, LDV, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), SVA( N ), U( LDU, * ), V( LDV, * ), * $ WORK( LWORK ) * INTEGER IWORK( * ) * CHARACTER*1 JOBA, JOBP, JOBR, JOBT, JOBU, JOBV * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGEJSV computes the singular value decomposition (SVD) of a real M-by-N *> matrix [A], where M >= N. The SVD of [A] is written as *> *> [A] = [U] * [SIGMA] * [V]^t, *> *> where [SIGMA] is an N-by-N (M-by-N) matrix which is zero except for its N *> diagonal elements, [U] is an M-by-N (or M-by-M) orthonormal matrix, and *> [V] is an N-by-N orthogonal matrix. The diagonal elements of [SIGMA] are *> the singular values of [A]. The columns of [U] and [V] are the left and *> the right singular vectors of [A], respectively. The matrices [U] and [V] *> are computed and stored in the arrays U and V, respectively. The diagonal *> of [SIGMA] is computed and stored in the array SVA. *> DGEJSV can sometimes compute tiny singular values and their singular vectors much *> more accurately than other SVD routines, see below under Further Details. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBA *> \verbatim *> JOBA is CHARACTER*1 *> Specifies the level of accuracy: *> = 'C': This option works well (high relative accuracy) if A = B * D, *> with well-conditioned B and arbitrary diagonal matrix D. *> The accuracy cannot be spoiled by COLUMN scaling. The *> accuracy of the computed output depends on the condition of *> B, and the procedure aims at the best theoretical accuracy. *> The relative error max_{i=1:N}|d sigma_i| / sigma_i is *> bounded by f(M,N)*epsilon* cond(B), independent of D. *> The input matrix is preprocessed with the QRF with column *> pivoting. This initial preprocessing and preconditioning by *> a rank revealing QR factorization is common for all values of *> JOBA. Additional actions are specified as follows: *> = 'E': Computation as with 'C' with an additional estimate of the *> condition number of B. It provides a realistic error bound. *> = 'F': If A = D1 * C * D2 with ill-conditioned diagonal scalings *> D1, D2, and well-conditioned matrix C, this option gives *> higher accuracy than the 'C' option. If the structure of the *> input matrix is not known, and relative accuracy is *> desirable, then this option is advisable. The input matrix A *> is preprocessed with QR factorization with FULL (row and *> column) pivoting. *> = 'G' Computation as with 'F' with an additional estimate of the *> condition number of B, where A=D*B. If A has heavily weighted *> rows, then using this condition number gives too pessimistic *> error bound. *> = 'A': Small singular values are the noise and the matrix is treated *> as numerically rank deficient. The error in the computed *> singular values is bounded by f(m,n)*epsilon*||A||. *> The computed SVD A = U * S * V^t restores A up to *> f(m,n)*epsilon*||A||. *> This gives the procedure the licence to discard (set to zero) *> all singular values below N*epsilon*||A||. *> = 'R': Similar as in 'A'. Rank revealing property of the initial *> QR factorization is used do reveal (using triangular factor) *> a gap sigma_{r+1} < epsilon * sigma_r in which case the *> numerical RANK is declared to be r. The SVD is computed with *> absolute error bounds, but more accurately than with 'A'. *> \endverbatim *> *> \param[in] JOBU *> \verbatim *> JOBU is CHARACTER*1 *> Specifies whether to compute the columns of U: *> = 'U': N columns of U are returned in the array U. *> = 'F': full set of M left sing. vectors is returned in the array U. *> = 'W': U may be used as workspace of length M*N. See the description *> of U. *> = 'N': U is not computed. *> \endverbatim *> *> \param[in] JOBV *> \verbatim *> JOBV is CHARACTER*1 *> Specifies whether to compute the matrix V: *> = 'V': N columns of V are returned in the array V; Jacobi rotations *> are not explicitly accumulated. *> = 'J': N columns of V are returned in the array V, but they are *> computed as the product of Jacobi rotations. This option is *> allowed only if JOBU .NE. 'N', i.e. in computing the full SVD. *> = 'W': V may be used as workspace of length N*N. See the description *> of V. *> = 'N': V is not computed. *> \endverbatim *> *> \param[in] JOBR *> \verbatim *> JOBR is CHARACTER*1 *> Specifies the RANGE for the singular values. Issues the licence to *> set to zero small positive singular values if they are outside *> specified range. If A .NE. 0 is scaled so that the largest singular *> value of c*A is around DSQRT(BIG), BIG=SLAMCH('O'), then JOBR issues *> the licence to kill columns of A whose norm in c*A is less than *> DSQRT(SFMIN) (for JOBR.EQ.'R'), or less than SMALL=SFMIN/EPSLN, *> where SFMIN=SLAMCH('S'), EPSLN=SLAMCH('E'). *> = 'N': Do not kill small columns of c*A. This option assumes that *> BLAS and QR factorizations and triangular solvers are *> implemented to work in that range. If the condition of A *> is greater than BIG, use DGESVJ. *> = 'R': RESTRICTED range for sigma(c*A) is [DSQRT(SFMIN), DSQRT(BIG)] *> (roughly, as described above). This option is recommended. *> ~~~~~~~~~~~~~~~~~~~~~~~~~~~ *> For computing the singular values in the FULL range [SFMIN,BIG] *> use DGESVJ. *> \endverbatim *> *> \param[in] JOBT *> \verbatim *> JOBT is CHARACTER*1 *> If the matrix is square then the procedure may determine to use *> transposed A if A^t seems to be better with respect to convergence. *> If the matrix is not square, JOBT is ignored. This is subject to *> changes in the future. *> The decision is based on two values of entropy over the adjoint *> orbit of A^t * A. See the descriptions of WORK(6) and WORK(7). *> = 'T': transpose if entropy test indicates possibly faster *> convergence of Jacobi process if A^t is taken as input. If A is *> replaced with A^t, then the row pivoting is included automatically. *> = 'N': do not speculate. *> This option can be used to compute only the singular values, or the *> full SVD (U, SIGMA and V). For only one set of singular vectors *> (U or V), the caller should provide both U and V, as one of the *> matrices is used as workspace if the matrix A is transposed. *> The implementer can easily remove this constraint and make the *> code more complicated. See the descriptions of U and V. *> \endverbatim *> *> \param[in] JOBP *> \verbatim *> JOBP is CHARACTER*1 *> Issues the licence to introduce structured perturbations to drown *> denormalized numbers. This licence should be active if the *> denormals are poorly implemented, causing slow computation, *> especially in cases of fast convergence (!). For details see [1,2]. *> For the sake of simplicity, this perturbations are included only *> when the full SVD or only the singular values are requested. The *> implementer/user can easily add the perturbation for the cases of *> computing one set of singular vectors. *> = 'P': introduce perturbation *> = 'N': do not perturb *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the input matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the input matrix A. M >= N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the M-by-N matrix A. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] SVA *> \verbatim *> SVA is DOUBLE PRECISION array, dimension (N) *> On exit, *> - For WORK(1)/WORK(2) = ONE: The singular values of A. During the *> computation SVA contains Euclidean column norms of the *> iterated matrices in the array A. *> - For WORK(1) .NE. WORK(2): The singular values of A are *> (WORK(1)/WORK(2)) * SVA(1:N). This factored form is used if *> sigma_max(A) overflows or if small singular values have been *> saved from underflow by scaling the input matrix A. *> - If JOBR='R' then some of the singular values may be returned *> as exact zeros obtained by "set to zero" because they are *> below the numerical rank threshold or are denormalized numbers. *> \endverbatim *> *> \param[out] U *> \verbatim *> U is DOUBLE PRECISION array, dimension ( LDU, N ) *> If JOBU = 'U', then U contains on exit the M-by-N matrix of *> the left singular vectors. *> If JOBU = 'F', then U contains on exit the M-by-M matrix of *> the left singular vectors, including an ONB *> of the orthogonal complement of the Range(A). *> If JOBU = 'W' .AND. (JOBV.EQ.'V' .AND. JOBT.EQ.'T' .AND. M.EQ.N), *> then U is used as workspace if the procedure *> replaces A with A^t. In that case, [V] is computed *> in U as left singular vectors of A^t and then *> copied back to the V array. This 'W' option is just *> a reminder to the caller that in this case U is *> reserved as workspace of length N*N. *> If JOBU = 'N' U is not referenced, unless JOBT='T'. *> \endverbatim *> *> \param[in] LDU *> \verbatim *> LDU is INTEGER *> The leading dimension of the array U, LDU >= 1. *> IF JOBU = 'U' or 'F' or 'W', then LDU >= M. *> \endverbatim *> *> \param[out] V *> \verbatim *> V is DOUBLE PRECISION array, dimension ( LDV, N ) *> If JOBV = 'V', 'J' then V contains on exit the N-by-N matrix of *> the right singular vectors; *> If JOBV = 'W', AND (JOBU.EQ.'U' AND JOBT.EQ.'T' AND M.EQ.N), *> then V is used as workspace if the pprocedure *> replaces A with A^t. In that case, [U] is computed *> in V as right singular vectors of A^t and then *> copied back to the U array. This 'W' option is just *> a reminder to the caller that in this case V is *> reserved as workspace of length N*N. *> If JOBV = 'N' V is not referenced, unless JOBT='T'. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the array V, LDV >= 1. *> If JOBV = 'V' or 'J' or 'W', then LDV >= N. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (LWORK) *> On exit, if N.GT.0 .AND. M.GT.0 (else not referenced), *> WORK(1) = SCALE = WORK(2) / WORK(1) is the scaling factor such *> that SCALE*SVA(1:N) are the computed singular values *> of A. (See the description of SVA().) *> WORK(2) = See the description of WORK(1). *> WORK(3) = SCONDA is an estimate for the condition number of *> column equilibrated A. (If JOBA .EQ. 'E' or 'G') *> SCONDA is an estimate of DSQRT(||(R^t * R)^(-1)||_1). *> It is computed using DPOCON. It holds *> N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA *> where R is the triangular factor from the QRF of A. *> However, if R is truncated and the numerical rank is *> determined to be strictly smaller than N, SCONDA is *> returned as -1, thus indicating that the smallest *> singular values might be lost. *> *> If full SVD is needed, the following two condition numbers are *> useful for the analysis of the algorithm. They are provied for *> a developer/implementer who is familiar with the details of *> the method. *> *> WORK(4) = an estimate of the scaled condition number of the *> triangular factor in the first QR factorization. *> WORK(5) = an estimate of the scaled condition number of the *> triangular factor in the second QR factorization. *> The following two parameters are computed if JOBT .EQ. 'T'. *> They are provided for a developer/implementer who is familiar *> with the details of the method. *> *> WORK(6) = the entropy of A^t*A :: this is the Shannon entropy *> of diag(A^t*A) / Trace(A^t*A) taken as point in the *> probability simplex. *> WORK(7) = the entropy of A*A^t. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> Length of WORK to confirm proper allocation of work space. *> LWORK depends on the job: *> *> If only SIGMA is needed ( JOBU.EQ.'N', JOBV.EQ.'N' ) and *> -> .. no scaled condition estimate required (JOBE.EQ.'N'): *> LWORK >= max(2*M+N,4*N+1,7). This is the minimal requirement. *> ->> For optimal performance (blocked code) the optimal value *> is LWORK >= max(2*M+N,3*N+(N+1)*NB,7). Here NB is the optimal *> block size for DGEQP3 and DGEQRF. *> In general, optimal LWORK is computed as *> LWORK >= max(2*M+N,N+LWORK(DGEQP3),N+LWORK(DGEQRF), 7). *> -> .. an estimate of the scaled condition number of A is *> required (JOBA='E', 'G'). In this case, LWORK is the maximum *> of the above and N*N+4*N, i.e. LWORK >= max(2*M+N,N*N+4*N,7). *> ->> For optimal performance (blocked code) the optimal value *> is LWORK >= max(2*M+N,3*N+(N+1)*NB, N*N+4*N, 7). *> In general, the optimal length LWORK is computed as *> LWORK >= max(2*M+N,N+LWORK(DGEQP3),N+LWORK(DGEQRF), *> N+N*N+LWORK(DPOCON),7). *> *> If SIGMA and the right singular vectors are needed (JOBV.EQ.'V'), *> -> the minimal requirement is LWORK >= max(2*M+N,4*N+1,7). *> -> For optimal performance, LWORK >= max(2*M+N,3*N+(N+1)*NB,7), *> where NB is the optimal block size for DGEQP3, DGEQRF, DGELQF, *> DORMLQ. In general, the optimal length LWORK is computed as *> LWORK >= max(2*M+N,N+LWORK(DGEQP3), N+LWORK(DPOCON), *> N+LWORK(DGELQF), 2*N+LWORK(DGEQRF), N+LWORK(DORMLQ)). *> *> If SIGMA and the left singular vectors are needed *> -> the minimal requirement is LWORK >= max(2*M+N,4*N+1,7). *> -> For optimal performance: *> if JOBU.EQ.'U' :: LWORK >= max(2*M+N,3*N+(N+1)*NB,7), *> if JOBU.EQ.'F' :: LWORK >= max(2*M+N,3*N+(N+1)*NB,N+M*NB,7), *> where NB is the optimal block size for DGEQP3, DGEQRF, DORMQR. *> In general, the optimal length LWORK is computed as *> LWORK >= max(2*M+N,N+LWORK(DGEQP3),N+LWORK(DPOCON), *> 2*N+LWORK(DGEQRF), N+LWORK(DORMQR)). *> Here LWORK(DORMQR) equals N*NB (for JOBU.EQ.'U') or *> M*NB (for JOBU.EQ.'F'). *> *> If the full SVD is needed: (JOBU.EQ.'U' or JOBU.EQ.'F') and *> -> if JOBV.EQ.'V' *> the minimal requirement is LWORK >= max(2*M+N,6*N+2*N*N). *> -> if JOBV.EQ.'J' the minimal requirement is *> LWORK >= max(2*M+N, 4*N+N*N,2*N+N*N+6). *> -> For optimal performance, LWORK should be additionally *> larger than N+M*NB, where NB is the optimal block size *> for DORMQR. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (M+3*N). *> On exit, *> IWORK(1) = the numerical rank determined after the initial *> QR factorization with pivoting. See the descriptions *> of JOBA and JOBR. *> IWORK(2) = the number of the computed nonzero singular values *> IWORK(3) = if nonzero, a warning message: *> If IWORK(3).EQ.1 then some of the column norms of A *> were denormalized floats. The requested high accuracy *> is not warranted by the data. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> < 0 : if INFO = -i, then the i-th argument had an illegal value. *> = 0 : successful exit; *> > 0 : DGEJSV did not converge in the maximal allowed number *> of sweeps. The computed values may be inaccurate. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleGEsing * *> \par Further Details: * ===================== *> *> \verbatim *> *> DGEJSV implements a preconditioned Jacobi SVD algorithm. It uses DGEQP3, *> DGEQRF, and DGELQF as preprocessors and preconditioners. Optionally, an *> additional row pivoting can be used as a preprocessor, which in some *> cases results in much higher accuracy. An example is matrix A with the *> structure A = D1 * C * D2, where D1, D2 are arbitrarily ill-conditioned *> diagonal matrices and C is well-conditioned matrix. In that case, complete *> pivoting in the first QR factorizations provides accuracy dependent on the *> condition number of C, and independent of D1, D2. Such higher accuracy is *> not completely understood theoretically, but it works well in practice. *> Further, if A can be written as A = B*D, with well-conditioned B and some *> diagonal D, then the high accuracy is guaranteed, both theoretically and *> in software, independent of D. For more details see [1], [2]. *> The computational range for the singular values can be the full range *> ( UNDERFLOW,OVERFLOW ), provided that the machine arithmetic and the BLAS *> & LAPACK routines called by DGEJSV are implemented to work in that range. *> If that is not the case, then the restriction for safe computation with *> the singular values in the range of normalized IEEE numbers is that the *> spectral condition number kappa(A)=sigma_max(A)/sigma_min(A) does not *> overflow. This code (DGEJSV) is best used in this restricted range, *> meaning that singular values of magnitude below ||A||_2 / DLAMCH('O') are *> returned as zeros. See JOBR for details on this. *> Further, this implementation is somewhat slower than the one described *> in [1,2] due to replacement of some non-LAPACK components, and because *> the choice of some tuning parameters in the iterative part (DGESVJ) is *> left to the implementer on a particular machine. *> The rank revealing QR factorization (in this code: DGEQP3) should be *> implemented as in [3]. We have a new version of DGEQP3 under development *> that is more robust than the current one in LAPACK, with a cleaner cut in *> rank deficient cases. It will be available in the SIGMA library [4]. *> If M is much larger than N, it is obvious that the initial QRF with *> column pivoting can be preprocessed by the QRF without pivoting. That *> well known trick is not used in DGEJSV because in some cases heavy row *> weighting can be treated with complete pivoting. The overhead in cases *> M much larger than N is then only due to pivoting, but the benefits in *> terms of accuracy have prevailed. The implementer/user can incorporate *> this extra QRF step easily. The implementer can also improve data movement *> (matrix transpose, matrix copy, matrix transposed copy) - this *> implementation of DGEJSV uses only the simplest, naive data movement. *> \endverbatim * *> \par Contributors: * ================== *> *> Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) * *> \par References: * ================ *> *> \verbatim *> *> [1] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm I. *> SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1322-1342. *> LAPACK Working note 169. *> [2] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm II. *> SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1343-1362. *> LAPACK Working note 170. *> [3] Z. Drmac and Z. Bujanovic: On the failure of rank-revealing QR *> factorization software - a case study. *> ACM Trans. Math. Softw. Vol. 35, No 2 (2008), pp. 1-28. *> LAPACK Working note 176. *> [4] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV, *> QSVD, (H,K)-SVD computations. *> Department of Mathematics, University of Zagreb, 2008. *> \endverbatim * *> \par Bugs, examples and comments: * ================================= *> *> Please report all bugs and send interesting examples and/or comments to *> drmac@math.hr. Thank you. *> * ===================================================================== SUBROUTINE DGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, $ M, N, A, LDA, SVA, U, LDU, V, LDV, $ WORK, LWORK, IWORK, INFO ) * * -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. IMPLICIT NONE INTEGER INFO, LDA, LDU, LDV, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), SVA( N ), U( LDU, * ), V( LDV, * ), $ WORK( LWORK ) INTEGER IWORK( * ) CHARACTER*1 JOBA, JOBP, JOBR, JOBT, JOBU, JOBV * .. * * =========================================================================== * * .. Local Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. DOUBLE PRECISION AAPP, AAQQ, AATMAX, AATMIN, BIG, BIG1, COND_OK, $ CONDR1, CONDR2, ENTRA, ENTRAT, EPSLN, MAXPRJ, SCALEM, $ SCONDA, SFMIN, SMALL, TEMP1, USCAL1, USCAL2, XSC INTEGER IERR, N1, NR, NUMRANK, p, q, WARNING LOGICAL ALMORT, DEFR, ERREST, GOSCAL, JRACC, KILL, LSVEC, $ L2ABER, L2KILL, L2PERT, L2RANK, L2TRAN, $ NOSCAL, ROWPIV, RSVEC, TRANSP * .. * .. Intrinsic Functions .. INTRINSIC DABS, DLOG, MAX, MIN, DBLE, IDNINT, DSIGN, DSQRT * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DNRM2 INTEGER IDAMAX LOGICAL LSAME EXTERNAL IDAMAX, LSAME, DLAMCH, DNRM2 * .. * .. External Subroutines .. EXTERNAL DCOPY, DGELQF, DGEQP3, DGEQRF, DLACPY, DLASCL, $ DLASET, DLASSQ, DLASWP, DORGQR, DORMLQ, $ DORMQR, DPOCON, DSCAL, DSWAP, DTRSM, XERBLA * EXTERNAL DGESVJ * .. * * Test the input arguments * LSVEC = LSAME( JOBU, 'U' ) .OR. LSAME( JOBU, 'F' ) JRACC = LSAME( JOBV, 'J' ) RSVEC = LSAME( JOBV, 'V' ) .OR. JRACC ROWPIV = LSAME( JOBA, 'F' ) .OR. LSAME( JOBA, 'G' ) L2RANK = LSAME( JOBA, 'R' ) L2ABER = LSAME( JOBA, 'A' ) ERREST = LSAME( JOBA, 'E' ) .OR. LSAME( JOBA, 'G' ) L2TRAN = LSAME( JOBT, 'T' ) L2KILL = LSAME( JOBR, 'R' ) DEFR = LSAME( JOBR, 'N' ) L2PERT = LSAME( JOBP, 'P' ) * IF ( .NOT.(ROWPIV .OR. L2RANK .OR. L2ABER .OR. $ ERREST .OR. LSAME( JOBA, 'C' ) )) THEN INFO = - 1 ELSE IF ( .NOT.( LSVEC .OR. LSAME( JOBU, 'N' ) .OR. $ LSAME( JOBU, 'W' )) ) THEN INFO = - 2 ELSE IF ( .NOT.( RSVEC .OR. LSAME( JOBV, 'N' ) .OR. $ LSAME( JOBV, 'W' )) .OR. ( JRACC .AND. (.NOT.LSVEC) ) ) THEN INFO = - 3 ELSE IF ( .NOT. ( L2KILL .OR. DEFR ) ) THEN INFO = - 4 ELSE IF ( .NOT. ( L2TRAN .OR. LSAME( JOBT, 'N' ) ) ) THEN INFO = - 5 ELSE IF ( .NOT. ( L2PERT .OR. LSAME( JOBP, 'N' ) ) ) THEN INFO = - 6 ELSE IF ( M .LT. 0 ) THEN INFO = - 7 ELSE IF ( ( N .LT. 0 ) .OR. ( N .GT. M ) ) THEN INFO = - 8 ELSE IF ( LDA .LT. M ) THEN INFO = - 10 ELSE IF ( LSVEC .AND. ( LDU .LT. M ) ) THEN INFO = - 13 ELSE IF ( RSVEC .AND. ( LDV .LT. N ) ) THEN INFO = - 15 ELSE IF ( (.NOT.(LSVEC .OR. RSVEC .OR. ERREST).AND. & (LWORK .LT. MAX(7,4*N+1,2*M+N))) .OR. & (.NOT.(LSVEC .OR. RSVEC) .AND. ERREST .AND. & (LWORK .LT. MAX(7,4*N+N*N,2*M+N))) .OR. & (LSVEC .AND. (.NOT.RSVEC) .AND. (LWORK .LT. MAX(7,2*M+N,4*N+1))) & .OR. & (RSVEC .AND. (.NOT.LSVEC) .AND. (LWORK .LT. MAX(7,2*M+N,4*N+1))) & .OR. & (LSVEC .AND. RSVEC .AND. (.NOT.JRACC) .AND. & (LWORK.LT.MAX(2*M+N,6*N+2*N*N))) & .OR. (LSVEC .AND. RSVEC .AND. JRACC .AND. & LWORK.LT.MAX(2*M+N,4*N+N*N,2*N+N*N+6))) & THEN INFO = - 17 ELSE * #:) INFO = 0 END IF * IF ( INFO .NE. 0 ) THEN * #:( CALL XERBLA( 'DGEJSV', - INFO ) RETURN END IF * * Quick return for void matrix (Y3K safe) * #:) IF ( ( M .EQ. 0 ) .OR. ( N .EQ. 0 ) ) THEN IWORK(1:3) = 0 WORK(1:7) = 0 RETURN ENDIF * * Determine whether the matrix U should be M x N or M x M * IF ( LSVEC ) THEN N1 = N IF ( LSAME( JOBU, 'F' ) ) N1 = M END IF * * Set numerical parameters * *! NOTE: Make sure DLAMCH() does not fail on the target architecture. * EPSLN = DLAMCH('Epsilon') SFMIN = DLAMCH('SafeMinimum') SMALL = SFMIN / EPSLN BIG = DLAMCH('O') * BIG = ONE / SFMIN * * Initialize SVA(1:N) = diag( ||A e_i||_2 )_1^N * *(!) If necessary, scale SVA() to protect the largest norm from * overflow. It is possible that this scaling pushes the smallest * column norm left from the underflow threshold (extreme case). * SCALEM = ONE / DSQRT(DBLE(M)*DBLE(N)) NOSCAL = .TRUE. GOSCAL = .TRUE. DO 1874 p = 1, N AAPP = ZERO AAQQ = ONE CALL DLASSQ( M, A(1,p), 1, AAPP, AAQQ ) IF ( AAPP .GT. BIG ) THEN INFO = - 9 CALL XERBLA( 'DGEJSV', -INFO ) RETURN END IF AAQQ = DSQRT(AAQQ) IF ( ( AAPP .LT. (BIG / AAQQ) ) .AND. NOSCAL ) THEN SVA(p) = AAPP * AAQQ ELSE NOSCAL = .FALSE. SVA(p) = AAPP * ( AAQQ * SCALEM ) IF ( GOSCAL ) THEN GOSCAL = .FALSE. CALL DSCAL( p-1, SCALEM, SVA, 1 ) END IF END IF 1874 CONTINUE * IF ( NOSCAL ) SCALEM = ONE * AAPP = ZERO AAQQ = BIG DO 4781 p = 1, N AAPP = MAX( AAPP, SVA(p) ) IF ( SVA(p) .NE. ZERO ) AAQQ = MIN( AAQQ, SVA(p) ) 4781 CONTINUE * * Quick return for zero M x N matrix * #:) IF ( AAPP .EQ. ZERO ) THEN IF ( LSVEC ) CALL DLASET( 'G', M, N1, ZERO, ONE, U, LDU ) IF ( RSVEC ) CALL DLASET( 'G', N, N, ZERO, ONE, V, LDV ) WORK(1) = ONE WORK(2) = ONE IF ( ERREST ) WORK(3) = ONE IF ( LSVEC .AND. RSVEC ) THEN WORK(4) = ONE WORK(5) = ONE END IF IF ( L2TRAN ) THEN WORK(6) = ZERO WORK(7) = ZERO END IF IWORK(1) = 0 IWORK(2) = 0 IWORK(3) = 0 RETURN END IF * * Issue warning if denormalized column norms detected. Override the * high relative accuracy request. Issue licence to kill columns * (set them to zero) whose norm is less than sigma_max / BIG (roughly). * #:( WARNING = 0 IF ( AAQQ .LE. SFMIN ) THEN L2RANK = .TRUE. L2KILL = .TRUE. WARNING = 1 END IF * * Quick return for one-column matrix * #:) IF ( N .EQ. 1 ) THEN * IF ( LSVEC ) THEN CALL DLASCL( 'G',0,0,SVA(1),SCALEM, M,1,A(1,1),LDA,IERR ) CALL DLACPY( 'A', M, 1, A, LDA, U, LDU ) * computing all M left singular vectors of the M x 1 matrix IF ( N1 .NE. N ) THEN CALL DGEQRF( M, N, U,LDU, WORK, WORK(N+1),LWORK-N,IERR ) CALL DORGQR( M,N1,1, U,LDU,WORK,WORK(N+1),LWORK-N,IERR ) CALL DCOPY( M, A(1,1), 1, U(1,1), 1 ) END IF END IF IF ( RSVEC ) THEN V(1,1) = ONE END IF IF ( SVA(1) .LT. (BIG*SCALEM) ) THEN SVA(1) = SVA(1) / SCALEM SCALEM = ONE END IF WORK(1) = ONE / SCALEM WORK(2) = ONE IF ( SVA(1) .NE. ZERO ) THEN IWORK(1) = 1 IF ( ( SVA(1) / SCALEM) .GE. SFMIN ) THEN IWORK(2) = 1 ELSE IWORK(2) = 0 END IF ELSE IWORK(1) = 0 IWORK(2) = 0 END IF IWORK(3) = 0 IF ( ERREST ) WORK(3) = ONE IF ( LSVEC .AND. RSVEC ) THEN WORK(4) = ONE WORK(5) = ONE END IF IF ( L2TRAN ) THEN WORK(6) = ZERO WORK(7) = ZERO END IF RETURN * END IF * TRANSP = .FALSE. L2TRAN = L2TRAN .AND. ( M .EQ. N ) * AATMAX = -ONE AATMIN = BIG IF ( ROWPIV .OR. L2TRAN ) THEN * * Compute the row norms, needed to determine row pivoting sequence * (in the case of heavily row weighted A, row pivoting is strongly * advised) and to collect information needed to compare the * structures of A * A^t and A^t * A (in the case L2TRAN.EQ..TRUE.). * IF ( L2TRAN ) THEN DO 1950 p = 1, M XSC = ZERO TEMP1 = ONE CALL DLASSQ( N, A(p,1), LDA, XSC, TEMP1 ) * DLASSQ gets both the ell_2 and the ell_infinity norm * in one pass through the vector WORK(M+N+p) = XSC * SCALEM WORK(N+p) = XSC * (SCALEM*DSQRT(TEMP1)) AATMAX = MAX( AATMAX, WORK(N+p) ) IF (WORK(N+p) .NE. ZERO) AATMIN = MIN(AATMIN,WORK(N+p)) 1950 CONTINUE ELSE DO 1904 p = 1, M WORK(M+N+p) = SCALEM*DABS( A(p,IDAMAX(N,A(p,1),LDA)) ) AATMAX = MAX( AATMAX, WORK(M+N+p) ) AATMIN = MIN( AATMIN, WORK(M+N+p) ) 1904 CONTINUE END IF * END IF * * For square matrix A try to determine whether A^t would be better * input for the preconditioned Jacobi SVD, with faster convergence. * The decision is based on an O(N) function of the vector of column * and row norms of A, based on the Shannon entropy. This should give * the right choice in most cases when the difference actually matters. * It may fail and pick the slower converging side. * ENTRA = ZERO ENTRAT = ZERO IF ( L2TRAN ) THEN * XSC = ZERO TEMP1 = ONE CALL DLASSQ( N, SVA, 1, XSC, TEMP1 ) TEMP1 = ONE / TEMP1 * ENTRA = ZERO DO 1113 p = 1, N BIG1 = ( ( SVA(p) / XSC )**2 ) * TEMP1 IF ( BIG1 .NE. ZERO ) ENTRA = ENTRA + BIG1 * DLOG(BIG1) 1113 CONTINUE ENTRA = - ENTRA / DLOG(DBLE(N)) * * Now, SVA().^2/Trace(A^t * A) is a point in the probability simplex. * It is derived from the diagonal of A^t * A. Do the same with the * diagonal of A * A^t, compute the entropy of the corresponding * probability distribution. Note that A * A^t and A^t * A have the * same trace. * ENTRAT = ZERO DO 1114 p = N+1, N+M BIG1 = ( ( WORK(p) / XSC )**2 ) * TEMP1 IF ( BIG1 .NE. ZERO ) ENTRAT = ENTRAT + BIG1 * DLOG(BIG1) 1114 CONTINUE ENTRAT = - ENTRAT / DLOG(DBLE(M)) * * Analyze the entropies and decide A or A^t. Smaller entropy * usually means better input for the algorithm. * TRANSP = ( ENTRAT .LT. ENTRA ) * * If A^t is better than A, transpose A. * IF ( TRANSP ) THEN * In an optimal implementation, this trivial transpose * should be replaced with faster transpose. DO 1115 p = 1, N - 1 DO 1116 q = p + 1, N TEMP1 = A(q,p) A(q,p) = A(p,q) A(p,q) = TEMP1 1116 CONTINUE 1115 CONTINUE DO 1117 p = 1, N WORK(M+N+p) = SVA(p) SVA(p) = WORK(N+p) 1117 CONTINUE TEMP1 = AAPP AAPP = AATMAX AATMAX = TEMP1 TEMP1 = AAQQ AAQQ = AATMIN AATMIN = TEMP1 KILL = LSVEC LSVEC = RSVEC RSVEC = KILL IF ( LSVEC ) N1 = N * ROWPIV = .TRUE. END IF * END IF * END IF L2TRAN * * Scale the matrix so that its maximal singular value remains less * than DSQRT(BIG) -- the matrix is scaled so that its maximal column * has Euclidean norm equal to DSQRT(BIG/N). The only reason to keep * DSQRT(BIG) instead of BIG is the fact that DGEJSV uses LAPACK and * BLAS routines that, in some implementations, are not capable of * working in the full interval [SFMIN,BIG] and that they may provoke * overflows in the intermediate results. If the singular values spread * from SFMIN to BIG, then DGESVJ will compute them. So, in that case, * one should use DGESVJ instead of DGEJSV. * BIG1 = DSQRT( BIG ) TEMP1 = DSQRT( BIG / DBLE(N) ) * CALL DLASCL( 'G', 0, 0, AAPP, TEMP1, N, 1, SVA, N, IERR ) IF ( AAQQ .GT. (AAPP * SFMIN) ) THEN AAQQ = ( AAQQ / AAPP ) * TEMP1 ELSE AAQQ = ( AAQQ * TEMP1 ) / AAPP END IF TEMP1 = TEMP1 * SCALEM CALL DLASCL( 'G', 0, 0, AAPP, TEMP1, M, N, A, LDA, IERR ) * * To undo scaling at the end of this procedure, multiply the * computed singular values with USCAL2 / USCAL1. * USCAL1 = TEMP1 USCAL2 = AAPP * IF ( L2KILL ) THEN * L2KILL enforces computation of nonzero singular values in * the restricted range of condition number of the initial A, * sigma_max(A) / sigma_min(A) approx. DSQRT(BIG)/DSQRT(SFMIN). XSC = DSQRT( SFMIN ) ELSE XSC = SMALL * * Now, if the condition number of A is too big, * sigma_max(A) / sigma_min(A) .GT. DSQRT(BIG/N) * EPSLN / SFMIN, * as a precaution measure, the full SVD is computed using DGESVJ * with accumulated Jacobi rotations. This provides numerically * more robust computation, at the cost of slightly increased run * time. Depending on the concrete implementation of BLAS and LAPACK * (i.e. how they behave in presence of extreme ill-conditioning) the * implementor may decide to remove this switch. IF ( ( AAQQ.LT.DSQRT(SFMIN) ) .AND. LSVEC .AND. RSVEC ) THEN JRACC = .TRUE. END IF * END IF IF ( AAQQ .LT. XSC ) THEN DO 700 p = 1, N IF ( SVA(p) .LT. XSC ) THEN CALL DLASET( 'A', M, 1, ZERO, ZERO, A(1,p), LDA ) SVA(p) = ZERO END IF 700 CONTINUE END IF * * Preconditioning using QR factorization with pivoting * IF ( ROWPIV ) THEN * Optional row permutation (Bjoerck row pivoting): * A result by Cox and Higham shows that the Bjoerck's * row pivoting combined with standard column pivoting * has similar effect as Powell-Reid complete pivoting. * The ell-infinity norms of A are made nonincreasing. DO 1952 p = 1, M - 1 q = IDAMAX( M-p+1, WORK(M+N+p), 1 ) + p - 1 IWORK(2*N+p) = q IF ( p .NE. q ) THEN TEMP1 = WORK(M+N+p) WORK(M+N+p) = WORK(M+N+q) WORK(M+N+q) = TEMP1 END IF 1952 CONTINUE CALL DLASWP( N, A, LDA, 1, M-1, IWORK(2*N+1), 1 ) END IF * * End of the preparation phase (scaling, optional sorting and * transposing, optional flushing of small columns). * * Preconditioning * * If the full SVD is needed, the right singular vectors are computed * from a matrix equation, and for that we need theoretical analysis * of the Businger-Golub pivoting. So we use DGEQP3 as the first RR QRF. * In all other cases the first RR QRF can be chosen by other criteria * (eg speed by replacing global with restricted window pivoting, such * as in SGEQPX from TOMS # 782). Good results will be obtained using * SGEQPX with properly (!) chosen numerical parameters. * Any improvement of DGEQP3 improves overal performance of DGEJSV. * * A * P1 = Q1 * [ R1^t 0]^t: DO 1963 p = 1, N * .. all columns are free columns IWORK(p) = 0 1963 CONTINUE CALL DGEQP3( M,N,A,LDA, IWORK,WORK, WORK(N+1),LWORK-N, IERR ) * * The upper triangular matrix R1 from the first QRF is inspected for * rank deficiency and possibilities for deflation, or possible * ill-conditioning. Depending on the user specified flag L2RANK, * the procedure explores possibilities to reduce the numerical * rank by inspecting the computed upper triangular factor. If * L2RANK or L2ABER are up, then DGEJSV will compute the SVD of * A + dA, where ||dA|| <= f(M,N)*EPSLN. * NR = 1 IF ( L2ABER ) THEN * Standard absolute error bound suffices. All sigma_i with * sigma_i < N*EPSLN*||A|| are flushed to zero. This is an * agressive enforcement of lower numerical rank by introducing a * backward error of the order of N*EPSLN*||A||. TEMP1 = DSQRT(DBLE(N))*EPSLN DO 3001 p = 2, N IF ( DABS(A(p,p)) .GE. (TEMP1*DABS(A(1,1))) ) THEN NR = NR + 1 ELSE GO TO 3002 END IF 3001 CONTINUE 3002 CONTINUE ELSE IF ( L2RANK ) THEN * .. similarly as above, only slightly more gentle (less agressive). * Sudden drop on the diagonal of R1 is used as the criterion for * close-to-rank-deficient. TEMP1 = DSQRT(SFMIN) DO 3401 p = 2, N IF ( ( DABS(A(p,p)) .LT. (EPSLN*DABS(A(p-1,p-1))) ) .OR. $ ( DABS(A(p,p)) .LT. SMALL ) .OR. $ ( L2KILL .AND. (DABS(A(p,p)) .LT. TEMP1) ) ) GO TO 3402 NR = NR + 1 3401 CONTINUE 3402 CONTINUE * ELSE * The goal is high relative accuracy. However, if the matrix * has high scaled condition number the relative accuracy is in * general not feasible. Later on, a condition number estimator * will be deployed to estimate the scaled condition number. * Here we just remove the underflowed part of the triangular * factor. This prevents the situation in which the code is * working hard to get the accuracy not warranted by the data. TEMP1 = DSQRT(SFMIN) DO 3301 p = 2, N IF ( ( DABS(A(p,p)) .LT. SMALL ) .OR. $ ( L2KILL .AND. (DABS(A(p,p)) .LT. TEMP1) ) ) GO TO 3302 NR = NR + 1 3301 CONTINUE 3302 CONTINUE * END IF * ALMORT = .FALSE. IF ( NR .EQ. N ) THEN MAXPRJ = ONE DO 3051 p = 2, N TEMP1 = DABS(A(p,p)) / SVA(IWORK(p)) MAXPRJ = MIN( MAXPRJ, TEMP1 ) 3051 CONTINUE IF ( MAXPRJ**2 .GE. ONE - DBLE(N)*EPSLN ) ALMORT = .TRUE. END IF * * SCONDA = - ONE CONDR1 = - ONE CONDR2 = - ONE * IF ( ERREST ) THEN IF ( N .EQ. NR ) THEN IF ( RSVEC ) THEN * .. V is available as workspace CALL DLACPY( 'U', N, N, A, LDA, V, LDV ) DO 3053 p = 1, N TEMP1 = SVA(IWORK(p)) CALL DSCAL( p, ONE/TEMP1, V(1,p), 1 ) 3053 CONTINUE CALL DPOCON( 'U', N, V, LDV, ONE, TEMP1, $ WORK(N+1), IWORK(2*N+M+1), IERR ) ELSE IF ( LSVEC ) THEN * .. U is available as workspace CALL DLACPY( 'U', N, N, A, LDA, U, LDU ) DO 3054 p = 1, N TEMP1 = SVA(IWORK(p)) CALL DSCAL( p, ONE/TEMP1, U(1,p), 1 ) 3054 CONTINUE CALL DPOCON( 'U', N, U, LDU, ONE, TEMP1, $ WORK(N+1), IWORK(2*N+M+1), IERR ) ELSE CALL DLACPY( 'U', N, N, A, LDA, WORK(N+1), N ) DO 3052 p = 1, N TEMP1 = SVA(IWORK(p)) CALL DSCAL( p, ONE/TEMP1, WORK(N+(p-1)*N+1), 1 ) 3052 CONTINUE * .. the columns of R are scaled to have unit Euclidean lengths. CALL DPOCON( 'U', N, WORK(N+1), N, ONE, TEMP1, $ WORK(N+N*N+1), IWORK(2*N+M+1), IERR ) END IF SCONDA = ONE / DSQRT(TEMP1) * SCONDA is an estimate of DSQRT(||(R^t * R)^(-1)||_1). * N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA ELSE SCONDA = - ONE END IF END IF * L2PERT = L2PERT .AND. ( DABS( A(1,1)/A(NR,NR) ) .GT. DSQRT(BIG1) ) * If there is no violent scaling, artificial perturbation is not needed. * * Phase 3: * IF ( .NOT. ( RSVEC .OR. LSVEC ) ) THEN * * Singular Values only * * .. transpose A(1:NR,1:N) DO 1946 p = 1, MIN( N-1, NR ) CALL DCOPY( N-p, A(p,p+1), LDA, A(p+1,p), 1 ) 1946 CONTINUE * * The following two DO-loops introduce small relative perturbation * into the strict upper triangle of the lower triangular matrix. * Small entries below the main diagonal are also changed. * This modification is useful if the computing environment does not * provide/allow FLUSH TO ZERO underflow, for it prevents many * annoying denormalized numbers in case of strongly scaled matrices. * The perturbation is structured so that it does not introduce any * new perturbation of the singular values, and it does not destroy * the job done by the preconditioner. * The licence for this perturbation is in the variable L2PERT, which * should be .FALSE. if FLUSH TO ZERO underflow is active. * IF ( .NOT. ALMORT ) THEN * IF ( L2PERT ) THEN * XSC = DSQRT(SMALL) XSC = EPSLN / DBLE(N) DO 4947 q = 1, NR TEMP1 = XSC*DABS(A(q,q)) DO 4949 p = 1, N IF ( ( (p.GT.q) .AND. (DABS(A(p,q)).LE.TEMP1) ) $ .OR. ( p .LT. q ) ) $ A(p,q) = DSIGN( TEMP1, A(p,q) ) 4949 CONTINUE 4947 CONTINUE ELSE CALL DLASET( 'U', NR-1,NR-1, ZERO,ZERO, A(1,2),LDA ) END IF * * .. second preconditioning using the QR factorization * CALL DGEQRF( N,NR, A,LDA, WORK, WORK(N+1),LWORK-N, IERR ) * * .. and transpose upper to lower triangular DO 1948 p = 1, NR - 1 CALL DCOPY( NR-p, A(p,p+1), LDA, A(p+1,p), 1 ) 1948 CONTINUE * END IF * * Row-cyclic Jacobi SVD algorithm with column pivoting * * .. again some perturbation (a "background noise") is added * to drown denormals IF ( L2PERT ) THEN * XSC = DSQRT(SMALL) XSC = EPSLN / DBLE(N) DO 1947 q = 1, NR TEMP1 = XSC*DABS(A(q,q)) DO 1949 p = 1, NR IF ( ( (p.GT.q) .AND. (DABS(A(p,q)).LE.TEMP1) ) $ .OR. ( p .LT. q ) ) $ A(p,q) = DSIGN( TEMP1, A(p,q) ) 1949 CONTINUE 1947 CONTINUE ELSE CALL DLASET( 'U', NR-1, NR-1, ZERO, ZERO, A(1,2), LDA ) END IF * * .. and one-sided Jacobi rotations are started on a lower * triangular matrix (plus perturbation which is ignored in * the part which destroys triangular form (confusing?!)) * CALL DGESVJ( 'L', 'NoU', 'NoV', NR, NR, A, LDA, SVA, $ N, V, LDV, WORK, LWORK, INFO ) * SCALEM = WORK(1) NUMRANK = IDNINT(WORK(2)) * * ELSE IF ( RSVEC .AND. ( .NOT. LSVEC ) ) THEN * * -> Singular Values and Right Singular Vectors <- * IF ( ALMORT ) THEN * * .. in this case NR equals N DO 1998 p = 1, NR CALL DCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 ) 1998 CONTINUE CALL DLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV ) * CALL DGESVJ( 'L','U','N', N, NR, V,LDV, SVA, NR, A,LDA, $ WORK, LWORK, INFO ) SCALEM = WORK(1) NUMRANK = IDNINT(WORK(2)) ELSE * * .. two more QR factorizations ( one QRF is not enough, two require * accumulated product of Jacobi rotations, three are perfect ) * CALL DLASET( 'Lower', NR-1, NR-1, ZERO, ZERO, A(2,1), LDA ) CALL DGELQF( NR, N, A, LDA, WORK, WORK(N+1), LWORK-N, IERR) CALL DLACPY( 'Lower', NR, NR, A, LDA, V, LDV ) CALL DLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV ) CALL DGEQRF( NR, NR, V, LDV, WORK(N+1), WORK(2*N+1), $ LWORK-2*N, IERR ) DO 8998 p = 1, NR CALL DCOPY( NR-p+1, V(p,p), LDV, V(p,p), 1 ) 8998 CONTINUE CALL DLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV ) * CALL DGESVJ( 'Lower', 'U','N', NR, NR, V,LDV, SVA, NR, U, $ LDU, WORK(N+1), LWORK, INFO ) SCALEM = WORK(N+1) NUMRANK = IDNINT(WORK(N+2)) IF ( NR .LT. N ) THEN CALL DLASET( 'A',N-NR, NR, ZERO,ZERO, V(NR+1,1), LDV ) CALL DLASET( 'A',NR, N-NR, ZERO,ZERO, V(1,NR+1), LDV ) CALL DLASET( 'A',N-NR,N-NR,ZERO,ONE, V(NR+1,NR+1), LDV ) END IF * CALL DORMLQ( 'Left', 'Transpose', N, N, NR, A, LDA, WORK, $ V, LDV, WORK(N+1), LWORK-N, IERR ) * END IF * DO 8991 p = 1, N CALL DCOPY( N, V(p,1), LDV, A(IWORK(p),1), LDA ) 8991 CONTINUE CALL DLACPY( 'All', N, N, A, LDA, V, LDV ) * IF ( TRANSP ) THEN CALL DLACPY( 'All', N, N, V, LDV, U, LDU ) END IF * ELSE IF ( LSVEC .AND. ( .NOT. RSVEC ) ) THEN * * .. Singular Values and Left Singular Vectors .. * * .. second preconditioning step to avoid need to accumulate * Jacobi rotations in the Jacobi iterations. DO 1965 p = 1, NR CALL DCOPY( N-p+1, A(p,p), LDA, U(p,p), 1 ) 1965 CONTINUE CALL DLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU ) * CALL DGEQRF( N, NR, U, LDU, WORK(N+1), WORK(2*N+1), $ LWORK-2*N, IERR ) * DO 1967 p = 1, NR - 1 CALL DCOPY( NR-p, U(p,p+1), LDU, U(p+1,p), 1 ) 1967 CONTINUE CALL DLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU ) * CALL DGESVJ( 'Lower', 'U', 'N', NR,NR, U, LDU, SVA, NR, A, $ LDA, WORK(N+1), LWORK-N, INFO ) SCALEM = WORK(N+1) NUMRANK = IDNINT(WORK(N+2)) * IF ( NR .LT. M ) THEN CALL DLASET( 'A', M-NR, NR,ZERO, ZERO, U(NR+1,1), LDU ) IF ( NR .LT. N1 ) THEN CALL DLASET( 'A',NR, N1-NR, ZERO, ZERO, U(1,NR+1), LDU ) CALL DLASET( 'A',M-NR,N1-NR,ZERO,ONE,U(NR+1,NR+1), LDU ) END IF END IF * CALL DORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U, $ LDU, WORK(N+1), LWORK-N, IERR ) * IF ( ROWPIV ) $ CALL DLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 ) * DO 1974 p = 1, N1 XSC = ONE / DNRM2( M, U(1,p), 1 ) CALL DSCAL( M, XSC, U(1,p), 1 ) 1974 CONTINUE * IF ( TRANSP ) THEN CALL DLACPY( 'All', N, N, U, LDU, V, LDV ) END IF * ELSE * * .. Full SVD .. * IF ( .NOT. JRACC ) THEN * IF ( .NOT. ALMORT ) THEN * * Second Preconditioning Step (QRF [with pivoting]) * Note that the composition of TRANSPOSE, QRF and TRANSPOSE is * equivalent to an LQF CALL. Since in many libraries the QRF * seems to be better optimized than the LQF, we do explicit * transpose and use the QRF. This is subject to changes in an * optimized implementation of DGEJSV. * DO 1968 p = 1, NR CALL DCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 ) 1968 CONTINUE * * .. the following two loops perturb small entries to avoid * denormals in the second QR factorization, where they are * as good as zeros. This is done to avoid painfully slow * computation with denormals. The relative size of the perturbation * is a parameter that can be changed by the implementer. * This perturbation device will be obsolete on machines with * properly implemented arithmetic. * To switch it off, set L2PERT=.FALSE. To remove it from the * code, remove the action under L2PERT=.TRUE., leave the ELSE part. * The following two loops should be blocked and fused with the * transposed copy above. * IF ( L2PERT ) THEN XSC = DSQRT(SMALL) DO 2969 q = 1, NR TEMP1 = XSC*DABS( V(q,q) ) DO 2968 p = 1, N IF ( ( p .GT. q ) .AND. ( DABS(V(p,q)) .LE. TEMP1 ) $ .OR. ( p .LT. q ) ) $ V(p,q) = DSIGN( TEMP1, V(p,q) ) IF ( p .LT. q ) V(p,q) = - V(p,q) 2968 CONTINUE 2969 CONTINUE ELSE CALL DLASET( 'U', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV ) END IF * * Estimate the row scaled condition number of R1 * (If R1 is rectangular, N > NR, then the condition number * of the leading NR x NR submatrix is estimated.) * CALL DLACPY( 'L', NR, NR, V, LDV, WORK(2*N+1), NR ) DO 3950 p = 1, NR TEMP1 = DNRM2(NR-p+1,WORK(2*N+(p-1)*NR+p),1) CALL DSCAL(NR-p+1,ONE/TEMP1,WORK(2*N+(p-1)*NR+p),1) 3950 CONTINUE CALL DPOCON('Lower',NR,WORK(2*N+1),NR,ONE,TEMP1, $ WORK(2*N+NR*NR+1),IWORK(M+2*N+1),IERR) CONDR1 = ONE / DSQRT(TEMP1) * .. here need a second oppinion on the condition number * .. then assume worst case scenario * R1 is OK for inverse <=> CONDR1 .LT. DBLE(N) * more conservative <=> CONDR1 .LT. DSQRT(DBLE(N)) * COND_OK = DSQRT(DBLE(NR)) *[TP] COND_OK is a tuning parameter. IF ( CONDR1 .LT. COND_OK ) THEN * .. the second QRF without pivoting. Note: in an optimized * implementation, this QRF should be implemented as the QRF * of a lower triangular matrix. * R1^t = Q2 * R2 CALL DGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1), $ LWORK-2*N, IERR ) * IF ( L2PERT ) THEN XSC = DSQRT(SMALL)/EPSLN DO 3959 p = 2, NR DO 3958 q = 1, p - 1 TEMP1 = XSC * MIN(DABS(V(p,p)),DABS(V(q,q))) IF ( DABS(V(q,p)) .LE. TEMP1 ) $ V(q,p) = DSIGN( TEMP1, V(q,p) ) 3958 CONTINUE 3959 CONTINUE END IF * IF ( NR .NE. N ) $ CALL DLACPY( 'A', N, NR, V, LDV, WORK(2*N+1), N ) * .. save ... * * .. this transposed copy should be better than naive DO 1969 p = 1, NR - 1 CALL DCOPY( NR-p, V(p,p+1), LDV, V(p+1,p), 1 ) 1969 CONTINUE * CONDR2 = CONDR1 * ELSE * * .. ill-conditioned case: second QRF with pivoting * Note that windowed pivoting would be equaly good * numerically, and more run-time efficient. So, in * an optimal implementation, the next call to DGEQP3 * should be replaced with eg. CALL SGEQPX (ACM TOMS #782) * with properly (carefully) chosen parameters. * * R1^t * P2 = Q2 * R2 DO 3003 p = 1, NR IWORK(N+p) = 0 3003 CONTINUE CALL DGEQP3( N, NR, V, LDV, IWORK(N+1), WORK(N+1), $ WORK(2*N+1), LWORK-2*N, IERR ) ** CALL DGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1), ** $ LWORK-2*N, IERR ) IF ( L2PERT ) THEN XSC = DSQRT(SMALL) DO 3969 p = 2, NR DO 3968 q = 1, p - 1 TEMP1 = XSC * MIN(DABS(V(p,p)),DABS(V(q,q))) IF ( DABS(V(q,p)) .LE. TEMP1 ) $ V(q,p) = DSIGN( TEMP1, V(q,p) ) 3968 CONTINUE 3969 CONTINUE END IF * CALL DLACPY( 'A', N, NR, V, LDV, WORK(2*N+1), N ) * IF ( L2PERT ) THEN XSC = DSQRT(SMALL) DO 8970 p = 2, NR DO 8971 q = 1, p - 1 TEMP1 = XSC * MIN(DABS(V(p,p)),DABS(V(q,q))) V(p,q) = - DSIGN( TEMP1, V(q,p) ) 8971 CONTINUE 8970 CONTINUE ELSE CALL DLASET( 'L',NR-1,NR-1,ZERO,ZERO,V(2,1),LDV ) END IF * Now, compute R2 = L3 * Q3, the LQ factorization. CALL DGELQF( NR, NR, V, LDV, WORK(2*N+N*NR+1), $ WORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, IERR ) * .. and estimate the condition number CALL DLACPY( 'L',NR,NR,V,LDV,WORK(2*N+N*NR+NR+1),NR ) DO 4950 p = 1, NR TEMP1 = DNRM2( p, WORK(2*N+N*NR+NR+p), NR ) CALL DSCAL( p, ONE/TEMP1, WORK(2*N+N*NR+NR+p), NR ) 4950 CONTINUE CALL DPOCON( 'L',NR,WORK(2*N+N*NR+NR+1),NR,ONE,TEMP1, $ WORK(2*N+N*NR+NR+NR*NR+1),IWORK(M+2*N+1),IERR ) CONDR2 = ONE / DSQRT(TEMP1) * IF ( CONDR2 .GE. COND_OK ) THEN * .. save the Householder vectors used for Q3 * (this overwrittes the copy of R2, as it will not be * needed in this branch, but it does not overwritte the * Huseholder vectors of Q2.). CALL DLACPY( 'U', NR, NR, V, LDV, WORK(2*N+1), N ) * .. and the rest of the information on Q3 is in * WORK(2*N+N*NR+1:2*N+N*NR+N) END IF * END IF * IF ( L2PERT ) THEN XSC = DSQRT(SMALL) DO 4968 q = 2, NR TEMP1 = XSC * V(q,q) DO 4969 p = 1, q - 1 * V(p,q) = - DSIGN( TEMP1, V(q,p) ) V(p,q) = - DSIGN( TEMP1, V(p,q) ) 4969 CONTINUE 4968 CONTINUE ELSE CALL DLASET( 'U', NR-1,NR-1, ZERO,ZERO, V(1,2), LDV ) END IF * * Second preconditioning finished; continue with Jacobi SVD * The input matrix is lower trinagular. * * Recover the right singular vectors as solution of a well * conditioned triangular matrix equation. * IF ( CONDR1 .LT. COND_OK ) THEN * CALL DGESVJ( 'L','U','N',NR,NR,V,LDV,SVA,NR,U, $ LDU,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,INFO ) SCALEM = WORK(2*N+N*NR+NR+1) NUMRANK = IDNINT(WORK(2*N+N*NR+NR+2)) DO 3970 p = 1, NR CALL DCOPY( NR, V(1,p), 1, U(1,p), 1 ) CALL DSCAL( NR, SVA(p), V(1,p), 1 ) 3970 CONTINUE * .. pick the right matrix equation and solve it * IF ( NR .EQ. N ) THEN * :)) .. best case, R1 is inverted. The solution of this matrix * equation is Q2*V2 = the product of the Jacobi rotations * used in DGESVJ, premultiplied with the orthogonal matrix * from the second QR factorization. CALL DTRSM( 'L','U','N','N', NR,NR,ONE, A,LDA, V,LDV ) ELSE * .. R1 is well conditioned, but non-square. Transpose(R2) * is inverted to get the product of the Jacobi rotations * used in DGESVJ. The Q-factor from the second QR * factorization is then built in explicitly. CALL DTRSM('L','U','T','N',NR,NR,ONE,WORK(2*N+1), $ N,V,LDV) IF ( NR .LT. N ) THEN CALL DLASET('A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV) CALL DLASET('A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV) CALL DLASET('A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV) END IF CALL DORMQR('L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1), $ V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR) END IF * ELSE IF ( CONDR2 .LT. COND_OK ) THEN * * :) .. the input matrix A is very likely a relative of * the Kahan matrix :) * The matrix R2 is inverted. The solution of the matrix equation * is Q3^T*V3 = the product of the Jacobi rotations (appplied to * the lower triangular L3 from the LQ factorization of * R2=L3*Q3), pre-multiplied with the transposed Q3. CALL DGESVJ( 'L', 'U', 'N', NR, NR, V, LDV, SVA, NR, U, $ LDU, WORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, INFO ) SCALEM = WORK(2*N+N*NR+NR+1) NUMRANK = IDNINT(WORK(2*N+N*NR+NR+2)) DO 3870 p = 1, NR CALL DCOPY( NR, V(1,p), 1, U(1,p), 1 ) CALL DSCAL( NR, SVA(p), U(1,p), 1 ) 3870 CONTINUE CALL DTRSM('L','U','N','N',NR,NR,ONE,WORK(2*N+1),N,U,LDU) * .. apply the permutation from the second QR factorization DO 873 q = 1, NR DO 872 p = 1, NR WORK(2*N+N*NR+NR+IWORK(N+p)) = U(p,q) 872 CONTINUE DO 874 p = 1, NR U(p,q) = WORK(2*N+N*NR+NR+p) 874 CONTINUE 873 CONTINUE IF ( NR .LT. N ) THEN CALL DLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV ) CALL DLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV ) CALL DLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV ) END IF CALL DORMQR( 'L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1), $ V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR ) ELSE * Last line of defense. * #:( This is a rather pathological case: no scaled condition * improvement after two pivoted QR factorizations. Other * possibility is that the rank revealing QR factorization * or the condition estimator has failed, or the COND_OK * is set very close to ONE (which is unnecessary). Normally, * this branch should never be executed, but in rare cases of * failure of the RRQR or condition estimator, the last line of * defense ensures that DGEJSV completes the task. * Compute the full SVD of L3 using DGESVJ with explicit * accumulation of Jacobi rotations. CALL DGESVJ( 'L', 'U', 'V', NR, NR, V, LDV, SVA, NR, U, $ LDU, WORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, INFO ) SCALEM = WORK(2*N+N*NR+NR+1) NUMRANK = IDNINT(WORK(2*N+N*NR+NR+2)) IF ( NR .LT. N ) THEN CALL DLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV ) CALL DLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV ) CALL DLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV ) END IF CALL DORMQR( 'L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1), $ V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR ) * CALL DORMLQ( 'L', 'T', NR, NR, NR, WORK(2*N+1), N, $ WORK(2*N+N*NR+1), U, LDU, WORK(2*N+N*NR+NR+1), $ LWORK-2*N-N*NR-NR, IERR ) DO 773 q = 1, NR DO 772 p = 1, NR WORK(2*N+N*NR+NR+IWORK(N+p)) = U(p,q) 772 CONTINUE DO 774 p = 1, NR U(p,q) = WORK(2*N+N*NR+NR+p) 774 CONTINUE 773 CONTINUE * END IF * * Permute the rows of V using the (column) permutation from the * first QRF. Also, scale the columns to make them unit in * Euclidean norm. This applies to all cases. * TEMP1 = DSQRT(DBLE(N)) * EPSLN DO 1972 q = 1, N DO 972 p = 1, N WORK(2*N+N*NR+NR+IWORK(p)) = V(p,q) 972 CONTINUE DO 973 p = 1, N V(p,q) = WORK(2*N+N*NR+NR+p) 973 CONTINUE XSC = ONE / DNRM2( N, V(1,q), 1 ) IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) $ CALL DSCAL( N, XSC, V(1,q), 1 ) 1972 CONTINUE * At this moment, V contains the right singular vectors of A. * Next, assemble the left singular vector matrix U (M x N). IF ( NR .LT. M ) THEN CALL DLASET( 'A', M-NR, NR, ZERO, ZERO, U(NR+1,1), LDU ) IF ( NR .LT. N1 ) THEN CALL DLASET('A',NR,N1-NR,ZERO,ZERO,U(1,NR+1),LDU) CALL DLASET('A',M-NR,N1-NR,ZERO,ONE,U(NR+1,NR+1),LDU) END IF END IF * * The Q matrix from the first QRF is built into the left singular * matrix U. This applies to all cases. * CALL DORMQR( 'Left', 'No_Tr', M, N1, N, A, LDA, WORK, U, $ LDU, WORK(N+1), LWORK-N, IERR ) * The columns of U are normalized. The cost is O(M*N) flops. TEMP1 = DSQRT(DBLE(M)) * EPSLN DO 1973 p = 1, NR XSC = ONE / DNRM2( M, U(1,p), 1 ) IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) $ CALL DSCAL( M, XSC, U(1,p), 1 ) 1973 CONTINUE * * If the initial QRF is computed with row pivoting, the left * singular vectors must be adjusted. * IF ( ROWPIV ) $ CALL DLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 ) * ELSE * * .. the initial matrix A has almost orthogonal columns and * the second QRF is not needed * CALL DLACPY( 'Upper', N, N, A, LDA, WORK(N+1), N ) IF ( L2PERT ) THEN XSC = DSQRT(SMALL) DO 5970 p = 2, N TEMP1 = XSC * WORK( N + (p-1)*N + p ) DO 5971 q = 1, p - 1 WORK(N+(q-1)*N+p)=-DSIGN(TEMP1,WORK(N+(p-1)*N+q)) 5971 CONTINUE 5970 CONTINUE ELSE CALL DLASET( 'Lower',N-1,N-1,ZERO,ZERO,WORK(N+2),N ) END IF * CALL DGESVJ( 'Upper', 'U', 'N', N, N, WORK(N+1), N, SVA, $ N, U, LDU, WORK(N+N*N+1), LWORK-N-N*N, INFO ) * SCALEM = WORK(N+N*N+1) NUMRANK = IDNINT(WORK(N+N*N+2)) DO 6970 p = 1, N CALL DCOPY( N, WORK(N+(p-1)*N+1), 1, U(1,p), 1 ) CALL DSCAL( N, SVA(p), WORK(N+(p-1)*N+1), 1 ) 6970 CONTINUE * CALL DTRSM( 'Left', 'Upper', 'NoTrans', 'No UD', N, N, $ ONE, A, LDA, WORK(N+1), N ) DO 6972 p = 1, N CALL DCOPY( N, WORK(N+p), N, V(IWORK(p),1), LDV ) 6972 CONTINUE TEMP1 = DSQRT(DBLE(N))*EPSLN DO 6971 p = 1, N XSC = ONE / DNRM2( N, V(1,p), 1 ) IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) $ CALL DSCAL( N, XSC, V(1,p), 1 ) 6971 CONTINUE * * Assemble the left singular vector matrix U (M x N). * IF ( N .LT. M ) THEN CALL DLASET( 'A', M-N, N, ZERO, ZERO, U(N+1,1), LDU ) IF ( N .LT. N1 ) THEN CALL DLASET( 'A',N, N1-N, ZERO, ZERO, U(1,N+1),LDU ) CALL DLASET( 'A',M-N,N1-N, ZERO, ONE,U(N+1,N+1),LDU ) END IF END IF CALL DORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U, $ LDU, WORK(N+1), LWORK-N, IERR ) TEMP1 = DSQRT(DBLE(M))*EPSLN DO 6973 p = 1, N1 XSC = ONE / DNRM2( M, U(1,p), 1 ) IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) $ CALL DSCAL( M, XSC, U(1,p), 1 ) 6973 CONTINUE * IF ( ROWPIV ) $ CALL DLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 ) * END IF * * end of the >> almost orthogonal case << in the full SVD * ELSE * * This branch deploys a preconditioned Jacobi SVD with explicitly * accumulated rotations. It is included as optional, mainly for * experimental purposes. It does perfom well, and can also be used. * In this implementation, this branch will be automatically activated * if the condition number sigma_max(A) / sigma_min(A) is predicted * to be greater than the overflow threshold. This is because the * a posteriori computation of the singular vectors assumes robust * implementation of BLAS and some LAPACK procedures, capable of working * in presence of extreme values. Since that is not always the case, ... * DO 7968 p = 1, NR CALL DCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 ) 7968 CONTINUE * IF ( L2PERT ) THEN XSC = DSQRT(SMALL/EPSLN) DO 5969 q = 1, NR TEMP1 = XSC*DABS( V(q,q) ) DO 5968 p = 1, N IF ( ( p .GT. q ) .AND. ( DABS(V(p,q)) .LE. TEMP1 ) $ .OR. ( p .LT. q ) ) $ V(p,q) = DSIGN( TEMP1, V(p,q) ) IF ( p .LT. q ) V(p,q) = - V(p,q) 5968 CONTINUE 5969 CONTINUE ELSE CALL DLASET( 'U', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV ) END IF CALL DGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1), $ LWORK-2*N, IERR ) CALL DLACPY( 'L', N, NR, V, LDV, WORK(2*N+1), N ) * DO 7969 p = 1, NR CALL DCOPY( NR-p+1, V(p,p), LDV, U(p,p), 1 ) 7969 CONTINUE IF ( L2PERT ) THEN XSC = DSQRT(SMALL/EPSLN) DO 9970 q = 2, NR DO 9971 p = 1, q - 1 TEMP1 = XSC * MIN(DABS(U(p,p)),DABS(U(q,q))) U(p,q) = - DSIGN( TEMP1, U(q,p) ) 9971 CONTINUE 9970 CONTINUE ELSE CALL DLASET('U', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU ) END IF CALL DGESVJ( 'G', 'U', 'V', NR, NR, U, LDU, SVA, $ N, V, LDV, WORK(2*N+N*NR+1), LWORK-2*N-N*NR, INFO ) SCALEM = WORK(2*N+N*NR+1) NUMRANK = IDNINT(WORK(2*N+N*NR+2)) IF ( NR .LT. N ) THEN CALL DLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV ) CALL DLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV ) CALL DLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV ) END IF CALL DORMQR( 'L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1), $ V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR ) * * Permute the rows of V using the (column) permutation from the * first QRF. Also, scale the columns to make them unit in * Euclidean norm. This applies to all cases. * TEMP1 = DSQRT(DBLE(N)) * EPSLN DO 7972 q = 1, N DO 8972 p = 1, N WORK(2*N+N*NR+NR+IWORK(p)) = V(p,q) 8972 CONTINUE DO 8973 p = 1, N V(p,q) = WORK(2*N+N*NR+NR+p) 8973 CONTINUE XSC = ONE / DNRM2( N, V(1,q), 1 ) IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) $ CALL DSCAL( N, XSC, V(1,q), 1 ) 7972 CONTINUE * * At this moment, V contains the right singular vectors of A. * Next, assemble the left singular vector matrix U (M x N). * IF ( NR .LT. M ) THEN CALL DLASET( 'A', M-NR, NR, ZERO, ZERO, U(NR+1,1), LDU ) IF ( NR .LT. N1 ) THEN CALL DLASET( 'A',NR, N1-NR, ZERO, ZERO, U(1,NR+1),LDU ) CALL DLASET( 'A',M-NR,N1-NR, ZERO, ONE,U(NR+1,NR+1),LDU ) END IF END IF * CALL DORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U, $ LDU, WORK(N+1), LWORK-N, IERR ) * IF ( ROWPIV ) $ CALL DLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 ) * * END IF IF ( TRANSP ) THEN * .. swap U and V because the procedure worked on A^t DO 6974 p = 1, N CALL DSWAP( N, U(1,p), 1, V(1,p), 1 ) 6974 CONTINUE END IF * END IF * end of the full SVD * * Undo scaling, if necessary (and possible) * IF ( USCAL2 .LE. (BIG/SVA(1))*USCAL1 ) THEN CALL DLASCL( 'G', 0, 0, USCAL1, USCAL2, NR, 1, SVA, N, IERR ) USCAL1 = ONE USCAL2 = ONE END IF * IF ( NR .LT. N ) THEN DO 3004 p = NR+1, N SVA(p) = ZERO 3004 CONTINUE END IF * WORK(1) = USCAL2 * SCALEM WORK(2) = USCAL1 IF ( ERREST ) WORK(3) = SCONDA IF ( LSVEC .AND. RSVEC ) THEN WORK(4) = CONDR1 WORK(5) = CONDR2 END IF IF ( L2TRAN ) THEN WORK(6) = ENTRA WORK(7) = ENTRAT END IF * IWORK(1) = NR IWORK(2) = NUMRANK IWORK(3) = WARNING * RETURN * .. * .. END OF DGEJSV * .. END * *> \brief \b DGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGELQ2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGELQ2 computes an LQ factorization of a real m by n matrix A: *> A = L * Q. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is 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). *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (M) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> 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**T *> *> 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). *> \endverbatim *> * ===================================================================== SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. 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 *> \brief \b DGELQF * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGELQF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGELQF computes an LQ factorization of a real M-by-N matrix A: *> A = L * Q. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is 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). *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> 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**T *> *> 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). *> \endverbatim *> * ===================================================================== SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. 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 *> \brief DGELS solves overdetermined or underdetermined systems for GE matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGELS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, * INFO ) * * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGELS solves overdetermined or underdetermined real linear systems *> involving an M-by-N matrix A, or its transpose, using a QR or LQ *> factorization of A. It is assumed that A has full rank. *> *> The following options are provided: *> *> 1. If TRANS = 'N' and m >= n: find the least squares solution of *> an overdetermined system, i.e., solve the least squares problem *> minimize || B - A*X ||. *> *> 2. If TRANS = 'N' and m < n: find the minimum norm solution of *> an underdetermined system A * X = B. *> *> 3. If TRANS = 'T' and m >= n: find the minimum norm solution of *> an underdetermined system A**T * X = B. *> *> 4. If TRANS = 'T' and m < n: find the least squares solution of *> an overdetermined system, i.e., solve the least squares problem *> minimize || B - A**T * X ||. *> *> Several right hand side vectors b and solution vectors x can be *> handled in a single call; they are stored as the columns of the *> M-by-NRHS right hand side matrix B and the N-by-NRHS solution *> matrix X. *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': the linear system involves A; *> = 'T': the linear system involves A**T. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of *> columns of the matrices B and X. NRHS >=0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the M-by-N matrix A. *> On exit, *> if M >= N, A is overwritten by details of its QR *> factorization as returned by DGEQRF; *> if M < N, A is overwritten by details of its LQ *> factorization as returned by DGELQF. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> On entry, the matrix B of right hand side vectors, stored *> columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS *> if TRANS = 'T'. *> On exit, if INFO = 0, B is overwritten by the solution *> vectors, stored columnwise: *> if TRANS = 'N' and m >= n, rows 1 to n of B contain the least *> squares solution vectors; the residual sum of squares for the *> solution in each column is given by the sum of squares of *> elements N+1 to M in that column; *> if TRANS = 'N' and m < n, rows 1 to N of B contain the *> minimum norm solution vectors; *> if TRANS = 'T' and m >= n, rows 1 to M of B contain the *> minimum norm solution vectors; *> if TRANS = 'T' and m < n, rows 1 to M of B contain the *> least squares solution vectors; the residual sum of squares *> for the solution in each column is given by the sum of *> squares of elements M+1 to N in that column. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= MAX(1,M,N). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. *> LWORK >= max( 1, MN + max( MN, NRHS ) ). *> For optimal performance, *> LWORK >= max( 1, MN + max( MN, NRHS )*NB ). *> where MN = min(M,N) and NB is the optimum block size. *> *> 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, the i-th diagonal element of the *> triangular factor of A is zero, so that A does not have *> full rank; the least squares solution could not be *> computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEsolve * * ===================================================================== SUBROUTINE DGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, $ INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER TRANS INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, TPSD INTEGER BROW, I, IASCL, IBSCL, J, MN, NB, SCLLEN, WSIZE DOUBLE PRECISION ANRM, BIGNUM, BNRM, SMLNUM * .. * .. Local Arrays .. DOUBLE PRECISION RWORK( 1 ) * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL LSAME, ILAENV, DLABAD, DLAMCH, DLANGE * .. * .. External Subroutines .. EXTERNAL DGELQF, DGEQRF, DLASCL, DLASET, DORMLQ, DORMQR, $ DTRTRS, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments. * INFO = 0 MN = MIN( M, N ) LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.( LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'T' ) ) ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( NRHS.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN INFO = -8 ELSE IF( LWORK.LT.MAX( 1, MN+MAX( MN, NRHS ) ) .AND. .NOT.LQUERY ) $ THEN INFO = -10 END IF * * Figure out optimal block size * IF( INFO.EQ.0 .OR. INFO.EQ.-10 ) THEN * TPSD = .TRUE. IF( LSAME( TRANS, 'N' ) ) $ TPSD = .FALSE. * IF( M.GE.N ) THEN NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) IF( TPSD ) THEN NB = MAX( NB, ILAENV( 1, 'DORMQR', 'LN', M, NRHS, N, $ -1 ) ) ELSE NB = MAX( NB, ILAENV( 1, 'DORMQR', 'LT', M, NRHS, N, $ -1 ) ) END IF ELSE NB = ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) IF( TPSD ) THEN NB = MAX( NB, ILAENV( 1, 'DORMLQ', 'LT', N, NRHS, M, $ -1 ) ) ELSE NB = MAX( NB, ILAENV( 1, 'DORMLQ', 'LN', N, NRHS, M, $ -1 ) ) END IF END IF * WSIZE = MAX( 1, MN+MAX( MN, NRHS )*NB ) WORK( 1 ) = DBLE( WSIZE ) * END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGELS ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( MIN( M, N, NRHS ).EQ.0 ) THEN CALL DLASET( 'Full', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB ) RETURN END IF * * Get machine parameters * SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) * * Scale A, B if max element outside range [SMLNUM,BIGNUM] * ANRM = DLANGE( 'M', M, N, A, LDA, RWORK ) IASCL = 0 IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN * * Scale matrix norm up to SMLNUM * CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO ) IASCL = 1 ELSE IF( ANRM.GT.BIGNUM ) THEN * * Scale matrix norm down to BIGNUM * CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO ) IASCL = 2 ELSE IF( ANRM.EQ.ZERO ) THEN * * Matrix all zero. Return zero solution. * CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB ) GO TO 50 END IF * BROW = M IF( TPSD ) $ BROW = N BNRM = DLANGE( 'M', BROW, NRHS, B, LDB, RWORK ) IBSCL = 0 IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN * * Scale matrix norm up to SMLNUM * CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, BROW, NRHS, B, LDB, $ INFO ) IBSCL = 1 ELSE IF( BNRM.GT.BIGNUM ) THEN * * Scale matrix norm down to BIGNUM * CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, BROW, NRHS, B, LDB, $ INFO ) IBSCL = 2 END IF * IF( M.GE.N ) THEN * * compute QR factorization of A * CALL DGEQRF( M, N, A, LDA, WORK( 1 ), WORK( MN+1 ), LWORK-MN, $ INFO ) * * workspace at least N, optimally N*NB * IF( .NOT.TPSD ) THEN * * Least-Squares Problem min || A * X - B || * * B(1:M,1:NRHS) := Q**T * B(1:M,1:NRHS) * CALL DORMQR( 'Left', 'Transpose', M, NRHS, N, A, LDA, $ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN, $ INFO ) * * workspace at least NRHS, optimally NRHS*NB * * B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS) * CALL DTRTRS( 'Upper', 'No transpose', 'Non-unit', N, NRHS, $ A, LDA, B, LDB, INFO ) * IF( INFO.GT.0 ) THEN RETURN END IF * SCLLEN = N * ELSE * * Underdetermined system of equations A**T * X = B * * B(1:N,1:NRHS) := inv(R**T) * B(1:N,1:NRHS) * CALL DTRTRS( 'Upper', 'Transpose', 'Non-unit', N, NRHS, $ A, LDA, B, LDB, INFO ) * IF( INFO.GT.0 ) THEN RETURN END IF * * B(N+1:M,1:NRHS) = ZERO * DO 20 J = 1, NRHS DO 10 I = N + 1, M B( I, J ) = ZERO 10 CONTINUE 20 CONTINUE * * B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS) * CALL DORMQR( 'Left', 'No transpose', M, NRHS, N, A, LDA, $ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN, $ INFO ) * * workspace at least NRHS, optimally NRHS*NB * SCLLEN = M * END IF * ELSE * * Compute LQ factorization of A * CALL DGELQF( M, N, A, LDA, WORK( 1 ), WORK( MN+1 ), LWORK-MN, $ INFO ) * * workspace at least M, optimally M*NB. * IF( .NOT.TPSD ) THEN * * underdetermined system of equations A * X = B * * B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS) * CALL DTRTRS( 'Lower', 'No transpose', 'Non-unit', M, NRHS, $ A, LDA, B, LDB, INFO ) * IF( INFO.GT.0 ) THEN RETURN END IF * * B(M+1:N,1:NRHS) = 0 * DO 40 J = 1, NRHS DO 30 I = M + 1, N B( I, J ) = ZERO 30 CONTINUE 40 CONTINUE * * B(1:N,1:NRHS) := Q(1:N,:)**T * B(1:M,1:NRHS) * CALL DORMLQ( 'Left', 'Transpose', N, NRHS, M, A, LDA, $ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN, $ INFO ) * * workspace at least NRHS, optimally NRHS*NB * SCLLEN = N * ELSE * * overdetermined system min || A**T * X - B || * * B(1:N,1:NRHS) := Q * B(1:N,1:NRHS) * CALL DORMLQ( 'Left', 'No transpose', N, NRHS, M, A, LDA, $ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN, $ INFO ) * * workspace at least NRHS, optimally NRHS*NB * * B(1:M,1:NRHS) := inv(L**T) * B(1:M,1:NRHS) * CALL DTRTRS( 'Lower', 'Transpose', 'Non-unit', M, NRHS, $ A, LDA, B, LDB, INFO ) * IF( INFO.GT.0 ) THEN RETURN END IF * SCLLEN = M * END IF * END IF * * Undo scaling * IF( IASCL.EQ.1 ) THEN CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, SCLLEN, NRHS, B, LDB, $ INFO ) ELSE IF( IASCL.EQ.2 ) THEN CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, SCLLEN, NRHS, B, LDB, $ INFO ) END IF IF( IBSCL.EQ.1 ) THEN CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, SCLLEN, NRHS, B, LDB, $ INFO ) ELSE IF( IBSCL.EQ.2 ) THEN CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, SCLLEN, NRHS, B, LDB, $ INFO ) END IF * 50 CONTINUE WORK( 1 ) = DBLE( WSIZE ) * RETURN * * End of DGELS * END *> \brief DGELSD computes the minimum-norm solution to a linear least squares problem for GE matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGELSD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, * WORK, LWORK, IWORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK * DOUBLE PRECISION RCOND * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGELSD computes the minimum-norm solution to a real linear least *> squares problem: *> minimize 2-norm(| b - A*x |) *> using the singular value decomposition (SVD) of A. A is an M-by-N *> matrix which may be rank-deficient. *> *> Several right hand side vectors b and solution vectors x can be *> handled in a single call; they are stored as the columns of the *> M-by-NRHS right hand side matrix B and the N-by-NRHS solution *> matrix X. *> *> The problem is solved in three steps: *> (1) Reduce the coefficient matrix A to bidiagonal form with *> Householder transformations, reducing the original problem *> into a "bidiagonal least squares problem" (BLS) *> (2) Solve the BLS using a divide and conquer approach. *> (3) Apply back all the Householder transformations to solve *> the original least squares problem. *> *> The effective rank of A is determined by treating as zero those *> singular values which are less than RCOND times the largest singular *> value. *> *> The divide and conquer algorithm makes very mild assumptions about *> floating point arithmetic. It will work on machines with a guard *> digit in add/subtract, or on those binary machines without guard *> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or *> Cray-2. It could conceivably fail on hexadecimal or decimal machines *> without guard digits, but we know of none. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrices B and X. NRHS >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the M-by-N matrix A. *> On exit, A has been destroyed. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> On entry, the M-by-NRHS right hand side matrix B. *> On exit, B is overwritten by the N-by-NRHS solution *> matrix X. If m >= n and RANK = n, the residual *> sum-of-squares for the solution in the i-th column is given *> by the sum of squares of elements n+1:m in that column. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,max(M,N)). *> \endverbatim *> *> \param[out] S *> \verbatim *> S is DOUBLE PRECISION array, dimension (min(M,N)) *> The singular values of A in decreasing order. *> The condition number of A in the 2-norm = S(1)/S(min(m,n)). *> \endverbatim *> *> \param[in] RCOND *> \verbatim *> RCOND is DOUBLE PRECISION *> RCOND is used to determine the effective rank of A. *> Singular values S(i) <= RCOND*S(1) are treated as zero. *> If RCOND < 0, machine precision is used instead. *> \endverbatim *> *> \param[out] RANK *> \verbatim *> RANK is INTEGER *> The effective rank of A, i.e., the number of singular values *> which are greater than RCOND*S(1). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK must be at least 1. *> The exact minimum amount of workspace needed depends on M, *> N and NRHS. As long as LWORK is at least *> 12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2, *> if M is greater than or equal to N or *> 12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2, *> if M is less than N, the code will execute correctly. *> SMLSIZ is returned by ILAENV and is equal to the maximum *> size of the subproblems at the bottom of the computation *> tree (usually about 25), and *> NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 ) *> For good performance, LWORK should generally be larger. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error *> message related to LWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) *> LIWORK >= max(1, 3 * MINMN * NLVL + 11 * MINMN), *> where MINMN = MIN( M,N ). *> On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: the algorithm for computing the SVD failed to converge; *> if INFO = i, i off-diagonal elements of an intermediate *> bidiagonal form did not converge to zero. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup doubleGEsolve * *> \par Contributors: * ================== *> *> Ming Gu and Ren-Cang Li, Computer Science Division, University of *> California at Berkeley, USA \n *> Osni Marques, LBNL/NERSC, USA \n * * ===================================================================== SUBROUTINE DGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, $ WORK, LWORK, IWORK, INFO ) * * -- LAPACK driver routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK DOUBLE PRECISION RCOND * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER IASCL, IBSCL, IE, IL, ITAU, ITAUP, ITAUQ, $ LDWORK, LIWORK, MAXMN, MAXWRK, MINMN, MINWRK, $ MM, MNTHR, NLVL, NWORK, SMLSIZ, WLALSD DOUBLE PRECISION ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM * .. * .. External Subroutines .. EXTERNAL DGEBRD, DGELQF, DGEQRF, DLABAD, DLACPY, DLALSD, $ DLASCL, DLASET, DORMBR, DORMLQ, DORMQR, XERBLA * .. * .. External Functions .. INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL ILAENV, DLAMCH, DLANGE * .. * .. Intrinsic Functions .. INTRINSIC DBLE, INT, LOG, MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments. * INFO = 0 MINMN = MIN( M, N ) MAXMN = MAX( M, N ) MNTHR = ILAENV( 6, 'DGELSD', ' ', M, N, NRHS, -1 ) LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( NRHS.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, MAXMN ) ) THEN INFO = -7 END IF * SMLSIZ = ILAENV( 9, 'DGELSD', ' ', 0, 0, 0, 0 ) * * Compute workspace. * (Note: Comments in the code beginning "Workspace:" describe the * minimal amount of workspace needed at that point in the code, * as well as the preferred amount for good performance. * NB refers to the optimal block size for the immediately * following subroutine, as returned by ILAENV.) * MINWRK = 1 LIWORK = 1 MINMN = MAX( 1, MINMN ) NLVL = MAX( INT( LOG( DBLE( MINMN ) / DBLE( SMLSIZ+1 ) ) / $ LOG( TWO ) ) + 1, 0 ) * IF( INFO.EQ.0 ) THEN MAXWRK = 0 LIWORK = 3*MINMN*NLVL + 11*MINMN MM = M IF( M.GE.N .AND. M.GE.MNTHR ) THEN * * Path 1a - overdetermined, with many more rows than columns. * MM = N MAXWRK = MAX( MAXWRK, N+N*ILAENV( 1, 'DGEQRF', ' ', M, N, $ -1, -1 ) ) MAXWRK = MAX( MAXWRK, N+NRHS* $ ILAENV( 1, 'DORMQR', 'LT', M, NRHS, N, -1 ) ) END IF IF( M.GE.N ) THEN * * Path 1 - overdetermined or exactly determined. * MAXWRK = MAX( MAXWRK, 3*N+( MM+N )* $ ILAENV( 1, 'DGEBRD', ' ', MM, N, -1, -1 ) ) MAXWRK = MAX( MAXWRK, 3*N+NRHS* $ ILAENV( 1, 'DORMBR', 'QLT', MM, NRHS, N, -1 ) ) MAXWRK = MAX( MAXWRK, 3*N+( N-1 )* $ ILAENV( 1, 'DORMBR', 'PLN', N, NRHS, N, -1 ) ) WLALSD = 9*N+2*N*SMLSIZ+8*N*NLVL+N*NRHS+(SMLSIZ+1)**2 MAXWRK = MAX( MAXWRK, 3*N+WLALSD ) MINWRK = MAX( 3*N+MM, 3*N+NRHS, 3*N+WLALSD ) END IF IF( N.GT.M ) THEN WLALSD = 9*M+2*M*SMLSIZ+8*M*NLVL+M*NRHS+(SMLSIZ+1)**2 IF( N.GE.MNTHR ) THEN * * Path 2a - underdetermined, with many more columns * than rows. * MAXWRK = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) MAXWRK = MAX( MAXWRK, M*M+4*M+2*M* $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) MAXWRK = MAX( MAXWRK, M*M+4*M+NRHS* $ ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, M, -1 ) ) MAXWRK = MAX( MAXWRK, M*M+4*M+( M-1 )* $ ILAENV( 1, 'DORMBR', 'PLN', M, NRHS, M, -1 ) ) IF( NRHS.GT.1 ) THEN MAXWRK = MAX( MAXWRK, M*M+M+M*NRHS ) ELSE MAXWRK = MAX( MAXWRK, M*M+2*M ) END IF MAXWRK = MAX( MAXWRK, M+NRHS* $ ILAENV( 1, 'DORMLQ', 'LT', N, NRHS, M, -1 ) ) MAXWRK = MAX( MAXWRK, M*M+4*M+WLALSD ) ! XXX: Ensure the Path 2a case below is triggered. The workspace ! calculation should use queries for all routines eventually. MAXWRK = MAX( MAXWRK, $ 4*M+M*M+MAX( M, 2*M-4, NRHS, N-3*M ) ) ELSE * * Path 2 - remaining underdetermined cases. * MAXWRK = 3*M + ( N+M )*ILAENV( 1, 'DGEBRD', ' ', M, N, $ -1, -1 ) MAXWRK = MAX( MAXWRK, 3*M+NRHS* $ ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, N, -1 ) ) MAXWRK = MAX( MAXWRK, 3*M+M* $ ILAENV( 1, 'DORMBR', 'PLN', N, NRHS, M, -1 ) ) MAXWRK = MAX( MAXWRK, 3*M+WLALSD ) END IF MINWRK = MAX( 3*M+NRHS, 3*M+M, 3*M+WLALSD ) END IF MINWRK = MIN( MINWRK, MAXWRK ) WORK( 1 ) = MAXWRK IWORK( 1 ) = LIWORK IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN INFO = -12 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGELSD', -INFO ) RETURN ELSE IF( LQUERY ) THEN GO TO 10 END IF * * Quick return if possible. * IF( M.EQ.0 .OR. N.EQ.0 ) THEN RANK = 0 RETURN END IF * * Get machine parameters. * EPS = DLAMCH( 'P' ) SFMIN = DLAMCH( 'S' ) SMLNUM = SFMIN / EPS BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) * * Scale A if max entry outside range [SMLNUM,BIGNUM]. * ANRM = DLANGE( 'M', M, N, A, LDA, WORK ) IASCL = 0 IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN * * Scale matrix norm up to SMLNUM. * CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO ) IASCL = 1 ELSE IF( ANRM.GT.BIGNUM ) THEN * * Scale matrix norm down to BIGNUM. * CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO ) IASCL = 2 ELSE IF( ANRM.EQ.ZERO ) THEN * * Matrix all zero. Return zero solution. * CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB ) CALL DLASET( 'F', MINMN, 1, ZERO, ZERO, S, 1 ) RANK = 0 GO TO 10 END IF * * Scale B if max entry outside range [SMLNUM,BIGNUM]. * BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK ) IBSCL = 0 IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN * * Scale matrix norm up to SMLNUM. * CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO ) IBSCL = 1 ELSE IF( BNRM.GT.BIGNUM ) THEN * * Scale matrix norm down to BIGNUM. * CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO ) IBSCL = 2 END IF * * If M < N make sure certain entries of B are zero. * IF( M.LT.N ) $ CALL DLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB ) * * Overdetermined case. * IF( M.GE.N ) THEN * * Path 1 - overdetermined or exactly determined. * MM = M IF( M.GE.MNTHR ) THEN * * Path 1a - overdetermined, with many more rows than columns. * MM = N ITAU = 1 NWORK = ITAU + N * * Compute A=Q*R. * (Workspace: need 2*N, prefer N+N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), $ LWORK-NWORK+1, INFO ) * * Multiply B by transpose(Q). * (Workspace: need N+NRHS, prefer N+NRHS*NB) * CALL DORMQR( 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAU ), B, $ LDB, WORK( NWORK ), LWORK-NWORK+1, INFO ) * * Zero out below R. * IF( N.GT.1 ) THEN CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA ) END IF END IF * IE = 1 ITAUQ = IE + N ITAUP = ITAUQ + N NWORK = ITAUP + N * * Bidiagonalize R in A. * (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) * CALL DGEBRD( MM, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, $ INFO ) * * Multiply B by transpose of left bidiagonalizing vectors of R. * (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) * CALL DORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, WORK( ITAUQ ), $ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO ) * * Solve the bidiagonal least squares problem. * CALL DLALSD( 'U', SMLSIZ, N, NRHS, S, WORK( IE ), B, LDB, $ RCOND, RANK, WORK( NWORK ), IWORK, INFO ) IF( INFO.NE.0 ) THEN GO TO 10 END IF * * Multiply B by right bidiagonalizing vectors of R. * CALL DORMBR( 'P', 'L', 'N', N, NRHS, N, A, LDA, WORK( ITAUP ), $ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO ) * ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+ $ MAX( M, 2*M-4, NRHS, N-3*M, WLALSD ) ) THEN * * Path 2a - underdetermined, with many more columns than rows * and sufficient workspace for an efficient algorithm. * LDWORK = M IF( LWORK.GE.MAX( 4*M+M*LDA+MAX( M, 2*M-4, NRHS, N-3*M ), $ M*LDA+M+M*NRHS, 4*M+M*LDA+WLALSD ) )LDWORK = LDA ITAU = 1 NWORK = M + 1 * * Compute A=L*Q. * (Workspace: need 2*M, prefer M+M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), $ LWORK-NWORK+1, INFO ) IL = NWORK * * Copy L to WORK(IL), zeroing out above its diagonal. * CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK ) CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( IL+LDWORK ), $ LDWORK ) IE = IL + LDWORK*M ITAUQ = IE + M ITAUP = ITAUQ + M NWORK = ITAUP + M * * Bidiagonalize L in WORK(IL). * (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) * CALL DGEBRD( M, M, WORK( IL ), LDWORK, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), $ LWORK-NWORK+1, INFO ) * * Multiply B by transpose of left bidiagonalizing vectors of L. * (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) * CALL DORMBR( 'Q', 'L', 'T', M, NRHS, M, WORK( IL ), LDWORK, $ WORK( ITAUQ ), B, LDB, WORK( NWORK ), $ LWORK-NWORK+1, INFO ) * * Solve the bidiagonal least squares problem. * CALL DLALSD( 'U', SMLSIZ, M, NRHS, S, WORK( IE ), B, LDB, $ RCOND, RANK, WORK( NWORK ), IWORK, INFO ) IF( INFO.NE.0 ) THEN GO TO 10 END IF * * Multiply B by right bidiagonalizing vectors of L. * CALL DORMBR( 'P', 'L', 'N', M, NRHS, M, WORK( IL ), LDWORK, $ WORK( ITAUP ), B, LDB, WORK( NWORK ), $ LWORK-NWORK+1, INFO ) * * Zero out below first M rows of B. * CALL DLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB ) NWORK = ITAU + M * * Multiply transpose(Q) by B. * (Workspace: need M+NRHS, prefer M+NRHS*NB) * CALL DORMLQ( 'L', 'T', N, NRHS, M, A, LDA, WORK( ITAU ), B, $ LDB, WORK( NWORK ), LWORK-NWORK+1, INFO ) * ELSE * * Path 2 - remaining underdetermined cases. * IE = 1 ITAUQ = IE + M ITAUP = ITAUQ + M NWORK = ITAUP + M * * Bidiagonalize A. * (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) * CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, $ INFO ) * * Multiply B by transpose of left bidiagonalizing vectors. * (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) * CALL DORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAUQ ), $ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO ) * * Solve the bidiagonal least squares problem. * CALL DLALSD( 'L', SMLSIZ, M, NRHS, S, WORK( IE ), B, LDB, $ RCOND, RANK, WORK( NWORK ), IWORK, INFO ) IF( INFO.NE.0 ) THEN GO TO 10 END IF * * Multiply B by right bidiagonalizing vectors of A. * CALL DORMBR( 'P', 'L', 'N', N, NRHS, M, A, LDA, WORK( ITAUP ), $ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO ) * END IF * * Undo scaling. * IF( IASCL.EQ.1 ) THEN CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO ) CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN, $ INFO ) ELSE IF( IASCL.EQ.2 ) THEN CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO ) CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN, $ INFO ) END IF IF( IBSCL.EQ.1 ) THEN CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO ) ELSE IF( IBSCL.EQ.2 ) THEN CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO ) END IF * 10 CONTINUE WORK( 1 ) = MAXWRK IWORK( 1 ) = LIWORK RETURN * * End of DGELSD * END *> \brief DGELSS solves overdetermined or underdetermined systems for GE matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGELSS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, * WORK, LWORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK * DOUBLE PRECISION RCOND * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGELSS computes the minimum norm solution to a real linear least *> squares problem: *> *> Minimize 2-norm(| b - A*x |). *> *> using the singular value decomposition (SVD) of A. A is an M-by-N *> matrix which may be rank-deficient. *> *> Several right hand side vectors b and solution vectors x can be *> handled in a single call; they are stored as the columns of the *> M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix *> X. *> *> The effective rank of A is determined by treating as zero those *> singular values which are less than RCOND times the largest singular *> value. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrices B and X. NRHS >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the M-by-N matrix A. *> On exit, the first min(m,n) rows of A are overwritten with *> its right singular vectors, stored rowwise. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> On entry, the M-by-NRHS right hand side matrix B. *> On exit, B is overwritten by the N-by-NRHS solution *> matrix X. If m >= n and RANK = n, the residual *> sum-of-squares for the solution in the i-th column is given *> by the sum of squares of elements n+1:m in that column. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,max(M,N)). *> \endverbatim *> *> \param[out] S *> \verbatim *> S is DOUBLE PRECISION array, dimension (min(M,N)) *> The singular values of A in decreasing order. *> The condition number of A in the 2-norm = S(1)/S(min(m,n)). *> \endverbatim *> *> \param[in] RCOND *> \verbatim *> RCOND is DOUBLE PRECISION *> RCOND is used to determine the effective rank of A. *> Singular values S(i) <= RCOND*S(1) are treated as zero. *> If RCOND < 0, machine precision is used instead. *> \endverbatim *> *> \param[out] RANK *> \verbatim *> RANK is INTEGER *> The effective rank of A, i.e., the number of singular values *> which are greater than RCOND*S(1). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= 1, and also: *> LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS ) *> For good performance, LWORK should generally be larger. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error *> message related to LWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: the algorithm for computing the SVD failed to converge; *> if INFO = i, i off-diagonal elements of an intermediate *> bidiagonal form did not converge to zero. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEsolve * * ===================================================================== SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, $ WORK, LWORK, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK DOUBLE PRECISION RCOND * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER BDSPAC, BL, CHUNK, I, IASCL, IBSCL, IE, IL, $ ITAU, ITAUP, ITAUQ, IWORK, LDWORK, MAXMN, $ MAXWRK, MINMN, MINWRK, MM, MNTHR INTEGER LWORK_DGEQRF, LWORK_DORMQR, LWORK_DGEBRD, $ LWORK_DORMBR, LWORK_DORGBR, LWORK_DORMLQ, $ LWORK_DGELQF DOUBLE PRECISION ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM, THR * .. * .. Local Arrays .. DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. EXTERNAL DBDSQR, DCOPY, DGEBRD, DGELQF, DGEMM, DGEMV, $ DGEQRF, DLABAD, DLACPY, DLASCL, DLASET, DORGBR, $ DORMBR, DORMLQ, DORMQR, DRSCL, XERBLA * .. * .. External Functions .. INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL ILAENV, DLAMCH, DLANGE * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 MINMN = MIN( M, N ) MAXMN = MAX( M, N ) LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) 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, M ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, MAXMN ) ) THEN INFO = -7 END IF * * Compute workspace * (Note: Comments in the code beginning "Workspace:" describe the * minimal amount of workspace needed at that point in the code, * as well as the preferred amount for good performance. * NB refers to the optimal block size for the immediately * following subroutine, as returned by ILAENV.) * IF( INFO.EQ.0 ) THEN MINWRK = 1 MAXWRK = 1 IF( MINMN.GT.0 ) THEN MM = M MNTHR = ILAENV( 6, 'DGELSS', ' ', M, N, NRHS, -1 ) IF( M.GE.N .AND. M.GE.MNTHR ) THEN * * Path 1a - overdetermined, with many more rows than * columns * * Compute space needed for DGEQRF CALL DGEQRF( M, N, A, LDA, DUM(1), DUM(1), -1, INFO ) LWORK_DGEQRF=DUM(1) * Compute space needed for DORMQR CALL DORMQR( 'L', 'T', M, NRHS, N, A, LDA, DUM(1), B, $ LDB, DUM(1), -1, INFO ) LWORK_DORMQR=DUM(1) MM = N MAXWRK = MAX( MAXWRK, N + LWORK_DGEQRF ) MAXWRK = MAX( MAXWRK, N + LWORK_DORMQR ) END IF IF( M.GE.N ) THEN * * Path 1 - overdetermined or exactly determined * * Compute workspace needed for DBDSQR * BDSPAC = MAX( 1, 5*N ) * Compute space needed for DGEBRD CALL DGEBRD( MM, N, A, LDA, S, DUM(1), DUM(1), $ DUM(1), DUM(1), -1, INFO ) LWORK_DGEBRD=DUM(1) * Compute space needed for DORMBR CALL DORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, DUM(1), $ B, LDB, DUM(1), -1, INFO ) LWORK_DORMBR=DUM(1) * Compute space needed for DORGBR CALL DORGBR( 'P', N, N, N, A, LDA, DUM(1), $ DUM(1), -1, INFO ) LWORK_DORGBR=DUM(1) * Compute total workspace needed MAXWRK = MAX( MAXWRK, 3*N + LWORK_DGEBRD ) MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORMBR ) MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORGBR ) MAXWRK = MAX( MAXWRK, BDSPAC ) MAXWRK = MAX( MAXWRK, N*NRHS ) MINWRK = MAX( 3*N + MM, 3*N + NRHS, BDSPAC ) MAXWRK = MAX( MINWRK, MAXWRK ) END IF IF( N.GT.M ) THEN * * Compute workspace needed for DBDSQR * BDSPAC = MAX( 1, 5*M ) MINWRK = MAX( 3*M+NRHS, 3*M+N, BDSPAC ) IF( N.GE.MNTHR ) THEN * * Path 2a - underdetermined, with many more columns * than rows * * Compute space needed for DGELQF CALL DGELQF( M, N, A, LDA, DUM(1), DUM(1), $ -1, INFO ) LWORK_DGELQF=DUM(1) * Compute space needed for DGEBRD CALL DGEBRD( M, M, A, LDA, S, DUM(1), DUM(1), $ DUM(1), DUM(1), -1, INFO ) LWORK_DGEBRD=DUM(1) * Compute space needed for DORMBR CALL DORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, $ DUM(1), B, LDB, DUM(1), -1, INFO ) LWORK_DORMBR=DUM(1) * Compute space needed for DORGBR CALL DORGBR( 'P', M, M, M, A, LDA, DUM(1), $ DUM(1), -1, INFO ) LWORK_DORGBR=DUM(1) * Compute space needed for DORMLQ CALL DORMLQ( 'L', 'T', N, NRHS, M, A, LDA, DUM(1), $ B, LDB, DUM(1), -1, INFO ) LWORK_DORMLQ=DUM(1) * Compute total workspace needed MAXWRK = M + LWORK_DGELQF MAXWRK = MAX( MAXWRK, M*M + 4*M + LWORK_DGEBRD ) MAXWRK = MAX( MAXWRK, M*M + 4*M + LWORK_DORMBR ) MAXWRK = MAX( MAXWRK, M*M + 4*M + LWORK_DORGBR ) MAXWRK = MAX( MAXWRK, M*M + M + BDSPAC ) IF( NRHS.GT.1 ) THEN MAXWRK = MAX( MAXWRK, M*M + M + M*NRHS ) ELSE MAXWRK = MAX( MAXWRK, M*M + 2*M ) END IF MAXWRK = MAX( MAXWRK, M + LWORK_DORMLQ ) ELSE * * Path 2 - underdetermined * * Compute space needed for DGEBRD CALL DGEBRD( M, N, A, LDA, S, DUM(1), DUM(1), $ DUM(1), DUM(1), -1, INFO ) LWORK_DGEBRD=DUM(1) * Compute space needed for DORMBR CALL DORMBR( 'Q', 'L', 'T', M, NRHS, M, A, LDA, $ DUM(1), B, LDB, DUM(1), -1, INFO ) LWORK_DORMBR=DUM(1) * Compute space needed for DORGBR CALL DORGBR( 'P', M, N, M, A, LDA, DUM(1), $ DUM(1), -1, INFO ) LWORK_DORGBR=DUM(1) MAXWRK = 3*M + LWORK_DGEBRD MAXWRK = MAX( MAXWRK, 3*M + LWORK_DORMBR ) MAXWRK = MAX( MAXWRK, 3*M + LWORK_DORGBR ) MAXWRK = MAX( MAXWRK, BDSPAC ) MAXWRK = MAX( MAXWRK, N*NRHS ) END IF END IF MAXWRK = MAX( MINWRK, MAXWRK ) END IF WORK( 1 ) = MAXWRK * IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) $ INFO = -12 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGELSS', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) THEN RANK = 0 RETURN END IF * * Get machine parameters * EPS = DLAMCH( 'P' ) SFMIN = DLAMCH( 'S' ) SMLNUM = SFMIN / EPS BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) * * Scale A if max element outside range [SMLNUM,BIGNUM] * ANRM = DLANGE( 'M', M, N, A, LDA, WORK ) IASCL = 0 IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN * * Scale matrix norm up to SMLNUM * CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO ) IASCL = 1 ELSE IF( ANRM.GT.BIGNUM ) THEN * * Scale matrix norm down to BIGNUM * CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO ) IASCL = 2 ELSE IF( ANRM.EQ.ZERO ) THEN * * Matrix all zero. Return zero solution. * CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB ) CALL DLASET( 'F', MINMN, 1, ZERO, ZERO, S, MINMN ) RANK = 0 GO TO 70 END IF * * Scale B if max element outside range [SMLNUM,BIGNUM] * BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK ) IBSCL = 0 IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN * * Scale matrix norm up to SMLNUM * CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO ) IBSCL = 1 ELSE IF( BNRM.GT.BIGNUM ) THEN * * Scale matrix norm down to BIGNUM * CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO ) IBSCL = 2 END IF * * Overdetermined case * IF( M.GE.N ) THEN * * Path 1 - overdetermined or exactly determined * MM = M IF( M.GE.MNTHR ) THEN * * Path 1a - overdetermined, with many more rows than columns * MM = N ITAU = 1 IWORK = ITAU + N * * Compute A=Q*R * (Workspace: need 2*N, prefer N+N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), $ LWORK-IWORK+1, INFO ) * * Multiply B by transpose(Q) * (Workspace: need N+NRHS, prefer N+NRHS*NB) * CALL DORMQR( 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAU ), B, $ LDB, WORK( IWORK ), LWORK-IWORK+1, INFO ) * * Zero out below R * IF( N.GT.1 ) $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA ) END IF * IE = 1 ITAUQ = IE + N ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize R in A * (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) * CALL DGEBRD( MM, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, $ INFO ) * * Multiply B by transpose of left bidiagonalizing vectors of R * (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) * CALL DORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, WORK( ITAUQ ), $ B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO ) * * Generate right bidiagonalizing vectors of R in A * (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) * CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, INFO ) IWORK = IE + N * * Perform bidiagonal QR iteration * multiply B by transpose of left singular vectors * compute right singular vectors in A * (Workspace: need BDSPAC) * CALL DBDSQR( 'U', N, N, 0, NRHS, S, WORK( IE ), A, LDA, DUM, $ 1, B, LDB, WORK( IWORK ), INFO ) IF( INFO.NE.0 ) $ GO TO 70 * * Multiply B by reciprocals of singular values * THR = MAX( RCOND*S( 1 ), SFMIN ) IF( RCOND.LT.ZERO ) $ THR = MAX( EPS*S( 1 ), SFMIN ) RANK = 0 DO 10 I = 1, N IF( S( I ).GT.THR ) THEN CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB ) RANK = RANK + 1 ELSE CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB ) END IF 10 CONTINUE * * Multiply B by right singular vectors * (Workspace: need N, prefer N*NRHS) * IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, A, LDA, B, LDB, ZERO, $ WORK, LDB ) CALL DLACPY( 'G', N, NRHS, WORK, LDB, B, LDB ) ELSE IF( NRHS.GT.1 ) THEN CHUNK = LWORK / N DO 20 I = 1, NRHS, CHUNK BL = MIN( NRHS-I+1, CHUNK ) CALL DGEMM( 'T', 'N', N, BL, N, ONE, A, LDA, B( 1, I ), $ LDB, ZERO, WORK, N ) CALL DLACPY( 'G', N, BL, WORK, N, B( 1, I ), LDB ) 20 CONTINUE ELSE CALL DGEMV( 'T', N, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 ) CALL DCOPY( N, WORK, 1, B, 1 ) END IF * ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+ $ MAX( M, 2*M-4, NRHS, N-3*M ) ) THEN * * Path 2a - underdetermined, with many more columns than rows * and sufficient workspace for an efficient algorithm * LDWORK = M IF( LWORK.GE.MAX( 4*M+M*LDA+MAX( M, 2*M-4, NRHS, N-3*M ), $ M*LDA+M+M*NRHS ) )LDWORK = LDA ITAU = 1 IWORK = M + 1 * * Compute A=L*Q * (Workspace: need 2*M, prefer M+M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), $ LWORK-IWORK+1, INFO ) IL = IWORK * * Copy L to WORK(IL), zeroing out above it * CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK ) CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( IL+LDWORK ), $ LDWORK ) IE = IL + LDWORK*M ITAUQ = IE + M ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize L in WORK(IL) * (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) * CALL DGEBRD( M, M, WORK( IL ), LDWORK, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, INFO ) * * Multiply B by transpose of left bidiagonalizing vectors of L * (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) * CALL DORMBR( 'Q', 'L', 'T', M, NRHS, M, WORK( IL ), LDWORK, $ WORK( ITAUQ ), B, LDB, WORK( IWORK ), $ LWORK-IWORK+1, INFO ) * * Generate right bidiagonalizing vectors of R in WORK(IL) * (Workspace: need M*M+5*M-1, prefer M*M+4*M+(M-1)*NB) * CALL DORGBR( 'P', M, M, M, WORK( IL ), LDWORK, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, INFO ) IWORK = IE + M * * Perform bidiagonal QR iteration, * computing right singular vectors of L in WORK(IL) and * multiplying B by transpose of left singular vectors * (Workspace: need M*M+M+BDSPAC) * CALL DBDSQR( 'U', M, M, 0, NRHS, S, WORK( IE ), WORK( IL ), $ LDWORK, A, LDA, B, LDB, WORK( IWORK ), INFO ) IF( INFO.NE.0 ) $ GO TO 70 * * Multiply B by reciprocals of singular values * THR = MAX( RCOND*S( 1 ), SFMIN ) IF( RCOND.LT.ZERO ) $ THR = MAX( EPS*S( 1 ), SFMIN ) RANK = 0 DO 30 I = 1, M IF( S( I ).GT.THR ) THEN CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB ) RANK = RANK + 1 ELSE CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB ) END IF 30 CONTINUE IWORK = IE * * Multiply B by right singular vectors of L in WORK(IL) * (Workspace: need M*M+2*M, prefer M*M+M+M*NRHS) * IF( LWORK.GE.LDB*NRHS+IWORK-1 .AND. NRHS.GT.1 ) THEN CALL DGEMM( 'T', 'N', M, NRHS, M, ONE, WORK( IL ), LDWORK, $ B, LDB, ZERO, WORK( IWORK ), LDB ) CALL DLACPY( 'G', M, NRHS, WORK( IWORK ), LDB, B, LDB ) ELSE IF( NRHS.GT.1 ) THEN CHUNK = ( LWORK-IWORK+1 ) / M DO 40 I = 1, NRHS, CHUNK BL = MIN( NRHS-I+1, CHUNK ) CALL DGEMM( 'T', 'N', M, BL, M, ONE, WORK( IL ), LDWORK, $ B( 1, I ), LDB, ZERO, WORK( IWORK ), M ) CALL DLACPY( 'G', M, BL, WORK( IWORK ), M, B( 1, I ), $ LDB ) 40 CONTINUE ELSE CALL DGEMV( 'T', M, M, ONE, WORK( IL ), LDWORK, B( 1, 1 ), $ 1, ZERO, WORK( IWORK ), 1 ) CALL DCOPY( M, WORK( IWORK ), 1, B( 1, 1 ), 1 ) END IF * * Zero out below first M rows of B * CALL DLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB ) IWORK = ITAU + M * * Multiply transpose(Q) by B * (Workspace: need M+NRHS, prefer M+NRHS*NB) * CALL DORMLQ( 'L', 'T', N, NRHS, M, A, LDA, WORK( ITAU ), B, $ LDB, WORK( IWORK ), LWORK-IWORK+1, INFO ) * ELSE * * Path 2 - remaining underdetermined cases * IE = 1 ITAUQ = IE + M ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize A * (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) * CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, $ INFO ) * * Multiply B by transpose of left bidiagonalizing vectors * (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) * CALL DORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAUQ ), $ B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO ) * * Generate right bidiagonalizing vectors in A * (Workspace: need 4*M, prefer 3*M+M*NB) * CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, INFO ) IWORK = IE + M * * Perform bidiagonal QR iteration, * computing right singular vectors of A in A and * multiplying B by transpose of left singular vectors * (Workspace: need BDSPAC) * CALL DBDSQR( 'L', M, N, 0, NRHS, S, WORK( IE ), A, LDA, DUM, $ 1, B, LDB, WORK( IWORK ), INFO ) IF( INFO.NE.0 ) $ GO TO 70 * * Multiply B by reciprocals of singular values * THR = MAX( RCOND*S( 1 ), SFMIN ) IF( RCOND.LT.ZERO ) $ THR = MAX( EPS*S( 1 ), SFMIN ) RANK = 0 DO 50 I = 1, M IF( S( I ).GT.THR ) THEN CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB ) RANK = RANK + 1 ELSE CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB ) END IF 50 CONTINUE * * Multiply B by right singular vectors of A * (Workspace: need N, prefer N*NRHS) * IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN CALL DGEMM( 'T', 'N', N, NRHS, M, ONE, A, LDA, B, LDB, ZERO, $ WORK, LDB ) CALL DLACPY( 'F', N, NRHS, WORK, LDB, B, LDB ) ELSE IF( NRHS.GT.1 ) THEN CHUNK = LWORK / N DO 60 I = 1, NRHS, CHUNK BL = MIN( NRHS-I+1, CHUNK ) CALL DGEMM( 'T', 'N', N, BL, M, ONE, A, LDA, B( 1, I ), $ LDB, ZERO, WORK, N ) CALL DLACPY( 'F', N, BL, WORK, N, B( 1, I ), LDB ) 60 CONTINUE ELSE CALL DGEMV( 'T', M, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 ) CALL DCOPY( N, WORK, 1, B, 1 ) END IF END IF * * Undo scaling * IF( IASCL.EQ.1 ) THEN CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO ) CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN, $ INFO ) ELSE IF( IASCL.EQ.2 ) THEN CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO ) CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN, $ INFO ) END IF IF( IBSCL.EQ.1 ) THEN CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO ) ELSE IF( IBSCL.EQ.2 ) THEN CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO ) END IF * 70 CONTINUE WORK( 1 ) = MAXWRK RETURN * * End of DGELSS * END *> \brief DGELSX solves overdetermined or underdetermined systems for GE matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGELSX + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, * WORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, M, N, NRHS, RANK * DOUBLE PRECISION RCOND * .. * .. Array Arguments .. * INTEGER JPVT( * ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> This routine is deprecated and has been replaced by routine DGELSY. *> *> DGELSX computes the minimum-norm solution to a real linear least *> squares problem: *> minimize || A * X - B || *> using a complete orthogonal factorization of A. A is an M-by-N *> matrix which may be rank-deficient. *> *> Several right hand side vectors b and solution vectors x can be *> handled in a single call; they are stored as the columns of the *> M-by-NRHS right hand side matrix B and the N-by-NRHS solution *> matrix X. *> *> The routine first computes a QR factorization with column pivoting: *> A * P = Q * [ R11 R12 ] *> [ 0 R22 ] *> with R11 defined as the largest leading submatrix whose estimated *> condition number is less than 1/RCOND. The order of R11, RANK, *> is the effective rank of A. *> *> Then, R22 is considered to be negligible, and R12 is annihilated *> by orthogonal transformations from the right, arriving at the *> complete orthogonal factorization: *> A * P = Q * [ T11 0 ] * Z *> [ 0 0 ] *> The minimum-norm solution is then *> X = P * Z**T [ inv(T11)*Q1**T*B ] *> [ 0 ] *> where Q1 consists of the first RANK columns of Q. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of *> columns of matrices B and X. NRHS >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the M-by-N matrix A. *> On exit, A has been overwritten by details of its *> complete orthogonal factorization. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> On entry, the M-by-NRHS right hand side matrix B. *> On exit, the N-by-NRHS solution matrix X. *> If m >= n and RANK = n, the residual sum-of-squares for *> the solution in the i-th column is given by the sum of *> squares of elements N+1:M in that column. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,M,N). *> \endverbatim *> *> \param[in,out] JPVT *> \verbatim *> JPVT is INTEGER array, dimension (N) *> On entry, if JPVT(i) .ne. 0, the i-th column of A is an *> initial column, otherwise it is a free column. Before *> the QR factorization of A, all initial columns are *> permuted to the leading positions; only the remaining *> free columns are moved as a result of column pivoting *> during the factorization. *> On exit, if JPVT(i) = k, then the i-th column of A*P *> was the k-th column of A. *> \endverbatim *> *> \param[in] RCOND *> \verbatim *> RCOND is DOUBLE PRECISION *> RCOND is used to determine the effective rank of A, which *> is defined as the order of the largest leading triangular *> submatrix R11 in the QR factorization with pivoting of A, *> whose estimated condition number < 1/RCOND. *> \endverbatim *> *> \param[out] RANK *> \verbatim *> RANK is INTEGER *> The effective rank of A, i.e., the order of the submatrix *> R11. This is the same as the order of the submatrix T11 *> in the complete orthogonal factorization of A. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension *> (max( min(M,N)+3*N, 2*min(M,N)+NRHS )), *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEsolve * * ===================================================================== SUBROUTINE DGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, $ WORK, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, M, N, NRHS, RANK DOUBLE PRECISION RCOND * .. * .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER IMAX, IMIN PARAMETER ( IMAX = 1, IMIN = 2 ) DOUBLE PRECISION ZERO, ONE, DONE, NTDONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, DONE = ZERO, $ NTDONE = ONE ) * .. * .. Local Scalars .. INTEGER I, IASCL, IBSCL, ISMAX, ISMIN, J, K, MN DOUBLE PRECISION ANRM, BIGNUM, BNRM, C1, C2, S1, S2, SMAX, $ SMAXPR, SMIN, SMINPR, SMLNUM, T1, T2 * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE * .. * .. External Subroutines .. EXTERNAL DGEQPF, DLAIC1, DLASCL, DLASET, DLATZM, DORM2R, $ DTRSM, DTZRQF, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. Executable Statements .. * MN = MIN( M, N ) ISMIN = MN + 1 ISMAX = 2*MN + 1 * * Test the input arguments. * INFO = 0 IF( M.LT.0 ) 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, M ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN INFO = -7 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGELSX', -INFO ) RETURN END IF * * Quick return if possible * IF( MIN( M, N, NRHS ).EQ.0 ) THEN RANK = 0 RETURN END IF * * Get machine parameters * SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) * * Scale A, B if max elements outside range [SMLNUM,BIGNUM] * ANRM = DLANGE( 'M', M, N, A, LDA, WORK ) IASCL = 0 IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN * * Scale matrix norm up to SMLNUM * CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO ) IASCL = 1 ELSE IF( ANRM.GT.BIGNUM ) THEN * * Scale matrix norm down to BIGNUM * CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO ) IASCL = 2 ELSE IF( ANRM.EQ.ZERO ) THEN * * Matrix all zero. Return zero solution. * CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB ) RANK = 0 GO TO 100 END IF * BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK ) IBSCL = 0 IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN * * Scale matrix norm up to SMLNUM * CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO ) IBSCL = 1 ELSE IF( BNRM.GT.BIGNUM ) THEN * * Scale matrix norm down to BIGNUM * CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO ) IBSCL = 2 END IF * * Compute QR factorization with column pivoting of A: * A * P = Q * R * CALL DGEQPF( M, N, A, LDA, JPVT, WORK( 1 ), WORK( MN+1 ), INFO ) * * workspace 3*N. Details of Householder rotations stored * in WORK(1:MN). * * Determine RANK using incremental condition estimation * WORK( ISMIN ) = ONE WORK( ISMAX ) = ONE SMAX = ABS( A( 1, 1 ) ) SMIN = SMAX IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN RANK = 0 CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB ) GO TO 100 ELSE RANK = 1 END IF * 10 CONTINUE IF( RANK.LT.MN ) THEN I = RANK + 1 CALL DLAIC1( IMIN, RANK, WORK( ISMIN ), SMIN, A( 1, I ), $ A( I, I ), SMINPR, S1, C1 ) CALL DLAIC1( IMAX, RANK, WORK( ISMAX ), SMAX, A( 1, I ), $ A( I, I ), SMAXPR, S2, C2 ) * IF( SMAXPR*RCOND.LE.SMINPR ) THEN DO 20 I = 1, RANK WORK( ISMIN+I-1 ) = S1*WORK( ISMIN+I-1 ) WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 ) 20 CONTINUE WORK( ISMIN+RANK ) = C1 WORK( ISMAX+RANK ) = C2 SMIN = SMINPR SMAX = SMAXPR RANK = RANK + 1 GO TO 10 END IF END IF * * Logically partition R = [ R11 R12 ] * [ 0 R22 ] * where R11 = R(1:RANK,1:RANK) * * [R11,R12] = [ T11, 0 ] * Y * IF( RANK.LT.N ) $ CALL DTZRQF( RANK, N, A, LDA, WORK( MN+1 ), INFO ) * * Details of Householder rotations stored in WORK(MN+1:2*MN) * * B(1:M,1:NRHS) := Q**T * B(1:M,1:NRHS) * CALL DORM2R( 'Left', 'Transpose', M, NRHS, MN, A, LDA, WORK( 1 ), $ B, LDB, WORK( 2*MN+1 ), INFO ) * * workspace NRHS * * B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) * CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK, $ NRHS, ONE, A, LDA, B, LDB ) * DO 40 I = RANK + 1, N DO 30 J = 1, NRHS B( I, J ) = ZERO 30 CONTINUE 40 CONTINUE * * B(1:N,1:NRHS) := Y**T * B(1:N,1:NRHS) * IF( RANK.LT.N ) THEN DO 50 I = 1, RANK CALL DLATZM( 'Left', N-RANK+1, NRHS, A( I, RANK+1 ), LDA, $ WORK( MN+I ), B( I, 1 ), B( RANK+1, 1 ), LDB, $ WORK( 2*MN+1 ) ) 50 CONTINUE END IF * * workspace NRHS * * B(1:N,1:NRHS) := P * B(1:N,1:NRHS) * DO 90 J = 1, NRHS DO 60 I = 1, N WORK( 2*MN+I ) = NTDONE 60 CONTINUE DO 80 I = 1, N IF( WORK( 2*MN+I ).EQ.NTDONE ) THEN IF( JPVT( I ).NE.I ) THEN K = I T1 = B( K, J ) T2 = B( JPVT( K ), J ) 70 CONTINUE B( JPVT( K ), J ) = T1 WORK( 2*MN+K ) = DONE T1 = T2 K = JPVT( K ) T2 = B( JPVT( K ), J ) IF( JPVT( K ).NE.I ) $ GO TO 70 B( I, J ) = T1 WORK( 2*MN+K ) = DONE END IF END IF 80 CONTINUE 90 CONTINUE * * Undo scaling * IF( IASCL.EQ.1 ) THEN CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO ) CALL DLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA, $ INFO ) ELSE IF( IASCL.EQ.2 ) THEN CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO ) CALL DLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA, $ INFO ) END IF IF( IBSCL.EQ.1 ) THEN CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO ) ELSE IF( IBSCL.EQ.2 ) THEN CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO ) END IF * 100 CONTINUE * RETURN * * End of DGELSX * END *> \brief DGELSY solves overdetermined or underdetermined systems for GE matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGELSY + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, * WORK, LWORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK * DOUBLE PRECISION RCOND * .. * .. Array Arguments .. * INTEGER JPVT( * ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGELSY computes the minimum-norm solution to a real linear least *> squares problem: *> minimize || A * X - B || *> using a complete orthogonal factorization of A. A is an M-by-N *> matrix which may be rank-deficient. *> *> Several right hand side vectors b and solution vectors x can be *> handled in a single call; they are stored as the columns of the *> M-by-NRHS right hand side matrix B and the N-by-NRHS solution *> matrix X. *> *> The routine first computes a QR factorization with column pivoting: *> A * P = Q * [ R11 R12 ] *> [ 0 R22 ] *> with R11 defined as the largest leading submatrix whose estimated *> condition number is less than 1/RCOND. The order of R11, RANK, *> is the effective rank of A. *> *> Then, R22 is considered to be negligible, and R12 is annihilated *> by orthogonal transformations from the right, arriving at the *> complete orthogonal factorization: *> A * P = Q * [ T11 0 ] * Z *> [ 0 0 ] *> The minimum-norm solution is then *> X = P * Z**T [ inv(T11)*Q1**T*B ] *> [ 0 ] *> where Q1 consists of the first RANK columns of Q. *> *> This routine is basically identical to the original xGELSX except *> three differences: *> o The call to the subroutine xGEQPF has been substituted by the *> the call to the subroutine xGEQP3. This subroutine is a Blas-3 *> version of the QR factorization with column pivoting. *> o Matrix B (the right hand side) is updated with Blas-3. *> o The permutation of matrix B (the right hand side) is faster and *> more simple. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of *> columns of matrices B and X. NRHS >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the M-by-N matrix A. *> On exit, A has been overwritten by details of its *> complete orthogonal factorization. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> On entry, the M-by-NRHS right hand side matrix B. *> On exit, the N-by-NRHS solution matrix X. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,M,N). *> \endverbatim *> *> \param[in,out] JPVT *> \verbatim *> JPVT is INTEGER array, dimension (N) *> On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted *> to the front of AP, otherwise column i is a free column. *> On exit, if JPVT(i) = k, then the i-th column of AP *> was the k-th column of A. *> \endverbatim *> *> \param[in] RCOND *> \verbatim *> RCOND is DOUBLE PRECISION *> RCOND is used to determine the effective rank of A, which *> is defined as the order of the largest leading triangular *> submatrix R11 in the QR factorization with pivoting of A, *> whose estimated condition number < 1/RCOND. *> \endverbatim *> *> \param[out] RANK *> \verbatim *> RANK is INTEGER *> The effective rank of A, i.e., the order of the submatrix *> R11. This is the same as the order of the submatrix T11 *> in the complete orthogonal factorization of A. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. *> The unblocked strategy requires that: *> LWORK >= MAX( MN+3*N+1, 2*MN+NRHS ), *> where MN = min( M, N ). *> The block algorithm requires that: *> LWORK >= MAX( MN+2*N+NB*(N+1), 2*MN+NB*NRHS ), *> where NB is an upper bound on the blocksize returned *> by ILAENV for the routines DGEQP3, DTZRZF, STZRQF, DORMQR, *> and DORMRZ. *> *> 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: If INFO = -i, the i-th argument had an illegal value. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEsolve * *> \par Contributors: * ================== *> *> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA \n *> E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain \n *> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain \n *> * ===================================================================== SUBROUTINE DGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, $ WORK, LWORK, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK DOUBLE PRECISION RCOND * .. * .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER IMAX, IMIN PARAMETER ( IMAX = 1, IMIN = 2 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IASCL, IBSCL, ISMAX, ISMIN, J, LWKMIN, $ LWKOPT, MN, NB, NB1, NB2, NB3, NB4 DOUBLE PRECISION ANRM, BIGNUM, BNRM, C1, C2, S1, S2, SMAX, $ SMAXPR, SMIN, SMINPR, SMLNUM, WSIZE * .. * .. External Functions .. INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL ILAENV, DLAMCH, DLANGE * .. * .. External Subroutines .. EXTERNAL DCOPY, DGEQP3, DLABAD, DLAIC1, DLASCL, DLASET, $ DORMQR, DORMRZ, DTRSM, DTZRZF, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. Executable Statements .. * MN = MIN( M, N ) ISMIN = MN + 1 ISMAX = 2*MN + 1 * * 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( NRHS.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN INFO = -7 END IF * * Figure out optimal block size * IF( INFO.EQ.0 ) THEN IF( MN.EQ.0 .OR. NRHS.EQ.0 ) THEN LWKMIN = 1 LWKOPT = 1 ELSE NB1 = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) NB2 = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 ) NB3 = ILAENV( 1, 'DORMQR', ' ', M, N, NRHS, -1 ) NB4 = ILAENV( 1, 'DORMRQ', ' ', M, N, NRHS, -1 ) NB = MAX( NB1, NB2, NB3, NB4 ) LWKMIN = MN + MAX( 2*MN, N + 1, MN + NRHS ) LWKOPT = MAX( LWKMIN, $ MN + 2*N + NB*( N + 1 ), 2*MN + NB*NRHS ) END IF WORK( 1 ) = LWKOPT * IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN INFO = -12 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGELSY', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( MN.EQ.0 .OR. NRHS.EQ.0 ) THEN RANK = 0 RETURN END IF * * Get machine parameters * SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) * * Scale A, B if max entries outside range [SMLNUM,BIGNUM] * ANRM = DLANGE( 'M', M, N, A, LDA, WORK ) IASCL = 0 IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN * * Scale matrix norm up to SMLNUM * CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO ) IASCL = 1 ELSE IF( ANRM.GT.BIGNUM ) THEN * * Scale matrix norm down to BIGNUM * CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO ) IASCL = 2 ELSE IF( ANRM.EQ.ZERO ) THEN * * Matrix all zero. Return zero solution. * CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB ) RANK = 0 GO TO 70 END IF * BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK ) IBSCL = 0 IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN * * Scale matrix norm up to SMLNUM * CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO ) IBSCL = 1 ELSE IF( BNRM.GT.BIGNUM ) THEN * * Scale matrix norm down to BIGNUM * CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO ) IBSCL = 2 END IF * * Compute QR factorization with column pivoting of A: * A * P = Q * R * CALL DGEQP3( M, N, A, LDA, JPVT, WORK( 1 ), WORK( MN+1 ), $ LWORK-MN, INFO ) WSIZE = MN + WORK( MN+1 ) * * workspace: MN+2*N+NB*(N+1). * Details of Householder rotations stored in WORK(1:MN). * * Determine RANK using incremental condition estimation * WORK( ISMIN ) = ONE WORK( ISMAX ) = ONE SMAX = ABS( A( 1, 1 ) ) SMIN = SMAX IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN RANK = 0 CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB ) GO TO 70 ELSE RANK = 1 END IF * 10 CONTINUE IF( RANK.LT.MN ) THEN I = RANK + 1 CALL DLAIC1( IMIN, RANK, WORK( ISMIN ), SMIN, A( 1, I ), $ A( I, I ), SMINPR, S1, C1 ) CALL DLAIC1( IMAX, RANK, WORK( ISMAX ), SMAX, A( 1, I ), $ A( I, I ), SMAXPR, S2, C2 ) * IF( SMAXPR*RCOND.LE.SMINPR ) THEN DO 20 I = 1, RANK WORK( ISMIN+I-1 ) = S1*WORK( ISMIN+I-1 ) WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 ) 20 CONTINUE WORK( ISMIN+RANK ) = C1 WORK( ISMAX+RANK ) = C2 SMIN = SMINPR SMAX = SMAXPR RANK = RANK + 1 GO TO 10 END IF END IF * * workspace: 3*MN. * * Logically partition R = [ R11 R12 ] * [ 0 R22 ] * where R11 = R(1:RANK,1:RANK) * * [R11,R12] = [ T11, 0 ] * Y * IF( RANK.LT.N ) $ CALL DTZRZF( RANK, N, A, LDA, WORK( MN+1 ), WORK( 2*MN+1 ), $ LWORK-2*MN, INFO ) * * workspace: 2*MN. * Details of Householder rotations stored in WORK(MN+1:2*MN) * * B(1:M,1:NRHS) := Q**T * B(1:M,1:NRHS) * CALL DORMQR( 'Left', 'Transpose', M, NRHS, MN, A, LDA, WORK( 1 ), $ B, LDB, WORK( 2*MN+1 ), LWORK-2*MN, INFO ) WSIZE = MAX( WSIZE, 2*MN+WORK( 2*MN+1 ) ) * * workspace: 2*MN+NB*NRHS. * * B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) * CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK, $ NRHS, ONE, A, LDA, B, LDB ) * DO 40 J = 1, NRHS DO 30 I = RANK + 1, N B( I, J ) = ZERO 30 CONTINUE 40 CONTINUE * * B(1:N,1:NRHS) := Y**T * B(1:N,1:NRHS) * IF( RANK.LT.N ) THEN CALL DORMRZ( 'Left', 'Transpose', N, NRHS, RANK, N-RANK, A, $ LDA, WORK( MN+1 ), B, LDB, WORK( 2*MN+1 ), $ LWORK-2*MN, INFO ) END IF * * workspace: 2*MN+NRHS. * * B(1:N,1:NRHS) := P * B(1:N,1:NRHS) * DO 60 J = 1, NRHS DO 50 I = 1, N WORK( JPVT( I ) ) = B( I, J ) 50 CONTINUE CALL DCOPY( N, WORK( 1 ), 1, B( 1, J ), 1 ) 60 CONTINUE * * workspace: N. * * Undo scaling * IF( IASCL.EQ.1 ) THEN CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO ) CALL DLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA, $ INFO ) ELSE IF( IASCL.EQ.2 ) THEN CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO ) CALL DLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA, $ INFO ) END IF IF( IBSCL.EQ.1 ) THEN CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO ) ELSE IF( IBSCL.EQ.2 ) THEN CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO ) END IF * 70 CONTINUE WORK( 1 ) = LWKOPT * RETURN * * End of DGELSY * END *> \brief \b DGEMQRT * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEMQRT + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, * C, LDC, WORK, INFO ) * * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDV, LDC, M, N, NB, LDT * .. * .. Array Arguments .. * DOUBLE PRECISION V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGEMQRT overwrites the general real M-by-N matrix C with *> *> SIDE = 'L' SIDE = 'R' *> TRANS = 'N': Q C C Q *> TRANS = 'T': Q**T C C Q**T *> *> where Q is a real orthogonal matrix defined as the product of K *> elementary reflectors: *> *> Q = H(1) H(2) . . . H(K) = I - V T V**T *> *> generated using the compact WY representation as returned by DGEQRT. *> *> Q is of order M if SIDE = 'L' and of order N if SIDE = 'R'. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply Q or Q**T from the Left; *> = 'R': apply Q or Q**T from the Right. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': No transpose, apply Q; *> = 'C': Transpose, apply Q**T. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. N >= 0. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The number of elementary reflectors whose product defines *> the matrix Q. *> If SIDE = 'L', M >= K >= 0; *> if SIDE = 'R', N >= K >= 0. *> \endverbatim *> *> \param[in] NB *> \verbatim *> NB is INTEGER *> The block size used for the storage of T. K >= NB >= 1. *> This must be the same value of NB used to generate T *> in CGEQRT. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is DOUBLE PRECISION array, dimension (LDV,K) *> The i-th column must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> CGEQRT in the first K columns of its array argument A. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the array V. *> If SIDE = 'L', LDA >= max(1,M); *> if SIDE = 'R', LDA >= max(1,N). *> \endverbatim *> *> \param[in] T *> \verbatim *> T is DOUBLE PRECISION array, dimension (LDT,K) *> The upper triangular factors of the block reflectors *> as returned by CGEQRT, stored as a NB-by-N matrix. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= NB. *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (LDC,N) *> On entry, the M-by-N matrix C. *> On exit, C is overwritten by Q C, Q**T C, C Q**T or C Q. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDC >= max(1,M). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array. The dimension of *> WORK is N*NB if SIDE = 'L', or M*NB if SIDE = 'R'. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEcomputational * * ===================================================================== SUBROUTINE DGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, $ C, LDC, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDV, LDC, M, N, NB, LDT * .. * .. Array Arguments .. DOUBLE PRECISION V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * ) * .. * * ===================================================================== * * .. * .. Local Scalars .. LOGICAL LEFT, RIGHT, TRAN, NOTRAN INTEGER I, IB, LDWORK, KF, Q * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, DLARFB * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * .. Test the input arguments .. * INFO = 0 LEFT = LSAME( SIDE, 'L' ) RIGHT = LSAME( SIDE, 'R' ) TRAN = LSAME( TRANS, 'T' ) NOTRAN = LSAME( TRANS, 'N' ) * IF( LEFT ) THEN LDWORK = MAX( 1, N ) Q = M ELSE IF ( RIGHT ) THEN LDWORK = MAX( 1, M ) Q = N END IF IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN INFO = -1 ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( K.LT.0 .OR. K.GT.Q ) THEN INFO = -5 ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0)) THEN INFO = -6 ELSE IF( LDV.LT.MAX( 1, Q ) ) THEN INFO = -8 ELSE IF( LDT.LT.NB ) THEN INFO = -10 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -12 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEMQRT', -INFO ) RETURN END IF * * .. Quick return if possible .. * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN * IF( LEFT .AND. TRAN ) THEN * DO I = 1, K, NB IB = MIN( NB, K-I+1 ) CALL DLARFB( 'L', 'T', 'F', 'C', M-I+1, N, IB, $ V( I, I ), LDV, T( 1, I ), LDT, $ C( I, 1 ), LDC, WORK, LDWORK ) END DO * ELSE IF( RIGHT .AND. NOTRAN ) THEN * DO I = 1, K, NB IB = MIN( NB, K-I+1 ) CALL DLARFB( 'R', 'N', 'F', 'C', M, N-I+1, IB, $ V( I, I ), LDV, T( 1, I ), LDT, $ C( 1, I ), LDC, WORK, LDWORK ) END DO * ELSE IF( LEFT .AND. NOTRAN ) THEN * KF = ((K-1)/NB)*NB+1 DO I = KF, 1, -NB IB = MIN( NB, K-I+1 ) CALL DLARFB( 'L', 'N', 'F', 'C', M-I+1, N, IB, $ V( I, I ), LDV, T( 1, I ), LDT, $ C( I, 1 ), LDC, WORK, LDWORK ) END DO * ELSE IF( RIGHT .AND. TRAN ) THEN * KF = ((K-1)/NB)*NB+1 DO I = KF, 1, -NB IB = MIN( NB, K-I+1 ) CALL DLARFB( 'R', 'T', 'F', 'C', M, N-I+1, IB, $ V( I, I ), LDV, T( 1, I ), LDT, $ C( 1, I ), LDC, WORK, LDWORK ) END DO * END IF * RETURN * * End of DGEMQRT * END *> \brief \b DGEQL2 computes the QL factorization of a general rectangular matrix using an unblocked algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEQL2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEQL2( M, N, A, LDA, TAU, WORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGEQL2 computes a QL factorization of a real m by n matrix A: *> A = Q * L. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is 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). *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> 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**T *> *> 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). *> \endverbatim *> * ===================================================================== SUBROUTINE DGEQL2( M, N, A, LDA, TAU, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. 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 *> \brief \b DGEQLF * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEQLF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGEQLF computes a QL factorization of a real M-by-N matrix A: *> A = Q * L. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is 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). *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> 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**T *> *> 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). *> \endverbatim *> * ===================================================================== SUBROUTINE DGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. 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**T 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 *> \brief \b DGEQP3 * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEQP3 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * INTEGER JPVT( * ) * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGEQP3 computes a QR factorization with column pivoting of a *> matrix A: A*P = Q*R using Level 3 BLAS. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is 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. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in,out] JPVT *> \verbatim *> JPVT is 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. *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO=0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> 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**T *> *> where tau is a real 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). *> \endverbatim * *> \par Contributors: * ================== *> *> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain *> X. Sun, Computer Science Dept., Duke University, USA *> * ===================================================================== SUBROUTINE DGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. 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 * * 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 *> \brief \b DGEQPF * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEQPF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * INTEGER JPVT( * ) * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0 *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is 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. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in,out] JPVT *> \verbatim *> JPVT is 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. *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> 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**T *> *> 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. *> -- April 2011 -- *> For more details see LAPACK Working Note 176. *> \endverbatim *> * ===================================================================== SUBROUTINE DGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. 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 *> \brief \b DGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEQR2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGEQR2 computes a QR factorization of a real m by n matrix A: *> A = Q * R. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is 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). *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> 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**T *> *> 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). *> \endverbatim *> * ===================================================================== SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. 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 *> \brief \b DGEQR2P computes the QR factorization of a general rectangular matrix with non-negative diagonal elements using an unblocked algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEQR2P + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEQR2P( M, N, A, LDA, TAU, WORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGEQR2P computes a QR factorization of a real m by n matrix A: *> A = Q * R. The diagonal entries of R are nonnegative. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is 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 diagonal entries of R are *> nonnegative; the elements below the diagonal, *> with the array TAU, represent the orthogonal matrix Q as a *> product of elementary reflectors (see Further Details). *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> 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**T *> *> 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). *> *> See Lapack Working Note 203 for details *> \endverbatim *> * ===================================================================== SUBROUTINE DGEQR2P( M, N, A, LDA, TAU, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, K DOUBLE PRECISION AII * .. * .. External Subroutines .. EXTERNAL DLARF, DLARFGP, 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( 'DGEQR2P', -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 DLARFGP( 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 DGEQR2P * END *> \brief \b DGEQRF * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEQRF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGEQRF computes a QR factorization of a real M-by-N matrix A: *> A = Q * R. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is 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). *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> 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**T *> *> 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). *> \endverbatim *> * ===================================================================== SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. 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**T 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 *> \brief \b DGEQRFP * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEQRFP + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGEQRFP computes a QR factorization of a real M-by-N matrix A: *> A = Q * R. The diagonal entries of R are nonnegative. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is 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 diagonal entries of R *> are nonnegative; 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). *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> 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**T *> *> 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). *> *> See Lapack Working Note 203 for details *> \endverbatim *> * ===================================================================== SUBROUTINE DGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, $ NBMIN, NX * .. * .. External Subroutines .. EXTERNAL DGEQR2P, 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( 'DGEQRFP', -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 DGEQR2P( 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**T 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 DGEQR2P( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) * WORK( 1 ) = IWS RETURN * * End of DGEQRFP * END *> \brief \b DGEQRT * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEQRT + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LDT, M, N, NB * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), T( LDT, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGEQRT computes a blocked QR factorization of a real M-by-N matrix A *> using the compact WY representation of Q. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] NB *> \verbatim *> NB is INTEGER *> The block size to be used in the blocked QR. MIN(M,N) >= NB >= 1. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is 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 *> are the columns of V. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] T *> \verbatim *> T is DOUBLE PRECISION array, dimension (LDT,MIN(M,N)) *> The upper triangular block reflectors stored in compact form *> as a sequence of upper triangular blocks. See below *> for further details. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= NB. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (NB*N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix V stores the elementary reflectors H(i) in the i-th column *> below the diagonal. For example, if M=5 and N=3, the matrix V is *> *> V = ( 1 ) *> ( v1 1 ) *> ( v1 v2 1 ) *> ( v1 v2 v3 ) *> ( v1 v2 v3 ) *> *> where the vi's represent the vectors which define H(i), which are returned *> in the matrix A. The 1's along the diagonal of V are not stored in A. *> *> Let K=MIN(M,N). The number of blocks is B = ceiling(K/NB), where each *> block is of order NB except for the last block, which is of order *> IB = K - (B-1)*NB. For each of the B blocks, a upper triangular block *> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB *> for the last block) T's are stored in the NB-by-K matrix T as *> *> T = (T1 T2 ... TB). *> \endverbatim *> * ===================================================================== SUBROUTINE DGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDT, M, N, NB * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), T( LDT, * ), WORK( * ) * .. * * ===================================================================== * * .. * .. Local Scalars .. INTEGER I, IB, IINFO, K LOGICAL USE_RECURSIVE_QR PARAMETER( USE_RECURSIVE_QR=.TRUE. ) * .. * .. External Subroutines .. EXTERNAL DGEQRT2, DGEQRT3, DLARFB, XERBLA * .. * .. 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( NB.LT.1 .OR. ( NB.GT.MIN(M,N) .AND. MIN(M,N).GT.0 ) )THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 ELSE IF( LDT.LT.NB ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEQRT', -INFO ) RETURN END IF * * Quick return if possible * K = MIN( M, N ) IF( K.EQ.0 ) RETURN * * Blocked loop of length K * DO I = 1, K, NB IB = MIN( K-I+1, NB ) * * Compute the QR factorization of the current block A(I:M,I:I+IB-1) * IF( USE_RECURSIVE_QR ) THEN CALL DGEQRT3( M-I+1, IB, A(I,I), LDA, T(1,I), LDT, IINFO ) ELSE CALL DGEQRT2( M-I+1, IB, A(I,I), LDA, T(1,I), LDT, IINFO ) END IF IF( I+IB.LE.N ) THEN * * Update by applying H**T to A(I:M,I+IB:N) from the left * CALL DLARFB( 'L', 'T', 'F', 'C', M-I+1, N-I-IB+1, IB, $ A( I, I ), LDA, T( 1, I ), LDT, $ A( I, I+IB ), LDA, WORK , N-I-IB+1 ) END IF END DO RETURN * * End of DGEQRT * END *> \brief \b DGEQRT2 computes a QR factorization of a general real or complex matrix using the compact WY representation of Q. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEQRT2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGEQRT2( M, N, A, LDA, T, LDT, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LDT, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), T( LDT, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGEQRT2 computes a QR factorization of a real M-by-N matrix A, *> using the compact WY representation of Q. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= N. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the real M-by-N matrix A. On exit, the elements on and *> above the diagonal contain the N-by-N upper triangular matrix R; the *> elements below the diagonal are the columns of V. See below for *> further details. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] T *> \verbatim *> T is DOUBLE PRECISION array, dimension (LDT,N) *> The N-by-N upper triangular factor of the block reflector. *> The elements on and above the diagonal contain the block *> reflector T; the elements below the diagonal are not used. *> See below for further details. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix V stores the elementary reflectors H(i) in the i-th column *> below the diagonal. For example, if M=5 and N=3, the matrix V is *> *> V = ( 1 ) *> ( v1 1 ) *> ( v1 v2 1 ) *> ( v1 v2 v3 ) *> ( v1 v2 v3 ) *> *> where the vi's represent the vectors which define H(i), which are returned *> in the matrix A. The 1's along the diagonal of V are not stored in A. The *> block reflector H is then given by *> *> H = I - V * T * V**T *> *> where V**T is the transpose of V. *> \endverbatim *> * ===================================================================== SUBROUTINE DGEQRT2( M, N, A, LDA, T, LDT, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDT, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), T( LDT, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER( ONE = 1.0D+00, ZERO = 0.0D+00 ) * .. * .. Local Scalars .. INTEGER I, K DOUBLE PRECISION AII, ALPHA * .. * .. External Subroutines .. EXTERNAL DLARFG, DGEMV, DGER, DTRMV, XERBLA * .. * .. 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 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEQRT2', -INFO ) RETURN END IF * K = MIN( M, N ) * DO I = 1, K * * Generate elem. refl. H(i) to annihilate A(i+1:m,i), tau(I) -> T(I,1) * CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, $ T( I, 1 ) ) 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 * * W(1:N-I) := A(I:M,I+1:N)^H * A(I:M,I) [W = T(:,N)] * CALL DGEMV( 'T',M-I+1, N-I, ONE, A( I, I+1 ), LDA, $ A( I, I ), 1, ZERO, T( 1, N ), 1 ) * * A(I:M,I+1:N) = A(I:m,I+1:N) + alpha*A(I:M,I)*W(1:N-1)^H * ALPHA = -(T( I, 1 )) CALL DGER( M-I+1, N-I, ALPHA, A( I, I ), 1, $ T( 1, N ), 1, A( I, I+1 ), LDA ) A( I, I ) = AII END IF END DO * DO I = 2, N AII = A( I, I ) A( I, I ) = ONE * * T(1:I-1,I) := alpha * A(I:M,1:I-1)**T * A(I:M,I) * ALPHA = -T( I, 1 ) CALL DGEMV( 'T', M-I+1, I-1, ALPHA, A( I, 1 ), LDA, $ A( I, I ), 1, ZERO, T( 1, I ), 1 ) A( I, I ) = AII * * T(1:I-1,I) := T(1:I-1,1:I-1) * T(1:I-1,I) * CALL DTRMV( 'U', 'N', 'N', I-1, T, LDT, T( 1, I ), 1 ) * * T(I,I) = tau(I) * T( I, I ) = T( I, 1 ) T( I, 1) = ZERO END DO * * End of DGEQRT2 * END *> \brief \b DGEQRT3 recursively computes a QR factorization of a general real or complex matrix using the compact WY representation of Q. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGEQRT3 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * RECURSIVE SUBROUTINE DGEQRT3( M, N, A, LDA, T, LDT, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N, LDT * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), T( LDT, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGEQRT3 recursively computes a QR factorization of a real M-by-N *> matrix A, using the compact WY representation of Q. *> *> Based on the algorithm of Elmroth and Gustavson, *> IBM J. Res. Develop. Vol 44 No. 4 July 2000. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= N. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the real M-by-N matrix A. On exit, the elements on and *> above the diagonal contain the N-by-N upper triangular matrix R; the *> elements below the diagonal are the columns of V. See below for *> further details. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] T *> \verbatim *> T is DOUBLE PRECISION array, dimension (LDT,N) *> The N-by-N upper triangular factor of the block reflector. *> The elements on and above the diagonal contain the block *> reflector T; the elements below the diagonal are not used. *> See below for further details. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix V stores the elementary reflectors H(i) in the i-th column *> below the diagonal. For example, if M=5 and N=3, the matrix V is *> *> V = ( 1 ) *> ( v1 1 ) *> ( v1 v2 1 ) *> ( v1 v2 v3 ) *> ( v1 v2 v3 ) *> *> where the vi's represent the vectors which define H(i), which are returned *> in the matrix A. The 1's along the diagonal of V are not stored in A. The *> block reflector H is then given by *> *> H = I - V * T * V**T *> *> where V**T is the transpose of V. *> *> For details of the algorithm, see Elmroth and Gustavson (cited above). *> \endverbatim *> * ===================================================================== RECURSIVE SUBROUTINE DGEQRT3( M, N, A, LDA, T, LDT, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N, LDT * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), T( LDT, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+00 ) * .. * .. Local Scalars .. INTEGER I, I1, J, J1, N1, N2, IINFO * .. * .. External Subroutines .. EXTERNAL DLARFG, DTRMM, DGEMM, XERBLA * .. * .. Executable Statements .. * INFO = 0 IF( N .LT. 0 ) THEN INFO = -2 ELSE IF( M .LT. N ) THEN INFO = -1 ELSE IF( LDA .LT. MAX( 1, M ) ) THEN INFO = -4 ELSE IF( LDT .LT. MAX( 1, N ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEQRT3', -INFO ) RETURN END IF * IF( N.EQ.1 ) THEN * * Compute Householder transform when N=1 * CALL DLARFG( M, A(1,1), A( MIN( 2, M ), 1 ), 1, T(1,1) ) * ELSE * * Otherwise, split A into blocks... * N1 = N/2 N2 = N-N1 J1 = MIN( N1+1, N ) I1 = MIN( N+1, M ) * * Compute A(1:M,1:N1) <- (Y1,R1,T1), where Q1 = I - Y1 T1 Y1^H * CALL DGEQRT3( M, N1, A, LDA, T, LDT, IINFO ) * * Compute A(1:M,J1:N) = Q1^H A(1:M,J1:N) [workspace: T(1:N1,J1:N)] * DO J=1,N2 DO I=1,N1 T( I, J+N1 ) = A( I, J+N1 ) END DO END DO CALL DTRMM( 'L', 'L', 'T', 'U', N1, N2, ONE, & A, LDA, T( 1, J1 ), LDT ) * CALL DGEMM( 'T', 'N', N1, N2, M-N1, ONE, A( J1, 1 ), LDA, & A( J1, J1 ), LDA, ONE, T( 1, J1 ), LDT) * CALL DTRMM( 'L', 'U', 'T', 'N', N1, N2, ONE, & T, LDT, T( 1, J1 ), LDT ) * CALL DGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( J1, 1 ), LDA, & T( 1, J1 ), LDT, ONE, A( J1, J1 ), LDA ) * CALL DTRMM( 'L', 'L', 'N', 'U', N1, N2, ONE, & A, LDA, T( 1, J1 ), LDT ) * DO J=1,N2 DO I=1,N1 A( I, J+N1 ) = A( I, J+N1 ) - T( I, J+N1 ) END DO END DO * * Compute A(J1:M,J1:N) <- (Y2,R2,T2) where Q2 = I - Y2 T2 Y2^H * CALL DGEQRT3( M-N1, N2, A( J1, J1 ), LDA, & T( J1, J1 ), LDT, IINFO ) * * Compute T3 = T(1:N1,J1:N) = -T1 Y1^H Y2 T2 * DO I=1,N1 DO J=1,N2 T( I, J+N1 ) = (A( J+N1, I )) END DO END DO * CALL DTRMM( 'R', 'L', 'N', 'U', N1, N2, ONE, & A( J1, J1 ), LDA, T( 1, J1 ), LDT ) * CALL DGEMM( 'T', 'N', N1, N2, M-N, ONE, A( I1, 1 ), LDA, & A( I1, J1 ), LDA, ONE, T( 1, J1 ), LDT ) * CALL DTRMM( 'L', 'U', 'N', 'N', N1, N2, -ONE, T, LDT, & T( 1, J1 ), LDT ) * CALL DTRMM( 'R', 'U', 'N', 'N', N1, N2, ONE, & T( J1, J1 ), LDT, T( 1, J1 ), LDT ) * * Y = (Y1,Y2); R = [ R1 A(1:N1,J1:N) ]; T = [T1 T3] * [ 0 R2 ] [ 0 T2] * END IF * RETURN * * End of DGEQRT3 * END *> \brief \b DGERFS * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGERFS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, * X, LDX, FERR, BERR, WORK, IWORK, INFO ) * * .. 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, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGERFS improves the computed solution to a system of linear *> equations and provides error bounds and backward error estimates for *> the solution. *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANS *> \verbatim *> TRANS is 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) *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrices B and X. NRHS >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The original N-by-N matrix A. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in] AF *> \verbatim *> AF is DOUBLE PRECISION array, dimension (LDAF,N) *> The factors L and U from the factorization A = P*L*U *> as computed by DGETRF. *> \endverbatim *> *> \param[in] LDAF *> \verbatim *> LDAF is INTEGER *> The leading dimension of the array AF. LDAF >= max(1,N). *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N) *> The pivot indices from DGETRF; for 1<=i<=N, row i of the *> matrix was interchanged with row IPIV(i). *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> The right hand side matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,NRHS) *> On entry, the solution matrix X, as computed by DGETRS. *> On exit, the improved solution matrix X. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the array X. LDX >= max(1,N). *> \endverbatim *> *> \param[out] FERR *> \verbatim *> FERR is 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. *> \endverbatim *> *> \param[out] BERR *> \verbatim *> BERR is 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). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * *> \par Internal Parameters: * ========================= *> *> \verbatim *> ITMAX is the maximum number of steps of iterative refinement. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEcomputational * * ===================================================================== SUBROUTINE DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, $ X, LDX, FERR, BERR, WORK, IWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER 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, * ) * .. * * ===================================================================== * * .. 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 *> \brief \b DGERQ2 computes the RQ factorization of a general rectangular matrix using an unblocked algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGERQ2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGERQ2( M, N, A, LDA, TAU, WORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGERQ2 computes an RQ factorization of a real m by n matrix A: *> A = R * Q. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is 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). *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (M) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> 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**T *> *> 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). *> \endverbatim *> * ===================================================================== SUBROUTINE DGERQ2( M, N, A, LDA, TAU, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. 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 *> \brief \b DGERQF * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGERQF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGERQF computes an RQ factorization of a real M-by-N matrix A: *> A = R * Q. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is 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). *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> 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**T *> *> 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). *> \endverbatim *> * ===================================================================== SUBROUTINE DGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. 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 *> \brief \b DGESC2 solves a system of linear equations using the LU factorization with complete pivoting computed by sgetc2. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGESC2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE ) * * .. Scalar Arguments .. * INTEGER LDA, N * DOUBLE PRECISION SCALE * .. * .. Array Arguments .. * INTEGER IPIV( * ), JPIV( * ) * DOUBLE PRECISION A( LDA, * ), RHS( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGESC2 solves a system of linear equations *> *> A * X = scale* RHS *> *> with a general N-by-N matrix A using the LU factorization with *> complete pivoting computed by DGETC2. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the LU part of the factorization of the n-by-n *> matrix A computed by DGETC2: A = P * L * U * Q *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1, N). *> \endverbatim *> *> \param[in,out] RHS *> \verbatim *> RHS is DOUBLE PRECISION array, dimension (N). *> On entry, the right hand side vector b. *> On exit, the solution vector X. *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N). *> The pivot indices; for 1 <= i <= N, row i of the *> matrix has been interchanged with row IPIV(i). *> \endverbatim *> *> \param[in] JPIV *> \verbatim *> JPIV is INTEGER array, dimension (N). *> The pivot indices; for 1 <= j <= N, column j of the *> matrix has been interchanged with column JPIV(j). *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is DOUBLE PRECISION *> On exit, SCALE contains the scale factor. SCALE is chosen *> 0 <= SCALE <= 1 to prevent owerflow in the solution. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date November 2017 * *> \ingroup doubleGEauxiliary * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * * ===================================================================== SUBROUTINE DGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE ) * * -- LAPACK auxiliary routine (version 3.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. Scalar Arguments .. INTEGER LDA, N DOUBLE PRECISION SCALE * .. * .. Array Arguments .. INTEGER IPIV( * ), JPIV( * ) DOUBLE PRECISION A( LDA, * ), RHS( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, TWO PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION BIGNUM, EPS, SMLNUM, TEMP * .. * .. External Subroutines .. EXTERNAL DLASWP, DSCAL, DLABAD * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH EXTERNAL IDAMAX, DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * * Set constant to control owerflow * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) / EPS BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) * * Apply permutations IPIV to RHS * CALL DLASWP( 1, RHS, LDA, 1, N-1, IPIV, 1 ) * * Solve for L part * DO 20 I = 1, N - 1 DO 10 J = I + 1, N RHS( J ) = RHS( J ) - A( J, I )*RHS( I ) 10 CONTINUE 20 CONTINUE * * Solve for U part * SCALE = ONE * * Check for scaling * I = IDAMAX( N, RHS, 1 ) IF( TWO*SMLNUM*ABS( RHS( I ) ).GT.ABS( A( N, N ) ) ) THEN TEMP = ( ONE / TWO ) / ABS( RHS( I ) ) CALL DSCAL( N, TEMP, RHS( 1 ), 1 ) SCALE = SCALE*TEMP END IF * DO 40 I = N, 1, -1 TEMP = ONE / A( I, I ) RHS( I ) = RHS( I )*TEMP DO 30 J = I + 1, N RHS( I ) = RHS( I ) - RHS( J )*( A( I, J )*TEMP ) 30 CONTINUE 40 CONTINUE * * Apply permutations JPIV to the solution (RHS) * CALL DLASWP( 1, RHS, LDA, 1, N-1, JPIV, -1 ) RETURN * * End of DGESC2 * END *> \brief \b DGESDD * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGESDD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, * WORK, LWORK, IWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBZ * INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ), * $ VT( LDVT, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGESDD computes the singular value decomposition (SVD) of a real *> M-by-N matrix A, optionally computing the left and right singular *> vectors. If singular vectors are desired, it uses a *> divide-and-conquer algorithm. *> *> The SVD is written *> *> A = U * SIGMA * transpose(V) *> *> where SIGMA is an M-by-N matrix which is zero except for its *> min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and *> V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA *> are the singular values of A; they are real and non-negative, and *> are returned in descending order. The first min(m,n) columns of *> U and V are the left and right singular vectors of A. *> *> Note that the routine returns VT = V**T, not V. *> *> The divide and conquer algorithm makes very mild assumptions about *> floating point arithmetic. It will work on machines with a guard *> digit in add/subtract, or on those binary machines without guard *> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or *> Cray-2. It could conceivably fail on hexadecimal or decimal machines *> without guard digits, but we know of none. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBZ *> \verbatim *> JOBZ is CHARACTER*1 *> Specifies options for computing all or part of the matrix U: *> = 'A': all M columns of U and all N rows of V**T are *> returned in the arrays U and VT; *> = 'S': the first min(M,N) columns of U and the first *> min(M,N) rows of V**T are returned in the arrays U *> and VT; *> = 'O': If M >= N, the first N columns of U are overwritten *> on the array A and all rows of V**T are returned in *> the array VT; *> otherwise, all columns of U are returned in the *> array U and the first M rows of V**T are overwritten *> in the array A; *> = 'N': no columns of U or rows of V**T are computed. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the input matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the input matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the M-by-N matrix A. *> On exit, *> if JOBZ = 'O', A is overwritten with the first N columns *> of U (the left singular vectors, stored *> columnwise) if M >= N; *> A is overwritten with the first M rows *> of V**T (the right singular vectors, stored *> rowwise) otherwise. *> if JOBZ .ne. 'O', the contents of A are destroyed. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] S *> \verbatim *> S is DOUBLE PRECISION array, dimension (min(M,N)) *> The singular values of A, sorted so that S(i) >= S(i+1). *> \endverbatim *> *> \param[out] U *> \verbatim *> U is DOUBLE PRECISION array, dimension (LDU,UCOL) *> UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N; *> UCOL = min(M,N) if JOBZ = 'S'. *> If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M *> orthogonal matrix U; *> if JOBZ = 'S', U contains the first min(M,N) columns of U *> (the left singular vectors, stored columnwise); *> if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced. *> \endverbatim *> *> \param[in] LDU *> \verbatim *> LDU is INTEGER *> The leading dimension of the array U. LDU >= 1; if *> JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M. *> \endverbatim *> *> \param[out] VT *> \verbatim *> VT is DOUBLE PRECISION array, dimension (LDVT,N) *> If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the *> N-by-N orthogonal matrix V**T; *> if JOBZ = 'S', VT contains the first min(M,N) rows of *> V**T (the right singular vectors, stored rowwise); *> if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced. *> \endverbatim *> *> \param[in] LDVT *> \verbatim *> LDVT is INTEGER *> The leading dimension of the array VT. LDVT >= 1; *> if JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N; *> if JOBZ = 'S', LDVT >= min(M,N). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK; *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= 1. *> If LWORK = -1, a workspace query is assumed. The optimal *> size for the WORK array is calculated and stored in WORK(1), *> and no other work except argument checking is performed. *> *> Let mx = max(M,N) and mn = min(M,N). *> If JOBZ = 'N', LWORK >= 3*mn + max( mx, 7*mn ). *> If JOBZ = 'O', LWORK >= 3*mn + max( mx, 5*mn*mn + 4*mn ). *> If JOBZ = 'S', LWORK >= 4*mn*mn + 7*mn. *> If JOBZ = 'A', LWORK >= 4*mn*mn + 6*mn + mx. *> These are not tight minimums in all cases; see comments inside code. *> For good performance, LWORK should generally be larger; *> a query is recommended. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (8*min(M,N)) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: DBDSDC did not converge, updating process failed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleGEsing * *> \par Contributors: * ================== *> *> Ming Gu and Huan Ren, Computer Science Division, University of *> California at Berkeley, USA *> * ===================================================================== SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, $ WORK, LWORK, IWORK, INFO ) implicit none * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ), $ VT( LDVT, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, WNTQA, WNTQAS, WNTQN, WNTQO, WNTQS INTEGER BDSPAC, BLK, CHUNK, I, IE, IERR, IL, $ IR, ISCL, ITAU, ITAUP, ITAUQ, IU, IVT, LDWKVT, $ LDWRKL, LDWRKR, LDWRKU, MAXWRK, MINMN, MINWRK, $ MNTHR, NWORK, WRKBL INTEGER LWORK_DGEBRD_MN, LWORK_DGEBRD_MM, $ LWORK_DGEBRD_NN, LWORK_DGELQF_MN, $ LWORK_DGEQRF_MN, $ LWORK_DORGBR_P_MM, LWORK_DORGBR_Q_NN, $ LWORK_DORGLQ_MN, LWORK_DORGLQ_NN, $ LWORK_DORGQR_MM, LWORK_DORGQR_MN, $ LWORK_DORMBR_PRT_MM, LWORK_DORMBR_QLN_MM, $ LWORK_DORMBR_PRT_MN, LWORK_DORMBR_QLN_MN, $ LWORK_DORMBR_PRT_NN, LWORK_DORMBR_QLN_NN DOUBLE PRECISION ANRM, BIGNUM, EPS, SMLNUM * .. * .. Local Arrays .. INTEGER IDUM( 1 ) DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. EXTERNAL DBDSDC, DGEBRD, DGELQF, DGEMM, DGEQRF, DLACPY, $ DLASCL, DLASET, DORGBR, DORGLQ, DORGQR, DORMBR, $ XERBLA * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE, LSAME * .. * .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN, SQRT * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 MINMN = MIN( M, N ) WNTQA = LSAME( JOBZ, 'A' ) WNTQS = LSAME( JOBZ, 'S' ) WNTQAS = WNTQA .OR. WNTQS WNTQO = LSAME( JOBZ, 'O' ) WNTQN = LSAME( JOBZ, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * IF( .NOT.( WNTQA .OR. WNTQS .OR. WNTQO .OR. WNTQN ) ) THEN INFO = -1 ELSE IF( M.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( LDU.LT.1 .OR. ( WNTQAS .AND. LDU.LT.M ) .OR. $ ( WNTQO .AND. M.LT.N .AND. LDU.LT.M ) ) THEN INFO = -8 ELSE IF( LDVT.LT.1 .OR. ( WNTQA .AND. LDVT.LT.N ) .OR. $ ( WNTQS .AND. LDVT.LT.MINMN ) .OR. $ ( WNTQO .AND. M.GE.N .AND. LDVT.LT.N ) ) THEN INFO = -10 END IF * * Compute workspace * Note: Comments in the code beginning "Workspace:" describe the * minimal amount of workspace allocated at that point in the code, * as well as the preferred amount for good performance. * NB refers to the optimal block size for the immediately * following subroutine, as returned by ILAENV. * IF( INFO.EQ.0 ) THEN MINWRK = 1 MAXWRK = 1 BDSPAC = 0 MNTHR = INT( MINMN*11.0D0 / 6.0D0 ) IF( M.GE.N .AND. MINMN.GT.0 ) THEN * * Compute space needed for DBDSDC * IF( WNTQN ) THEN * dbdsdc needs only 4*N (or 6*N for uplo=L for LAPACK <= 3.6) * keep 7*N for backwards compatability. BDSPAC = 7*N ELSE BDSPAC = 3*N*N + 4*N END IF * * Compute space preferred for each routine CALL DGEBRD( M, N, DUM(1), M, DUM(1), DUM(1), DUM(1), $ DUM(1), DUM(1), -1, IERR ) LWORK_DGEBRD_MN = INT( DUM(1) ) * CALL DGEBRD( N, N, DUM(1), N, DUM(1), DUM(1), DUM(1), $ DUM(1), DUM(1), -1, IERR ) LWORK_DGEBRD_NN = INT( DUM(1) ) * CALL DGEQRF( M, N, DUM(1), M, DUM(1), DUM(1), -1, IERR ) LWORK_DGEQRF_MN = INT( DUM(1) ) * CALL DORGBR( 'Q', N, N, N, DUM(1), N, DUM(1), DUM(1), -1, $ IERR ) LWORK_DORGBR_Q_NN = INT( DUM(1) ) * CALL DORGQR( M, M, N, DUM(1), M, DUM(1), DUM(1), -1, IERR ) LWORK_DORGQR_MM = INT( DUM(1) ) * CALL DORGQR( M, N, N, DUM(1), M, DUM(1), DUM(1), -1, IERR ) LWORK_DORGQR_MN = INT( DUM(1) ) * CALL DORMBR( 'P', 'R', 'T', N, N, N, DUM(1), N, $ DUM(1), DUM(1), N, DUM(1), -1, IERR ) LWORK_DORMBR_PRT_NN = INT( DUM(1) ) * CALL DORMBR( 'Q', 'L', 'N', N, N, N, DUM(1), N, $ DUM(1), DUM(1), N, DUM(1), -1, IERR ) LWORK_DORMBR_QLN_NN = INT( DUM(1) ) * CALL DORMBR( 'Q', 'L', 'N', M, N, N, DUM(1), M, $ DUM(1), DUM(1), M, DUM(1), -1, IERR ) LWORK_DORMBR_QLN_MN = INT( DUM(1) ) * CALL DORMBR( 'Q', 'L', 'N', M, M, N, DUM(1), M, $ DUM(1), DUM(1), M, DUM(1), -1, IERR ) LWORK_DORMBR_QLN_MM = INT( DUM(1) ) * IF( M.GE.MNTHR ) THEN IF( WNTQN ) THEN * * Path 1 (M >> N, JOBZ='N') * WRKBL = N + LWORK_DGEQRF_MN WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD_NN ) MAXWRK = MAX( WRKBL, BDSPAC + N ) MINWRK = BDSPAC + N ELSE IF( WNTQO ) THEN * * Path 2 (M >> N, JOBZ='O') * WRKBL = N + LWORK_DGEQRF_MN WRKBL = MAX( WRKBL, N + LWORK_DORGQR_MN ) WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD_NN ) WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_QLN_NN ) WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_PRT_NN ) WRKBL = MAX( WRKBL, 3*N + BDSPAC ) MAXWRK = WRKBL + 2*N*N MINWRK = BDSPAC + 2*N*N + 3*N ELSE IF( WNTQS ) THEN * * Path 3 (M >> N, JOBZ='S') * WRKBL = N + LWORK_DGEQRF_MN WRKBL = MAX( WRKBL, N + LWORK_DORGQR_MN ) WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD_NN ) WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_QLN_NN ) WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_PRT_NN ) WRKBL = MAX( WRKBL, 3*N + BDSPAC ) MAXWRK = WRKBL + N*N MINWRK = BDSPAC + N*N + 3*N ELSE IF( WNTQA ) THEN * * Path 4 (M >> N, JOBZ='A') * WRKBL = N + LWORK_DGEQRF_MN WRKBL = MAX( WRKBL, N + LWORK_DORGQR_MM ) WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD_NN ) WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_QLN_NN ) WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_PRT_NN ) WRKBL = MAX( WRKBL, 3*N + BDSPAC ) MAXWRK = WRKBL + N*N MINWRK = N*N + MAX( 3*N + BDSPAC, N + M ) END IF ELSE * * Path 5 (M >= N, but not much larger) * WRKBL = 3*N + LWORK_DGEBRD_MN IF( WNTQN ) THEN * Path 5n (M >= N, jobz='N') MAXWRK = MAX( WRKBL, 3*N + BDSPAC ) MINWRK = 3*N + MAX( M, BDSPAC ) ELSE IF( WNTQO ) THEN * Path 5o (M >= N, jobz='O') WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_PRT_NN ) WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_QLN_MN ) WRKBL = MAX( WRKBL, 3*N + BDSPAC ) MAXWRK = WRKBL + M*N MINWRK = 3*N + MAX( M, N*N + BDSPAC ) ELSE IF( WNTQS ) THEN * Path 5s (M >= N, jobz='S') WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_QLN_MN ) WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_PRT_NN ) MAXWRK = MAX( WRKBL, 3*N + BDSPAC ) MINWRK = 3*N + MAX( M, BDSPAC ) ELSE IF( WNTQA ) THEN * Path 5a (M >= N, jobz='A') WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_QLN_MM ) WRKBL = MAX( WRKBL, 3*N + LWORK_DORMBR_PRT_NN ) MAXWRK = MAX( WRKBL, 3*N + BDSPAC ) MINWRK = 3*N + MAX( M, BDSPAC ) END IF END IF ELSE IF( MINMN.GT.0 ) THEN * * Compute space needed for DBDSDC * IF( WNTQN ) THEN * dbdsdc needs only 4*N (or 6*N for uplo=L for LAPACK <= 3.6) * keep 7*N for backwards compatability. BDSPAC = 7*M ELSE BDSPAC = 3*M*M + 4*M END IF * * Compute space preferred for each routine CALL DGEBRD( M, N, DUM(1), M, DUM(1), DUM(1), DUM(1), $ DUM(1), DUM(1), -1, IERR ) LWORK_DGEBRD_MN = INT( DUM(1) ) * CALL DGEBRD( M, M, A, M, S, DUM(1), DUM(1), $ DUM(1), DUM(1), -1, IERR ) LWORK_DGEBRD_MM = INT( DUM(1) ) * CALL DGELQF( M, N, A, M, DUM(1), DUM(1), -1, IERR ) LWORK_DGELQF_MN = INT( DUM(1) ) * CALL DORGLQ( N, N, M, DUM(1), N, DUM(1), DUM(1), -1, IERR ) LWORK_DORGLQ_NN = INT( DUM(1) ) * CALL DORGLQ( M, N, M, A, M, DUM(1), DUM(1), -1, IERR ) LWORK_DORGLQ_MN = INT( DUM(1) ) * CALL DORGBR( 'P', M, M, M, A, N, DUM(1), DUM(1), -1, IERR ) LWORK_DORGBR_P_MM = INT( DUM(1) ) * CALL DORMBR( 'P', 'R', 'T', M, M, M, DUM(1), M, $ DUM(1), DUM(1), M, DUM(1), -1, IERR ) LWORK_DORMBR_PRT_MM = INT( DUM(1) ) * CALL DORMBR( 'P', 'R', 'T', M, N, M, DUM(1), M, $ DUM(1), DUM(1), M, DUM(1), -1, IERR ) LWORK_DORMBR_PRT_MN = INT( DUM(1) ) * CALL DORMBR( 'P', 'R', 'T', N, N, M, DUM(1), N, $ DUM(1), DUM(1), N, DUM(1), -1, IERR ) LWORK_DORMBR_PRT_NN = INT( DUM(1) ) * CALL DORMBR( 'Q', 'L', 'N', M, M, M, DUM(1), M, $ DUM(1), DUM(1), M, DUM(1), -1, IERR ) LWORK_DORMBR_QLN_MM = INT( DUM(1) ) * IF( N.GE.MNTHR ) THEN IF( WNTQN ) THEN * * Path 1t (N >> M, JOBZ='N') * WRKBL = M + LWORK_DGELQF_MN WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD_MM ) MAXWRK = MAX( WRKBL, BDSPAC + M ) MINWRK = BDSPAC + M ELSE IF( WNTQO ) THEN * * Path 2t (N >> M, JOBZ='O') * WRKBL = M + LWORK_DGELQF_MN WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_MN ) WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD_MM ) WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_QLN_MM ) WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_PRT_MM ) WRKBL = MAX( WRKBL, 3*M + BDSPAC ) MAXWRK = WRKBL + 2*M*M MINWRK = BDSPAC + 2*M*M + 3*M ELSE IF( WNTQS ) THEN * * Path 3t (N >> M, JOBZ='S') * WRKBL = M + LWORK_DGELQF_MN WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_MN ) WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD_MM ) WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_QLN_MM ) WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_PRT_MM ) WRKBL = MAX( WRKBL, 3*M + BDSPAC ) MAXWRK = WRKBL + M*M MINWRK = BDSPAC + M*M + 3*M ELSE IF( WNTQA ) THEN * * Path 4t (N >> M, JOBZ='A') * WRKBL = M + LWORK_DGELQF_MN WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_NN ) WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD_MM ) WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_QLN_MM ) WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_PRT_MM ) WRKBL = MAX( WRKBL, 3*M + BDSPAC ) MAXWRK = WRKBL + M*M MINWRK = M*M + MAX( 3*M + BDSPAC, M + N ) END IF ELSE * * Path 5t (N > M, but not much larger) * WRKBL = 3*M + LWORK_DGEBRD_MN IF( WNTQN ) THEN * Path 5tn (N > M, jobz='N') MAXWRK = MAX( WRKBL, 3*M + BDSPAC ) MINWRK = 3*M + MAX( N, BDSPAC ) ELSE IF( WNTQO ) THEN * Path 5to (N > M, jobz='O') WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_QLN_MM ) WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_PRT_MN ) WRKBL = MAX( WRKBL, 3*M + BDSPAC ) MAXWRK = WRKBL + M*N MINWRK = 3*M + MAX( N, M*M + BDSPAC ) ELSE IF( WNTQS ) THEN * Path 5ts (N > M, jobz='S') WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_QLN_MM ) WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_PRT_MN ) MAXWRK = MAX( WRKBL, 3*M + BDSPAC ) MINWRK = 3*M + MAX( N, BDSPAC ) ELSE IF( WNTQA ) THEN * Path 5ta (N > M, jobz='A') WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_QLN_MM ) WRKBL = MAX( WRKBL, 3*M + LWORK_DORMBR_PRT_NN ) MAXWRK = MAX( WRKBL, 3*M + BDSPAC ) MINWRK = 3*M + MAX( N, BDSPAC ) END IF END IF END IF MAXWRK = MAX( MAXWRK, MINWRK ) WORK( 1 ) = MAXWRK * IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN INFO = -12 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGESDD', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) THEN RETURN END IF * * Get machine constants * EPS = DLAMCH( 'P' ) SMLNUM = SQRT( DLAMCH( 'S' ) ) / EPS BIGNUM = ONE / SMLNUM * * Scale A if max element outside range [SMLNUM,BIGNUM] * ANRM = DLANGE( 'M', M, N, A, LDA, DUM ) ISCL = 0 IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN ISCL = 1 CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR ) ELSE IF( ANRM.GT.BIGNUM ) THEN ISCL = 1 CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR ) END IF * IF( M.GE.N ) THEN * * A has at least as many rows as columns. If A has sufficiently * more rows than columns, first reduce using the QR * decomposition (if sufficient workspace available) * IF( M.GE.MNTHR ) THEN * IF( WNTQN ) THEN * * Path 1 (M >> N, JOBZ='N') * No singular vectors to be computed * ITAU = 1 NWORK = ITAU + N * * Compute A=Q*R * Workspace: need N [tau] + N [work] * Workspace: prefer N [tau] + N*NB [work] * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), $ LWORK - NWORK + 1, IERR ) * * Zero out below R * CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA ) IE = 1 ITAUQ = IE + N ITAUP = ITAUQ + N NWORK = ITAUP + N * * Bidiagonalize R in A * Workspace: need 3*N [e, tauq, taup] + N [work] * Workspace: prefer 3*N [e, tauq, taup] + 2*N*NB [work] * CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, $ IERR ) NWORK = IE + N * * Perform bidiagonal SVD, computing singular values only * Workspace: need N [e] + BDSPAC * CALL DBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1, $ DUM, IDUM, WORK( NWORK ), IWORK, INFO ) * ELSE IF( WNTQO ) THEN * * Path 2 (M >> N, JOBZ = 'O') * N left singular vectors to be overwritten on A and * N right singular vectors to be computed in VT * IR = 1 * * WORK(IR) is LDWRKR by N * IF( LWORK .GE. LDA*N + N*N + 3*N + BDSPAC ) THEN LDWRKR = LDA ELSE LDWRKR = ( LWORK - N*N - 3*N - BDSPAC ) / N END IF ITAU = IR + LDWRKR*N NWORK = ITAU + N * * Compute A=Q*R * Workspace: need N*N [R] + N [tau] + N [work] * Workspace: prefer N*N [R] + N [tau] + N*NB [work] * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), $ LWORK - NWORK + 1, IERR ) * * Copy R to WORK(IR), zeroing out below it * CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR ) CALL DLASET( 'L', N - 1, N - 1, ZERO, ZERO, WORK(IR+1), $ LDWRKR ) * * Generate Q in A * Workspace: need N*N [R] + N [tau] + N [work] * Workspace: prefer N*N [R] + N [tau] + N*NB [work] * CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) IE = ITAU ITAUQ = IE + N ITAUP = ITAUQ + N NWORK = ITAUP + N * * Bidiagonalize R in WORK(IR) * Workspace: need N*N [R] + 3*N [e, tauq, taup] + N [work] * Workspace: prefer N*N [R] + 3*N [e, tauq, taup] + 2*N*NB [work] * CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), $ LWORK - NWORK + 1, IERR ) * * WORK(IU) is N by N * IU = NWORK NWORK = IU + N*N * * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in WORK(IU) and computing right * singular vectors of bidiagonal matrix in VT * Workspace: need N*N [R] + 3*N [e, tauq, taup] + N*N [U] + BDSPAC * CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), N, $ VT, LDVT, DUM, IDUM, WORK( NWORK ), IWORK, $ INFO ) * * Overwrite WORK(IU) by left singular vectors of R * and VT by right singular vectors of R * Workspace: need N*N [R] + 3*N [e, tauq, taup] + N*N [U] + N [work] * Workspace: prefer N*N [R] + 3*N [e, tauq, taup] + N*N [U] + N*NB [work] * CALL DORMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IU ), N, WORK( NWORK ), $ LWORK - NWORK + 1, IERR ) CALL DORMBR( 'P', 'R', 'T', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), $ LWORK - NWORK + 1, IERR ) * * Multiply Q in A by left singular vectors of R in * WORK(IU), storing result in WORK(IR) and copying to A * Workspace: need N*N [R] + 3*N [e, tauq, taup] + N*N [U] * Workspace: prefer M*N [R] + 3*N [e, tauq, taup] + N*N [U] * DO 10 I = 1, M, LDWRKR CHUNK = MIN( M - I + 1, LDWRKR ) CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ), $ LDA, WORK( IU ), N, ZERO, WORK( IR ), $ LDWRKR ) CALL DLACPY( 'F', CHUNK, N, WORK( IR ), LDWRKR, $ A( I, 1 ), LDA ) 10 CONTINUE * ELSE IF( WNTQS ) THEN * * Path 3 (M >> N, JOBZ='S') * N left singular vectors to be computed in U and * N right singular vectors to be computed in VT * IR = 1 * * WORK(IR) is N by N * LDWRKR = N ITAU = IR + LDWRKR*N NWORK = ITAU + N * * Compute A=Q*R * Workspace: need N*N [R] + N [tau] + N [work] * Workspace: prefer N*N [R] + N [tau] + N*NB [work] * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), $ LWORK - NWORK + 1, IERR ) * * Copy R to WORK(IR), zeroing out below it * CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR ) CALL DLASET( 'L', N - 1, N - 1, ZERO, ZERO, WORK(IR+1), $ LDWRKR ) * * Generate Q in A * Workspace: need N*N [R] + N [tau] + N [work] * Workspace: prefer N*N [R] + N [tau] + N*NB [work] * CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) IE = ITAU ITAUQ = IE + N ITAUP = ITAUQ + N NWORK = ITAUP + N * * Bidiagonalize R in WORK(IR) * Workspace: need N*N [R] + 3*N [e, tauq, taup] + N [work] * Workspace: prefer N*N [R] + 3*N [e, tauq, taup] + 2*N*NB [work] * CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), $ LWORK - NWORK + 1, IERR ) * * Perform bidiagonal SVD, computing left singular vectors * of bidiagoal matrix in U and computing right singular * vectors of bidiagonal matrix in VT * Workspace: need N*N [R] + 3*N [e, tauq, taup] + BDSPAC * CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT, $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK, $ INFO ) * * Overwrite U by left singular vectors of R and VT * by right singular vectors of R * Workspace: need N*N [R] + 3*N [e, tauq, taup] + N [work] * Workspace: prefer N*N [R] + 3*N [e, tauq, taup] + N*NB [work] * CALL DORMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), $ LWORK - NWORK + 1, IERR ) * CALL DORMBR( 'P', 'R', 'T', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), $ LWORK - NWORK + 1, IERR ) * * Multiply Q in A by left singular vectors of R in * WORK(IR), storing result in U * Workspace: need N*N [R] * CALL DLACPY( 'F', N, N, U, LDU, WORK( IR ), LDWRKR ) CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA, WORK( IR ), $ LDWRKR, ZERO, U, LDU ) * ELSE IF( WNTQA ) THEN * * Path 4 (M >> N, JOBZ='A') * M left singular vectors to be computed in U and * N right singular vectors to be computed in VT * IU = 1 * * WORK(IU) is N by N * LDWRKU = N ITAU = IU + LDWRKU*N NWORK = ITAU + N * * Compute A=Q*R, copying result to U * Workspace: need N*N [U] + N [tau] + N [work] * Workspace: prefer N*N [U] + N [tau] + N*NB [work] * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), $ LWORK - NWORK + 1, IERR ) CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U * Workspace: need N*N [U] + N [tau] + M [work] * Workspace: prefer N*N [U] + N [tau] + M*NB [work] CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) * * Produce R in A, zeroing out other entries * CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA ) IE = ITAU ITAUQ = IE + N ITAUP = ITAUQ + N NWORK = ITAUP + N * * Bidiagonalize R in A * Workspace: need N*N [U] + 3*N [e, tauq, taup] + N [work] * Workspace: prefer N*N [U] + 3*N [e, tauq, taup] + 2*N*NB [work] * CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, $ IERR ) * * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in WORK(IU) and computing right * singular vectors of bidiagonal matrix in VT * Workspace: need N*N [U] + 3*N [e, tauq, taup] + BDSPAC * CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), N, $ VT, LDVT, DUM, IDUM, WORK( NWORK ), IWORK, $ INFO ) * * Overwrite WORK(IU) by left singular vectors of R and VT * by right singular vectors of R * Workspace: need N*N [U] + 3*N [e, tauq, taup] + N [work] * Workspace: prefer N*N [U] + 3*N [e, tauq, taup] + N*NB [work] * CALL DORMBR( 'Q', 'L', 'N', N, N, N, A, LDA, $ WORK( ITAUQ ), WORK( IU ), LDWRKU, $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) CALL DORMBR( 'P', 'R', 'T', N, N, N, A, LDA, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), $ LWORK - NWORK + 1, IERR ) * * Multiply Q in U by left singular vectors of R in * WORK(IU), storing result in A * Workspace: need N*N [U] * CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU, WORK( IU ), $ LDWRKU, ZERO, A, LDA ) * * Copy left singular vectors of A from A to U * CALL DLACPY( 'F', M, N, A, LDA, U, LDU ) * END IF * ELSE * * M .LT. MNTHR * * Path 5 (M >= N, but not much larger) * Reduce to bidiagonal form without QR decomposition * IE = 1 ITAUQ = IE + N ITAUP = ITAUQ + N NWORK = ITAUP + N * * Bidiagonalize A * Workspace: need 3*N [e, tauq, taup] + M [work] * Workspace: prefer 3*N [e, tauq, taup] + (M+N)*NB [work] * CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, $ IERR ) IF( WNTQN ) THEN * * Path 5n (M >= N, JOBZ='N') * Perform bidiagonal SVD, only computing singular values * Workspace: need 3*N [e, tauq, taup] + BDSPAC * CALL DBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1, $ DUM, IDUM, WORK( NWORK ), IWORK, INFO ) ELSE IF( WNTQO ) THEN * Path 5o (M >= N, JOBZ='O') IU = NWORK IF( LWORK .GE. M*N + 3*N + BDSPAC ) THEN * * WORK( IU ) is M by N * LDWRKU = M NWORK = IU + LDWRKU*N CALL DLASET( 'F', M, N, ZERO, ZERO, WORK( IU ), $ LDWRKU ) * IR is unused; silence compile warnings IR = -1 ELSE * * WORK( IU ) is N by N * LDWRKU = N NWORK = IU + LDWRKU*N * * WORK(IR) is LDWRKR by N * IR = NWORK LDWRKR = ( LWORK - N*N - 3*N ) / N END IF NWORK = IU + LDWRKU*N * * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in WORK(IU) and computing right * singular vectors of bidiagonal matrix in VT * Workspace: need 3*N [e, tauq, taup] + N*N [U] + BDSPAC * CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), $ LDWRKU, VT, LDVT, DUM, IDUM, WORK( NWORK ), $ IWORK, INFO ) * * Overwrite VT by right singular vectors of A * Workspace: need 3*N [e, tauq, taup] + N*N [U] + N [work] * Workspace: prefer 3*N [e, tauq, taup] + N*N [U] + N*NB [work] * CALL DORMBR( 'P', 'R', 'T', N, N, N, A, LDA, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), $ LWORK - NWORK + 1, IERR ) * IF( LWORK .GE. M*N + 3*N + BDSPAC ) THEN * * Path 5o-fast * Overwrite WORK(IU) by left singular vectors of A * Workspace: need 3*N [e, tauq, taup] + M*N [U] + N [work] * Workspace: prefer 3*N [e, tauq, taup] + M*N [U] + N*NB [work] * CALL DORMBR( 'Q', 'L', 'N', M, N, N, A, LDA, $ WORK( ITAUQ ), WORK( IU ), LDWRKU, $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) * * Copy left singular vectors of A from WORK(IU) to A * CALL DLACPY( 'F', M, N, WORK( IU ), LDWRKU, A, LDA ) ELSE * * Path 5o-slow * Generate Q in A * Workspace: need 3*N [e, tauq, taup] + N*N [U] + N [work] * Workspace: prefer 3*N [e, tauq, taup] + N*N [U] + N*NB [work] * CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) * * Multiply Q in A by left singular vectors of * bidiagonal matrix in WORK(IU), storing result in * WORK(IR) and copying to A * Workspace: need 3*N [e, tauq, taup] + N*N [U] + NB*N [R] * Workspace: prefer 3*N [e, tauq, taup] + N*N [U] + M*N [R] * DO 20 I = 1, M, LDWRKR CHUNK = MIN( M - I + 1, LDWRKR ) CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ), $ LDA, WORK( IU ), LDWRKU, ZERO, $ WORK( IR ), LDWRKR ) CALL DLACPY( 'F', CHUNK, N, WORK( IR ), LDWRKR, $ A( I, 1 ), LDA ) 20 CONTINUE END IF * ELSE IF( WNTQS ) THEN * * Path 5s (M >= N, JOBZ='S') * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in VT * Workspace: need 3*N [e, tauq, taup] + BDSPAC * CALL DLASET( 'F', M, N, ZERO, ZERO, U, LDU ) CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT, $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK, $ INFO ) * * Overwrite U by left singular vectors of A and VT * by right singular vectors of A * Workspace: need 3*N [e, tauq, taup] + N [work] * Workspace: prefer 3*N [e, tauq, taup] + N*NB [work] * CALL DORMBR( 'Q', 'L', 'N', M, N, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), $ LWORK - NWORK + 1, IERR ) CALL DORMBR( 'P', 'R', 'T', N, N, N, A, LDA, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), $ LWORK - NWORK + 1, IERR ) ELSE IF( WNTQA ) THEN * * Path 5a (M >= N, JOBZ='A') * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in VT * Workspace: need 3*N [e, tauq, taup] + BDSPAC * CALL DLASET( 'F', M, M, ZERO, ZERO, U, LDU ) CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT, $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK, $ INFO ) * * Set the right corner of U to identity matrix * IF( M.GT.N ) THEN CALL DLASET( 'F', M - N, M - N, ZERO, ONE, U(N+1,N+1), $ LDU ) END IF * * Overwrite U by left singular vectors of A and VT * by right singular vectors of A * Workspace: need 3*N [e, tauq, taup] + M [work] * Workspace: prefer 3*N [e, tauq, taup] + M*NB [work] * CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), $ LWORK - NWORK + 1, IERR ) CALL DORMBR( 'P', 'R', 'T', N, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), $ LWORK - NWORK + 1, IERR ) END IF * END IF * ELSE * * A has more columns than rows. If A has sufficiently more * columns than rows, first reduce using the LQ decomposition (if * sufficient workspace available) * IF( N.GE.MNTHR ) THEN * IF( WNTQN ) THEN * * Path 1t (N >> M, JOBZ='N') * No singular vectors to be computed * ITAU = 1 NWORK = ITAU + M * * Compute A=L*Q * Workspace: need M [tau] + M [work] * Workspace: prefer M [tau] + M*NB [work] * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), $ LWORK - NWORK + 1, IERR ) * * Zero out above L * CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA ) IE = 1 ITAUQ = IE + M ITAUP = ITAUQ + M NWORK = ITAUP + M * * Bidiagonalize L in A * Workspace: need 3*M [e, tauq, taup] + M [work] * Workspace: prefer 3*M [e, tauq, taup] + 2*M*NB [work] * CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, $ IERR ) NWORK = IE + M * * Perform bidiagonal SVD, computing singular values only * Workspace: need M [e] + BDSPAC * CALL DBDSDC( 'U', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1, $ DUM, IDUM, WORK( NWORK ), IWORK, INFO ) * ELSE IF( WNTQO ) THEN * * Path 2t (N >> M, JOBZ='O') * M right singular vectors to be overwritten on A and * M left singular vectors to be computed in U * IVT = 1 * * WORK(IVT) is M by M * WORK(IL) is M by M; it is later resized to M by chunk for gemm * IL = IVT + M*M IF( LWORK .GE. M*N + M*M + 3*M + BDSPAC ) THEN LDWRKL = M CHUNK = N ELSE LDWRKL = M CHUNK = ( LWORK - M*M ) / M END IF ITAU = IL + LDWRKL*M NWORK = ITAU + M * * Compute A=L*Q * Workspace: need M*M [VT] + M*M [L] + M [tau] + M [work] * Workspace: prefer M*M [VT] + M*M [L] + M [tau] + M*NB [work] * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), $ LWORK - NWORK + 1, IERR ) * * Copy L to WORK(IL), zeroing about above it * CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL ) CALL DLASET( 'U', M - 1, M - 1, ZERO, ZERO, $ WORK( IL + LDWRKL ), LDWRKL ) * * Generate Q in A * Workspace: need M*M [VT] + M*M [L] + M [tau] + M [work] * Workspace: prefer M*M [VT] + M*M [L] + M [tau] + M*NB [work] * CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) IE = ITAU ITAUQ = IE + M ITAUP = ITAUQ + M NWORK = ITAUP + M * * Bidiagonalize L in WORK(IL) * Workspace: need M*M [VT] + M*M [L] + 3*M [e, tauq, taup] + M [work] * Workspace: prefer M*M [VT] + M*M [L] + 3*M [e, tauq, taup] + 2*M*NB [work] * CALL DGEBRD( M, M, WORK( IL ), LDWRKL, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), $ LWORK - NWORK + 1, IERR ) * * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U, and computing right singular * vectors of bidiagonal matrix in WORK(IVT) * Workspace: need M*M [VT] + M*M [L] + 3*M [e, tauq, taup] + BDSPAC * CALL DBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU, $ WORK( IVT ), M, DUM, IDUM, WORK( NWORK ), $ IWORK, INFO ) * * Overwrite U by left singular vectors of L and WORK(IVT) * by right singular vectors of L * Workspace: need M*M [VT] + M*M [L] + 3*M [e, tauq, taup] + M [work] * Workspace: prefer M*M [VT] + M*M [L] + 3*M [e, tauq, taup] + M*NB [work] * CALL DORMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL, $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), $ LWORK - NWORK + 1, IERR ) CALL DORMBR( 'P', 'R', 'T', M, M, M, WORK( IL ), LDWRKL, $ WORK( ITAUP ), WORK( IVT ), M, $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) * * Multiply right singular vectors of L in WORK(IVT) by Q * in A, storing result in WORK(IL) and copying to A * Workspace: need M*M [VT] + M*M [L] * Workspace: prefer M*M [VT] + M*N [L] * At this point, L is resized as M by chunk. * DO 30 I = 1, N, CHUNK BLK = MIN( N - I + 1, CHUNK ) CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IVT ), M, $ A( 1, I ), LDA, ZERO, WORK( IL ), LDWRKL ) CALL DLACPY( 'F', M, BLK, WORK( IL ), LDWRKL, $ A( 1, I ), LDA ) 30 CONTINUE * ELSE IF( WNTQS ) THEN * * Path 3t (N >> M, JOBZ='S') * M right singular vectors to be computed in VT and * M left singular vectors to be computed in U * IL = 1 * * WORK(IL) is M by M * LDWRKL = M ITAU = IL + LDWRKL*M NWORK = ITAU + M * * Compute A=L*Q * Workspace: need M*M [L] + M [tau] + M [work] * Workspace: prefer M*M [L] + M [tau] + M*NB [work] * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), $ LWORK - NWORK + 1, IERR ) * * Copy L to WORK(IL), zeroing out above it * CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL ) CALL DLASET( 'U', M - 1, M - 1, ZERO, ZERO, $ WORK( IL + LDWRKL ), LDWRKL ) * * Generate Q in A * Workspace: need M*M [L] + M [tau] + M [work] * Workspace: prefer M*M [L] + M [tau] + M*NB [work] * CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) IE = ITAU ITAUQ = IE + M ITAUP = ITAUQ + M NWORK = ITAUP + M * * Bidiagonalize L in WORK(IU). * Workspace: need M*M [L] + 3*M [e, tauq, taup] + M [work] * Workspace: prefer M*M [L] + 3*M [e, tauq, taup] + 2*M*NB [work] * CALL DGEBRD( M, M, WORK( IL ), LDWRKL, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), $ LWORK - NWORK + 1, IERR ) * * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in VT * Workspace: need M*M [L] + 3*M [e, tauq, taup] + BDSPAC * CALL DBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU, VT, $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK, $ INFO ) * * Overwrite U by left singular vectors of L and VT * by right singular vectors of L * Workspace: need M*M [L] + 3*M [e, tauq, taup] + M [work] * Workspace: prefer M*M [L] + 3*M [e, tauq, taup] + M*NB [work] * CALL DORMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL, $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), $ LWORK - NWORK + 1, IERR ) CALL DORMBR( 'P', 'R', 'T', M, M, M, WORK( IL ), LDWRKL, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), $ LWORK - NWORK + 1, IERR ) * * Multiply right singular vectors of L in WORK(IL) by * Q in A, storing result in VT * Workspace: need M*M [L] * CALL DLACPY( 'F', M, M, VT, LDVT, WORK( IL ), LDWRKL ) CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IL ), LDWRKL, $ A, LDA, ZERO, VT, LDVT ) * ELSE IF( WNTQA ) THEN * * Path 4t (N >> M, JOBZ='A') * N right singular vectors to be computed in VT and * M left singular vectors to be computed in U * IVT = 1 * * WORK(IVT) is M by M * LDWKVT = M ITAU = IVT + LDWKVT*M NWORK = ITAU + M * * Compute A=L*Q, copying result to VT * Workspace: need M*M [VT] + M [tau] + M [work] * Workspace: prefer M*M [VT] + M [tau] + M*NB [work] * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), $ LWORK - NWORK + 1, IERR ) CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT * Workspace: need M*M [VT] + M [tau] + N [work] * Workspace: prefer M*M [VT] + M [tau] + N*NB [work] * CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) * * Produce L in A, zeroing out other entries * CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA ) IE = ITAU ITAUQ = IE + M ITAUP = ITAUQ + M NWORK = ITAUP + M * * Bidiagonalize L in A * Workspace: need M*M [VT] + 3*M [e, tauq, taup] + M [work] * Workspace: prefer M*M [VT] + 3*M [e, tauq, taup] + 2*M*NB [work] * CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, $ IERR ) * * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in WORK(IVT) * Workspace: need M*M [VT] + 3*M [e, tauq, taup] + BDSPAC * CALL DBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU, $ WORK( IVT ), LDWKVT, DUM, IDUM, $ WORK( NWORK ), IWORK, INFO ) * * Overwrite U by left singular vectors of L and WORK(IVT) * by right singular vectors of L * Workspace: need M*M [VT] + 3*M [e, tauq, taup]+ M [work] * Workspace: prefer M*M [VT] + 3*M [e, tauq, taup]+ M*NB [work] * CALL DORMBR( 'Q', 'L', 'N', M, M, M, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), $ LWORK - NWORK + 1, IERR ) CALL DORMBR( 'P', 'R', 'T', M, M, M, A, LDA, $ WORK( ITAUP ), WORK( IVT ), LDWKVT, $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) * * Multiply right singular vectors of L in WORK(IVT) by * Q in VT, storing result in A * Workspace: need M*M [VT] * CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IVT ), LDWKVT, $ VT, LDVT, ZERO, A, LDA ) * * Copy right singular vectors of A from A to VT * CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT ) * END IF * ELSE * * N .LT. MNTHR * * Path 5t (N > M, but not much larger) * Reduce to bidiagonal form without LQ decomposition * IE = 1 ITAUQ = IE + M ITAUP = ITAUQ + M NWORK = ITAUP + M * * Bidiagonalize A * Workspace: need 3*M [e, tauq, taup] + N [work] * Workspace: prefer 3*M [e, tauq, taup] + (M+N)*NB [work] * CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, $ IERR ) IF( WNTQN ) THEN * * Path 5tn (N > M, JOBZ='N') * Perform bidiagonal SVD, only computing singular values * Workspace: need 3*M [e, tauq, taup] + BDSPAC * CALL DBDSDC( 'L', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1, $ DUM, IDUM, WORK( NWORK ), IWORK, INFO ) ELSE IF( WNTQO ) THEN * Path 5to (N > M, JOBZ='O') LDWKVT = M IVT = NWORK IF( LWORK .GE. M*N + 3*M + BDSPAC ) THEN * * WORK( IVT ) is M by N * CALL DLASET( 'F', M, N, ZERO, ZERO, WORK( IVT ), $ LDWKVT ) NWORK = IVT + LDWKVT*N * IL is unused; silence compile warnings IL = -1 ELSE * * WORK( IVT ) is M by M * NWORK = IVT + LDWKVT*M IL = NWORK * * WORK(IL) is M by CHUNK * CHUNK = ( LWORK - M*M - 3*M ) / M END IF * * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in WORK(IVT) * Workspace: need 3*M [e, tauq, taup] + M*M [VT] + BDSPAC * CALL DBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, $ WORK( IVT ), LDWKVT, DUM, IDUM, $ WORK( NWORK ), IWORK, INFO ) * * Overwrite U by left singular vectors of A * Workspace: need 3*M [e, tauq, taup] + M*M [VT] + M [work] * Workspace: prefer 3*M [e, tauq, taup] + M*M [VT] + M*NB [work] * CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), $ LWORK - NWORK + 1, IERR ) * IF( LWORK .GE. M*N + 3*M + BDSPAC ) THEN * * Path 5to-fast * Overwrite WORK(IVT) by left singular vectors of A * Workspace: need 3*M [e, tauq, taup] + M*N [VT] + M [work] * Workspace: prefer 3*M [e, tauq, taup] + M*N [VT] + M*NB [work] * CALL DORMBR( 'P', 'R', 'T', M, N, M, A, LDA, $ WORK( ITAUP ), WORK( IVT ), LDWKVT, $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) * * Copy right singular vectors of A from WORK(IVT) to A * CALL DLACPY( 'F', M, N, WORK( IVT ), LDWKVT, A, LDA ) ELSE * * Path 5to-slow * Generate P**T in A * Workspace: need 3*M [e, tauq, taup] + M*M [VT] + M [work] * Workspace: prefer 3*M [e, tauq, taup] + M*M [VT] + M*NB [work] * CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), $ WORK( NWORK ), LWORK - NWORK + 1, IERR ) * * Multiply Q in A by right singular vectors of * bidiagonal matrix in WORK(IVT), storing result in * WORK(IL) and copying to A * Workspace: need 3*M [e, tauq, taup] + M*M [VT] + M*NB [L] * Workspace: prefer 3*M [e, tauq, taup] + M*M [VT] + M*N [L] * DO 40 I = 1, N, CHUNK BLK = MIN( N - I + 1, CHUNK ) CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IVT ), $ LDWKVT, A( 1, I ), LDA, ZERO, $ WORK( IL ), M ) CALL DLACPY( 'F', M, BLK, WORK( IL ), M, A( 1, I ), $ LDA ) 40 CONTINUE END IF ELSE IF( WNTQS ) THEN * * Path 5ts (N > M, JOBZ='S') * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in VT * Workspace: need 3*M [e, tauq, taup] + BDSPAC * CALL DLASET( 'F', M, N, ZERO, ZERO, VT, LDVT ) CALL DBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, VT, $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK, $ INFO ) * * Overwrite U by left singular vectors of A and VT * by right singular vectors of A * Workspace: need 3*M [e, tauq, taup] + M [work] * Workspace: prefer 3*M [e, tauq, taup] + M*NB [work] * CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), $ LWORK - NWORK + 1, IERR ) CALL DORMBR( 'P', 'R', 'T', M, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), $ LWORK - NWORK + 1, IERR ) ELSE IF( WNTQA ) THEN * * Path 5ta (N > M, JOBZ='A') * Perform bidiagonal SVD, computing left singular vectors * of bidiagonal matrix in U and computing right singular * vectors of bidiagonal matrix in VT * Workspace: need 3*M [e, tauq, taup] + BDSPAC * CALL DLASET( 'F', N, N, ZERO, ZERO, VT, LDVT ) CALL DBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, VT, $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK, $ INFO ) * * Set the right corner of VT to identity matrix * IF( N.GT.M ) THEN CALL DLASET( 'F', N-M, N-M, ZERO, ONE, VT(M+1,M+1), $ LDVT ) END IF * * Overwrite U by left singular vectors of A and VT * by right singular vectors of A * Workspace: need 3*M [e, tauq, taup] + N [work] * Workspace: prefer 3*M [e, tauq, taup] + N*NB [work] * CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( NWORK ), $ LWORK - NWORK + 1, IERR ) CALL DORMBR( 'P', 'R', 'T', N, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ), $ LWORK - NWORK + 1, IERR ) END IF * END IF * END IF * * Undo scaling if necessary * IF( ISCL.EQ.1 ) THEN IF( ANRM.GT.BIGNUM ) $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN, $ IERR ) IF( ANRM.LT.SMLNUM ) $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN, $ IERR ) END IF * * Return optimal workspace in WORK(1) * WORK( 1 ) = MAXWRK * RETURN * * End of DGESDD * END *> \brief DGESV computes the solution to system of linear equations A * X = B for GE matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGESV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, N, NRHS * .. * .. Array Arguments .. * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGESV computes the solution to a real system of linear equations *> A * X = B, *> where A is an N-by-N matrix and X and B are N-by-NRHS matrices. *> *> The LU decomposition with partial pivoting and row interchanges is *> used to factor A as *> A = P * L * U, *> where P is a permutation matrix, L is unit lower triangular, and U is *> upper triangular. The factored form of A is then used to solve the *> system of equations A * X = B. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The number of linear equations, i.e., the order of the *> matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrix B. NRHS >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the N-by-N coefficient matrix A. *> On exit, the factors L and U from the factorization *> A = P*L*U; the unit diagonal elements of L are not stored. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N) *> The pivot indices that define the permutation matrix P; *> row i of the matrix was interchanged with row IPIV(i). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is 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. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, U(i,i) is exactly zero. The factorization *> has been completed, but the factor U is exactly *> singular, so the solution could not be computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEsolve * * ===================================================================== SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * ===================================================================== * * .. External Subroutines .. EXTERNAL DGETRF, DGETRS, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( NRHS.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGESV ', -INFO ) RETURN END IF * * Compute the LU factorization of A. * CALL DGETRF( N, N, A, LDA, IPIV, INFO ) IF( INFO.EQ.0 ) THEN * * Solve the system A*X = B, overwriting B with X. * CALL DGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB, $ INFO ) END IF RETURN * * End of DGESV * END *> \brief DGESVD computes the singular value decomposition (SVD) for GE matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGESVD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, * WORK, LWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBU, JOBVT * INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ), * $ VT( LDVT, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGESVD computes the singular value decomposition (SVD) of a real *> M-by-N matrix A, optionally computing the left and/or right singular *> vectors. The SVD is written *> *> A = U * SIGMA * transpose(V) *> *> where SIGMA is an M-by-N matrix which is zero except for its *> min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and *> V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA *> are the singular values of A; they are real and non-negative, and *> are returned in descending order. The first min(m,n) columns of *> U and V are the left and right singular vectors of A. *> *> Note that the routine returns V**T, not V. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBU *> \verbatim *> JOBU is CHARACTER*1 *> Specifies options for computing all or part of the matrix U: *> = 'A': all M columns of U are returned in array U: *> = 'S': the first min(m,n) columns of U (the left singular *> vectors) are returned in the array U; *> = 'O': the first min(m,n) columns of U (the left singular *> vectors) are overwritten on the array A; *> = 'N': no columns of U (no left singular vectors) are *> computed. *> \endverbatim *> *> \param[in] JOBVT *> \verbatim *> JOBVT is CHARACTER*1 *> Specifies options for computing all or part of the matrix *> V**T: *> = 'A': all N rows of V**T are returned in the array VT; *> = 'S': the first min(m,n) rows of V**T (the right singular *> vectors) are returned in the array VT; *> = 'O': the first min(m,n) rows of V**T (the right singular *> vectors) are overwritten on the array A; *> = 'N': no rows of V**T (no right singular vectors) are *> computed. *> *> JOBVT and JOBU cannot both be 'O'. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the input matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the input matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the M-by-N matrix A. *> On exit, *> if JOBU = 'O', A is overwritten with the first min(m,n) *> columns of U (the left singular vectors, *> stored columnwise); *> if JOBVT = 'O', A is overwritten with the first min(m,n) *> rows of V**T (the right singular vectors, *> stored rowwise); *> if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A *> are destroyed. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] S *> \verbatim *> S is DOUBLE PRECISION array, dimension (min(M,N)) *> The singular values of A, sorted so that S(i) >= S(i+1). *> \endverbatim *> *> \param[out] U *> \verbatim *> U is DOUBLE PRECISION array, dimension (LDU,UCOL) *> (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'. *> If JOBU = 'A', U contains the M-by-M orthogonal matrix U; *> if JOBU = 'S', U contains the first min(m,n) columns of U *> (the left singular vectors, stored columnwise); *> if JOBU = 'N' or 'O', U is not referenced. *> \endverbatim *> *> \param[in] LDU *> \verbatim *> LDU is INTEGER *> The leading dimension of the array U. LDU >= 1; if *> JOBU = 'S' or 'A', LDU >= M. *> \endverbatim *> *> \param[out] VT *> \verbatim *> VT is DOUBLE PRECISION array, dimension (LDVT,N) *> If JOBVT = 'A', VT contains the N-by-N orthogonal matrix *> V**T; *> if JOBVT = 'S', VT contains the first min(m,n) rows of *> V**T (the right singular vectors, stored rowwise); *> if JOBVT = 'N' or 'O', VT is not referenced. *> \endverbatim *> *> \param[in] LDVT *> \verbatim *> LDVT is INTEGER *> The leading dimension of the array VT. LDVT >= 1; if *> JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK; *> if INFO > 0, WORK(2:MIN(M,N)) contains the unconverged *> superdiagonal elements of an upper bidiagonal matrix B *> whose diagonal is in S (not necessarily sorted). B *> satisfies A = U * B * VT, so it has the same singular values *> as A, and singular vectors related by U and VT. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. *> LWORK >= MAX(1,5*MIN(M,N)) for the paths (see comments inside code): *> - PATH 1 (M much larger than N, JOBU='N') *> - PATH 1t (N much larger than M, JOBVT='N') *> LWORK >= MAX(1,3*MIN(M,N) + MAX(M,N),5*MIN(M,N)) for the other paths *> For good performance, LWORK should generally be larger. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error *> message related to LWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: if DBDSQR did not converge, INFO specifies how many *> superdiagonals of an intermediate bidiagonal form B *> did not converge to zero. See the description of WORK *> above for details. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date April 2012 * *> \ingroup doubleGEsing * * ===================================================================== SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, $ VT, LDVT, WORK, LWORK, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * April 2012 * * .. Scalar Arguments .. CHARACTER JOBU, JOBVT INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ), $ VT( LDVT, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS, $ WNTVA, WNTVAS, WNTVN, WNTVO, WNTVS INTEGER BDSPAC, BLK, CHUNK, I, IE, IERR, IR, ISCL, $ ITAU, ITAUP, ITAUQ, IU, IWORK, LDWRKR, LDWRKU, $ MAXWRK, MINMN, MINWRK, MNTHR, NCU, NCVT, NRU, $ NRVT, WRKBL INTEGER LWORK_DGEQRF, LWORK_DORGQR_N, LWORK_DORGQR_M, $ LWORK_DGEBRD, LWORK_DORGBR_P, LWORK_DORGBR_Q, $ LWORK_DGELQF, LWORK_DORGLQ_N, LWORK_DORGLQ_M DOUBLE PRECISION ANRM, BIGNUM, EPS, SMLNUM * .. * .. Local Arrays .. DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. EXTERNAL DBDSQR, DGEBRD, DGELQF, DGEMM, DGEQRF, DLACPY, $ DLASCL, DLASET, DORGBR, DORGLQ, DORGQR, DORMBR, $ XERBLA * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 MINMN = MIN( M, N ) WNTUA = LSAME( JOBU, 'A' ) WNTUS = LSAME( JOBU, 'S' ) WNTUAS = WNTUA .OR. WNTUS WNTUO = LSAME( JOBU, 'O' ) WNTUN = LSAME( JOBU, 'N' ) WNTVA = LSAME( JOBVT, 'A' ) WNTVS = LSAME( JOBVT, 'S' ) WNTVAS = WNTVA .OR. WNTVS WNTVO = LSAME( JOBVT, 'O' ) WNTVN = LSAME( JOBVT, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * IF( .NOT.( WNTUA .OR. WNTUS .OR. WNTUO .OR. WNTUN ) ) THEN INFO = -1 ELSE IF( .NOT.( WNTVA .OR. WNTVS .OR. WNTVO .OR. WNTVN ) .OR. $ ( WNTVO .AND. WNTUO ) ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF( LDU.LT.1 .OR. ( WNTUAS .AND. LDU.LT.M ) ) THEN INFO = -9 ELSE IF( LDVT.LT.1 .OR. ( WNTVA .AND. LDVT.LT.N ) .OR. $ ( WNTVS .AND. LDVT.LT.MINMN ) ) THEN INFO = -11 END IF * * Compute workspace * (Note: Comments in the code beginning "Workspace:" describe the * minimal amount of workspace needed at that point in the code, * as well as the preferred amount for good performance. * NB refers to the optimal block size for the immediately * following subroutine, as returned by ILAENV.) * IF( INFO.EQ.0 ) THEN MINWRK = 1 MAXWRK = 1 IF( M.GE.N .AND. MINMN.GT.0 ) THEN * * Compute space needed for DBDSQR * MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 ) BDSPAC = 5*N * Compute space needed for DGEQRF CALL DGEQRF( M, N, A, LDA, DUM(1), DUM(1), -1, IERR ) LWORK_DGEQRF = INT( DUM(1) ) * Compute space needed for DORGQR CALL DORGQR( M, N, N, A, LDA, DUM(1), DUM(1), -1, IERR ) LWORK_DORGQR_N = INT( DUM(1) ) CALL DORGQR( M, M, N, A, LDA, DUM(1), DUM(1), -1, IERR ) LWORK_DORGQR_M = INT( DUM(1) ) * Compute space needed for DGEBRD CALL DGEBRD( N, N, A, LDA, S, DUM(1), DUM(1), $ DUM(1), DUM(1), -1, IERR ) LWORK_DGEBRD = INT( DUM(1) ) * Compute space needed for DORGBR P CALL DORGBR( 'P', N, N, N, A, LDA, DUM(1), $ DUM(1), -1, IERR ) LWORK_DORGBR_P = INT( DUM(1) ) * Compute space needed for DORGBR Q CALL DORGBR( 'Q', N, N, N, A, LDA, DUM(1), $ DUM(1), -1, IERR ) LWORK_DORGBR_Q = INT( DUM(1) ) * IF( M.GE.MNTHR ) THEN IF( WNTUN ) THEN * * Path 1 (M much larger than N, JOBU='N') * MAXWRK = N + LWORK_DGEQRF MAXWRK = MAX( MAXWRK, 3*N + LWORK_DGEBRD ) IF( WNTVO .OR. WNTVAS ) $ MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORGBR_P ) MAXWRK = MAX( MAXWRK, BDSPAC ) MINWRK = MAX( 4*N, BDSPAC ) ELSE IF( WNTUO .AND. WNTVN ) THEN * * Path 2 (M much larger than N, JOBU='O', JOBVT='N') * WRKBL = N + LWORK_DGEQRF WRKBL = MAX( WRKBL, N + LWORK_DORGQR_N ) WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD ) WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = MAX( N*N + WRKBL, N*N + M*N + N ) MINWRK = MAX( 3*N + M, BDSPAC ) ELSE IF( WNTUO .AND. WNTVAS ) THEN * * Path 3 (M much larger than N, JOBU='O', JOBVT='S' or * 'A') * WRKBL = N + LWORK_DGEQRF WRKBL = MAX( WRKBL, N + LWORK_DORGQR_N ) WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD ) WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q ) WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_P ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = MAX( N*N + WRKBL, N*N + M*N + N ) MINWRK = MAX( 3*N + M, BDSPAC ) ELSE IF( WNTUS .AND. WNTVN ) THEN * * Path 4 (M much larger than N, JOBU='S', JOBVT='N') * WRKBL = N + LWORK_DGEQRF WRKBL = MAX( WRKBL, N + LWORK_DORGQR_N ) WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD ) WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = N*N + WRKBL MINWRK = MAX( 3*N + M, BDSPAC ) ELSE IF( WNTUS .AND. WNTVO ) THEN * * Path 5 (M much larger than N, JOBU='S', JOBVT='O') * WRKBL = N + LWORK_DGEQRF WRKBL = MAX( WRKBL, N + LWORK_DORGQR_N ) WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD ) WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q ) WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_P ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = 2*N*N + WRKBL MINWRK = MAX( 3*N + M, BDSPAC ) ELSE IF( WNTUS .AND. WNTVAS ) THEN * * Path 6 (M much larger than N, JOBU='S', JOBVT='S' or * 'A') * WRKBL = N + LWORK_DGEQRF WRKBL = MAX( WRKBL, N + LWORK_DORGQR_N ) WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD ) WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q ) WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_P ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = N*N + WRKBL MINWRK = MAX( 3*N + M, BDSPAC ) ELSE IF( WNTUA .AND. WNTVN ) THEN * * Path 7 (M much larger than N, JOBU='A', JOBVT='N') * WRKBL = N + LWORK_DGEQRF WRKBL = MAX( WRKBL, N + LWORK_DORGQR_M ) WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD ) WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = N*N + WRKBL MINWRK = MAX( 3*N + M, BDSPAC ) ELSE IF( WNTUA .AND. WNTVO ) THEN * * Path 8 (M much larger than N, JOBU='A', JOBVT='O') * WRKBL = N + LWORK_DGEQRF WRKBL = MAX( WRKBL, N + LWORK_DORGQR_M ) WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD ) WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q ) WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_P ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = 2*N*N + WRKBL MINWRK = MAX( 3*N + M, BDSPAC ) ELSE IF( WNTUA .AND. WNTVAS ) THEN * * Path 9 (M much larger than N, JOBU='A', JOBVT='S' or * 'A') * WRKBL = N + LWORK_DGEQRF WRKBL = MAX( WRKBL, N + LWORK_DORGQR_M ) WRKBL = MAX( WRKBL, 3*N + LWORK_DGEBRD ) WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_Q ) WRKBL = MAX( WRKBL, 3*N + LWORK_DORGBR_P ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = N*N + WRKBL MINWRK = MAX( 3*N + M, BDSPAC ) END IF ELSE * * Path 10 (M at least N, but not much larger) * CALL DGEBRD( M, N, A, LDA, S, DUM(1), DUM(1), $ DUM(1), DUM(1), -1, IERR ) LWORK_DGEBRD = INT( DUM(1) ) MAXWRK = 3*N + LWORK_DGEBRD IF( WNTUS .OR. WNTUO ) THEN CALL DORGBR( 'Q', M, N, N, A, LDA, DUM(1), $ DUM(1), -1, IERR ) LWORK_DORGBR_Q = INT( DUM(1) ) MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORGBR_Q ) END IF IF( WNTUA ) THEN CALL DORGBR( 'Q', M, M, N, A, LDA, DUM(1), $ DUM(1), -1, IERR ) LWORK_DORGBR_Q = INT( DUM(1) ) MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORGBR_Q ) END IF IF( .NOT.WNTVN ) THEN MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORGBR_P ) END IF MAXWRK = MAX( MAXWRK, BDSPAC ) MINWRK = MAX( 3*N + M, BDSPAC ) END IF ELSE IF( MINMN.GT.0 ) THEN * * Compute space needed for DBDSQR * MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 ) BDSPAC = 5*M * Compute space needed for DGELQF CALL DGELQF( M, N, A, LDA, DUM(1), DUM(1), -1, IERR ) LWORK_DGELQF = INT( DUM(1) ) * Compute space needed for DORGLQ CALL DORGLQ( N, N, M, DUM(1), N, DUM(1), DUM(1), -1, IERR ) LWORK_DORGLQ_N = INT( DUM(1) ) CALL DORGLQ( M, N, M, A, LDA, DUM(1), DUM(1), -1, IERR ) LWORK_DORGLQ_M = INT( DUM(1) ) * Compute space needed for DGEBRD CALL DGEBRD( M, M, A, LDA, S, DUM(1), DUM(1), $ DUM(1), DUM(1), -1, IERR ) LWORK_DGEBRD = INT( DUM(1) ) * Compute space needed for DORGBR P CALL DORGBR( 'P', M, M, M, A, N, DUM(1), $ DUM(1), -1, IERR ) LWORK_DORGBR_P = INT( DUM(1) ) * Compute space needed for DORGBR Q CALL DORGBR( 'Q', M, M, M, A, N, DUM(1), $ DUM(1), -1, IERR ) LWORK_DORGBR_Q = INT( DUM(1) ) IF( N.GE.MNTHR ) THEN IF( WNTVN ) THEN * * Path 1t(N much larger than M, JOBVT='N') * MAXWRK = M + LWORK_DGELQF MAXWRK = MAX( MAXWRK, 3*M + LWORK_DGEBRD ) IF( WNTUO .OR. WNTUAS ) $ MAXWRK = MAX( MAXWRK, 3*M + LWORK_DORGBR_Q ) MAXWRK = MAX( MAXWRK, BDSPAC ) MINWRK = MAX( 4*M, BDSPAC ) ELSE IF( WNTVO .AND. WNTUN ) THEN * * Path 2t(N much larger than M, JOBU='N', JOBVT='O') * WRKBL = M + LWORK_DGELQF WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_M ) WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD ) WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = MAX( M*M + WRKBL, M*M + M*N + M ) MINWRK = MAX( 3*M + N, BDSPAC ) ELSE IF( WNTVO .AND. WNTUAS ) THEN * * Path 3t(N much larger than M, JOBU='S' or 'A', * JOBVT='O') * WRKBL = M + LWORK_DGELQF WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_M ) WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD ) WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P ) WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_Q ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = MAX( M*M + WRKBL, M*M + M*N + M ) MINWRK = MAX( 3*M + N, BDSPAC ) ELSE IF( WNTVS .AND. WNTUN ) THEN * * Path 4t(N much larger than M, JOBU='N', JOBVT='S') * WRKBL = M + LWORK_DGELQF WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_M ) WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD ) WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = M*M + WRKBL MINWRK = MAX( 3*M + N, BDSPAC ) ELSE IF( WNTVS .AND. WNTUO ) THEN * * Path 5t(N much larger than M, JOBU='O', JOBVT='S') * WRKBL = M + LWORK_DGELQF WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_M ) WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD ) WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P ) WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_Q ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = 2*M*M + WRKBL MINWRK = MAX( 3*M + N, BDSPAC ) ELSE IF( WNTVS .AND. WNTUAS ) THEN * * Path 6t(N much larger than M, JOBU='S' or 'A', * JOBVT='S') * WRKBL = M + LWORK_DGELQF WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_M ) WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD ) WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P ) WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_Q ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = M*M + WRKBL MINWRK = MAX( 3*M + N, BDSPAC ) ELSE IF( WNTVA .AND. WNTUN ) THEN * * Path 7t(N much larger than M, JOBU='N', JOBVT='A') * WRKBL = M + LWORK_DGELQF WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_N ) WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD ) WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = M*M + WRKBL MINWRK = MAX( 3*M + N, BDSPAC ) ELSE IF( WNTVA .AND. WNTUO ) THEN * * Path 8t(N much larger than M, JOBU='O', JOBVT='A') * WRKBL = M + LWORK_DGELQF WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_N ) WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD ) WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P ) WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_Q ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = 2*M*M + WRKBL MINWRK = MAX( 3*M + N, BDSPAC ) ELSE IF( WNTVA .AND. WNTUAS ) THEN * * Path 9t(N much larger than M, JOBU='S' or 'A', * JOBVT='A') * WRKBL = M + LWORK_DGELQF WRKBL = MAX( WRKBL, M + LWORK_DORGLQ_N ) WRKBL = MAX( WRKBL, 3*M + LWORK_DGEBRD ) WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_P ) WRKBL = MAX( WRKBL, 3*M + LWORK_DORGBR_Q ) WRKBL = MAX( WRKBL, BDSPAC ) MAXWRK = M*M + WRKBL MINWRK = MAX( 3*M + N, BDSPAC ) END IF ELSE * * Path 10t(N greater than M, but not much larger) * CALL DGEBRD( M, N, A, LDA, S, DUM(1), DUM(1), $ DUM(1), DUM(1), -1, IERR ) LWORK_DGEBRD = INT( DUM(1) ) MAXWRK = 3*M + LWORK_DGEBRD IF( WNTVS .OR. WNTVO ) THEN * Compute space needed for DORGBR P CALL DORGBR( 'P', M, N, M, A, N, DUM(1), $ DUM(1), -1, IERR ) LWORK_DORGBR_P = INT( DUM(1) ) MAXWRK = MAX( MAXWRK, 3*M + LWORK_DORGBR_P ) END IF IF( WNTVA ) THEN CALL DORGBR( 'P', N, N, M, A, N, DUM(1), $ DUM(1), -1, IERR ) LWORK_DORGBR_P = INT( DUM(1) ) MAXWRK = MAX( MAXWRK, 3*M + LWORK_DORGBR_P ) END IF IF( .NOT.WNTUN ) THEN MAXWRK = MAX( MAXWRK, 3*M + LWORK_DORGBR_Q ) END IF MAXWRK = MAX( MAXWRK, BDSPAC ) MINWRK = MAX( 3*M + N, BDSPAC ) END IF END IF MAXWRK = MAX( MAXWRK, MINWRK ) WORK( 1 ) = MAXWRK * IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN INFO = -13 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGESVD', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) THEN RETURN END IF * * Get machine constants * EPS = DLAMCH( 'P' ) SMLNUM = SQRT( DLAMCH( 'S' ) ) / EPS BIGNUM = ONE / SMLNUM * * Scale A if max element outside range [SMLNUM,BIGNUM] * ANRM = DLANGE( 'M', M, N, A, LDA, DUM ) ISCL = 0 IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN ISCL = 1 CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR ) ELSE IF( ANRM.GT.BIGNUM ) THEN ISCL = 1 CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR ) END IF * IF( M.GE.N ) THEN * * A has at least as many rows as columns. If A has sufficiently * more rows than columns, first reduce using the QR * decomposition (if sufficient workspace available) * IF( M.GE.MNTHR ) THEN * IF( WNTUN ) THEN * * Path 1 (M much larger than N, JOBU='N') * No left singular vectors to be computed * ITAU = 1 IWORK = ITAU + N * * Compute A=Q*R * (Workspace: need 2*N, prefer N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Zero out below R * IF( N .GT. 1 ) THEN CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), $ LDA ) END IF IE = 1 ITAUQ = IE + N ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize R in A * (Workspace: need 4*N, prefer 3*N + 2*N*NB) * CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, $ IERR ) NCVT = 0 IF( WNTVO .OR. WNTVAS ) THEN * * If right singular vectors desired, generate P'. * (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) * CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) NCVT = N END IF IWORK = IE + N * * Perform bidiagonal QR iteration, computing right * singular vectors of A in A if desired * (Workspace: need BDSPAC) * CALL DBDSQR( 'U', N, NCVT, 0, 0, S, WORK( IE ), A, LDA, $ DUM, 1, DUM, 1, WORK( IWORK ), INFO ) * * If right singular vectors desired in VT, copy them there * IF( WNTVAS ) $ CALL DLACPY( 'F', N, N, A, LDA, VT, LDVT ) * ELSE IF( WNTUO .AND. WNTVN ) THEN * * Path 2 (M much larger than N, JOBU='O', JOBVT='N') * N left singular vectors to be overwritten on A and * no right singular vectors to be computed * IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN * * Sufficient workspace for a fast algorithm * IR = 1 IF( LWORK.GE.MAX( WRKBL, LDA*N + N ) + LDA*N ) THEN * * WORK(IU) is LDA by N, WORK(IR) is LDA by N * LDWRKU = LDA LDWRKR = LDA ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N + N ) + N*N ) THEN * * WORK(IU) is LDA by N, WORK(IR) is N by N * LDWRKU = LDA LDWRKR = N ELSE * * WORK(IU) is LDWRKU by N, WORK(IR) is N by N * LDWRKU = ( LWORK-N*N-N ) / N LDWRKR = N END IF ITAU = IR + LDWRKR*N IWORK = ITAU + N * * Compute A=Q*R * (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy R to WORK(IR) and zero out below it * CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR ) CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ), $ LDWRKR ) * * Generate Q in A * (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) * CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = ITAU ITAUQ = IE + N ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize R in WORK(IR) * (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB) * CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate left vectors bidiagonalizing R * (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB) * CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IR) * (Workspace: need N*N + BDSPAC) * CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM, 1, $ WORK( IR ), LDWRKR, DUM, 1, $ WORK( IWORK ), INFO ) IU = IE + N * * Multiply Q in A by left singular vectors of R in * WORK(IR), storing result in WORK(IU) and copying to A * (Workspace: need N*N + 2*N, prefer N*N + M*N + N) * DO 10 I = 1, M, LDWRKU CHUNK = MIN( M-I+1, LDWRKU ) CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ), $ LDA, WORK( IR ), LDWRKR, ZERO, $ WORK( IU ), LDWRKU ) CALL DLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU, $ A( I, 1 ), LDA ) 10 CONTINUE * ELSE * * Insufficient workspace for a fast algorithm * IE = 1 ITAUQ = IE + N ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize A * (Workspace: need 3*N + M, prefer 3*N + (M + N)*NB) * CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate left vectors bidiagonalizing A * (Workspace: need 4*N, prefer 3*N + N*NB) * CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of A in A * (Workspace: need BDSPAC) * CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM, 1, $ A, LDA, DUM, 1, WORK( IWORK ), INFO ) * END IF * ELSE IF( WNTUO .AND. WNTVAS ) THEN * * Path 3 (M much larger than N, JOBU='O', JOBVT='S' or 'A') * N left singular vectors to be overwritten on A and * N right singular vectors to be computed in VT * IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN * * Sufficient workspace for a fast algorithm * IR = 1 IF( LWORK.GE.MAX( WRKBL, LDA*N + N ) + LDA*N ) THEN * * WORK(IU) is LDA by N and WORK(IR) is LDA by N * LDWRKU = LDA LDWRKR = LDA ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N + N ) + N*N ) THEN * * WORK(IU) is LDA by N and WORK(IR) is N by N * LDWRKU = LDA LDWRKR = N ELSE * * WORK(IU) is LDWRKU by N and WORK(IR) is N by N * LDWRKU = ( LWORK-N*N-N ) / N LDWRKR = N END IF ITAU = IR + LDWRKR*N IWORK = ITAU + N * * Compute A=Q*R * (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy R to VT, zeroing out below it * CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) IF( N.GT.1 ) $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, $ VT( 2, 1 ), LDVT ) * * Generate Q in A * (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) * CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = ITAU ITAUQ = IE + N ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize R in VT, copying result to WORK(IR) * (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB) * CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'L', N, N, VT, LDVT, WORK( IR ), LDWRKR ) * * Generate left vectors bidiagonalizing R in WORK(IR) * (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB) * CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right vectors bidiagonalizing R in VT * (Workspace: need N*N + 4*N-1, prefer N*N + 3*N + (N-1)*NB) * CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IR) and computing right * singular vectors of R in VT * (Workspace: need N*N + BDSPAC) * CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT, LDVT, $ WORK( IR ), LDWRKR, DUM, 1, $ WORK( IWORK ), INFO ) IU = IE + N * * Multiply Q in A by left singular vectors of R in * WORK(IR), storing result in WORK(IU) and copying to A * (Workspace: need N*N + 2*N, prefer N*N + M*N + N) * DO 20 I = 1, M, LDWRKU CHUNK = MIN( M-I+1, LDWRKU ) CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ), $ LDA, WORK( IR ), LDWRKR, ZERO, $ WORK( IU ), LDWRKU ) CALL DLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU, $ A( I, 1 ), LDA ) 20 CONTINUE * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + N * * Compute A=Q*R * (Workspace: need 2*N, prefer N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy R to VT, zeroing out below it * CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) IF( N.GT.1 ) $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, $ VT( 2, 1 ), LDVT ) * * Generate Q in A * (Workspace: need 2*N, prefer N + N*NB) * CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = ITAU ITAUQ = IE + N ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize R in VT * (Workspace: need 4*N, prefer 3*N + 2*N*NB) * CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply Q in A by left vectors bidiagonalizing R * (Workspace: need 3*N + M, prefer 3*N + M*NB) * CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, $ WORK( ITAUQ ), A, LDA, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right vectors bidiagonalizing R in VT * (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) * CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of A in A and computing right * singular vectors of A in VT * (Workspace: need BDSPAC) * CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT, LDVT, $ A, LDA, DUM, 1, WORK( IWORK ), INFO ) * END IF * ELSE IF( WNTUS ) THEN * IF( WNTVN ) THEN * * Path 4 (M much larger than N, JOBU='S', JOBVT='N') * N left singular vectors to be computed in U and * no right singular vectors to be computed * IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN * * Sufficient workspace for a fast algorithm * IR = 1 IF( LWORK.GE.WRKBL+LDA*N ) THEN * * WORK(IR) is LDA by N * LDWRKR = LDA ELSE * * WORK(IR) is N by N * LDWRKR = N END IF ITAU = IR + LDWRKR*N IWORK = ITAU + N * * Compute A=Q*R * (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy R to WORK(IR), zeroing out below it * CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), $ LDWRKR ) CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, $ WORK( IR+1 ), LDWRKR ) * * Generate Q in A * (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) * CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = ITAU ITAUQ = IE + N ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize R in WORK(IR) * (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB) * CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, $ WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate left vectors bidiagonalizing R in WORK(IR) * (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB) * CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IR) * (Workspace: need N*N + BDSPAC) * CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM, $ 1, WORK( IR ), LDWRKR, DUM, 1, $ WORK( IWORK ), INFO ) * * Multiply Q in A by left singular vectors of R in * WORK(IR), storing result in U * (Workspace: need N*N) * CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA, $ WORK( IR ), LDWRKR, ZERO, U, LDU ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + N * * Compute A=Q*R, copying result to U * (Workspace: need 2*N, prefer N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U * (Workspace: need 2*N, prefer N + N*NB) * CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = ITAU ITAUQ = IE + N ITAUP = ITAUQ + N IWORK = ITAUP + N * * Zero out below R in A * IF( N .GT. 1 ) THEN CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, $ A( 2, 1 ), LDA ) END IF * * Bidiagonalize R in A * (Workspace: need 4*N, prefer 3*N + 2*N*NB) * CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply Q in U by left vectors bidiagonalizing R * (Workspace: need 3*N + M, prefer 3*N + M*NB) * CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of A in U * (Workspace: need BDSPAC) * CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM, $ 1, U, LDU, DUM, 1, WORK( IWORK ), $ INFO ) * END IF * ELSE IF( WNTVO ) THEN * * Path 5 (M much larger than N, JOBU='S', JOBVT='O') * N left singular vectors to be computed in U and * N right singular vectors to be overwritten on A * IF( LWORK.GE.2*N*N+MAX( 4*N, BDSPAC ) ) THEN * * Sufficient workspace for a fast algorithm * IU = 1 IF( LWORK.GE.WRKBL+2*LDA*N ) THEN * * WORK(IU) is LDA by N and WORK(IR) is LDA by N * LDWRKU = LDA IR = IU + LDWRKU*N LDWRKR = LDA ELSE IF( LWORK.GE.WRKBL+( LDA + N )*N ) THEN * * WORK(IU) is LDA by N and WORK(IR) is N by N * LDWRKU = LDA IR = IU + LDWRKU*N LDWRKR = N ELSE * * WORK(IU) is N by N and WORK(IR) is N by N * LDWRKU = N IR = IU + LDWRKU*N LDWRKR = N END IF ITAU = IR + LDWRKR*N IWORK = ITAU + N * * Compute A=Q*R * (Workspace: need 2*N*N + 2*N, prefer 2*N*N + N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy R to WORK(IU), zeroing out below it * CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ), $ LDWRKU ) CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, $ WORK( IU+1 ), LDWRKU ) * * Generate Q in A * (Workspace: need 2*N*N + 2*N, prefer 2*N*N + N + N*NB) * CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = ITAU ITAUQ = IE + N ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize R in WORK(IU), copying result to * WORK(IR) * (Workspace: need 2*N*N + 4*N, * prefer 2*N*N+3*N+2*N*NB) * CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S, $ WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU, $ WORK( IR ), LDWRKR ) * * Generate left bidiagonalizing vectors in WORK(IU) * (Workspace: need 2*N*N + 4*N, prefer 2*N*N + 3*N + N*NB) * CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in WORK(IR) * (Workspace: need 2*N*N + 4*N-1, * prefer 2*N*N+3*N+(N-1)*NB) * CALL DORGBR( 'P', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IU) and computing * right singular vectors of R in WORK(IR) * (Workspace: need 2*N*N + BDSPAC) * CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), $ WORK( IR ), LDWRKR, WORK( IU ), $ LDWRKU, DUM, 1, WORK( IWORK ), INFO ) * * Multiply Q in A by left singular vectors of R in * WORK(IU), storing result in U * (Workspace: need N*N) * CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA, $ WORK( IU ), LDWRKU, ZERO, U, LDU ) * * Copy right singular vectors of R to A * (Workspace: need N*N) * CALL DLACPY( 'F', N, N, WORK( IR ), LDWRKR, A, $ LDA ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + N * * Compute A=Q*R, copying result to U * (Workspace: need 2*N, prefer N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U * (Workspace: need 2*N, prefer N + N*NB) * CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = ITAU ITAUQ = IE + N ITAUP = ITAUQ + N IWORK = ITAUP + N * * Zero out below R in A * IF( N .GT. 1 ) THEN CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, $ A( 2, 1 ), LDA ) END IF * * Bidiagonalize R in A * (Workspace: need 4*N, prefer 3*N + 2*N*NB) * CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply Q in U by left vectors bidiagonalizing R * (Workspace: need 3*N + M, prefer 3*N + M*NB) * CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right vectors bidiagonalizing R in A * (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) * CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of A in U and computing right * singular vectors of A in A * (Workspace: need BDSPAC) * CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), A, $ LDA, U, LDU, DUM, 1, WORK( IWORK ), $ INFO ) * END IF * ELSE IF( WNTVAS ) THEN * * Path 6 (M much larger than N, JOBU='S', JOBVT='S' * or 'A') * N left singular vectors to be computed in U and * N right singular vectors to be computed in VT * IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN * * Sufficient workspace for a fast algorithm * IU = 1 IF( LWORK.GE.WRKBL+LDA*N ) THEN * * WORK(IU) is LDA by N * LDWRKU = LDA ELSE * * WORK(IU) is N by N * LDWRKU = N END IF ITAU = IU + LDWRKU*N IWORK = ITAU + N * * Compute A=Q*R * (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy R to WORK(IU), zeroing out below it * CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ), $ LDWRKU ) CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, $ WORK( IU+1 ), LDWRKU ) * * Generate Q in A * (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) * CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = ITAU ITAUQ = IE + N ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize R in WORK(IU), copying result to VT * (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB) * CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S, $ WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT, $ LDVT ) * * Generate left bidiagonalizing vectors in WORK(IU) * (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB) * CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in VT * (Workspace: need N*N + 4*N-1, * prefer N*N+3*N+(N-1)*NB) * CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IU) and computing * right singular vectors of R in VT * (Workspace: need N*N + BDSPAC) * CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT, $ LDVT, WORK( IU ), LDWRKU, DUM, 1, $ WORK( IWORK ), INFO ) * * Multiply Q in A by left singular vectors of R in * WORK(IU), storing result in U * (Workspace: need N*N) * CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA, $ WORK( IU ), LDWRKU, ZERO, U, LDU ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + N * * Compute A=Q*R, copying result to U * (Workspace: need 2*N, prefer N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U * (Workspace: need 2*N, prefer N + N*NB) * CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy R to VT, zeroing out below it * CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) IF( N.GT.1 ) $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, $ VT( 2, 1 ), LDVT ) IE = ITAU ITAUQ = IE + N ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize R in VT * (Workspace: need 4*N, prefer 3*N + 2*N*NB) * CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply Q in U by left bidiagonalizing vectors * in VT * (Workspace: need 3*N + M, prefer 3*N + M*NB) * CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in VT * (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) * CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of A in U and computing right * singular vectors of A in VT * (Workspace: need BDSPAC) * CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT, $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), $ INFO ) * END IF * END IF * ELSE IF( WNTUA ) THEN * IF( WNTVN ) THEN * * Path 7 (M much larger than N, JOBU='A', JOBVT='N') * M left singular vectors to be computed in U and * no right singular vectors to be computed * IF( LWORK.GE.N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN * * Sufficient workspace for a fast algorithm * IR = 1 IF( LWORK.GE.WRKBL+LDA*N ) THEN * * WORK(IR) is LDA by N * LDWRKR = LDA ELSE * * WORK(IR) is N by N * LDWRKR = N END IF ITAU = IR + LDWRKR*N IWORK = ITAU + N * * Compute A=Q*R, copying result to U * (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) * * Copy R to WORK(IR), zeroing out below it * CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), $ LDWRKR ) CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, $ WORK( IR+1 ), LDWRKR ) * * Generate Q in U * (Workspace: need N*N + N + M, prefer N*N + N + M*NB) * CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = ITAU ITAUQ = IE + N ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize R in WORK(IR) * (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB) * CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, $ WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in WORK(IR) * (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB) * CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IR) * (Workspace: need N*N + BDSPAC) * CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM, $ 1, WORK( IR ), LDWRKR, DUM, 1, $ WORK( IWORK ), INFO ) * * Multiply Q in U by left singular vectors of R in * WORK(IR), storing result in A * (Workspace: need N*N) * CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU, $ WORK( IR ), LDWRKR, ZERO, A, LDA ) * * Copy left singular vectors of A from A to U * CALL DLACPY( 'F', M, N, A, LDA, U, LDU ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + N * * Compute A=Q*R, copying result to U * (Workspace: need 2*N, prefer N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U * (Workspace: need N + M, prefer N + M*NB) * CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = ITAU ITAUQ = IE + N ITAUP = ITAUQ + N IWORK = ITAUP + N * * Zero out below R in A * IF( N .GT. 1 ) THEN CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, $ A( 2, 1 ), LDA ) END IF * * Bidiagonalize R in A * (Workspace: need 4*N, prefer 3*N + 2*N*NB) * CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply Q in U by left bidiagonalizing vectors * in A * (Workspace: need 3*N + M, prefer 3*N + M*NB) * CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of A in U * (Workspace: need BDSPAC) * CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM, $ 1, U, LDU, DUM, 1, WORK( IWORK ), $ INFO ) * END IF * ELSE IF( WNTVO ) THEN * * Path 8 (M much larger than N, JOBU='A', JOBVT='O') * M left singular vectors to be computed in U and * N right singular vectors to be overwritten on A * IF( LWORK.GE.2*N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN * * Sufficient workspace for a fast algorithm * IU = 1 IF( LWORK.GE.WRKBL+2*LDA*N ) THEN * * WORK(IU) is LDA by N and WORK(IR) is LDA by N * LDWRKU = LDA IR = IU + LDWRKU*N LDWRKR = LDA ELSE IF( LWORK.GE.WRKBL+( LDA + N )*N ) THEN * * WORK(IU) is LDA by N and WORK(IR) is N by N * LDWRKU = LDA IR = IU + LDWRKU*N LDWRKR = N ELSE * * WORK(IU) is N by N and WORK(IR) is N by N * LDWRKU = N IR = IU + LDWRKU*N LDWRKR = N END IF ITAU = IR + LDWRKR*N IWORK = ITAU + N * * Compute A=Q*R, copying result to U * (Workspace: need 2*N*N + 2*N, prefer 2*N*N + N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U * (Workspace: need 2*N*N + N + M, prefer 2*N*N + N + M*NB) * CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy R to WORK(IU), zeroing out below it * CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ), $ LDWRKU ) CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, $ WORK( IU+1 ), LDWRKU ) IE = ITAU ITAUQ = IE + N ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize R in WORK(IU), copying result to * WORK(IR) * (Workspace: need 2*N*N + 4*N, * prefer 2*N*N+3*N+2*N*NB) * CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S, $ WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU, $ WORK( IR ), LDWRKR ) * * Generate left bidiagonalizing vectors in WORK(IU) * (Workspace: need 2*N*N + 4*N, prefer 2*N*N + 3*N + N*NB) * CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in WORK(IR) * (Workspace: need 2*N*N + 4*N-1, * prefer 2*N*N+3*N+(N-1)*NB) * CALL DORGBR( 'P', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IU) and computing * right singular vectors of R in WORK(IR) * (Workspace: need 2*N*N + BDSPAC) * CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), $ WORK( IR ), LDWRKR, WORK( IU ), $ LDWRKU, DUM, 1, WORK( IWORK ), INFO ) * * Multiply Q in U by left singular vectors of R in * WORK(IU), storing result in A * (Workspace: need N*N) * CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU, $ WORK( IU ), LDWRKU, ZERO, A, LDA ) * * Copy left singular vectors of A from A to U * CALL DLACPY( 'F', M, N, A, LDA, U, LDU ) * * Copy right singular vectors of R from WORK(IR) to A * CALL DLACPY( 'F', N, N, WORK( IR ), LDWRKR, A, $ LDA ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + N * * Compute A=Q*R, copying result to U * (Workspace: need 2*N, prefer N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U * (Workspace: need N + M, prefer N + M*NB) * CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = ITAU ITAUQ = IE + N ITAUP = ITAUQ + N IWORK = ITAUP + N * * Zero out below R in A * IF( N .GT. 1 ) THEN CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, $ A( 2, 1 ), LDA ) END IF * * Bidiagonalize R in A * (Workspace: need 4*N, prefer 3*N + 2*N*NB) * CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply Q in U by left bidiagonalizing vectors * in A * (Workspace: need 3*N + M, prefer 3*N + M*NB) * CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in A * (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) * CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of A in U and computing right * singular vectors of A in A * (Workspace: need BDSPAC) * CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), A, $ LDA, U, LDU, DUM, 1, WORK( IWORK ), $ INFO ) * END IF * ELSE IF( WNTVAS ) THEN * * Path 9 (M much larger than N, JOBU='A', JOBVT='S' * or 'A') * M left singular vectors to be computed in U and * N right singular vectors to be computed in VT * IF( LWORK.GE.N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN * * Sufficient workspace for a fast algorithm * IU = 1 IF( LWORK.GE.WRKBL+LDA*N ) THEN * * WORK(IU) is LDA by N * LDWRKU = LDA ELSE * * WORK(IU) is N by N * LDWRKU = N END IF ITAU = IU + LDWRKU*N IWORK = ITAU + N * * Compute A=Q*R, copying result to U * (Workspace: need N*N + 2*N, prefer N*N + N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U * (Workspace: need N*N + N + M, prefer N*N + N + M*NB) * CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy R to WORK(IU), zeroing out below it * CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ), $ LDWRKU ) CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, $ WORK( IU+1 ), LDWRKU ) IE = ITAU ITAUQ = IE + N ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize R in WORK(IU), copying result to VT * (Workspace: need N*N + 4*N, prefer N*N + 3*N + 2*N*NB) * CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S, $ WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT, $ LDVT ) * * Generate left bidiagonalizing vectors in WORK(IU) * (Workspace: need N*N + 4*N, prefer N*N + 3*N + N*NB) * CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in VT * (Workspace: need N*N + 4*N-1, * prefer N*N+3*N+(N-1)*NB) * CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IU) and computing * right singular vectors of R in VT * (Workspace: need N*N + BDSPAC) * CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT, $ LDVT, WORK( IU ), LDWRKU, DUM, 1, $ WORK( IWORK ), INFO ) * * Multiply Q in U by left singular vectors of R in * WORK(IU), storing result in A * (Workspace: need N*N) * CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU, $ WORK( IU ), LDWRKU, ZERO, A, LDA ) * * Copy left singular vectors of A from A to U * CALL DLACPY( 'F', M, N, A, LDA, U, LDU ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + N * * Compute A=Q*R, copying result to U * (Workspace: need 2*N, prefer N + N*NB) * CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U * (Workspace: need N + M, prefer N + M*NB) * CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy R from A to VT, zeroing out below it * CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) IF( N.GT.1 ) $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, $ VT( 2, 1 ), LDVT ) IE = ITAU ITAUQ = IE + N ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize R in VT * (Workspace: need 4*N, prefer 3*N + 2*N*NB) * CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply Q in U by left bidiagonalizing vectors * in VT * (Workspace: need 3*N + M, prefer 3*N + M*NB) * CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in VT * (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) * CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of A in U and computing right * singular vectors of A in VT * (Workspace: need BDSPAC) * CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT, $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), $ INFO ) * END IF * END IF * END IF * ELSE * * M .LT. MNTHR * * Path 10 (M at least N, but not much larger) * Reduce to bidiagonal form without QR decomposition * IE = 1 ITAUQ = IE + N ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize A * (Workspace: need 3*N + M, prefer 3*N + (M + N)*NB) * CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, $ IERR ) IF( WNTUAS ) THEN * * If left singular vectors desired in U, copy result to U * and generate left bidiagonalizing vectors in U * (Workspace: need 3*N + NCU, prefer 3*N + NCU*NB) * CALL DLACPY( 'L', M, N, A, LDA, U, LDU ) IF( WNTUS ) $ NCU = N IF( WNTUA ) $ NCU = M CALL DORGBR( 'Q', M, NCU, N, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) END IF IF( WNTVAS ) THEN * * If right singular vectors desired in VT, copy result to * VT and generate right bidiagonalizing vectors in VT * (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) * CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT ) CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) END IF IF( WNTUO ) THEN * * If left singular vectors desired in A, generate left * bidiagonalizing vectors in A * (Workspace: need 4*N, prefer 3*N + N*NB) * CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) END IF IF( WNTVO ) THEN * * If right singular vectors desired in A, generate right * bidiagonalizing vectors in A * (Workspace: need 4*N-1, prefer 3*N + (N-1)*NB) * CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) END IF IWORK = IE + N IF( WNTUAS .OR. WNTUO ) $ NRU = M IF( WNTUN ) $ NRU = 0 IF( WNTVAS .OR. WNTVO ) $ NCVT = N IF( WNTVN ) $ NCVT = 0 IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN * * Perform bidiagonal QR iteration, if desired, computing * left singular vectors in U and computing right singular * vectors in VT * (Workspace: need BDSPAC) * CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), VT, $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), INFO ) ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN * * Perform bidiagonal QR iteration, if desired, computing * left singular vectors in U and computing right singular * vectors in A * (Workspace: need BDSPAC) * CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), A, LDA, $ U, LDU, DUM, 1, WORK( IWORK ), INFO ) ELSE * * Perform bidiagonal QR iteration, if desired, computing * left singular vectors in A and computing right singular * vectors in VT * (Workspace: need BDSPAC) * CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), VT, $ LDVT, A, LDA, DUM, 1, WORK( IWORK ), INFO ) END IF * END IF * ELSE * * A has more columns than rows. If A has sufficiently more * columns than rows, first reduce using the LQ decomposition (if * sufficient workspace available) * IF( N.GE.MNTHR ) THEN * IF( WNTVN ) THEN * * Path 1t(N much larger than M, JOBVT='N') * No right singular vectors to be computed * ITAU = 1 IWORK = ITAU + M * * Compute A=L*Q * (Workspace: need 2*M, prefer M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Zero out above L * CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA ) IE = 1 ITAUQ = IE + M ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize L in A * (Workspace: need 4*M, prefer 3*M + 2*M*NB) * CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, $ IERR ) IF( WNTUO .OR. WNTUAS ) THEN * * If left singular vectors desired, generate Q * (Workspace: need 4*M, prefer 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) END IF IWORK = IE + M NRU = 0 IF( WNTUO .OR. WNTUAS ) $ NRU = M * * Perform bidiagonal QR iteration, computing left singular * vectors of A in A if desired * (Workspace: need BDSPAC) * CALL DBDSQR( 'U', M, 0, NRU, 0, S, WORK( IE ), DUM, 1, A, $ LDA, DUM, 1, WORK( IWORK ), INFO ) * * If left singular vectors desired in U, copy them there * IF( WNTUAS ) $ CALL DLACPY( 'F', M, M, A, LDA, U, LDU ) * ELSE IF( WNTVO .AND. WNTUN ) THEN * * Path 2t(N much larger than M, JOBU='N', JOBVT='O') * M right singular vectors to be overwritten on A and * no left singular vectors to be computed * IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN * * Sufficient workspace for a fast algorithm * IR = 1 IF( LWORK.GE.MAX( WRKBL, LDA*N + M ) + LDA*M ) THEN * * WORK(IU) is LDA by N and WORK(IR) is LDA by M * LDWRKU = LDA CHUNK = N LDWRKR = LDA ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N + M ) + M*M ) THEN * * WORK(IU) is LDA by N and WORK(IR) is M by M * LDWRKU = LDA CHUNK = N LDWRKR = M ELSE * * WORK(IU) is M by CHUNK and WORK(IR) is M by M * LDWRKU = M CHUNK = ( LWORK-M*M-M ) / M LDWRKR = M END IF ITAU = IR + LDWRKR*M IWORK = ITAU + M * * Compute A=L*Q * (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy L to WORK(IR) and zero out above it * CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ), LDWRKR ) CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, $ WORK( IR+LDWRKR ), LDWRKR ) * * Generate Q in A * (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) * CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = ITAU ITAUQ = IE + M ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize L in WORK(IR) * (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB) * CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate right vectors bidiagonalizing L * (Workspace: need M*M + 4*M-1, prefer M*M + 3*M + (M-1)*NB) * CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IWORK = IE + M * * Perform bidiagonal QR iteration, computing right * singular vectors of L in WORK(IR) * (Workspace: need M*M + BDSPAC) * CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ), $ WORK( IR ), LDWRKR, DUM, 1, DUM, 1, $ WORK( IWORK ), INFO ) IU = IE + M * * Multiply right singular vectors of L in WORK(IR) by Q * in A, storing result in WORK(IU) and copying to A * (Workspace: need M*M + 2*M, prefer M*M + M*N + M) * DO 30 I = 1, N, CHUNK BLK = MIN( N-I+1, CHUNK ) CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IR ), $ LDWRKR, A( 1, I ), LDA, ZERO, $ WORK( IU ), LDWRKU ) CALL DLACPY( 'F', M, BLK, WORK( IU ), LDWRKU, $ A( 1, I ), LDA ) 30 CONTINUE * ELSE * * Insufficient workspace for a fast algorithm * IE = 1 ITAUQ = IE + M ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize A * (Workspace: need 3*M + N, prefer 3*M + (M + N)*NB) * CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate right vectors bidiagonalizing A * (Workspace: need 4*M, prefer 3*M + M*NB) * CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IWORK = IE + M * * Perform bidiagonal QR iteration, computing right * singular vectors of A in A * (Workspace: need BDSPAC) * CALL DBDSQR( 'L', M, N, 0, 0, S, WORK( IE ), A, LDA, $ DUM, 1, DUM, 1, WORK( IWORK ), INFO ) * END IF * ELSE IF( WNTVO .AND. WNTUAS ) THEN * * Path 3t(N much larger than M, JOBU='S' or 'A', JOBVT='O') * M right singular vectors to be overwritten on A and * M left singular vectors to be computed in U * IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN * * Sufficient workspace for a fast algorithm * IR = 1 IF( LWORK.GE.MAX( WRKBL, LDA*N + M ) + LDA*M ) THEN * * WORK(IU) is LDA by N and WORK(IR) is LDA by M * LDWRKU = LDA CHUNK = N LDWRKR = LDA ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N + M ) + M*M ) THEN * * WORK(IU) is LDA by N and WORK(IR) is M by M * LDWRKU = LDA CHUNK = N LDWRKR = M ELSE * * WORK(IU) is M by CHUNK and WORK(IR) is M by M * LDWRKU = M CHUNK = ( LWORK-M*M-M ) / M LDWRKR = M END IF ITAU = IR + LDWRKR*M IWORK = ITAU + M * * Compute A=L*Q * (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy L to U, zeroing about above it * CALL DLACPY( 'L', M, M, A, LDA, U, LDU ) CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ), $ LDU ) * * Generate Q in A * (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) * CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = ITAU ITAUQ = IE + M ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize L in U, copying result to WORK(IR) * (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB) * CALL DGEBRD( M, M, U, LDU, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'U', M, M, U, LDU, WORK( IR ), LDWRKR ) * * Generate right vectors bidiagonalizing L in WORK(IR) * (Workspace: need M*M + 4*M-1, prefer M*M + 3*M + (M-1)*NB) * CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate left vectors bidiagonalizing L in U * (Workspace: need M*M + 4*M, prefer M*M + 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IWORK = IE + M * * Perform bidiagonal QR iteration, computing left * singular vectors of L in U, and computing right * singular vectors of L in WORK(IR) * (Workspace: need M*M + BDSPAC) * CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), $ WORK( IR ), LDWRKR, U, LDU, DUM, 1, $ WORK( IWORK ), INFO ) IU = IE + M * * Multiply right singular vectors of L in WORK(IR) by Q * in A, storing result in WORK(IU) and copying to A * (Workspace: need M*M + 2*M, prefer M*M + M*N + M)) * DO 40 I = 1, N, CHUNK BLK = MIN( N-I+1, CHUNK ) CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IR ), $ LDWRKR, A( 1, I ), LDA, ZERO, $ WORK( IU ), LDWRKU ) CALL DLACPY( 'F', M, BLK, WORK( IU ), LDWRKU, $ A( 1, I ), LDA ) 40 CONTINUE * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + M * * Compute A=L*Q * (Workspace: need 2*M, prefer M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy L to U, zeroing out above it * CALL DLACPY( 'L', M, M, A, LDA, U, LDU ) CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ), $ LDU ) * * Generate Q in A * (Workspace: need 2*M, prefer M + M*NB) * CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = ITAU ITAUQ = IE + M ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize L in U * (Workspace: need 4*M, prefer 3*M + 2*M*NB) * CALL DGEBRD( M, M, U, LDU, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply right vectors bidiagonalizing L by Q in A * (Workspace: need 3*M + N, prefer 3*M + N*NB) * CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU, $ WORK( ITAUP ), A, LDA, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate left vectors bidiagonalizing L in U * (Workspace: need 4*M, prefer 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IWORK = IE + M * * Perform bidiagonal QR iteration, computing left * singular vectors of A in U and computing right * singular vectors of A in A * (Workspace: need BDSPAC) * CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), A, LDA, $ U, LDU, DUM, 1, WORK( IWORK ), INFO ) * END IF * ELSE IF( WNTVS ) THEN * IF( WNTUN ) THEN * * Path 4t(N much larger than M, JOBU='N', JOBVT='S') * M right singular vectors to be computed in VT and * no left singular vectors to be computed * IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN * * Sufficient workspace for a fast algorithm * IR = 1 IF( LWORK.GE.WRKBL+LDA*M ) THEN * * WORK(IR) is LDA by M * LDWRKR = LDA ELSE * * WORK(IR) is M by M * LDWRKR = M END IF ITAU = IR + LDWRKR*M IWORK = ITAU + M * * Compute A=L*Q * (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy L to WORK(IR), zeroing out above it * CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ), $ LDWRKR ) CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, $ WORK( IR+LDWRKR ), LDWRKR ) * * Generate Q in A * (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) * CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = ITAU ITAUQ = IE + M ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize L in WORK(IR) * (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB) * CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S, $ WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right vectors bidiagonalizing L in * WORK(IR) * (Workspace: need M*M + 4*M, prefer M*M + 3*M + (M-1)*NB) * CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IWORK = IE + M * * Perform bidiagonal QR iteration, computing right * singular vectors of L in WORK(IR) * (Workspace: need M*M + BDSPAC) * CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ), $ WORK( IR ), LDWRKR, DUM, 1, DUM, 1, $ WORK( IWORK ), INFO ) * * Multiply right singular vectors of L in WORK(IR) by * Q in A, storing result in VT * (Workspace: need M*M) * CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IR ), $ LDWRKR, A, LDA, ZERO, VT, LDVT ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + M * * Compute A=L*Q * (Workspace: need 2*M, prefer M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy result to VT * CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT * (Workspace: need 2*M, prefer M + M*NB) * CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = ITAU ITAUQ = IE + M ITAUP = ITAUQ + M IWORK = ITAUP + M * * Zero out above L in A * CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), $ LDA ) * * Bidiagonalize L in A * (Workspace: need 4*M, prefer 3*M + 2*M*NB) * CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply right vectors bidiagonalizing L by Q in VT * (Workspace: need 3*M + N, prefer 3*M + N*NB) * CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IWORK = IE + M * * Perform bidiagonal QR iteration, computing right * singular vectors of A in VT * (Workspace: need BDSPAC) * CALL DBDSQR( 'U', M, N, 0, 0, S, WORK( IE ), VT, $ LDVT, DUM, 1, DUM, 1, WORK( IWORK ), $ INFO ) * END IF * ELSE IF( WNTUO ) THEN * * Path 5t(N much larger than M, JOBU='O', JOBVT='S') * M right singular vectors to be computed in VT and * M left singular vectors to be overwritten on A * IF( LWORK.GE.2*M*M+MAX( 4*M, BDSPAC ) ) THEN * * Sufficient workspace for a fast algorithm * IU = 1 IF( LWORK.GE.WRKBL+2*LDA*M ) THEN * * WORK(IU) is LDA by M and WORK(IR) is LDA by M * LDWRKU = LDA IR = IU + LDWRKU*M LDWRKR = LDA ELSE IF( LWORK.GE.WRKBL+( LDA + M )*M ) THEN * * WORK(IU) is LDA by M and WORK(IR) is M by M * LDWRKU = LDA IR = IU + LDWRKU*M LDWRKR = M ELSE * * WORK(IU) is M by M and WORK(IR) is M by M * LDWRKU = M IR = IU + LDWRKU*M LDWRKR = M END IF ITAU = IR + LDWRKR*M IWORK = ITAU + M * * Compute A=L*Q * (Workspace: need 2*M*M + 2*M, prefer 2*M*M + M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy L to WORK(IU), zeroing out below it * CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ), $ LDWRKU ) CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, $ WORK( IU+LDWRKU ), LDWRKU ) * * Generate Q in A * (Workspace: need 2*M*M + 2*M, prefer 2*M*M + M + M*NB) * CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = ITAU ITAUQ = IE + M ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize L in WORK(IU), copying result to * WORK(IR) * (Workspace: need 2*M*M + 4*M, * prefer 2*M*M+3*M+2*M*NB) * CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S, $ WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU, $ WORK( IR ), LDWRKR ) * * Generate right bidiagonalizing vectors in WORK(IU) * (Workspace: need 2*M*M + 4*M-1, * prefer 2*M*M+3*M+(M-1)*NB) * CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in WORK(IR) * (Workspace: need 2*M*M + 4*M, prefer 2*M*M + 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IWORK = IE + M * * Perform bidiagonal QR iteration, computing left * singular vectors of L in WORK(IR) and computing * right singular vectors of L in WORK(IU) * (Workspace: need 2*M*M + BDSPAC) * CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), $ WORK( IU ), LDWRKU, WORK( IR ), $ LDWRKR, DUM, 1, WORK( IWORK ), INFO ) * * Multiply right singular vectors of L in WORK(IU) by * Q in A, storing result in VT * (Workspace: need M*M) * CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ), $ LDWRKU, A, LDA, ZERO, VT, LDVT ) * * Copy left singular vectors of L to A * (Workspace: need M*M) * CALL DLACPY( 'F', M, M, WORK( IR ), LDWRKR, A, $ LDA ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + M * * Compute A=L*Q, copying result to VT * (Workspace: need 2*M, prefer M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT * (Workspace: need 2*M, prefer M + M*NB) * CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = ITAU ITAUQ = IE + M ITAUP = ITAUQ + M IWORK = ITAUP + M * * Zero out above L in A * CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), $ LDA ) * * Bidiagonalize L in A * (Workspace: need 4*M, prefer 3*M + 2*M*NB) * CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply right vectors bidiagonalizing L by Q in VT * (Workspace: need 3*M + N, prefer 3*M + N*NB) * CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors of L in A * (Workspace: need 4*M, prefer 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IWORK = IE + M * * Perform bidiagonal QR iteration, compute left * singular vectors of A in A and compute right * singular vectors of A in VT * (Workspace: need BDSPAC) * CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT, $ LDVT, A, LDA, DUM, 1, WORK( IWORK ), $ INFO ) * END IF * ELSE IF( WNTUAS ) THEN * * Path 6t(N much larger than M, JOBU='S' or 'A', * JOBVT='S') * M right singular vectors to be computed in VT and * M left singular vectors to be computed in U * IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN * * Sufficient workspace for a fast algorithm * IU = 1 IF( LWORK.GE.WRKBL+LDA*M ) THEN * * WORK(IU) is LDA by N * LDWRKU = LDA ELSE * * WORK(IU) is LDA by M * LDWRKU = M END IF ITAU = IU + LDWRKU*M IWORK = ITAU + M * * Compute A=L*Q * (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy L to WORK(IU), zeroing out above it * CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ), $ LDWRKU ) CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, $ WORK( IU+LDWRKU ), LDWRKU ) * * Generate Q in A * (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) * CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = ITAU ITAUQ = IE + M ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize L in WORK(IU), copying result to U * (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB) * CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S, $ WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU, U, $ LDU ) * * Generate right bidiagonalizing vectors in WORK(IU) * (Workspace: need M*M + 4*M-1, * prefer M*M+3*M+(M-1)*NB) * CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in U * (Workspace: need M*M + 4*M, prefer M*M + 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IWORK = IE + M * * Perform bidiagonal QR iteration, computing left * singular vectors of L in U and computing right * singular vectors of L in WORK(IU) * (Workspace: need M*M + BDSPAC) * CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), $ WORK( IU ), LDWRKU, U, LDU, DUM, 1, $ WORK( IWORK ), INFO ) * * Multiply right singular vectors of L in WORK(IU) by * Q in A, storing result in VT * (Workspace: need M*M) * CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ), $ LDWRKU, A, LDA, ZERO, VT, LDVT ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + M * * Compute A=L*Q, copying result to VT * (Workspace: need 2*M, prefer M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT * (Workspace: need 2*M, prefer M + M*NB) * CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy L to U, zeroing out above it * CALL DLACPY( 'L', M, M, A, LDA, U, LDU ) CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ), $ LDU ) IE = ITAU ITAUQ = IE + M ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize L in U * (Workspace: need 4*M, prefer 3*M + 2*M*NB) * CALL DGEBRD( M, M, U, LDU, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply right bidiagonalizing vectors in U by Q * in VT * (Workspace: need 3*M + N, prefer 3*M + N*NB) * CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU, $ WORK( ITAUP ), VT, LDVT, $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in U * (Workspace: need 4*M, prefer 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IWORK = IE + M * * Perform bidiagonal QR iteration, computing left * singular vectors of A in U and computing right * singular vectors of A in VT * (Workspace: need BDSPAC) * CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT, $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), $ INFO ) * END IF * END IF * ELSE IF( WNTVA ) THEN * IF( WNTUN ) THEN * * Path 7t(N much larger than M, JOBU='N', JOBVT='A') * N right singular vectors to be computed in VT and * no left singular vectors to be computed * IF( LWORK.GE.M*M+MAX( N + M, 4*M, BDSPAC ) ) THEN * * Sufficient workspace for a fast algorithm * IR = 1 IF( LWORK.GE.WRKBL+LDA*M ) THEN * * WORK(IR) is LDA by M * LDWRKR = LDA ELSE * * WORK(IR) is M by M * LDWRKR = M END IF ITAU = IR + LDWRKR*M IWORK = ITAU + M * * Compute A=L*Q, copying result to VT * (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Copy L to WORK(IR), zeroing out above it * CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ), $ LDWRKR ) CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, $ WORK( IR+LDWRKR ), LDWRKR ) * * Generate Q in VT * (Workspace: need M*M + M + N, prefer M*M + M + N*NB) * CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = ITAU ITAUQ = IE + M ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize L in WORK(IR) * (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB) * CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S, $ WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in WORK(IR) * (Workspace: need M*M + 4*M-1, * prefer M*M+3*M+(M-1)*NB) * CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IWORK = IE + M * * Perform bidiagonal QR iteration, computing right * singular vectors of L in WORK(IR) * (Workspace: need M*M + BDSPAC) * CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ), $ WORK( IR ), LDWRKR, DUM, 1, DUM, 1, $ WORK( IWORK ), INFO ) * * Multiply right singular vectors of L in WORK(IR) by * Q in VT, storing result in A * (Workspace: need M*M) * CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IR ), $ LDWRKR, VT, LDVT, ZERO, A, LDA ) * * Copy right singular vectors of A from A to VT * CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + M * * Compute A=L*Q, copying result to VT * (Workspace: need 2*M, prefer M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT * (Workspace: need M + N, prefer M + N*NB) * CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = ITAU ITAUQ = IE + M ITAUP = ITAUQ + M IWORK = ITAUP + M * * Zero out above L in A * CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), $ LDA ) * * Bidiagonalize L in A * (Workspace: need 4*M, prefer 3*M + 2*M*NB) * CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply right bidiagonalizing vectors in A by Q * in VT * (Workspace: need 3*M + N, prefer 3*M + N*NB) * CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IWORK = IE + M * * Perform bidiagonal QR iteration, computing right * singular vectors of A in VT * (Workspace: need BDSPAC) * CALL DBDSQR( 'U', M, N, 0, 0, S, WORK( IE ), VT, $ LDVT, DUM, 1, DUM, 1, WORK( IWORK ), $ INFO ) * END IF * ELSE IF( WNTUO ) THEN * * Path 8t(N much larger than M, JOBU='O', JOBVT='A') * N right singular vectors to be computed in VT and * M left singular vectors to be overwritten on A * IF( LWORK.GE.2*M*M+MAX( N + M, 4*M, BDSPAC ) ) THEN * * Sufficient workspace for a fast algorithm * IU = 1 IF( LWORK.GE.WRKBL+2*LDA*M ) THEN * * WORK(IU) is LDA by M and WORK(IR) is LDA by M * LDWRKU = LDA IR = IU + LDWRKU*M LDWRKR = LDA ELSE IF( LWORK.GE.WRKBL+( LDA + M )*M ) THEN * * WORK(IU) is LDA by M and WORK(IR) is M by M * LDWRKU = LDA IR = IU + LDWRKU*M LDWRKR = M ELSE * * WORK(IU) is M by M and WORK(IR) is M by M * LDWRKU = M IR = IU + LDWRKU*M LDWRKR = M END IF ITAU = IR + LDWRKR*M IWORK = ITAU + M * * Compute A=L*Q, copying result to VT * (Workspace: need 2*M*M + 2*M, prefer 2*M*M + M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT * (Workspace: need 2*M*M + M + N, prefer 2*M*M + M + N*NB) * CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy L to WORK(IU), zeroing out above it * CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ), $ LDWRKU ) CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, $ WORK( IU+LDWRKU ), LDWRKU ) IE = ITAU ITAUQ = IE + M ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize L in WORK(IU), copying result to * WORK(IR) * (Workspace: need 2*M*M + 4*M, * prefer 2*M*M+3*M+2*M*NB) * CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S, $ WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU, $ WORK( IR ), LDWRKR ) * * Generate right bidiagonalizing vectors in WORK(IU) * (Workspace: need 2*M*M + 4*M-1, * prefer 2*M*M+3*M+(M-1)*NB) * CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in WORK(IR) * (Workspace: need 2*M*M + 4*M, prefer 2*M*M + 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IWORK = IE + M * * Perform bidiagonal QR iteration, computing left * singular vectors of L in WORK(IR) and computing * right singular vectors of L in WORK(IU) * (Workspace: need 2*M*M + BDSPAC) * CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), $ WORK( IU ), LDWRKU, WORK( IR ), $ LDWRKR, DUM, 1, WORK( IWORK ), INFO ) * * Multiply right singular vectors of L in WORK(IU) by * Q in VT, storing result in A * (Workspace: need M*M) * CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ), $ LDWRKU, VT, LDVT, ZERO, A, LDA ) * * Copy right singular vectors of A from A to VT * CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT ) * * Copy left singular vectors of A from WORK(IR) to A * CALL DLACPY( 'F', M, M, WORK( IR ), LDWRKR, A, $ LDA ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + M * * Compute A=L*Q, copying result to VT * (Workspace: need 2*M, prefer M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT * (Workspace: need M + N, prefer M + N*NB) * CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = ITAU ITAUQ = IE + M ITAUP = ITAUQ + M IWORK = ITAUP + M * * Zero out above L in A * CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), $ LDA ) * * Bidiagonalize L in A * (Workspace: need 4*M, prefer 3*M + 2*M*NB) * CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply right bidiagonalizing vectors in A by Q * in VT * (Workspace: need 3*M + N, prefer 3*M + N*NB) * CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in A * (Workspace: need 4*M, prefer 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IWORK = IE + M * * Perform bidiagonal QR iteration, computing left * singular vectors of A in A and computing right * singular vectors of A in VT * (Workspace: need BDSPAC) * CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT, $ LDVT, A, LDA, DUM, 1, WORK( IWORK ), $ INFO ) * END IF * ELSE IF( WNTUAS ) THEN * * Path 9t(N much larger than M, JOBU='S' or 'A', * JOBVT='A') * N right singular vectors to be computed in VT and * M left singular vectors to be computed in U * IF( LWORK.GE.M*M+MAX( N + M, 4*M, BDSPAC ) ) THEN * * Sufficient workspace for a fast algorithm * IU = 1 IF( LWORK.GE.WRKBL+LDA*M ) THEN * * WORK(IU) is LDA by M * LDWRKU = LDA ELSE * * WORK(IU) is M by M * LDWRKU = M END IF ITAU = IU + LDWRKU*M IWORK = ITAU + M * * Compute A=L*Q, copying result to VT * (Workspace: need M*M + 2*M, prefer M*M + M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT * (Workspace: need M*M + M + N, prefer M*M + M + N*NB) * CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy L to WORK(IU), zeroing out above it * CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ), $ LDWRKU ) CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, $ WORK( IU+LDWRKU ), LDWRKU ) IE = ITAU ITAUQ = IE + M ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize L in WORK(IU), copying result to U * (Workspace: need M*M + 4*M, prefer M*M + 3*M + 2*M*NB) * CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S, $ WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU, U, $ LDU ) * * Generate right bidiagonalizing vectors in WORK(IU) * (Workspace: need M*M + 4*M, prefer M*M + 3*M + (M-1)*NB) * CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in U * (Workspace: need M*M + 4*M, prefer M*M + 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IWORK = IE + M * * Perform bidiagonal QR iteration, computing left * singular vectors of L in U and computing right * singular vectors of L in WORK(IU) * (Workspace: need M*M + BDSPAC) * CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), $ WORK( IU ), LDWRKU, U, LDU, DUM, 1, $ WORK( IWORK ), INFO ) * * Multiply right singular vectors of L in WORK(IU) by * Q in VT, storing result in A * (Workspace: need M*M) * CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ), $ LDWRKU, VT, LDVT, ZERO, A, LDA ) * * Copy right singular vectors of A from A to VT * CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + M * * Compute A=L*Q, copying result to VT * (Workspace: need 2*M, prefer M + M*NB) * CALL DGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT * (Workspace: need M + N, prefer M + N*NB) * CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy L to U, zeroing out above it * CALL DLACPY( 'L', M, M, A, LDA, U, LDU ) CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ), $ LDU ) IE = ITAU ITAUQ = IE + M ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize L in U * (Workspace: need 4*M, prefer 3*M + 2*M*NB) * CALL DGEBRD( M, M, U, LDU, S, WORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply right bidiagonalizing vectors in U by Q * in VT * (Workspace: need 3*M + N, prefer 3*M + N*NB) * CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU, $ WORK( ITAUP ), VT, LDVT, $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in U * (Workspace: need 4*M, prefer 3*M + M*NB) * CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IWORK = IE + M * * Perform bidiagonal QR iteration, computing left * singular vectors of A in U and computing right * singular vectors of A in VT * (Workspace: need BDSPAC) * CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT, $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), $ INFO ) * END IF * END IF * END IF * ELSE * * N .LT. MNTHR * * Path 10t(N greater than M, but not much larger) * Reduce to bidiagonal form without LQ decomposition * IE = 1 ITAUQ = IE + M ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize A * (Workspace: need 3*M + N, prefer 3*M + (M + N)*NB) * CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, $ IERR ) IF( WNTUAS ) THEN * * If left singular vectors desired in U, copy result to U * and generate left bidiagonalizing vectors in U * (Workspace: need 4*M-1, prefer 3*M + (M-1)*NB) * CALL DLACPY( 'L', M, M, A, LDA, U, LDU ) CALL DORGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) END IF IF( WNTVAS ) THEN * * If right singular vectors desired in VT, copy result to * VT and generate right bidiagonalizing vectors in VT * (Workspace: need 3*M + NRVT, prefer 3*M + NRVT*NB) * CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT ) IF( WNTVA ) $ NRVT = N IF( WNTVS ) $ NRVT = M CALL DORGBR( 'P', NRVT, N, M, VT, LDVT, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) END IF IF( WNTUO ) THEN * * If left singular vectors desired in A, generate left * bidiagonalizing vectors in A * (Workspace: need 4*M-1, prefer 3*M + (M-1)*NB) * CALL DORGBR( 'Q', M, M, N, A, LDA, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) END IF IF( WNTVO ) THEN * * If right singular vectors desired in A, generate right * bidiagonalizing vectors in A * (Workspace: need 4*M, prefer 3*M + M*NB) * CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) END IF IWORK = IE + M IF( WNTUAS .OR. WNTUO ) $ NRU = M IF( WNTUN ) $ NRU = 0 IF( WNTVAS .OR. WNTVO ) $ NCVT = N IF( WNTVN ) $ NCVT = 0 IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN * * Perform bidiagonal QR iteration, if desired, computing * left singular vectors in U and computing right singular * vectors in VT * (Workspace: need BDSPAC) * CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), VT, $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), INFO ) ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN * * Perform bidiagonal QR iteration, if desired, computing * left singular vectors in U and computing right singular * vectors in A * (Workspace: need BDSPAC) * CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), A, LDA, $ U, LDU, DUM, 1, WORK( IWORK ), INFO ) ELSE * * Perform bidiagonal QR iteration, if desired, computing * left singular vectors in A and computing right singular * vectors in VT * (Workspace: need BDSPAC) * CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), VT, $ LDVT, A, LDA, DUM, 1, WORK( IWORK ), INFO ) END IF * END IF * END IF * * If DBDSQR failed to converge, copy unconverged superdiagonals * to WORK( 2:MINMN ) * IF( INFO.NE.0 ) THEN IF( IE.GT.2 ) THEN DO 50 I = 1, MINMN - 1 WORK( I+1 ) = WORK( I+IE-1 ) 50 CONTINUE END IF IF( IE.LT.2 ) THEN DO 60 I = MINMN - 1, 1, -1 WORK( I+1 ) = WORK( I+IE-1 ) 60 CONTINUE END IF END IF * * Undo scaling if necessary * IF( ISCL.EQ.1 ) THEN IF( ANRM.GT.BIGNUM ) $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN, $ IERR ) IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM ) $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN-1, 1, WORK( 2 ), $ MINMN, IERR ) IF( ANRM.LT.SMLNUM ) $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN, $ IERR ) IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM ) $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN-1, 1, WORK( 2 ), $ MINMN, IERR ) END IF * * Return optimal workspace in WORK(1) * WORK( 1 ) = MAXWRK * RETURN * * End of DGESVD * END *> \brief \b DGESVJ * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGESVJ + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, * LDV, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LDV, LWORK, M, MV, N * CHARACTER*1 JOBA, JOBU, JOBV * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), SVA( N ), V( LDV, * ), * $ WORK( LWORK ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGESVJ computes the singular value decomposition (SVD) of a real *> M-by-N matrix A, where M >= N. The SVD of A is written as *> [++] [xx] [x0] [xx] *> A = U * SIGMA * V^t, [++] = [xx] * [ox] * [xx] *> [++] [xx] *> where SIGMA is an N-by-N diagonal matrix, U is an M-by-N orthonormal *> matrix, and V is an N-by-N orthogonal matrix. The diagonal elements *> of SIGMA are the singular values of A. The columns of U and V are the *> left and the right singular vectors of A, respectively. *> DGESVJ can sometimes compute tiny singular values and their singular vectors much *> more accurately than other SVD routines, see below under Further Details. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBA *> \verbatim *> JOBA is CHARACTER*1 *> Specifies the structure of A. *> = 'L': The input matrix A is lower triangular; *> = 'U': The input matrix A is upper triangular; *> = 'G': The input matrix A is general M-by-N matrix, M >= N. *> \endverbatim *> *> \param[in] JOBU *> \verbatim *> JOBU is CHARACTER*1 *> Specifies whether to compute the left singular vectors *> (columns of U): *> = 'U': The left singular vectors corresponding to the nonzero *> singular values are computed and returned in the leading *> columns of A. See more details in the description of A. *> The default numerical orthogonality threshold is set to *> approximately TOL=CTOL*EPS, CTOL=DSQRT(M), EPS=DLAMCH('E'). *> = 'C': Analogous to JOBU='U', except that user can control the *> level of numerical orthogonality of the computed left *> singular vectors. TOL can be set to TOL = CTOL*EPS, where *> CTOL is given on input in the array WORK. *> No CTOL smaller than ONE is allowed. CTOL greater *> than 1 / EPS is meaningless. The option 'C' *> can be used if M*EPS is satisfactory orthogonality *> of the computed left singular vectors, so CTOL=M could *> save few sweeps of Jacobi rotations. *> See the descriptions of A and WORK(1). *> = 'N': The matrix U is not computed. However, see the *> description of A. *> \endverbatim *> *> \param[in] JOBV *> \verbatim *> JOBV is CHARACTER*1 *> Specifies whether to compute the right singular vectors, that *> is, the matrix V: *> = 'V' : the matrix V is computed and returned in the array V *> = 'A' : the Jacobi rotations are applied to the MV-by-N *> array V. In other words, the right singular vector *> matrix V is not computed explicitly, instead it is *> applied to an MV-by-N matrix initially stored in the *> first MV rows of V. *> = 'N' : the matrix V is not computed and the array V is not *> referenced *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the input matrix A. 1/DLAMCH('E') > M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the input matrix A. *> M >= N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the M-by-N matrix A. *> On exit : *> If JOBU .EQ. 'U' .OR. JOBU .EQ. 'C' : *> If INFO .EQ. 0 : *> RANKA orthonormal columns of U are returned in the *> leading RANKA columns of the array A. Here RANKA <= N *> is the number of computed singular values of A that are *> above the underflow threshold DLAMCH('S'). The singular *> vectors corresponding to underflowed or zero singular *> values are not computed. The value of RANKA is returned *> in the array WORK as RANKA=NINT(WORK(2)). Also see the *> descriptions of SVA and WORK. The computed columns of U *> are mutually numerically orthogonal up to approximately *> TOL=DSQRT(M)*EPS (default); or TOL=CTOL*EPS (JOBU.EQ.'C'), *> see the description of JOBU. *> If INFO .GT. 0 : *> the procedure DGESVJ did not converge in the given number *> of iterations (sweeps). In that case, the computed *> columns of U may not be orthogonal up to TOL. The output *> U (stored in A), SIGMA (given by the computed singular *> values in SVA(1:N)) and V is still a decomposition of the *> input matrix A in the sense that the residual *> ||A-SCALE*U*SIGMA*V^T||_2 / ||A||_2 is small. *> *> If JOBU .EQ. 'N' : *> If INFO .EQ. 0 : *> Note that the left singular vectors are 'for free' in the *> one-sided Jacobi SVD algorithm. However, if only the *> singular values are needed, the level of numerical *> orthogonality of U is not an issue and iterations are *> stopped when the columns of the iterated matrix are *> numerically orthogonal up to approximately M*EPS. Thus, *> on exit, A contains the columns of U scaled with the *> corresponding singular values. *> If INFO .GT. 0 : *> the procedure DGESVJ did not converge in the given number *> of iterations (sweeps). *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] SVA *> \verbatim *> SVA is DOUBLE PRECISION array, dimension (N) *> On exit : *> If INFO .EQ. 0 : *> depending on the value SCALE = WORK(1), we have: *> If SCALE .EQ. ONE : *> SVA(1:N) contains the computed singular values of A. *> During the computation SVA contains the Euclidean column *> norms of the iterated matrices in the array A. *> If SCALE .NE. ONE : *> The singular values of A are SCALE*SVA(1:N), and this *> factored representation is due to the fact that some of the *> singular values of A might underflow or overflow. *> If INFO .GT. 0 : *> the procedure DGESVJ did not converge in the given number of *> iterations (sweeps) and SCALE*SVA(1:N) may not be accurate. *> \endverbatim *> *> \param[in] MV *> \verbatim *> MV is INTEGER *> If JOBV .EQ. 'A', then the product of Jacobi rotations in DGESVJ *> is applied to the first MV rows of V. See the description of JOBV. *> \endverbatim *> *> \param[in,out] V *> \verbatim *> V is DOUBLE PRECISION array, dimension (LDV,N) *> If JOBV = 'V', then V contains on exit the N-by-N matrix of *> the right singular vectors; *> If JOBV = 'A', then V contains the product of the computed right *> singular vector matrix and the initial matrix in *> the array V. *> If JOBV = 'N', then V is not referenced. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the array V, LDV .GE. 1. *> If JOBV .EQ. 'V', then LDV .GE. max(1,N). *> If JOBV .EQ. 'A', then LDV .GE. max(1,MV) . *> \endverbatim *> *> \param[in,out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (LWORK) *> On entry : *> If JOBU .EQ. 'C' : *> WORK(1) = CTOL, where CTOL defines the threshold for convergence. *> The process stops if all columns of A are mutually *> orthogonal up to CTOL*EPS, EPS=DLAMCH('E'). *> It is required that CTOL >= ONE, i.e. it is not *> allowed to force the routine to obtain orthogonality *> below EPS. *> On exit : *> WORK(1) = SCALE is the scaling factor such that SCALE*SVA(1:N) *> are the computed singular values of A. *> (See description of SVA().) *> WORK(2) = NINT(WORK(2)) is the number of the computed nonzero *> singular values. *> WORK(3) = NINT(WORK(3)) is the number of the computed singular *> values that are larger than the underflow threshold. *> WORK(4) = NINT(WORK(4)) is the number of sweeps of Jacobi *> rotations needed for numerical convergence. *> WORK(5) = max_{i.NE.j} |COS(A(:,i),A(:,j))| in the last sweep. *> This is useful information in cases when DGESVJ did *> not converge, as it can be used to estimate whether *> the output is stil useful and for post festum analysis. *> WORK(6) = the largest absolute value over all sines of the *> Jacobi rotation angles in the last sweep. It can be *> useful for a post festum analysis. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> length of WORK, WORK >= MAX(6,M+N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0 : successful exit. *> < 0 : if INFO = -i, then the i-th argument had an illegal value *> > 0 : DGESVJ did not converge in the maximal allowed number (30) *> of sweeps. The output may still be useful. See the *> description of WORK. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The orthogonal N-by-N matrix V is obtained as a product of Jacobi plane *> rotations. The rotations are implemented as fast scaled rotations of *> Anda and Park [1]. In the case of underflow of the Jacobi angle, a *> modified Jacobi transformation of Drmac [4] is used. Pivot strategy uses *> column interchanges of de Rijk [2]. The relative accuracy of the computed *> singular values and the accuracy of the computed singular vectors (in *> angle metric) is as guaranteed by the theory of Demmel and Veselic [3]. *> The condition number that determines the accuracy in the full rank case *> is essentially min_{D=diag} kappa(A*D), where kappa(.) is the *> spectral condition number. The best performance of this Jacobi SVD *> procedure is achieved if used in an accelerated version of Drmac and *> Veselic [5,6], and it is the kernel routine in the SIGMA library [7]. *> Some tunning parameters (marked with [TP]) are available for the *> implementer. *> The computational range for the nonzero singular values is the machine *> number interval ( UNDERFLOW , OVERFLOW ). In extreme cases, even *> denormalized singular values can be computed with the corresponding *> gradual loss of accurate digits. *> \endverbatim * *> \par Contributors: * ================== *> *> \verbatim *> *> ============ *> *> Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) *> \endverbatim * *> \par References: * ================ *> *> \verbatim *> *> [1] A. A. Anda and H. Park: Fast plane rotations with dynamic scaling. *> SIAM J. matrix Anal. Appl., Vol. 15 (1994), pp. 162-174. *> [2] P. P. M. De Rijk: A one-sided Jacobi algorithm for computing the *> singular value decomposition on a vector computer. *> SIAM J. Sci. Stat. Comp., Vol. 10 (1998), pp. 359-371. *> [3] J. Demmel and K. Veselic: Jacobi method is more accurate than QR. *> [4] Z. Drmac: Implementation of Jacobi rotations for accurate singular *> value computation in floating point arithmetic. *> SIAM J. Sci. Comp., Vol. 18 (1997), pp. 1200-1222. *> [5] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm I. *> SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1322-1342. *> LAPACK Working note 169. *> [6] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm II. *> SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1343-1362. *> LAPACK Working note 170. *> [7] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV, *> QSVD, (H,K)-SVD computations. *> Department of Mathematics, University of Zagreb, 2008. *> \endverbatim * *> \par Bugs, examples and comments: * ================================= *> *> \verbatim *> =========================== *> Please report all bugs and send interesting test examples and comments to *> drmac@math.hr. Thank you. *> \endverbatim *> * ===================================================================== SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, $ LDV, WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDV, LWORK, M, MV, N CHARACTER*1 JOBA, JOBU, JOBV * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), SVA( N ), V( LDV, * ), $ WORK( LWORK ) * .. * * ===================================================================== * * .. Local Parameters .. DOUBLE PRECISION ZERO, HALF, ONE PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0) INTEGER NSWEEP PARAMETER ( NSWEEP = 30 ) * .. * .. Local Scalars .. DOUBLE PRECISION AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG, $ BIGTHETA, CS, CTOL, EPSLN, LARGE, MXAAPQ, $ MXSINJ, ROOTBIG, ROOTEPS, ROOTSFMIN, ROOTTOL, $ SKL, SFMIN, SMALL, SN, T, TEMP1, THETA, $ THSIGN, TOL INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1, $ ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, N2, N34, $ N4, NBL, NOTROT, p, PSKIPPED, q, ROWSKIP, $ SWBAND LOGICAL APPLV, GOSCALE, LOWER, LSVEC, NOSCALE, ROTOK, $ RSVEC, UCTOL, UPPER * .. * .. Local Arrays .. DOUBLE PRECISION FASTR( 5 ) * .. * .. Intrinsic Functions .. INTRINSIC DABS, MAX, MIN, DBLE, DSIGN, DSQRT * .. * .. External Functions .. * .. * from BLAS DOUBLE PRECISION DDOT, DNRM2 EXTERNAL DDOT, DNRM2 INTEGER IDAMAX EXTERNAL IDAMAX * from LAPACK DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. * .. * from BLAS EXTERNAL DAXPY, DCOPY, DROTM, DSCAL, DSWAP * from LAPACK EXTERNAL DLASCL, DLASET, DLASSQ, XERBLA * EXTERNAL DGSVJ0, DGSVJ1 * .. * .. Executable Statements .. * * Test the input arguments * LSVEC = LSAME( JOBU, 'U' ) UCTOL = LSAME( JOBU, 'C' ) RSVEC = LSAME( JOBV, 'V' ) APPLV = LSAME( JOBV, 'A' ) UPPER = LSAME( JOBA, 'U' ) LOWER = LSAME( JOBA, 'L' ) * IF( .NOT.( UPPER .OR. LOWER .OR. LSAME( JOBA, 'G' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( LSVEC .OR. UCTOL .OR. LSAME( JOBU, 'N' ) ) ) THEN INFO = -2 ELSE IF( .NOT.( RSVEC .OR. APPLV .OR. LSAME( JOBV, 'N' ) ) ) THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( ( N.LT.0 ) .OR. ( N.GT.M ) ) THEN INFO = -5 ELSE IF( LDA.LT.M ) THEN INFO = -7 ELSE IF( MV.LT.0 ) THEN INFO = -9 ELSE IF( ( RSVEC .AND. ( LDV.LT.N ) ) .OR. $ ( APPLV .AND. ( LDV.LT.MV ) ) ) THEN INFO = -11 ELSE IF( UCTOL .AND. ( WORK( 1 ).LE.ONE ) ) THEN INFO = -12 ELSE IF( LWORK.LT.MAX( M+N, 6 ) ) THEN INFO = -13 ELSE INFO = 0 END IF * * #:( IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGESVJ', -INFO ) RETURN END IF * * #:) Quick return for void matrix * IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) )RETURN * * Set numerical parameters * The stopping criterion for Jacobi rotations is * * max_{i<>j}|A(:,i)^T * A(:,j)|/(||A(:,i)||*||A(:,j)||) < CTOL*EPS * * where EPS is the round-off and CTOL is defined as follows: * IF( UCTOL ) THEN * ... user controlled CTOL = WORK( 1 ) ELSE * ... default IF( LSVEC .OR. RSVEC .OR. APPLV ) THEN CTOL = DSQRT( DBLE( M ) ) ELSE CTOL = DBLE( M ) END IF END IF * ... and the machine dependent parameters are *[!] (Make sure that DLAMCH() works properly on the target machine.) * EPSLN = DLAMCH( 'Epsilon' ) ROOTEPS = DSQRT( EPSLN ) SFMIN = DLAMCH( 'SafeMinimum' ) ROOTSFMIN = DSQRT( SFMIN ) SMALL = SFMIN / EPSLN BIG = DLAMCH( 'Overflow' ) * BIG = ONE / SFMIN ROOTBIG = ONE / ROOTSFMIN LARGE = BIG / DSQRT( DBLE( M*N ) ) BIGTHETA = ONE / ROOTEPS * TOL = CTOL*EPSLN ROOTTOL = DSQRT( TOL ) * IF( DBLE( M )*EPSLN.GE.ONE ) THEN INFO = -4 CALL XERBLA( 'DGESVJ', -INFO ) RETURN END IF * * Initialize the right singular vector matrix. * IF( RSVEC ) THEN MVL = N CALL DLASET( 'A', MVL, N, ZERO, ONE, V, LDV ) ELSE IF( APPLV ) THEN MVL = MV END IF RSVEC = RSVEC .OR. APPLV * * Initialize SVA( 1:N ) = ( ||A e_i||_2, i = 1:N ) *(!) If necessary, scale A to protect the largest singular value * from overflow. It is possible that saving the largest singular * value destroys the information about the small ones. * This initial scaling is almost minimal in the sense that the * goal is to make sure that no column norm overflows, and that * DSQRT(N)*max_i SVA(i) does not overflow. If INFinite entries * in A are detected, the procedure returns with INFO=-6. * SKL= ONE / DSQRT( DBLE( M )*DBLE( N ) ) NOSCALE = .TRUE. GOSCALE = .TRUE. * IF( LOWER ) THEN * the input matrix is M-by-N lower triangular (trapezoidal) DO 1874 p = 1, N AAPP = ZERO AAQQ = ONE CALL DLASSQ( M-p+1, A( p, p ), 1, AAPP, AAQQ ) IF( AAPP.GT.BIG ) THEN INFO = -6 CALL XERBLA( 'DGESVJ', -INFO ) RETURN END IF AAQQ = DSQRT( AAQQ ) IF( ( AAPP.LT.( BIG / AAQQ ) ) .AND. NOSCALE ) THEN SVA( p ) = AAPP*AAQQ ELSE NOSCALE = .FALSE. SVA( p ) = AAPP*( AAQQ*SKL) IF( GOSCALE ) THEN GOSCALE = .FALSE. DO 1873 q = 1, p - 1 SVA( q ) = SVA( q )*SKL 1873 CONTINUE END IF END IF 1874 CONTINUE ELSE IF( UPPER ) THEN * the input matrix is M-by-N upper triangular (trapezoidal) DO 2874 p = 1, N AAPP = ZERO AAQQ = ONE CALL DLASSQ( p, A( 1, p ), 1, AAPP, AAQQ ) IF( AAPP.GT.BIG ) THEN INFO = -6 CALL XERBLA( 'DGESVJ', -INFO ) RETURN END IF AAQQ = DSQRT( AAQQ ) IF( ( AAPP.LT.( BIG / AAQQ ) ) .AND. NOSCALE ) THEN SVA( p ) = AAPP*AAQQ ELSE NOSCALE = .FALSE. SVA( p ) = AAPP*( AAQQ*SKL) IF( GOSCALE ) THEN GOSCALE = .FALSE. DO 2873 q = 1, p - 1 SVA( q ) = SVA( q )*SKL 2873 CONTINUE END IF END IF 2874 CONTINUE ELSE * the input matrix is M-by-N general dense DO 3874 p = 1, N AAPP = ZERO AAQQ = ONE CALL DLASSQ( M, A( 1, p ), 1, AAPP, AAQQ ) IF( AAPP.GT.BIG ) THEN INFO = -6 CALL XERBLA( 'DGESVJ', -INFO ) RETURN END IF AAQQ = DSQRT( AAQQ ) IF( ( AAPP.LT.( BIG / AAQQ ) ) .AND. NOSCALE ) THEN SVA( p ) = AAPP*AAQQ ELSE NOSCALE = .FALSE. SVA( p ) = AAPP*( AAQQ*SKL) IF( GOSCALE ) THEN GOSCALE = .FALSE. DO 3873 q = 1, p - 1 SVA( q ) = SVA( q )*SKL 3873 CONTINUE END IF END IF 3874 CONTINUE END IF * IF( NOSCALE )SKL= ONE * * Move the smaller part of the spectrum from the underflow threshold *(!) Start by determining the position of the nonzero entries of the * array SVA() relative to ( SFMIN, BIG ). * AAPP = ZERO AAQQ = BIG DO 4781 p = 1, N IF( SVA( p ).NE.ZERO )AAQQ = MIN( AAQQ, SVA( p ) ) AAPP = MAX( AAPP, SVA( p ) ) 4781 CONTINUE * * #:) Quick return for zero matrix * IF( AAPP.EQ.ZERO ) THEN IF( LSVEC )CALL DLASET( 'G', M, N, ZERO, ONE, A, LDA ) WORK( 1 ) = ONE WORK( 2 ) = ZERO WORK( 3 ) = ZERO WORK( 4 ) = ZERO WORK( 5 ) = ZERO WORK( 6 ) = ZERO RETURN END IF * * #:) Quick return for one-column matrix * IF( N.EQ.1 ) THEN IF( LSVEC )CALL DLASCL( 'G', 0, 0, SVA( 1 ), SKL, M, 1, $ A( 1, 1 ), LDA, IERR ) WORK( 1 ) = ONE / SKL IF( SVA( 1 ).GE.SFMIN ) THEN WORK( 2 ) = ONE ELSE WORK( 2 ) = ZERO END IF WORK( 3 ) = ZERO WORK( 4 ) = ZERO WORK( 5 ) = ZERO WORK( 6 ) = ZERO RETURN END IF * * Protect small singular values from underflow, and try to * avoid underflows/overflows in computing Jacobi rotations. * SN = DSQRT( SFMIN / EPSLN ) TEMP1 = DSQRT( BIG / DBLE( N ) ) IF( ( AAPP.LE.SN ) .OR. ( AAQQ.GE.TEMP1 ) .OR. $ ( ( SN.LE.AAQQ ) .AND. ( AAPP.LE.TEMP1 ) ) ) THEN TEMP1 = MIN( BIG, TEMP1 / AAPP ) * AAQQ = AAQQ*TEMP1 * AAPP = AAPP*TEMP1 ELSE IF( ( AAQQ.LE.SN ) .AND. ( AAPP.LE.TEMP1 ) ) THEN TEMP1 = MIN( SN / AAQQ, BIG / ( AAPP*DSQRT( DBLE( N ) ) ) ) * AAQQ = AAQQ*TEMP1 * AAPP = AAPP*TEMP1 ELSE IF( ( AAQQ.GE.SN ) .AND. ( AAPP.GE.TEMP1 ) ) THEN TEMP1 = MAX( SN / AAQQ, TEMP1 / AAPP ) * AAQQ = AAQQ*TEMP1 * AAPP = AAPP*TEMP1 ELSE IF( ( AAQQ.LE.SN ) .AND. ( AAPP.GE.TEMP1 ) ) THEN TEMP1 = MIN( SN / AAQQ, BIG / ( DSQRT( DBLE( N ) )*AAPP ) ) * AAQQ = AAQQ*TEMP1 * AAPP = AAPP*TEMP1 ELSE TEMP1 = ONE END IF * * Scale, if necessary * IF( TEMP1.NE.ONE ) THEN CALL DLASCL( 'G', 0, 0, ONE, TEMP1, N, 1, SVA, N, IERR ) END IF SKL= TEMP1*SKL IF( SKL.NE.ONE ) THEN CALL DLASCL( JOBA, 0, 0, ONE, SKL, M, N, A, LDA, IERR ) SKL= ONE / SKL END IF * * Row-cyclic Jacobi SVD algorithm with column pivoting * EMPTSW = ( N*( N-1 ) ) / 2 NOTROT = 0 FASTR( 1 ) = ZERO * * A is represented in factored form A = A * diag(WORK), where diag(WORK) * is initialized to identity. WORK is updated during fast scaled * rotations. * DO 1868 q = 1, N WORK( q ) = ONE 1868 CONTINUE * * SWBAND = 3 *[TP] SWBAND is a tuning parameter [TP]. It is meaningful and effective * if DGESVJ is used as a computational routine in the preconditioned * Jacobi SVD algorithm DGESVJ. For sweeps i=1:SWBAND the procedure * works on pivots inside a band-like region around the diagonal. * The boundaries are determined dynamically, based on the number of * pivots above a threshold. * KBL = MIN( 8, N ) *[TP] KBL is a tuning parameter that defines the tile size in the * tiling of the p-q loops of pivot pairs. In general, an optimal * value of KBL depends on the matrix dimensions and on the * parameters of the computer's memory. * NBL = N / KBL IF( ( NBL*KBL ).NE.N )NBL = NBL + 1 * BLSKIP = KBL**2 *[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL. * ROWSKIP = MIN( 5, KBL ) *[TP] ROWSKIP is a tuning parameter. * LKAHEAD = 1 *[TP] LKAHEAD is a tuning parameter. * * Quasi block transformations, using the lower (upper) triangular * structure of the input matrix. The quasi-block-cycling usually * invokes cubic convergence. Big part of this cycle is done inside * canonical subspaces of dimensions less than M. * IF( ( LOWER .OR. UPPER ) .AND. ( N.GT.MAX( 64, 4*KBL ) ) ) THEN *[TP] The number of partition levels and the actual partition are * tuning parameters. N4 = N / 4 N2 = N / 2 N34 = 3*N4 IF( APPLV ) THEN q = 0 ELSE q = 1 END IF * IF( LOWER ) THEN * * This works very well on lower triangular matrices, in particular * in the framework of the preconditioned Jacobi SVD (xGEJSV). * The idea is simple: * [+ 0 0 0] Note that Jacobi transformations of [0 0] * [+ + 0 0] [0 0] * [+ + x 0] actually work on [x 0] [x 0] * [+ + x x] [x x]. [x x] * CALL DGSVJ0( JOBV, M-N34, N-N34, A( N34+1, N34+1 ), LDA, $ WORK( N34+1 ), SVA( N34+1 ), MVL, $ V( N34*q+1, N34+1 ), LDV, EPSLN, SFMIN, TOL, $ 2, WORK( N+1 ), LWORK-N, IERR ) * CALL DGSVJ0( JOBV, M-N2, N34-N2, A( N2+1, N2+1 ), LDA, $ WORK( N2+1 ), SVA( N2+1 ), MVL, $ V( N2*q+1, N2+1 ), LDV, EPSLN, SFMIN, TOL, 2, $ WORK( N+1 ), LWORK-N, IERR ) * CALL DGSVJ1( JOBV, M-N2, N-N2, N4, A( N2+1, N2+1 ), LDA, $ WORK( N2+1 ), SVA( N2+1 ), MVL, $ V( N2*q+1, N2+1 ), LDV, EPSLN, SFMIN, TOL, 1, $ WORK( N+1 ), LWORK-N, IERR ) * CALL DGSVJ0( JOBV, M-N4, N2-N4, A( N4+1, N4+1 ), LDA, $ WORK( N4+1 ), SVA( N4+1 ), MVL, $ V( N4*q+1, N4+1 ), LDV, EPSLN, SFMIN, TOL, 1, $ WORK( N+1 ), LWORK-N, IERR ) * CALL DGSVJ0( JOBV, M, N4, A, LDA, WORK, SVA, MVL, V, LDV, $ EPSLN, SFMIN, TOL, 1, WORK( N+1 ), LWORK-N, $ IERR ) * CALL DGSVJ1( JOBV, M, N2, N4, A, LDA, WORK, SVA, MVL, V, $ LDV, EPSLN, SFMIN, TOL, 1, WORK( N+1 ), $ LWORK-N, IERR ) * * ELSE IF( UPPER ) THEN * * CALL DGSVJ0( JOBV, N4, N4, A, LDA, WORK, SVA, MVL, V, LDV, $ EPSLN, SFMIN, TOL, 2, WORK( N+1 ), LWORK-N, $ IERR ) * CALL DGSVJ0( JOBV, N2, N4, A( 1, N4+1 ), LDA, WORK( N4+1 ), $ SVA( N4+1 ), MVL, V( N4*q+1, N4+1 ), LDV, $ EPSLN, SFMIN, TOL, 1, WORK( N+1 ), LWORK-N, $ IERR ) * CALL DGSVJ1( JOBV, N2, N2, N4, A, LDA, WORK, SVA, MVL, V, $ LDV, EPSLN, SFMIN, TOL, 1, WORK( N+1 ), $ LWORK-N, IERR ) * CALL DGSVJ0( JOBV, N2+N4, N4, A( 1, N2+1 ), LDA, $ WORK( N2+1 ), SVA( N2+1 ), MVL, $ V( N2*q+1, N2+1 ), LDV, EPSLN, SFMIN, TOL, 1, $ WORK( N+1 ), LWORK-N, IERR ) END IF * END IF * * .. Row-cyclic pivot strategy with de Rijk's pivoting .. * DO 1993 i = 1, NSWEEP * * .. go go go ... * MXAAPQ = ZERO MXSINJ = ZERO ISWROT = 0 * NOTROT = 0 PSKIPPED = 0 * * Each sweep is unrolled using KBL-by-KBL tiles over the pivot pairs * 1 <= p < q <= N. This is the first step toward a blocked implementation * of the rotations. New implementation, based on block transformations, * is under development. * DO 2000 ibr = 1, NBL * igl = ( ibr-1 )*KBL + 1 * DO 1002 ir1 = 0, MIN( LKAHEAD, NBL-ibr ) * igl = igl + ir1*KBL * DO 2001 p = igl, MIN( igl+KBL-1, N-1 ) * * .. de Rijk's pivoting * q = IDAMAX( N-p+1, SVA( p ), 1 ) + p - 1 IF( p.NE.q ) THEN CALL DSWAP( M, A( 1, p ), 1, A( 1, q ), 1 ) IF( RSVEC )CALL DSWAP( MVL, V( 1, p ), 1, $ V( 1, q ), 1 ) TEMP1 = SVA( p ) SVA( p ) = SVA( q ) SVA( q ) = TEMP1 TEMP1 = WORK( p ) WORK( p ) = WORK( q ) WORK( q ) = TEMP1 END IF * IF( ir1.EQ.0 ) THEN * * Column norms are periodically updated by explicit * norm computation. * Caveat: * Unfortunately, some BLAS implementations compute DNRM2(M,A(1,p),1) * as DSQRT(DDOT(M,A(1,p),1,A(1,p),1)), which may cause the result to * overflow for ||A(:,p)||_2 > DSQRT(overflow_threshold), and to * underflow for ||A(:,p)||_2 < DSQRT(underflow_threshold). * Hence, DNRM2 cannot be trusted, not even in the case when * the true norm is far from the under(over)flow boundaries. * If properly implemented DNRM2 is available, the IF-THEN-ELSE * below should read "AAPP = DNRM2( M, A(1,p), 1 ) * WORK(p)". * IF( ( SVA( p ).LT.ROOTBIG ) .AND. $ ( SVA( p ).GT.ROOTSFMIN ) ) THEN SVA( p ) = DNRM2( M, A( 1, p ), 1 )*WORK( p ) ELSE TEMP1 = ZERO AAPP = ONE CALL DLASSQ( M, A( 1, p ), 1, TEMP1, AAPP ) SVA( p ) = TEMP1*DSQRT( AAPP )*WORK( p ) END IF AAPP = SVA( p ) ELSE AAPP = SVA( p ) END IF * IF( AAPP.GT.ZERO ) THEN * PSKIPPED = 0 * DO 2002 q = p + 1, MIN( igl+KBL-1, N ) * AAQQ = SVA( q ) * IF( AAQQ.GT.ZERO ) THEN * AAPP0 = AAPP IF( AAQQ.GE.ONE ) THEN ROTOK = ( SMALL*AAPP ).LE.AAQQ IF( AAPP.LT.( BIG / AAQQ ) ) THEN AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1, $ q ), 1 )*WORK( p )*WORK( q ) / $ AAQQ ) / AAPP ELSE CALL DCOPY( M, A( 1, p ), 1, $ WORK( N+1 ), 1 ) CALL DLASCL( 'G', 0, 0, AAPP, $ WORK( p ), M, 1, $ WORK( N+1 ), LDA, IERR ) AAPQ = DDOT( M, WORK( N+1 ), 1, $ A( 1, q ), 1 )*WORK( q ) / AAQQ END IF ELSE ROTOK = AAPP.LE.( AAQQ / SMALL ) IF( AAPP.GT.( SMALL / AAQQ ) ) THEN AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1, $ q ), 1 )*WORK( p )*WORK( q ) / $ AAQQ ) / AAPP ELSE CALL DCOPY( M, A( 1, q ), 1, $ WORK( N+1 ), 1 ) CALL DLASCL( 'G', 0, 0, AAQQ, $ WORK( q ), M, 1, $ WORK( N+1 ), LDA, IERR ) AAPQ = DDOT( M, WORK( N+1 ), 1, $ A( 1, p ), 1 )*WORK( p ) / AAPP END IF END IF * MXAAPQ = MAX( MXAAPQ, DABS( AAPQ ) ) * * TO rotate or NOT to rotate, THAT is the question ... * IF( DABS( AAPQ ).GT.TOL ) THEN * * .. rotate *[RTD] ROTATED = ROTATED + ONE * IF( ir1.EQ.0 ) THEN NOTROT = 0 PSKIPPED = 0 ISWROT = ISWROT + 1 END IF * IF( ROTOK ) THEN * AQOAP = AAQQ / AAPP APOAQ = AAPP / AAQQ THETA = -HALF*DABS(AQOAP-APOAQ)/AAPQ * IF( DABS( THETA ).GT.BIGTHETA ) THEN * T = HALF / THETA FASTR( 3 ) = T*WORK( p ) / WORK( q ) FASTR( 4 ) = -T*WORK( q ) / $ WORK( p ) CALL DROTM( M, A( 1, p ), 1, $ A( 1, q ), 1, FASTR ) IF( RSVEC )CALL DROTM( MVL, $ V( 1, p ), 1, $ V( 1, q ), 1, $ FASTR ) SVA( q ) = AAQQ*DSQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ ) ) AAPP = AAPP*DSQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ ) ) MXSINJ = MAX( MXSINJ, DABS( T ) ) * ELSE * * .. choose correct signum for THETA and rotate * THSIGN = -DSIGN( ONE, AAPQ ) T = ONE / ( THETA+THSIGN* $ DSQRT( ONE+THETA*THETA ) ) CS = DSQRT( ONE / ( ONE+T*T ) ) SN = T*CS * MXSINJ = MAX( MXSINJ, DABS( SN ) ) SVA( q ) = AAQQ*DSQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ ) ) AAPP = AAPP*DSQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ ) ) * APOAQ = WORK( p ) / WORK( q ) AQOAP = WORK( q ) / WORK( p ) IF( WORK( p ).GE.ONE ) THEN IF( WORK( q ).GE.ONE ) THEN FASTR( 3 ) = T*APOAQ FASTR( 4 ) = -T*AQOAP WORK( p ) = WORK( p )*CS WORK( q ) = WORK( q )*CS CALL DROTM( M, A( 1, p ), 1, $ A( 1, q ), 1, $ FASTR ) IF( RSVEC )CALL DROTM( MVL, $ V( 1, p ), 1, V( 1, q ), $ 1, FASTR ) ELSE CALL DAXPY( M, -T*AQOAP, $ A( 1, q ), 1, $ A( 1, p ), 1 ) CALL DAXPY( M, CS*SN*APOAQ, $ A( 1, p ), 1, $ A( 1, q ), 1 ) WORK( p ) = WORK( p )*CS WORK( q ) = WORK( q ) / CS IF( RSVEC ) THEN CALL DAXPY( MVL, -T*AQOAP, $ V( 1, q ), 1, $ V( 1, p ), 1 ) CALL DAXPY( MVL, $ CS*SN*APOAQ, $ V( 1, p ), 1, $ V( 1, q ), 1 ) END IF END IF ELSE IF( WORK( q ).GE.ONE ) THEN CALL DAXPY( M, T*APOAQ, $ A( 1, p ), 1, $ A( 1, q ), 1 ) CALL DAXPY( M, -CS*SN*AQOAP, $ A( 1, q ), 1, $ A( 1, p ), 1 ) WORK( p ) = WORK( p ) / CS WORK( q ) = WORK( q )*CS IF( RSVEC ) THEN CALL DAXPY( MVL, T*APOAQ, $ V( 1, p ), 1, $ V( 1, q ), 1 ) CALL DAXPY( MVL, $ -CS*SN*AQOAP, $ V( 1, q ), 1, $ V( 1, p ), 1 ) END IF ELSE IF( WORK( p ).GE.WORK( q ) ) $ THEN CALL DAXPY( M, -T*AQOAP, $ A( 1, q ), 1, $ A( 1, p ), 1 ) CALL DAXPY( M, CS*SN*APOAQ, $ A( 1, p ), 1, $ A( 1, q ), 1 ) WORK( p ) = WORK( p )*CS WORK( q ) = WORK( q ) / CS IF( RSVEC ) THEN CALL DAXPY( MVL, $ -T*AQOAP, $ V( 1, q ), 1, $ V( 1, p ), 1 ) CALL DAXPY( MVL, $ CS*SN*APOAQ, $ V( 1, p ), 1, $ V( 1, q ), 1 ) END IF ELSE CALL DAXPY( M, T*APOAQ, $ A( 1, p ), 1, $ A( 1, q ), 1 ) CALL DAXPY( M, $ -CS*SN*AQOAP, $ A( 1, q ), 1, $ A( 1, p ), 1 ) WORK( p ) = WORK( p ) / CS WORK( q ) = WORK( q )*CS IF( RSVEC ) THEN CALL DAXPY( MVL, $ T*APOAQ, V( 1, p ), $ 1, V( 1, q ), 1 ) CALL DAXPY( MVL, $ -CS*SN*AQOAP, $ V( 1, q ), 1, $ V( 1, p ), 1 ) END IF END IF END IF END IF END IF * ELSE * .. have to use modified Gram-Schmidt like transformation CALL DCOPY( M, A( 1, p ), 1, $ WORK( N+1 ), 1 ) CALL DLASCL( 'G', 0, 0, AAPP, ONE, M, $ 1, WORK( N+1 ), LDA, $ IERR ) CALL DLASCL( 'G', 0, 0, AAQQ, ONE, M, $ 1, A( 1, q ), LDA, IERR ) TEMP1 = -AAPQ*WORK( p ) / WORK( q ) CALL DAXPY( M, TEMP1, WORK( N+1 ), 1, $ A( 1, q ), 1 ) CALL DLASCL( 'G', 0, 0, ONE, AAQQ, M, $ 1, A( 1, q ), LDA, IERR ) SVA( q ) = AAQQ*DSQRT( MAX( ZERO, $ ONE-AAPQ*AAPQ ) ) MXSINJ = MAX( MXSINJ, SFMIN ) END IF * END IF ROTOK THEN ... ELSE * * In the case of cancellation in updating SVA(q), SVA(p) * recompute SVA(q), SVA(p). * IF( ( SVA( q ) / AAQQ )**2.LE.ROOTEPS ) $ THEN IF( ( AAQQ.LT.ROOTBIG ) .AND. $ ( AAQQ.GT.ROOTSFMIN ) ) THEN SVA( q ) = DNRM2( M, A( 1, q ), 1 )* $ WORK( q ) ELSE T = ZERO AAQQ = ONE CALL DLASSQ( M, A( 1, q ), 1, T, $ AAQQ ) SVA( q ) = T*DSQRT( AAQQ )*WORK( q ) END IF END IF IF( ( AAPP / AAPP0 ).LE.ROOTEPS ) THEN IF( ( AAPP.LT.ROOTBIG ) .AND. $ ( AAPP.GT.ROOTSFMIN ) ) THEN AAPP = DNRM2( M, A( 1, p ), 1 )* $ WORK( p ) ELSE T = ZERO AAPP = ONE CALL DLASSQ( M, A( 1, p ), 1, T, $ AAPP ) AAPP = T*DSQRT( AAPP )*WORK( p ) END IF SVA( p ) = AAPP END IF * ELSE * A(:,p) and A(:,q) already numerically orthogonal IF( ir1.EQ.0 )NOTROT = NOTROT + 1 *[RTD] SKIPPED = SKIPPED + 1 PSKIPPED = PSKIPPED + 1 END IF ELSE * A(:,q) is zero column IF( ir1.EQ.0 )NOTROT = NOTROT + 1 PSKIPPED = PSKIPPED + 1 END IF * IF( ( i.LE.SWBAND ) .AND. $ ( PSKIPPED.GT.ROWSKIP ) ) THEN IF( ir1.EQ.0 )AAPP = -AAPP NOTROT = 0 GO TO 2103 END IF * 2002 CONTINUE * END q-LOOP * 2103 CONTINUE * bailed out of q-loop * SVA( p ) = AAPP * ELSE SVA( p ) = AAPP IF( ( ir1.EQ.0 ) .AND. ( AAPP.EQ.ZERO ) ) $ NOTROT = NOTROT + MIN( igl+KBL-1, N ) - p END IF * 2001 CONTINUE * end of the p-loop * end of doing the block ( ibr, ibr ) 1002 CONTINUE * end of ir1-loop * * ... go to the off diagonal blocks * igl = ( ibr-1 )*KBL + 1 * DO 2010 jbc = ibr + 1, NBL * jgl = ( jbc-1 )*KBL + 1 * * doing the block at ( ibr, jbc ) * IJBLSK = 0 DO 2100 p = igl, MIN( igl+KBL-1, N ) * AAPP = SVA( p ) IF( AAPP.GT.ZERO ) THEN * PSKIPPED = 0 * DO 2200 q = jgl, MIN( jgl+KBL-1, N ) * AAQQ = SVA( q ) IF( AAQQ.GT.ZERO ) THEN AAPP0 = AAPP * * .. M x 2 Jacobi SVD .. * * Safe Gram matrix computation * IF( AAQQ.GE.ONE ) THEN IF( AAPP.GE.AAQQ ) THEN ROTOK = ( SMALL*AAPP ).LE.AAQQ ELSE ROTOK = ( SMALL*AAQQ ).LE.AAPP END IF IF( AAPP.LT.( BIG / AAQQ ) ) THEN AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1, $ q ), 1 )*WORK( p )*WORK( q ) / $ AAQQ ) / AAPP ELSE CALL DCOPY( M, A( 1, p ), 1, $ WORK( N+1 ), 1 ) CALL DLASCL( 'G', 0, 0, AAPP, $ WORK( p ), M, 1, $ WORK( N+1 ), LDA, IERR ) AAPQ = DDOT( M, WORK( N+1 ), 1, $ A( 1, q ), 1 )*WORK( q ) / AAQQ END IF ELSE IF( AAPP.GE.AAQQ ) THEN ROTOK = AAPP.LE.( AAQQ / SMALL ) ELSE ROTOK = AAQQ.LE.( AAPP / SMALL ) END IF IF( AAPP.GT.( SMALL / AAQQ ) ) THEN AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1, $ q ), 1 )*WORK( p )*WORK( q ) / $ AAQQ ) / AAPP ELSE CALL DCOPY( M, A( 1, q ), 1, $ WORK( N+1 ), 1 ) CALL DLASCL( 'G', 0, 0, AAQQ, $ WORK( q ), M, 1, $ WORK( N+1 ), LDA, IERR ) AAPQ = DDOT( M, WORK( N+1 ), 1, $ A( 1, p ), 1 )*WORK( p ) / AAPP END IF END IF * MXAAPQ = MAX( MXAAPQ, DABS( AAPQ ) ) * * TO rotate or NOT to rotate, THAT is the question ... * IF( DABS( AAPQ ).GT.TOL ) THEN NOTROT = 0 *[RTD] ROTATED = ROTATED + 1 PSKIPPED = 0 ISWROT = ISWROT + 1 * IF( ROTOK ) THEN * AQOAP = AAQQ / AAPP APOAQ = AAPP / AAQQ THETA = -HALF*DABS(AQOAP-APOAQ)/AAPQ IF( AAQQ.GT.AAPP0 )THETA = -THETA * IF( DABS( THETA ).GT.BIGTHETA ) THEN T = HALF / THETA FASTR( 3 ) = T*WORK( p ) / WORK( q ) FASTR( 4 ) = -T*WORK( q ) / $ WORK( p ) CALL DROTM( M, A( 1, p ), 1, $ A( 1, q ), 1, FASTR ) IF( RSVEC )CALL DROTM( MVL, $ V( 1, p ), 1, $ V( 1, q ), 1, $ FASTR ) SVA( q ) = AAQQ*DSQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ ) ) AAPP = AAPP*DSQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ ) ) MXSINJ = MAX( MXSINJ, DABS( T ) ) ELSE * * .. choose correct signum for THETA and rotate * THSIGN = -DSIGN( ONE, AAPQ ) IF( AAQQ.GT.AAPP0 )THSIGN = -THSIGN T = ONE / ( THETA+THSIGN* $ DSQRT( ONE+THETA*THETA ) ) CS = DSQRT( ONE / ( ONE+T*T ) ) SN = T*CS MXSINJ = MAX( MXSINJ, DABS( SN ) ) SVA( q ) = AAQQ*DSQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ ) ) AAPP = AAPP*DSQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ ) ) * APOAQ = WORK( p ) / WORK( q ) AQOAP = WORK( q ) / WORK( p ) IF( WORK( p ).GE.ONE ) THEN * IF( WORK( q ).GE.ONE ) THEN FASTR( 3 ) = T*APOAQ FASTR( 4 ) = -T*AQOAP WORK( p ) = WORK( p )*CS WORK( q ) = WORK( q )*CS CALL DROTM( M, A( 1, p ), 1, $ A( 1, q ), 1, $ FASTR ) IF( RSVEC )CALL DROTM( MVL, $ V( 1, p ), 1, V( 1, q ), $ 1, FASTR ) ELSE CALL DAXPY( M, -T*AQOAP, $ A( 1, q ), 1, $ A( 1, p ), 1 ) CALL DAXPY( M, CS*SN*APOAQ, $ A( 1, p ), 1, $ A( 1, q ), 1 ) IF( RSVEC ) THEN CALL DAXPY( MVL, -T*AQOAP, $ V( 1, q ), 1, $ V( 1, p ), 1 ) CALL DAXPY( MVL, $ CS*SN*APOAQ, $ V( 1, p ), 1, $ V( 1, q ), 1 ) END IF WORK( p ) = WORK( p )*CS WORK( q ) = WORK( q ) / CS END IF ELSE IF( WORK( q ).GE.ONE ) THEN CALL DAXPY( M, T*APOAQ, $ A( 1, p ), 1, $ A( 1, q ), 1 ) CALL DAXPY( M, -CS*SN*AQOAP, $ A( 1, q ), 1, $ A( 1, p ), 1 ) IF( RSVEC ) THEN CALL DAXPY( MVL, T*APOAQ, $ V( 1, p ), 1, $ V( 1, q ), 1 ) CALL DAXPY( MVL, $ -CS*SN*AQOAP, $ V( 1, q ), 1, $ V( 1, p ), 1 ) END IF WORK( p ) = WORK( p ) / CS WORK( q ) = WORK( q )*CS ELSE IF( WORK( p ).GE.WORK( q ) ) $ THEN CALL DAXPY( M, -T*AQOAP, $ A( 1, q ), 1, $ A( 1, p ), 1 ) CALL DAXPY( M, CS*SN*APOAQ, $ A( 1, p ), 1, $ A( 1, q ), 1 ) WORK( p ) = WORK( p )*CS WORK( q ) = WORK( q ) / CS IF( RSVEC ) THEN CALL DAXPY( MVL, $ -T*AQOAP, $ V( 1, q ), 1, $ V( 1, p ), 1 ) CALL DAXPY( MVL, $ CS*SN*APOAQ, $ V( 1, p ), 1, $ V( 1, q ), 1 ) END IF ELSE CALL DAXPY( M, T*APOAQ, $ A( 1, p ), 1, $ A( 1, q ), 1 ) CALL DAXPY( M, $ -CS*SN*AQOAP, $ A( 1, q ), 1, $ A( 1, p ), 1 ) WORK( p ) = WORK( p ) / CS WORK( q ) = WORK( q )*CS IF( RSVEC ) THEN CALL DAXPY( MVL, $ T*APOAQ, V( 1, p ), $ 1, V( 1, q ), 1 ) CALL DAXPY( MVL, $ -CS*SN*AQOAP, $ V( 1, q ), 1, $ V( 1, p ), 1 ) END IF END IF END IF END IF END IF * ELSE IF( AAPP.GT.AAQQ ) THEN CALL DCOPY( M, A( 1, p ), 1, $ WORK( N+1 ), 1 ) CALL DLASCL( 'G', 0, 0, AAPP, ONE, $ M, 1, WORK( N+1 ), LDA, $ IERR ) CALL DLASCL( 'G', 0, 0, AAQQ, ONE, $ M, 1, A( 1, q ), LDA, $ IERR ) TEMP1 = -AAPQ*WORK( p ) / WORK( q ) CALL DAXPY( M, TEMP1, WORK( N+1 ), $ 1, A( 1, q ), 1 ) CALL DLASCL( 'G', 0, 0, ONE, AAQQ, $ M, 1, A( 1, q ), LDA, $ IERR ) SVA( q ) = AAQQ*DSQRT( MAX( ZERO, $ ONE-AAPQ*AAPQ ) ) MXSINJ = MAX( MXSINJ, SFMIN ) ELSE CALL DCOPY( M, A( 1, q ), 1, $ WORK( N+1 ), 1 ) CALL DLASCL( 'G', 0, 0, AAQQ, ONE, $ M, 1, WORK( N+1 ), LDA, $ IERR ) CALL DLASCL( 'G', 0, 0, AAPP, ONE, $ M, 1, A( 1, p ), LDA, $ IERR ) TEMP1 = -AAPQ*WORK( q ) / WORK( p ) CALL DAXPY( M, TEMP1, WORK( N+1 ), $ 1, A( 1, p ), 1 ) CALL DLASCL( 'G', 0, 0, ONE, AAPP, $ M, 1, A( 1, p ), LDA, $ IERR ) SVA( p ) = AAPP*DSQRT( MAX( ZERO, $ ONE-AAPQ*AAPQ ) ) MXSINJ = MAX( MXSINJ, SFMIN ) END IF END IF * END IF ROTOK THEN ... ELSE * * In the case of cancellation in updating SVA(q) * .. recompute SVA(q) IF( ( SVA( q ) / AAQQ )**2.LE.ROOTEPS ) $ THEN IF( ( AAQQ.LT.ROOTBIG ) .AND. $ ( AAQQ.GT.ROOTSFMIN ) ) THEN SVA( q ) = DNRM2( M, A( 1, q ), 1 )* $ WORK( q ) ELSE T = ZERO AAQQ = ONE CALL DLASSQ( M, A( 1, q ), 1, T, $ AAQQ ) SVA( q ) = T*DSQRT( AAQQ )*WORK( q ) END IF END IF IF( ( AAPP / AAPP0 )**2.LE.ROOTEPS ) THEN IF( ( AAPP.LT.ROOTBIG ) .AND. $ ( AAPP.GT.ROOTSFMIN ) ) THEN AAPP = DNRM2( M, A( 1, p ), 1 )* $ WORK( p ) ELSE T = ZERO AAPP = ONE CALL DLASSQ( M, A( 1, p ), 1, T, $ AAPP ) AAPP = T*DSQRT( AAPP )*WORK( p ) END IF SVA( p ) = AAPP END IF * end of OK rotation ELSE NOTROT = NOTROT + 1 *[RTD] SKIPPED = SKIPPED + 1 PSKIPPED = PSKIPPED + 1 IJBLSK = IJBLSK + 1 END IF ELSE NOTROT = NOTROT + 1 PSKIPPED = PSKIPPED + 1 IJBLSK = IJBLSK + 1 END IF * IF( ( i.LE.SWBAND ) .AND. ( IJBLSK.GE.BLSKIP ) ) $ THEN SVA( p ) = AAPP NOTROT = 0 GO TO 2011 END IF IF( ( i.LE.SWBAND ) .AND. $ ( PSKIPPED.GT.ROWSKIP ) ) THEN AAPP = -AAPP NOTROT = 0 GO TO 2203 END IF * 2200 CONTINUE * end of the q-loop 2203 CONTINUE * SVA( p ) = AAPP * ELSE * IF( AAPP.EQ.ZERO )NOTROT = NOTROT + $ MIN( jgl+KBL-1, N ) - jgl + 1 IF( AAPP.LT.ZERO )NOTROT = 0 * END IF * 2100 CONTINUE * end of the p-loop 2010 CONTINUE * end of the jbc-loop 2011 CONTINUE *2011 bailed out of the jbc-loop DO 2012 p = igl, MIN( igl+KBL-1, N ) SVA( p ) = DABS( SVA( p ) ) 2012 CONTINUE *** 2000 CONTINUE *2000 :: end of the ibr-loop * * .. update SVA(N) IF( ( SVA( N ).LT.ROOTBIG ) .AND. ( SVA( N ).GT.ROOTSFMIN ) ) $ THEN SVA( N ) = DNRM2( M, A( 1, N ), 1 )*WORK( N ) ELSE T = ZERO AAPP = ONE CALL DLASSQ( M, A( 1, N ), 1, T, AAPP ) SVA( N ) = T*DSQRT( AAPP )*WORK( N ) END IF * * Additional steering devices * IF( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR. $ ( ISWROT.LE.N ) ) )SWBAND = i * IF( ( i.GT.SWBAND+1 ) .AND. ( MXAAPQ.LT.DSQRT( DBLE( N ) )* $ TOL ) .AND. ( DBLE( N )*MXAAPQ*MXSINJ.LT.TOL ) ) THEN GO TO 1994 END IF * IF( NOTROT.GE.EMPTSW )GO TO 1994 * 1993 CONTINUE * end i=1:NSWEEP loop * * #:( Reaching this point means that the procedure has not converged. INFO = NSWEEP - 1 GO TO 1995 * 1994 CONTINUE * #:) Reaching this point means numerical convergence after the i-th * sweep. * INFO = 0 * #:) INFO = 0 confirms successful iterations. 1995 CONTINUE * * Sort the singular values and find how many are above * the underflow threshold. * N2 = 0 N4 = 0 DO 5991 p = 1, N - 1 q = IDAMAX( N-p+1, SVA( p ), 1 ) + p - 1 IF( p.NE.q ) THEN TEMP1 = SVA( p ) SVA( p ) = SVA( q ) SVA( q ) = TEMP1 TEMP1 = WORK( p ) WORK( p ) = WORK( q ) WORK( q ) = TEMP1 CALL DSWAP( M, A( 1, p ), 1, A( 1, q ), 1 ) IF( RSVEC )CALL DSWAP( MVL, V( 1, p ), 1, V( 1, q ), 1 ) END IF IF( SVA( p ).NE.ZERO ) THEN N4 = N4 + 1 IF( SVA( p )*SKL.GT.SFMIN )N2 = N2 + 1 END IF 5991 CONTINUE IF( SVA( N ).NE.ZERO ) THEN N4 = N4 + 1 IF( SVA( N )*SKL.GT.SFMIN )N2 = N2 + 1 END IF * * Normalize the left singular vectors. * IF( LSVEC .OR. UCTOL ) THEN DO 1998 p = 1, N2 CALL DSCAL( M, WORK( p ) / SVA( p ), A( 1, p ), 1 ) 1998 CONTINUE END IF * * Scale the product of Jacobi rotations (assemble the fast rotations). * IF( RSVEC ) THEN IF( APPLV ) THEN DO 2398 p = 1, N CALL DSCAL( MVL, WORK( p ), V( 1, p ), 1 ) 2398 CONTINUE ELSE DO 2399 p = 1, N TEMP1 = ONE / DNRM2( MVL, V( 1, p ), 1 ) CALL DSCAL( MVL, TEMP1, V( 1, p ), 1 ) 2399 CONTINUE END IF END IF * * Undo scaling, if necessary (and possible). IF( ( ( SKL.GT.ONE ) .AND. ( SVA( 1 ).LT.( BIG / SKL) ) ) $ .OR. ( ( SKL.LT.ONE ) .AND. ( SVA( MAX( N2, 1 ) ) .GT. $ ( SFMIN / SKL) ) ) ) THEN DO 2400 p = 1, N SVA( P ) = SKL*SVA( P ) 2400 CONTINUE SKL= ONE END IF * WORK( 1 ) = SKL * The singular values of A are SKL*SVA(1:N). If SKL.NE.ONE * then some of the singular values may overflow or underflow and * the spectrum is given in this factored representation. * WORK( 2 ) = DBLE( N4 ) * N4 is the number of computed nonzero singular values of A. * WORK( 3 ) = DBLE( N2 ) * N2 is the number of singular values of A greater than SFMIN. * If N2 \brief DGESVX computes the solution to system of linear equations A * X = B for GE matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGESVX + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, * EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, * WORK, IWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER EQUED, FACT, TRANS * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS * DOUBLE PRECISION RCOND * .. * .. Array Arguments .. * INTEGER IPIV( * ), IWORK( * ) * DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), * $ BERR( * ), C( * ), FERR( * ), R( * ), * $ WORK( * ), X( LDX, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGESVX uses the LU factorization to compute the solution to a real *> system of linear equations *> A * X = B, *> where A is an N-by-N matrix and X and B are N-by-NRHS matrices. *> *> Error bounds on the solution and a condition estimate are also *> provided. *> \endverbatim * *> \par Description: * ================= *> *> \verbatim *> *> The following steps are performed: *> *> 1. If FACT = 'E', real scaling factors are computed to equilibrate *> the system: *> TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B *> TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B *> TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B *> Whether or not the system will be equilibrated depends on the *> scaling of the matrix A, but if equilibration is used, A is *> overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') *> or diag(C)*B (if TRANS = 'T' or 'C'). *> *> 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the *> matrix A (after equilibration if FACT = 'E') as *> A = P * L * U, *> where P is a permutation matrix, L is a unit lower triangular *> matrix, and U is upper triangular. *> *> 3. 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. *> *> 4. The system of equations is solved for X using the factored form *> of A. *> *> 5. Iterative refinement is applied to improve the computed solution *> matrix and calculate error bounds and backward error estimates *> for it. *> *> 6. If equilibration was used, the matrix X is premultiplied by *> diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so *> that it solves the original system before equilibration. *> \endverbatim * * Arguments: * ========== * *> \param[in] FACT *> \verbatim *> FACT is CHARACTER*1 *> Specifies whether or not the factored form of the matrix A is *> supplied on entry, and if not, whether the matrix A should be *> equilibrated before it is factored. *> = 'F': On entry, AF and IPIV contain the factored form of A. *> If EQUED is not 'N', the matrix A has been *> equilibrated with scaling factors given by R and C. *> A, AF, and IPIV are not modified. *> = 'N': The matrix A will be copied to AF and factored. *> = 'E': The matrix A will be equilibrated if necessary, then *> copied to AF and factored. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is 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 (Transpose) *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of linear equations, i.e., the order of the *> matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrices B and X. NRHS >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is *> not 'N', then A must have been equilibrated by the scaling *> factors in R and/or C. A is not modified if FACT = 'F' or *> 'N', or if FACT = 'E' and EQUED = 'N' on exit. *> *> On exit, if EQUED .ne. 'N', A is scaled as follows: *> EQUED = 'R': A := diag(R) * A *> EQUED = 'C': A := A * diag(C) *> EQUED = 'B': A := diag(R) * A * diag(C). *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] AF *> \verbatim *> AF is DOUBLE PRECISION array, dimension (LDAF,N) *> If FACT = 'F', then AF is an input argument and on entry *> contains the factors L and U from the factorization *> A = P*L*U as computed by DGETRF. If EQUED .ne. 'N', then *> AF is the factored form of the equilibrated matrix A. *> *> If FACT = 'N', then AF is an output argument and on exit *> returns the factors L and U from the factorization A = P*L*U *> of the original matrix A. *> *> If FACT = 'E', then AF is an output argument and on exit *> returns the factors L and U from the factorization A = P*L*U *> of the equilibrated matrix A (see the description of A for *> the form of the equilibrated matrix). *> \endverbatim *> *> \param[in] LDAF *> \verbatim *> LDAF is INTEGER *> The leading dimension of the array AF. LDAF >= max(1,N). *> \endverbatim *> *> \param[in,out] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N) *> If FACT = 'F', then IPIV is an input argument and on entry *> contains the pivot indices from the factorization A = P*L*U *> as computed by DGETRF; row i of the matrix was interchanged *> with row IPIV(i). *> *> If FACT = 'N', then IPIV is an output argument and on exit *> contains the pivot indices from the factorization A = P*L*U *> of the original matrix A. *> *> If FACT = 'E', then IPIV is an output argument and on exit *> contains the pivot indices from the factorization A = P*L*U *> of the equilibrated matrix A. *> \endverbatim *> *> \param[in,out] EQUED *> \verbatim *> EQUED is CHARACTER*1 *> Specifies the form of equilibration that was done. *> = 'N': No equilibration (always true if FACT = 'N'). *> = 'R': Row equilibration, i.e., A has been premultiplied by *> diag(R). *> = 'C': Column equilibration, i.e., A has been postmultiplied *> by diag(C). *> = 'B': Both row and column equilibration, i.e., A has been *> replaced by diag(R) * A * diag(C). *> EQUED is an input argument if FACT = 'F'; otherwise, it is an *> output argument. *> \endverbatim *> *> \param[in,out] R *> \verbatim *> R is DOUBLE PRECISION array, dimension (N) *> The row scale factors for A. If EQUED = 'R' or 'B', A is *> multiplied on the left by diag(R); if EQUED = 'N' or 'C', R *> is not accessed. R is an input argument if FACT = 'F'; *> otherwise, R is an output argument. If FACT = 'F' and *> EQUED = 'R' or 'B', each element of R must be positive. *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (N) *> The column scale factors for A. If EQUED = 'C' or 'B', A is *> multiplied on the right by diag(C); if EQUED = 'N' or 'R', C *> is not accessed. C is an input argument if FACT = 'F'; *> otherwise, C is an output argument. If FACT = 'F' and *> EQUED = 'C' or 'B', each element of C must be positive. *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> On entry, the N-by-NRHS right hand side matrix B. *> On exit, *> if EQUED = 'N', B is not modified; *> if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by *> diag(R)*B; *> if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is *> overwritten by diag(C)*B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,NRHS) *> If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X *> to the original system of equations. Note that A and B are *> modified on exit if EQUED .ne. 'N', and the solution to the *> equilibrated system is inv(diag(C))*X if TRANS = 'N' and *> EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C' *> and EQUED = 'R' or 'B'. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the array X. LDX >= max(1,N). *> \endverbatim *> *> \param[out] RCOND *> \verbatim *> RCOND is DOUBLE PRECISION *> The estimate of the reciprocal condition number of the matrix *> A after equilibration (if done). 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. *> \endverbatim *> *> \param[out] FERR *> \verbatim *> FERR is 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. *> \endverbatim *> *> \param[out] BERR *> \verbatim *> BERR is 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). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (4*N) *> On exit, WORK(1) contains the reciprocal pivot growth *> factor norm(A)/norm(U). The "max absolute element" norm is *> used. If WORK(1) is much less than 1, then the stability *> of the LU factorization of the (equilibrated) matrix A *> could be poor. This also means that the solution X, condition *> estimator RCOND, and forward error bound FERR could be *> unreliable. If factorization fails with 0 WORK(1) contains the reciprocal pivot growth factor for the *> leading INFO columns of A. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, and i is *> <= N: U(i,i) is exactly zero. The factorization has *> been completed, 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. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date April 2012 * *> \ingroup doubleGEsolve * * ===================================================================== SUBROUTINE DGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, $ EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, $ WORK, IWORK, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * April 2012 * * .. Scalar Arguments .. CHARACTER EQUED, FACT, TRANS INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS DOUBLE PRECISION RCOND * .. * .. Array Arguments .. INTEGER IPIV( * ), IWORK( * ) DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), $ BERR( * ), C( * ), FERR( * ), R( * ), $ WORK( * ), X( LDX, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU CHARACTER NORM INTEGER I, INFEQU, J DOUBLE PRECISION AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN, $ ROWCND, RPVGRW, SMLNUM * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE, DLANTR EXTERNAL LSAME, DLAMCH, DLANGE, DLANTR * .. * .. External Subroutines .. EXTERNAL DGECON, DGEEQU, DGERFS, DGETRF, DGETRS, DLACPY, $ DLAQGE, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * INFO = 0 NOFACT = LSAME( FACT, 'N' ) EQUIL = LSAME( FACT, 'E' ) NOTRAN = LSAME( TRANS, 'N' ) IF( NOFACT .OR. EQUIL ) THEN EQUED = 'N' ROWEQU = .FALSE. COLEQU = .FALSE. ELSE ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) SMLNUM = DLAMCH( 'Safe minimum' ) BIGNUM = ONE / SMLNUM END IF * * Test the input parameters. * IF( .NOT.NOFACT .AND. .NOT.EQUIL .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( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. $ ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN INFO = -10 ELSE IF( ROWEQU ) THEN RCMIN = BIGNUM RCMAX = ZERO DO 10 J = 1, N RCMIN = MIN( RCMIN, R( J ) ) RCMAX = MAX( RCMAX, R( J ) ) 10 CONTINUE IF( RCMIN.LE.ZERO ) THEN INFO = -11 ELSE IF( N.GT.0 ) THEN ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) ELSE ROWCND = ONE END IF END IF IF( COLEQU .AND. INFO.EQ.0 ) THEN RCMIN = BIGNUM RCMAX = ZERO DO 20 J = 1, N RCMIN = MIN( RCMIN, C( J ) ) RCMAX = MAX( RCMAX, C( J ) ) 20 CONTINUE IF( RCMIN.LE.ZERO ) THEN INFO = -12 ELSE IF( N.GT.0 ) THEN COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) ELSE COLCND = ONE END IF END IF IF( INFO.EQ.0 ) THEN IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -14 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -16 END IF END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGESVX', -INFO ) RETURN END IF * IF( EQUIL ) THEN * * Compute row and column scalings to equilibrate the matrix A. * CALL DGEEQU( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFEQU ) IF( INFEQU.EQ.0 ) THEN * * Equilibrate the matrix. * CALL DLAQGE( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, $ EQUED ) ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) END IF END IF * * Scale the right hand side. * IF( NOTRAN ) THEN IF( ROWEQU ) THEN DO 40 J = 1, NRHS DO 30 I = 1, N B( I, J ) = R( I )*B( I, J ) 30 CONTINUE 40 CONTINUE END IF ELSE IF( COLEQU ) THEN DO 60 J = 1, NRHS DO 50 I = 1, N B( I, J ) = C( I )*B( I, J ) 50 CONTINUE 60 CONTINUE END IF * IF( NOFACT .OR. EQUIL ) THEN * * Compute the LU factorization of A. * CALL DLACPY( 'Full', N, N, A, LDA, AF, LDAF ) CALL DGETRF( N, N, AF, LDAF, IPIV, INFO ) * * Return if INFO is non-zero. * IF( INFO.GT.0 ) THEN * * Compute the reciprocal pivot growth factor of the * leading rank-deficient INFO columns of A. * RPVGRW = DLANTR( 'M', 'U', 'N', INFO, INFO, AF, LDAF, $ WORK ) IF( RPVGRW.EQ.ZERO ) THEN RPVGRW = ONE ELSE RPVGRW = DLANGE( 'M', N, INFO, A, LDA, WORK ) / RPVGRW END IF WORK( 1 ) = RPVGRW RCOND = ZERO RETURN END IF END IF * * Compute the norm of the matrix A and the * reciprocal pivot growth factor RPVGRW. * IF( NOTRAN ) THEN NORM = '1' ELSE NORM = 'I' END IF ANORM = DLANGE( NORM, N, N, A, LDA, WORK ) RPVGRW = DLANTR( 'M', 'U', 'N', N, N, AF, LDAF, WORK ) IF( RPVGRW.EQ.ZERO ) THEN RPVGRW = ONE ELSE RPVGRW = DLANGE( 'M', N, N, A, LDA, WORK ) / RPVGRW END IF * * Compute the reciprocal of the condition number of A. * CALL DGECON( NORM, N, AF, LDAF, ANORM, RCOND, WORK, IWORK, INFO ) * * Compute the solution matrix X. * CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) CALL DGETRS( TRANS, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO ) * * Use iterative refinement to improve the computed solution and * compute error bounds and backward error estimates for it. * CALL DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, $ LDX, FERR, BERR, WORK, IWORK, INFO ) * * Transform the solution matrix X to a solution of the original * system. * IF( NOTRAN ) THEN IF( COLEQU ) THEN DO 80 J = 1, NRHS DO 70 I = 1, N X( I, J ) = C( I )*X( I, J ) 70 CONTINUE 80 CONTINUE DO 90 J = 1, NRHS FERR( J ) = FERR( J ) / COLCND 90 CONTINUE END IF ELSE IF( ROWEQU ) THEN DO 110 J = 1, NRHS DO 100 I = 1, N X( I, J ) = R( I )*X( I, J ) 100 CONTINUE 110 CONTINUE DO 120 J = 1, NRHS FERR( J ) = FERR( J ) / ROWCND 120 CONTINUE END IF * WORK( 1 ) = RPVGRW * * Set INFO = N+1 if the matrix is singular to working precision. * IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) $ INFO = N + 1 RETURN * * End of DGESVX * END *> \brief \b DGETC2 computes the LU factorization with complete pivoting of the general n-by-n matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGETC2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGETC2( N, A, LDA, IPIV, JPIV, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, N * .. * .. Array Arguments .. * INTEGER IPIV( * ), JPIV( * ) * DOUBLE PRECISION A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGETC2 computes an LU factorization with complete pivoting of the *> n-by-n matrix A. The factorization has the form A = P * L * U * Q, *> where P and Q are permutation matrices, L is lower triangular with *> unit diagonal elements and U is upper triangular. *> *> This is the Level 2 BLAS algorithm. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA, N) *> On entry, the n-by-n matrix A to be factored. *> On exit, the factors L and U from the factorization *> A = P*L*U*Q; the unit diagonal elements of L are not stored. *> If U(k, k) appears to be less than SMIN, U(k, k) is given the *> value of SMIN, i.e., giving a nonsingular perturbed system. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] IPIV *> \verbatim *> IPIV is INTEGER array, dimension(N). *> The pivot indices; for 1 <= i <= N, row i of the *> matrix has been interchanged with row IPIV(i). *> \endverbatim *> *> \param[out] JPIV *> \verbatim *> JPIV is INTEGER array, dimension(N). *> The pivot indices; for 1 <= j <= N, column j of the *> matrix has been interchanged with column JPIV(j). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> > 0: if INFO = k, U(k, k) is likely to produce owerflow if *> we try to solve for x in Ax = b. So U is perturbed to *> avoid the overflow. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleGEauxiliary * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * * ===================================================================== SUBROUTINE DGETC2( N, A, LDA, IPIV, JPIV, INFO ) * * -- LAPACK auxiliary routine (version 3.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, N * .. * .. Array Arguments .. INTEGER IPIV( * ), JPIV( * ) DOUBLE PRECISION A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, IP, IPV, J, JP, JPV DOUBLE PRECISION BIGNUM, EPS, SMIN, SMLNUM, XMAX * .. * .. External Subroutines .. EXTERNAL DGER, DSWAP, DLABAD * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Set constants to control overflow * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) / EPS BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) * * Handle the case N=1 by itself * IF( N.EQ.1 ) THEN IPIV( 1 ) = 1 JPIV( 1 ) = 1 IF( ABS( A( 1, 1 ) ).LT.SMLNUM ) THEN INFO = 1 A( 1, 1 ) = SMLNUM END IF RETURN END IF * * Factorize A using complete pivoting. * Set pivots less than SMIN to SMIN. * DO 40 I = 1, N - 1 * * Find max element in matrix A * XMAX = ZERO DO 20 IP = I, N DO 10 JP = I, N IF( ABS( A( IP, JP ) ).GE.XMAX ) THEN XMAX = ABS( A( IP, JP ) ) IPV = IP JPV = JP END IF 10 CONTINUE 20 CONTINUE IF( I.EQ.1 ) $ SMIN = MAX( EPS*XMAX, SMLNUM ) * * Swap rows * IF( IPV.NE.I ) $ CALL DSWAP( N, A( IPV, 1 ), LDA, A( I, 1 ), LDA ) IPIV( I ) = IPV * * Swap columns * IF( JPV.NE.I ) $ CALL DSWAP( N, A( 1, JPV ), 1, A( 1, I ), 1 ) JPIV( I ) = JPV * * Check for singularity * IF( ABS( A( I, I ) ).LT.SMIN ) THEN INFO = I A( I, I ) = SMIN END IF DO 30 J = I + 1, N A( J, I ) = A( J, I ) / A( I, I ) 30 CONTINUE CALL DGER( N-I, N-I, -ONE, A( I+1, I ), 1, A( I, I+1 ), LDA, $ A( I+1, I+1 ), LDA ) 40 CONTINUE * IF( ABS( A( N, N ) ).LT.SMIN ) THEN INFO = N A( N, N ) = SMIN END IF * * Set last pivots to N * IPIV( N ) = N JPIV( N ) = N * RETURN * * End of DGETC2 * END *> \brief \b DGETF2 computes the LU factorization of a general m-by-n matrix using partial pivoting with row interchanges (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGETF2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is 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. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] IPIV *> \verbatim *> IPIV is 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). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is 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. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEcomputational * * ===================================================================== SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ) * .. * * ===================================================================== * * .. 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 *> \brief \b DGETRF * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGETRF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is 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. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] IPIV *> \verbatim *> IPIV is 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). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, 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. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEcomputational * * ===================================================================== SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, IINFO, J, JB, NB * .. * .. External Subroutines .. EXTERNAL DGEMM, DGETRF2, 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 DGETRF2( 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 DGETRF2( 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 *> \brief \b DGETRF2 * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * RECURSIVE SUBROUTINE DGETRF2( M, N, A, LDA, IPIV, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGETRF2 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 recursive version of the algorithm. It divides *> the matrix into four submatrices: *> *> [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2 *> A = [ -----|----- ] with n1 = min(m,n)/2 *> [ A21 | A22 ] n2 = n-n1 *> *> [ A11 ] *> The subroutine calls itself to factor [ --- ], *> [ A12 ] *> [ A12 ] *> do the swaps on [ --- ], solve A12, update A22, *> [ A22 ] *> *> then calls itself to factor A22 and do the swaps on A21. *> *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is 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. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] IPIV *> \verbatim *> IPIV is 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). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, 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. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleGEcomputational * * ===================================================================== RECURSIVE SUBROUTINE DGETRF2( M, N, A, LDA, IPIV, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. DOUBLE PRECISION SFMIN, TEMP INTEGER I, IINFO, N1, N2 * .. * .. External Functions .. DOUBLE PRECISION DLAMCH INTEGER IDAMAX EXTERNAL DLAMCH, IDAMAX * .. * .. External Subroutines .. EXTERNAL DGEMM, DSCAL, DLASWP, DTRSM, 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( 'DGETRF2', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN IF ( M.EQ.1 ) THEN * * Use unblocked code for one row case * Just need to handle IPIV and INFO * IPIV( 1 ) = 1 IF ( A(1,1).EQ.ZERO ) $ INFO = 1 * ELSE IF( N.EQ.1 ) THEN * * Use unblocked code for one column case * * * Compute machine safe minimum * SFMIN = DLAMCH('S') * * Find pivot and test for singularity * I = IDAMAX( M, A( 1, 1 ), 1 ) IPIV( 1 ) = I IF( A( I, 1 ).NE.ZERO ) THEN * * Apply the interchange * IF( I.NE.1 ) THEN TEMP = A( 1, 1 ) A( 1, 1 ) = A( I, 1 ) A( I, 1 ) = TEMP END IF * * Compute elements 2:M of the column * IF( ABS(A( 1, 1 )) .GE. SFMIN ) THEN CALL DSCAL( M-1, ONE / A( 1, 1 ), A( 2, 1 ), 1 ) ELSE DO 10 I = 1, M-1 A( 1+I, 1 ) = A( 1+I, 1 ) / A( 1, 1 ) 10 CONTINUE END IF * ELSE INFO = 1 END IF * ELSE * * Use recursive code * N1 = MIN( M, N ) / 2 N2 = N-N1 * * [ A11 ] * Factor [ --- ] * [ A21 ] * CALL DGETRF2( M, N1, A, LDA, IPIV, IINFO ) IF ( INFO.EQ.0 .AND. IINFO.GT.0 ) $ INFO = IINFO * * [ A12 ] * Apply interchanges to [ --- ] * [ A22 ] * CALL DLASWP( N2, A( 1, N1+1 ), LDA, 1, N1, IPIV, 1 ) * * Solve A12 * CALL DTRSM( 'L', 'L', 'N', 'U', N1, N2, ONE, A, LDA, $ A( 1, N1+1 ), LDA ) * * Update A22 * CALL DGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( N1+1, 1 ), LDA, $ A( 1, N1+1 ), LDA, ONE, A( N1+1, N1+1 ), LDA ) * * Factor A22 * CALL DGETRF2( M-N1, N2, A( N1+1, N1+1 ), LDA, IPIV( N1+1 ), $ IINFO ) * * Adjust INFO and the pivot indices * IF ( INFO.EQ.0 .AND. IINFO.GT.0 ) $ INFO = IINFO + N1 DO 20 I = N1+1, MIN( M, N ) IPIV( I ) = IPIV( I ) + N1 20 CONTINUE * * Apply interchanges to A21 * CALL DLASWP( N1, A( 1, 1 ), LDA, N1+1, MIN( M, N), IPIV, 1 ) * END IF RETURN * * End of DGETRF2 * END *> \brief \b DGETRI * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGETRI + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, N * .. * .. Array Arguments .. * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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). *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is 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. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N) *> The pivot indices from DGETRF; for 1<=i<=N, row i of the *> matrix was interchanged with row IPIV(i). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO=0, then WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, U(i,i) is exactly zero; the matrix is *> singular and its inverse could not be computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEcomputational * * ===================================================================== SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * ===================================================================== * * .. 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 *> \brief \b DGETRS * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGETRS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, LDA, LDB, N, NRHS * .. * .. Array Arguments .. * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGETRS solves a system of linear equations *> A * X = B or A**T * X = B *> with a general N-by-N matrix A using the LU factorization computed *> by DGETRF. *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> Specifies the form of the system of equations: *> = 'N': A * X = B (No transpose) *> = 'T': A**T* X = B (Transpose) *> = 'C': A**T* X = B (Conjugate transpose = Transpose) *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrix B. NRHS >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The factors L and U from the factorization A = P*L*U *> as computed by DGETRF. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N) *> The pivot indices from DGETRF; for 1<=i<=N, row i of the *> matrix was interchanged with row IPIV(i). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> On entry, the right hand side matrix B. *> On exit, the solution matrix X. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEcomputational * * ===================================================================== SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER TRANS INTEGER INFO, LDA, LDB, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * ===================================================================== * * .. 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**T * X = B. * * Solve U**T *X = B, overwriting B with X. * CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, $ ONE, A, LDA, B, LDB ) * * Solve L**T *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 *> \brief \b DGGBAK * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGGBAK + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, * LDV, INFO ) * * .. Scalar Arguments .. * CHARACTER JOB, SIDE * INTEGER IHI, ILO, INFO, LDV, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION LSCALE( * ), RSCALE( * ), V( LDV, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is 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. *> \endverbatim *> *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'R': V contains right eigenvectors; *> = 'L': V contains left eigenvectors. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of rows of the matrix V. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> The integers ILO and IHI determined by DGGBAL. *> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. *> \endverbatim *> *> \param[in] LSCALE *> \verbatim *> LSCALE is 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. *> \endverbatim *> *> \param[in] RSCALE *> \verbatim *> RSCALE is 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. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of columns of the matrix V. M >= 0. *> \endverbatim *> *> \param[in,out] V *> \verbatim *> V is 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. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the matrix V. LDV >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGBcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> See R.C. Ward, Balancing the generalized eigenvalue problem, *> SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. *> \endverbatim *> * ===================================================================== SUBROUTINE DGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, $ LDV, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER JOB, SIDE INTEGER IHI, ILO, INFO, LDV, M, N * .. * .. Array Arguments .. DOUBLE PRECISION LSCALE( * ), RSCALE( * ), V( LDV, * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL LEFTV, RIGHTV INTEGER I, K * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DSCAL, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, INT * .. * .. 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 = INT(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 = INT(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 = INT(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 = INT(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 *> \brief \b DGGBAL * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGGBAL + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, * RSCALE, WORK, INFO ) * * .. Scalar Arguments .. * CHARACTER JOB * INTEGER IHI, ILO, INFO, LDA, LDB, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), LSCALE( * ), * $ RSCALE( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is 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. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A and B. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is 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. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is 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. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[out] IHI *> \verbatim *> IHI is 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. *> \endverbatim *> *> \param[out] LSCALE *> \verbatim *> LSCALE is 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. *> \endverbatim *> *> \param[out] RSCALE *> \verbatim *> RSCALE is 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. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION 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'. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGBcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> See R.C. WARD, Balancing the generalized eigenvalue problem, *> SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. *> \endverbatim *> * ===================================================================== SUBROUTINE DGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, $ RSCALE, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER JOB INTEGER IHI, ILO, INFO, LDA, LDB, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), LSCALE( * ), $ RSCALE( * ), WORK( * ) * .. * * ===================================================================== * * .. 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 = INT(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 = INT(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 *> \brief DGGES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGGES + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, * SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, * LDVSR, WORK, LWORK, BWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBVSL, JOBVSR, SORT * INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM * .. * .. Array Arguments .. * LOGICAL BWORK( * ) * DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), * $ B( LDB, * ), BETA( * ), VSL( LDVSL, * ), * $ VSR( LDVSR, * ), WORK( * ) * .. * .. Function Arguments .. * LOGICAL SELCTG * EXTERNAL SELCTG * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGGES computes for a pair of N-by-N real nonsymmetric matrices (A,B), *> the generalized eigenvalues, the generalized real Schur form (S,T), *> optionally, the left and/or right matrices of Schur vectors (VSL and *> VSR). This gives the generalized Schur factorization *> *> (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T ) *> *> Optionally, it also orders the eigenvalues so that a selected cluster *> of eigenvalues appears in the leading diagonal blocks of the upper *> quasi-triangular matrix S and the upper triangular matrix T.The *> leading columns of VSL and VSR then form an orthonormal basis for the *> corresponding left and right eigenspaces (deflating subspaces). *> *> (If only the generalized eigenvalues are needed, use the driver *> DGGEV instead, which is faster.) *> *> A generalized eigenvalue for a pair of matrices (A,B) is a scalar w *> or a ratio alpha/beta = w, such that A - w*B is singular. It is *> usually represented as the pair (alpha,beta), as there is a *> reasonable interpretation for beta=0 or both being zero. *> *> A pair of matrices (S,T) is in generalized real Schur form if T is *> upper triangular with non-negative diagonal and S is block upper *> triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond *> to real generalized eigenvalues, while 2-by-2 blocks of S will be *> "standardized" by making the corresponding elements of T have the *> form: *> [ a 0 ] *> [ 0 b ] *> *> and the pair of corresponding 2-by-2 blocks in S and T will have a *> complex conjugate pair of generalized eigenvalues. *> *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBVSL *> \verbatim *> JOBVSL is CHARACTER*1 *> = 'N': do not compute the left Schur vectors; *> = 'V': compute the left Schur vectors. *> \endverbatim *> *> \param[in] JOBVSR *> \verbatim *> JOBVSR is CHARACTER*1 *> = 'N': do not compute the right Schur vectors; *> = 'V': compute the right Schur vectors. *> \endverbatim *> *> \param[in] SORT *> \verbatim *> SORT is CHARACTER*1 *> Specifies whether or not to order the eigenvalues on the *> diagonal of the generalized Schur form. *> = 'N': Eigenvalues are not ordered; *> = 'S': Eigenvalues are ordered (see SELCTG); *> \endverbatim *> *> \param[in] SELCTG *> \verbatim *> SELCTG is a LOGICAL FUNCTION of three DOUBLE PRECISION arguments *> SELCTG must be declared EXTERNAL in the calling subroutine. *> If SORT = 'N', SELCTG is not referenced. *> If SORT = 'S', SELCTG is used to select eigenvalues to sort *> to the top left of the Schur form. *> An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if *> SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either *> one of a complex conjugate pair of eigenvalues is selected, *> then both complex eigenvalues are selected. *> *> Note that in the ill-conditioned case, a selected complex *> eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j), *> BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2 *> in this case. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A, B, VSL, and VSR. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA, N) *> On entry, the first of the pair of matrices. *> On exit, A has been overwritten by its generalized Schur *> form S. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB, N) *> On entry, the second of the pair of matrices. *> On exit, B has been overwritten by its generalized Schur *> form T. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] SDIM *> \verbatim *> SDIM is INTEGER *> If SORT = 'N', SDIM = 0. *> If SORT = 'S', SDIM = number of eigenvalues (after sorting) *> for which SELCTG is true. (Complex conjugate pairs for which *> SELCTG is true for either eigenvalue count as 2.) *> \endverbatim *> *> \param[out] ALPHAR *> \verbatim *> ALPHAR is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] ALPHAI *> \verbatim *> ALPHAI is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] BETA *> \verbatim *> BETA is DOUBLE PRECISION array, dimension (N) *> On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will *> be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i, *> and BETA(j),j=1,...,N are the diagonals of the complex Schur *> form (S,T) that would result if the 2-by-2 diagonal blocks of *> the real Schur form of (A,B) were further reduced to *> triangular form using 2-by-2 complex unitary transformations. *> If ALPHAI(j) is zero, then the j-th eigenvalue is real; if *> positive, then the j-th and (j+1)-st eigenvalues are a *> complex conjugate pair, with ALPHAI(j+1) negative. *> *> Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) *> may easily over- or underflow, and BETA(j) may even be zero. *> Thus, the user should avoid naively computing the ratio. *> However, ALPHAR and ALPHAI will be always less than and *> usually comparable with norm(A) in magnitude, and BETA always *> less than and usually comparable with norm(B). *> \endverbatim *> *> \param[out] VSL *> \verbatim *> VSL is DOUBLE PRECISION array, dimension (LDVSL,N) *> If JOBVSL = 'V', VSL will contain the left Schur vectors. *> Not referenced if JOBVSL = 'N'. *> \endverbatim *> *> \param[in] LDVSL *> \verbatim *> LDVSL is INTEGER *> The leading dimension of the matrix VSL. LDVSL >=1, and *> if JOBVSL = 'V', LDVSL >= N. *> \endverbatim *> *> \param[out] VSR *> \verbatim *> VSR is DOUBLE PRECISION array, dimension (LDVSR,N) *> If JOBVSR = 'V', VSR will contain the right Schur vectors. *> Not referenced if JOBVSR = 'N'. *> \endverbatim *> *> \param[in] LDVSR *> \verbatim *> LDVSR is INTEGER *> The leading dimension of the matrix VSR. LDVSR >= 1, and *> if JOBVSR = 'V', LDVSR >= N. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. *> If N = 0, LWORK >= 1, else LWORK >= 8*N+16. *> For good performance , LWORK must generally be larger. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error *> message related to LWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] BWORK *> \verbatim *> BWORK is LOGICAL array, dimension (N) *> Not referenced if SORT = 'N'. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> = 1,...,N: *> The QZ iteration failed. (A,B) are not in Schur *> form, but ALPHAR(j), ALPHAI(j), and BETA(j) should *> be correct for j=INFO+1,...,N. *> > N: =N+1: other than QZ iteration failed in DHGEQZ. *> =N+2: after reordering, roundoff changed values of *> some complex eigenvalues so that leading *> eigenvalues in the Generalized Schur form no *> longer satisfy SELCTG=.TRUE. This could also *> be caused due to scaling. *> =N+3: reordering failed in DTGSEN. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEeigen * * ===================================================================== SUBROUTINE DGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, $ SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, $ LDVSR, WORK, LWORK, BWORK, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER JOBVSL, JOBVSR, SORT INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM * .. * .. Array Arguments .. LOGICAL BWORK( * ) DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), $ B( LDB, * ), BETA( * ), VSL( LDVSL, * ), $ VSR( LDVSR, * ), WORK( * ) * .. * .. Function Arguments .. LOGICAL SELCTG EXTERNAL SELCTG * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL, $ LQUERY, LST2SL, WANTST INTEGER I, ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, $ ILO, IP, IRIGHT, IROWS, ITAU, IWRK, MAXWRK, $ MINWRK DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PVSL, $ PVSR, SAFMAX, SAFMIN, SMLNUM * .. * .. Local Arrays .. INTEGER IDUM( 1 ) DOUBLE PRECISION DIF( 2 ) * .. * .. External Subroutines .. EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLABAD, $ DLACPY, DLASCL, DLASET, DORGQR, DORMQR, DTGSEN, $ XERBLA * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * * Decode the input arguments * IF( LSAME( JOBVSL, 'N' ) ) THEN IJOBVL = 1 ILVSL = .FALSE. ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN IJOBVL = 2 ILVSL = .TRUE. ELSE IJOBVL = -1 ILVSL = .FALSE. END IF * IF( LSAME( JOBVSR, 'N' ) ) THEN IJOBVR = 1 ILVSR = .FALSE. ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN IJOBVR = 2 ILVSR = .TRUE. ELSE IJOBVR = -1 ILVSR = .FALSE. END IF * WANTST = LSAME( SORT, 'S' ) * * Test the input arguments * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) IF( IJOBVL.LE.0 ) THEN INFO = -1 ELSE IF( IJOBVR.LE.0 ) THEN INFO = -2 ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) 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( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN INFO = -15 ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN INFO = -17 END IF * * Compute workspace * (Note: Comments in the code beginning "Workspace:" describe the * minimal amount of workspace needed at that point in the code, * as well as the preferred amount for good performance. * NB refers to the optimal block size for the immediately * following subroutine, as returned by ILAENV.) * IF( INFO.EQ.0 ) THEN IF( N.GT.0 )THEN MINWRK = MAX( 8*N, 6*N + 16 ) MAXWRK = MINWRK - N + $ N*ILAENV( 1, 'DGEQRF', ' ', N, 1, N, 0 ) MAXWRK = MAX( MAXWRK, MINWRK - N + $ N*ILAENV( 1, 'DORMQR', ' ', N, 1, N, -1 ) ) IF( ILVSL ) THEN MAXWRK = MAX( MAXWRK, MINWRK - N + $ N*ILAENV( 1, 'DORGQR', ' ', N, 1, N, -1 ) ) END IF ELSE MINWRK = 1 MAXWRK = 1 END IF WORK( 1 ) = MAXWRK * IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) $ INFO = -19 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGGES ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN SDIM = 0 RETURN END IF * * Get machine constants * EPS = DLAMCH( 'P' ) SAFMIN = DLAMCH( 'S' ) SAFMAX = ONE / SAFMIN CALL DLABAD( SAFMIN, SAFMAX ) SMLNUM = SQRT( SAFMIN ) / EPS BIGNUM = ONE / SMLNUM * * Scale A if max element outside range [SMLNUM,BIGNUM] * ANRM = DLANGE( 'M', N, N, A, LDA, WORK ) ILASCL = .FALSE. IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN ANRMTO = SMLNUM ILASCL = .TRUE. ELSE IF( ANRM.GT.BIGNUM ) THEN ANRMTO = BIGNUM ILASCL = .TRUE. END IF IF( ILASCL ) $ CALL DLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR ) * * Scale B if max element outside range [SMLNUM,BIGNUM] * BNRM = DLANGE( 'M', N, N, B, LDB, WORK ) ILBSCL = .FALSE. IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN BNRMTO = SMLNUM ILBSCL = .TRUE. ELSE IF( BNRM.GT.BIGNUM ) THEN BNRMTO = BIGNUM ILBSCL = .TRUE. END IF IF( ILBSCL ) $ CALL DLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR ) * * Permute the matrix to make it more nearly triangular * (Workspace: need 6*N + 2*N space for storing balancing factors) * ILEFT = 1 IRIGHT = N + 1 IWRK = IRIGHT + N CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ), $ WORK( IRIGHT ), WORK( IWRK ), IERR ) * * Reduce B to triangular form (QR decomposition of B) * (Workspace: need N, prefer N*NB) * IROWS = IHI + 1 - ILO ICOLS = N + 1 - ILO ITAU = IWRK IWRK = ITAU + IROWS CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), $ WORK( IWRK ), LWORK+1-IWRK, IERR ) * * Apply the orthogonal transformation to matrix A * (Workspace: need N, prefer N*NB) * CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ), $ LWORK+1-IWRK, IERR ) * * Initialize VSL * (Workspace: need N, prefer N*NB) * IF( ILVSL ) THEN CALL DLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL ) IF( IROWS.GT.1 ) THEN CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, $ VSL( ILO+1, ILO ), LDVSL ) END IF CALL DORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL, $ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR ) END IF * * Initialize VSR * IF( ILVSR ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR ) * * Reduce to generalized Hessenberg form * (Workspace: none needed) * CALL DGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL, $ LDVSL, VSR, LDVSR, IERR ) * * Perform QZ algorithm, computing Schur vectors if desired * (Workspace: need N) * IWRK = ITAU CALL DHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, $ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, $ WORK( IWRK ), LWORK+1-IWRK, IERR ) IF( IERR.NE.0 ) THEN IF( IERR.GT.0 .AND. IERR.LE.N ) THEN INFO = IERR ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN INFO = IERR - N ELSE INFO = N + 1 END IF GO TO 50 END IF * * Sort eigenvalues ALPHA/BETA if desired * (Workspace: need 4*N+16 ) * SDIM = 0 IF( WANTST ) THEN * * Undo scaling on eigenvalues before SELCTGing * IF( ILASCL ) THEN CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, $ IERR ) CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, $ IERR ) END IF IF( ILBSCL ) $ CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR ) * * Select eigenvalues * DO 10 I = 1, N BWORK( I ) = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) ) 10 CONTINUE * CALL DTGSEN( 0, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB, ALPHAR, $ ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, SDIM, PVSL, $ PVSR, DIF, WORK( IWRK ), LWORK-IWRK+1, IDUM, 1, $ IERR ) IF( IERR.EQ.1 ) $ INFO = N + 3 * END IF * * Apply back-permutation to VSL and VSR * (Workspace: none needed) * IF( ILVSL ) $ CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ), $ WORK( IRIGHT ), N, VSL, LDVSL, IERR ) * IF( ILVSR ) $ CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ), $ WORK( IRIGHT ), N, VSR, LDVSR, IERR ) * * Check if unscaling would cause over/underflow, if so, rescale * (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of * B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I) * IF( ILASCL ) THEN DO 20 I = 1, N IF( ALPHAI( I ).NE.ZERO ) THEN IF( ( ALPHAR( I ) / SAFMAX ).GT.( ANRMTO / ANRM ) .OR. $ ( SAFMIN / ALPHAR( I ) ).GT.( ANRM / ANRMTO ) ) THEN WORK( 1 ) = ABS( A( I, I ) / ALPHAR( I ) ) BETA( I ) = BETA( I )*WORK( 1 ) ALPHAR( I ) = ALPHAR( I )*WORK( 1 ) ALPHAI( I ) = ALPHAI( I )*WORK( 1 ) ELSE IF( ( ALPHAI( I ) / SAFMAX ).GT. $ ( ANRMTO / ANRM ) .OR. $ ( SAFMIN / ALPHAI( I ) ).GT.( ANRM / ANRMTO ) ) $ THEN WORK( 1 ) = ABS( A( I, I+1 ) / ALPHAI( I ) ) BETA( I ) = BETA( I )*WORK( 1 ) ALPHAR( I ) = ALPHAR( I )*WORK( 1 ) ALPHAI( I ) = ALPHAI( I )*WORK( 1 ) END IF END IF 20 CONTINUE END IF * IF( ILBSCL ) THEN DO 30 I = 1, N IF( ALPHAI( I ).NE.ZERO ) THEN IF( ( BETA( I ) / SAFMAX ).GT.( BNRMTO / BNRM ) .OR. $ ( SAFMIN / BETA( I ) ).GT.( BNRM / BNRMTO ) ) THEN WORK( 1 ) = ABS( B( I, I ) / BETA( I ) ) BETA( I ) = BETA( I )*WORK( 1 ) ALPHAR( I ) = ALPHAR( I )*WORK( 1 ) ALPHAI( I ) = ALPHAI( I )*WORK( 1 ) END IF END IF 30 CONTINUE END IF * * Undo scaling * IF( ILASCL ) THEN CALL DLASCL( 'H', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR ) CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR ) CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR ) END IF * IF( ILBSCL ) THEN CALL DLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR ) CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR ) END IF * IF( WANTST ) THEN * * Check if reordering is correct * LASTSL = .TRUE. LST2SL = .TRUE. SDIM = 0 IP = 0 DO 40 I = 1, N CURSL = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) ) IF( ALPHAI( I ).EQ.ZERO ) THEN IF( CURSL ) $ SDIM = SDIM + 1 IP = 0 IF( CURSL .AND. .NOT.LASTSL ) $ INFO = N + 2 ELSE IF( IP.EQ.1 ) THEN * * Last eigenvalue of conjugate pair * CURSL = CURSL .OR. LASTSL LASTSL = CURSL IF( CURSL ) $ SDIM = SDIM + 2 IP = -1 IF( CURSL .AND. .NOT.LST2SL ) $ INFO = N + 2 ELSE * * First eigenvalue of conjugate pair * IP = 1 END IF END IF LST2SL = LASTSL LASTSL = CURSL 40 CONTINUE * END IF * 50 CONTINUE * WORK( 1 ) = MAXWRK * RETURN * * End of DGGES * END *> \brief DGGESX computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGGESX + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, * B, LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, * VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, IWORK, * LIWORK, BWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBVSL, JOBVSR, SENSE, SORT * INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LIWORK, LWORK, N, * $ SDIM * .. * .. Array Arguments .. * LOGICAL BWORK( * ) * INTEGER IWORK( * ) * DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), * $ B( LDB, * ), BETA( * ), RCONDE( 2 ), * $ RCONDV( 2 ), VSL( LDVSL, * ), VSR( LDVSR, * ), * $ WORK( * ) * .. * .. Function Arguments .. * LOGICAL SELCTG * EXTERNAL SELCTG * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGGESX computes for a pair of N-by-N real nonsymmetric matrices *> (A,B), the generalized eigenvalues, the real Schur form (S,T), and, *> optionally, the left and/or right matrices of Schur vectors (VSL and *> VSR). This gives the generalized Schur factorization *> *> (A,B) = ( (VSL) S (VSR)**T, (VSL) T (VSR)**T ) *> *> Optionally, it also orders the eigenvalues so that a selected cluster *> of eigenvalues appears in the leading diagonal blocks of the upper *> quasi-triangular matrix S and the upper triangular matrix T; computes *> a reciprocal condition number for the average of the selected *> eigenvalues (RCONDE); and computes a reciprocal condition number for *> the right and left deflating subspaces corresponding to the selected *> eigenvalues (RCONDV). The leading columns of VSL and VSR then form *> an orthonormal basis for the corresponding left and right eigenspaces *> (deflating subspaces). *> *> A generalized eigenvalue for a pair of matrices (A,B) is a scalar w *> or a ratio alpha/beta = w, such that A - w*B is singular. It is *> usually represented as the pair (alpha,beta), as there is a *> reasonable interpretation for beta=0 or for both being zero. *> *> A pair of matrices (S,T) is in generalized real Schur form if T is *> upper triangular with non-negative diagonal and S is block upper *> triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond *> to real generalized eigenvalues, while 2-by-2 blocks of S will be *> "standardized" by making the corresponding elements of T have the *> form: *> [ a 0 ] *> [ 0 b ] *> *> and the pair of corresponding 2-by-2 blocks in S and T will have a *> complex conjugate pair of generalized eigenvalues. *> *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBVSL *> \verbatim *> JOBVSL is CHARACTER*1 *> = 'N': do not compute the left Schur vectors; *> = 'V': compute the left Schur vectors. *> \endverbatim *> *> \param[in] JOBVSR *> \verbatim *> JOBVSR is CHARACTER*1 *> = 'N': do not compute the right Schur vectors; *> = 'V': compute the right Schur vectors. *> \endverbatim *> *> \param[in] SORT *> \verbatim *> SORT is CHARACTER*1 *> Specifies whether or not to order the eigenvalues on the *> diagonal of the generalized Schur form. *> = 'N': Eigenvalues are not ordered; *> = 'S': Eigenvalues are ordered (see SELCTG). *> \endverbatim *> *> \param[in] SELCTG *> \verbatim *> SELCTG is a LOGICAL FUNCTION of three DOUBLE PRECISION arguments *> SELCTG must be declared EXTERNAL in the calling subroutine. *> If SORT = 'N', SELCTG is not referenced. *> If SORT = 'S', SELCTG is used to select eigenvalues to sort *> to the top left of the Schur form. *> An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if *> SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either *> one of a complex conjugate pair of eigenvalues is selected, *> then both complex eigenvalues are selected. *> Note that a selected complex eigenvalue may no longer satisfy *> SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) = .TRUE. after ordering, *> since ordering may change the value of complex eigenvalues *> (especially if the eigenvalue is ill-conditioned), in this *> case INFO is set to N+3. *> \endverbatim *> *> \param[in] SENSE *> \verbatim *> SENSE is CHARACTER*1 *> Determines which reciprocal condition numbers are computed. *> = 'N' : None are computed; *> = 'E' : Computed for average of selected eigenvalues only; *> = 'V' : Computed for selected deflating subspaces only; *> = 'B' : Computed for both. *> If SENSE = 'E', 'V', or 'B', SORT must equal 'S'. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A, B, VSL, and VSR. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA, N) *> On entry, the first of the pair of matrices. *> On exit, A has been overwritten by its generalized Schur *> form S. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB, N) *> On entry, the second of the pair of matrices. *> On exit, B has been overwritten by its generalized Schur *> form T. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] SDIM *> \verbatim *> SDIM is INTEGER *> If SORT = 'N', SDIM = 0. *> If SORT = 'S', SDIM = number of eigenvalues (after sorting) *> for which SELCTG is true. (Complex conjugate pairs for which *> SELCTG is true for either eigenvalue count as 2.) *> \endverbatim *> *> \param[out] ALPHAR *> \verbatim *> ALPHAR is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] ALPHAI *> \verbatim *> ALPHAI is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] BETA *> \verbatim *> BETA is DOUBLE PRECISION array, dimension (N) *> On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will *> be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i *> and BETA(j),j=1,...,N are the diagonals of the complex Schur *> form (S,T) that would result if the 2-by-2 diagonal blocks of *> the real Schur form of (A,B) were further reduced to *> triangular form using 2-by-2 complex unitary transformations. *> If ALPHAI(j) is zero, then the j-th eigenvalue is real; if *> positive, then the j-th and (j+1)-st eigenvalues are a *> complex conjugate pair, with ALPHAI(j+1) negative. *> *> Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) *> may easily over- or underflow, and BETA(j) may even be zero. *> Thus, the user should avoid naively computing the ratio. *> However, ALPHAR and ALPHAI will be always less than and *> usually comparable with norm(A) in magnitude, and BETA always *> less than and usually comparable with norm(B). *> \endverbatim *> *> \param[out] VSL *> \verbatim *> VSL is DOUBLE PRECISION array, dimension (LDVSL,N) *> If JOBVSL = 'V', VSL will contain the left Schur vectors. *> Not referenced if JOBVSL = 'N'. *> \endverbatim *> *> \param[in] LDVSL *> \verbatim *> LDVSL is INTEGER *> The leading dimension of the matrix VSL. LDVSL >=1, and *> if JOBVSL = 'V', LDVSL >= N. *> \endverbatim *> *> \param[out] VSR *> \verbatim *> VSR is DOUBLE PRECISION array, dimension (LDVSR,N) *> If JOBVSR = 'V', VSR will contain the right Schur vectors. *> Not referenced if JOBVSR = 'N'. *> \endverbatim *> *> \param[in] LDVSR *> \verbatim *> LDVSR is INTEGER *> The leading dimension of the matrix VSR. LDVSR >= 1, and *> if JOBVSR = 'V', LDVSR >= N. *> \endverbatim *> *> \param[out] RCONDE *> \verbatim *> RCONDE is DOUBLE PRECISION array, dimension ( 2 ) *> If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the *> reciprocal condition numbers for the average of the selected *> eigenvalues. *> Not referenced if SENSE = 'N' or 'V'. *> \endverbatim *> *> \param[out] RCONDV *> \verbatim *> RCONDV is DOUBLE PRECISION array, dimension ( 2 ) *> If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the *> reciprocal condition numbers for the selected deflating *> subspaces. *> Not referenced if SENSE = 'N' or 'E'. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. *> If N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B', *> LWORK >= max( 8*N, 6*N+16, 2*SDIM*(N-SDIM) ), else *> LWORK >= max( 8*N, 6*N+16 ). *> Note that 2*SDIM*(N-SDIM) <= N*N/2. *> Note also that an error is only returned if *> LWORK < max( 8*N, 6*N+16), but if SENSE = 'E' or 'V' or 'B' *> this may not be large enough. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the bound on the optimal size of the WORK *> array and the minimum size of the IWORK array, returns these *> values as the first entries of the WORK and IWORK arrays, and *> no error message related to LWORK or LIWORK is issued by *> XERBLA. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) *> On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK. *> \endverbatim *> *> \param[in] LIWORK *> \verbatim *> LIWORK is INTEGER *> The dimension of the array IWORK. *> If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise *> LIWORK >= N+6. *> *> If LIWORK = -1, then a workspace query is assumed; the *> routine only calculates the bound on the optimal size of the *> WORK array and the minimum size of the IWORK array, returns *> these values as the first entries of the WORK and IWORK *> arrays, and no error message related to LWORK or LIWORK is *> issued by XERBLA. *> \endverbatim *> *> \param[out] BWORK *> \verbatim *> BWORK is LOGICAL array, dimension (N) *> Not referenced if SORT = 'N'. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> = 1,...,N: *> The QZ iteration failed. (A,B) are not in Schur *> form, but ALPHAR(j), ALPHAI(j), and BETA(j) should *> be correct for j=INFO+1,...,N. *> > N: =N+1: other than QZ iteration failed in DHGEQZ *> =N+2: after reordering, roundoff changed values of *> some complex eigenvalues so that leading *> eigenvalues in the Generalized Schur form no *> longer satisfy SELCTG=.TRUE. This could also *> be caused due to scaling. *> =N+3: reordering failed in DTGSEN. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup doubleGEeigen * *> \par Further Details: * ===================== *> *> \verbatim *> *> An approximate (asymptotic) bound on the average absolute error of *> the selected eigenvalues is *> *> EPS * norm((A, B)) / RCONDE( 1 ). *> *> An approximate (asymptotic) bound on the maximum angular error in *> the computed deflating subspaces is *> *> EPS * norm((A, B)) / RCONDV( 2 ). *> *> See LAPACK User's Guide, section 4.11 for more information. *> \endverbatim *> * ===================================================================== SUBROUTINE DGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, $ B, LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, $ VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, IWORK, $ LIWORK, BWORK, INFO ) * * -- LAPACK driver routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. CHARACTER JOBVSL, JOBVSR, SENSE, SORT INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LIWORK, LWORK, N, $ SDIM * .. * .. Array Arguments .. LOGICAL BWORK( * ) INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), $ B( LDB, * ), BETA( * ), RCONDE( 2 ), $ RCONDV( 2 ), VSL( LDVSL, * ), VSR( LDVSR, * ), $ WORK( * ) * .. * .. Function Arguments .. LOGICAL SELCTG EXTERNAL SELCTG * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL, $ LQUERY, LST2SL, WANTSB, WANTSE, WANTSN, WANTST, $ WANTSV INTEGER I, ICOLS, IERR, IHI, IJOB, IJOBVL, IJOBVR, $ ILEFT, ILO, IP, IRIGHT, IROWS, ITAU, IWRK, $ LIWMIN, LWRK, MAXWRK, MINWRK DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PL, $ PR, SAFMAX, SAFMIN, SMLNUM * .. * .. Local Arrays .. DOUBLE PRECISION DIF( 2 ) * .. * .. External Subroutines .. EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLABAD, $ DLACPY, DLASCL, DLASET, DORGQR, DORMQR, DTGSEN, $ XERBLA * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * * Decode the input arguments * IF( LSAME( JOBVSL, 'N' ) ) THEN IJOBVL = 1 ILVSL = .FALSE. ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN IJOBVL = 2 ILVSL = .TRUE. ELSE IJOBVL = -1 ILVSL = .FALSE. END IF * IF( LSAME( JOBVSR, 'N' ) ) THEN IJOBVR = 1 ILVSR = .FALSE. ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN IJOBVR = 2 ILVSR = .TRUE. ELSE IJOBVR = -1 ILVSR = .FALSE. END IF * WANTST = LSAME( SORT, 'S' ) WANTSN = LSAME( SENSE, 'N' ) WANTSE = LSAME( SENSE, 'E' ) WANTSV = LSAME( SENSE, 'V' ) WANTSB = LSAME( SENSE, 'B' ) LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) IF( WANTSN ) THEN IJOB = 0 ELSE IF( WANTSE ) THEN IJOB = 1 ELSE IF( WANTSV ) THEN IJOB = 2 ELSE IF( WANTSB ) THEN IJOB = 4 END IF * * Test the input arguments * INFO = 0 IF( IJOBVL.LE.0 ) THEN INFO = -1 ELSE IF( IJOBVR.LE.0 ) THEN INFO = -2 ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN INFO = -3 ELSE IF( .NOT.( WANTSN .OR. WANTSE .OR. WANTSV .OR. WANTSB ) .OR. $ ( .NOT.WANTST .AND. .NOT.WANTSN ) ) THEN INFO = -5 ELSE IF( N.LT.0 ) THEN INFO = -6 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -10 ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN INFO = -16 ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN INFO = -18 END IF * * Compute workspace * (Note: Comments in the code beginning "Workspace:" describe the * minimal amount of workspace needed at that point in the code, * as well as the preferred amount for good performance. * NB refers to the optimal block size for the immediately * following subroutine, as returned by ILAENV.) * IF( INFO.EQ.0 ) THEN IF( N.GT.0) THEN MINWRK = MAX( 8*N, 6*N + 16 ) MAXWRK = MINWRK - N + $ N*ILAENV( 1, 'DGEQRF', ' ', N, 1, N, 0 ) MAXWRK = MAX( MAXWRK, MINWRK - N + $ N*ILAENV( 1, 'DORMQR', ' ', N, 1, N, -1 ) ) IF( ILVSL ) THEN MAXWRK = MAX( MAXWRK, MINWRK - N + $ N*ILAENV( 1, 'DORGQR', ' ', N, 1, N, -1 ) ) END IF LWRK = MAXWRK IF( IJOB.GE.1 ) $ LWRK = MAX( LWRK, N*N/2 ) ELSE MINWRK = 1 MAXWRK = 1 LWRK = 1 END IF WORK( 1 ) = LWRK IF( WANTSN .OR. N.EQ.0 ) THEN LIWMIN = 1 ELSE LIWMIN = N + 6 END IF IWORK( 1 ) = LIWMIN * IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN INFO = -22 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN INFO = -24 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGGESX', -INFO ) RETURN ELSE IF (LQUERY) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN SDIM = 0 RETURN END IF * * Get machine constants * EPS = DLAMCH( 'P' ) SAFMIN = DLAMCH( 'S' ) SAFMAX = ONE / SAFMIN CALL DLABAD( SAFMIN, SAFMAX ) SMLNUM = SQRT( SAFMIN ) / EPS BIGNUM = ONE / SMLNUM * * Scale A if max element outside range [SMLNUM,BIGNUM] * ANRM = DLANGE( 'M', N, N, A, LDA, WORK ) ILASCL = .FALSE. IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN ANRMTO = SMLNUM ILASCL = .TRUE. ELSE IF( ANRM.GT.BIGNUM ) THEN ANRMTO = BIGNUM ILASCL = .TRUE. END IF IF( ILASCL ) $ CALL DLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR ) * * Scale B if max element outside range [SMLNUM,BIGNUM] * BNRM = DLANGE( 'M', N, N, B, LDB, WORK ) ILBSCL = .FALSE. IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN BNRMTO = SMLNUM ILBSCL = .TRUE. ELSE IF( BNRM.GT.BIGNUM ) THEN BNRMTO = BIGNUM ILBSCL = .TRUE. END IF IF( ILBSCL ) $ CALL DLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR ) * * Permute the matrix to make it more nearly triangular * (Workspace: need 6*N + 2*N for permutation parameters) * ILEFT = 1 IRIGHT = N + 1 IWRK = IRIGHT + N CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ), $ WORK( IRIGHT ), WORK( IWRK ), IERR ) * * Reduce B to triangular form (QR decomposition of B) * (Workspace: need N, prefer N*NB) * IROWS = IHI + 1 - ILO ICOLS = N + 1 - ILO ITAU = IWRK IWRK = ITAU + IROWS CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), $ WORK( IWRK ), LWORK+1-IWRK, IERR ) * * Apply the orthogonal transformation to matrix A * (Workspace: need N, prefer N*NB) * CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ), $ LWORK+1-IWRK, IERR ) * * Initialize VSL * (Workspace: need N, prefer N*NB) * IF( ILVSL ) THEN CALL DLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL ) IF( IROWS.GT.1 ) THEN CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, $ VSL( ILO+1, ILO ), LDVSL ) END IF CALL DORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL, $ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR ) END IF * * Initialize VSR * IF( ILVSR ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR ) * * Reduce to generalized Hessenberg form * (Workspace: none needed) * CALL DGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL, $ LDVSL, VSR, LDVSR, IERR ) * SDIM = 0 * * Perform QZ algorithm, computing Schur vectors if desired * (Workspace: need N) * IWRK = ITAU CALL DHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, $ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, $ WORK( IWRK ), LWORK+1-IWRK, IERR ) IF( IERR.NE.0 ) THEN IF( IERR.GT.0 .AND. IERR.LE.N ) THEN INFO = IERR ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN INFO = IERR - N ELSE INFO = N + 1 END IF GO TO 60 END IF * * Sort eigenvalues ALPHA/BETA and compute the reciprocal of * condition number(s) * (Workspace: If IJOB >= 1, need MAX( 8*(N+1), 2*SDIM*(N-SDIM) ) * otherwise, need 8*(N+1) ) * IF( WANTST ) THEN * * Undo scaling on eigenvalues before SELCTGing * IF( ILASCL ) THEN CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, $ IERR ) CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, $ IERR ) END IF IF( ILBSCL ) $ CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR ) * * Select eigenvalues * DO 10 I = 1, N BWORK( I ) = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) ) 10 CONTINUE * * Reorder eigenvalues, transform Generalized Schur vectors, and * compute reciprocal condition numbers * CALL DTGSEN( IJOB, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB, $ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, $ SDIM, PL, PR, DIF, WORK( IWRK ), LWORK-IWRK+1, $ IWORK, LIWORK, IERR ) * IF( IJOB.GE.1 ) $ MAXWRK = MAX( MAXWRK, 2*SDIM*( N-SDIM ) ) IF( IERR.EQ.-22 ) THEN * * not enough real workspace * INFO = -22 ELSE IF( IJOB.EQ.1 .OR. IJOB.EQ.4 ) THEN RCONDE( 1 ) = PL RCONDE( 2 ) = PR END IF IF( IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN RCONDV( 1 ) = DIF( 1 ) RCONDV( 2 ) = DIF( 2 ) END IF IF( IERR.EQ.1 ) $ INFO = N + 3 END IF * END IF * * Apply permutation to VSL and VSR * (Workspace: none needed) * IF( ILVSL ) $ CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ), $ WORK( IRIGHT ), N, VSL, LDVSL, IERR ) * IF( ILVSR ) $ CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ), $ WORK( IRIGHT ), N, VSR, LDVSR, IERR ) * * Check if unscaling would cause over/underflow, if so, rescale * (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of * B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I) * IF( ILASCL ) THEN DO 20 I = 1, N IF( ALPHAI( I ).NE.ZERO ) THEN IF( ( ALPHAR( I ) / SAFMAX ).GT.( ANRMTO / ANRM ) .OR. $ ( SAFMIN / ALPHAR( I ) ).GT.( ANRM / ANRMTO ) ) THEN WORK( 1 ) = ABS( A( I, I ) / ALPHAR( I ) ) BETA( I ) = BETA( I )*WORK( 1 ) ALPHAR( I ) = ALPHAR( I )*WORK( 1 ) ALPHAI( I ) = ALPHAI( I )*WORK( 1 ) ELSE IF( ( ALPHAI( I ) / SAFMAX ).GT. $ ( ANRMTO / ANRM ) .OR. $ ( SAFMIN / ALPHAI( I ) ).GT.( ANRM / ANRMTO ) ) $ THEN WORK( 1 ) = ABS( A( I, I+1 ) / ALPHAI( I ) ) BETA( I ) = BETA( I )*WORK( 1 ) ALPHAR( I ) = ALPHAR( I )*WORK( 1 ) ALPHAI( I ) = ALPHAI( I )*WORK( 1 ) END IF END IF 20 CONTINUE END IF * IF( ILBSCL ) THEN DO 30 I = 1, N IF( ALPHAI( I ).NE.ZERO ) THEN IF( ( BETA( I ) / SAFMAX ).GT.( BNRMTO / BNRM ) .OR. $ ( SAFMIN / BETA( I ) ).GT.( BNRM / BNRMTO ) ) THEN WORK( 1 ) = ABS( B( I, I ) / BETA( I ) ) BETA( I ) = BETA( I )*WORK( 1 ) ALPHAR( I ) = ALPHAR( I )*WORK( 1 ) ALPHAI( I ) = ALPHAI( I )*WORK( 1 ) END IF END IF 30 CONTINUE END IF * * Undo scaling * IF( ILASCL ) THEN CALL DLASCL( 'H', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR ) CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR ) CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR ) END IF * IF( ILBSCL ) THEN CALL DLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR ) CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR ) END IF * IF( WANTST ) THEN * * Check if reordering is correct * LASTSL = .TRUE. LST2SL = .TRUE. SDIM = 0 IP = 0 DO 50 I = 1, N CURSL = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) ) IF( ALPHAI( I ).EQ.ZERO ) THEN IF( CURSL ) $ SDIM = SDIM + 1 IP = 0 IF( CURSL .AND. .NOT.LASTSL ) $ INFO = N + 2 ELSE IF( IP.EQ.1 ) THEN * * Last eigenvalue of conjugate pair * CURSL = CURSL .OR. LASTSL LASTSL = CURSL IF( CURSL ) $ SDIM = SDIM + 2 IP = -1 IF( CURSL .AND. .NOT.LST2SL ) $ INFO = N + 2 ELSE * * First eigenvalue of conjugate pair * IP = 1 END IF END IF LST2SL = LASTSL LASTSL = CURSL 50 CONTINUE * END IF * 60 CONTINUE * WORK( 1 ) = MAXWRK IWORK( 1 ) = LIWMIN * RETURN * * End of DGGESX * END *> \brief DGGEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGGEV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, * BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBVL, JOBVR * INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), * $ B( LDB, * ), BETA( * ), VL( LDVL, * ), * $ VR( LDVR, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGGEV computes for a pair of N-by-N real nonsymmetric matrices (A,B) *> the generalized eigenvalues, and optionally, the left and/or right *> generalized eigenvectors. *> *> A generalized eigenvalue for a pair of matrices (A,B) is a scalar *> lambda or a ratio alpha/beta = lambda, such that A - lambda*B is *> singular. It is usually represented as the pair (alpha,beta), as *> there is a reasonable interpretation for beta=0, and even for both *> being zero. *> *> The right eigenvector v(j) corresponding to the eigenvalue lambda(j) *> of (A,B) satisfies *> *> A * v(j) = lambda(j) * B * v(j). *> *> The left eigenvector u(j) corresponding to the eigenvalue lambda(j) *> of (A,B) satisfies *> *> u(j)**H * A = lambda(j) * u(j)**H * B . *> *> where u(j)**H is the conjugate-transpose of u(j). *> *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBVL *> \verbatim *> JOBVL is CHARACTER*1 *> = 'N': do not compute the left generalized eigenvectors; *> = 'V': compute the left generalized eigenvectors. *> \endverbatim *> *> \param[in] JOBVR *> \verbatim *> JOBVR is CHARACTER*1 *> = 'N': do not compute the right generalized eigenvectors; *> = 'V': compute the right generalized eigenvectors. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A, B, VL, and VR. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA, N) *> On entry, the matrix A in the pair (A,B). *> On exit, A has been overwritten. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB, N) *> On entry, the matrix B in the pair (A,B). *> On exit, B has been overwritten. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] ALPHAR *> \verbatim *> ALPHAR is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] ALPHAI *> \verbatim *> ALPHAI is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] BETA *> \verbatim *> BETA is DOUBLE PRECISION array, dimension (N) *> On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will *> be the generalized eigenvalues. If ALPHAI(j) is zero, then *> the j-th eigenvalue is real; if positive, then the j-th and *> (j+1)-st eigenvalues are a complex conjugate pair, with *> ALPHAI(j+1) negative. *> *> Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) *> may easily over- or underflow, and BETA(j) may even be zero. *> Thus, the user should avoid naively computing the ratio *> alpha/beta. However, ALPHAR and ALPHAI will be always less *> than and usually comparable with norm(A) in magnitude, and *> BETA always less than and usually comparable with norm(B). *> \endverbatim *> *> \param[out] VL *> \verbatim *> VL is DOUBLE PRECISION array, dimension (LDVL,N) *> If JOBVL = 'V', the left eigenvectors u(j) are stored one *> after another in the columns of VL, in the same order as *> their eigenvalues. If the j-th eigenvalue is real, then *> u(j) = VL(:,j), the j-th column of VL. If the j-th and *> (j+1)-th eigenvalues form a complex conjugate pair, then *> u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1). *> Each eigenvector is scaled so the largest component has *> abs(real part)+abs(imag. part)=1. *> Not referenced if JOBVL = 'N'. *> \endverbatim *> *> \param[in] LDVL *> \verbatim *> LDVL is INTEGER *> The leading dimension of the matrix VL. LDVL >= 1, and *> if JOBVL = 'V', LDVL >= N. *> \endverbatim *> *> \param[out] VR *> \verbatim *> VR is DOUBLE PRECISION array, dimension (LDVR,N) *> If JOBVR = 'V', the right eigenvectors v(j) are stored one *> after another in the columns of VR, in the same order as *> their eigenvalues. If the j-th eigenvalue is real, then *> v(j) = VR(:,j), the j-th column of VR. If the j-th and *> (j+1)-th eigenvalues form a complex conjugate pair, then *> v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1). *> Each eigenvector is scaled so the largest component has *> abs(real part)+abs(imag. part)=1. *> Not referenced if JOBVR = 'N'. *> \endverbatim *> *> \param[in] LDVR *> \verbatim *> LDVR is INTEGER *> The leading dimension of the matrix VR. LDVR >= 1, and *> if JOBVR = 'V', LDVR >= N. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= max(1,8*N). *> For good performance, LWORK must generally be larger. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error *> message related to LWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> = 1,...,N: *> The QZ iteration failed. No eigenvectors have been *> calculated, but ALPHAR(j), ALPHAI(j), and BETA(j) *> should be correct for j=INFO+1,...,N. *> > N: =N+1: other than QZ iteration failed in DHGEQZ. *> =N+2: error return from DTGEVC. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date April 2012 * *> \ingroup doubleGEeigen * * ===================================================================== SUBROUTINE DGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, $ BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * April 2012 * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), $ B( LDB, * ), BETA( * ), VL( LDVL, * ), $ VR( LDVR, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY CHARACTER CHTEMP INTEGER ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, ILO, $ IN, IRIGHT, IROWS, ITAU, IWRK, JC, JR, MAXWRK, $ MINWRK DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, $ SMLNUM, TEMP * .. * .. Local Arrays .. LOGICAL LDUMMA( 1 ) * .. * .. External Subroutines .. EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLABAD, $ DLACPY,DLASCL, DLASET, DORGQR, DORMQR, DTGEVC, $ XERBLA * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * * Decode the input arguments * IF( LSAME( JOBVL, 'N' ) ) THEN IJOBVL = 1 ILVL = .FALSE. ELSE IF( LSAME( JOBVL, 'V' ) ) THEN IJOBVL = 2 ILVL = .TRUE. ELSE IJOBVL = -1 ILVL = .FALSE. END IF * IF( LSAME( JOBVR, 'N' ) ) THEN IJOBVR = 1 ILVR = .FALSE. ELSE IF( LSAME( JOBVR, 'V' ) ) THEN IJOBVR = 2 ILVR = .TRUE. ELSE IJOBVR = -1 ILVR = .FALSE. END IF ILV = ILVL .OR. ILVR * * Test the input arguments * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) IF( IJOBVL.LE.0 ) THEN INFO = -1 ELSE IF( IJOBVR.LE.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN INFO = -12 ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN INFO = -14 END IF * * Compute workspace * (Note: Comments in the code beginning "Workspace:" describe the * minimal amount of workspace needed at that point in the code, * as well as the preferred amount for good performance. * NB refers to the optimal block size for the immediately * following subroutine, as returned by ILAENV. The workspace is * computed assuming ILO = 1 and IHI = N, the worst case.) * IF( INFO.EQ.0 ) THEN MINWRK = MAX( 1, 8*N ) MAXWRK = MAX( 1, N*( 7 + $ ILAENV( 1, 'DGEQRF', ' ', N, 1, N, 0 ) ) ) MAXWRK = MAX( MAXWRK, N*( 7 + $ ILAENV( 1, 'DORMQR', ' ', N, 1, N, 0 ) ) ) IF( ILVL ) THEN MAXWRK = MAX( MAXWRK, N*( 7 + $ ILAENV( 1, 'DORGQR', ' ', N, 1, N, -1 ) ) ) END IF WORK( 1 ) = MAXWRK * IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) $ INFO = -16 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGGEV ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Get machine constants * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = SQRT( SMLNUM ) / EPS BIGNUM = ONE / SMLNUM * * Scale A if max element outside range [SMLNUM,BIGNUM] * ANRM = DLANGE( 'M', N, N, A, LDA, WORK ) ILASCL = .FALSE. IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN ANRMTO = SMLNUM ILASCL = .TRUE. ELSE IF( ANRM.GT.BIGNUM ) THEN ANRMTO = BIGNUM ILASCL = .TRUE. END IF IF( ILASCL ) $ CALL DLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR ) * * Scale B if max element outside range [SMLNUM,BIGNUM] * BNRM = DLANGE( 'M', N, N, B, LDB, WORK ) ILBSCL = .FALSE. IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN BNRMTO = SMLNUM ILBSCL = .TRUE. ELSE IF( BNRM.GT.BIGNUM ) THEN BNRMTO = BIGNUM ILBSCL = .TRUE. END IF IF( ILBSCL ) $ CALL DLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR ) * * Permute the matrices A, B to isolate eigenvalues if possible * (Workspace: need 6*N) * ILEFT = 1 IRIGHT = N + 1 IWRK = IRIGHT + N CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ), $ WORK( IRIGHT ), WORK( IWRK ), IERR ) * * Reduce B to triangular form (QR decomposition of B) * (Workspace: need N, prefer N*NB) * IROWS = IHI + 1 - ILO IF( ILV ) THEN ICOLS = N + 1 - ILO ELSE ICOLS = IROWS END IF ITAU = IWRK IWRK = ITAU + IROWS CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), $ WORK( IWRK ), LWORK+1-IWRK, IERR ) * * Apply the orthogonal transformation to matrix A * (Workspace: need N, prefer N*NB) * CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ), $ LWORK+1-IWRK, IERR ) * * Initialize VL * (Workspace: need N, prefer N*NB) * IF( ILVL ) THEN CALL DLASET( 'Full', N, N, ZERO, ONE, VL, LDVL ) IF( IROWS.GT.1 ) THEN CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, $ VL( ILO+1, ILO ), LDVL ) END IF CALL DORGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL, $ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR ) END IF * * Initialize VR * IF( ILVR ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, VR, LDVR ) * * Reduce to generalized Hessenberg form * (Workspace: none needed) * IF( ILV ) THEN * * Eigenvectors requested -- work on whole matrix. * CALL DGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL, $ LDVL, VR, LDVR, IERR ) ELSE CALL DGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA, $ B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IERR ) END IF * * Perform QZ algorithm (Compute eigenvalues, and optionally, the * Schur forms and Schur vectors) * (Workspace: need N) * IWRK = ITAU IF( ILV ) THEN CHTEMP = 'S' ELSE CHTEMP = 'E' END IF CALL DHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, $ ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, $ WORK( IWRK ), LWORK+1-IWRK, IERR ) IF( IERR.NE.0 ) THEN IF( IERR.GT.0 .AND. IERR.LE.N ) THEN INFO = IERR ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN INFO = IERR - N ELSE INFO = N + 1 END IF GO TO 110 END IF * * Compute Eigenvectors * (Workspace: need 6*N) * IF( ILV ) THEN IF( ILVL ) THEN IF( ILVR ) THEN CHTEMP = 'B' ELSE CHTEMP = 'L' END IF ELSE CHTEMP = 'R' END IF CALL DTGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL, LDVL, $ VR, LDVR, N, IN, WORK( IWRK ), IERR ) IF( IERR.NE.0 ) THEN INFO = N + 2 GO TO 110 END IF * * Undo balancing on VL and VR and normalization * (Workspace: none needed) * IF( ILVL ) THEN CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ), $ WORK( IRIGHT ), N, VL, LDVL, IERR ) DO 50 JC = 1, N IF( ALPHAI( JC ).LT.ZERO ) $ GO TO 50 TEMP = ZERO IF( ALPHAI( JC ).EQ.ZERO ) THEN DO 10 JR = 1, N TEMP = MAX( TEMP, ABS( VL( JR, JC ) ) ) 10 CONTINUE ELSE DO 20 JR = 1, N TEMP = MAX( TEMP, ABS( VL( JR, JC ) )+ $ ABS( VL( JR, JC+1 ) ) ) 20 CONTINUE END IF IF( TEMP.LT.SMLNUM ) $ GO TO 50 TEMP = ONE / TEMP IF( ALPHAI( JC ).EQ.ZERO ) THEN DO 30 JR = 1, N VL( JR, JC ) = VL( JR, JC )*TEMP 30 CONTINUE ELSE DO 40 JR = 1, N VL( JR, JC ) = VL( JR, JC )*TEMP VL( JR, JC+1 ) = VL( JR, JC+1 )*TEMP 40 CONTINUE END IF 50 CONTINUE END IF IF( ILVR ) THEN CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ), $ WORK( IRIGHT ), N, VR, LDVR, IERR ) DO 100 JC = 1, N IF( ALPHAI( JC ).LT.ZERO ) $ GO TO 100 TEMP = ZERO IF( ALPHAI( JC ).EQ.ZERO ) THEN DO 60 JR = 1, N TEMP = MAX( TEMP, ABS( VR( JR, JC ) ) ) 60 CONTINUE ELSE DO 70 JR = 1, N TEMP = MAX( TEMP, ABS( VR( JR, JC ) )+ $ ABS( VR( JR, JC+1 ) ) ) 70 CONTINUE END IF IF( TEMP.LT.SMLNUM ) $ GO TO 100 TEMP = ONE / TEMP IF( ALPHAI( JC ).EQ.ZERO ) THEN DO 80 JR = 1, N VR( JR, JC ) = VR( JR, JC )*TEMP 80 CONTINUE ELSE DO 90 JR = 1, N VR( JR, JC ) = VR( JR, JC )*TEMP VR( JR, JC+1 ) = VR( JR, JC+1 )*TEMP 90 CONTINUE END IF 100 CONTINUE END IF * * End of eigenvector calculation * END IF * * Undo scaling if necessary * 110 CONTINUE * IF( ILASCL ) THEN CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR ) CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR ) END IF * IF( ILBSCL ) THEN CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR ) END IF * WORK( 1 ) = MAXWRK RETURN * * End of DGGEV * END *> \brief DGGEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGGEVX + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, * ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, ILO, * IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, * RCONDV, WORK, LWORK, IWORK, BWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER BALANC, JOBVL, JOBVR, SENSE * INTEGER IHI, ILO, INFO, LDA, LDB, LDVL, LDVR, LWORK, N * DOUBLE PRECISION ABNRM, BBNRM * .. * .. Array Arguments .. * LOGICAL BWORK( * ) * INTEGER IWORK( * ) * DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), * $ B( LDB, * ), BETA( * ), LSCALE( * ), * $ RCONDE( * ), RCONDV( * ), RSCALE( * ), * $ VL( LDVL, * ), VR( LDVR, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B) *> the generalized eigenvalues, and optionally, the left and/or right *> generalized eigenvectors. *> *> Optionally also, it computes a balancing transformation to improve *> the conditioning of the eigenvalues and eigenvectors (ILO, IHI, *> LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for *> the eigenvalues (RCONDE), and reciprocal condition numbers for the *> right eigenvectors (RCONDV). *> *> A generalized eigenvalue for a pair of matrices (A,B) is a scalar *> lambda or a ratio alpha/beta = lambda, such that A - lambda*B is *> singular. It is usually represented as the pair (alpha,beta), as *> there is a reasonable interpretation for beta=0, and even for both *> being zero. *> *> The right eigenvector v(j) corresponding to the eigenvalue lambda(j) *> of (A,B) satisfies *> *> A * v(j) = lambda(j) * B * v(j) . *> *> The left eigenvector u(j) corresponding to the eigenvalue lambda(j) *> of (A,B) satisfies *> *> u(j)**H * A = lambda(j) * u(j)**H * B. *> *> where u(j)**H is the conjugate-transpose of u(j). *> *> \endverbatim * * Arguments: * ========== * *> \param[in] BALANC *> \verbatim *> BALANC is CHARACTER*1 *> Specifies the balance option to be performed. *> = 'N': do not diagonally scale or permute; *> = 'P': permute only; *> = 'S': scale only; *> = 'B': both permute and scale. *> Computed reciprocal condition numbers will be for the *> matrices after permuting and/or balancing. Permuting does *> not change condition numbers (in exact arithmetic), but *> balancing does. *> \endverbatim *> *> \param[in] JOBVL *> \verbatim *> JOBVL is CHARACTER*1 *> = 'N': do not compute the left generalized eigenvectors; *> = 'V': compute the left generalized eigenvectors. *> \endverbatim *> *> \param[in] JOBVR *> \verbatim *> JOBVR is CHARACTER*1 *> = 'N': do not compute the right generalized eigenvectors; *> = 'V': compute the right generalized eigenvectors. *> \endverbatim *> *> \param[in] SENSE *> \verbatim *> SENSE is CHARACTER*1 *> Determines which reciprocal condition numbers are computed. *> = 'N': none are computed; *> = 'E': computed for eigenvalues only; *> = 'V': computed for eigenvectors only; *> = 'B': computed for eigenvalues and eigenvectors. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A, B, VL, and VR. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA, N) *> On entry, the matrix A in the pair (A,B). *> On exit, A has been overwritten. If JOBVL='V' or JOBVR='V' *> or both, then A contains the first part of the real Schur *> form of the "balanced" versions of the input A and B. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB, N) *> On entry, the matrix B in the pair (A,B). *> On exit, B has been overwritten. If JOBVL='V' or JOBVR='V' *> or both, then B contains the second part of the real Schur *> form of the "balanced" versions of the input A and B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] ALPHAR *> \verbatim *> ALPHAR is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] ALPHAI *> \verbatim *> ALPHAI is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] BETA *> \verbatim *> BETA is DOUBLE PRECISION array, dimension (N) *> On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will *> be the generalized eigenvalues. If ALPHAI(j) is zero, then *> the j-th eigenvalue is real; if positive, then the j-th and *> (j+1)-st eigenvalues are a complex conjugate pair, with *> ALPHAI(j+1) negative. *> *> Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) *> may easily over- or underflow, and BETA(j) may even be zero. *> Thus, the user should avoid naively computing the ratio *> ALPHA/BETA. However, ALPHAR and ALPHAI will be always less *> than and usually comparable with norm(A) in magnitude, and *> BETA always less than and usually comparable with norm(B). *> \endverbatim *> *> \param[out] VL *> \verbatim *> VL is DOUBLE PRECISION array, dimension (LDVL,N) *> If JOBVL = 'V', the left eigenvectors u(j) are stored one *> after another in the columns of VL, in the same order as *> their eigenvalues. If the j-th eigenvalue is real, then *> u(j) = VL(:,j), the j-th column of VL. If the j-th and *> (j+1)-th eigenvalues form a complex conjugate pair, then *> u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1). *> Each eigenvector will be scaled so the largest component have *> abs(real part) + abs(imag. part) = 1. *> Not referenced if JOBVL = 'N'. *> \endverbatim *> *> \param[in] LDVL *> \verbatim *> LDVL is INTEGER *> The leading dimension of the matrix VL. LDVL >= 1, and *> if JOBVL = 'V', LDVL >= N. *> \endverbatim *> *> \param[out] VR *> \verbatim *> VR is DOUBLE PRECISION array, dimension (LDVR,N) *> If JOBVR = 'V', the right eigenvectors v(j) are stored one *> after another in the columns of VR, in the same order as *> their eigenvalues. If the j-th eigenvalue is real, then *> v(j) = VR(:,j), the j-th column of VR. If the j-th and *> (j+1)-th eigenvalues form a complex conjugate pair, then *> v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1). *> Each eigenvector will be scaled so the largest component have *> abs(real part) + abs(imag. part) = 1. *> Not referenced if JOBVR = 'N'. *> \endverbatim *> *> \param[in] LDVR *> \verbatim *> LDVR is INTEGER *> The leading dimension of the matrix VR. LDVR >= 1, and *> if JOBVR = 'V', LDVR >= N. *> \endverbatim *> *> \param[out] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[out] IHI *> \verbatim *> IHI is INTEGER *> ILO and IHI are integer values 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 BALANC = 'N' or 'S', ILO = 1 and IHI = N. *> \endverbatim *> *> \param[out] LSCALE *> \verbatim *> LSCALE is DOUBLE PRECISION array, dimension (N) *> Details of the permutations and scaling factors applied *> to the left side of A and B. If PL(j) is the index of the *> row interchanged with row j, and DL(j) is the scaling *> factor applied to row j, then *> LSCALE(j) = PL(j) for j = 1,...,ILO-1 *> = DL(j) for j = ILO,...,IHI *> = PL(j) for j = IHI+1,...,N. *> The order in which the interchanges are made is N to IHI+1, *> then 1 to ILO-1. *> \endverbatim *> *> \param[out] RSCALE *> \verbatim *> RSCALE is DOUBLE PRECISION array, dimension (N) *> Details of the permutations and scaling factors applied *> to the right side of A and B. If PR(j) is the index of the *> column interchanged with column j, and DR(j) is the scaling *> factor applied to column j, then *> RSCALE(j) = PR(j) for j = 1,...,ILO-1 *> = DR(j) for j = ILO,...,IHI *> = PR(j) for j = IHI+1,...,N *> The order in which the interchanges are made is N to IHI+1, *> then 1 to ILO-1. *> \endverbatim *> *> \param[out] ABNRM *> \verbatim *> ABNRM is DOUBLE PRECISION *> The one-norm of the balanced matrix A. *> \endverbatim *> *> \param[out] BBNRM *> \verbatim *> BBNRM is DOUBLE PRECISION *> The one-norm of the balanced matrix B. *> \endverbatim *> *> \param[out] RCONDE *> \verbatim *> RCONDE is DOUBLE PRECISION array, dimension (N) *> If SENSE = 'E' or 'B', the reciprocal condition numbers of *> the eigenvalues, stored in consecutive elements of the array. *> For a complex conjugate pair of eigenvalues two consecutive *> elements of RCONDE are set to the same value. Thus RCONDE(j), *> RCONDV(j), and the j-th columns of VL and VR all correspond *> to the j-th eigenpair. *> If SENSE = 'N or 'V', RCONDE is not referenced. *> \endverbatim *> *> \param[out] RCONDV *> \verbatim *> RCONDV is DOUBLE PRECISION array, dimension (N) *> If SENSE = 'V' or 'B', the estimated reciprocal condition *> numbers of the eigenvectors, stored in consecutive elements *> of the array. For a complex eigenvector two consecutive *> elements of RCONDV are set to the same value. If the *> eigenvalues cannot be reordered to compute RCONDV(j), *> RCONDV(j) is set to 0; this can only occur when the true *> value would be very small anyway. *> If SENSE = 'N' or 'E', RCONDV is not referenced. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= max(1,2*N). *> If BALANC = 'S' or 'B', or JOBVL = 'V', or JOBVR = 'V', *> LWORK >= max(1,6*N). *> If SENSE = 'E' or 'B', LWORK >= max(1,10*N). *> If SENSE = 'V' or 'B', LWORK >= 2*N*N+8*N+16. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error *> message related to LWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N+6) *> If SENSE = 'E', IWORK is not referenced. *> \endverbatim *> *> \param[out] BWORK *> \verbatim *> BWORK is LOGICAL array, dimension (N) *> If SENSE = 'N', BWORK is not referenced. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> = 1,...,N: *> The QZ iteration failed. No eigenvectors have been *> calculated, but ALPHAR(j), ALPHAI(j), and BETA(j) *> should be correct for j=INFO+1,...,N. *> > N: =N+1: other than QZ iteration failed in DHGEQZ. *> =N+2: error return from DTGEVC. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date April 2012 * *> \ingroup doubleGEeigen * *> \par Further Details: * ===================== *> *> \verbatim *> *> Balancing a matrix pair (A,B) includes, first, permuting rows and *> columns to isolate eigenvalues, second, applying diagonal similarity *> transformation to the rows and columns to make the rows and columns *> as close in norm as possible. The computed reciprocal condition *> numbers correspond to the balanced matrix. Permuting rows and columns *> will not change the condition numbers (in exact arithmetic) but *> diagonal scaling will. For further explanation of balancing, see *> section 4.11.1.2 of LAPACK Users' Guide. *> *> An approximate error bound on the chordal distance between the i-th *> computed generalized eigenvalue w and the corresponding exact *> eigenvalue lambda is *> *> chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I) *> *> An approximate error bound for the angle between the i-th computed *> eigenvector VL(i) or VR(i) is given by *> *> EPS * norm(ABNRM, BBNRM) / DIF(i). *> *> For further explanation of the reciprocal condition numbers RCONDE *> and RCONDV, see section 4.11 of LAPACK User's Guide. *> \endverbatim *> * ===================================================================== SUBROUTINE DGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, $ ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, ILO, $ IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, $ RCONDV, WORK, LWORK, IWORK, BWORK, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * April 2012 * * .. Scalar Arguments .. CHARACTER BALANC, JOBVL, JOBVR, SENSE INTEGER IHI, ILO, INFO, LDA, LDB, LDVL, LDVR, LWORK, N DOUBLE PRECISION ABNRM, BBNRM * .. * .. Array Arguments .. LOGICAL BWORK( * ) INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), $ B( LDB, * ), BETA( * ), LSCALE( * ), $ RCONDE( * ), RCONDV( * ), RSCALE( * ), $ VL( LDVL, * ), VR( LDVR, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY, NOSCL, $ PAIR, WANTSB, WANTSE, WANTSN, WANTSV CHARACTER CHTEMP INTEGER I, ICOLS, IERR, IJOBVL, IJOBVR, IN, IROWS, $ ITAU, IWRK, IWRK1, J, JC, JR, M, MAXWRK, $ MINWRK, MM DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, $ SMLNUM, TEMP * .. * .. Local Arrays .. LOGICAL LDUMMA( 1 ) * .. * .. External Subroutines .. EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLABAD, $ DLACPY, DLASCL, DLASET, DORGQR, DORMQR, DTGEVC, $ DTGSNA, XERBLA * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * * Decode the input arguments * IF( LSAME( JOBVL, 'N' ) ) THEN IJOBVL = 1 ILVL = .FALSE. ELSE IF( LSAME( JOBVL, 'V' ) ) THEN IJOBVL = 2 ILVL = .TRUE. ELSE IJOBVL = -1 ILVL = .FALSE. END IF * IF( LSAME( JOBVR, 'N' ) ) THEN IJOBVR = 1 ILVR = .FALSE. ELSE IF( LSAME( JOBVR, 'V' ) ) THEN IJOBVR = 2 ILVR = .TRUE. ELSE IJOBVR = -1 ILVR = .FALSE. END IF ILV = ILVL .OR. ILVR * NOSCL = LSAME( BALANC, 'N' ) .OR. LSAME( BALANC, 'P' ) WANTSN = LSAME( SENSE, 'N' ) WANTSE = LSAME( SENSE, 'E' ) WANTSV = LSAME( SENSE, 'V' ) WANTSB = LSAME( SENSE, 'B' ) * * Test the input arguments * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LSAME( BALANC, $ 'S' ) .OR. LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) ) ) $ THEN INFO = -1 ELSE IF( IJOBVL.LE.0 ) THEN INFO = -2 ELSE IF( IJOBVR.LE.0 ) THEN INFO = -3 ELSE IF( .NOT.( WANTSN .OR. WANTSE .OR. WANTSB .OR. WANTSV ) ) $ THEN INFO = -4 ELSE IF( N.LT.0 ) 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( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN INFO = -14 ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN INFO = -16 END IF * * Compute workspace * (Note: Comments in the code beginning "Workspace:" describe the * minimal amount of workspace needed at that point in the code, * as well as the preferred amount for good performance. * NB refers to the optimal block size for the immediately * following subroutine, as returned by ILAENV. The workspace is * computed assuming ILO = 1 and IHI = N, the worst case.) * IF( INFO.EQ.0 ) THEN IF( N.EQ.0 ) THEN MINWRK = 1 MAXWRK = 1 ELSE IF( NOSCL .AND. .NOT.ILV ) THEN MINWRK = 2*N ELSE MINWRK = 6*N END IF IF( WANTSE .OR. WANTSB ) THEN MINWRK = 10*N END IF IF( WANTSV .OR. WANTSB ) THEN MINWRK = MAX( MINWRK, 2*N*( N + 4 ) + 16 ) END IF MAXWRK = MINWRK MAXWRK = MAX( MAXWRK, $ N + N*ILAENV( 1, 'DGEQRF', ' ', N, 1, N, 0 ) ) MAXWRK = MAX( MAXWRK, $ N + N*ILAENV( 1, 'DORMQR', ' ', N, 1, N, 0 ) ) IF( ILVL ) THEN MAXWRK = MAX( MAXWRK, N + $ N*ILAENV( 1, 'DORGQR', ' ', N, 1, N, 0 ) ) END IF END IF WORK( 1 ) = MAXWRK * IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN INFO = -26 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGGEVX', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * * Get machine constants * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = SQRT( SMLNUM ) / EPS BIGNUM = ONE / SMLNUM * * Scale A if max element outside range [SMLNUM,BIGNUM] * ANRM = DLANGE( 'M', N, N, A, LDA, WORK ) ILASCL = .FALSE. IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN ANRMTO = SMLNUM ILASCL = .TRUE. ELSE IF( ANRM.GT.BIGNUM ) THEN ANRMTO = BIGNUM ILASCL = .TRUE. END IF IF( ILASCL ) $ CALL DLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR ) * * Scale B if max element outside range [SMLNUM,BIGNUM] * BNRM = DLANGE( 'M', N, N, B, LDB, WORK ) ILBSCL = .FALSE. IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN BNRMTO = SMLNUM ILBSCL = .TRUE. ELSE IF( BNRM.GT.BIGNUM ) THEN BNRMTO = BIGNUM ILBSCL = .TRUE. END IF IF( ILBSCL ) $ CALL DLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR ) * * Permute and/or balance the matrix pair (A,B) * (Workspace: need 6*N if BALANC = 'S' or 'B', 1 otherwise) * CALL DGGBAL( BALANC, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, $ WORK, IERR ) * * Compute ABNRM and BBNRM * ABNRM = DLANGE( '1', N, N, A, LDA, WORK( 1 ) ) IF( ILASCL ) THEN WORK( 1 ) = ABNRM CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, 1, 1, WORK( 1 ), 1, $ IERR ) ABNRM = WORK( 1 ) END IF * BBNRM = DLANGE( '1', N, N, B, LDB, WORK( 1 ) ) IF( ILBSCL ) THEN WORK( 1 ) = BBNRM CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, 1, 1, WORK( 1 ), 1, $ IERR ) BBNRM = WORK( 1 ) END IF * * Reduce B to triangular form (QR decomposition of B) * (Workspace: need N, prefer N*NB ) * IROWS = IHI + 1 - ILO IF( ILV .OR. .NOT.WANTSN ) THEN ICOLS = N + 1 - ILO ELSE ICOLS = IROWS END IF ITAU = 1 IWRK = ITAU + IROWS CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), $ WORK( IWRK ), LWORK+1-IWRK, IERR ) * * Apply the orthogonal transformation to A * (Workspace: need N, prefer N*NB) * CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ), $ LWORK+1-IWRK, IERR ) * * Initialize VL and/or VR * (Workspace: need N, prefer N*NB) * IF( ILVL ) THEN CALL DLASET( 'Full', N, N, ZERO, ONE, VL, LDVL ) IF( IROWS.GT.1 ) THEN CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, $ VL( ILO+1, ILO ), LDVL ) END IF CALL DORGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL, $ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR ) END IF * IF( ILVR ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, VR, LDVR ) * * Reduce to generalized Hessenberg form * (Workspace: none needed) * IF( ILV .OR. .NOT.WANTSN ) THEN * * Eigenvectors requested -- work on whole matrix. * CALL DGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL, $ LDVL, VR, LDVR, IERR ) ELSE CALL DGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA, $ B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IERR ) END IF * * Perform QZ algorithm (Compute eigenvalues, and optionally, the * Schur forms and Schur vectors) * (Workspace: need N) * IF( ILV .OR. .NOT.WANTSN ) THEN CHTEMP = 'S' ELSE CHTEMP = 'E' END IF * CALL DHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, $ ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, $ LWORK, IERR ) IF( IERR.NE.0 ) THEN IF( IERR.GT.0 .AND. IERR.LE.N ) THEN INFO = IERR ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN INFO = IERR - N ELSE INFO = N + 1 END IF GO TO 130 END IF * * Compute Eigenvectors and estimate condition numbers if desired * (Workspace: DTGEVC: need 6*N * DTGSNA: need 2*N*(N+2)+16 if SENSE = 'V' or 'B', * need N otherwise ) * IF( ILV .OR. .NOT.WANTSN ) THEN IF( ILV ) THEN IF( ILVL ) THEN IF( ILVR ) THEN CHTEMP = 'B' ELSE CHTEMP = 'L' END IF ELSE CHTEMP = 'R' END IF * CALL DTGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL, $ LDVL, VR, LDVR, N, IN, WORK, IERR ) IF( IERR.NE.0 ) THEN INFO = N + 2 GO TO 130 END IF END IF * IF( .NOT.WANTSN ) THEN * * compute eigenvectors (DTGEVC) and estimate condition * numbers (DTGSNA). Note that the definition of the condition * number is not invariant under transformation (u,v) to * (Q*u, Z*v), where (u,v) are eigenvectors of the generalized * Schur form (S,T), Q and Z are orthogonal matrices. In order * to avoid using extra 2*N*N workspace, we have to recalculate * eigenvectors and estimate one condition numbers at a time. * PAIR = .FALSE. DO 20 I = 1, N * IF( PAIR ) THEN PAIR = .FALSE. GO TO 20 END IF MM = 1 IF( I.LT.N ) THEN IF( A( I+1, I ).NE.ZERO ) THEN PAIR = .TRUE. MM = 2 END IF END IF * DO 10 J = 1, N BWORK( J ) = .FALSE. 10 CONTINUE IF( MM.EQ.1 ) THEN BWORK( I ) = .TRUE. ELSE IF( MM.EQ.2 ) THEN BWORK( I ) = .TRUE. BWORK( I+1 ) = .TRUE. END IF * IWRK = MM*N + 1 IWRK1 = IWRK + MM*N * * Compute a pair of left and right eigenvectors. * (compute workspace: need up to 4*N + 6*N) * IF( WANTSE .OR. WANTSB ) THEN CALL DTGEVC( 'B', 'S', BWORK, N, A, LDA, B, LDB, $ WORK( 1 ), N, WORK( IWRK ), N, MM, M, $ WORK( IWRK1 ), IERR ) IF( IERR.NE.0 ) THEN INFO = N + 2 GO TO 130 END IF END IF * CALL DTGSNA( SENSE, 'S', BWORK, N, A, LDA, B, LDB, $ WORK( 1 ), N, WORK( IWRK ), N, RCONDE( I ), $ RCONDV( I ), MM, M, WORK( IWRK1 ), $ LWORK-IWRK1+1, IWORK, IERR ) * 20 CONTINUE END IF END IF * * Undo balancing on VL and VR and normalization * (Workspace: none needed) * IF( ILVL ) THEN CALL DGGBAK( BALANC, 'L', N, ILO, IHI, LSCALE, RSCALE, N, VL, $ LDVL, IERR ) * DO 70 JC = 1, N IF( ALPHAI( JC ).LT.ZERO ) $ GO TO 70 TEMP = ZERO IF( ALPHAI( JC ).EQ.ZERO ) THEN DO 30 JR = 1, N TEMP = MAX( TEMP, ABS( VL( JR, JC ) ) ) 30 CONTINUE ELSE DO 40 JR = 1, N TEMP = MAX( TEMP, ABS( VL( JR, JC ) )+ $ ABS( VL( JR, JC+1 ) ) ) 40 CONTINUE END IF IF( TEMP.LT.SMLNUM ) $ GO TO 70 TEMP = ONE / TEMP IF( ALPHAI( JC ).EQ.ZERO ) THEN DO 50 JR = 1, N VL( JR, JC ) = VL( JR, JC )*TEMP 50 CONTINUE ELSE DO 60 JR = 1, N VL( JR, JC ) = VL( JR, JC )*TEMP VL( JR, JC+1 ) = VL( JR, JC+1 )*TEMP 60 CONTINUE END IF 70 CONTINUE END IF IF( ILVR ) THEN CALL DGGBAK( BALANC, 'R', N, ILO, IHI, LSCALE, RSCALE, N, VR, $ LDVR, IERR ) DO 120 JC = 1, N IF( ALPHAI( JC ).LT.ZERO ) $ GO TO 120 TEMP = ZERO IF( ALPHAI( JC ).EQ.ZERO ) THEN DO 80 JR = 1, N TEMP = MAX( TEMP, ABS( VR( JR, JC ) ) ) 80 CONTINUE ELSE DO 90 JR = 1, N TEMP = MAX( TEMP, ABS( VR( JR, JC ) )+ $ ABS( VR( JR, JC+1 ) ) ) 90 CONTINUE END IF IF( TEMP.LT.SMLNUM ) $ GO TO 120 TEMP = ONE / TEMP IF( ALPHAI( JC ).EQ.ZERO ) THEN DO 100 JR = 1, N VR( JR, JC ) = VR( JR, JC )*TEMP 100 CONTINUE ELSE DO 110 JR = 1, N VR( JR, JC ) = VR( JR, JC )*TEMP VR( JR, JC+1 ) = VR( JR, JC+1 )*TEMP 110 CONTINUE END IF 120 CONTINUE END IF * * Undo scaling if necessary * 130 CONTINUE * IF( ILASCL ) THEN CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR ) CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR ) END IF * IF( ILBSCL ) THEN CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR ) END IF * WORK( 1 ) = MAXWRK RETURN * * End of DGGEVX * END *> \brief \b DGGGLM * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGGGLM + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, * INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, P * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), D( * ), WORK( * ), * $ X( * ), Y( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGGGLM solves a general Gauss-Markov linear model (GLM) problem: *> *> minimize || y ||_2 subject to d = A*x + B*y *> x *> *> where A is an N-by-M matrix, B is an N-by-P matrix, and d is a *> given N-vector. It is assumed that M <= N <= M+P, and *> *> rank(A) = M and rank( A B ) = N. *> *> Under these assumptions, the constrained equation is always *> consistent, and there is a unique solution x and a minimal 2-norm *> solution y, which is obtained using a generalized QR factorization *> of the matrices (A, B) given by *> *> A = Q*(R), B = Q*T*Z. *> (0) *> *> In particular, if matrix B is square nonsingular, then the problem *> GLM is equivalent to the following weighted linear least squares *> problem *> *> minimize || inv(B)*(d-A*x) ||_2 *> x *> *> where inv(B) denotes the inverse of B. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The number of rows of the matrices A and B. N >= 0. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of columns of the matrix A. 0 <= M <= N. *> \endverbatim *> *> \param[in] P *> \verbatim *> P is INTEGER *> The number of columns of the matrix B. P >= N-M. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,M) *> On entry, the N-by-M matrix A. *> On exit, the upper triangular part of the array A contains *> the M-by-M upper triangular matrix R. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is 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. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> On entry, D is the left hand side of the GLM equation. *> On exit, D is destroyed. *> \endverbatim *> *> \param[out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (M) *> \endverbatim *> *> \param[out] Y *> \verbatim *> Y is DOUBLE PRECISION array, dimension (P) *> *> On exit, X and Y are the solutions of the GLM problem. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= max(1,N+M+P). *> For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB, *> where NB is an upper bound for the optimal blocksizes for *> DGEQRF, SGERQF, DORMQR and SORMRQ. *> *> 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> = 1: the upper triangular factor R associated with A in the *> generalized QR factorization of the pair (A, B) is *> singular, so that rank(A) < M; the least squares *> solution could not be computed. *> = 2: the bottom (N-M) by (N-M) part of the upper trapezoidal *> factor T associated with B in the generalized QR *> factorization of the pair (A, B) is singular, so that *> rank( A B ) < N; the least squares solution could not *> be computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHEReigen * * ===================================================================== SUBROUTINE DGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, $ INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, P * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), D( * ), WORK( * ), $ X( * ), Y( * ) * .. * * =================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, LOPT, LWKMIN, LWKOPT, NB, NB1, NB2, NB3, $ NB4, NP * .. * .. External Subroutines .. EXTERNAL DCOPY, DGEMV, DGGQRF, DORMQR, DORMRQ, DTRTRS, $ XERBLA * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 NP = MIN( N, P ) LQUERY = ( LWORK.EQ.-1 ) IF( N.LT.0 ) THEN INFO = -1 ELSE IF( M.LT.0 .OR. M.GT.N ) THEN INFO = -2 ELSE IF( P.LT.0 .OR. P.LT.N-M ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 END IF * * Calculate workspace * IF( INFO.EQ.0) THEN IF( N.EQ.0 ) THEN LWKMIN = 1 LWKOPT = 1 ELSE NB1 = ILAENV( 1, 'DGEQRF', ' ', N, M, -1, -1 ) NB2 = ILAENV( 1, 'DGERQF', ' ', N, M, -1, -1 ) NB3 = ILAENV( 1, 'DORMQR', ' ', N, M, P, -1 ) NB4 = ILAENV( 1, 'DORMRQ', ' ', N, M, P, -1 ) NB = MAX( NB1, NB2, NB3, NB4 ) LWKMIN = M + N + P LWKOPT = M + NP + MAX( N, P )*NB END IF WORK( 1 ) = LWKOPT * IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN INFO = -12 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGGGLM', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Compute the GQR factorization of matrices A and B: * * Q**T*A = ( R11 ) M, Q**T*B*Z**T = ( T11 T12 ) M * ( 0 ) N-M ( 0 T22 ) N-M * M M+P-N N-M * * where R11 and T22 are upper triangular, and Q and Z are * orthogonal. * CALL DGGQRF( N, M, P, A, LDA, WORK, B, LDB, WORK( M+1 ), $ WORK( M+NP+1 ), LWORK-M-NP, INFO ) LOPT = WORK( M+NP+1 ) * * Update left-hand-side vector d = Q**T*d = ( d1 ) M * ( d2 ) N-M * CALL DORMQR( 'Left', 'Transpose', N, 1, M, A, LDA, WORK, D, $ MAX( 1, N ), WORK( M+NP+1 ), LWORK-M-NP, INFO ) LOPT = MAX( LOPT, INT( WORK( M+NP+1 ) ) ) * * Solve T22*y2 = d2 for y2 * IF( N.GT.M ) THEN CALL DTRTRS( 'Upper', 'No transpose', 'Non unit', N-M, 1, $ B( M+1, M+P-N+1 ), LDB, D( M+1 ), N-M, INFO ) * IF( INFO.GT.0 ) THEN INFO = 1 RETURN END IF * CALL DCOPY( N-M, D( M+1 ), 1, Y( M+P-N+1 ), 1 ) END IF * * Set y1 = 0 * DO 10 I = 1, M + P - N Y( I ) = ZERO 10 CONTINUE * * Update d1 = d1 - T12*y2 * CALL DGEMV( 'No transpose', M, N-M, -ONE, B( 1, M+P-N+1 ), LDB, $ Y( M+P-N+1 ), 1, ONE, D, 1 ) * * Solve triangular system: R11*x = d1 * IF( M.GT.0 ) THEN CALL DTRTRS( 'Upper', 'No Transpose', 'Non unit', M, 1, A, LDA, $ D, M, INFO ) * IF( INFO.GT.0 ) THEN INFO = 2 RETURN END IF * * Copy D to X * CALL DCOPY( M, D, 1, X, 1 ) END IF * * Backward transformation y = Z**T *y * CALL DORMRQ( 'Left', 'Transpose', P, 1, NP, $ B( MAX( 1, N-P+1 ), 1 ), LDB, WORK( M+1 ), Y, $ MAX( 1, P ), WORK( M+NP+1 ), LWORK-M-NP, INFO ) WORK( 1 ) = M + NP + MAX( LOPT, INT( WORK( M+NP+1 ) ) ) * RETURN * * End of DGGGLM * END *> \brief \b DGGHRD * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGGHRD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, * LDQ, Z, LDZ, INFO ) * * .. 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, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] COMPQ *> \verbatim *> COMPQ is 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. *> \endverbatim *> *> \param[in] COMPZ *> \verbatim *> COMPZ is 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. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A and B. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is 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 DGGBAL; 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. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is 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. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is 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. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is 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'. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. *> LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is 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'. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. *> LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> 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.) *> \endverbatim *> * ===================================================================== SUBROUTINE DGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, $ LDQ, Z, LDZ, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), $ Z( LDZ, * ) * .. * * ===================================================================== * * .. 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 *> \brief DGGLSE solves overdetermined or underdetermined systems for OTHER matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGGLSE + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, * INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, P * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( * ), D( * ), * $ WORK( * ), X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGGLSE solves the linear equality-constrained least squares (LSE) *> problem: *> *> minimize || c - A*x ||_2 subject to B*x = d *> *> where A is an M-by-N matrix, B is a P-by-N matrix, c is a given *> M-vector, and d is a given P-vector. It is assumed that *> P <= N <= M+P, and *> *> rank(B) = P and rank( (A) ) = N. *> ( (B) ) *> *> These conditions ensure that the LSE problem has a unique solution, *> which is obtained using a generalized RQ factorization of the *> matrices (B, A) given by *> *> B = (0 R)*Q, A = Z*T*Q. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrices A and B. N >= 0. *> \endverbatim *> *> \param[in] P *> \verbatim *> P is INTEGER *> The number of rows of the matrix B. 0 <= P <= N <= M+P. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is 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 T. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,N) *> On entry, the P-by-N matrix B. *> On exit, the upper triangle of the subarray B(1:P,N-P+1:N) *> contains the P-by-P upper triangular matrix R. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,P). *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (M) *> On entry, C contains the right hand side vector for the *> least squares part of the LSE problem. *> On exit, the residual sum of squares for the solution *> is given by the sum of squares of elements N-P+1 to M of *> vector C. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (P) *> On entry, D contains the right hand side vector for the *> constrained equation. *> On exit, D is destroyed. *> \endverbatim *> *> \param[out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (N) *> On exit, X is the solution of the LSE problem. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= max(1,M+N+P). *> For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB, *> where NB is an upper bound for the optimal blocksizes for *> DGEQRF, SGERQF, DORMQR and SORMRQ. *> *> 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> = 1: the upper triangular factor R associated with B in the *> generalized RQ factorization of the pair (B, A) is *> singular, so that rank(B) < P; the least squares *> solution could not be computed. *> = 2: the (N-P) by (N-P) part of the upper trapezoidal factor *> T associated with A in the generalized RQ factorization *> of the pair (B, A) is singular, so that *> rank( (A) ) < N; the least squares solution could not *> ( (B) ) *> be computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERsolve * * ===================================================================== SUBROUTINE DGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, $ INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, P * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( * ), D( * ), $ WORK( * ), X( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER LOPT, LWKMIN, LWKOPT, MN, NB, NB1, NB2, NB3, $ NB4, NR * .. * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMV, DGGRQF, DORMQR, DORMRQ, $ DTRMV, DTRTRS, XERBLA * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 MN = MIN( M, N ) LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( P.LT.0 .OR. P.GT.N .OR. P.LT.N-M ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, P ) ) THEN INFO = -7 END IF * * Calculate workspace * IF( INFO.EQ.0) THEN IF( N.EQ.0 ) THEN LWKMIN = 1 LWKOPT = 1 ELSE NB1 = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) NB2 = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 ) NB3 = ILAENV( 1, 'DORMQR', ' ', M, N, P, -1 ) NB4 = ILAENV( 1, 'DORMRQ', ' ', M, N, P, -1 ) NB = MAX( NB1, NB2, NB3, NB4 ) LWKMIN = M + N + P LWKOPT = P + MN + MAX( M, N )*NB END IF WORK( 1 ) = LWKOPT * IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN INFO = -12 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGGLSE', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Compute the GRQ factorization of matrices B and A: * * B*Q**T = ( 0 T12 ) P Z**T*A*Q**T = ( R11 R12 ) N-P * N-P P ( 0 R22 ) M+P-N * N-P P * * where T12 and R11 are upper triangular, and Q and Z are * orthogonal. * CALL DGGRQF( P, M, N, B, LDB, WORK, A, LDA, WORK( P+1 ), $ WORK( P+MN+1 ), LWORK-P-MN, INFO ) LOPT = WORK( P+MN+1 ) * * Update c = Z**T *c = ( c1 ) N-P * ( c2 ) M+P-N * CALL DORMQR( 'Left', 'Transpose', M, 1, MN, A, LDA, WORK( P+1 ), $ C, MAX( 1, M ), WORK( P+MN+1 ), LWORK-P-MN, INFO ) LOPT = MAX( LOPT, INT( WORK( P+MN+1 ) ) ) * * Solve T12*x2 = d for x2 * IF( P.GT.0 ) THEN CALL DTRTRS( 'Upper', 'No transpose', 'Non-unit', P, 1, $ B( 1, N-P+1 ), LDB, D, P, INFO ) * IF( INFO.GT.0 ) THEN INFO = 1 RETURN END IF * * Put the solution in X * CALL DCOPY( P, D, 1, X( N-P+1 ), 1 ) * * Update c1 * CALL DGEMV( 'No transpose', N-P, P, -ONE, A( 1, N-P+1 ), LDA, $ D, 1, ONE, C, 1 ) END IF * * Solve R11*x1 = c1 for x1 * IF( N.GT.P ) THEN CALL DTRTRS( 'Upper', 'No transpose', 'Non-unit', N-P, 1, $ A, LDA, C, N-P, INFO ) * IF( INFO.GT.0 ) THEN INFO = 2 RETURN END IF * * Put the solutions in X * CALL DCOPY( N-P, C, 1, X, 1 ) END IF * * Compute the residual vector: * IF( M.LT.N ) THEN NR = M + P - N IF( NR.GT.0 ) $ CALL DGEMV( 'No transpose', NR, N-M, -ONE, A( N-P+1, M+1 ), $ LDA, D( NR+1 ), 1, ONE, C( N-P+1 ), 1 ) ELSE NR = P END IF IF( NR.GT.0 ) THEN CALL DTRMV( 'Upper', 'No transpose', 'Non unit', NR, $ A( N-P+1, N-P+1 ), LDA, D, 1 ) CALL DAXPY( NR, -ONE, D, 1, C( N-P+1 ), 1 ) END IF * * Backward transformation x = Q**T*x * CALL DORMRQ( 'Left', 'Transpose', N, 1, P, B, LDB, WORK( 1 ), X, $ N, WORK( P+MN+1 ), LWORK-P-MN, INFO ) WORK( 1 ) = P + MN + MAX( LOPT, INT( WORK( P+MN+1 ) ) ) * RETURN * * End of DGGLSE * END *> \brief \b DGGQRF * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGGQRF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, * LWORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, P * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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**T*(inv(T)*R) *> *> where inv(B) denotes the inverse of the matrix B, and Z**T denotes the *> transpose of the matrix Z. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The number of rows of the matrices A and B. N >= 0. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of columns of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] P *> \verbatim *> P is INTEGER *> The number of columns of the matrix B. P >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is 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). *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] TAUA *> \verbatim *> TAUA is DOUBLE PRECISION array, dimension (min(N,M)) *> The scalar factors of the elementary reflectors which *> represent the orthogonal matrix Q (see Further Details). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is 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). *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] TAUB *> \verbatim *> TAUB is DOUBLE PRECISION array, dimension (min(N,P)) *> The scalar factors of the elementary reflectors which *> represent the orthogonal matrix Z (see Further Details). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> 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**T *> *> 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**T *> *> 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. *> \endverbatim *> * ===================================================================== SUBROUTINE DGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, $ LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, P * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ), $ WORK( * ) * .. * * ===================================================================== * * .. 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**T*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 *> \brief \b DGGRQF * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGGRQF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, * LWORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LWORK, M, N, P * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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**T *> *> where inv(B) denotes the inverse of the matrix B, and Z**T denotes the *> transpose of the matrix Z. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] P *> \verbatim *> P is INTEGER *> The number of rows of the matrix B. P >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrices A and B. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is 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). *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] TAUA *> \verbatim *> TAUA is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors which *> represent the orthogonal matrix Q (see Further Details). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is 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). *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,P). *> \endverbatim *> *> \param[out] TAUB *> \verbatim *> TAUB is DOUBLE PRECISION array, dimension (min(P,N)) *> The scalar factors of the elementary reflectors which *> represent the orthogonal matrix Z (see Further Details). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INF0= -i, the i-th argument had an illegal value. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> 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**T *> *> 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**T *> *> 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. *> \endverbatim *> * ===================================================================== SUBROUTINE DGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, $ LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LWORK, M, N, P * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ), $ WORK( * ) * .. * * ===================================================================== * * .. 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**T * 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 *> \brief DGGSVD computes the singular value decomposition (SVD) for OTHER matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGGSVD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, * LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, * IWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBQ, JOBU, JOBV * INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION A( LDA, * ), ALPHA( * ), B( LDB, * ), * $ BETA( * ), Q( LDQ, * ), U( LDU, * ), * $ V( LDV, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> This routine is deprecated and has been replaced by routine DGGSVD3. *> *> DGGSVD computes the generalized singular value decomposition (GSVD) *> of an M-by-N real matrix A and P-by-N real matrix B: *> *> U**T*A*Q = D1*( 0 R ), V**T*B*Q = D2*( 0 R ) *> *> where U, V and Q are orthogonal matrices. *> Let K+L = the effective numerical rank of the matrix (A**T,B**T)**T, *> then R is a K+L-by-K+L nonsingular upper triangular matrix, D1 and *> D2 are M-by-(K+L) and P-by-(K+L) "diagonal" matrices and of the *> following structures, respectively: *> *> If M-K-L >= 0, *> *> K L *> D1 = K ( I 0 ) *> L ( 0 C ) *> M-K-L ( 0 0 ) *> *> K L *> D2 = L ( 0 S ) *> P-L ( 0 0 ) *> *> N-K-L K L *> ( 0 R ) = K ( 0 R11 R12 ) *> L ( 0 0 R22 ) *> *> where *> *> C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), *> S = diag( BETA(K+1), ... , BETA(K+L) ), *> C**2 + S**2 = I. *> *> R is stored in A(1:K+L,N-K-L+1:N) on exit. *> *> If M-K-L < 0, *> *> K M-K K+L-M *> D1 = K ( I 0 0 ) *> M-K ( 0 C 0 ) *> *> K M-K K+L-M *> D2 = M-K ( 0 S 0 ) *> K+L-M ( 0 0 I ) *> P-L ( 0 0 0 ) *> *> N-K-L K M-K K+L-M *> ( 0 R ) = K ( 0 R11 R12 R13 ) *> M-K ( 0 0 R22 R23 ) *> K+L-M ( 0 0 0 R33 ) *> *> where *> *> C = diag( ALPHA(K+1), ... , ALPHA(M) ), *> S = diag( BETA(K+1), ... , BETA(M) ), *> C**2 + S**2 = I. *> *> (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored *> ( 0 R22 R23 ) *> in B(M-K+1:L,N+M-K-L+1:N) on exit. *> *> The routine computes C, S, R, and optionally the orthogonal *> transformation matrices U, V and Q. *> *> In particular, if B is an N-by-N nonsingular matrix, then the GSVD of *> A and B implicitly gives the SVD of A*inv(B): *> A*inv(B) = U*(D1*inv(D2))*V**T. *> If ( A**T,B**T)**T has orthonormal columns, then the GSVD of A and B is *> also equal to the CS decomposition of A and B. Furthermore, the GSVD *> can be used to derive the solution of the eigenvalue problem: *> A**T*A x = lambda* B**T*B x. *> In some literature, the GSVD of A and B is presented in the form *> U**T*A*X = ( 0 D1 ), V**T*B*X = ( 0 D2 ) *> where U and V are orthogonal and X is nonsingular, D1 and D2 are *> ``diagonal''. The former GSVD form can be converted to the latter *> form by taking the nonsingular matrix X as *> *> X = Q*( I 0 ) *> ( 0 inv(R) ). *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBU *> \verbatim *> JOBU is CHARACTER*1 *> = 'U': Orthogonal matrix U is computed; *> = 'N': U is not computed. *> \endverbatim *> *> \param[in] JOBV *> \verbatim *> JOBV is CHARACTER*1 *> = 'V': Orthogonal matrix V is computed; *> = 'N': V is not computed. *> \endverbatim *> *> \param[in] JOBQ *> \verbatim *> JOBQ is CHARACTER*1 *> = 'Q': Orthogonal matrix Q is computed; *> = 'N': Q is not computed. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrices A and B. N >= 0. *> \endverbatim *> *> \param[in] P *> \verbatim *> P is INTEGER *> The number of rows of the matrix B. P >= 0. *> \endverbatim *> *> \param[out] K *> \verbatim *> K is INTEGER *> \endverbatim *> *> \param[out] L *> \verbatim *> L is INTEGER *> *> On exit, K and L specify the dimension of the subblocks *> described in Purpose. *> K + L = effective numerical rank of (A**T,B**T)**T. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the M-by-N matrix A. *> On exit, A contains the triangular matrix R, or part of R. *> See Purpose for details. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,N) *> On entry, the P-by-N matrix B. *> On exit, B contains the triangular matrix R if M-K-L < 0. *> See Purpose for details. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,P). *> \endverbatim *> *> \param[out] ALPHA *> \verbatim *> ALPHA is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] BETA *> \verbatim *> BETA is DOUBLE PRECISION array, dimension (N) *> *> On exit, ALPHA and BETA contain the generalized singular *> value pairs of A and B; *> ALPHA(1:K) = 1, *> BETA(1:K) = 0, *> and if M-K-L >= 0, *> ALPHA(K+1:K+L) = C, *> BETA(K+1:K+L) = S, *> or if M-K-L < 0, *> ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0 *> BETA(K+1:M) =S, BETA(M+1:K+L) =1 *> and *> ALPHA(K+L+1:N) = 0 *> BETA(K+L+1:N) = 0 *> \endverbatim *> *> \param[out] U *> \verbatim *> U is DOUBLE PRECISION array, dimension (LDU,M) *> If JOBU = 'U', U contains the M-by-M orthogonal matrix U. *> If JOBU = 'N', U is not referenced. *> \endverbatim *> *> \param[in] LDU *> \verbatim *> LDU is INTEGER *> The leading dimension of the array U. LDU >= max(1,M) if *> JOBU = 'U'; LDU >= 1 otherwise. *> \endverbatim *> *> \param[out] V *> \verbatim *> V is DOUBLE PRECISION array, dimension (LDV,P) *> If JOBV = 'V', V contains the P-by-P orthogonal matrix V. *> If JOBV = 'N', V is not referenced. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the array V. LDV >= max(1,P) if *> JOBV = 'V'; LDV >= 1 otherwise. *> \endverbatim *> *> \param[out] Q *> \verbatim *> Q is DOUBLE PRECISION array, dimension (LDQ,N) *> If JOBQ = 'Q', Q contains the N-by-N orthogonal matrix Q. *> If JOBQ = 'N', Q is not referenced. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= max(1,N) if *> JOBQ = 'Q'; LDQ >= 1 otherwise. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, *> dimension (max(3*N,M,P)+N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> On exit, IWORK stores the sorting information. More *> precisely, the following loop will sort ALPHA *> for I = K+1, min(M,K+L) *> swap ALPHA(I) and ALPHA(IWORK(I)) *> endfor *> such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: if INFO = 1, the Jacobi-type procedure failed to *> converge. For further details, see subroutine DTGSJA. *> \endverbatim * *> \par Internal Parameters: * ========================= *> *> \verbatim *> TOLA DOUBLE PRECISION *> TOLB DOUBLE PRECISION *> TOLA and TOLB are the thresholds to determine the effective *> rank of (A',B')**T. 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. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERsing * *> \par Contributors: * ================== *> *> Ming Gu and Huan Ren, Computer Science Division, University of *> California at Berkeley, USA *> * ===================================================================== SUBROUTINE DGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, $ LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, $ IWORK, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER JOBQ, JOBU, JOBV INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), ALPHA( * ), B( LDB, * ), $ BETA( * ), Q( LDQ, * ), U( LDU, * ), $ V( LDV, * ), WORK( * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL WANTQ, WANTU, WANTV INTEGER I, IBND, ISUB, J, NCYCLE DOUBLE PRECISION ANORM, BNORM, SMAX, TEMP, TOLA, TOLB, ULP, UNFL * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL LSAME, DLAMCH, DLANGE * .. * .. External Subroutines .. EXTERNAL DCOPY, DGGSVP, DTGSJA, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters * WANTU = LSAME( JOBU, 'U' ) WANTV = LSAME( JOBV, 'V' ) WANTQ = LSAME( JOBQ, 'Q' ) * 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( N.LT.0 ) THEN INFO = -5 ELSE IF( P.LT.0 ) THEN INFO = -6 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LDB.LT.MAX( 1, P ) ) THEN INFO = -12 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( 'DGGSVD', -INFO ) RETURN END IF * * Compute the Frobenius norm of matrices A and B * ANORM = DLANGE( '1', M, N, A, LDA, WORK ) BNORM = DLANGE( '1', P, N, B, LDB, WORK ) * * Get machine precision and set up threshold for determining * the effective numerical rank of the matrices A and B. * ULP = DLAMCH( 'Precision' ) UNFL = DLAMCH( 'Safe Minimum' ) TOLA = MAX( M, N )*MAX( ANORM, UNFL )*ULP TOLB = MAX( P, N )*MAX( BNORM, UNFL )*ULP * * Preprocessing * CALL DGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA, $ TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, WORK, $ WORK( N+1 ), INFO ) * * Compute the GSVD of two upper "triangular" matrices * CALL DTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, LDB, $ TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, $ WORK, NCYCLE, INFO ) * * Sort the singular values and store the pivot indices in IWORK * Copy ALPHA to WORK, then sort ALPHA in WORK * CALL DCOPY( N, ALPHA, 1, WORK, 1 ) IBND = MIN( L, M-K ) DO 20 I = 1, IBND * * Scan for largest ALPHA(K+I) * ISUB = I SMAX = WORK( K+I ) DO 10 J = I + 1, IBND TEMP = WORK( K+J ) IF( TEMP.GT.SMAX ) THEN ISUB = J SMAX = TEMP END IF 10 CONTINUE IF( ISUB.NE.I ) THEN WORK( K+ISUB ) = WORK( K+I ) WORK( K+I ) = SMAX IWORK( K+I ) = K + ISUB ELSE IWORK( K+I ) = K + I END IF 20 CONTINUE * RETURN * * End of DGGSVD * END *> \brief \b DGGSVP * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGGSVP + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 ) * * .. 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( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> This routine is deprecated and has been replaced by routine DGGSVP3. *> *> DGGSVP computes orthogonal matrices U, V and Q such that *> *> N-K-L K L *> U**T*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**T*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**T,B**T)**T. *> *> This decomposition is the preprocessing step for computing the *> Generalized Singular Value Decomposition (GSVD), see subroutine *> DGGSVD. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBU *> \verbatim *> JOBU is CHARACTER*1 *> = 'U': Orthogonal matrix U is computed; *> = 'N': U is not computed. *> \endverbatim *> *> \param[in] JOBV *> \verbatim *> JOBV is CHARACTER*1 *> = 'V': Orthogonal matrix V is computed; *> = 'N': V is not computed. *> \endverbatim *> *> \param[in] JOBQ *> \verbatim *> JOBQ is CHARACTER*1 *> = 'Q': Orthogonal matrix Q is computed; *> = 'N': Q is not computed. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] P *> \verbatim *> P is INTEGER *> The number of rows of the matrix B. P >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrices A and B. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is 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. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is 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. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,P). *> \endverbatim *> *> \param[in] TOLA *> \verbatim *> TOLA is DOUBLE PRECISION *> \endverbatim *> *> \param[in] TOLB *> \verbatim *> TOLB is 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)*MACHEPS, *> TOLB = MAX(P,N)*norm(B)*MACHEPS. *> The size of TOLA and TOLB may affect the size of backward *> errors of the decomposition. *> \endverbatim *> *> \param[out] K *> \verbatim *> K is INTEGER *> \endverbatim *> *> \param[out] L *> \verbatim *> L is INTEGER *> *> On exit, K and L specify the dimension of the subblocks *> described in Purpose section. *> K + L = effective numerical rank of (A**T,B**T)**T. *> \endverbatim *> *> \param[out] U *> \verbatim *> U is DOUBLE PRECISION array, dimension (LDU,M) *> If JOBU = 'U', U contains the orthogonal matrix U. *> If JOBU = 'N', U is not referenced. *> \endverbatim *> *> \param[in] LDU *> \verbatim *> LDU is INTEGER *> The leading dimension of the array U. LDU >= max(1,M) if *> JOBU = 'U'; LDU >= 1 otherwise. *> \endverbatim *> *> \param[out] V *> \verbatim *> V is DOUBLE PRECISION array, dimension (LDV,P) *> If JOBV = 'V', V contains the orthogonal matrix V. *> If JOBV = 'N', V is not referenced. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the array V. LDV >= max(1,P) if *> JOBV = 'V'; LDV >= 1 otherwise. *> \endverbatim *> *> \param[out] Q *> \verbatim *> Q is DOUBLE PRECISION array, dimension (LDQ,N) *> If JOBQ = 'Q', Q contains the orthogonal matrix Q. *> If JOBQ = 'N', Q is not referenced. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= max(1,N) if *> JOBQ = 'Q'; LDQ >= 1 otherwise. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (max(3*N,M,P)) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par 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. *> * ===================================================================== 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 computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER 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( * ) * .. * * ===================================================================== * * .. 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**T * CALL DORMR2( 'Right', 'Transpose', M, N, L, B, LDB, TAU, A, $ LDA, WORK, INFO ) * IF( WANTQ ) THEN * * Update Q := Q*Z**T * 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**T * ( 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**T*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**T * 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 *> \brief \b DGSVJ0 pre-processor for the routine dgesvj. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGSVJ0 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, * SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LDV, LWORK, M, MV, N, NSWEEP * DOUBLE PRECISION EPS, SFMIN, TOL * CHARACTER*1 JOBV * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), SVA( N ), D( N ), V( LDV, * ), * $ WORK( LWORK ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGSVJ0 is called from DGESVJ as a pre-processor and that is its main *> purpose. It applies Jacobi rotations in the same way as DGESVJ does, but *> it does not check convergence (stopping criterion). Few tuning *> parameters (marked by [TP]) are available for the implementer. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBV *> \verbatim *> JOBV is CHARACTER*1 *> Specifies whether the output from this procedure is used *> to compute the matrix V: *> = 'V': the product of the Jacobi rotations is accumulated *> by postmulyiplying the N-by-N array V. *> (See the description of V.) *> = 'A': the product of the Jacobi rotations is accumulated *> by postmulyiplying the MV-by-N array V. *> (See the descriptions of MV and V.) *> = 'N': the Jacobi rotations are not accumulated. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the input matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the input matrix A. *> M >= N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, M-by-N matrix A, such that A*diag(D) represents *> the input matrix. *> On exit, *> A_onexit * D_onexit represents the input matrix A*diag(D) *> post-multiplied by a sequence of Jacobi rotations, where the *> rotation threshold and the total number of sweeps are given in *> TOL and NSWEEP, respectively. *> (See the descriptions of D, TOL and NSWEEP.) *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The array D accumulates the scaling factors from the fast scaled *> Jacobi rotations. *> On entry, A*diag(D) represents the input matrix. *> On exit, A_onexit*diag(D_onexit) represents the input matrix *> post-multiplied by a sequence of Jacobi rotations, where the *> rotation threshold and the total number of sweeps are given in *> TOL and NSWEEP, respectively. *> (See the descriptions of A, TOL and NSWEEP.) *> \endverbatim *> *> \param[in,out] SVA *> \verbatim *> SVA is DOUBLE PRECISION array, dimension (N) *> On entry, SVA contains the Euclidean norms of the columns of *> the matrix A*diag(D). *> On exit, SVA contains the Euclidean norms of the columns of *> the matrix onexit*diag(D_onexit). *> \endverbatim *> *> \param[in] MV *> \verbatim *> MV is INTEGER *> If JOBV .EQ. 'A', then MV rows of V are post-multipled by a *> sequence of Jacobi rotations. *> If JOBV = 'N', then MV is not referenced. *> \endverbatim *> *> \param[in,out] V *> \verbatim *> V is DOUBLE PRECISION array, dimension (LDV,N) *> If JOBV .EQ. 'V' then N rows of V are post-multipled by a *> sequence of Jacobi rotations. *> If JOBV .EQ. 'A' then MV rows of V are post-multipled by a *> sequence of Jacobi rotations. *> If JOBV = 'N', then V is not referenced. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the array V, LDV >= 1. *> If JOBV = 'V', LDV .GE. N. *> If JOBV = 'A', LDV .GE. MV. *> \endverbatim *> *> \param[in] EPS *> \verbatim *> EPS is DOUBLE PRECISION *> EPS = DLAMCH('Epsilon') *> \endverbatim *> *> \param[in] SFMIN *> \verbatim *> SFMIN is DOUBLE PRECISION *> SFMIN = DLAMCH('Safe Minimum') *> \endverbatim *> *> \param[in] TOL *> \verbatim *> TOL is DOUBLE PRECISION *> TOL is the threshold for Jacobi rotations. For a pair *> A(:,p), A(:,q) of pivot columns, the Jacobi rotation is *> applied only if DABS(COS(angle(A(:,p),A(:,q)))) .GT. TOL. *> \endverbatim *> *> \param[in] NSWEEP *> \verbatim *> NSWEEP is INTEGER *> NSWEEP is the number of sweeps of Jacobi rotations to be *> performed. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (LWORK) *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> LWORK is the dimension of WORK. LWORK .GE. M. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0 : successful exit. *> < 0 : if INFO = -i, then the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date November 2017 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> DGSVJ0 is used just to enable DGESVJ to call a simplified version of *> itself to work on a submatrix of the original matrix. *> *> \par Contributors: * ================== *> *> Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) *> *> \par Bugs, Examples and Comments: * ================================= *> *> Please report all bugs and send interesting test examples and comments to *> drmac@math.hr. Thank you. * * ===================================================================== SUBROUTINE DGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, $ SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDV, LWORK, M, MV, N, NSWEEP DOUBLE PRECISION EPS, SFMIN, TOL CHARACTER*1 JOBV * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), SVA( N ), D( N ), V( LDV, * ), $ WORK( LWORK ) * .. * * ===================================================================== * * .. Local Parameters .. DOUBLE PRECISION ZERO, HALF, ONE PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0) * .. * .. Local Scalars .. DOUBLE PRECISION AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG, $ BIGTHETA, CS, MXAAPQ, MXSINJ, ROOTBIG, ROOTEPS, $ ROOTSFMIN, ROOTTOL, SMALL, SN, T, TEMP1, THETA, $ THSIGN INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1, $ ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, NBL, $ NOTROT, p, PSKIPPED, q, ROWSKIP, SWBAND LOGICAL APPLV, ROTOK, RSVEC * .. * .. Local Arrays .. DOUBLE PRECISION FASTR( 5 ) * .. * .. Intrinsic Functions .. INTRINSIC DABS, MAX, DBLE, MIN, DSIGN, DSQRT * .. * .. External Functions .. DOUBLE PRECISION DDOT, DNRM2 INTEGER IDAMAX LOGICAL LSAME EXTERNAL IDAMAX, LSAME, DDOT, DNRM2 * .. * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DLASCL, DLASSQ, DROTM, DSWAP, $ XERBLA * .. * .. Executable Statements .. * * Test the input parameters. * APPLV = LSAME( JOBV, 'A' ) RSVEC = LSAME( JOBV, 'V' ) IF( .NOT.( RSVEC .OR. APPLV .OR. LSAME( JOBV, 'N' ) ) ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -2 ELSE IF( ( N.LT.0 ) .OR. ( N.GT.M ) ) THEN INFO = -3 ELSE IF( LDA.LT.M ) THEN INFO = -5 ELSE IF( ( RSVEC.OR.APPLV ) .AND. ( MV.LT.0 ) ) THEN INFO = -8 ELSE IF( ( RSVEC.AND.( LDV.LT.N ) ).OR. $ ( APPLV.AND.( LDV.LT.MV ) ) ) THEN INFO = -10 ELSE IF( TOL.LE.EPS ) THEN INFO = -13 ELSE IF( NSWEEP.LT.0 ) THEN INFO = -14 ELSE IF( LWORK.LT.M ) THEN INFO = -16 ELSE INFO = 0 END IF * * #:( IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGSVJ0', -INFO ) RETURN END IF * IF( RSVEC ) THEN MVL = N ELSE IF( APPLV ) THEN MVL = MV END IF RSVEC = RSVEC .OR. APPLV ROOTEPS = DSQRT( EPS ) ROOTSFMIN = DSQRT( SFMIN ) SMALL = SFMIN / EPS BIG = ONE / SFMIN ROOTBIG = ONE / ROOTSFMIN BIGTHETA = ONE / ROOTEPS ROOTTOL = DSQRT( TOL ) * * -#- Row-cyclic Jacobi SVD algorithm with column pivoting -#- * EMPTSW = ( N*( N-1 ) ) / 2 NOTROT = 0 FASTR( 1 ) = ZERO * * -#- Row-cyclic pivot strategy with de Rijk's pivoting -#- * SWBAND = 0 *[TP] SWBAND is a tuning parameter. It is meaningful and effective * if SGESVJ is used as a computational routine in the preconditioned * Jacobi SVD algorithm SGESVJ. For sweeps i=1:SWBAND the procedure * ...... KBL = MIN( 8, N ) *[TP] KBL is a tuning parameter that defines the tile size in the * tiling of the p-q loops of pivot pairs. In general, an optimal * value of KBL depends on the matrix dimensions and on the * parameters of the computer's memory. * NBL = N / KBL IF( ( NBL*KBL ).NE.N )NBL = NBL + 1 BLSKIP = ( KBL**2 ) + 1 *[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL. ROWSKIP = MIN( 5, KBL ) *[TP] ROWSKIP is a tuning parameter. LKAHEAD = 1 *[TP] LKAHEAD is a tuning parameter. SWBAND = 0 PSKIPPED = 0 * DO 1993 i = 1, NSWEEP * .. go go go ... * MXAAPQ = ZERO MXSINJ = ZERO ISWROT = 0 * NOTROT = 0 PSKIPPED = 0 * DO 2000 ibr = 1, NBL igl = ( ibr-1 )*KBL + 1 * DO 1002 ir1 = 0, MIN( LKAHEAD, NBL-ibr ) * igl = igl + ir1*KBL * DO 2001 p = igl, MIN( igl+KBL-1, N-1 ) * .. de Rijk's pivoting q = IDAMAX( N-p+1, SVA( p ), 1 ) + p - 1 IF( p.NE.q ) THEN CALL DSWAP( M, A( 1, p ), 1, A( 1, q ), 1 ) IF( RSVEC )CALL DSWAP( MVL, V( 1, p ), 1, $ V( 1, q ), 1 ) TEMP1 = SVA( p ) SVA( p ) = SVA( q ) SVA( q ) = TEMP1 TEMP1 = D( p ) D( p ) = D( q ) D( q ) = TEMP1 END IF * IF( ir1.EQ.0 ) THEN * * Column norms are periodically updated by explicit * norm computation. * Caveat: * Some BLAS implementations compute DNRM2(M,A(1,p),1) * as DSQRT(DDOT(M,A(1,p),1,A(1,p),1)), which may result in * overflow for ||A(:,p)||_2 > DSQRT(overflow_threshold), and * undeflow for ||A(:,p)||_2 < DSQRT(underflow_threshold). * Hence, DNRM2 cannot be trusted, not even in the case when * the true norm is far from the under(over)flow boundaries. * If properly implemented DNRM2 is available, the IF-THEN-ELSE * below should read "AAPP = DNRM2( M, A(1,p), 1 ) * D(p)". * IF( ( SVA( p ).LT.ROOTBIG ) .AND. $ ( SVA( p ).GT.ROOTSFMIN ) ) THEN SVA( p ) = DNRM2( M, A( 1, p ), 1 )*D( p ) ELSE TEMP1 = ZERO AAPP = ONE CALL DLASSQ( M, A( 1, p ), 1, TEMP1, AAPP ) SVA( p ) = TEMP1*DSQRT( AAPP )*D( p ) END IF AAPP = SVA( p ) ELSE AAPP = SVA( p ) END IF * IF( AAPP.GT.ZERO ) THEN * PSKIPPED = 0 * DO 2002 q = p + 1, MIN( igl+KBL-1, N ) * AAQQ = SVA( q ) IF( AAQQ.GT.ZERO ) THEN * AAPP0 = AAPP IF( AAQQ.GE.ONE ) THEN ROTOK = ( SMALL*AAPP ).LE.AAQQ IF( AAPP.LT.( BIG / AAQQ ) ) THEN AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1, $ q ), 1 )*D( p )*D( q ) / AAQQ ) $ / AAPP ELSE CALL DCOPY( M, A( 1, p ), 1, WORK, 1 ) CALL DLASCL( 'G', 0, 0, AAPP, D( p ), $ M, 1, WORK, LDA, IERR ) AAPQ = DDOT( M, WORK, 1, A( 1, q ), $ 1 )*D( q ) / AAQQ END IF ELSE ROTOK = AAPP.LE.( AAQQ / SMALL ) IF( AAPP.GT.( SMALL / AAQQ ) ) THEN AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1, $ q ), 1 )*D( p )*D( q ) / AAQQ ) $ / AAPP ELSE CALL DCOPY( M, A( 1, q ), 1, WORK, 1 ) CALL DLASCL( 'G', 0, 0, AAQQ, D( q ), $ M, 1, WORK, LDA, IERR ) AAPQ = DDOT( M, WORK, 1, A( 1, p ), $ 1 )*D( p ) / AAPP END IF END IF * MXAAPQ = MAX( MXAAPQ, DABS( AAPQ ) ) * * TO rotate or NOT to rotate, THAT is the question ... * IF( DABS( AAPQ ).GT.TOL ) THEN * * .. rotate * ROTATED = ROTATED + ONE * IF( ir1.EQ.0 ) THEN NOTROT = 0 PSKIPPED = 0 ISWROT = ISWROT + 1 END IF * IF( ROTOK ) THEN * AQOAP = AAQQ / AAPP APOAQ = AAPP / AAQQ THETA = -HALF*DABS( AQOAP-APOAQ )/AAPQ * IF( DABS( THETA ).GT.BIGTHETA ) THEN * T = HALF / THETA FASTR( 3 ) = T*D( p ) / D( q ) FASTR( 4 ) = -T*D( q ) / D( p ) CALL DROTM( M, A( 1, p ), 1, $ A( 1, q ), 1, FASTR ) IF( RSVEC )CALL DROTM( MVL, $ V( 1, p ), 1, $ V( 1, q ), 1, $ FASTR ) SVA( q ) = AAQQ*DSQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ ) ) AAPP = AAPP*DSQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ ) ) MXSINJ = MAX( MXSINJ, DABS( T ) ) * ELSE * * .. choose correct signum for THETA and rotate * THSIGN = -DSIGN( ONE, AAPQ ) T = ONE / ( THETA+THSIGN* $ DSQRT( ONE+THETA*THETA ) ) CS = DSQRT( ONE / ( ONE+T*T ) ) SN = T*CS * MXSINJ = MAX( MXSINJ, DABS( SN ) ) SVA( q ) = AAQQ*DSQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ ) ) AAPP = AAPP*DSQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ ) ) * APOAQ = D( p ) / D( q ) AQOAP = D( q ) / D( p ) IF( D( p ).GE.ONE ) THEN IF( D( q ).GE.ONE ) THEN FASTR( 3 ) = T*APOAQ FASTR( 4 ) = -T*AQOAP D( p ) = D( p )*CS D( q ) = D( q )*CS CALL DROTM( M, A( 1, p ), 1, $ A( 1, q ), 1, $ FASTR ) IF( RSVEC )CALL DROTM( MVL, $ V( 1, p ), 1, V( 1, q ), $ 1, FASTR ) ELSE CALL DAXPY( M, -T*AQOAP, $ A( 1, q ), 1, $ A( 1, p ), 1 ) CALL DAXPY( M, CS*SN*APOAQ, $ A( 1, p ), 1, $ A( 1, q ), 1 ) D( p ) = D( p )*CS D( q ) = D( q ) / CS IF( RSVEC ) THEN CALL DAXPY( MVL, -T*AQOAP, $ V( 1, q ), 1, $ V( 1, p ), 1 ) CALL DAXPY( MVL, $ CS*SN*APOAQ, $ V( 1, p ), 1, $ V( 1, q ), 1 ) END IF END IF ELSE IF( D( q ).GE.ONE ) THEN CALL DAXPY( M, T*APOAQ, $ A( 1, p ), 1, $ A( 1, q ), 1 ) CALL DAXPY( M, -CS*SN*AQOAP, $ A( 1, q ), 1, $ A( 1, p ), 1 ) D( p ) = D( p ) / CS D( q ) = D( q )*CS IF( RSVEC ) THEN CALL DAXPY( MVL, T*APOAQ, $ V( 1, p ), 1, $ V( 1, q ), 1 ) CALL DAXPY( MVL, $ -CS*SN*AQOAP, $ V( 1, q ), 1, $ V( 1, p ), 1 ) END IF ELSE IF( D( p ).GE.D( q ) ) THEN CALL DAXPY( M, -T*AQOAP, $ A( 1, q ), 1, $ A( 1, p ), 1 ) CALL DAXPY( M, CS*SN*APOAQ, $ A( 1, p ), 1, $ A( 1, q ), 1 ) D( p ) = D( p )*CS D( q ) = D( q ) / CS IF( RSVEC ) THEN CALL DAXPY( MVL, $ -T*AQOAP, $ V( 1, q ), 1, $ V( 1, p ), 1 ) CALL DAXPY( MVL, $ CS*SN*APOAQ, $ V( 1, p ), 1, $ V( 1, q ), 1 ) END IF ELSE CALL DAXPY( M, T*APOAQ, $ A( 1, p ), 1, $ A( 1, q ), 1 ) CALL DAXPY( M, $ -CS*SN*AQOAP, $ A( 1, q ), 1, $ A( 1, p ), 1 ) D( p ) = D( p ) / CS D( q ) = D( q )*CS IF( RSVEC ) THEN CALL DAXPY( MVL, $ T*APOAQ, V( 1, p ), $ 1, V( 1, q ), 1 ) CALL DAXPY( MVL, $ -CS*SN*AQOAP, $ V( 1, q ), 1, $ V( 1, p ), 1 ) END IF END IF END IF END IF END IF * ELSE * .. have to use modified Gram-Schmidt like transformation CALL DCOPY( M, A( 1, p ), 1, WORK, 1 ) CALL DLASCL( 'G', 0, 0, AAPP, ONE, M, $ 1, WORK, LDA, IERR ) CALL DLASCL( 'G', 0, 0, AAQQ, ONE, M, $ 1, A( 1, q ), LDA, IERR ) TEMP1 = -AAPQ*D( p ) / D( q ) CALL DAXPY( M, TEMP1, WORK, 1, $ A( 1, q ), 1 ) CALL DLASCL( 'G', 0, 0, ONE, AAQQ, M, $ 1, A( 1, q ), LDA, IERR ) SVA( q ) = AAQQ*DSQRT( MAX( ZERO, $ ONE-AAPQ*AAPQ ) ) MXSINJ = MAX( MXSINJ, SFMIN ) END IF * END IF ROTOK THEN ... ELSE * * In the case of cancellation in updating SVA(q), SVA(p) * recompute SVA(q), SVA(p). IF( ( SVA( q ) / AAQQ )**2.LE.ROOTEPS ) $ THEN IF( ( AAQQ.LT.ROOTBIG ) .AND. $ ( AAQQ.GT.ROOTSFMIN ) ) THEN SVA( q ) = DNRM2( M, A( 1, q ), 1 )* $ D( q ) ELSE T = ZERO AAQQ = ONE CALL DLASSQ( M, A( 1, q ), 1, T, $ AAQQ ) SVA( q ) = T*DSQRT( AAQQ )*D( q ) END IF END IF IF( ( AAPP / AAPP0 ).LE.ROOTEPS ) THEN IF( ( AAPP.LT.ROOTBIG ) .AND. $ ( AAPP.GT.ROOTSFMIN ) ) THEN AAPP = DNRM2( M, A( 1, p ), 1 )* $ D( p ) ELSE T = ZERO AAPP = ONE CALL DLASSQ( M, A( 1, p ), 1, T, $ AAPP ) AAPP = T*DSQRT( AAPP )*D( p ) END IF SVA( p ) = AAPP END IF * ELSE * A(:,p) and A(:,q) already numerically orthogonal IF( ir1.EQ.0 )NOTROT = NOTROT + 1 PSKIPPED = PSKIPPED + 1 END IF ELSE * A(:,q) is zero column IF( ir1.EQ.0 )NOTROT = NOTROT + 1 PSKIPPED = PSKIPPED + 1 END IF * IF( ( i.LE.SWBAND ) .AND. $ ( PSKIPPED.GT.ROWSKIP ) ) THEN IF( ir1.EQ.0 )AAPP = -AAPP NOTROT = 0 GO TO 2103 END IF * 2002 CONTINUE * END q-LOOP * 2103 CONTINUE * bailed out of q-loop SVA( p ) = AAPP ELSE SVA( p ) = AAPP IF( ( ir1.EQ.0 ) .AND. ( AAPP.EQ.ZERO ) ) $ NOTROT = NOTROT + MIN( igl+KBL-1, N ) - p END IF * 2001 CONTINUE * end of the p-loop * end of doing the block ( ibr, ibr ) 1002 CONTINUE * end of ir1-loop * *........................................................ * ... go to the off diagonal blocks * igl = ( ibr-1 )*KBL + 1 * DO 2010 jbc = ibr + 1, NBL * jgl = ( jbc-1 )*KBL + 1 * * doing the block at ( ibr, jbc ) * IJBLSK = 0 DO 2100 p = igl, MIN( igl+KBL-1, N ) * AAPP = SVA( p ) * IF( AAPP.GT.ZERO ) THEN * PSKIPPED = 0 * DO 2200 q = jgl, MIN( jgl+KBL-1, N ) * AAQQ = SVA( q ) * IF( AAQQ.GT.ZERO ) THEN AAPP0 = AAPP * * -#- M x 2 Jacobi SVD -#- * * -#- Safe Gram matrix computation -#- * IF( AAQQ.GE.ONE ) THEN IF( AAPP.GE.AAQQ ) THEN ROTOK = ( SMALL*AAPP ).LE.AAQQ ELSE ROTOK = ( SMALL*AAQQ ).LE.AAPP END IF IF( AAPP.LT.( BIG / AAQQ ) ) THEN AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1, $ q ), 1 )*D( p )*D( q ) / AAQQ ) $ / AAPP ELSE CALL DCOPY( M, A( 1, p ), 1, WORK, 1 ) CALL DLASCL( 'G', 0, 0, AAPP, D( p ), $ M, 1, WORK, LDA, IERR ) AAPQ = DDOT( M, WORK, 1, A( 1, q ), $ 1 )*D( q ) / AAQQ END IF ELSE IF( AAPP.GE.AAQQ ) THEN ROTOK = AAPP.LE.( AAQQ / SMALL ) ELSE ROTOK = AAQQ.LE.( AAPP / SMALL ) END IF IF( AAPP.GT.( SMALL / AAQQ ) ) THEN AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1, $ q ), 1 )*D( p )*D( q ) / AAQQ ) $ / AAPP ELSE CALL DCOPY( M, A( 1, q ), 1, WORK, 1 ) CALL DLASCL( 'G', 0, 0, AAQQ, D( q ), $ M, 1, WORK, LDA, IERR ) AAPQ = DDOT( M, WORK, 1, A( 1, p ), $ 1 )*D( p ) / AAPP END IF END IF * MXAAPQ = MAX( MXAAPQ, DABS( AAPQ ) ) * * TO rotate or NOT to rotate, THAT is the question ... * IF( DABS( AAPQ ).GT.TOL ) THEN NOTROT = 0 * ROTATED = ROTATED + 1 PSKIPPED = 0 ISWROT = ISWROT + 1 * IF( ROTOK ) THEN * AQOAP = AAQQ / AAPP APOAQ = AAPP / AAQQ THETA = -HALF*DABS( AQOAP-APOAQ )/AAPQ IF( AAQQ.GT.AAPP0 )THETA = -THETA * IF( DABS( THETA ).GT.BIGTHETA ) THEN T = HALF / THETA FASTR( 3 ) = T*D( p ) / D( q ) FASTR( 4 ) = -T*D( q ) / D( p ) CALL DROTM( M, A( 1, p ), 1, $ A( 1, q ), 1, FASTR ) IF( RSVEC )CALL DROTM( MVL, $ V( 1, p ), 1, $ V( 1, q ), 1, $ FASTR ) SVA( q ) = AAQQ*DSQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ ) ) AAPP = AAPP*DSQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ ) ) MXSINJ = MAX( MXSINJ, DABS( T ) ) ELSE * * .. choose correct signum for THETA and rotate * THSIGN = -DSIGN( ONE, AAPQ ) IF( AAQQ.GT.AAPP0 )THSIGN = -THSIGN T = ONE / ( THETA+THSIGN* $ DSQRT( ONE+THETA*THETA ) ) CS = DSQRT( ONE / ( ONE+T*T ) ) SN = T*CS MXSINJ = MAX( MXSINJ, DABS( SN ) ) SVA( q ) = AAQQ*DSQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ ) ) AAPP = AAPP*DSQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ ) ) * APOAQ = D( p ) / D( q ) AQOAP = D( q ) / D( p ) IF( D( p ).GE.ONE ) THEN * IF( D( q ).GE.ONE ) THEN FASTR( 3 ) = T*APOAQ FASTR( 4 ) = -T*AQOAP D( p ) = D( p )*CS D( q ) = D( q )*CS CALL DROTM( M, A( 1, p ), 1, $ A( 1, q ), 1, $ FASTR ) IF( RSVEC )CALL DROTM( MVL, $ V( 1, p ), 1, V( 1, q ), $ 1, FASTR ) ELSE CALL DAXPY( M, -T*AQOAP, $ A( 1, q ), 1, $ A( 1, p ), 1 ) CALL DAXPY( M, CS*SN*APOAQ, $ A( 1, p ), 1, $ A( 1, q ), 1 ) IF( RSVEC ) THEN CALL DAXPY( MVL, -T*AQOAP, $ V( 1, q ), 1, $ V( 1, p ), 1 ) CALL DAXPY( MVL, $ CS*SN*APOAQ, $ V( 1, p ), 1, $ V( 1, q ), 1 ) END IF D( p ) = D( p )*CS D( q ) = D( q ) / CS END IF ELSE IF( D( q ).GE.ONE ) THEN CALL DAXPY( M, T*APOAQ, $ A( 1, p ), 1, $ A( 1, q ), 1 ) CALL DAXPY( M, -CS*SN*AQOAP, $ A( 1, q ), 1, $ A( 1, p ), 1 ) IF( RSVEC ) THEN CALL DAXPY( MVL, T*APOAQ, $ V( 1, p ), 1, $ V( 1, q ), 1 ) CALL DAXPY( MVL, $ -CS*SN*AQOAP, $ V( 1, q ), 1, $ V( 1, p ), 1 ) END IF D( p ) = D( p ) / CS D( q ) = D( q )*CS ELSE IF( D( p ).GE.D( q ) ) THEN CALL DAXPY( M, -T*AQOAP, $ A( 1, q ), 1, $ A( 1, p ), 1 ) CALL DAXPY( M, CS*SN*APOAQ, $ A( 1, p ), 1, $ A( 1, q ), 1 ) D( p ) = D( p )*CS D( q ) = D( q ) / CS IF( RSVEC ) THEN CALL DAXPY( MVL, $ -T*AQOAP, $ V( 1, q ), 1, $ V( 1, p ), 1 ) CALL DAXPY( MVL, $ CS*SN*APOAQ, $ V( 1, p ), 1, $ V( 1, q ), 1 ) END IF ELSE CALL DAXPY( M, T*APOAQ, $ A( 1, p ), 1, $ A( 1, q ), 1 ) CALL DAXPY( M, $ -CS*SN*AQOAP, $ A( 1, q ), 1, $ A( 1, p ), 1 ) D( p ) = D( p ) / CS D( q ) = D( q )*CS IF( RSVEC ) THEN CALL DAXPY( MVL, $ T*APOAQ, V( 1, p ), $ 1, V( 1, q ), 1 ) CALL DAXPY( MVL, $ -CS*SN*AQOAP, $ V( 1, q ), 1, $ V( 1, p ), 1 ) END IF END IF END IF END IF END IF * ELSE IF( AAPP.GT.AAQQ ) THEN CALL DCOPY( M, A( 1, p ), 1, WORK, $ 1 ) CALL DLASCL( 'G', 0, 0, AAPP, ONE, $ M, 1, WORK, LDA, IERR ) CALL DLASCL( 'G', 0, 0, AAQQ, ONE, $ M, 1, A( 1, q ), LDA, $ IERR ) TEMP1 = -AAPQ*D( p ) / D( q ) CALL DAXPY( M, TEMP1, WORK, 1, $ A( 1, q ), 1 ) CALL DLASCL( 'G', 0, 0, ONE, AAQQ, $ M, 1, A( 1, q ), LDA, $ IERR ) SVA( q ) = AAQQ*DSQRT( MAX( ZERO, $ ONE-AAPQ*AAPQ ) ) MXSINJ = MAX( MXSINJ, SFMIN ) ELSE CALL DCOPY( M, A( 1, q ), 1, WORK, $ 1 ) CALL DLASCL( 'G', 0, 0, AAQQ, ONE, $ M, 1, WORK, LDA, IERR ) CALL DLASCL( 'G', 0, 0, AAPP, ONE, $ M, 1, A( 1, p ), LDA, $ IERR ) TEMP1 = -AAPQ*D( q ) / D( p ) CALL DAXPY( M, TEMP1, WORK, 1, $ A( 1, p ), 1 ) CALL DLASCL( 'G', 0, 0, ONE, AAPP, $ M, 1, A( 1, p ), LDA, $ IERR ) SVA( p ) = AAPP*DSQRT( MAX( ZERO, $ ONE-AAPQ*AAPQ ) ) MXSINJ = MAX( MXSINJ, SFMIN ) END IF END IF * END IF ROTOK THEN ... ELSE * * In the case of cancellation in updating SVA(q) * .. recompute SVA(q) IF( ( SVA( q ) / AAQQ )**2.LE.ROOTEPS ) $ THEN IF( ( AAQQ.LT.ROOTBIG ) .AND. $ ( AAQQ.GT.ROOTSFMIN ) ) THEN SVA( q ) = DNRM2( M, A( 1, q ), 1 )* $ D( q ) ELSE T = ZERO AAQQ = ONE CALL DLASSQ( M, A( 1, q ), 1, T, $ AAQQ ) SVA( q ) = T*DSQRT( AAQQ )*D( q ) END IF END IF IF( ( AAPP / AAPP0 )**2.LE.ROOTEPS ) THEN IF( ( AAPP.LT.ROOTBIG ) .AND. $ ( AAPP.GT.ROOTSFMIN ) ) THEN AAPP = DNRM2( M, A( 1, p ), 1 )* $ D( p ) ELSE T = ZERO AAPP = ONE CALL DLASSQ( M, A( 1, p ), 1, T, $ AAPP ) AAPP = T*DSQRT( AAPP )*D( p ) END IF SVA( p ) = AAPP END IF * end of OK rotation ELSE NOTROT = NOTROT + 1 PSKIPPED = PSKIPPED + 1 IJBLSK = IJBLSK + 1 END IF ELSE NOTROT = NOTROT + 1 PSKIPPED = PSKIPPED + 1 IJBLSK = IJBLSK + 1 END IF * IF( ( i.LE.SWBAND ) .AND. ( IJBLSK.GE.BLSKIP ) ) $ THEN SVA( p ) = AAPP NOTROT = 0 GO TO 2011 END IF IF( ( i.LE.SWBAND ) .AND. $ ( PSKIPPED.GT.ROWSKIP ) ) THEN AAPP = -AAPP NOTROT = 0 GO TO 2203 END IF * 2200 CONTINUE * end of the q-loop 2203 CONTINUE * SVA( p ) = AAPP * ELSE IF( AAPP.EQ.ZERO )NOTROT = NOTROT + $ MIN( jgl+KBL-1, N ) - jgl + 1 IF( AAPP.LT.ZERO )NOTROT = 0 END IF 2100 CONTINUE * end of the p-loop 2010 CONTINUE * end of the jbc-loop 2011 CONTINUE *2011 bailed out of the jbc-loop DO 2012 p = igl, MIN( igl+KBL-1, N ) SVA( p ) = DABS( SVA( p ) ) 2012 CONTINUE * 2000 CONTINUE *2000 :: end of the ibr-loop * * .. update SVA(N) IF( ( SVA( N ).LT.ROOTBIG ) .AND. ( SVA( N ).GT.ROOTSFMIN ) ) $ THEN SVA( N ) = DNRM2( M, A( 1, N ), 1 )*D( N ) ELSE T = ZERO AAPP = ONE CALL DLASSQ( M, A( 1, N ), 1, T, AAPP ) SVA( N ) = T*DSQRT( AAPP )*D( N ) END IF * * Additional steering devices * IF( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR. $ ( ISWROT.LE.N ) ) )SWBAND = i * IF( ( i.GT.SWBAND+1 ) .AND. ( MXAAPQ.LT.DBLE( N )*TOL ) .AND. $ ( DBLE( N )*MXAAPQ*MXSINJ.LT.TOL ) ) THEN GO TO 1994 END IF * IF( NOTROT.GE.EMPTSW )GO TO 1994 1993 CONTINUE * end i=1:NSWEEP loop * #:) Reaching this point means that the procedure has comleted the given * number of iterations. INFO = NSWEEP - 1 GO TO 1995 1994 CONTINUE * #:) Reaching this point means that during the i-th sweep all pivots were * below the given tolerance, causing early exit. * INFO = 0 * #:) INFO = 0 confirms successful iterations. 1995 CONTINUE * * Sort the vector D. DO 5991 p = 1, N - 1 q = IDAMAX( N-p+1, SVA( p ), 1 ) + p - 1 IF( p.NE.q ) THEN TEMP1 = SVA( p ) SVA( p ) = SVA( q ) SVA( q ) = TEMP1 TEMP1 = D( p ) D( p ) = D( q ) D( q ) = TEMP1 CALL DSWAP( M, A( 1, p ), 1, A( 1, q ), 1 ) IF( RSVEC )CALL DSWAP( MVL, V( 1, p ), 1, V( 1, q ), 1 ) END IF 5991 CONTINUE * RETURN * .. * .. END OF DGSVJ0 * .. END *> \brief \b DGSVJ1 pre-processor for the routine dgesvj, applies Jacobi rotations targeting only particular pivots. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGSVJ1 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, * EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * DOUBLE PRECISION EPS, SFMIN, TOL * INTEGER INFO, LDA, LDV, LWORK, M, MV, N, N1, NSWEEP * CHARACTER*1 JOBV * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), D( N ), SVA( N ), V( LDV, * ), * $ WORK( LWORK ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGSVJ1 is called from DGESVJ as a pre-processor and that is its main *> purpose. It applies Jacobi rotations in the same way as DGESVJ does, but *> it targets only particular pivots and it does not check convergence *> (stopping criterion). Few tunning parameters (marked by [TP]) are *> available for the implementer. *> *> Further Details *> ~~~~~~~~~~~~~~~ *> DGSVJ1 applies few sweeps of Jacobi rotations in the column space of *> the input M-by-N matrix A. The pivot pairs are taken from the (1,2) *> off-diagonal block in the corresponding N-by-N Gram matrix A^T * A. The *> block-entries (tiles) of the (1,2) off-diagonal block are marked by the *> [x]'s in the following scheme: *> *> | * * * [x] [x] [x]| *> | * * * [x] [x] [x]| Row-cycling in the nblr-by-nblc [x] blocks. *> | * * * [x] [x] [x]| Row-cyclic pivoting inside each [x] block. *> |[x] [x] [x] * * * | *> |[x] [x] [x] * * * | *> |[x] [x] [x] * * * | *> *> In terms of the columns of A, the first N1 columns are rotated 'against' *> the remaining N-N1 columns, trying to increase the angle between the *> corresponding subspaces. The off-diagonal block is N1-by(N-N1) and it is *> tiled using quadratic tiles of side KBL. Here, KBL is a tunning parmeter. *> The number of sweeps is given in NSWEEP and the orthogonality threshold *> is given in TOL. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBV *> \verbatim *> JOBV is CHARACTER*1 *> Specifies whether the output from this procedure is used *> to compute the matrix V: *> = 'V': the product of the Jacobi rotations is accumulated *> by postmulyiplying the N-by-N array V. *> (See the description of V.) *> = 'A': the product of the Jacobi rotations is accumulated *> by postmulyiplying the MV-by-N array V. *> (See the descriptions of MV and V.) *> = 'N': the Jacobi rotations are not accumulated. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the input matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the input matrix A. *> M >= N >= 0. *> \endverbatim *> *> \param[in] N1 *> \verbatim *> N1 is INTEGER *> N1 specifies the 2 x 2 block partition, the first N1 columns are *> rotated 'against' the remaining N-N1 columns of A. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, M-by-N matrix A, such that A*diag(D) represents *> the input matrix. *> On exit, *> A_onexit * D_onexit represents the input matrix A*diag(D) *> post-multiplied by a sequence of Jacobi rotations, where the *> rotation threshold and the total number of sweeps are given in *> TOL and NSWEEP, respectively. *> (See the descriptions of N1, D, TOL and NSWEEP.) *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The array D accumulates the scaling factors from the fast scaled *> Jacobi rotations. *> On entry, A*diag(D) represents the input matrix. *> On exit, A_onexit*diag(D_onexit) represents the input matrix *> post-multiplied by a sequence of Jacobi rotations, where the *> rotation threshold and the total number of sweeps are given in *> TOL and NSWEEP, respectively. *> (See the descriptions of N1, A, TOL and NSWEEP.) *> \endverbatim *> *> \param[in,out] SVA *> \verbatim *> SVA is DOUBLE PRECISION array, dimension (N) *> On entry, SVA contains the Euclidean norms of the columns of *> the matrix A*diag(D). *> On exit, SVA contains the Euclidean norms of the columns of *> the matrix onexit*diag(D_onexit). *> \endverbatim *> *> \param[in] MV *> \verbatim *> MV is INTEGER *> If JOBV .EQ. 'A', then MV rows of V are post-multipled by a *> sequence of Jacobi rotations. *> If JOBV = 'N', then MV is not referenced. *> \endverbatim *> *> \param[in,out] V *> \verbatim *> V is DOUBLE PRECISION array, dimension (LDV,N) *> If JOBV .EQ. 'V' then N rows of V are post-multipled by a *> sequence of Jacobi rotations. *> If JOBV .EQ. 'A' then MV rows of V are post-multipled by a *> sequence of Jacobi rotations. *> If JOBV = 'N', then V is not referenced. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the array V, LDV >= 1. *> If JOBV = 'V', LDV .GE. N. *> If JOBV = 'A', LDV .GE. MV. *> \endverbatim *> *> \param[in] EPS *> \verbatim *> EPS is DOUBLE PRECISION *> EPS = DLAMCH('Epsilon') *> \endverbatim *> *> \param[in] SFMIN *> \verbatim *> SFMIN is DOUBLE PRECISION *> SFMIN = DLAMCH('Safe Minimum') *> \endverbatim *> *> \param[in] TOL *> \verbatim *> TOL is DOUBLE PRECISION *> TOL is the threshold for Jacobi rotations. For a pair *> A(:,p), A(:,q) of pivot columns, the Jacobi rotation is *> applied only if DABS(COS(angle(A(:,p),A(:,q)))) .GT. TOL. *> \endverbatim *> *> \param[in] NSWEEP *> \verbatim *> NSWEEP is INTEGER *> NSWEEP is the number of sweeps of Jacobi rotations to be *> performed. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (LWORK) *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> LWORK is the dimension of WORK. LWORK .GE. M. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0 : successful exit. *> < 0 : if INFO = -i, then the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleOTHERcomputational * *> \par Contributors: * ================== *> *> Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) * * ===================================================================== SUBROUTINE DGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, $ EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. DOUBLE PRECISION EPS, SFMIN, TOL INTEGER INFO, LDA, LDV, LWORK, M, MV, N, N1, NSWEEP CHARACTER*1 JOBV * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), D( N ), SVA( N ), V( LDV, * ), $ WORK( LWORK ) * .. * * ===================================================================== * * .. Local Parameters .. DOUBLE PRECISION ZERO, HALF, ONE PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. DOUBLE PRECISION AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG, $ BIGTHETA, CS, LARGE, MXAAPQ, MXSINJ, ROOTBIG, $ ROOTEPS, ROOTSFMIN, ROOTTOL, SMALL, SN, T, $ TEMP1, THETA, THSIGN INTEGER BLSKIP, EMPTSW, i, ibr, igl, IERR, IJBLSK, $ ISWROT, jbc, jgl, KBL, MVL, NOTROT, nblc, nblr, $ p, PSKIPPED, q, ROWSKIP, SWBAND LOGICAL APPLV, ROTOK, RSVEC * .. * .. Local Arrays .. DOUBLE PRECISION FASTR( 5 ) * .. * .. Intrinsic Functions .. INTRINSIC DABS, MAX, DBLE, MIN, DSIGN, DSQRT * .. * .. External Functions .. DOUBLE PRECISION DDOT, DNRM2 INTEGER IDAMAX LOGICAL LSAME EXTERNAL IDAMAX, LSAME, DDOT, DNRM2 * .. * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DLASCL, DLASSQ, DROTM, DSWAP, $ XERBLA * .. * .. Executable Statements .. * * Test the input parameters. * APPLV = LSAME( JOBV, 'A' ) RSVEC = LSAME( JOBV, 'V' ) IF( .NOT.( RSVEC .OR. APPLV .OR. LSAME( JOBV, 'N' ) ) ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -2 ELSE IF( ( N.LT.0 ) .OR. ( N.GT.M ) ) THEN INFO = -3 ELSE IF( N1.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.M ) THEN INFO = -6 ELSE IF( ( RSVEC.OR.APPLV ) .AND. ( MV.LT.0 ) ) THEN INFO = -9 ELSE IF( ( RSVEC.AND.( LDV.LT.N ) ).OR. $ ( APPLV.AND.( LDV.LT.MV ) ) ) THEN INFO = -11 ELSE IF( TOL.LE.EPS ) THEN INFO = -14 ELSE IF( NSWEEP.LT.0 ) THEN INFO = -15 ELSE IF( LWORK.LT.M ) THEN INFO = -17 ELSE INFO = 0 END IF * * #:( IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGSVJ1', -INFO ) RETURN END IF * IF( RSVEC ) THEN MVL = N ELSE IF( APPLV ) THEN MVL = MV END IF RSVEC = RSVEC .OR. APPLV ROOTEPS = DSQRT( EPS ) ROOTSFMIN = DSQRT( SFMIN ) SMALL = SFMIN / EPS BIG = ONE / SFMIN ROOTBIG = ONE / ROOTSFMIN LARGE = BIG / DSQRT( DBLE( M*N ) ) BIGTHETA = ONE / ROOTEPS ROOTTOL = DSQRT( TOL ) * * .. Initialize the right singular vector matrix .. * * RSVEC = LSAME( JOBV, 'Y' ) * EMPTSW = N1*( N-N1 ) NOTROT = 0 FASTR( 1 ) = ZERO * * .. Row-cyclic pivot strategy with de Rijk's pivoting .. * KBL = MIN( 8, N ) NBLR = N1 / KBL IF( ( NBLR*KBL ).NE.N1 )NBLR = NBLR + 1 * .. the tiling is nblr-by-nblc [tiles] NBLC = ( N-N1 ) / KBL IF( ( NBLC*KBL ).NE.( N-N1 ) )NBLC = NBLC + 1 BLSKIP = ( KBL**2 ) + 1 *[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL. ROWSKIP = MIN( 5, KBL ) *[TP] ROWSKIP is a tuning parameter. SWBAND = 0 *[TP] SWBAND is a tuning parameter. It is meaningful and effective * if SGESVJ is used as a computational routine in the preconditioned * Jacobi SVD algorithm SGESVJ. * * * | * * * [x] [x] [x]| * | * * * [x] [x] [x]| Row-cycling in the nblr-by-nblc [x] blocks. * | * * * [x] [x] [x]| Row-cyclic pivoting inside each [x] block. * |[x] [x] [x] * * * | * |[x] [x] [x] * * * | * |[x] [x] [x] * * * | * * DO 1993 i = 1, NSWEEP * .. go go go ... * MXAAPQ = ZERO MXSINJ = ZERO ISWROT = 0 * NOTROT = 0 PSKIPPED = 0 * DO 2000 ibr = 1, NBLR igl = ( ibr-1 )*KBL + 1 * * *........................................................ * ... go to the off diagonal blocks igl = ( ibr-1 )*KBL + 1 DO 2010 jbc = 1, NBLC jgl = N1 + ( jbc-1 )*KBL + 1 * doing the block at ( ibr, jbc ) IJBLSK = 0 DO 2100 p = igl, MIN( igl+KBL-1, N1 ) AAPP = SVA( p ) IF( AAPP.GT.ZERO ) THEN PSKIPPED = 0 DO 2200 q = jgl, MIN( jgl+KBL-1, N ) * AAQQ = SVA( q ) IF( AAQQ.GT.ZERO ) THEN AAPP0 = AAPP * * .. M x 2 Jacobi SVD .. * * .. Safe Gram matrix computation .. * IF( AAQQ.GE.ONE ) THEN IF( AAPP.GE.AAQQ ) THEN ROTOK = ( SMALL*AAPP ).LE.AAQQ ELSE ROTOK = ( SMALL*AAQQ ).LE.AAPP END IF IF( AAPP.LT.( BIG / AAQQ ) ) THEN AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1, $ q ), 1 )*D( p )*D( q ) / AAQQ ) $ / AAPP ELSE CALL DCOPY( M, A( 1, p ), 1, WORK, 1 ) CALL DLASCL( 'G', 0, 0, AAPP, D( p ), $ M, 1, WORK, LDA, IERR ) AAPQ = DDOT( M, WORK, 1, A( 1, q ), $ 1 )*D( q ) / AAQQ END IF ELSE IF( AAPP.GE.AAQQ ) THEN ROTOK = AAPP.LE.( AAQQ / SMALL ) ELSE ROTOK = AAQQ.LE.( AAPP / SMALL ) END IF IF( AAPP.GT.( SMALL / AAQQ ) ) THEN AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1, $ q ), 1 )*D( p )*D( q ) / AAQQ ) $ / AAPP ELSE CALL DCOPY( M, A( 1, q ), 1, WORK, 1 ) CALL DLASCL( 'G', 0, 0, AAQQ, D( q ), $ M, 1, WORK, LDA, IERR ) AAPQ = DDOT( M, WORK, 1, A( 1, p ), $ 1 )*D( p ) / AAPP END IF END IF MXAAPQ = MAX( MXAAPQ, DABS( AAPQ ) ) * TO rotate or NOT to rotate, THAT is the question ... * IF( DABS( AAPQ ).GT.TOL ) THEN NOTROT = 0 * ROTATED = ROTATED + 1 PSKIPPED = 0 ISWROT = ISWROT + 1 * IF( ROTOK ) THEN * AQOAP = AAQQ / AAPP APOAQ = AAPP / AAQQ THETA = -HALF*DABS(AQOAP-APOAQ) / AAPQ IF( AAQQ.GT.AAPP0 )THETA = -THETA IF( DABS( THETA ).GT.BIGTHETA ) THEN T = HALF / THETA FASTR( 3 ) = T*D( p ) / D( q ) FASTR( 4 ) = -T*D( q ) / D( p ) CALL DROTM( M, A( 1, p ), 1, $ A( 1, q ), 1, FASTR ) IF( RSVEC )CALL DROTM( MVL, $ V( 1, p ), 1, $ V( 1, q ), 1, $ FASTR ) SVA( q ) = AAQQ*DSQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ ) ) AAPP = AAPP*DSQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ ) ) MXSINJ = MAX( MXSINJ, DABS( T ) ) ELSE * * .. choose correct signum for THETA and rotate * THSIGN = -DSIGN( ONE, AAPQ ) IF( AAQQ.GT.AAPP0 )THSIGN = -THSIGN T = ONE / ( THETA+THSIGN* $ DSQRT( ONE+THETA*THETA ) ) CS = DSQRT( ONE / ( ONE+T*T ) ) SN = T*CS MXSINJ = MAX( MXSINJ, DABS( SN ) ) SVA( q ) = AAQQ*DSQRT( MAX( ZERO, $ ONE+T*APOAQ*AAPQ ) ) AAPP = AAPP*DSQRT( MAX( ZERO, $ ONE-T*AQOAP*AAPQ ) ) APOAQ = D( p ) / D( q ) AQOAP = D( q ) / D( p ) IF( D( p ).GE.ONE ) THEN * IF( D( q ).GE.ONE ) THEN FASTR( 3 ) = T*APOAQ FASTR( 4 ) = -T*AQOAP D( p ) = D( p )*CS D( q ) = D( q )*CS CALL DROTM( M, A( 1, p ), 1, $ A( 1, q ), 1, $ FASTR ) IF( RSVEC )CALL DROTM( MVL, $ V( 1, p ), 1, V( 1, q ), $ 1, FASTR ) ELSE CALL DAXPY( M, -T*AQOAP, $ A( 1, q ), 1, $ A( 1, p ), 1 ) CALL DAXPY( M, CS*SN*APOAQ, $ A( 1, p ), 1, $ A( 1, q ), 1 ) IF( RSVEC ) THEN CALL DAXPY( MVL, -T*AQOAP, $ V( 1, q ), 1, $ V( 1, p ), 1 ) CALL DAXPY( MVL, $ CS*SN*APOAQ, $ V( 1, p ), 1, $ V( 1, q ), 1 ) END IF D( p ) = D( p )*CS D( q ) = D( q ) / CS END IF ELSE IF( D( q ).GE.ONE ) THEN CALL DAXPY( M, T*APOAQ, $ A( 1, p ), 1, $ A( 1, q ), 1 ) CALL DAXPY( M, -CS*SN*AQOAP, $ A( 1, q ), 1, $ A( 1, p ), 1 ) IF( RSVEC ) THEN CALL DAXPY( MVL, T*APOAQ, $ V( 1, p ), 1, $ V( 1, q ), 1 ) CALL DAXPY( MVL, $ -CS*SN*AQOAP, $ V( 1, q ), 1, $ V( 1, p ), 1 ) END IF D( p ) = D( p ) / CS D( q ) = D( q )*CS ELSE IF( D( p ).GE.D( q ) ) THEN CALL DAXPY( M, -T*AQOAP, $ A( 1, q ), 1, $ A( 1, p ), 1 ) CALL DAXPY( M, CS*SN*APOAQ, $ A( 1, p ), 1, $ A( 1, q ), 1 ) D( p ) = D( p )*CS D( q ) = D( q ) / CS IF( RSVEC ) THEN CALL DAXPY( MVL, $ -T*AQOAP, $ V( 1, q ), 1, $ V( 1, p ), 1 ) CALL DAXPY( MVL, $ CS*SN*APOAQ, $ V( 1, p ), 1, $ V( 1, q ), 1 ) END IF ELSE CALL DAXPY( M, T*APOAQ, $ A( 1, p ), 1, $ A( 1, q ), 1 ) CALL DAXPY( M, $ -CS*SN*AQOAP, $ A( 1, q ), 1, $ A( 1, p ), 1 ) D( p ) = D( p ) / CS D( q ) = D( q )*CS IF( RSVEC ) THEN CALL DAXPY( MVL, $ T*APOAQ, V( 1, p ), $ 1, V( 1, q ), 1 ) CALL DAXPY( MVL, $ -CS*SN*AQOAP, $ V( 1, q ), 1, $ V( 1, p ), 1 ) END IF END IF END IF END IF END IF ELSE IF( AAPP.GT.AAQQ ) THEN CALL DCOPY( M, A( 1, p ), 1, WORK, $ 1 ) CALL DLASCL( 'G', 0, 0, AAPP, ONE, $ M, 1, WORK, LDA, IERR ) CALL DLASCL( 'G', 0, 0, AAQQ, ONE, $ M, 1, A( 1, q ), LDA, $ IERR ) TEMP1 = -AAPQ*D( p ) / D( q ) CALL DAXPY( M, TEMP1, WORK, 1, $ A( 1, q ), 1 ) CALL DLASCL( 'G', 0, 0, ONE, AAQQ, $ M, 1, A( 1, q ), LDA, $ IERR ) SVA( q ) = AAQQ*DSQRT( MAX( ZERO, $ ONE-AAPQ*AAPQ ) ) MXSINJ = MAX( MXSINJ, SFMIN ) ELSE CALL DCOPY( M, A( 1, q ), 1, WORK, $ 1 ) CALL DLASCL( 'G', 0, 0, AAQQ, ONE, $ M, 1, WORK, LDA, IERR ) CALL DLASCL( 'G', 0, 0, AAPP, ONE, $ M, 1, A( 1, p ), LDA, $ IERR ) TEMP1 = -AAPQ*D( q ) / D( p ) CALL DAXPY( M, TEMP1, WORK, 1, $ A( 1, p ), 1 ) CALL DLASCL( 'G', 0, 0, ONE, AAPP, $ M, 1, A( 1, p ), LDA, $ IERR ) SVA( p ) = AAPP*DSQRT( MAX( ZERO, $ ONE-AAPQ*AAPQ ) ) MXSINJ = MAX( MXSINJ, SFMIN ) END IF END IF * END IF ROTOK THEN ... ELSE * * In the case of cancellation in updating SVA(q) * .. recompute SVA(q) IF( ( SVA( q ) / AAQQ )**2.LE.ROOTEPS ) $ THEN IF( ( AAQQ.LT.ROOTBIG ) .AND. $ ( AAQQ.GT.ROOTSFMIN ) ) THEN SVA( q ) = DNRM2( M, A( 1, q ), 1 )* $ D( q ) ELSE T = ZERO AAQQ = ONE CALL DLASSQ( M, A( 1, q ), 1, T, $ AAQQ ) SVA( q ) = T*DSQRT( AAQQ )*D( q ) END IF END IF IF( ( AAPP / AAPP0 )**2.LE.ROOTEPS ) THEN IF( ( AAPP.LT.ROOTBIG ) .AND. $ ( AAPP.GT.ROOTSFMIN ) ) THEN AAPP = DNRM2( M, A( 1, p ), 1 )* $ D( p ) ELSE T = ZERO AAPP = ONE CALL DLASSQ( M, A( 1, p ), 1, T, $ AAPP ) AAPP = T*DSQRT( AAPP )*D( p ) END IF SVA( p ) = AAPP END IF * end of OK rotation ELSE NOTROT = NOTROT + 1 * SKIPPED = SKIPPED + 1 PSKIPPED = PSKIPPED + 1 IJBLSK = IJBLSK + 1 END IF ELSE NOTROT = NOTROT + 1 PSKIPPED = PSKIPPED + 1 IJBLSK = IJBLSK + 1 END IF * IF ( NOTROT .GE. EMPTSW ) GO TO 2011 IF( ( i.LE.SWBAND ) .AND. ( IJBLSK.GE.BLSKIP ) ) $ THEN SVA( p ) = AAPP NOTROT = 0 GO TO 2011 END IF IF( ( i.LE.SWBAND ) .AND. $ ( PSKIPPED.GT.ROWSKIP ) ) THEN AAPP = -AAPP NOTROT = 0 GO TO 2203 END IF * 2200 CONTINUE * end of the q-loop 2203 CONTINUE SVA( p ) = AAPP * ELSE IF( AAPP.EQ.ZERO )NOTROT = NOTROT + $ MIN( jgl+KBL-1, N ) - jgl + 1 IF( AAPP.LT.ZERO )NOTROT = 0 *** IF ( NOTROT .GE. EMPTSW ) GO TO 2011 END IF 2100 CONTINUE * end of the p-loop 2010 CONTINUE * end of the jbc-loop 2011 CONTINUE *2011 bailed out of the jbc-loop DO 2012 p = igl, MIN( igl+KBL-1, N ) SVA( p ) = DABS( SVA( p ) ) 2012 CONTINUE *** IF ( NOTROT .GE. EMPTSW ) GO TO 1994 2000 CONTINUE *2000 :: end of the ibr-loop * * .. update SVA(N) IF( ( SVA( N ).LT.ROOTBIG ) .AND. ( SVA( N ).GT.ROOTSFMIN ) ) $ THEN SVA( N ) = DNRM2( M, A( 1, N ), 1 )*D( N ) ELSE T = ZERO AAPP = ONE CALL DLASSQ( M, A( 1, N ), 1, T, AAPP ) SVA( N ) = T*DSQRT( AAPP )*D( N ) END IF * * Additional steering devices * IF( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR. $ ( ISWROT.LE.N ) ) )SWBAND = i IF( ( i.GT.SWBAND+1 ) .AND. ( MXAAPQ.LT.DBLE( N )*TOL ) .AND. $ ( DBLE( N )*MXAAPQ*MXSINJ.LT.TOL ) ) THEN GO TO 1994 END IF * IF( NOTROT.GE.EMPTSW )GO TO 1994 1993 CONTINUE * end i=1:NSWEEP loop * #:) Reaching this point means that the procedure has completed the given * number of sweeps. INFO = NSWEEP - 1 GO TO 1995 1994 CONTINUE * #:) Reaching this point means that during the i-th sweep all pivots were * below the given threshold, causing early exit. INFO = 0 * #:) INFO = 0 confirms successful iterations. 1995 CONTINUE * * Sort the vector D * DO 5991 p = 1, N - 1 q = IDAMAX( N-p+1, SVA( p ), 1 ) + p - 1 IF( p.NE.q ) THEN TEMP1 = SVA( p ) SVA( p ) = SVA( q ) SVA( q ) = TEMP1 TEMP1 = D( p ) D( p ) = D( q ) D( q ) = TEMP1 CALL DSWAP( M, A( 1, p ), 1, A( 1, q ), 1 ) IF( RSVEC )CALL DSWAP( MVL, V( 1, p ), 1, V( 1, q ), 1 ) END IF 5991 CONTINUE * RETURN * .. * .. END OF DGSVJ1 * .. END *> \brief \b DGTCON * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGTCON + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, * WORK, IWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER NORM * INTEGER INFO, N * DOUBLE PRECISION ANORM, RCOND * .. * .. Array Arguments .. * INTEGER IPIV( * ), IWORK( * ) * DOUBLE PRECISION D( * ), DL( * ), DU( * ), DU2( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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))). *> \endverbatim * * Arguments: * ========== * *> \param[in] NORM *> \verbatim *> NORM is 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. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] DL *> \verbatim *> DL is 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. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The n diagonal elements of the upper triangular matrix U from *> the LU factorization of A. *> \endverbatim *> *> \param[in] DU *> \verbatim *> DU is DOUBLE PRECISION array, dimension (N-1) *> The (n-1) elements of the first superdiagonal of U. *> \endverbatim *> *> \param[in] DU2 *> \verbatim *> DU2 is DOUBLE PRECISION array, dimension (N-2) *> The (n-2) elements of the second superdiagonal of U. *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is 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. *> \endverbatim *> *> \param[in] ANORM *> \verbatim *> ANORM is 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. *> \endverbatim *> *> \param[out] RCOND *> \verbatim *> RCOND is 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. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (2*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGTcomputational * * ===================================================================== SUBROUTINE DGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, $ WORK, IWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER NORM INTEGER INFO, N DOUBLE PRECISION ANORM, RCOND * .. * .. Array Arguments .. INTEGER IPIV( * ), IWORK( * ) DOUBLE PRECISION D( * ), DL( * ), DU( * ), DU2( * ), WORK( * ) * .. * * ===================================================================== * * .. 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**T)*inv(U**T). * 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 *> \brief \b DGTRFS * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGTRFS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, * IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, * INFO ) * * .. 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, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANS *> \verbatim *> TRANS is 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) *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrix B. NRHS >= 0. *> \endverbatim *> *> \param[in] DL *> \verbatim *> DL is DOUBLE PRECISION array, dimension (N-1) *> The (n-1) subdiagonal elements of A. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The diagonal elements of A. *> \endverbatim *> *> \param[in] DU *> \verbatim *> DU is DOUBLE PRECISION array, dimension (N-1) *> The (n-1) superdiagonal elements of A. *> \endverbatim *> *> \param[in] DLF *> \verbatim *> DLF is 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. *> \endverbatim *> *> \param[in] DF *> \verbatim *> DF is DOUBLE PRECISION array, dimension (N) *> The n diagonal elements of the upper triangular matrix U from *> the LU factorization of A. *> \endverbatim *> *> \param[in] DUF *> \verbatim *> DUF is DOUBLE PRECISION array, dimension (N-1) *> The (n-1) elements of the first superdiagonal of U. *> \endverbatim *> *> \param[in] DU2 *> \verbatim *> DU2 is DOUBLE PRECISION array, dimension (N-2) *> The (n-2) elements of the second superdiagonal of U. *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is 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. *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> The right hand side matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,NRHS) *> On entry, the solution matrix X, as computed by DGTTRS. *> On exit, the improved solution matrix X. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the array X. LDX >= max(1,N). *> \endverbatim *> *> \param[out] FERR *> \verbatim *> FERR is 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. *> \endverbatim *> *> \param[out] BERR *> \verbatim *> BERR is 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). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * *> \par Internal Parameters: * ========================= *> *> \verbatim *> ITMAX is the maximum number of steps of iterative refinement. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGTcomputational * * ===================================================================== SUBROUTINE DGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, $ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, $ INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER 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, * ) * .. * * ===================================================================== * * .. 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 *> \brief DGTSV computes the solution to system of linear equations A * X = B for GT matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGTSV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGTSV( N, NRHS, DL, D, DU, B, LDB, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. * DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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**T*X = B may be solved by interchanging the *> order of the arguments DU and DL. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrix B. NRHS >= 0. *> \endverbatim *> *> \param[in,out] DL *> \verbatim *> DL is 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). *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is 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. *> \endverbatim *> *> \param[in,out] DU *> \verbatim *> DU is 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. *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is 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. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, U(i,i) is exactly zero, and the solution *> has not been computed. The factorization has not been *> completed unless i = N. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGTsolve * * ===================================================================== SUBROUTINE DGTSV( N, NRHS, DL, D, DU, B, LDB, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ) * .. * * ===================================================================== * * .. 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 *> \brief DGTSVX computes the solution to system of linear equations A * X = B for GT matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGTSVX + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, * DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, * WORK, IWORK, INFO ) * * .. 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, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * *> \par Description: * ================= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] FACT *> \verbatim *> FACT is 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. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is 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) *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrix B. NRHS >= 0. *> \endverbatim *> *> \param[in] DL *> \verbatim *> DL is DOUBLE PRECISION array, dimension (N-1) *> The (n-1) subdiagonal elements of A. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The n diagonal elements of A. *> \endverbatim *> *> \param[in] DU *> \verbatim *> DU is DOUBLE PRECISION array, dimension (N-1) *> The (n-1) superdiagonal elements of A. *> \endverbatim *> *> \param[in,out] DLF *> \verbatim *> DLF is 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. *> \endverbatim *> *> \param[in,out] DF *> \verbatim *> DF is 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. *> \endverbatim *> *> \param[in,out] DUF *> \verbatim *> DUF is 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. *> \endverbatim *> *> \param[in,out] DU2 *> \verbatim *> DU2 is 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. *> \endverbatim *> *> \param[in,out] IPIV *> \verbatim *> IPIV is 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. *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> The N-by-NRHS right hand side matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,NRHS) *> If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the array X. LDX >= max(1,N). *> \endverbatim *> *> \param[out] RCOND *> \verbatim *> RCOND is 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. *> \endverbatim *> *> \param[out] FERR *> \verbatim *> FERR is 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. *> \endverbatim *> *> \param[out] BERR *> \verbatim *> BERR is 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). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 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. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGTsolve * * ===================================================================== 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 driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER 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, * ) * .. * * ===================================================================== * * .. 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 *> \brief \b DGTTRF * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGTTRF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGTTRF( N, DL, D, DU, DU2, IPIV, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, N * .. * .. Array Arguments .. * INTEGER IPIV( * ) * DOUBLE PRECISION D( * ), DL( * ), DU( * ), DU2( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. *> \endverbatim *> *> \param[in,out] DL *> \verbatim *> DL is 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. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is 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. *> \endverbatim *> *> \param[in,out] DU *> \verbatim *> DU is 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. *> \endverbatim *> *> \param[out] DU2 *> \verbatim *> DU2 is DOUBLE PRECISION array, dimension (N-2) *> On exit, DU2 is overwritten by the (n-2) elements of the *> second super-diagonal of U. *> \endverbatim *> *> \param[out] IPIV *> \verbatim *> IPIV is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is 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. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGTcomputational * * ===================================================================== SUBROUTINE DGTTRF( N, DL, D, DU, DU2, IPIV, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION D( * ), DL( * ), DU( * ), DU2( * ) * .. * * ===================================================================== * * .. 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 *> \brief \b DGTTRS * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGTTRS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, * INFO ) * * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. * INTEGER IPIV( * ) * DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGTTRS solves one of the systems of equations *> A*X = B or A**T*X = B, *> with a tridiagonal matrix A using the LU factorization computed *> by DGTTRF. *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> Specifies the form of the system of equations. *> = 'N': A * X = B (No transpose) *> = 'T': A**T* X = B (Transpose) *> = 'C': A**T* X = B (Conjugate transpose = Transpose) *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrix B. NRHS >= 0. *> \endverbatim *> *> \param[in] DL *> \verbatim *> DL is DOUBLE PRECISION array, dimension (N-1) *> The (n-1) multipliers that define the matrix L from the *> LU factorization of A. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The n diagonal elements of the upper triangular matrix U from *> the LU factorization of A. *> \endverbatim *> *> \param[in] DU *> \verbatim *> DU is DOUBLE PRECISION array, dimension (N-1) *> The (n-1) elements of the first super-diagonal of U. *> \endverbatim *> *> \param[in] DU2 *> \verbatim *> DU2 is DOUBLE PRECISION array, dimension (N-2) *> The (n-2) elements of the second super-diagonal of U. *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is 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. *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is 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. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGTcomputational * * ===================================================================== SUBROUTINE DGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, $ INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER TRANS INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) * .. * * ===================================================================== * * .. 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 *> \brief \b DGTTS2 solves a system of linear equations with a tridiagonal matrix using the LU factorization computed by sgttrf. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DGTTS2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) * * .. Scalar Arguments .. * INTEGER ITRANS, LDB, N, NRHS * .. * .. Array Arguments .. * INTEGER IPIV( * ) * DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DGTTS2 solves one of the systems of equations *> A*X = B or A**T*X = B, *> with a tridiagonal matrix A using the LU factorization computed *> by DGTTRF. *> \endverbatim * * Arguments: * ========== * *> \param[in] ITRANS *> \verbatim *> ITRANS is INTEGER *> Specifies the form of the system of equations. *> = 0: A * X = B (No transpose) *> = 1: A**T* X = B (Transpose) *> = 2: A**T* X = B (Conjugate transpose = Transpose) *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrix B. NRHS >= 0. *> \endverbatim *> *> \param[in] DL *> \verbatim *> DL is DOUBLE PRECISION array, dimension (N-1) *> The (n-1) multipliers that define the matrix L from the *> LU factorization of A. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The n diagonal elements of the upper triangular matrix U from *> the LU factorization of A. *> \endverbatim *> *> \param[in] DU *> \verbatim *> DU is DOUBLE PRECISION array, dimension (N-1) *> The (n-1) elements of the first super-diagonal of U. *> \endverbatim *> *> \param[in] DU2 *> \verbatim *> DU2 is DOUBLE PRECISION array, dimension (N-2) *> The (n-2) elements of the second super-diagonal of U. *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is 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. *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is 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. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGTcomputational * * ===================================================================== SUBROUTINE DGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER ITRANS, LDB, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I, IP, J DOUBLE PRECISION TEMP * .. * .. Executable Statements .. * * Quick return if possible * IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * IF( ITRANS.EQ.0 ) THEN * * Solve A*X = B using the LU factorization of A, * overwriting each right hand side vector with its solution. * IF( NRHS.LE.1 ) THEN J = 1 10 CONTINUE * * Solve L*x = b. * DO 20 I = 1, N - 1 IP = IPIV( I ) TEMP = B( I+1-IP+I, J ) - DL( I )*B( IP, J ) B( I, J ) = B( IP, J ) B( I+1, J ) = TEMP 20 CONTINUE * * Solve U*x = b. * 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 30 I = N - 2, 1, -1 B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )* $ B( I+2, J ) ) / D( I ) 30 CONTINUE IF( J.LT.NRHS ) THEN J = J + 1 GO TO 10 END IF ELSE DO 60 J = 1, NRHS * * Solve L*x = b. * DO 40 I = 1, N - 1 IF( IPIV( I ).EQ.I ) THEN B( I+1, J ) = B( I+1, J ) - DL( I )*B( I, J ) ELSE TEMP = B( I, J ) B( I, J ) = B( I+1, J ) B( I+1, J ) = TEMP - DL( I )*B( I, J ) END IF 40 CONTINUE * * Solve U*x = b. * 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 50 I = N - 2, 1, -1 B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )* $ B( I+2, J ) ) / D( I ) 50 CONTINUE 60 CONTINUE END IF ELSE * * Solve A**T * X = B. * IF( NRHS.LE.1 ) THEN * * Solve U**T*x = b. * J = 1 70 CONTINUE B( 1, J ) = B( 1, J ) / D( 1 ) IF( N.GT.1 ) $ B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 ) DO 80 I = 3, N B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-DU2( I-2 )* $ B( I-2, J ) ) / D( I ) 80 CONTINUE * * Solve L**T*x = b. * DO 90 I = N - 1, 1, -1 IP = IPIV( I ) TEMP = B( I, J ) - DL( I )*B( I+1, J ) B( I, J ) = B( IP, J ) B( IP, J ) = TEMP 90 CONTINUE IF( J.LT.NRHS ) THEN J = J + 1 GO TO 70 END IF * ELSE DO 120 J = 1, NRHS * * Solve U**T*x = b. * B( 1, J ) = B( 1, J ) / D( 1 ) IF( N.GT.1 ) $ B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 ) DO 100 I = 3, N B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )- $ DU2( I-2 )*B( I-2, J ) ) / D( I ) 100 CONTINUE DO 110 I = N - 1, 1, -1 IF( IPIV( I ).EQ.I ) THEN B( I, J ) = B( I, J ) - DL( I )*B( I+1, J ) ELSE TEMP = B( I+1, J ) B( I+1, J ) = B( I, J ) - DL( I )*TEMP B( I, J ) = TEMP END IF 110 CONTINUE 120 CONTINUE END IF END IF * * End of DGTTS2 * END *> \brief \b DHGEQZ * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DHGEQZ + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, * ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, * LWORK, INFO ) * * .. 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, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> = 'E': Compute eigenvalues only; *> = 'S': Compute eigenvalues and the Schur form. *> \endverbatim *> *> \param[in] COMPQ *> \verbatim *> COMPQ is 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. *> \endverbatim *> *> \param[in] COMPZ *> \verbatim *> COMPZ is 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. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices H, T, Q, and Z. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is 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. *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is 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. *> If JOB = 'E', the diagonal blocks of H match those of S, but *> the rest of H is unspecified. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is INTEGER *> The leading dimension of the array H. LDH >= max( 1, N ). *> \endverbatim *> *> \param[in,out] T *> \verbatim *> T is 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. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= max( 1, N ). *> \endverbatim *> *> \param[out] ALPHAR *> \verbatim *> ALPHAR is DOUBLE PRECISION array, dimension (N) *> The real parts of each scalar alpha defining an eigenvalue *> of GNEP. *> \endverbatim *> *> \param[out] ALPHAI *> \verbatim *> ALPHAI is 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). *> \endverbatim *> *> \param[out] BETA *> \verbatim *> BETA is 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. *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is DOUBLE PRECISION array, dimension (LDQ, N) *> On entry, if COMPQ = 'V', the orthogonal matrix Q1 used in *> the reduction of (A,B) to generalized Hessenberg form. *> On exit, if COMPQ = 'I', the orthogonal matrix of left Schur *> vectors of (H,T), and if COMPQ = 'V', the orthogonal matrix *> of left Schur vectors of (A,B). *> Not referenced if COMPQ = 'N'. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= 1. *> If COMPQ='V' or 'I', then LDQ >= N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is 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'. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1. *> If COMPZ='V' or 'I', then LDZ >= N. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO >= 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is 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. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> 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. *> \endverbatim *> * ===================================================================== SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, $ LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. 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, * ) * .. * * ===================================================================== * * .. 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 *> \brief \b DHSEIN * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DHSEIN + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI, * VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL, * IFAILR, INFO ) * * .. 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( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'R': compute right eigenvectors only; *> = 'L': compute left eigenvectors only; *> = 'B': compute both right and left eigenvectors. *> \endverbatim *> *> \param[in] EIGSRC *> \verbatim *> EIGSRC is 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. *> \endverbatim *> *> \param[in] INITV *> \verbatim *> INITV is CHARACTER*1 *> = 'N': no initial vectors are supplied; *> = 'U': user-supplied initial vectors are stored in the arrays *> VL and/or VR. *> \endverbatim *> *> \param[in,out] SELECT *> \verbatim *> SELECT is 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.. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix H. N >= 0. *> \endverbatim *> *> \param[in] H *> \verbatim *> H is DOUBLE PRECISION array, dimension (LDH,N) *> The upper Hessenberg matrix H. *> If a NaN is detected in H, the routine will return with INFO=-6. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is INTEGER *> The leading dimension of the array H. LDH >= max(1,N). *> \endverbatim *> *> \param[in,out] WR *> \verbatim *> WR is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[in] WI *> \verbatim *> WI is 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. *> \endverbatim *> *> \param[in,out] VL *> \verbatim *> VL is 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. *> \endverbatim *> *> \param[in] LDVL *> \verbatim *> LDVL is INTEGER *> The leading dimension of the array VL. *> LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise. *> \endverbatim *> *> \param[in,out] VR *> \verbatim *> VR is 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. *> \endverbatim *> *> \param[in] LDVR *> \verbatim *> LDVR is INTEGER *> The leading dimension of the array VR. *> LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise. *> \endverbatim *> *> \param[in] MM *> \verbatim *> MM is INTEGER *> The number of columns in the arrays VL and/or VR. MM >= M. *> \endverbatim *> *> \param[out] M *> \verbatim *> M is 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. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension ((N+2)*N) *> \endverbatim *> *> \param[out] IFAILL *> \verbatim *> IFAILL is 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. *> \endverbatim *> *> \param[out] IFAILR *> \verbatim *> IFAILR is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, i is the number of eigenvectors which *> failed to converge; see IFAILL and IFAILR for further *> details. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> 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|. *> \endverbatim *> * ===================================================================== SUBROUTINE DHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI, $ VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL, $ IFAILR, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER 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( * ) * .. * * ===================================================================== * * .. 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, DISNAN DOUBLE PRECISION DLAMCH, DLANHS EXTERNAL LSAME, DLAMCH, DLANHS, DISNAN * .. * .. 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( DISNAN( HNORM ) ) THEN INFO = -6 RETURN ELSE 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 *> \brief \b DHSEQR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DHSEQR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, * LDZ, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N * CHARACTER COMPZ, JOB * .. * .. Array Arguments .. * DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> = 'E': compute eigenvalues only; *> = 'S': compute eigenvalues and the Schur form T. *> \endverbatim *> *> \param[in] COMPZ *> \verbatim *> COMPZ is 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. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix H. N .GE. 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is 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 ZGEHRD *> 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. *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is 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. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is INTEGER *> The leading dimension of the array H. LDH .GE. max(1,N). *> \endverbatim *> *> \param[out] WR *> \verbatim *> WR is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] WI *> \verbatim *> WI is 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). *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is 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.) *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. if COMPZ = 'I' or *> COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (LWORK) *> On exit, if INFO = 0, WORK(1) returns an estimate of *> the optimal value for LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK .GE. max(1,N) *> is sufficient and delivers very good and sometimes *> optimal performance. However, LWORK as large as 11*N *> may be required for optimal performance. A workspace *> query is recommended to determine the optimal workspace *> size. *> *> 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is 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. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA * *> \par Further Details: * ===================== *> *> \verbatim *> *> 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=12: The DLAHQR vs DLAQR0 crossover point. *> Default: 75. (Must be at least 11.) *> *> ISPEC=13: Recommended deflation window size. *> This depends on ILO, IHI and NS. NS is the *> number of simultaneous shifts returned *> by ILAENV(ISPEC=15). (See ISPEC=15 below.) *> The default for (IHI-ILO+1).LE.500 is NS. *> The default for (IHI-ILO+1).GT.500 is 3*NS/2. *> *> ISPEC=14: Nibble crossover point. (See IPARMQ for *> details.) Default: 14% of deflation window *> size. *> *> ISPEC=15: Number of simultaneous shifts in a multishift *> 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 this parameter is ignored. See *> ISPEC=12 above and comments in IPARMQ for *> details. *> *> (**) The asterisks (**) indicate an ad-hoc *> function of N increasing from 10 to 64. *> *> ISPEC=16: Select structured matrix multiply. *> If the number of simultaneous shifts (specified *> by ISPEC=15) is less than 14, then the default *> for ISPEC=16 is 0. Otherwise the default for *> ISPEC=16 is 2. *> \endverbatim * *> \par 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. *> \n *> 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. * * ===================================================================== SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, $ LDZ, WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N CHARACTER COMPZ, JOB * .. * .. Array Arguments .. DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), $ Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. * * ==== Matrices of order NTINY or smaller must be processed by * . DLAHQR because of insufficient subdiagonal scratch space. * . (This is a hard limit.) ==== INTEGER NTINY PARAMETER ( NTINY = 11 ) * * ==== 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=12,...) 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 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 *> \brief \b DISNAN tests input for NaN. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DISNAN + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * LOGICAL FUNCTION DISNAN( DIN ) * * .. Scalar Arguments .. * DOUBLE PRECISION, INTENT(IN) :: DIN * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DISNAN returns .TRUE. if its argument is NaN, and .FALSE. *> otherwise. To be replaced by the Fortran 2003 intrinsic in the *> future. *> \endverbatim * * Arguments: * ========== * *> \param[in] DIN *> \verbatim *> DIN is DOUBLE PRECISION *> Input to test for NaN. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup OTHERauxiliary * * ===================================================================== LOGICAL FUNCTION DISNAN( DIN ) * * -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. DOUBLE PRECISION, INTENT(IN) :: DIN * .. * * ===================================================================== * * .. External Functions .. LOGICAL DLAISNAN EXTERNAL DLAISNAN * .. * .. Executable Statements .. DISNAN = DLAISNAN(DIN,DIN) RETURN END *> \brief \b DLABAD * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLABAD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLABAD( SMALL, LARGE ) * * .. Scalar Arguments .. * DOUBLE PRECISION LARGE, SMALL * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLABAD takes as input the values computed by DLAMCH for underflow and *> overflow, and returns the square root of each of these values if the *> log of LARGE is sufficiently large. This subroutine is intended to *> identify machines with a large exponent range, such as the Crays, and *> redefine the underflow and overflow limits to be the square roots of *> the values computed by DLAMCH. This subroutine is needed because *> DLAMCH does not compensate for poor arithmetic in the upper half of *> the exponent range, as is found on a Cray. *> \endverbatim * * Arguments: * ========== * *> \param[in,out] SMALL *> \verbatim *> SMALL is DOUBLE PRECISION *> On entry, the underflow threshold as computed by DLAMCH. *> On exit, if LOG10(LARGE) is sufficiently large, the square *> root of SMALL, otherwise unchanged. *> \endverbatim *> *> \param[in,out] LARGE *> \verbatim *> LARGE is DOUBLE PRECISION *> On entry, the overflow threshold as computed by DLAMCH. *> On exit, if LOG10(LARGE) is sufficiently large, the square *> root of LARGE, otherwise unchanged. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLABAD( SMALL, LARGE ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION LARGE, SMALL * .. * * ===================================================================== * * .. Intrinsic Functions .. INTRINSIC LOG10, SQRT * .. * .. Executable Statements .. * * If it looks like we're on a Cray, take the square root of * SMALL and LARGE to avoid overflow and underflow problems. * IF( LOG10( LARGE ).GT.2000.D0 ) THEN SMALL = SQRT( SMALL ) LARGE = SQRT( LARGE ) END IF * RETURN * * End of DLABAD * END *> \brief \b DLABRD reduces the first nb rows and columns of a general matrix to a bidiagonal form. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLABRD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, * LDY ) * * .. Scalar Arguments .. * INTEGER LDA, LDX, LDY, M, N, NB * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), * $ TAUQ( * ), X( LDX, * ), Y( LDY, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLABRD reduces the first NB rows and columns of a real general *> m by n matrix A to upper or lower bidiagonal form by an orthogonal *> transformation Q**T * A * P, and returns the matrices X and Y which *> are needed to apply the transformation to the unreduced part of A. *> *> If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower *> bidiagonal form. *> *> This is an auxiliary routine called by DGEBRD *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows in the matrix A. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns in the matrix A. *> \endverbatim *> *> \param[in] NB *> \verbatim *> NB is INTEGER *> The number of leading rows and columns of A to be reduced. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the m by n general matrix to be reduced. *> On exit, the first NB rows and columns of the matrix are *> overwritten; the rest of the array is unchanged. *> If m >= n, elements on and below the diagonal in the first NB *> columns, with the array TAUQ, represent the orthogonal *> matrix Q as a product of elementary reflectors; and *> elements above the diagonal in the first NB rows, with the *> array TAUP, represent the orthogonal matrix P as a product *> of elementary reflectors. *> If m < n, elements below the diagonal in the first NB *> columns, with the array TAUQ, represent the orthogonal *> matrix Q as a product of elementary reflectors, and *> elements on and above the diagonal in the first NB rows, *> with the array TAUP, represent the orthogonal matrix P as *> a product of elementary reflectors. *> See Further Details. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (NB) *> The diagonal elements of the first NB rows and columns of *> the reduced matrix. D(i) = A(i,i). *> \endverbatim *> *> \param[out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (NB) *> The off-diagonal elements of the first NB rows and columns of *> the reduced matrix. *> \endverbatim *> *> \param[out] TAUQ *> \verbatim *> TAUQ is DOUBLE PRECISION array, dimension (NB) *> The scalar factors of the elementary reflectors which *> represent the orthogonal matrix Q. See Further Details. *> \endverbatim *> *> \param[out] TAUP *> \verbatim *> TAUP is DOUBLE PRECISION array, dimension (NB) *> The scalar factors of the elementary reflectors which *> represent the orthogonal matrix P. See Further Details. *> \endverbatim *> *> \param[out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,NB) *> The m-by-nb matrix X required to update the unreduced part *> of A. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the array X. LDX >= max(1,M). *> \endverbatim *> *> \param[out] Y *> \verbatim *> Y is DOUBLE PRECISION array, dimension (LDY,NB) *> The n-by-nb matrix Y required to update the unreduced part *> of A. *> \endverbatim *> *> \param[in] LDY *> \verbatim *> LDY is INTEGER *> The leading dimension of the array Y. LDY >= max(1,N). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup doubleOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrices Q and P are represented as products of elementary *> reflectors: *> *> Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb) *> *> Each H(i) and G(i) has the form: *> *> H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T *> *> where tauq and taup are real scalars, and v and u are real vectors. *> *> If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in *> A(i:m,i); u(1:i) = 0, u(i+1) = 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). *> *> If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in *> A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in *> A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). *> *> The elements of the vectors v and u together form the m-by-nb matrix *> V and the nb-by-n matrix U**T which are needed, with X and Y, to apply *> the transformation to the unreduced part of the matrix, using a block *> update of the form: A := A - V*Y**T - X*U**T. *> *> The contents of A on exit are illustrated by the following examples *> with nb = 2: *> *> m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): *> *> ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 ) *> ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 ) *> ( v1 v2 a a a ) ( v1 1 a a a a ) *> ( v1 v2 a a a ) ( v1 v2 a a a a ) *> ( v1 v2 a a a ) ( v1 v2 a a a a ) *> ( v1 v2 a a a ) *> *> where a denotes an element of the original matrix which is unchanged, *> vi denotes an element of the vector defining H(i), and ui an element *> of the vector defining G(i). *> \endverbatim *> * ===================================================================== SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, $ LDY ) * * -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. INTEGER LDA, LDX, LDY, M, N, NB * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), $ TAUQ( * ), X( LDX, * ), Y( LDY, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. INTEGER I * .. * .. External Subroutines .. EXTERNAL DGEMV, DLARFG, DSCAL * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 ) $ RETURN * IF( M.GE.N ) THEN * * Reduce to upper bidiagonal form * DO 10 I = 1, NB * * Update A(i:m,i) * CALL DGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ), $ LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 ) CALL DGEMV( 'No transpose', M-I+1, I-1, -ONE, X( I, 1 ), $ LDX, A( 1, I ), 1, ONE, A( I, I ), 1 ) * * Generate reflection Q(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 ) IF( I.LT.N ) THEN A( I, I ) = ONE * * Compute Y(i+1:n,i) * CALL DGEMV( 'Transpose', M-I+1, N-I, ONE, A( I, I+1 ), $ LDA, A( I, I ), 1, ZERO, Y( I+1, I ), 1 ) CALL DGEMV( 'Transpose', M-I+1, I-1, ONE, A( I, 1 ), LDA, $ A( I, I ), 1, ZERO, Y( 1, I ), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) CALL DGEMV( 'Transpose', M-I+1, I-1, ONE, X( I, 1 ), LDX, $ A( I, I ), 1, ZERO, Y( 1, I ), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ), $ LDA, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) CALL DSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 ) * * Update A(i,i+1:n) * CALL DGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ), $ LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA ) CALL DGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ), $ LDA, X( I, 1 ), LDX, ONE, A( I, I+1 ), LDA ) * * Generate reflection P(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 * * Compute X(i+1:m,i) * CALL DGEMV( 'No transpose', M-I, N-I, ONE, A( I+1, I+1 ), $ LDA, A( I, I+1 ), LDA, ZERO, X( I+1, I ), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, Y( I+1, 1 ), LDY, $ A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 ) CALL DGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ), $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) CALL DGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), $ LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 ) CALL DGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) CALL DSCAL( M-I, TAUP( I ), X( I+1, I ), 1 ) END IF 10 CONTINUE ELSE * * Reduce to lower bidiagonal form * DO 20 I = 1, NB * * Update A(i,i:n) * CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ), $ LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA ) CALL DGEMV( 'Transpose', I-1, N-I+1, -ONE, A( 1, I ), LDA, $ X( I, 1 ), LDX, ONE, A( I, I ), LDA ) * * Generate reflection P(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 ) IF( I.LT.M ) THEN A( I, I ) = ONE * * Compute X(i+1:m,i) * CALL DGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ), $ LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Y( I, 1 ), LDY, $ A( I, I ), LDA, ZERO, X( 1, I ), 1 ) CALL DGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) CALL DGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ), $ LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 ) CALL DGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) CALL DSCAL( M-I, TAUP( I ), X( I+1, I ), 1 ) * * Update A(i+1:m,i) * CALL DGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), $ LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 ) CALL DGEMV( 'No transpose', M-I, I, -ONE, X( I+1, 1 ), $ LDX, A( 1, I ), 1, ONE, A( I+1, I ), 1 ) * * Generate reflection Q(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 * * Compute Y(i+1:n,i) * CALL DGEMV( 'Transpose', M-I, N-I, ONE, A( I+1, I+1 ), $ LDA, A( I+1, I ), 1, ZERO, Y( I+1, I ), 1 ) CALL DGEMV( 'Transpose', M-I, I-1, ONE, A( I+1, 1 ), LDA, $ A( I+1, I ), 1, ZERO, Y( 1, I ), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) CALL DGEMV( 'Transpose', M-I, I, ONE, X( I+1, 1 ), LDX, $ A( I+1, I ), 1, ZERO, Y( 1, I ), 1 ) CALL DGEMV( 'Transpose', I, N-I, -ONE, A( 1, I+1 ), LDA, $ Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) CALL DSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 ) END IF 20 CONTINUE END IF RETURN * * End of DLABRD * END *> \brief \b DLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vector products. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLACN2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE ) * * .. Scalar Arguments .. * INTEGER KASE, N * DOUBLE PRECISION EST * .. * .. Array Arguments .. * INTEGER ISGN( * ), ISAVE( 3 ) * DOUBLE PRECISION V( * ), X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLACN2 estimates the 1-norm of a square, real matrix A. *> Reverse communication is used for evaluating matrix-vector products. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix. N >= 1. *> \endverbatim *> *> \param[out] V *> \verbatim *> V is DOUBLE PRECISION array, dimension (N) *> On the final return, V = A*W, where EST = norm(V)/norm(W) *> (W is not returned). *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (N) *> On an intermediate return, X should be overwritten by *> A * X, if KASE=1, *> A**T * X, if KASE=2, *> and DLACN2 must be re-called with all the other parameters *> unchanged. *> \endverbatim *> *> \param[out] ISGN *> \verbatim *> ISGN is INTEGER array, dimension (N) *> \endverbatim *> *> \param[in,out] EST *> \verbatim *> EST is DOUBLE PRECISION *> On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be *> unchanged from the previous call to DLACN2. *> On exit, EST is an estimate (a lower bound) for norm(A). *> \endverbatim *> *> \param[in,out] KASE *> \verbatim *> KASE is INTEGER *> On the initial call to DLACN2, KASE should be 0. *> On an intermediate return, KASE will be 1 or 2, indicating *> whether X should be overwritten by A * X or A**T * X. *> On the final return from DLACN2, KASE will again be 0. *> \endverbatim *> *> \param[in,out] ISAVE *> \verbatim *> ISAVE is INTEGER array, dimension (3) *> ISAVE is used to save variables between calls to DLACN2 *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> Originally named SONEST, dated March 16, 1988. *> *> This is a thread safe version of DLACON, which uses the array ISAVE *> in place of a SAVE statement, as follows: *> *> DLACON DLACN2 *> JUMP ISAVE(1) *> J ISAVE(2) *> ITER ISAVE(3) *> \endverbatim * *> \par Contributors: * ================== *> *> Nick Higham, University of Manchester * *> \par References: * ================ *> *> N.J. Higham, "FORTRAN codes for estimating the one-norm of *> a real or complex matrix, with applications to condition estimation", *> ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. *> * ===================================================================== SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER KASE, N DOUBLE PRECISION EST * .. * .. Array Arguments .. INTEGER ISGN( * ), ISAVE( 3 ) DOUBLE PRECISION V( * ), X( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER ITMAX PARAMETER ( ITMAX = 5 ) DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) * .. * .. Local Scalars .. INTEGER I, JLAST DOUBLE PRECISION ALTSGN, ESTOLD, TEMP * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DASUM EXTERNAL IDAMAX, DASUM * .. * .. External Subroutines .. EXTERNAL DCOPY * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, NINT, SIGN * .. * .. Executable Statements .. * IF( KASE.EQ.0 ) THEN DO 10 I = 1, N X( I ) = ONE / DBLE( N ) 10 CONTINUE KASE = 1 ISAVE( 1 ) = 1 RETURN END IF * GO TO ( 20, 40, 70, 110, 140 )ISAVE( 1 ) * * ................ ENTRY (ISAVE( 1 ) = 1) * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. * 20 CONTINUE IF( N.EQ.1 ) THEN V( 1 ) = X( 1 ) EST = ABS( V( 1 ) ) * ... QUIT GO TO 150 END IF EST = DASUM( N, X, 1 ) * DO 30 I = 1, N X( I ) = SIGN( ONE, X( I ) ) ISGN( I ) = NINT( X( I ) ) 30 CONTINUE KASE = 2 ISAVE( 1 ) = 2 RETURN * * ................ ENTRY (ISAVE( 1 ) = 2) * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. * 40 CONTINUE ISAVE( 2 ) = IDAMAX( N, X, 1 ) ISAVE( 3 ) = 2 * * MAIN LOOP - ITERATIONS 2,3,...,ITMAX. * 50 CONTINUE DO 60 I = 1, N X( I ) = ZERO 60 CONTINUE X( ISAVE( 2 ) ) = ONE KASE = 1 ISAVE( 1 ) = 3 RETURN * * ................ ENTRY (ISAVE( 1 ) = 3) * X HAS BEEN OVERWRITTEN BY A*X. * 70 CONTINUE CALL DCOPY( N, X, 1, V, 1 ) ESTOLD = EST EST = DASUM( N, V, 1 ) DO 80 I = 1, N IF( NINT( SIGN( ONE, X( I ) ) ).NE.ISGN( I ) ) $ GO TO 90 80 CONTINUE * REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. GO TO 120 * 90 CONTINUE * TEST FOR CYCLING. IF( EST.LE.ESTOLD ) $ GO TO 120 * DO 100 I = 1, N X( I ) = SIGN( ONE, X( I ) ) ISGN( I ) = NINT( X( I ) ) 100 CONTINUE KASE = 2 ISAVE( 1 ) = 4 RETURN * * ................ ENTRY (ISAVE( 1 ) = 4) * X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. * 110 CONTINUE JLAST = ISAVE( 2 ) ISAVE( 2 ) = IDAMAX( N, X, 1 ) IF( ( X( JLAST ).NE.ABS( X( ISAVE( 2 ) ) ) ) .AND. $ ( ISAVE( 3 ).LT.ITMAX ) ) THEN ISAVE( 3 ) = ISAVE( 3 ) + 1 GO TO 50 END IF * * ITERATION COMPLETE. FINAL STAGE. * 120 CONTINUE ALTSGN = ONE DO 130 I = 1, N X( I ) = ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) ) ALTSGN = -ALTSGN 130 CONTINUE KASE = 1 ISAVE( 1 ) = 5 RETURN * * ................ ENTRY (ISAVE( 1 ) = 5) * X HAS BEEN OVERWRITTEN BY A*X. * 140 CONTINUE TEMP = TWO*( DASUM( N, X, 1 ) / DBLE( 3*N ) ) IF( TEMP.GT.EST ) THEN CALL DCOPY( N, X, 1, V, 1 ) EST = TEMP END IF * 150 CONTINUE KASE = 0 RETURN * * End of DLACN2 * END *> \brief \b DLACON estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vector products. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLACON + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE ) * * .. Scalar Arguments .. * INTEGER KASE, N * DOUBLE PRECISION EST * .. * .. Array Arguments .. * INTEGER ISGN( * ) * DOUBLE PRECISION V( * ), X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLACON estimates the 1-norm of a square, real matrix A. *> Reverse communication is used for evaluating matrix-vector products. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix. N >= 1. *> \endverbatim *> *> \param[out] V *> \verbatim *> V is DOUBLE PRECISION array, dimension (N) *> On the final return, V = A*W, where EST = norm(V)/norm(W) *> (W is not returned). *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (N) *> On an intermediate return, X should be overwritten by *> A * X, if KASE=1, *> A**T * X, if KASE=2, *> and DLACON must be re-called with all the other parameters *> unchanged. *> \endverbatim *> *> \param[out] ISGN *> \verbatim *> ISGN is INTEGER array, dimension (N) *> \endverbatim *> *> \param[in,out] EST *> \verbatim *> EST is DOUBLE PRECISION *> On entry with KASE = 1 or 2 and JUMP = 3, EST should be *> unchanged from the previous call to DLACON. *> On exit, EST is an estimate (a lower bound) for norm(A). *> \endverbatim *> *> \param[in,out] KASE *> \verbatim *> KASE is INTEGER *> On the initial call to DLACON, KASE should be 0. *> On an intermediate return, KASE will be 1 or 2, indicating *> whether X should be overwritten by A * X or A**T * X. *> On the final return from DLACON, KASE will again be 0. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Contributors: * ================== *> *> Nick Higham, University of Manchester. \n *> Originally named SONEST, dated March 16, 1988. * *> \par References: * ================ *> *> N.J. Higham, "FORTRAN codes for estimating the one-norm of *> a real or complex matrix, with applications to condition estimation", *> ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. *> * ===================================================================== SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER KASE, N DOUBLE PRECISION EST * .. * .. Array Arguments .. INTEGER ISGN( * ) DOUBLE PRECISION V( * ), X( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER ITMAX PARAMETER ( ITMAX = 5 ) DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) * .. * .. Local Scalars .. INTEGER I, ITER, J, JLAST, JUMP DOUBLE PRECISION ALTSGN, ESTOLD, TEMP * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DASUM EXTERNAL IDAMAX, DASUM * .. * .. External Subroutines .. EXTERNAL DCOPY * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, NINT, SIGN * .. * .. Save statement .. SAVE * .. * .. Executable Statements .. * IF( KASE.EQ.0 ) THEN DO 10 I = 1, N X( I ) = ONE / DBLE( N ) 10 CONTINUE KASE = 1 JUMP = 1 RETURN END IF * GO TO ( 20, 40, 70, 110, 140 )JUMP * * ................ ENTRY (JUMP = 1) * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. * 20 CONTINUE IF( N.EQ.1 ) THEN V( 1 ) = X( 1 ) EST = ABS( V( 1 ) ) * ... QUIT GO TO 150 END IF EST = DASUM( N, X, 1 ) * DO 30 I = 1, N X( I ) = SIGN( ONE, X( I ) ) ISGN( I ) = NINT( X( I ) ) 30 CONTINUE KASE = 2 JUMP = 2 RETURN * * ................ ENTRY (JUMP = 2) * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. * 40 CONTINUE J = IDAMAX( N, X, 1 ) ITER = 2 * * MAIN LOOP - ITERATIONS 2,3,...,ITMAX. * 50 CONTINUE DO 60 I = 1, N X( I ) = ZERO 60 CONTINUE X( J ) = ONE KASE = 1 JUMP = 3 RETURN * * ................ ENTRY (JUMP = 3) * X HAS BEEN OVERWRITTEN BY A*X. * 70 CONTINUE CALL DCOPY( N, X, 1, V, 1 ) ESTOLD = EST EST = DASUM( N, V, 1 ) DO 80 I = 1, N IF( NINT( SIGN( ONE, X( I ) ) ).NE.ISGN( I ) ) $ GO TO 90 80 CONTINUE * REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. GO TO 120 * 90 CONTINUE * TEST FOR CYCLING. IF( EST.LE.ESTOLD ) $ GO TO 120 * DO 100 I = 1, N X( I ) = SIGN( ONE, X( I ) ) ISGN( I ) = NINT( X( I ) ) 100 CONTINUE KASE = 2 JUMP = 4 RETURN * * ................ ENTRY (JUMP = 4) * X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. * 110 CONTINUE JLAST = J J = IDAMAX( N, X, 1 ) IF( ( X( JLAST ).NE.ABS( X( J ) ) ) .AND. ( ITER.LT.ITMAX ) ) THEN ITER = ITER + 1 GO TO 50 END IF * * ITERATION COMPLETE. FINAL STAGE. * 120 CONTINUE ALTSGN = ONE DO 130 I = 1, N X( I ) = ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) ) ALTSGN = -ALTSGN 130 CONTINUE KASE = 1 JUMP = 5 RETURN * * ................ ENTRY (JUMP = 5) * X HAS BEEN OVERWRITTEN BY A*X. * 140 CONTINUE TEMP = TWO*( DASUM( N, X, 1 ) / DBLE( 3*N ) ) IF( TEMP.GT.EST ) THEN CALL DCOPY( N, X, 1, V, 1 ) EST = TEMP END IF * 150 CONTINUE KASE = 0 RETURN * * End of DLACON * END *> \brief \b DLACPY copies all or part of one two-dimensional array to another. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLACPY + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDB, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLACPY copies all or part of a two-dimensional matrix A to another *> matrix B. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies the part of the matrix A to be copied to B. *> = 'U': Upper triangular part *> = 'L': Lower triangular part *> Otherwise: All of the matrix A *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The m by n matrix A. If UPLO = 'U', only the upper triangle *> or trapezoid is accessed; if UPLO = 'L', only the lower *> triangle or trapezoid is accessed. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,N) *> On exit, B = A in the locations specified by UPLO. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,M). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER LDA, LDB, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * IF( LSAME( UPLO, 'U' ) ) THEN DO 20 J = 1, N DO 10 I = 1, MIN( J, M ) B( I, J ) = A( I, J ) 10 CONTINUE 20 CONTINUE ELSE IF( LSAME( UPLO, 'L' ) ) THEN DO 40 J = 1, N DO 30 I = J, M B( I, J ) = A( I, J ) 30 CONTINUE 40 CONTINUE ELSE DO 60 J = 1, N DO 50 I = 1, M B( I, J ) = A( I, J ) 50 CONTINUE 60 CONTINUE END IF RETURN * * End of DLACPY * END *> \brief \b DLADIV performs complex division in real arithmetic, avoiding unnecessary overflow. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLADIV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLADIV( A, B, C, D, P, Q ) * * .. Scalar Arguments .. * DOUBLE PRECISION A, B, C, D, P, Q * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLADIV performs complex division in real arithmetic *> *> a + i*b *> p + i*q = --------- *> c + i*d *> *> The algorithm is due to Michael Baudin and Robert L. Smith *> and can be found in the paper *> "A Robust Complex Division in Scilab" *> \endverbatim * * Arguments: * ========== * *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION *> \endverbatim *> *> \param[in] C *> \verbatim *> C is DOUBLE PRECISION *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION *> The scalars a, b, c, and d in the above expression. *> \endverbatim *> *> \param[out] P *> \verbatim *> P is DOUBLE PRECISION *> \endverbatim *> *> \param[out] Q *> \verbatim *> Q is DOUBLE PRECISION *> The scalars p and q in the above expression. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date January 2013 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLADIV( A, B, C, D, P, Q ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * January 2013 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, D, P, Q * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION BS PARAMETER ( BS = 2.0D0 ) DOUBLE PRECISION HALF PARAMETER ( HALF = 0.5D0 ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D0 ) * * .. Local Scalars .. DOUBLE PRECISION AA, BB, CC, DD, AB, CD, S, OV, UN, BE, EPS * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. External Subroutines .. EXTERNAL DLADIV1 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Executable Statements .. * AA = A BB = B CC = C DD = D AB = MAX( ABS(A), ABS(B) ) CD = MAX( ABS(C), ABS(D) ) S = 1.0D0 OV = DLAMCH( 'Overflow threshold' ) UN = DLAMCH( 'Safe minimum' ) EPS = DLAMCH( 'Epsilon' ) BE = BS / (EPS*EPS) IF( AB >= HALF*OV ) THEN AA = HALF * AA BB = HALF * BB S = TWO * S END IF IF( CD >= HALF*OV ) THEN CC = HALF * CC DD = HALF * DD S = HALF * S END IF IF( AB <= UN*BS/EPS ) THEN AA = AA * BE BB = BB * BE S = S / BE END IF IF( CD <= UN*BS/EPS ) THEN CC = CC * BE DD = DD * BE S = S * BE END IF IF( ABS( D ).LE.ABS( C ) ) THEN CALL DLADIV1(AA, BB, CC, DD, P, Q) ELSE CALL DLADIV1(BB, AA, DD, CC, P, Q) Q = -Q END IF P = P * S Q = Q * S * RETURN * * End of DLADIV * END *> \ingroup doubleOTHERauxiliary SUBROUTINE DLADIV1( A, B, C, D, P, Q ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * January 2013 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, D, P, Q * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) * * .. Local Scalars .. DOUBLE PRECISION R, T * .. * .. External Functions .. DOUBLE PRECISION DLADIV2 EXTERNAL DLADIV2 * .. * .. Executable Statements .. * R = D / C T = ONE / (C + D * R) P = DLADIV2(A, B, C, D, R, T) A = -A Q = DLADIV2(B, A, C, D, R, T) * RETURN * * End of DLADIV1 * END *> \ingroup doubleOTHERauxiliary DOUBLE PRECISION FUNCTION DLADIV2( A, B, C, D, R, T ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * January 2013 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, D, R, T * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) * * .. Local Scalars .. DOUBLE PRECISION BR * .. * .. Executable Statements .. * IF( R.NE.ZERO ) THEN BR = B * R IF( BR.NE.ZERO ) THEN DLADIV2 = (A + BR) * T ELSE DLADIV2 = A * T + (B * T) * R END IF ELSE DLADIV2 = (A + D * (B / C)) * T END IF * RETURN * * End of DLADIV12 * END *> \brief \b DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAE2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) * * .. Scalar Arguments .. * DOUBLE PRECISION A, B, C, RT1, RT2 * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix *> [ A B ] *> [ B C ]. *> On return, RT1 is the eigenvalue of larger absolute value, and RT2 *> is the eigenvalue of smaller absolute value. *> \endverbatim * * Arguments: * ========== * *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION *> The (1,1) element of the 2-by-2 matrix. *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION *> The (1,2) and (2,1) elements of the 2-by-2 matrix. *> \endverbatim *> *> \param[in] C *> \verbatim *> C is DOUBLE PRECISION *> The (2,2) element of the 2-by-2 matrix. *> \endverbatim *> *> \param[out] RT1 *> \verbatim *> RT1 is DOUBLE PRECISION *> The eigenvalue of larger absolute value. *> \endverbatim *> *> \param[out] RT2 *> \verbatim *> RT2 is DOUBLE PRECISION *> The eigenvalue of smaller absolute value. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> RT1 is accurate to a few ulps barring over/underflow. *> *> RT2 may be inaccurate if there is massive cancellation in the *> determinant A*C-B*B; higher precision or correctly rounded or *> correctly truncated arithmetic would be needed to compute RT2 *> accurately in all cases. *> *> Overflow is possible only if RT1 is within a factor of 5 of overflow. *> Underflow is harmless if the input data is 0 or exceeds *> underflow_threshold / macheps. *> \endverbatim *> * ===================================================================== SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, RT1, RT2 * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D0 ) DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION HALF PARAMETER ( HALF = 0.5D0 ) * .. * .. Local Scalars .. DOUBLE PRECISION AB, ACMN, ACMX, ADF, DF, RT, SM, TB * .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT * .. * .. Executable Statements .. * * Compute the eigenvalues * SM = A + C DF = A - C ADF = ABS( DF ) TB = B + B AB = ABS( TB ) IF( ABS( A ).GT.ABS( C ) ) THEN ACMX = A ACMN = C ELSE ACMX = C ACMN = A END IF IF( ADF.GT.AB ) THEN RT = ADF*SQRT( ONE+( AB / ADF )**2 ) ELSE IF( ADF.LT.AB ) THEN RT = AB*SQRT( ONE+( ADF / AB )**2 ) ELSE * * Includes case AB=ADF=0 * RT = AB*SQRT( TWO ) END IF IF( SM.LT.ZERO ) THEN RT1 = HALF*( SM-RT ) * * Order of execution important. * To get fully accurate smaller eigenvalue, * next line needs to be executed in higher precision. * RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B ELSE IF( SM.GT.ZERO ) THEN RT1 = HALF*( SM+RT ) * * Order of execution important. * To get fully accurate smaller eigenvalue, * next line needs to be executed in higher precision. * RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B ELSE * * Includes case RT1 = RT2 = 0 * RT1 = HALF*RT RT2 = -HALF*RT END IF RETURN * * End of DLAE2 * END *> \brief \b DLAEBZ computes the number of eigenvalues of a real symmetric tridiagonal matrix which are less than or equal to a given value, and performs other tasks required by the routine sstebz. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAEBZ + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL, * RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT, * NAB, WORK, IWORK, INFO ) * * .. Scalar Arguments .. * INTEGER IJOB, INFO, MINP, MMAX, MOUT, N, NBMIN, NITMAX * DOUBLE PRECISION ABSTOL, PIVMIN, RELTOL * .. * .. Array Arguments .. * INTEGER IWORK( * ), NAB( MMAX, * ), NVAL( * ) * DOUBLE PRECISION AB( MMAX, * ), C( * ), D( * ), E( * ), E2( * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAEBZ contains the iteration loops which compute and use the *> function N(w), which is the count of eigenvalues of a symmetric *> tridiagonal matrix T less than or equal to its argument w. It *> performs a choice of two types of loops: *> *> IJOB=1, followed by *> IJOB=2: It takes as input a list of intervals and returns a list of *> sufficiently small intervals whose union contains the same *> eigenvalues as the union of the original intervals. *> The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP. *> The output interval (AB(j,1),AB(j,2)] will contain *> eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT. *> *> IJOB=3: It performs a binary search in each input interval *> (AB(j,1),AB(j,2)] for a point w(j) such that *> N(w(j))=NVAL(j), and uses C(j) as the starting point of *> the search. If such a w(j) is found, then on output *> AB(j,1)=AB(j,2)=w. If no such w(j) is found, then on output *> (AB(j,1),AB(j,2)] will be a small interval containing the *> point where N(w) jumps through NVAL(j), unless that point *> lies outside the initial interval. *> *> Note that the intervals are in all cases half-open intervals, *> i.e., of the form (a,b] , which includes b but not a . *> *> To avoid underflow, the matrix should be scaled so that its largest *> element is no greater than overflow**(1/2) * underflow**(1/4) *> in absolute value. To assure the most accurate computation *> of small eigenvalues, the matrix should be scaled to be *> not much smaller than that, either. *> *> See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal *> Matrix", Report CS41, Computer Science Dept., Stanford *> University, July 21, 1966 *> *> Note: the arguments are, in general, *not* checked for unreasonable *> values. *> \endverbatim * * Arguments: * ========== * *> \param[in] IJOB *> \verbatim *> IJOB is INTEGER *> Specifies what is to be done: *> = 1: Compute NAB for the initial intervals. *> = 2: Perform bisection iteration to find eigenvalues of T. *> = 3: Perform bisection iteration to invert N(w), i.e., *> to find a point which has a specified number of *> eigenvalues of T to its left. *> Other values will cause DLAEBZ to return with INFO=-1. *> \endverbatim *> *> \param[in] NITMAX *> \verbatim *> NITMAX is INTEGER *> The maximum number of "levels" of bisection to be *> performed, i.e., an interval of width W will not be made *> smaller than 2^(-NITMAX) * W. If not all intervals *> have converged after NITMAX iterations, then INFO is set *> to the number of non-converged intervals. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The dimension n of the tridiagonal matrix T. It must be at *> least 1. *> \endverbatim *> *> \param[in] MMAX *> \verbatim *> MMAX is INTEGER *> The maximum number of intervals. If more than MMAX intervals *> are generated, then DLAEBZ will quit with INFO=MMAX+1. *> \endverbatim *> *> \param[in] MINP *> \verbatim *> MINP is INTEGER *> The initial number of intervals. It may not be greater than *> MMAX. *> \endverbatim *> *> \param[in] NBMIN *> \verbatim *> NBMIN is INTEGER *> The smallest number of intervals that should be processed *> using a vector loop. If zero, then only the scalar loop *> will be used. *> \endverbatim *> *> \param[in] ABSTOL *> \verbatim *> ABSTOL is DOUBLE PRECISION *> The minimum (absolute) width of an interval. When an *> interval is narrower than ABSTOL, or than RELTOL times the *> larger (in magnitude) endpoint, then it is considered to be *> sufficiently small, i.e., converged. This must be at least *> zero. *> \endverbatim *> *> \param[in] RELTOL *> \verbatim *> RELTOL is DOUBLE PRECISION *> The minimum relative width of an interval. When an interval *> is narrower than ABSTOL, or than RELTOL times the larger (in *> magnitude) endpoint, then it is considered to be *> sufficiently small, i.e., converged. Note: this should *> always be at least radix*machine epsilon. *> \endverbatim *> *> \param[in] PIVMIN *> \verbatim *> PIVMIN is DOUBLE PRECISION *> The minimum absolute value of a "pivot" in the Sturm *> sequence loop. *> This must be at least max |e(j)**2|*safe_min and at *> least safe_min, where safe_min is at least *> the smallest number that can divide one without overflow. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The diagonal elements of the tridiagonal matrix T. *> \endverbatim *> *> \param[in] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N) *> The offdiagonal elements of the tridiagonal matrix T in *> positions 1 through N-1. E(N) is arbitrary. *> \endverbatim *> *> \param[in] E2 *> \verbatim *> E2 is DOUBLE PRECISION array, dimension (N) *> The squares of the offdiagonal elements of the tridiagonal *> matrix T. E2(N) is ignored. *> \endverbatim *> *> \param[in,out] NVAL *> \verbatim *> NVAL is INTEGER array, dimension (MINP) *> If IJOB=1 or 2, not referenced. *> If IJOB=3, the desired values of N(w). The elements of NVAL *> will be reordered to correspond with the intervals in AB. *> Thus, NVAL(j) on output will not, in general be the same as *> NVAL(j) on input, but it will correspond with the interval *> (AB(j,1),AB(j,2)] on output. *> \endverbatim *> *> \param[in,out] AB *> \verbatim *> AB is DOUBLE PRECISION array, dimension (MMAX,2) *> The endpoints of the intervals. AB(j,1) is a(j), the left *> endpoint of the j-th interval, and AB(j,2) is b(j), the *> right endpoint of the j-th interval. The input intervals *> will, in general, be modified, split, and reordered by the *> calculation. *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (MMAX) *> If IJOB=1, ignored. *> If IJOB=2, workspace. *> If IJOB=3, then on input C(j) should be initialized to the *> first search point in the binary search. *> \endverbatim *> *> \param[out] MOUT *> \verbatim *> MOUT is INTEGER *> If IJOB=1, the number of eigenvalues in the intervals. *> If IJOB=2 or 3, the number of intervals output. *> If IJOB=3, MOUT will equal MINP. *> \endverbatim *> *> \param[in,out] NAB *> \verbatim *> NAB is INTEGER array, dimension (MMAX,2) *> If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)). *> If IJOB=2, then on input, NAB(i,j) should be set. It must *> satisfy the condition: *> N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)), *> which means that in interval i only eigenvalues *> NAB(i,1)+1,...,NAB(i,2) will be considered. Usually, *> NAB(i,j)=N(AB(i,j)), from a previous call to DLAEBZ with *> IJOB=1. *> On output, NAB(i,j) will contain *> max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of *> the input interval that the output interval *> (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the *> the input values of NAB(k,1) and NAB(k,2). *> If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)), *> unless N(w) > NVAL(i) for all search points w , in which *> case NAB(i,1) will not be modified, i.e., the output *> value will be the same as the input value (modulo *> reorderings -- see NVAL and AB), or unless N(w) < NVAL(i) *> for all search points w , in which case NAB(i,2) will *> not be modified. Normally, NAB should be set to some *> distinctive value(s) before DLAEBZ is called. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MMAX) *> Workspace. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (MMAX) *> Workspace. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: All intervals converged. *> = 1--MMAX: The last INFO intervals did not converge. *> = MMAX+1: More than MMAX intervals were generated. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> This routine is intended to be called only by other LAPACK *> routines, thus the interface is less user-friendly. It is intended *> for two purposes: *> *> (a) finding eigenvalues. In this case, DLAEBZ should have one or *> more initial intervals set up in AB, and DLAEBZ should be called *> with IJOB=1. This sets up NAB, and also counts the eigenvalues. *> Intervals with no eigenvalues would usually be thrown out at *> this point. Also, if not all the eigenvalues in an interval i *> are desired, NAB(i,1) can be increased or NAB(i,2) decreased. *> For example, set NAB(i,1)=NAB(i,2)-1 to get the largest *> eigenvalue. DLAEBZ is then called with IJOB=2 and MMAX *> no smaller than the value of MOUT returned by the call with *> IJOB=1. After this (IJOB=2) call, eigenvalues NAB(i,1)+1 *> through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the *> tolerance specified by ABSTOL and RELTOL. *> *> (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l). *> In this case, start with a Gershgorin interval (a,b). Set up *> AB to contain 2 search intervals, both initially (a,b). One *> NVAL element should contain f-1 and the other should contain l *> , while C should contain a and b, resp. NAB(i,1) should be -1 *> and NAB(i,2) should be N+1, to flag an error if the desired *> interval does not lie in (a,b). DLAEBZ is then called with *> IJOB=3. On exit, if w(f-1) < w(f), then one of the intervals -- *> j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while *> if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r *> >= 0, then the interval will have N(AB(j,1))=NAB(j,1)=f-k and *> N(AB(j,2))=NAB(j,2)=f+r. The cases w(l) < w(l+1) and *> w(l-r)=...=w(l+k) are handled similarly. *> \endverbatim *> * ===================================================================== SUBROUTINE DLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL, $ RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT, $ NAB, WORK, IWORK, INFO ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER IJOB, INFO, MINP, MMAX, MOUT, N, NBMIN, NITMAX DOUBLE PRECISION ABSTOL, PIVMIN, RELTOL * .. * .. Array Arguments .. INTEGER IWORK( * ), NAB( MMAX, * ), NVAL( * ) DOUBLE PRECISION AB( MMAX, * ), C( * ), D( * ), E( * ), E2( * ), $ WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, TWO, HALF PARAMETER ( ZERO = 0.0D0, TWO = 2.0D0, $ HALF = 1.0D0 / TWO ) * .. * .. Local Scalars .. INTEGER ITMP1, ITMP2, J, JI, JIT, JP, KF, KFNEW, KL, $ KLNEW DOUBLE PRECISION TMP1, TMP2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. Executable Statements .. * * Check for Errors * INFO = 0 IF( IJOB.LT.1 .OR. IJOB.GT.3 ) THEN INFO = -1 RETURN END IF * * Initialize NAB * IF( IJOB.EQ.1 ) THEN * * Compute the number of eigenvalues in the initial intervals. * MOUT = 0 DO 30 JI = 1, MINP DO 20 JP = 1, 2 TMP1 = D( 1 ) - AB( JI, JP ) IF( ABS( TMP1 ).LT.PIVMIN ) $ TMP1 = -PIVMIN NAB( JI, JP ) = 0 IF( TMP1.LE.ZERO ) $ NAB( JI, JP ) = 1 * DO 10 J = 2, N TMP1 = D( J ) - E2( J-1 ) / TMP1 - AB( JI, JP ) IF( ABS( TMP1 ).LT.PIVMIN ) $ TMP1 = -PIVMIN IF( TMP1.LE.ZERO ) $ NAB( JI, JP ) = NAB( JI, JP ) + 1 10 CONTINUE 20 CONTINUE MOUT = MOUT + NAB( JI, 2 ) - NAB( JI, 1 ) 30 CONTINUE RETURN END IF * * Initialize for loop * * KF and KL have the following meaning: * Intervals 1,...,KF-1 have converged. * Intervals KF,...,KL still need to be refined. * KF = 1 KL = MINP * * If IJOB=2, initialize C. * If IJOB=3, use the user-supplied starting point. * IF( IJOB.EQ.2 ) THEN DO 40 JI = 1, MINP C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) ) 40 CONTINUE END IF * * Iteration loop * DO 130 JIT = 1, NITMAX * * Loop over intervals * IF( KL-KF+1.GE.NBMIN .AND. NBMIN.GT.0 ) THEN * * Begin of Parallel Version of the loop * DO 60 JI = KF, KL * * Compute N(c), the number of eigenvalues less than c * WORK( JI ) = D( 1 ) - C( JI ) IWORK( JI ) = 0 IF( WORK( JI ).LE.PIVMIN ) THEN IWORK( JI ) = 1 WORK( JI ) = MIN( WORK( JI ), -PIVMIN ) END IF * DO 50 J = 2, N WORK( JI ) = D( J ) - E2( J-1 ) / WORK( JI ) - C( JI ) IF( WORK( JI ).LE.PIVMIN ) THEN IWORK( JI ) = IWORK( JI ) + 1 WORK( JI ) = MIN( WORK( JI ), -PIVMIN ) END IF 50 CONTINUE 60 CONTINUE * IF( IJOB.LE.2 ) THEN * * IJOB=2: Choose all intervals containing eigenvalues. * KLNEW = KL DO 70 JI = KF, KL * * Insure that N(w) is monotone * IWORK( JI ) = MIN( NAB( JI, 2 ), $ MAX( NAB( JI, 1 ), IWORK( JI ) ) ) * * Update the Queue -- add intervals if both halves * contain eigenvalues. * IF( IWORK( JI ).EQ.NAB( JI, 2 ) ) THEN * * No eigenvalue in the upper interval: * just use the lower interval. * AB( JI, 2 ) = C( JI ) * ELSE IF( IWORK( JI ).EQ.NAB( JI, 1 ) ) THEN * * No eigenvalue in the lower interval: * just use the upper interval. * AB( JI, 1 ) = C( JI ) ELSE KLNEW = KLNEW + 1 IF( KLNEW.LE.MMAX ) THEN * * Eigenvalue in both intervals -- add upper to * queue. * AB( KLNEW, 2 ) = AB( JI, 2 ) NAB( KLNEW, 2 ) = NAB( JI, 2 ) AB( KLNEW, 1 ) = C( JI ) NAB( KLNEW, 1 ) = IWORK( JI ) AB( JI, 2 ) = C( JI ) NAB( JI, 2 ) = IWORK( JI ) ELSE INFO = MMAX + 1 END IF END IF 70 CONTINUE IF( INFO.NE.0 ) $ RETURN KL = KLNEW ELSE * * IJOB=3: Binary search. Keep only the interval containing * w s.t. N(w) = NVAL * DO 80 JI = KF, KL IF( IWORK( JI ).LE.NVAL( JI ) ) THEN AB( JI, 1 ) = C( JI ) NAB( JI, 1 ) = IWORK( JI ) END IF IF( IWORK( JI ).GE.NVAL( JI ) ) THEN AB( JI, 2 ) = C( JI ) NAB( JI, 2 ) = IWORK( JI ) END IF 80 CONTINUE END IF * ELSE * * End of Parallel Version of the loop * * Begin of Serial Version of the loop * KLNEW = KL DO 100 JI = KF, KL * * Compute N(w), the number of eigenvalues less than w * TMP1 = C( JI ) TMP2 = D( 1 ) - TMP1 ITMP1 = 0 IF( TMP2.LE.PIVMIN ) THEN ITMP1 = 1 TMP2 = MIN( TMP2, -PIVMIN ) END IF * DO 90 J = 2, N TMP2 = D( J ) - E2( J-1 ) / TMP2 - TMP1 IF( TMP2.LE.PIVMIN ) THEN ITMP1 = ITMP1 + 1 TMP2 = MIN( TMP2, -PIVMIN ) END IF 90 CONTINUE * IF( IJOB.LE.2 ) THEN * * IJOB=2: Choose all intervals containing eigenvalues. * * Insure that N(w) is monotone * ITMP1 = MIN( NAB( JI, 2 ), $ MAX( NAB( JI, 1 ), ITMP1 ) ) * * Update the Queue -- add intervals if both halves * contain eigenvalues. * IF( ITMP1.EQ.NAB( JI, 2 ) ) THEN * * No eigenvalue in the upper interval: * just use the lower interval. * AB( JI, 2 ) = TMP1 * ELSE IF( ITMP1.EQ.NAB( JI, 1 ) ) THEN * * No eigenvalue in the lower interval: * just use the upper interval. * AB( JI, 1 ) = TMP1 ELSE IF( KLNEW.LT.MMAX ) THEN * * Eigenvalue in both intervals -- add upper to queue. * KLNEW = KLNEW + 1 AB( KLNEW, 2 ) = AB( JI, 2 ) NAB( KLNEW, 2 ) = NAB( JI, 2 ) AB( KLNEW, 1 ) = TMP1 NAB( KLNEW, 1 ) = ITMP1 AB( JI, 2 ) = TMP1 NAB( JI, 2 ) = ITMP1 ELSE INFO = MMAX + 1 RETURN END IF ELSE * * IJOB=3: Binary search. Keep only the interval * containing w s.t. N(w) = NVAL * IF( ITMP1.LE.NVAL( JI ) ) THEN AB( JI, 1 ) = TMP1 NAB( JI, 1 ) = ITMP1 END IF IF( ITMP1.GE.NVAL( JI ) ) THEN AB( JI, 2 ) = TMP1 NAB( JI, 2 ) = ITMP1 END IF END IF 100 CONTINUE KL = KLNEW * END IF * * Check for convergence * KFNEW = KF DO 110 JI = KF, KL TMP1 = ABS( AB( JI, 2 )-AB( JI, 1 ) ) TMP2 = MAX( ABS( AB( JI, 2 ) ), ABS( AB( JI, 1 ) ) ) IF( TMP1.LT.MAX( ABSTOL, PIVMIN, RELTOL*TMP2 ) .OR. $ NAB( JI, 1 ).GE.NAB( JI, 2 ) ) THEN * * Converged -- Swap with position KFNEW, * then increment KFNEW * IF( JI.GT.KFNEW ) THEN TMP1 = AB( JI, 1 ) TMP2 = AB( JI, 2 ) ITMP1 = NAB( JI, 1 ) ITMP2 = NAB( JI, 2 ) AB( JI, 1 ) = AB( KFNEW, 1 ) AB( JI, 2 ) = AB( KFNEW, 2 ) NAB( JI, 1 ) = NAB( KFNEW, 1 ) NAB( JI, 2 ) = NAB( KFNEW, 2 ) AB( KFNEW, 1 ) = TMP1 AB( KFNEW, 2 ) = TMP2 NAB( KFNEW, 1 ) = ITMP1 NAB( KFNEW, 2 ) = ITMP2 IF( IJOB.EQ.3 ) THEN ITMP1 = NVAL( JI ) NVAL( JI ) = NVAL( KFNEW ) NVAL( KFNEW ) = ITMP1 END IF END IF KFNEW = KFNEW + 1 END IF 110 CONTINUE KF = KFNEW * * Choose Midpoints * DO 120 JI = KF, KL C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) ) 120 CONTINUE * * If no more intervals to refine, quit. * IF( KF.GT.KL ) $ GO TO 140 130 CONTINUE * * Converged * 140 CONTINUE INFO = MAX( KL+1-KF, 0 ) MOUT = KL * RETURN * * End of DLAEBZ * END *> \brief \b DLAED0 used by sstedc. Computes all eigenvalues and corresponding eigenvectors of an unreduced symmetric tridiagonal matrix using the divide and conquer method. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAED0 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, * WORK, IWORK, INFO ) * * .. Scalar Arguments .. * INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAED0 computes all eigenvalues and corresponding eigenvectors of a *> symmetric tridiagonal matrix using the divide and conquer method. *> \endverbatim * * Arguments: * ========== * *> \param[in] ICOMPQ *> \verbatim *> ICOMPQ is 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. *> \endverbatim *> *> \param[in] QSIZ *> \verbatim *> QSIZ is INTEGER *> The dimension of the orthogonal matrix used to reduce *> the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The dimension of the symmetric tridiagonal matrix. N >= 0. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> On entry, the main diagonal of the tridiagonal matrix. *> On exit, its eigenvalues. *> \endverbatim *> *> \param[in] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N-1) *> The off-diagonal elements of the tridiagonal matrix. *> On exit, E has been destroyed. *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is 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. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. If eigenvectors are *> desired, then LDQ >= max(1,N). In any case, LDQ >= 1. *> \endverbatim *> *> \param[out] QSTORE *> \verbatim *> QSTORE is 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. *> \endverbatim *> *> \param[in] LDQS *> \verbatim *> LDQS is INTEGER *> The leading dimension of the array QSTORE. If ICOMPQ = 1, *> then LDQS >= max(1,N). In any case, LDQS >= 1. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, *> If ICOMPQ = 0 or 1, the dimension of WORK must be at least *> 1 + 3*N + 2*N*lg N + 3*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. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is 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). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup auxOTHERcomputational * *> \par Contributors: * ================== *> *> Jeff Rutter, Computer Science Division, University of California *> at Berkeley, USA * * ===================================================================== SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, $ WORK, IWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ), $ WORK( * ) * .. * * ===================================================================== * * .. 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 *> \brief \b DLAED1 used by sstedc. Computes the updated eigensystem of a diagonal matrix after modification by a rank-one symmetric matrix. Used when the original matrix is tridiagonal. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAED1 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, * INFO ) * * .. Scalar Arguments .. * INTEGER CUTPNT, INFO, LDQ, N * DOUBLE PRECISION RHO * .. * .. Array Arguments .. * INTEGER INDXQ( * ), IWORK( * ) * DOUBLE PRECISION D( * ), Q( LDQ, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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**T ) Q**T(in) = Q(out) * D(out) * Q**T(out) *> *> where Z = Q**T*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 occurrence 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The dimension of the symmetric tridiagonal matrix. N >= 0. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> On entry, the eigenvalues of the rank-1-perturbed matrix. *> On exit, the eigenvalues of the repaired matrix. *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is 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. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= max(1,N). *> \endverbatim *> *> \param[in,out] INDXQ *> \verbatim *> INDXQ is 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. *> \endverbatim *> *> \param[in] RHO *> \verbatim *> RHO is DOUBLE PRECISION *> The subdiagonal entry used to create the rank-1 modification. *> \endverbatim *> *> \param[in] CUTPNT *> \verbatim *> CUTPNT is INTEGER *> The location of the last eigenvalue in the leading sub-matrix. *> min(1,N) <= CUTPNT <= N/2. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (4*N + N**2) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (4*N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: if INFO = 1, an eigenvalue did not converge *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup auxOTHERcomputational * *> \par Contributors: * ================== *> *> Jeff Rutter, Computer Science Division, University of California *> at Berkeley, USA \n *> Modified by Francoise Tisseur, University of Tennessee *> * ===================================================================== SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, $ INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. INTEGER CUTPNT, INFO, LDQ, N DOUBLE PRECISION RHO * .. * .. Array Arguments .. INTEGER INDXQ( * ), IWORK( * ) DOUBLE PRECISION D( * ), Q( LDQ, * ), WORK( * ) * .. * * ===================================================================== * * .. 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 *> \brief \b DLAED2 used by sstedc. Merges eigenvalues and deflates secular equation. Used when the original matrix is tridiagonal. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAED2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, * Q2, INDX, INDXC, INDXP, COLTYP, INFO ) * * .. 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( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[out] K *> \verbatim *> K is INTEGER *> The number of non-deflated eigenvalues, and the order of the *> related secular equation. 0 <= K <=N. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The dimension of the symmetric tridiagonal matrix. N >= 0. *> \endverbatim *> *> \param[in] N1 *> \verbatim *> N1 is INTEGER *> The location of the last eigenvalue in the leading sub-matrix. *> min(1,N) <= N1 <= N/2. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is 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. *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is 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. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= max(1,N). *> \endverbatim *> *> \param[in,out] INDXQ *> \verbatim *> INDXQ is 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. *> \endverbatim *> *> \param[in,out] RHO *> \verbatim *> RHO is 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. *> \endverbatim *> *> \param[in] Z *> \verbatim *> Z is 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. *> \endverbatim *> *> \param[out] DLAMDA *> \verbatim *> DLAMDA is DOUBLE PRECISION array, dimension (N) *> A copy of the first K eigenvalues which will be used by *> DLAED3 to form the secular equation. *> \endverbatim *> *> \param[out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> The first k values of the final deflation-altered z-vector *> which will be passed to DLAED3. *> \endverbatim *> *> \param[out] Q2 *> \verbatim *> Q2 is 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. *> \endverbatim *> *> \param[out] INDX *> \verbatim *> INDX is INTEGER array, dimension (N) *> The permutation used to sort the contents of DLAMDA into *> ascending order. *> \endverbatim *> *> \param[out] INDXC *> \verbatim *> INDXC is 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. *> \endverbatim *> *> \param[out] INDXP *> \verbatim *> INDXP is 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. *> \endverbatim *> *> \param[out] COLTYP *> \verbatim *> COLTYP is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup auxOTHERcomputational * *> \par Contributors: * ================== *> *> Jeff Rutter, Computer Science Division, University of California *> at Berkeley, USA \n *> Modified by Francoise Tisseur, University of Tennessee *> * ===================================================================== SUBROUTINE DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, $ Q2, INDX, INDXC, INDXP, COLTYP, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. 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( * ) * .. * * ===================================================================== * * .. 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. * IF( K.LT.N ) THEN 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 ) END IF * * 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 *> \brief \b DLAED3 used by sstedc. Finds the roots of the secular equation and updates the eigenvectors. Used when the original matrix is tridiagonal. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAED3 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX, * CTOT, W, S, INFO ) * * .. 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( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] K *> \verbatim *> K is INTEGER *> The number of terms in the rational function to be solved by *> DLAED4. K >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of rows and columns in the Q matrix. *> N >= K (deflation may result in N>K). *> \endverbatim *> *> \param[in] N1 *> \verbatim *> N1 is INTEGER *> The location of the last eigenvalue in the leading submatrix. *> min(1,N) <= N1 <= N/2. *> \endverbatim *> *> \param[out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> D(I) contains the updated eigenvalues for *> 1 <= I <= K. *> \endverbatim *> *> \param[out] Q *> \verbatim *> Q is 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. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= max(1,N). *> \endverbatim *> *> \param[in] RHO *> \verbatim *> RHO is DOUBLE PRECISION *> The value of the parameter in the rank one update equation. *> RHO >= 0 required. *> \endverbatim *> *> \param[in,out] DLAMDA *> \verbatim *> DLAMDA is 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. *> \endverbatim *> *> \param[in] Q2 *> \verbatim *> Q2 is DOUBLE PRECISION array, dimension (LDQ2*N) *> The first K columns of this matrix contain the non-deflated *> eigenvectors for the split problem. *> \endverbatim *> *> \param[in] INDX *> \verbatim *> INDX is 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. *> \endverbatim *> *> \param[in] CTOT *> \verbatim *> CTOT is 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. *> \endverbatim *> *> \param[in,out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (K) *> The first K elements of this array contain the components *> of the deflation-adjusted updating vector. Destroyed on *> output. *> \endverbatim *> *> \param[out] S *> \verbatim *> S is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: if INFO = 1, an eigenvalue did not converge *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup auxOTHERcomputational * *> \par Contributors: * ================== *> *> Jeff Rutter, Computer Science Division, University of California *> at Berkeley, USA \n *> Modified by Francoise Tisseur, University of Tennessee *> * ===================================================================== SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX, $ CTOT, W, S, INFO ) * * -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. 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( * ) * .. * * ===================================================================== * * .. 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 *> \brief \b DLAED4 used by sstedc. Finds a single root of the secular equation. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAED4 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO ) * * .. Scalar Arguments .. * INTEGER I, INFO, N * DOUBLE PRECISION DLAM, RHO * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), DELTA( * ), Z( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The length of all arrays. *> \endverbatim *> *> \param[in] I *> \verbatim *> I is INTEGER *> The index of the eigenvalue to be computed. 1 <= I <= N. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The original eigenvalues. It is assumed that they are in *> order, D(I) < D(J) for I < J. *> \endverbatim *> *> \param[in] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (N) *> The components of the updating vector. *> \endverbatim *> *> \param[out] DELTA *> \verbatim *> DELTA is 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. *> \endverbatim *> *> \param[in] RHO *> \verbatim *> RHO is DOUBLE PRECISION *> The scalar in the symmetric updating formula. *> \endverbatim *> *> \param[out] DLAM *> \verbatim *> DLAM is DOUBLE PRECISION *> The computed lambda_I, the I-th updated eigenvalue. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> > 0: if INFO = 1, the updating process failed. *> \endverbatim * *> \par Internal Parameters: * ========================= *> *> \verbatim *> 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. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup auxOTHERcomputational * *> \par Contributors: * ================== *> *> Ren-Cang Li, Computer Science Division, University of California *> at Berkeley, USA *> * ===================================================================== SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER I, INFO, N DOUBLE PRECISION DLAM, RHO * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), DELTA( * ), Z( * ) * .. * * ===================================================================== * * .. 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 *> \brief \b DLAED5 used by sstedc. Solves the 2-by-2 secular equation. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAED5 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM ) * * .. Scalar Arguments .. * INTEGER I * DOUBLE PRECISION DLAM, RHO * .. * .. Array Arguments .. * DOUBLE PRECISION D( 2 ), DELTA( 2 ), Z( 2 ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] I *> \verbatim *> I is INTEGER *> The index of the eigenvalue to be computed. I = 1 or I = 2. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (2) *> The original eigenvalues. We assume D(1) < D(2). *> \endverbatim *> *> \param[in] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (2) *> The components of the updating vector. *> \endverbatim *> *> \param[out] DELTA *> \verbatim *> DELTA is DOUBLE PRECISION array, dimension (2) *> The vector DELTA contains the information necessary *> to construct the eigenvectors. *> \endverbatim *> *> \param[in] RHO *> \verbatim *> RHO is DOUBLE PRECISION *> The scalar in the symmetric updating formula. *> \endverbatim *> *> \param[out] DLAM *> \verbatim *> DLAM is DOUBLE PRECISION *> The computed lambda_I, the I-th updated eigenvalue. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup auxOTHERcomputational * *> \par Contributors: * ================== *> *> Ren-Cang Li, Computer Science Division, University of California *> at Berkeley, USA *> * ===================================================================== SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER I DOUBLE PRECISION DLAM, RHO * .. * .. Array Arguments .. DOUBLE PRECISION D( 2 ), DELTA( 2 ), Z( 2 ) * .. * * ===================================================================== * * .. 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 *> \brief \b DLAED6 used by sstedc. Computes one Newton step in solution of the secular equation. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAED6 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) * * .. Scalar Arguments .. * LOGICAL ORGATI * INTEGER INFO, KNITER * DOUBLE PRECISION FINIT, RHO, TAU * .. * .. Array Arguments .. * DOUBLE PRECISION D( 3 ), Z( 3 ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] KNITER *> \verbatim *> KNITER is INTEGER *> Refer to DLAED4 for its significance. *> \endverbatim *> *> \param[in] ORGATI *> \verbatim *> ORGATI is 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. *> \endverbatim *> *> \param[in] RHO *> \verbatim *> RHO is DOUBLE PRECISION *> Refer to the equation f(x) above. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (3) *> D satisfies d(1) < d(2) < d(3). *> \endverbatim *> *> \param[in] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (3) *> Each of the elements in z must be positive. *> \endverbatim *> *> \param[in] FINIT *> \verbatim *> FINIT is 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). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION *> The root of the equation f(x). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> > 0: if INFO = 1, failure to converge *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup auxOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> 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. *> \endverbatim * *> \par Contributors: * ================== *> *> Ren-Cang Li, Computer Science Division, University of California *> at Berkeley, USA *> * ===================================================================== SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. LOGICAL ORGATI INTEGER INFO, KNITER DOUBLE PRECISION FINIT, RHO, TAU * .. * .. Array Arguments .. DOUBLE PRECISION D( 3 ), Z( 3 ) * .. * * ===================================================================== * * .. Parameters .. INTEGER MAXIT PARAMETER ( MAXIT = 40 ) DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, $ THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0 ) * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. Local Arrays .. DOUBLE PRECISION DSCALE( 3 ), ZSCALE( 3 ) * .. * .. Local Scalars .. LOGICAL SCALE INTEGER I, ITER, NITER DOUBLE PRECISION A, B, BASE, C, DDF, DF, EPS, ERRETM, ETA, F, $ FC, SCLFAC, SCLINV, SMALL1, SMALL2, SMINV1, $ SMINV2, TEMP, TEMP1, TEMP2, TEMP3, TEMP4, $ LBD, UBD * .. * .. Intrinsic Functions .. INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT * .. * .. Executable Statements .. * INFO = 0 * IF( ORGATI ) THEN LBD = D(2) UBD = D(3) ELSE LBD = D(1) UBD = D(2) END IF IF( FINIT .LT. ZERO )THEN LBD = ZERO ELSE UBD = ZERO END IF * NITER = 1 TAU = ZERO IF( KNITER.EQ.2 ) THEN IF( ORGATI ) THEN TEMP = ( D( 3 )-D( 2 ) ) / TWO C = RHO + Z( 1 ) / ( ( D( 1 )-D( 2 ) )-TEMP ) A = C*( D( 2 )+D( 3 ) ) + Z( 2 ) + Z( 3 ) B = C*D( 2 )*D( 3 ) + Z( 2 )*D( 3 ) + Z( 3 )*D( 2 ) ELSE TEMP = ( D( 1 )-D( 2 ) ) / TWO C = RHO + Z( 3 ) / ( ( D( 3 )-D( 2 ) )-TEMP ) A = C*( D( 1 )+D( 2 ) ) + Z( 1 ) + Z( 2 ) B = C*D( 1 )*D( 2 ) + Z( 1 )*D( 2 ) + Z( 2 )*D( 1 ) END IF TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) ) A = A / TEMP B = B / TEMP C = C / TEMP IF( C.EQ.ZERO ) THEN TAU = B / A ELSE IF( A.LE.ZERO ) THEN TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) ELSE TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) END IF IF( TAU .LT. LBD .OR. TAU .GT. UBD ) $ TAU = ( LBD+UBD )/TWO IF( D(1).EQ.TAU .OR. D(2).EQ.TAU .OR. D(3).EQ.TAU ) THEN TAU = ZERO ELSE TEMP = FINIT + TAU*Z(1)/( D(1)*( D( 1 )-TAU ) ) + $ TAU*Z(2)/( D(2)*( D( 2 )-TAU ) ) + $ TAU*Z(3)/( D(3)*( D( 3 )-TAU ) ) IF( TEMP .LE. ZERO )THEN LBD = TAU ELSE UBD = TAU END IF IF( ABS( FINIT ).LE.ABS( TEMP ) ) $ TAU = ZERO END IF END IF * * get machine parameters for possible scaling to avoid overflow * * modified by Sven: parameters SMALL1, SMINV1, SMALL2, * SMINV2, EPS are not SAVEd anymore between one call to the * others but recomputed at each call * EPS = DLAMCH( 'Epsilon' ) BASE = DLAMCH( 'Base' ) SMALL1 = BASE**( INT( LOG( DLAMCH( 'SafMin' ) ) / LOG( BASE ) / $ THREE ) ) SMINV1 = ONE / SMALL1 SMALL2 = SMALL1*SMALL1 SMINV2 = SMINV1*SMINV1 * * Determine if scaling of inputs necessary to avoid overflow * when computing 1/TEMP**3 * IF( ORGATI ) THEN TEMP = MIN( ABS( D( 2 )-TAU ), ABS( D( 3 )-TAU ) ) ELSE TEMP = MIN( ABS( D( 1 )-TAU ), ABS( D( 2 )-TAU ) ) END IF SCALE = .FALSE. IF( TEMP.LE.SMALL1 ) THEN SCALE = .TRUE. IF( TEMP.LE.SMALL2 ) THEN * * Scale up by power of radix nearest 1/SAFMIN**(2/3) * SCLFAC = SMINV2 SCLINV = SMALL2 ELSE * * Scale up by power of radix nearest 1/SAFMIN**(1/3) * SCLFAC = SMINV1 SCLINV = SMALL1 END IF * * Scaling up safe because D, Z, TAU scaled elsewhere to be O(1) * DO 10 I = 1, 3 DSCALE( I ) = D( I )*SCLFAC ZSCALE( I ) = Z( I )*SCLFAC 10 CONTINUE TAU = TAU*SCLFAC LBD = LBD*SCLFAC UBD = UBD*SCLFAC ELSE * * Copy D and Z to DSCALE and ZSCALE * DO 20 I = 1, 3 DSCALE( I ) = D( I ) ZSCALE( I ) = Z( I ) 20 CONTINUE END IF * FC = ZERO DF = ZERO DDF = ZERO DO 30 I = 1, 3 TEMP = ONE / ( DSCALE( I )-TAU ) TEMP1 = ZSCALE( I )*TEMP TEMP2 = TEMP1*TEMP TEMP3 = TEMP2*TEMP FC = FC + TEMP1 / DSCALE( I ) DF = DF + TEMP2 DDF = DDF + TEMP3 30 CONTINUE F = FINIT + TAU*FC * IF( ABS( F ).LE.ZERO ) $ GO TO 60 IF( F .LE. ZERO )THEN LBD = TAU ELSE UBD = TAU END IF * * Iteration begins -- Use Gragg-Thornton-Warner cubic convergent * scheme * * It is not hard to see that * * 1) Iterations will go up monotonically * if FINIT < 0; * * 2) Iterations will go down monotonically * if FINIT > 0. * ITER = NITER + 1 * DO 50 NITER = ITER, MAXIT * IF( ORGATI ) THEN TEMP1 = DSCALE( 2 ) - TAU TEMP2 = DSCALE( 3 ) - TAU ELSE TEMP1 = DSCALE( 1 ) - TAU TEMP2 = DSCALE( 2 ) - TAU END IF A = ( TEMP1+TEMP2 )*F - TEMP1*TEMP2*DF B = TEMP1*TEMP2*F C = F - ( TEMP1+TEMP2 )*DF + TEMP1*TEMP2*DDF TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) ) A = A / TEMP B = B / TEMP C = C / TEMP IF( C.EQ.ZERO ) THEN ETA = B / A ELSE IF( A.LE.ZERO ) THEN ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) ELSE ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) END IF IF( F*ETA.GE.ZERO ) THEN ETA = -F / DF END IF * TAU = TAU + ETA IF( TAU .LT. LBD .OR. TAU .GT. UBD ) $ TAU = ( LBD + UBD )/TWO * FC = ZERO ERRETM = ZERO DF = ZERO DDF = ZERO DO 40 I = 1, 3 IF ( ( DSCALE( I )-TAU ).NE.ZERO ) THEN 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 ELSE GO TO 60 END IF 40 CONTINUE F = FINIT + TAU*FC ERRETM = EIGHT*( ABS( FINIT )+ABS( TAU )*ERRETM ) + $ ABS( TAU )*DF IF( ( ABS( F ).LE.FOUR*EPS*ERRETM ) .OR. $ ( (UBD-LBD).LE.FOUR*EPS*ABS(TAU) ) ) $ 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 *> \brief \b DLAED7 used by sstedc. Computes the updated eigensystem of a diagonal matrix after modification by a rank-one symmetric matrix. Used when the original matrix is dense. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAED7 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, * LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR, * PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK, * INFO ) * * .. 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( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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**T ) Q**T(in) = Q(out) * D(out) * Q**T(out) *> *> where Z = Q**Tu, 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 occurrence 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] ICOMPQ *> \verbatim *> ICOMPQ is 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. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The dimension of the symmetric tridiagonal matrix. N >= 0. *> \endverbatim *> *> \param[in] QSIZ *> \verbatim *> QSIZ is INTEGER *> The dimension of the orthogonal matrix used to reduce *> the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. *> \endverbatim *> *> \param[in] TLVLS *> \verbatim *> TLVLS is INTEGER *> The total number of merging levels in the overall divide and *> conquer tree. *> \endverbatim *> *> \param[in] CURLVL *> \verbatim *> CURLVL is INTEGER *> The current level in the overall merge routine, *> 0 <= CURLVL <= TLVLS. *> \endverbatim *> *> \param[in] CURPBM *> \verbatim *> CURPBM is INTEGER *> The current problem in the current level in the overall *> merge routine (counting from upper left to lower right). *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> On entry, the eigenvalues of the rank-1-perturbed matrix. *> On exit, the eigenvalues of the repaired matrix. *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is 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. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= max(1,N). *> \endverbatim *> *> \param[out] INDXQ *> \verbatim *> INDXQ is 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. *> \endverbatim *> *> \param[in] RHO *> \verbatim *> RHO is DOUBLE PRECISION *> The subdiagonal element used to create the rank-1 *> modification. *> \endverbatim *> *> \param[in] CUTPNT *> \verbatim *> CUTPNT is INTEGER *> Contains the location of the last eigenvalue in the leading *> sub-matrix. min(1,N) <= CUTPNT <= N. *> \endverbatim *> *> \param[in,out] QSTORE *> \verbatim *> QSTORE is 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. *> \endverbatim *> *> \param[in,out] QPTR *> \verbatim *> QPTR is 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. *> \endverbatim *> *> \param[in] PRMPTR *> \verbatim *> PRMPTR is 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. *> \endverbatim *> *> \param[in] PERM *> \verbatim *> PERM is INTEGER array, dimension (N lg N) *> Contains the permutations (from deflation and sorting) to be *> applied to each eigenblock. *> \endverbatim *> *> \param[in] GIVPTR *> \verbatim *> GIVPTR is 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. *> \endverbatim *> *> \param[in] GIVCOL *> \verbatim *> GIVCOL is INTEGER array, dimension (2, N lg N) *> Each pair of numbers indicates a pair of columns to take place *> in a Givens rotation. *> \endverbatim *> *> \param[in] GIVNUM *> \verbatim *> GIVNUM is DOUBLE PRECISION array, dimension (2, N lg N) *> Each number indicates the S value to be used in the *> corresponding Givens rotation. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*N+2*QSIZ*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (4*N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: if INFO = 1, an eigenvalue did not converge *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup auxOTHERcomputational * *> \par Contributors: * ================== *> *> Jeff Rutter, Computer Science Division, University of California *> at Berkeley, USA * * ===================================================================== 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 computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. 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( * ) * .. * * ===================================================================== * * .. 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 = -3 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 *> \brief \b DLAED8 used by sstedc. Merges eigenvalues and deflates secular equation. Used when the original matrix is dense. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAED8 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, * CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR, * GIVCOL, GIVNUM, INDXP, INDX, INFO ) * * .. 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( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] ICOMPQ *> \verbatim *> ICOMPQ is 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. *> \endverbatim *> *> \param[out] K *> \verbatim *> K is INTEGER *> The number of non-deflated eigenvalues, and the order of the *> related secular equation. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The dimension of the symmetric tridiagonal matrix. N >= 0. *> \endverbatim *> *> \param[in] QSIZ *> \verbatim *> QSIZ is INTEGER *> The dimension of the orthogonal matrix used to reduce *> the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is 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. *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is 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. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= max(1,N). *> \endverbatim *> *> \param[in] INDXQ *> \verbatim *> INDXQ is 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. *> \endverbatim *> *> \param[in,out] RHO *> \verbatim *> RHO is 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. *> \endverbatim *> *> \param[in] CUTPNT *> \verbatim *> CUTPNT is INTEGER *> The location of the last eigenvalue in the leading *> sub-matrix. min(1,N) <= CUTPNT <= N. *> \endverbatim *> *> \param[in] Z *> \verbatim *> Z is 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. *> \endverbatim *> *> \param[out] DLAMDA *> \verbatim *> DLAMDA is DOUBLE PRECISION array, dimension (N) *> A copy of the first K eigenvalues which will be used by *> DLAED3 to form the secular equation. *> \endverbatim *> *> \param[out] Q2 *> \verbatim *> Q2 is 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. *> \endverbatim *> *> \param[in] LDQ2 *> \verbatim *> LDQ2 is INTEGER *> The leading dimension of the array Q2. LDQ2 >= max(1,N). *> \endverbatim *> *> \param[out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> The first k values of the final deflation-altered z-vector and *> will be passed to DLAED3. *> \endverbatim *> *> \param[out] PERM *> \verbatim *> PERM is INTEGER array, dimension (N) *> The permutations (from deflation and sorting) to be applied *> to each eigenblock. *> \endverbatim *> *> \param[out] GIVPTR *> \verbatim *> GIVPTR is INTEGER *> The number of Givens rotations which took place in this *> subproblem. *> \endverbatim *> *> \param[out] GIVCOL *> \verbatim *> GIVCOL is INTEGER array, dimension (2, N) *> Each pair of numbers indicates a pair of columns to take place *> in a Givens rotation. *> \endverbatim *> *> \param[out] GIVNUM *> \verbatim *> GIVNUM is DOUBLE PRECISION array, dimension (2, N) *> Each number indicates the S value to be used in the *> corresponding Givens rotation. *> \endverbatim *> *> \param[out] INDXP *> \verbatim *> INDXP is 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. *> \endverbatim *> *> \param[out] INDX *> \verbatim *> INDX is INTEGER array, dimension (N) *> The permutation used to sort the contents of D into ascending *> order. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup auxOTHERcomputational * *> \par Contributors: * ================== *> *> Jeff Rutter, Computer Science Division, University of California *> at Berkeley, USA * * ===================================================================== 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 computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. 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( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT PARAMETER ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0, $ TWO = 2.0D0, EIGHT = 8.0D0 ) * .. * .. Local Scalars .. * INTEGER I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2 DOUBLE PRECISION C, EPS, S, T, TAU, TOL * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DLAPY2 EXTERNAL IDAMAX, DLAMCH, DLAPY2 * .. * .. External Subroutines .. EXTERNAL DCOPY, DLACPY, DLAMRG, DROT, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 * IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN INFO = -4 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN INFO = -10 ELSE IF( LDQ2.LT.MAX( 1, N ) ) THEN INFO = -14 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLAED8', -INFO ) RETURN END IF * * Need to initialize GIVPTR to O here in case of quick exit * to prevent an unspecified code behavior (usually sigfault) * when IWORK array on entry to *stedc is not zeroed * (or at least some IWORK entries which used in *laed7 for GIVPTR). * GIVPTR = 0 * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * N1 = CUTPNT N2 = N - N1 N1P1 = N1 + 1 * IF( RHO.LT.ZERO ) THEN CALL DSCAL( N2, MONE, Z( N1P1 ), 1 ) END IF * * Normalize z so that norm(z) = 1 * T = ONE / SQRT( TWO ) DO 10 J = 1, N INDX( J ) = J 10 CONTINUE CALL DSCAL( N, T, Z, 1 ) RHO = ABS( TWO*RHO ) * * Sort the eigenvalues into increasing order * DO 20 I = CUTPNT + 1, N INDXQ( I ) = INDXQ( I ) + CUTPNT 20 CONTINUE DO 30 I = 1, N DLAMDA( I ) = D( INDXQ( I ) ) W( I ) = Z( INDXQ( I ) ) 30 CONTINUE I = 1 J = CUTPNT + 1 CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDX ) DO 40 I = 1, N D( I ) = DLAMDA( INDX( I ) ) Z( I ) = W( INDX( I ) ) 40 CONTINUE * * Calculate the allowable deflation tolerence * IMAX = IDAMAX( N, Z, 1 ) JMAX = IDAMAX( N, D, 1 ) EPS = DLAMCH( 'Epsilon' ) TOL = EIGHT*EPS*ABS( D( JMAX ) ) * * If the rank-1 modifier is small enough, no more needs to be done * except to reorganize Q so that its columns correspond with the * elements in D. * IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN K = 0 IF( ICOMPQ.EQ.0 ) THEN DO 50 J = 1, N PERM( J ) = INDXQ( INDX( J ) ) 50 CONTINUE ELSE DO 60 J = 1, N PERM( J ) = INDXQ( INDX( J ) ) CALL DCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 ) 60 CONTINUE CALL DLACPY( 'A', QSIZ, N, Q2( 1, 1 ), LDQ2, Q( 1, 1 ), $ LDQ ) END IF RETURN END IF * * If there are multiple eigenvalues then the problem deflates. Here * the number of equal eigenvalues are found. As each equal * eigenvalue is found, an elementary reflector is computed to rotate * the corresponding eigensubspace so that the corresponding * components of Z are zero in this new basis. * K = 0 K2 = N + 1 DO 70 J = 1, N IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN * * Deflate due to small z component. * K2 = K2 - 1 INDXP( K2 ) = J IF( J.EQ.N ) $ GO TO 110 ELSE JLAM = J GO TO 80 END IF 70 CONTINUE 80 CONTINUE J = J + 1 IF( J.GT.N ) $ GO TO 100 IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN * * Deflate due to small z component. * K2 = K2 - 1 INDXP( K2 ) = J ELSE * * Check if eigenvalues are close enough to allow deflation. * S = Z( JLAM ) C = Z( J ) * * Find sqrt(a**2+b**2) without overflow or * destructive underflow. * TAU = DLAPY2( C, S ) T = D( J ) - D( JLAM ) C = C / TAU S = -S / TAU IF( ABS( T*C*S ).LE.TOL ) THEN * * Deflation is possible. * Z( J ) = TAU Z( JLAM ) = ZERO * * Record the appropriate Givens rotation * GIVPTR = GIVPTR + 1 GIVCOL( 1, GIVPTR ) = INDXQ( INDX( JLAM ) ) GIVCOL( 2, GIVPTR ) = INDXQ( INDX( J ) ) GIVNUM( 1, GIVPTR ) = C GIVNUM( 2, GIVPTR ) = S IF( ICOMPQ.EQ.1 ) THEN CALL DROT( QSIZ, Q( 1, INDXQ( INDX( JLAM ) ) ), 1, $ Q( 1, INDXQ( INDX( J ) ) ), 1, C, S ) END IF T = D( JLAM )*C*C + D( J )*S*S D( J ) = D( JLAM )*S*S + D( J )*C*C D( JLAM ) = T K2 = K2 - 1 I = 1 90 CONTINUE IF( K2+I.LE.N ) THEN IF( D( JLAM ).LT.D( INDXP( K2+I ) ) ) THEN INDXP( K2+I-1 ) = INDXP( K2+I ) INDXP( K2+I ) = JLAM I = I + 1 GO TO 90 ELSE INDXP( K2+I-1 ) = JLAM END IF ELSE INDXP( K2+I-1 ) = JLAM END IF JLAM = J ELSE K = K + 1 W( K ) = Z( JLAM ) DLAMDA( K ) = D( JLAM ) INDXP( K ) = JLAM JLAM = J END IF END IF GO TO 80 100 CONTINUE * * Record the last eigenvalue. * K = K + 1 W( K ) = Z( JLAM ) DLAMDA( K ) = D( JLAM ) INDXP( K ) = JLAM * 110 CONTINUE * * Sort the eigenvalues and corresponding eigenvectors into DLAMDA * and Q2 respectively. The eigenvalues/vectors which were not * deflated go into the first K slots of DLAMDA and Q2 respectively, * while those which were deflated go into the last N - K slots. * IF( ICOMPQ.EQ.0 ) THEN DO 120 J = 1, N JP = INDXP( J ) DLAMDA( J ) = D( JP ) PERM( J ) = INDXQ( INDX( JP ) ) 120 CONTINUE ELSE DO 130 J = 1, N JP = INDXP( J ) DLAMDA( J ) = D( JP ) PERM( J ) = INDXQ( INDX( JP ) ) CALL DCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 ) 130 CONTINUE END IF * * The deflated eigenvalues and their corresponding vectors go back * into the last N - K slots of D and Q respectively. * IF( K.LT.N ) THEN IF( ICOMPQ.EQ.0 ) THEN CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 ) ELSE CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 ) CALL DLACPY( 'A', QSIZ, N-K, Q2( 1, K+1 ), LDQ2, $ Q( 1, K+1 ), LDQ ) END IF END IF * RETURN * * End of DLAED8 * END *> \brief \b DLAED9 used by sstedc. Finds the roots of the secular equation and updates the eigenvectors. Used when the original matrix is dense. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAED9 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W, * S, LDS, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N * DOUBLE PRECISION RHO * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ), * $ W( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] K *> \verbatim *> K is INTEGER *> The number of terms in the rational function to be solved by *> DLAED4. K >= 0. *> \endverbatim *> *> \param[in] KSTART *> \verbatim *> KSTART is INTEGER *> \endverbatim *> *> \param[in] KSTOP *> \verbatim *> KSTOP is INTEGER *> The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP *> are to be computed. 1 <= KSTART <= KSTOP <= K. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of rows and columns in the Q matrix. *> N >= K (delation may result in N > K). *> \endverbatim *> *> \param[out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> D(I) contains the updated eigenvalues *> for KSTART <= I <= KSTOP. *> \endverbatim *> *> \param[out] Q *> \verbatim *> Q is DOUBLE PRECISION array, dimension (LDQ,N) *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= max( 1, N ). *> \endverbatim *> *> \param[in] RHO *> \verbatim *> RHO is DOUBLE PRECISION *> The value of the parameter in the rank one update equation. *> RHO >= 0 required. *> \endverbatim *> *> \param[in] DLAMDA *> \verbatim *> DLAMDA is 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. *> \endverbatim *> *> \param[in] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (K) *> The first K elements of this array contain the components *> of the deflation-adjusted updating vector. *> \endverbatim *> *> \param[out] S *> \verbatim *> S is 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. *> \endverbatim *> *> \param[in] LDS *> \verbatim *> LDS is INTEGER *> The leading dimension of S. LDS >= max( 1, K ). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: if INFO = 1, an eigenvalue did not converge *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup auxOTHERcomputational * *> \par Contributors: * ================== *> *> Jeff Rutter, Computer Science Division, University of California *> at Berkeley, USA * * ===================================================================== SUBROUTINE DLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W, $ S, LDS, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N DOUBLE PRECISION RHO * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ), $ W( * ) * .. * * ===================================================================== * * .. 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 *> \brief \b DLAEDA used by sstedc. Computes the Z vector determining the rank-one modification of the diagonal matrix. Used when the original matrix is dense. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAEDA + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, * GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO ) * * .. Scalar Arguments .. * INTEGER CURLVL, CURPBM, INFO, N, TLVLS * .. * .. Array Arguments .. * INTEGER GIVCOL( 2, * ), GIVPTR( * ), PERM( * ), * $ PRMPTR( * ), QPTR( * ) * DOUBLE PRECISION GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The dimension of the symmetric tridiagonal matrix. N >= 0. *> \endverbatim *> *> \param[in] TLVLS *> \verbatim *> TLVLS is INTEGER *> The total number of merging levels in the overall divide and *> conquer tree. *> \endverbatim *> *> \param[in] CURLVL *> \verbatim *> CURLVL is INTEGER *> The current level in the overall merge routine, *> 0 <= curlvl <= tlvls. *> \endverbatim *> *> \param[in] CURPBM *> \verbatim *> CURPBM is INTEGER *> The current problem in the current level in the overall *> merge routine (counting from upper left to lower right). *> \endverbatim *> *> \param[in] PRMPTR *> \verbatim *> PRMPTR is 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. *> \endverbatim *> *> \param[in] PERM *> \verbatim *> PERM is INTEGER array, dimension (N lg N) *> Contains the permutations (from deflation and sorting) to be *> applied to each eigenblock. *> \endverbatim *> *> \param[in] GIVPTR *> \verbatim *> GIVPTR is 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. *> \endverbatim *> *> \param[in] GIVCOL *> \verbatim *> GIVCOL is INTEGER array, dimension (2, N lg N) *> Each pair of numbers indicates a pair of columns to take place *> in a Givens rotation. *> \endverbatim *> *> \param[in] GIVNUM *> \verbatim *> GIVNUM is DOUBLE PRECISION array, dimension (2, N lg N) *> Each number indicates the S value to be used in the *> corresponding Givens rotation. *> \endverbatim *> *> \param[in] Q *> \verbatim *> Q is DOUBLE PRECISION array, dimension (N**2) *> Contains the square eigenblocks from previous levels, the *> starting positions for blocks are given by QPTR. *> \endverbatim *> *> \param[in] QPTR *> \verbatim *> QPTR is 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. *> \endverbatim *> *> \param[out] Z *> \verbatim *> Z is 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). *> \endverbatim *> *> \param[out] ZTEMP *> \verbatim *> ZTEMP is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup auxOTHERcomputational * *> \par Contributors: * ================== *> *> Jeff Rutter, Computer Science Division, University of California *> at Berkeley, USA * * ===================================================================== SUBROUTINE DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, $ GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER CURLVL, CURPBM, INFO, N, TLVLS * .. * .. Array Arguments .. INTEGER GIVCOL( 2, * ), GIVPTR( * ), PERM( * ), $ PRMPTR( * ), QPTR( * ) DOUBLE PRECISION GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. INTEGER BSIZ1, BSIZ2, CURR, I, K, MID, PSIZ1, PSIZ2, $ PTR, ZPTR1 * .. * .. External Subroutines .. EXTERNAL DCOPY, DGEMV, DROT, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC DBLE, INT, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 * IF( N.LT.0 ) THEN INFO = -1 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLAEDA', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Determine location of first number in second half. * MID = N / 2 + 1 * * Gather last/first rows of appropriate eigenblocks into center of Z * PTR = 1 * * Determine location of lowest level subproblem in the full storage * scheme * CURR = PTR + CURPBM*2**CURLVL + 2**( CURLVL-1 ) - 1 * * Determine size of these matrices. We add HALF to the value of * the SQRT in case the machine underestimates one of these square * roots. * BSIZ1 = INT( HALF+SQRT( DBLE( QPTR( CURR+1 )-QPTR( CURR ) ) ) ) BSIZ2 = INT( HALF+SQRT( DBLE( QPTR( CURR+2 )-QPTR( CURR+1 ) ) ) ) DO 10 K = 1, MID - BSIZ1 - 1 Z( K ) = ZERO 10 CONTINUE CALL DCOPY( BSIZ1, Q( QPTR( CURR )+BSIZ1-1 ), BSIZ1, $ Z( MID-BSIZ1 ), 1 ) CALL DCOPY( BSIZ2, Q( QPTR( CURR+1 ) ), BSIZ2, Z( MID ), 1 ) DO 20 K = MID + BSIZ2, N Z( K ) = ZERO 20 CONTINUE * * Loop through remaining levels 1 -> CURLVL applying the Givens * rotations and permutation and then multiplying the center matrices * against the current Z. * PTR = 2**TLVLS + 1 DO 70 K = 1, CURLVL - 1 CURR = PTR + CURPBM*2**( CURLVL-K ) + 2**( CURLVL-K-1 ) - 1 PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR ) PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 ) ZPTR1 = MID - PSIZ1 * * Apply Givens at CURR and CURR+1 * DO 30 I = GIVPTR( CURR ), GIVPTR( CURR+1 ) - 1 CALL DROT( 1, Z( ZPTR1+GIVCOL( 1, I )-1 ), 1, $ Z( ZPTR1+GIVCOL( 2, I )-1 ), 1, GIVNUM( 1, I ), $ GIVNUM( 2, I ) ) 30 CONTINUE DO 40 I = GIVPTR( CURR+1 ), GIVPTR( CURR+2 ) - 1 CALL DROT( 1, Z( MID-1+GIVCOL( 1, I ) ), 1, $ Z( MID-1+GIVCOL( 2, I ) ), 1, GIVNUM( 1, I ), $ GIVNUM( 2, I ) ) 40 CONTINUE PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR ) PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 ) DO 50 I = 0, PSIZ1 - 1 ZTEMP( I+1 ) = Z( ZPTR1+PERM( PRMPTR( CURR )+I )-1 ) 50 CONTINUE DO 60 I = 0, PSIZ2 - 1 ZTEMP( PSIZ1+I+1 ) = Z( MID+PERM( PRMPTR( CURR+1 )+I )-1 ) 60 CONTINUE * * Multiply Blocks at CURR and CURR+1 * * Determine size of these matrices. We add HALF to the value of * the SQRT in case the machine underestimates one of these * square roots. * BSIZ1 = INT( HALF+SQRT( DBLE( QPTR( CURR+1 )-QPTR( CURR ) ) ) ) BSIZ2 = INT( HALF+SQRT( DBLE( QPTR( CURR+2 )-QPTR( CURR+ $ 1 ) ) ) ) IF( BSIZ1.GT.0 ) THEN CALL DGEMV( 'T', BSIZ1, BSIZ1, ONE, Q( QPTR( CURR ) ), $ BSIZ1, ZTEMP( 1 ), 1, ZERO, Z( ZPTR1 ), 1 ) END IF CALL DCOPY( PSIZ1-BSIZ1, ZTEMP( BSIZ1+1 ), 1, Z( ZPTR1+BSIZ1 ), $ 1 ) IF( BSIZ2.GT.0 ) THEN CALL DGEMV( 'T', BSIZ2, BSIZ2, ONE, Q( QPTR( CURR+1 ) ), $ BSIZ2, ZTEMP( PSIZ1+1 ), 1, ZERO, Z( MID ), 1 ) END IF CALL DCOPY( PSIZ2-BSIZ2, ZTEMP( PSIZ1+BSIZ2+1 ), 1, $ Z( MID+BSIZ2 ), 1 ) * PTR = PTR + 2**( TLVLS-K ) 70 CONTINUE * RETURN * * End of DLAEDA * END *> \brief \b DLAEIN computes a specified right or left eigenvector of an upper Hessenberg matrix by inverse iteration. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAEIN + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAEIN( RIGHTV, NOINIT, N, H, LDH, WR, WI, VR, VI, B, * LDB, WORK, EPS3, SMLNUM, BIGNUM, INFO ) * * .. Scalar Arguments .. * LOGICAL NOINIT, RIGHTV * INTEGER INFO, LDB, LDH, N * DOUBLE PRECISION BIGNUM, EPS3, SMLNUM, WI, WR * .. * .. Array Arguments .. * DOUBLE PRECISION B( LDB, * ), H( LDH, * ), VI( * ), VR( * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAEIN uses inverse iteration to find a right or left eigenvector *> corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg *> matrix H. *> \endverbatim * * Arguments: * ========== * *> \param[in] RIGHTV *> \verbatim *> RIGHTV is LOGICAL *> = .TRUE. : compute right eigenvector; *> = .FALSE.: compute left eigenvector. *> \endverbatim *> *> \param[in] NOINIT *> \verbatim *> NOINIT is LOGICAL *> = .TRUE. : no initial vector supplied in (VR,VI). *> = .FALSE.: initial vector supplied in (VR,VI). *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix H. N >= 0. *> \endverbatim *> *> \param[in] H *> \verbatim *> H is DOUBLE PRECISION array, dimension (LDH,N) *> The upper Hessenberg matrix H. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is INTEGER *> The leading dimension of the array H. LDH >= max(1,N). *> \endverbatim *> *> \param[in] WR *> \verbatim *> WR is DOUBLE PRECISION *> \endverbatim *> *> \param[in] WI *> \verbatim *> WI is DOUBLE PRECISION *> The real and imaginary parts of the eigenvalue of H whose *> corresponding right or left eigenvector is to be computed. *> \endverbatim *> *> \param[in,out] VR *> \verbatim *> VR is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[in,out] VI *> \verbatim *> VI is DOUBLE PRECISION array, dimension (N) *> On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain *> a real starting vector for inverse iteration using the real *> eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI *> must contain the real and imaginary parts of a complex *> starting vector for inverse iteration using the complex *> eigenvalue (WR,WI); otherwise VR and VI need not be set. *> On exit, if WI = 0.0 (real eigenvalue), VR contains the *> computed real eigenvector; if WI.ne.0.0 (complex eigenvalue), *> VR and VI contain the real and imaginary parts of the *> computed complex eigenvector. The eigenvector is normalized *> so that the component of largest magnitude has magnitude 1; *> here the magnitude of a complex number (x,y) is taken to be *> |x| + |y|. *> VI is not referenced if WI = 0.0. *> \endverbatim *> *> \param[out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,N) *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= N+1. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[in] EPS3 *> \verbatim *> EPS3 is DOUBLE PRECISION *> A small machine-dependent value which is used to perturb *> close eigenvalues, and to replace zero pivots. *> \endverbatim *> *> \param[in] SMLNUM *> \verbatim *> SMLNUM is DOUBLE PRECISION *> A machine-dependent value close to the underflow threshold. *> \endverbatim *> *> \param[in] BIGNUM *> \verbatim *> BIGNUM is DOUBLE PRECISION *> A machine-dependent value close to the overflow threshold. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> = 1: inverse iteration did not converge; VR is set to the *> last iterate, and so is VI if WI.ne.0.0. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLAEIN( RIGHTV, NOINIT, N, H, LDH, WR, WI, VR, VI, B, $ LDB, WORK, EPS3, SMLNUM, BIGNUM, INFO ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. LOGICAL NOINIT, RIGHTV INTEGER INFO, LDB, LDH, N DOUBLE PRECISION BIGNUM, EPS3, SMLNUM, WI, WR * .. * .. Array Arguments .. DOUBLE PRECISION B( LDB, * ), H( LDH, * ), VI( * ), VR( * ), $ WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TENTH PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TENTH = 1.0D-1 ) * .. * .. Local Scalars .. CHARACTER NORMIN, TRANS INTEGER I, I1, I2, I3, IERR, ITS, J DOUBLE PRECISION ABSBII, ABSBJJ, EI, EJ, GROWTO, NORM, NRMSML, $ REC, ROOTN, SCALE, TEMP, VCRIT, VMAX, VNORM, W, $ W1, X, XI, XR, Y * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DASUM, DLAPY2, DNRM2 EXTERNAL IDAMAX, DASUM, DLAPY2, DNRM2 * .. * .. External Subroutines .. EXTERNAL DLADIV, DLATRS, DSCAL * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, SQRT * .. * .. Executable Statements .. * INFO = 0 * * GROWTO is the threshold used in the acceptance test for an * eigenvector. * ROOTN = SQRT( DBLE( N ) ) GROWTO = TENTH / ROOTN NRMSML = MAX( ONE, EPS3*ROOTN )*SMLNUM * * Form B = H - (WR,WI)*I (except that the subdiagonal elements and * the imaginary parts of the diagonal elements are not stored). * DO 20 J = 1, N DO 10 I = 1, J - 1 B( I, J ) = H( I, J ) 10 CONTINUE B( J, J ) = H( J, J ) - WR 20 CONTINUE * IF( WI.EQ.ZERO ) THEN * * Real eigenvalue. * IF( NOINIT ) THEN * * Set initial vector. * DO 30 I = 1, N VR( I ) = EPS3 30 CONTINUE ELSE * * Scale supplied initial vector. * VNORM = DNRM2( N, VR, 1 ) CALL DSCAL( N, ( EPS3*ROOTN ) / MAX( VNORM, NRMSML ), VR, $ 1 ) END IF * IF( RIGHTV ) THEN * * LU decomposition with partial pivoting of B, replacing zero * pivots by EPS3. * DO 60 I = 1, N - 1 EI = H( I+1, I ) IF( ABS( B( I, I ) ).LT.ABS( EI ) ) THEN * * Interchange rows and eliminate. * X = B( I, I ) / EI B( I, I ) = EI DO 40 J = I + 1, N TEMP = B( I+1, J ) B( I+1, J ) = B( I, J ) - X*TEMP B( I, J ) = TEMP 40 CONTINUE ELSE * * Eliminate without interchange. * IF( B( I, I ).EQ.ZERO ) $ B( I, I ) = EPS3 X = EI / B( I, I ) IF( X.NE.ZERO ) THEN DO 50 J = I + 1, N B( I+1, J ) = B( I+1, J ) - X*B( I, J ) 50 CONTINUE END IF END IF 60 CONTINUE IF( B( N, N ).EQ.ZERO ) $ B( N, N ) = EPS3 * TRANS = 'N' * ELSE * * UL decomposition with partial pivoting of B, replacing zero * pivots by EPS3. * DO 90 J = N, 2, -1 EJ = H( J, J-1 ) IF( ABS( B( J, J ) ).LT.ABS( EJ ) ) THEN * * Interchange columns and eliminate. * X = B( J, J ) / EJ B( J, J ) = EJ DO 70 I = 1, J - 1 TEMP = B( I, J-1 ) B( I, J-1 ) = B( I, J ) - X*TEMP B( I, J ) = TEMP 70 CONTINUE ELSE * * Eliminate without interchange. * IF( B( J, J ).EQ.ZERO ) $ B( J, J ) = EPS3 X = EJ / B( J, J ) IF( X.NE.ZERO ) THEN DO 80 I = 1, J - 1 B( I, J-1 ) = B( I, J-1 ) - X*B( I, J ) 80 CONTINUE END IF END IF 90 CONTINUE IF( B( 1, 1 ).EQ.ZERO ) $ B( 1, 1 ) = EPS3 * TRANS = 'T' * END IF * NORMIN = 'N' DO 110 ITS = 1, N * * Solve U*x = scale*v for a right eigenvector * or U**T*x = scale*v for a left eigenvector, * overwriting x on v. * CALL DLATRS( 'Upper', TRANS, 'Nonunit', NORMIN, N, B, LDB, $ VR, SCALE, WORK, IERR ) NORMIN = 'Y' * * Test for sufficient growth in the norm of v. * VNORM = DASUM( N, VR, 1 ) IF( VNORM.GE.GROWTO*SCALE ) $ GO TO 120 * * Choose new orthogonal starting vector and try again. * TEMP = EPS3 / ( ROOTN+ONE ) VR( 1 ) = EPS3 DO 100 I = 2, N VR( I ) = TEMP 100 CONTINUE VR( N-ITS+1 ) = VR( N-ITS+1 ) - EPS3*ROOTN 110 CONTINUE * * Failure to find eigenvector in N iterations. * INFO = 1 * 120 CONTINUE * * Normalize eigenvector. * I = IDAMAX( N, VR, 1 ) CALL DSCAL( N, ONE / ABS( VR( I ) ), VR, 1 ) ELSE * * Complex eigenvalue. * IF( NOINIT ) THEN * * Set initial vector. * DO 130 I = 1, N VR( I ) = EPS3 VI( I ) = ZERO 130 CONTINUE ELSE * * Scale supplied initial vector. * NORM = DLAPY2( DNRM2( N, VR, 1 ), DNRM2( N, VI, 1 ) ) REC = ( EPS3*ROOTN ) / MAX( NORM, NRMSML ) CALL DSCAL( N, REC, VR, 1 ) CALL DSCAL( N, REC, VI, 1 ) END IF * IF( RIGHTV ) THEN * * LU decomposition with partial pivoting of B, replacing zero * pivots by EPS3. * * The imaginary part of the (i,j)-th element of U is stored in * B(j+1,i). * B( 2, 1 ) = -WI DO 140 I = 2, N B( I+1, 1 ) = ZERO 140 CONTINUE * DO 170 I = 1, N - 1 ABSBII = DLAPY2( B( I, I ), B( I+1, I ) ) EI = H( I+1, I ) IF( ABSBII.LT.ABS( EI ) ) THEN * * Interchange rows and eliminate. * XR = B( I, I ) / EI XI = B( I+1, I ) / EI B( I, I ) = EI B( I+1, I ) = ZERO DO 150 J = I + 1, N TEMP = B( I+1, J ) B( I+1, J ) = B( I, J ) - XR*TEMP B( J+1, I+1 ) = B( J+1, I ) - XI*TEMP B( I, J ) = TEMP B( J+1, I ) = ZERO 150 CONTINUE B( I+2, I ) = -WI B( I+1, I+1 ) = B( I+1, I+1 ) - XI*WI B( I+2, I+1 ) = B( I+2, I+1 ) + XR*WI ELSE * * Eliminate without interchanging rows. * IF( ABSBII.EQ.ZERO ) THEN B( I, I ) = EPS3 B( I+1, I ) = ZERO ABSBII = EPS3 END IF EI = ( EI / ABSBII ) / ABSBII XR = B( I, I )*EI XI = -B( I+1, I )*EI DO 160 J = I + 1, N B( I+1, J ) = B( I+1, J ) - XR*B( I, J ) + $ XI*B( J+1, I ) B( J+1, I+1 ) = -XR*B( J+1, I ) - XI*B( I, J ) 160 CONTINUE B( I+2, I+1 ) = B( I+2, I+1 ) - WI END IF * * Compute 1-norm of offdiagonal elements of i-th row. * WORK( I ) = DASUM( N-I, B( I, I+1 ), LDB ) + $ DASUM( N-I, B( I+2, I ), 1 ) 170 CONTINUE IF( B( N, N ).EQ.ZERO .AND. B( N+1, N ).EQ.ZERO ) $ B( N, N ) = EPS3 WORK( N ) = ZERO * I1 = N I2 = 1 I3 = -1 ELSE * * UL decomposition with partial pivoting of conjg(B), * replacing zero pivots by EPS3. * * The imaginary part of the (i,j)-th element of U is stored in * B(j+1,i). * B( N+1, N ) = WI DO 180 J = 1, N - 1 B( N+1, J ) = ZERO 180 CONTINUE * DO 210 J = N, 2, -1 EJ = H( J, J-1 ) ABSBJJ = DLAPY2( B( J, J ), B( J+1, J ) ) IF( ABSBJJ.LT.ABS( EJ ) ) THEN * * Interchange columns and eliminate * XR = B( J, J ) / EJ XI = B( J+1, J ) / EJ B( J, J ) = EJ B( J+1, J ) = ZERO DO 190 I = 1, J - 1 TEMP = B( I, J-1 ) B( I, J-1 ) = B( I, J ) - XR*TEMP B( J, I ) = B( J+1, I ) - XI*TEMP B( I, J ) = TEMP B( J+1, I ) = ZERO 190 CONTINUE B( J+1, J-1 ) = WI B( J-1, J-1 ) = B( J-1, J-1 ) + XI*WI B( J, J-1 ) = B( J, J-1 ) - XR*WI ELSE * * Eliminate without interchange. * IF( ABSBJJ.EQ.ZERO ) THEN B( J, J ) = EPS3 B( J+1, J ) = ZERO ABSBJJ = EPS3 END IF EJ = ( EJ / ABSBJJ ) / ABSBJJ XR = B( J, J )*EJ XI = -B( J+1, J )*EJ DO 200 I = 1, J - 1 B( I, J-1 ) = B( I, J-1 ) - XR*B( I, J ) + $ XI*B( J+1, I ) B( J, I ) = -XR*B( J+1, I ) - XI*B( I, J ) 200 CONTINUE B( J, J-1 ) = B( J, J-1 ) + WI END IF * * Compute 1-norm of offdiagonal elements of j-th column. * WORK( J ) = DASUM( J-1, B( 1, J ), 1 ) + $ DASUM( J-1, B( J+1, 1 ), LDB ) 210 CONTINUE IF( B( 1, 1 ).EQ.ZERO .AND. B( 2, 1 ).EQ.ZERO ) $ B( 1, 1 ) = EPS3 WORK( 1 ) = ZERO * I1 = 1 I2 = N I3 = 1 END IF * DO 270 ITS = 1, N SCALE = ONE VMAX = ONE VCRIT = BIGNUM * * Solve U*(xr,xi) = scale*(vr,vi) for a right eigenvector, * or U**T*(xr,xi) = scale*(vr,vi) for a left eigenvector, * overwriting (xr,xi) on (vr,vi). * DO 250 I = I1, I2, I3 * IF( WORK( I ).GT.VCRIT ) THEN REC = ONE / VMAX CALL DSCAL( N, REC, VR, 1 ) CALL DSCAL( N, REC, VI, 1 ) SCALE = SCALE*REC VMAX = ONE VCRIT = BIGNUM END IF * XR = VR( I ) XI = VI( I ) IF( RIGHTV ) THEN DO 220 J = I + 1, N XR = XR - B( I, J )*VR( J ) + B( J+1, I )*VI( J ) XI = XI - B( I, J )*VI( J ) - B( J+1, I )*VR( J ) 220 CONTINUE ELSE DO 230 J = 1, I - 1 XR = XR - B( J, I )*VR( J ) + B( I+1, J )*VI( J ) XI = XI - B( J, I )*VI( J ) - B( I+1, J )*VR( J ) 230 CONTINUE END IF * W = ABS( B( I, I ) ) + ABS( B( I+1, I ) ) IF( W.GT.SMLNUM ) THEN IF( W.LT.ONE ) THEN W1 = ABS( XR ) + ABS( XI ) IF( W1.GT.W*BIGNUM ) THEN REC = ONE / W1 CALL DSCAL( N, REC, VR, 1 ) CALL DSCAL( N, REC, VI, 1 ) XR = VR( I ) XI = VI( I ) SCALE = SCALE*REC VMAX = VMAX*REC END IF END IF * * Divide by diagonal element of B. * CALL DLADIV( XR, XI, B( I, I ), B( I+1, I ), VR( I ), $ VI( I ) ) VMAX = MAX( ABS( VR( I ) )+ABS( VI( I ) ), VMAX ) VCRIT = BIGNUM / VMAX ELSE DO 240 J = 1, N VR( J ) = ZERO VI( J ) = ZERO 240 CONTINUE VR( I ) = ONE VI( I ) = ONE SCALE = ZERO VMAX = ONE VCRIT = BIGNUM END IF 250 CONTINUE * * Test for sufficient growth in the norm of (VR,VI). * VNORM = DASUM( N, VR, 1 ) + DASUM( N, VI, 1 ) IF( VNORM.GE.GROWTO*SCALE ) $ GO TO 280 * * Choose a new orthogonal starting vector and try again. * Y = EPS3 / ( ROOTN+ONE ) VR( 1 ) = EPS3 VI( 1 ) = ZERO * DO 260 I = 2, N VR( I ) = Y VI( I ) = ZERO 260 CONTINUE VR( N-ITS+1 ) = VR( N-ITS+1 ) - EPS3*ROOTN 270 CONTINUE * * Failure to find eigenvector in N iterations * INFO = 1 * 280 CONTINUE * * Normalize eigenvector. * VNORM = ZERO DO 290 I = 1, N VNORM = MAX( VNORM, ABS( VR( I ) )+ABS( VI( I ) ) ) 290 CONTINUE CALL DSCAL( N, ONE / VNORM, VR, 1 ) CALL DSCAL( N, ONE / VNORM, VI, 1 ) * END IF * RETURN * * End of DLAEIN * END *> \brief \b DLAEV2 computes the eigenvalues and eigenvectors of a 2-by-2 symmetric/Hermitian matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAEV2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) * * .. Scalar Arguments .. * DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1 * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix *> [ A B ] *> [ B C ]. *> On return, RT1 is the eigenvalue of larger absolute value, RT2 is the *> eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right *> eigenvector for RT1, giving the decomposition *> *> [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ] *> [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]. *> \endverbatim * * Arguments: * ========== * *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION *> The (1,1) element of the 2-by-2 matrix. *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION *> The (1,2) element and the conjugate of the (2,1) element of *> the 2-by-2 matrix. *> \endverbatim *> *> \param[in] C *> \verbatim *> C is DOUBLE PRECISION *> The (2,2) element of the 2-by-2 matrix. *> \endverbatim *> *> \param[out] RT1 *> \verbatim *> RT1 is DOUBLE PRECISION *> The eigenvalue of larger absolute value. *> \endverbatim *> *> \param[out] RT2 *> \verbatim *> RT2 is DOUBLE PRECISION *> The eigenvalue of smaller absolute value. *> \endverbatim *> *> \param[out] CS1 *> \verbatim *> CS1 is DOUBLE PRECISION *> \endverbatim *> *> \param[out] SN1 *> \verbatim *> SN1 is DOUBLE PRECISION *> The vector (CS1, SN1) is a unit right eigenvector for RT1. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> RT1 is accurate to a few ulps barring over/underflow. *> *> RT2 may be inaccurate if there is massive cancellation in the *> determinant A*C-B*B; higher precision or correctly rounded or *> correctly truncated arithmetic would be needed to compute RT2 *> accurately in all cases. *> *> CS1 and SN1 are accurate to a few ulps barring over/underflow. *> *> Overflow is possible only if RT1 is within a factor of 5 of overflow. *> Underflow is harmless if the input data is 0 or exceeds *> underflow_threshold / macheps. *> \endverbatim *> * ===================================================================== SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1 * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D0 ) DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION HALF PARAMETER ( HALF = 0.5D0 ) * .. * .. Local Scalars .. INTEGER SGN1, SGN2 DOUBLE PRECISION AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM, $ TB, TN * .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT * .. * .. Executable Statements .. * * Compute the eigenvalues * SM = A + C DF = A - C ADF = ABS( DF ) TB = B + B AB = ABS( TB ) IF( ABS( A ).GT.ABS( C ) ) THEN ACMX = A ACMN = C ELSE ACMX = C ACMN = A END IF IF( ADF.GT.AB ) THEN RT = ADF*SQRT( ONE+( AB / ADF )**2 ) ELSE IF( ADF.LT.AB ) THEN RT = AB*SQRT( ONE+( ADF / AB )**2 ) ELSE * * Includes case AB=ADF=0 * RT = AB*SQRT( TWO ) END IF IF( SM.LT.ZERO ) THEN RT1 = HALF*( SM-RT ) SGN1 = -1 * * Order of execution important. * To get fully accurate smaller eigenvalue, * next line needs to be executed in higher precision. * RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B ELSE IF( SM.GT.ZERO ) THEN RT1 = HALF*( SM+RT ) SGN1 = 1 * * Order of execution important. * To get fully accurate smaller eigenvalue, * next line needs to be executed in higher precision. * RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B ELSE * * Includes case RT1 = RT2 = 0 * RT1 = HALF*RT RT2 = -HALF*RT SGN1 = 1 END IF * * Compute the eigenvector * IF( DF.GE.ZERO ) THEN CS = DF + RT SGN2 = 1 ELSE CS = DF - RT SGN2 = -1 END IF ACS = ABS( CS ) IF( ACS.GT.AB ) THEN CT = -TB / CS SN1 = ONE / SQRT( ONE+CT*CT ) CS1 = CT*SN1 ELSE IF( AB.EQ.ZERO ) THEN CS1 = ONE SN1 = ZERO ELSE TN = -CS / TB CS1 = ONE / SQRT( ONE+TN*TN ) SN1 = TN*CS1 END IF END IF IF( SGN1.EQ.SGN2 ) THEN TN = CS1 CS1 = -SN1 SN1 = TN END IF RETURN * * End of DLAEV2 * END *> \brief \b DLAEXC swaps adjacent diagonal blocks of a real upper quasi-triangular matrix in Schur canonical form, by an orthogonal similarity transformation. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAEXC + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, * INFO ) * * .. Scalar Arguments .. * LOGICAL WANTQ * INTEGER INFO, J1, LDQ, LDT, N, N1, N2 * .. * .. Array Arguments .. * DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in *> an upper quasi-triangular matrix T by an orthogonal similarity *> transformation. *> *> T must be in Schur canonical form, that is, block upper triangular *> with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block *> has its diagonal elemnts equal and its off-diagonal elements of *> opposite sign. *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTQ *> \verbatim *> WANTQ is LOGICAL *> = .TRUE. : accumulate the transformation in the matrix Q; *> = .FALSE.: do not accumulate the transformation. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix T. N >= 0. *> \endverbatim *> *> \param[in,out] T *> \verbatim *> T is DOUBLE PRECISION array, dimension (LDT,N) *> On entry, the upper quasi-triangular matrix T, in Schur *> canonical form. *> On exit, the updated matrix T, again in Schur canonical form. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= max(1,N). *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is DOUBLE PRECISION array, dimension (LDQ,N) *> On entry, if WANTQ is .TRUE., the orthogonal matrix Q. *> On exit, if WANTQ is .TRUE., the updated matrix Q. *> If WANTQ is .FALSE., Q is not referenced. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. *> LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N. *> \endverbatim *> *> \param[in] J1 *> \verbatim *> J1 is INTEGER *> The index of the first row of the first block T11. *> \endverbatim *> *> \param[in] N1 *> \verbatim *> N1 is INTEGER *> The order of the first block T11. N1 = 0, 1 or 2. *> \endverbatim *> *> \param[in] N2 *> \verbatim *> N2 is INTEGER *> The order of the second block T22. N2 = 0, 1 or 2. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> = 1: the transformed matrix T would be too far from Schur *> form; the blocks are not swapped and T and Q are *> unchanged. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, $ INFO ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. LOGICAL WANTQ INTEGER INFO, J1, LDQ, LDT, N, N1, N2 * .. * .. Array Arguments .. DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION TEN PARAMETER ( TEN = 1.0D+1 ) INTEGER LDD, LDX PARAMETER ( LDD = 4, LDX = 2 ) * .. * .. Local Scalars .. INTEGER IERR, J2, J3, J4, K, ND DOUBLE PRECISION CS, DNORM, EPS, SCALE, SMLNUM, SN, T11, T22, $ T33, TAU, TAU1, TAU2, TEMP, THRESH, WI1, WI2, $ WR1, WR2, XNORM * .. * .. Local Arrays .. DOUBLE PRECISION D( LDD, 4 ), U( 3 ), U1( 3 ), U2( 3 ), $ X( LDX, 2 ) * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE * .. * .. External Subroutines .. EXTERNAL DLACPY, DLANV2, DLARFG, DLARFX, DLARTG, DLASY2, $ DROT * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.EQ.0 .OR. N1.EQ.0 .OR. N2.EQ.0 ) $ RETURN IF( J1+N1.GT.N ) $ RETURN * J2 = J1 + 1 J3 = J1 + 2 J4 = J1 + 3 * IF( N1.EQ.1 .AND. N2.EQ.1 ) THEN * * Swap two 1-by-1 blocks. * T11 = T( J1, J1 ) T22 = T( J2, J2 ) * * Determine the transformation to perform the interchange. * CALL DLARTG( T( J1, J2 ), T22-T11, CS, SN, TEMP ) * * Apply transformation to the matrix T. * IF( J3.LE.N ) $ CALL DROT( N-J1-1, T( J1, J3 ), LDT, T( J2, J3 ), LDT, CS, $ SN ) CALL DROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN ) * T( J1, J1 ) = T22 T( J2, J2 ) = T11 * IF( WANTQ ) THEN * * Accumulate transformation in the matrix Q. * CALL DROT( N, Q( 1, J1 ), 1, Q( 1, J2 ), 1, CS, SN ) END IF * ELSE * * Swapping involves at least one 2-by-2 block. * * Copy the diagonal block of order N1+N2 to the local array D * and compute its norm. * ND = N1 + N2 CALL DLACPY( 'Full', ND, ND, T( J1, J1 ), LDT, D, LDD ) DNORM = DLANGE( 'Max', ND, ND, D, LDD, WORK ) * * Compute machine-dependent threshold for test for accepting * swap. * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) / EPS THRESH = MAX( TEN*EPS*DNORM, SMLNUM ) * * Solve T11*X - X*T22 = scale*T12 for X. * CALL DLASY2( .FALSE., .FALSE., -1, N1, N2, D, LDD, $ D( N1+1, N1+1 ), LDD, D( 1, N1+1 ), LDD, SCALE, X, $ LDX, XNORM, IERR ) * * Swap the adjacent diagonal blocks. * K = N1 + N1 + N2 - 3 GO TO ( 10, 20, 30 )K * 10 CONTINUE * * N1 = 1, N2 = 2: generate elementary reflector H so that: * * ( scale, X11, X12 ) H = ( 0, 0, * ) * U( 1 ) = SCALE U( 2 ) = X( 1, 1 ) U( 3 ) = X( 1, 2 ) CALL DLARFG( 3, U( 3 ), U, 1, TAU ) U( 3 ) = ONE T11 = T( J1, J1 ) * * Perform swap provisionally on diagonal block in D. * CALL DLARFX( 'L', 3, 3, U, TAU, D, LDD, WORK ) CALL DLARFX( 'R', 3, 3, U, TAU, D, LDD, WORK ) * * Test whether to reject swap. * IF( MAX( ABS( D( 3, 1 ) ), ABS( D( 3, 2 ) ), ABS( D( 3, $ 3 )-T11 ) ).GT.THRESH )GO TO 50 * * Accept swap: apply transformation to the entire matrix T. * CALL DLARFX( 'L', 3, N-J1+1, U, TAU, T( J1, J1 ), LDT, WORK ) CALL DLARFX( 'R', J2, 3, U, TAU, T( 1, J1 ), LDT, WORK ) * T( J3, J1 ) = ZERO T( J3, J2 ) = ZERO T( J3, J3 ) = T11 * IF( WANTQ ) THEN * * Accumulate transformation in the matrix Q. * CALL DLARFX( 'R', N, 3, U, TAU, Q( 1, J1 ), LDQ, WORK ) END IF GO TO 40 * 20 CONTINUE * * N1 = 2, N2 = 1: generate elementary reflector H so that: * * H ( -X11 ) = ( * ) * ( -X21 ) = ( 0 ) * ( scale ) = ( 0 ) * U( 1 ) = -X( 1, 1 ) U( 2 ) = -X( 2, 1 ) U( 3 ) = SCALE CALL DLARFG( 3, U( 1 ), U( 2 ), 1, TAU ) U( 1 ) = ONE T33 = T( J3, J3 ) * * Perform swap provisionally on diagonal block in D. * CALL DLARFX( 'L', 3, 3, U, TAU, D, LDD, WORK ) CALL DLARFX( 'R', 3, 3, U, TAU, D, LDD, WORK ) * * Test whether to reject swap. * IF( MAX( ABS( D( 2, 1 ) ), ABS( D( 3, 1 ) ), ABS( D( 1, $ 1 )-T33 ) ).GT.THRESH )GO TO 50 * * Accept swap: apply transformation to the entire matrix T. * CALL DLARFX( 'R', J3, 3, U, TAU, T( 1, J1 ), LDT, WORK ) CALL DLARFX( 'L', 3, N-J1, U, TAU, T( J1, J2 ), LDT, WORK ) * T( J1, J1 ) = T33 T( J2, J1 ) = ZERO T( J3, J1 ) = ZERO * IF( WANTQ ) THEN * * Accumulate transformation in the matrix Q. * CALL DLARFX( 'R', N, 3, U, TAU, Q( 1, J1 ), LDQ, WORK ) END IF GO TO 40 * 30 CONTINUE * * N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so * that: * * H(2) H(1) ( -X11 -X12 ) = ( * * ) * ( -X21 -X22 ) ( 0 * ) * ( scale 0 ) ( 0 0 ) * ( 0 scale ) ( 0 0 ) * U1( 1 ) = -X( 1, 1 ) U1( 2 ) = -X( 2, 1 ) U1( 3 ) = SCALE CALL DLARFG( 3, U1( 1 ), U1( 2 ), 1, TAU1 ) U1( 1 ) = ONE * TEMP = -TAU1*( X( 1, 2 )+U1( 2 )*X( 2, 2 ) ) U2( 1 ) = -TEMP*U1( 2 ) - X( 2, 2 ) U2( 2 ) = -TEMP*U1( 3 ) U2( 3 ) = SCALE CALL DLARFG( 3, U2( 1 ), U2( 2 ), 1, TAU2 ) U2( 1 ) = ONE * * Perform swap provisionally on diagonal block in D. * CALL DLARFX( 'L', 3, 4, U1, TAU1, D, LDD, WORK ) CALL DLARFX( 'R', 4, 3, U1, TAU1, D, LDD, WORK ) CALL DLARFX( 'L', 3, 4, U2, TAU2, D( 2, 1 ), LDD, WORK ) CALL DLARFX( 'R', 4, 3, U2, TAU2, D( 1, 2 ), LDD, WORK ) * * Test whether to reject swap. * IF( MAX( ABS( D( 3, 1 ) ), ABS( D( 3, 2 ) ), ABS( D( 4, 1 ) ), $ ABS( D( 4, 2 ) ) ).GT.THRESH )GO TO 50 * * Accept swap: apply transformation to the entire matrix T. * CALL DLARFX( 'L', 3, N-J1+1, U1, TAU1, T( J1, J1 ), LDT, WORK ) CALL DLARFX( 'R', J4, 3, U1, TAU1, T( 1, J1 ), LDT, WORK ) CALL DLARFX( 'L', 3, N-J1+1, U2, TAU2, T( J2, J1 ), LDT, WORK ) CALL DLARFX( 'R', J4, 3, U2, TAU2, T( 1, J2 ), LDT, WORK ) * T( J3, J1 ) = ZERO T( J3, J2 ) = ZERO T( J4, J1 ) = ZERO T( J4, J2 ) = ZERO * IF( WANTQ ) THEN * * Accumulate transformation in the matrix Q. * CALL DLARFX( 'R', N, 3, U1, TAU1, Q( 1, J1 ), LDQ, WORK ) CALL DLARFX( 'R', N, 3, U2, TAU2, Q( 1, J2 ), LDQ, WORK ) END IF * 40 CONTINUE * IF( N2.EQ.2 ) THEN * * Standardize new 2-by-2 block T11 * CALL DLANV2( T( J1, J1 ), T( J1, J2 ), T( J2, J1 ), $ T( J2, J2 ), WR1, WI1, WR2, WI2, CS, SN ) CALL DROT( N-J1-1, T( J1, J1+2 ), LDT, T( J2, J1+2 ), LDT, $ CS, SN ) CALL DROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN ) IF( WANTQ ) $ CALL DROT( N, Q( 1, J1 ), 1, Q( 1, J2 ), 1, CS, SN ) END IF * IF( N1.EQ.2 ) THEN * * Standardize new 2-by-2 block T22 * J3 = J1 + N2 J4 = J3 + 1 CALL DLANV2( T( J3, J3 ), T( J3, J4 ), T( J4, J3 ), $ T( J4, J4 ), WR1, WI1, WR2, WI2, CS, SN ) IF( J3+2.LE.N ) $ CALL DROT( N-J3-1, T( J3, J3+2 ), LDT, T( J4, J3+2 ), $ LDT, CS, SN ) CALL DROT( J3-1, T( 1, J3 ), 1, T( 1, J4 ), 1, CS, SN ) IF( WANTQ ) $ CALL DROT( N, Q( 1, J3 ), 1, Q( 1, J4 ), 1, CS, SN ) END IF * END IF RETURN * * Exit with INFO = 1 if swap was rejected. * 50 CONTINUE INFO = 1 RETURN * * End of DLAEXC * END *> \brief \b DLAG2 computes the eigenvalues of a 2-by-2 generalized eigenvalue problem, with scaling as necessary to avoid over-/underflow. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAG2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, * WR2, WI ) * * .. Scalar Arguments .. * INTEGER LDA, LDB * DOUBLE PRECISION SAFMIN, SCALE1, SCALE2, WI, WR1, WR2 * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAG2 computes the eigenvalues of a 2 x 2 generalized eigenvalue *> problem A - w B, with scaling as necessary to avoid over-/underflow. *> *> The scaling factor "s" results in a modified eigenvalue equation *> *> s A - w B *> *> where s is a non-negative scaling factor chosen so that w, w B, *> and s A do not overflow and, if possible, do not underflow, either. *> \endverbatim * * Arguments: * ========== * *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA, 2) *> On entry, the 2 x 2 matrix A. It is assumed that its 1-norm *> is less than 1/SAFMIN. Entries less than *> sqrt(SAFMIN)*norm(A) are subject to being treated as zero. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= 2. *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB, 2) *> On entry, the 2 x 2 upper triangular matrix B. It is *> assumed that the one-norm of B is less than 1/SAFMIN. The *> diagonals should be at least sqrt(SAFMIN) times the largest *> element of B (in absolute value); if a diagonal is smaller *> than that, then +/- sqrt(SAFMIN) will be used instead of *> that diagonal. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= 2. *> \endverbatim *> *> \param[in] SAFMIN *> \verbatim *> SAFMIN is DOUBLE PRECISION *> The smallest positive number s.t. 1/SAFMIN does not *> overflow. (This should always be DLAMCH('S') -- it is an *> argument in order to avoid having to call DLAMCH frequently.) *> \endverbatim *> *> \param[out] SCALE1 *> \verbatim *> SCALE1 is DOUBLE PRECISION *> A scaling factor used to avoid over-/underflow in the *> eigenvalue equation which defines the first eigenvalue. If *> the eigenvalues are complex, then the eigenvalues are *> ( WR1 +/- WI i ) / SCALE1 (which may lie outside the *> exponent range of the machine), SCALE1=SCALE2, and SCALE1 *> will always be positive. If the eigenvalues are real, then *> the first (real) eigenvalue is WR1 / SCALE1 , but this may *> overflow or underflow, and in fact, SCALE1 may be zero or *> less than the underflow threshold if the exact eigenvalue *> is sufficiently large. *> \endverbatim *> *> \param[out] SCALE2 *> \verbatim *> SCALE2 is DOUBLE PRECISION *> A scaling factor used to avoid over-/underflow in the *> eigenvalue equation which defines the second eigenvalue. If *> the eigenvalues are complex, then SCALE2=SCALE1. If the *> eigenvalues are real, then the second (real) eigenvalue is *> WR2 / SCALE2 , but this may overflow or underflow, and in *> fact, SCALE2 may be zero or less than the underflow *> threshold if the exact eigenvalue is sufficiently large. *> \endverbatim *> *> \param[out] WR1 *> \verbatim *> WR1 is DOUBLE PRECISION *> If the eigenvalue is real, then WR1 is SCALE1 times the *> eigenvalue closest to the (2,2) element of A B**(-1). If the *> eigenvalue is complex, then WR1=WR2 is SCALE1 times the real *> part of the eigenvalues. *> \endverbatim *> *> \param[out] WR2 *> \verbatim *> WR2 is DOUBLE PRECISION *> If the eigenvalue is real, then WR2 is SCALE2 times the *> other eigenvalue. If the eigenvalue is complex, then *> WR1=WR2 is SCALE1 times the real part of the eigenvalues. *> \endverbatim *> *> \param[out] WI *> \verbatim *> WI is DOUBLE PRECISION *> If the eigenvalue is real, then WI is zero. If the *> eigenvalue is complex, then WI is SCALE1 times the imaginary *> part of the eigenvalues. WI will always be non-negative. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, $ WR2, WI ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB DOUBLE PRECISION SAFMIN, SCALE1, SCALE2, WI, WR1, WR2 * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) DOUBLE PRECISION HALF PARAMETER ( HALF = ONE / TWO ) DOUBLE PRECISION FUZZY1 PARAMETER ( FUZZY1 = ONE+1.0D-5 ) * .. * .. Local Scalars .. DOUBLE PRECISION A11, A12, A21, A22, ABI22, ANORM, AS11, AS12, $ AS22, ASCALE, B11, B12, B22, BINV11, BINV22, $ BMIN, BNORM, BSCALE, BSIZE, C1, C2, C3, C4, C5, $ DIFF, DISCR, PP, QQ, R, RTMAX, RTMIN, S1, S2, $ SAFMAX, SHIFT, SS, SUM, WABS, WBIG, WDET, $ WSCALE, WSIZE, WSMALL * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SIGN, SQRT * .. * .. Executable Statements .. * RTMIN = SQRT( SAFMIN ) RTMAX = ONE / RTMIN SAFMAX = ONE / SAFMIN * * Scale A * ANORM = MAX( ABS( A( 1, 1 ) )+ABS( A( 2, 1 ) ), $ ABS( A( 1, 2 ) )+ABS( A( 2, 2 ) ), SAFMIN ) ASCALE = ONE / ANORM A11 = ASCALE*A( 1, 1 ) A21 = ASCALE*A( 2, 1 ) A12 = ASCALE*A( 1, 2 ) A22 = ASCALE*A( 2, 2 ) * * Perturb B if necessary to insure non-singularity * B11 = B( 1, 1 ) B12 = B( 1, 2 ) B22 = B( 2, 2 ) BMIN = RTMIN*MAX( ABS( B11 ), ABS( B12 ), ABS( B22 ), RTMIN ) IF( ABS( B11 ).LT.BMIN ) $ B11 = SIGN( BMIN, B11 ) IF( ABS( B22 ).LT.BMIN ) $ B22 = SIGN( BMIN, B22 ) * * Scale B * BNORM = MAX( ABS( B11 ), ABS( B12 )+ABS( B22 ), SAFMIN ) BSIZE = MAX( ABS( B11 ), ABS( B22 ) ) BSCALE = ONE / BSIZE B11 = B11*BSCALE B12 = B12*BSCALE B22 = B22*BSCALE * * Compute larger eigenvalue by method described by C. van Loan * * ( AS is A shifted by -SHIFT*B ) * BINV11 = ONE / B11 BINV22 = ONE / B22 S1 = A11*BINV11 S2 = A22*BINV22 IF( ABS( S1 ).LE.ABS( S2 ) ) THEN AS12 = A12 - S1*B12 AS22 = A22 - S1*B22 SS = A21*( BINV11*BINV22 ) ABI22 = AS22*BINV22 - SS*B12 PP = HALF*ABI22 SHIFT = S1 ELSE AS12 = A12 - S2*B12 AS11 = A11 - S2*B11 SS = A21*( BINV11*BINV22 ) ABI22 = -SS*B12 PP = HALF*( AS11*BINV11+ABI22 ) SHIFT = S2 END IF QQ = SS*AS12 IF( ABS( PP*RTMIN ).GE.ONE ) THEN DISCR = ( RTMIN*PP )**2 + QQ*SAFMIN R = SQRT( ABS( DISCR ) )*RTMAX ELSE IF( PP**2+ABS( QQ ).LE.SAFMIN ) THEN DISCR = ( RTMAX*PP )**2 + QQ*SAFMAX R = SQRT( ABS( DISCR ) )*RTMIN ELSE DISCR = PP**2 + QQ R = SQRT( ABS( DISCR ) ) END IF END IF * * Note: the test of R in the following IF is to cover the case when * DISCR is small and negative and is flushed to zero during * the calculation of R. On machines which have a consistent * flush-to-zero threshold and handle numbers above that * threshold correctly, it would not be necessary. * IF( DISCR.GE.ZERO .OR. R.EQ.ZERO ) THEN SUM = PP + SIGN( R, PP ) DIFF = PP - SIGN( R, PP ) WBIG = SHIFT + SUM * * Compute smaller eigenvalue * WSMALL = SHIFT + DIFF IF( HALF*ABS( WBIG ).GT.MAX( ABS( WSMALL ), SAFMIN ) ) THEN WDET = ( A11*A22-A12*A21 )*( BINV11*BINV22 ) WSMALL = WDET / WBIG END IF * * Choose (real) eigenvalue closest to 2,2 element of A*B**(-1) * for WR1. * IF( PP.GT.ABI22 ) THEN WR1 = MIN( WBIG, WSMALL ) WR2 = MAX( WBIG, WSMALL ) ELSE WR1 = MAX( WBIG, WSMALL ) WR2 = MIN( WBIG, WSMALL ) END IF WI = ZERO ELSE * * Complex eigenvalues * WR1 = SHIFT + PP WR2 = WR1 WI = R END IF * * Further scaling to avoid underflow and overflow in computing * SCALE1 and overflow in computing w*B. * * This scale factor (WSCALE) is bounded from above using C1 and C2, * and from below using C3 and C4. * C1 implements the condition s A must never overflow. * C2 implements the condition w B must never overflow. * C3, with C2, * implement the condition that s A - w B must never overflow. * C4 implements the condition s should not underflow. * C5 implements the condition max(s,|w|) should be at least 2. * C1 = BSIZE*( SAFMIN*MAX( ONE, ASCALE ) ) C2 = SAFMIN*MAX( ONE, BNORM ) C3 = BSIZE*SAFMIN IF( ASCALE.LE.ONE .AND. BSIZE.LE.ONE ) THEN C4 = MIN( ONE, ( ASCALE / SAFMIN )*BSIZE ) ELSE C4 = ONE END IF IF( ASCALE.LE.ONE .OR. BSIZE.LE.ONE ) THEN C5 = MIN( ONE, ASCALE*BSIZE ) ELSE C5 = ONE END IF * * Scale first eigenvalue * WABS = ABS( WR1 ) + ABS( WI ) WSIZE = MAX( SAFMIN, C1, FUZZY1*( WABS*C2+C3 ), $ MIN( C4, HALF*MAX( WABS, C5 ) ) ) IF( WSIZE.NE.ONE ) THEN WSCALE = ONE / WSIZE IF( WSIZE.GT.ONE ) THEN SCALE1 = ( MAX( ASCALE, BSIZE )*WSCALE )* $ MIN( ASCALE, BSIZE ) ELSE SCALE1 = ( MIN( ASCALE, BSIZE )*WSCALE )* $ MAX( ASCALE, BSIZE ) END IF WR1 = WR1*WSCALE IF( WI.NE.ZERO ) THEN WI = WI*WSCALE WR2 = WR1 SCALE2 = SCALE1 END IF ELSE SCALE1 = ASCALE*BSIZE SCALE2 = SCALE1 END IF * * Scale second eigenvalue (if real) * IF( WI.EQ.ZERO ) THEN WSIZE = MAX( SAFMIN, C1, FUZZY1*( ABS( WR2 )*C2+C3 ), $ MIN( C4, HALF*MAX( ABS( WR2 ), C5 ) ) ) IF( WSIZE.NE.ONE ) THEN WSCALE = ONE / WSIZE IF( WSIZE.GT.ONE ) THEN SCALE2 = ( MAX( ASCALE, BSIZE )*WSCALE )* $ MIN( ASCALE, BSIZE ) ELSE SCALE2 = ( MIN( ASCALE, BSIZE )*WSCALE )* $ MAX( ASCALE, BSIZE ) END IF WR2 = WR2*WSCALE ELSE SCALE2 = ASCALE*BSIZE END IF END IF * * End of DLAG2 * RETURN END *> \brief \b DLAGS2 computes 2-by-2 orthogonal matrices U, V, and Q, and applies them to matrices A and B such that the rows of the transformed A and B are parallel. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAGS2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, * SNV, CSQ, SNQ ) * * .. Scalar Arguments .. * LOGICAL UPPER * DOUBLE PRECISION A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, SNQ, * $ SNU, SNV * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such *> that if ( UPPER ) then *> *> U**T *A*Q = U**T *( A1 A2 )*Q = ( x 0 ) *> ( 0 A3 ) ( x x ) *> and *> V**T*B*Q = V**T *( B1 B2 )*Q = ( x 0 ) *> ( 0 B3 ) ( x x ) *> *> or if ( .NOT.UPPER ) then *> *> U**T *A*Q = U**T *( A1 0 )*Q = ( x x ) *> ( A2 A3 ) ( 0 x ) *> and *> V**T*B*Q = V**T*( B1 0 )*Q = ( x x ) *> ( B2 B3 ) ( 0 x ) *> *> The rows of the transformed A and B are parallel, where *> *> U = ( CSU SNU ), V = ( CSV SNV ), Q = ( CSQ SNQ ) *> ( -SNU CSU ) ( -SNV CSV ) ( -SNQ CSQ ) *> *> Z**T denotes the transpose of Z. *> *> \endverbatim * * Arguments: * ========== * *> \param[in] UPPER *> \verbatim *> UPPER is LOGICAL *> = .TRUE.: the input matrices A and B are upper triangular. *> = .FALSE.: the input matrices A and B are lower triangular. *> \endverbatim *> *> \param[in] A1 *> \verbatim *> A1 is DOUBLE PRECISION *> \endverbatim *> *> \param[in] A2 *> \verbatim *> A2 is DOUBLE PRECISION *> \endverbatim *> *> \param[in] A3 *> \verbatim *> A3 is DOUBLE PRECISION *> On entry, A1, A2 and A3 are elements of the input 2-by-2 *> upper (lower) triangular matrix A. *> \endverbatim *> *> \param[in] B1 *> \verbatim *> B1 is DOUBLE PRECISION *> \endverbatim *> *> \param[in] B2 *> \verbatim *> B2 is DOUBLE PRECISION *> \endverbatim *> *> \param[in] B3 *> \verbatim *> B3 is DOUBLE PRECISION *> On entry, B1, B2 and B3 are elements of the input 2-by-2 *> upper (lower) triangular matrix B. *> \endverbatim *> *> \param[out] CSU *> \verbatim *> CSU is DOUBLE PRECISION *> \endverbatim *> *> \param[out] SNU *> \verbatim *> SNU is DOUBLE PRECISION *> The desired orthogonal matrix U. *> \endverbatim *> *> \param[out] CSV *> \verbatim *> CSV is DOUBLE PRECISION *> \endverbatim *> *> \param[out] SNV *> \verbatim *> SNV is DOUBLE PRECISION *> The desired orthogonal matrix V. *> \endverbatim *> *> \param[out] CSQ *> \verbatim *> CSQ is DOUBLE PRECISION *> \endverbatim *> *> \param[out] SNQ *> \verbatim *> SNQ is DOUBLE PRECISION *> The desired orthogonal matrix Q. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, $ SNV, CSQ, SNQ ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. LOGICAL UPPER DOUBLE PRECISION A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, SNQ, $ SNU, SNV * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. DOUBLE PRECISION A, AUA11, AUA12, AUA21, AUA22, AVB11, AVB12, $ AVB21, AVB22, B, C, CSL, CSR, D, R, S1, S2, $ SNL, SNR, UA11, UA11R, UA12, UA21, UA22, UA22R, $ VB11, VB11R, VB12, VB21, VB22, VB22R * .. * .. External Subroutines .. EXTERNAL DLARTG, DLASV2 * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * IF( UPPER ) THEN * * Input matrices A and B are upper triangular matrices * * Form matrix C = A*adj(B) = ( a b ) * ( 0 d ) * A = A1*B3 D = A3*B1 B = A2*B1 - A1*B2 * * The SVD of real 2-by-2 triangular C * * ( CSL -SNL )*( A B )*( CSR SNR ) = ( R 0 ) * ( SNL CSL ) ( 0 D ) ( -SNR CSR ) ( 0 T ) * CALL DLASV2( A, B, D, S1, S2, SNR, CSR, SNL, CSL ) * IF( ABS( CSL ).GE.ABS( SNL ) .OR. ABS( CSR ).GE.ABS( SNR ) ) $ THEN * * Compute the (1,1) and (1,2) elements of U**T *A and V**T *B, * and (1,2) element of |U|**T *|A| and |V|**T *|B|. * UA11R = CSL*A1 UA12 = CSL*A2 + SNL*A3 * VB11R = CSR*B1 VB12 = CSR*B2 + SNR*B3 * AUA12 = ABS( CSL )*ABS( A2 ) + ABS( SNL )*ABS( A3 ) AVB12 = ABS( CSR )*ABS( B2 ) + ABS( SNR )*ABS( B3 ) * * zero (1,2) elements of U**T *A and V**T *B * IF( ( ABS( UA11R )+ABS( UA12 ) ).NE.ZERO ) THEN IF( AUA12 / ( ABS( UA11R )+ABS( UA12 ) ).LE.AVB12 / $ ( ABS( VB11R )+ABS( VB12 ) ) ) THEN CALL DLARTG( -UA11R, UA12, CSQ, SNQ, R ) ELSE CALL DLARTG( -VB11R, VB12, CSQ, SNQ, R ) END IF ELSE CALL DLARTG( -VB11R, VB12, CSQ, SNQ, R ) END IF * CSU = CSL SNU = -SNL CSV = CSR SNV = -SNR * ELSE * * Compute the (2,1) and (2,2) elements of U**T *A and V**T *B, * and (2,2) element of |U|**T *|A| and |V|**T *|B|. * UA21 = -SNL*A1 UA22 = -SNL*A2 + CSL*A3 * VB21 = -SNR*B1 VB22 = -SNR*B2 + CSR*B3 * AUA22 = ABS( SNL )*ABS( A2 ) + ABS( CSL )*ABS( A3 ) AVB22 = ABS( SNR )*ABS( B2 ) + ABS( CSR )*ABS( B3 ) * * zero (2,2) elements of U**T*A and V**T*B, and then swap. * IF( ( ABS( UA21 )+ABS( UA22 ) ).NE.ZERO ) THEN IF( AUA22 / ( ABS( UA21 )+ABS( UA22 ) ).LE.AVB22 / $ ( ABS( VB21 )+ABS( VB22 ) ) ) THEN CALL DLARTG( -UA21, UA22, CSQ, SNQ, R ) ELSE CALL DLARTG( -VB21, VB22, CSQ, SNQ, R ) END IF ELSE CALL DLARTG( -VB21, VB22, CSQ, SNQ, R ) END IF * CSU = SNL SNU = CSL CSV = SNR SNV = CSR * END IF * ELSE * * Input matrices A and B are lower triangular matrices * * Form matrix C = A*adj(B) = ( a 0 ) * ( c d ) * A = A1*B3 D = A3*B1 C = A2*B3 - A3*B2 * * The SVD of real 2-by-2 triangular C * * ( CSL -SNL )*( A 0 )*( CSR SNR ) = ( R 0 ) * ( SNL CSL ) ( C D ) ( -SNR CSR ) ( 0 T ) * CALL DLASV2( A, C, D, S1, S2, SNR, CSR, SNL, CSL ) * IF( ABS( CSR ).GE.ABS( SNR ) .OR. ABS( CSL ).GE.ABS( SNL ) ) $ THEN * * Compute the (2,1) and (2,2) elements of U**T *A and V**T *B, * and (2,1) element of |U|**T *|A| and |V|**T *|B|. * UA21 = -SNR*A1 + CSR*A2 UA22R = CSR*A3 * VB21 = -SNL*B1 + CSL*B2 VB22R = CSL*B3 * AUA21 = ABS( SNR )*ABS( A1 ) + ABS( CSR )*ABS( A2 ) AVB21 = ABS( SNL )*ABS( B1 ) + ABS( CSL )*ABS( B2 ) * * zero (2,1) elements of U**T *A and V**T *B. * IF( ( ABS( UA21 )+ABS( UA22R ) ).NE.ZERO ) THEN IF( AUA21 / ( ABS( UA21 )+ABS( UA22R ) ).LE.AVB21 / $ ( ABS( VB21 )+ABS( VB22R ) ) ) THEN CALL DLARTG( UA22R, UA21, CSQ, SNQ, R ) ELSE CALL DLARTG( VB22R, VB21, CSQ, SNQ, R ) END IF ELSE CALL DLARTG( VB22R, VB21, CSQ, SNQ, R ) END IF * CSU = CSR SNU = -SNR CSV = CSL SNV = -SNL * ELSE * * Compute the (1,1) and (1,2) elements of U**T *A and V**T *B, * and (1,1) element of |U|**T *|A| and |V|**T *|B|. * UA11 = CSR*A1 + SNR*A2 UA12 = SNR*A3 * VB11 = CSL*B1 + SNL*B2 VB12 = SNL*B3 * AUA11 = ABS( CSR )*ABS( A1 ) + ABS( SNR )*ABS( A2 ) AVB11 = ABS( CSL )*ABS( B1 ) + ABS( SNL )*ABS( B2 ) * * zero (1,1) elements of U**T*A and V**T*B, and then swap. * IF( ( ABS( UA11 )+ABS( UA12 ) ).NE.ZERO ) THEN IF( AUA11 / ( ABS( UA11 )+ABS( UA12 ) ).LE.AVB11 / $ ( ABS( VB11 )+ABS( VB12 ) ) ) THEN CALL DLARTG( UA12, UA11, CSQ, SNQ, R ) ELSE CALL DLARTG( VB12, VB11, CSQ, SNQ, R ) END IF ELSE CALL DLARTG( VB12, VB11, CSQ, SNQ, R ) END IF * CSU = SNR SNU = CSR CSV = SNL SNV = CSL * END IF * END IF * RETURN * * End of DLAGS2 * END *> \brief \b DLAGTF computes an LU factorization of a matrix T-λI, where T is a general tridiagonal matrix, and λ a scalar, using partial pivoting with row interchanges. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAGTF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, N * DOUBLE PRECISION LAMBDA, TOL * .. * .. Array Arguments .. * INTEGER IN( * ) * DOUBLE PRECISION A( * ), B( * ), C( * ), D( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix T. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is 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. *> \endverbatim *> *> \param[in] LAMBDA *> \verbatim *> LAMBDA is DOUBLE PRECISION *> On entry, the scalar lambda. *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is 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. *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is 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. *> \endverbatim *> *> \param[in] TOL *> \verbatim *> TOL is 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. *> \endverbatim *> *> \param[out] D *> \verbatim *> D is 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. *> \endverbatim *> *> \param[out] IN *> \verbatim *> IN is 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, *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0 : successful exit *> .lt. 0: if INFO = -k, the kth argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE DLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, N DOUBLE PRECISION LAMBDA, TOL * .. * .. Array Arguments .. INTEGER IN( * ) DOUBLE PRECISION A( * ), B( * ), C( * ), D( * ) * .. * * ===================================================================== * * .. 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 *> \brief \b DLAGTM performs a matrix-matrix product of the form C = αAB+βC, where A is a tridiagonal matrix, B and C are rectangular matrices, and α and β are scalars, which may be 0, 1, or -1. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAGTM + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, * B, LDB ) * * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER LDB, LDX, N, NRHS * DOUBLE PRECISION ALPHA, BETA * .. * .. Array Arguments .. * DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), * $ X( LDX, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAGTM performs a matrix-vector product of the form *> *> B := alpha * A * X + beta * B *> *> where A is a tridiagonal matrix of order N, B and X are N by NRHS *> matrices, and alpha and beta are real scalars, each of which may be *> 0., 1., or -1. *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> Specifies the operation applied to A. *> = 'N': No transpose, B := alpha * A * X + beta * B *> = 'T': Transpose, B := alpha * A'* X + beta * B *> = 'C': Conjugate transpose = Transpose *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrices X and B. *> \endverbatim *> *> \param[in] ALPHA *> \verbatim *> ALPHA is DOUBLE PRECISION *> The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise, *> it is assumed to be 0. *> \endverbatim *> *> \param[in] DL *> \verbatim *> DL is DOUBLE PRECISION array, dimension (N-1) *> The (n-1) sub-diagonal elements of T. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The diagonal elements of T. *> \endverbatim *> *> \param[in] DU *> \verbatim *> DU is DOUBLE PRECISION array, dimension (N-1) *> The (n-1) super-diagonal elements of T. *> \endverbatim *> *> \param[in] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,NRHS) *> The N by NRHS matrix X. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the array X. LDX >= max(N,1). *> \endverbatim *> *> \param[in] BETA *> \verbatim *> BETA is DOUBLE PRECISION *> The scalar beta. BETA must be 0., 1., or -1.; otherwise, *> it is assumed to be 1. *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> On entry, the N by NRHS matrix B. *> On exit, B is overwritten by the matrix expression *> B := alpha * A * X + beta * B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(N,1). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, $ B, LDB ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER TRANS INTEGER LDB, LDX, N, NRHS DOUBLE PRECISION ALPHA, BETA * .. * .. Array Arguments .. DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), $ X( LDX, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Executable Statements .. * IF( N.EQ.0 ) $ RETURN * * Multiply B by BETA if BETA.NE.1. * IF( BETA.EQ.ZERO ) THEN DO 20 J = 1, NRHS DO 10 I = 1, N B( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE IF( BETA.EQ.-ONE ) THEN DO 40 J = 1, NRHS DO 30 I = 1, N B( I, J ) = -B( I, J ) 30 CONTINUE 40 CONTINUE END IF * IF( ALPHA.EQ.ONE ) THEN IF( LSAME( TRANS, 'N' ) ) THEN * * Compute B := B + A*X * DO 60 J = 1, NRHS IF( N.EQ.1 ) THEN B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) ELSE B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) + $ DU( 1 )*X( 2, J ) B( N, J ) = B( N, J ) + DL( N-1 )*X( N-1, J ) + $ D( N )*X( N, J ) DO 50 I = 2, N - 1 B( I, J ) = B( I, J ) + DL( I-1 )*X( I-1, J ) + $ D( I )*X( I, J ) + DU( I )*X( I+1, J ) 50 CONTINUE END IF 60 CONTINUE ELSE * * Compute B := B + A**T*X * DO 80 J = 1, NRHS IF( N.EQ.1 ) THEN B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) ELSE B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) + $ DL( 1 )*X( 2, J ) B( N, J ) = B( N, J ) + DU( N-1 )*X( N-1, J ) + $ D( N )*X( N, J ) DO 70 I = 2, N - 1 B( I, J ) = B( I, J ) + DU( I-1 )*X( I-1, J ) + $ D( I )*X( I, J ) + DL( I )*X( I+1, J ) 70 CONTINUE END IF 80 CONTINUE END IF ELSE IF( ALPHA.EQ.-ONE ) THEN IF( LSAME( TRANS, 'N' ) ) THEN * * Compute B := B - A*X * DO 100 J = 1, NRHS IF( N.EQ.1 ) THEN B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) ELSE B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) - $ DU( 1 )*X( 2, J ) B( N, J ) = B( N, J ) - DL( N-1 )*X( N-1, J ) - $ D( N )*X( N, J ) DO 90 I = 2, N - 1 B( I, J ) = B( I, J ) - DL( I-1 )*X( I-1, J ) - $ D( I )*X( I, J ) - DU( I )*X( I+1, J ) 90 CONTINUE END IF 100 CONTINUE ELSE * * Compute B := B - A**T*X * DO 120 J = 1, NRHS IF( N.EQ.1 ) THEN B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) ELSE B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) - $ DL( 1 )*X( 2, J ) B( N, J ) = B( N, J ) - DU( N-1 )*X( N-1, J ) - $ D( N )*X( N, J ) DO 110 I = 2, N - 1 B( I, J ) = B( I, J ) - DU( I-1 )*X( I-1, J ) - $ D( I )*X( I, J ) - DL( I )*X( I+1, J ) 110 CONTINUE END IF 120 CONTINUE END IF END IF RETURN * * End of DLAGTM * END *> \brief \b DLAGTS solves the system of equations (T-λI)x = y or (T-λI)Tx = y,where T is a general tridiagonal matrix and λ a scalar, using the LU factorization computed by slagtf. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAGTS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, JOB, N * DOUBLE PRECISION TOL * .. * .. Array Arguments .. * INTEGER IN( * ) * DOUBLE PRECISION A( * ), B( * ), C( * ), D( * ), Y( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAGTS may be used to solve one of the systems of equations *> *> (T - lambda*I)*x = y or (T - lambda*I)**T*x = y, *> *> where T is an n by n tridiagonal matrix, for x, following the *> factorization of (T - lambda*I) as *> *> (T - lambda*I) = P*L*U , *> *> by routine DLAGTF. The choice of equation to be solved is *> controlled by the argument JOB, and in each case there is an option *> to perturb zero or very small diagonal elements of U, this option *> being intended for use in applications such as inverse iteration. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is INTEGER *> Specifies the job to be performed by DLAGTS as follows: *> = 1: The equations (T - lambda*I)x = y are to be solved, *> but diagonal elements of U are not to be perturbed. *> = -1: The equations (T - lambda*I)x = y are to be solved *> and, if overflow would otherwise occur, the diagonal *> elements of U are to be perturbed. See argument TOL *> below. *> = 2: The equations (T - lambda*I)**Tx = y are to be solved, *> but diagonal elements of U are not to be perturbed. *> = -2: The equations (T - lambda*I)**Tx = y are to be solved *> and, if overflow would otherwise occur, the diagonal *> elements of U are to be perturbed. See argument TOL *> below. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix T. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (N) *> On entry, A must contain the diagonal elements of U as *> returned from DLAGTF. *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (N-1) *> On entry, B must contain the first super-diagonal elements of *> U as returned from DLAGTF. *> \endverbatim *> *> \param[in] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (N-1) *> On entry, C must contain the sub-diagonal elements of L as *> returned from DLAGTF. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N-2) *> On entry, D must contain the second super-diagonal elements *> of U as returned from DLAGTF. *> \endverbatim *> *> \param[in] IN *> \verbatim *> IN is INTEGER array, dimension (N) *> On entry, IN must contain details of the matrix P as returned *> from DLAGTF. *> \endverbatim *> *> \param[in,out] Y *> \verbatim *> Y is DOUBLE PRECISION array, dimension (N) *> On entry, the right hand side vector y. *> On exit, Y is overwritten by the solution vector x. *> \endverbatim *> *> \param[in,out] TOL *> \verbatim *> TOL is DOUBLE PRECISION *> On entry, with JOB .lt. 0, TOL should be the minimum *> perturbation to be made to very small diagonal elements of U. *> TOL should normally be chosen as about eps*norm(U), where eps *> is the relative machine precision, but if TOL is supplied as *> non-positive, then it is reset to eps*max( abs( u(i,j) ) ). *> If JOB .gt. 0 then TOL is not referenced. *> *> On exit, TOL is changed as described above, only if TOL is *> non-positive on entry. Otherwise TOL is unchanged. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0 : successful exit *> .lt. 0: if INFO = -i, the i-th argument had an illegal value *> .gt. 0: overflow would occur when computing the INFO(th) *> element of the solution vector x. This can only occur *> when JOB is supplied as positive and either means *> that a diagonal element of U is very small, or that *> the elements of the right-hand side vector y are very *> large. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, JOB, N DOUBLE PRECISION TOL * .. * .. Array Arguments .. INTEGER IN( * ) DOUBLE PRECISION A( * ), B( * ), C( * ), D( * ), Y( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER K DOUBLE PRECISION ABSAK, AK, BIGNUM, EPS, PERT, SFMIN, TEMP * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SIGN * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * INFO = 0 IF( ( ABS( JOB ).GT.2 ) .OR. ( JOB.EQ.0 ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLAGTS', -INFO ) RETURN END IF * IF( N.EQ.0 ) $ RETURN * EPS = DLAMCH( 'Epsilon' ) SFMIN = DLAMCH( 'Safe minimum' ) BIGNUM = ONE / SFMIN * IF( JOB.LT.0 ) THEN IF( TOL.LE.ZERO ) THEN TOL = ABS( A( 1 ) ) IF( N.GT.1 ) $ TOL = MAX( TOL, ABS( A( 2 ) ), ABS( B( 1 ) ) ) DO 10 K = 3, N TOL = MAX( TOL, ABS( A( K ) ), ABS( B( K-1 ) ), $ ABS( D( K-2 ) ) ) 10 CONTINUE TOL = TOL*EPS IF( TOL.EQ.ZERO ) $ TOL = EPS END IF END IF * IF( ABS( JOB ).EQ.1 ) THEN DO 20 K = 2, N IF( IN( K-1 ).EQ.0 ) THEN Y( K ) = Y( K ) - C( K-1 )*Y( K-1 ) ELSE TEMP = Y( K-1 ) Y( K-1 ) = Y( K ) Y( K ) = TEMP - C( K-1 )*Y( K ) END IF 20 CONTINUE IF( JOB.EQ.1 ) THEN DO 30 K = N, 1, -1 IF( K.LE.N-2 ) THEN TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 ) ELSE IF( K.EQ.N-1 ) THEN TEMP = Y( K ) - B( K )*Y( K+1 ) ELSE TEMP = Y( K ) END IF AK = A( K ) ABSAK = ABS( AK ) IF( ABSAK.LT.ONE ) THEN IF( ABSAK.LT.SFMIN ) THEN IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) $ THEN INFO = K RETURN ELSE TEMP = TEMP*BIGNUM AK = AK*BIGNUM END IF ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN INFO = K RETURN END IF END IF Y( K ) = TEMP / AK 30 CONTINUE ELSE DO 50 K = N, 1, -1 IF( K.LE.N-2 ) THEN TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 ) ELSE IF( K.EQ.N-1 ) THEN TEMP = Y( K ) - B( K )*Y( K+1 ) ELSE TEMP = Y( K ) END IF AK = A( K ) PERT = SIGN( TOL, AK ) 40 CONTINUE ABSAK = ABS( AK ) IF( ABSAK.LT.ONE ) THEN IF( ABSAK.LT.SFMIN ) THEN IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) $ THEN AK = AK + PERT PERT = 2*PERT GO TO 40 ELSE TEMP = TEMP*BIGNUM AK = AK*BIGNUM END IF ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN AK = AK + PERT PERT = 2*PERT GO TO 40 END IF END IF Y( K ) = TEMP / AK 50 CONTINUE END IF ELSE * * Come to here if JOB = 2 or -2 * IF( JOB.EQ.2 ) THEN DO 60 K = 1, N IF( K.GE.3 ) THEN TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 ) ELSE IF( K.EQ.2 ) THEN TEMP = Y( K ) - B( K-1 )*Y( K-1 ) ELSE TEMP = Y( K ) END IF AK = A( K ) ABSAK = ABS( AK ) IF( ABSAK.LT.ONE ) THEN IF( ABSAK.LT.SFMIN ) THEN IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) $ THEN INFO = K RETURN ELSE TEMP = TEMP*BIGNUM AK = AK*BIGNUM END IF ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN INFO = K RETURN END IF END IF Y( K ) = TEMP / AK 60 CONTINUE ELSE DO 80 K = 1, N IF( K.GE.3 ) THEN TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 ) ELSE IF( K.EQ.2 ) THEN TEMP = Y( K ) - B( K-1 )*Y( K-1 ) ELSE TEMP = Y( K ) END IF AK = A( K ) PERT = SIGN( TOL, AK ) 70 CONTINUE ABSAK = ABS( AK ) IF( ABSAK.LT.ONE ) THEN IF( ABSAK.LT.SFMIN ) THEN IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) $ THEN AK = AK + PERT PERT = 2*PERT GO TO 70 ELSE TEMP = TEMP*BIGNUM AK = AK*BIGNUM END IF ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN AK = AK + PERT PERT = 2*PERT GO TO 70 END IF END IF Y( K ) = TEMP / AK 80 CONTINUE END IF * DO 90 K = N, 2, -1 IF( IN( K-1 ).EQ.0 ) THEN Y( K-1 ) = Y( K-1 ) - C( K-1 )*Y( K ) ELSE TEMP = Y( K-1 ) Y( K-1 ) = Y( K ) Y( K ) = TEMP - C( K-1 )*Y( K ) END IF 90 CONTINUE END IF * * End of DLAGTS * END *> \brief \b DLAGV2 computes the Generalized Schur factorization of a real 2-by-2 matrix pencil (A,B) where B is upper triangular. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAGV2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, * CSR, SNR ) * * .. Scalar Arguments .. * INTEGER LDA, LDB * DOUBLE PRECISION CSL, CSR, SNL, SNR * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), ALPHAI( 2 ), ALPHAR( 2 ), * $ B( LDB, * ), BETA( 2 ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAGV2 computes the Generalized Schur factorization of a real 2-by-2 *> matrix pencil (A,B) where B is upper triangular. This routine *> computes orthogonal (rotation) matrices given by CSL, SNL and CSR, *> SNR such that *> *> 1) if the pencil (A,B) has two real eigenvalues (include 0/0 or 1/0 *> types), then *> *> [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ] *> [ 0 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ] *> *> [ b11 b12 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ] *> [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ], *> *> 2) if the pencil (A,B) has a pair of complex conjugate eigenvalues, *> then *> *> [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ] *> [ a21 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ] *> *> [ b11 0 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ] *> [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ] *> *> where b11 >= b22 > 0. *> *> \endverbatim * * Arguments: * ========== * *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA, 2) *> On entry, the 2 x 2 matrix A. *> On exit, A is overwritten by the ``A-part'' of the *> generalized Schur form. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> THe leading dimension of the array A. LDA >= 2. *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB, 2) *> On entry, the upper triangular 2 x 2 matrix B. *> On exit, B is overwritten by the ``B-part'' of the *> generalized Schur form. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> THe leading dimension of the array B. LDB >= 2. *> \endverbatim *> *> \param[out] ALPHAR *> \verbatim *> ALPHAR is DOUBLE PRECISION array, dimension (2) *> \endverbatim *> *> \param[out] ALPHAI *> \verbatim *> ALPHAI is DOUBLE PRECISION array, dimension (2) *> \endverbatim *> *> \param[out] BETA *> \verbatim *> BETA is DOUBLE PRECISION array, dimension (2) *> (ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the *> pencil (A,B), k=1,2, i = sqrt(-1). Note that BETA(k) may *> be zero. *> \endverbatim *> *> \param[out] CSL *> \verbatim *> CSL is DOUBLE PRECISION *> The cosine of the left rotation matrix. *> \endverbatim *> *> \param[out] SNL *> \verbatim *> SNL is DOUBLE PRECISION *> The sine of the left rotation matrix. *> \endverbatim *> *> \param[out] CSR *> \verbatim *> CSR is DOUBLE PRECISION *> The cosine of the right rotation matrix. *> \endverbatim *> *> \param[out] SNR *> \verbatim *> SNR is DOUBLE PRECISION *> The sine of the right rotation matrix. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Contributors: * ================== *> *> Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA * * ===================================================================== SUBROUTINE DLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, $ CSR, SNR ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER LDA, LDB DOUBLE PRECISION CSL, CSR, SNL, SNR * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), ALPHAI( 2 ), ALPHAR( 2 ), $ B( LDB, * ), BETA( 2 ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. DOUBLE PRECISION ANORM, ASCALE, BNORM, BSCALE, H1, H2, H3, QQ, $ R, RR, SAFMIN, SCALE1, SCALE2, T, ULP, WI, WR1, $ WR2 * .. * .. External Subroutines .. EXTERNAL DLAG2, DLARTG, DLASV2, DROT * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLAPY2 EXTERNAL DLAMCH, DLAPY2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Executable Statements .. * SAFMIN = DLAMCH( 'S' ) ULP = DLAMCH( 'P' ) * * Scale A * ANORM = MAX( ABS( A( 1, 1 ) )+ABS( A( 2, 1 ) ), $ ABS( A( 1, 2 ) )+ABS( A( 2, 2 ) ), SAFMIN ) ASCALE = ONE / ANORM A( 1, 1 ) = ASCALE*A( 1, 1 ) A( 1, 2 ) = ASCALE*A( 1, 2 ) A( 2, 1 ) = ASCALE*A( 2, 1 ) A( 2, 2 ) = ASCALE*A( 2, 2 ) * * Scale B * BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 1, 2 ) )+ABS( B( 2, 2 ) ), $ SAFMIN ) BSCALE = ONE / BNORM B( 1, 1 ) = BSCALE*B( 1, 1 ) B( 1, 2 ) = BSCALE*B( 1, 2 ) B( 2, 2 ) = BSCALE*B( 2, 2 ) * * Check if A can be deflated * IF( ABS( A( 2, 1 ) ).LE.ULP ) THEN CSL = ONE SNL = ZERO CSR = ONE SNR = ZERO A( 2, 1 ) = ZERO B( 2, 1 ) = ZERO WI = ZERO * * Check if B is singular * ELSE IF( ABS( B( 1, 1 ) ).LE.ULP ) THEN CALL DLARTG( A( 1, 1 ), A( 2, 1 ), CSL, SNL, R ) CSR = ONE SNR = ZERO CALL DROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL ) CALL DROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL ) A( 2, 1 ) = ZERO B( 1, 1 ) = ZERO B( 2, 1 ) = ZERO WI = ZERO * ELSE IF( ABS( B( 2, 2 ) ).LE.ULP ) THEN CALL DLARTG( A( 2, 2 ), A( 2, 1 ), CSR, SNR, T ) SNR = -SNR CALL DROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR ) CALL DROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR ) CSL = ONE SNL = ZERO A( 2, 1 ) = ZERO B( 2, 1 ) = ZERO B( 2, 2 ) = ZERO WI = ZERO * ELSE * * B is nonsingular, first compute the eigenvalues of (A,B) * CALL DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, WR2, $ WI ) * IF( WI.EQ.ZERO ) THEN * * two real eigenvalues, compute s*A-w*B * H1 = SCALE1*A( 1, 1 ) - WR1*B( 1, 1 ) H2 = SCALE1*A( 1, 2 ) - WR1*B( 1, 2 ) H3 = SCALE1*A( 2, 2 ) - WR1*B( 2, 2 ) * RR = DLAPY2( H1, H2 ) QQ = DLAPY2( SCALE1*A( 2, 1 ), H3 ) * IF( RR.GT.QQ ) THEN * * find right rotation matrix to zero 1,1 element of * (sA - wB) * CALL DLARTG( H2, H1, CSR, SNR, T ) * ELSE * * find right rotation matrix to zero 2,1 element of * (sA - wB) * CALL DLARTG( H3, SCALE1*A( 2, 1 ), CSR, SNR, T ) * END IF * SNR = -SNR CALL DROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR ) CALL DROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR ) * * compute inf norms of A and B * H1 = MAX( ABS( A( 1, 1 ) )+ABS( A( 1, 2 ) ), $ ABS( A( 2, 1 ) )+ABS( A( 2, 2 ) ) ) H2 = MAX( ABS( B( 1, 1 ) )+ABS( B( 1, 2 ) ), $ ABS( B( 2, 1 ) )+ABS( B( 2, 2 ) ) ) * IF( ( SCALE1*H1 ).GE.ABS( WR1 )*H2 ) THEN * * find left rotation matrix Q to zero out B(2,1) * CALL DLARTG( B( 1, 1 ), B( 2, 1 ), CSL, SNL, R ) * ELSE * * find left rotation matrix Q to zero out A(2,1) * CALL DLARTG( A( 1, 1 ), A( 2, 1 ), CSL, SNL, R ) * END IF * CALL DROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL ) CALL DROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL ) * A( 2, 1 ) = ZERO B( 2, 1 ) = ZERO * ELSE * * a pair of complex conjugate eigenvalues * first compute the SVD of the matrix B * CALL DLASV2( B( 1, 1 ), B( 1, 2 ), B( 2, 2 ), R, T, SNR, $ CSR, SNL, CSL ) * * Form (A,B) := Q(A,B)Z**T where Q is left rotation matrix and * Z is right rotation matrix computed from DLASV2 * CALL DROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL ) CALL DROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL ) CALL DROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR ) CALL DROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR ) * B( 2, 1 ) = ZERO B( 1, 2 ) = ZERO * END IF * END IF * * Unscaling * A( 1, 1 ) = ANORM*A( 1, 1 ) A( 2, 1 ) = ANORM*A( 2, 1 ) A( 1, 2 ) = ANORM*A( 1, 2 ) A( 2, 2 ) = ANORM*A( 2, 2 ) B( 1, 1 ) = BNORM*B( 1, 1 ) B( 2, 1 ) = BNORM*B( 2, 1 ) B( 1, 2 ) = BNORM*B( 1, 2 ) B( 2, 2 ) = BNORM*B( 2, 2 ) * IF( WI.EQ.ZERO ) THEN ALPHAR( 1 ) = A( 1, 1 ) ALPHAR( 2 ) = A( 2, 2 ) ALPHAI( 1 ) = ZERO ALPHAI( 2 ) = ZERO BETA( 1 ) = B( 1, 1 ) BETA( 2 ) = B( 2, 2 ) ELSE ALPHAR( 1 ) = ANORM*WR1 / SCALE1 / BNORM ALPHAI( 1 ) = ANORM*WI / SCALE1 / BNORM ALPHAR( 2 ) = ALPHAR( 1 ) ALPHAI( 2 ) = -ALPHAI( 1 ) BETA( 1 ) = ONE BETA( 2 ) = ONE END IF * RETURN * * End of DLAGV2 * END *> \brief \b DLAHQR computes the eigenvalues and Schur factorization of an upper Hessenberg matrix, using the double-shift/single-shift QR algorithm. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAHQR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, * ILOZ, IHIZ, Z, LDZ, INFO ) * * .. Scalar Arguments .. * INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N * LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. * DOUBLE PRECISION H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAHQR is an auxiliary routine called by DHSEQR to update the *> eigenvalues and Schur decomposition already computed by DHSEQR, by *> dealing with the Hessenberg submatrix in rows and columns ILO to *> IHI. *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTT *> \verbatim *> WANTT is LOGICAL *> = .TRUE. : the full Schur form T is required; *> = .FALSE.: only eigenvalues are required. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> = .TRUE. : the matrix of Schur vectors Z is required; *> = .FALSE.: Schur vectors are not required. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix H. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> It is assumed that H is already upper quasi-triangular in *> rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless *> ILO = 1). DLAHQR works primarily with the Hessenberg *> submatrix in rows and columns ILO to IHI, but applies *> transformations to all of H if WANTT is .TRUE.. *> 1 <= ILO <= max(1,IHI); IHI <= N. *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is DOUBLE PRECISION array, dimension (LDH,N) *> On entry, the upper Hessenberg matrix H. *> On exit, if INFO is zero and if WANTT is .TRUE., H is upper *> quasi-triangular in rows and columns ILO:IHI, with any *> 2-by-2 diagonal blocks in standard form. If INFO is zero *> and WANTT is .FALSE., the contents of H are unspecified on *> exit. The output state of H if INFO is nonzero is given *> below under the description of INFO. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is INTEGER *> The leading dimension of the array H. LDH >= max(1,N). *> \endverbatim *> *> \param[out] WR *> \verbatim *> WR is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] WI *> \verbatim *> WI is DOUBLE PRECISION array, dimension (N) *> The real and imaginary parts, respectively, of the computed *> eigenvalues ILO to IHI are stored in the corresponding *> elements of WR and WI. 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) > 0 and WI(i+1) < 0. If WANTT is .TRUE., 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). *> \endverbatim *> *> \param[in] ILOZ *> \verbatim *> ILOZ is INTEGER *> \endverbatim *> *> \param[in] IHIZ *> \verbatim *> IHIZ is INTEGER *> Specify the rows of Z to which transformations must be *> applied if WANTZ is .TRUE.. *> 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ,N) *> If WANTZ is .TRUE., on entry Z must contain the current *> matrix Z of transformations accumulated by DHSEQR, and on *> exit Z has been updated; transformations are applied only to *> the submatrix Z(ILOZ:IHIZ,ILO:IHI). *> If WANTZ is .FALSE., Z is not referenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> .GT. 0: If INFO = i, DLAHQR failed to compute all the *> eigenvalues ILO to IHI in a total of 30 iterations *> per eigenvalue; elements i+1:ihi of WR and WI *> contain those eigenvalues which have been *> successfully computed. *> *> If INFO .GT. 0 and WANTT is .FALSE., then on exit, *> the remaining unconverged eigenvalues are the *> eigenvalues of the upper Hessenberg matrix rows *> and columns ILO thorugh INFO of the final, output *> value of H. *> *> If INFO .GT. 0 and WANTT is .TRUE., then on exit *> (*) (initial value of H)*U = U*(final value of H) *> where U is an orthognal matrix. The final *> value of H is upper Hessenberg and triangular in *> rows and columns INFO+1 through IHI. *> *> If INFO .GT. 0 and WANTZ is .TRUE., then on exit *> (final value of Z) = (initial value of Z)*U *> where U is the orthogonal matrix in (*) *> (regardless of the value of WANTT.) *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> 02-96 Based on modifications by *> David Day, Sandia National Laboratory, USA *> *> 12-04 Further modifications by *> Ralph Byers, University of Kansas, USA *> This is a modified version of DLAHQR from LAPACK version 3.0. *> It is (1) more robust against overflow and underflow and *> (2) adopts the more conservative Ahues & Tisseur stopping *> criterion (LAWN 122, 1997). *> \endverbatim *> * ===================================================================== SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, INFO ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. DOUBLE PRECISION H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * ) * .. * * ========================================================= * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0, TWO = 2.0d0 ) DOUBLE PRECISION DAT1, DAT2 PARAMETER ( DAT1 = 3.0d0 / 4.0d0, DAT2 = -0.4375d0 ) * .. * .. Local Scalars .. DOUBLE PRECISION AA, AB, BA, BB, CS, DET, H11, H12, H21, H21S, $ H22, RT1I, RT1R, RT2I, RT2R, RTDISC, S, SAFMAX, $ SAFMIN, SMLNUM, SN, SUM, T1, T2, T3, TR, TST, $ ULP, V2, V3 INTEGER I, I1, I2, ITS, ITMAX, J, K, L, M, NH, NR, NZ * .. * .. Local Arrays .. DOUBLE PRECISION V( 3 ) * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. External Subroutines .. EXTERNAL DCOPY, DLABAD, DLANV2, DLARFG, DROT * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN, SQRT * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.EQ.0 ) $ RETURN IF( ILO.EQ.IHI ) THEN WR( ILO ) = H( ILO, ILO ) WI( ILO ) = ZERO RETURN END IF * * ==== clear out the trash ==== DO 10 J = ILO, IHI - 3 H( J+2, J ) = ZERO H( J+3, J ) = ZERO 10 CONTINUE IF( ILO.LE.IHI-2 ) $ H( IHI, IHI-2 ) = ZERO * NH = IHI - ILO + 1 NZ = IHIZ - ILOZ + 1 * * Set machine-dependent constants for the stopping criterion. * SAFMIN = DLAMCH( 'SAFE MINIMUM' ) SAFMAX = ONE / SAFMIN CALL DLABAD( SAFMIN, SAFMAX ) ULP = DLAMCH( 'PRECISION' ) SMLNUM = SAFMIN*( DBLE( NH ) / ULP ) * * I1 and I2 are the indices of the first row and last column of H * to which transformations must be applied. If eigenvalues only are * being computed, I1 and I2 are set inside the main loop. * IF( WANTT ) THEN I1 = 1 I2 = N END IF * * ITMAX is the total number of QR iterations allowed. * ITMAX = 30 * MAX( 10, NH ) * * The main loop begins here. I is the loop index and decreases from * IHI to ILO in steps of 1 or 2. Each iteration of the loop works * with the active submatrix in rows and columns L to I. * Eigenvalues I+1 to IHI have already converged. Either L = ILO or * H(L,L-1) is negligible so that the matrix splits. * I = IHI 20 CONTINUE L = ILO IF( I.LT.ILO ) $ GO TO 160 * * Perform QR iterations on rows and columns ILO to I until a * submatrix of order 1 or 2 splits off at the bottom because a * subdiagonal element has become negligible. * DO 140 ITS = 0, ITMAX * * Look for a single small subdiagonal element. * DO 30 K = I, L + 1, -1 IF( ABS( H( K, K-1 ) ).LE.SMLNUM ) $ GO TO 40 TST = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) ) IF( TST.EQ.ZERO ) THEN IF( K-2.GE.ILO ) $ TST = TST + ABS( H( K-1, K-2 ) ) IF( K+1.LE.IHI ) $ TST = TST + ABS( H( K+1, K ) ) END IF * ==== The following is a conservative small subdiagonal * . deflation criterion due to Ahues & Tisseur (LAWN 122, * . 1997). It has better mathematical foundation and * . improves accuracy in some cases. ==== IF( ABS( H( K, K-1 ) ).LE.ULP*TST ) THEN AB = MAX( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) ) BA = MIN( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) ) AA = MAX( ABS( H( K, K ) ), $ ABS( H( K-1, K-1 )-H( K, K ) ) ) BB = MIN( ABS( H( K, K ) ), $ ABS( H( K-1, K-1 )-H( K, K ) ) ) S = AA + AB IF( BA*( AB / S ).LE.MAX( SMLNUM, $ ULP*( BB*( AA / S ) ) ) )GO TO 40 END IF 30 CONTINUE 40 CONTINUE L = K IF( L.GT.ILO ) THEN * * H(L,L-1) is negligible * H( L, L-1 ) = ZERO END IF * * Exit from loop if a submatrix of order 1 or 2 has split off. * IF( L.GE.I-1 ) $ GO TO 150 * * Now the active submatrix is in rows and columns L to I. If * eigenvalues only are being computed, only the active submatrix * need be transformed. * IF( .NOT.WANTT ) THEN I1 = L I2 = I END IF * IF( ITS.EQ.10 ) THEN * * Exceptional shift. * S = ABS( H( L+1, L ) ) + ABS( H( L+2, L+1 ) ) H11 = DAT1*S + H( L, L ) H12 = DAT2*S H21 = S H22 = H11 ELSE IF( ITS.EQ.20 ) THEN * * Exceptional shift. * S = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) ) H11 = DAT1*S + H( I, I ) H12 = DAT2*S H21 = S H22 = H11 ELSE * * Prepare to use Francis' double shift * (i.e. 2nd degree generalized Rayleigh quotient) * H11 = H( I-1, I-1 ) H21 = H( I, I-1 ) H12 = H( I-1, I ) H22 = H( I, I ) END IF S = ABS( H11 ) + ABS( H12 ) + ABS( H21 ) + ABS( H22 ) IF( S.EQ.ZERO ) THEN RT1R = ZERO RT1I = ZERO RT2R = ZERO RT2I = ZERO ELSE H11 = H11 / S H21 = H21 / S H12 = H12 / S H22 = H22 / S TR = ( H11+H22 ) / TWO DET = ( H11-TR )*( H22-TR ) - H12*H21 RTDISC = SQRT( ABS( DET ) ) IF( DET.GE.ZERO ) THEN * * ==== complex conjugate shifts ==== * RT1R = TR*S RT2R = RT1R RT1I = RTDISC*S RT2I = -RT1I ELSE * * ==== real shifts (use only one of them) ==== * RT1R = TR + RTDISC RT2R = TR - RTDISC IF( ABS( RT1R-H22 ).LE.ABS( RT2R-H22 ) ) THEN RT1R = RT1R*S RT2R = RT1R ELSE RT2R = RT2R*S RT1R = RT2R END IF RT1I = ZERO RT2I = ZERO END IF END IF * * Look for two consecutive small subdiagonal elements. * DO 50 M = I - 2, L, -1 * Determine the effect of starting the double-shift QR * iteration at row M, and see if this would make H(M,M-1) * negligible. (The following uses scaling to avoid * overflows and most underflows.) * H21S = H( M+1, M ) S = ABS( H( M, M )-RT2R ) + ABS( RT2I ) + ABS( H21S ) H21S = H( M+1, M ) / S V( 1 ) = H21S*H( M, M+1 ) + ( H( M, M )-RT1R )* $ ( ( H( M, M )-RT2R ) / S ) - RT1I*( RT2I / S ) V( 2 ) = H21S*( H( M, M )+H( M+1, M+1 )-RT1R-RT2R ) V( 3 ) = H21S*H( M+2, M+1 ) S = ABS( V( 1 ) ) + ABS( V( 2 ) ) + ABS( V( 3 ) ) V( 1 ) = V( 1 ) / S V( 2 ) = V( 2 ) / S V( 3 ) = V( 3 ) / S IF( M.EQ.L ) $ GO TO 60 IF( ABS( H( M, M-1 ) )*( ABS( V( 2 ) )+ABS( V( 3 ) ) ).LE. $ ULP*ABS( V( 1 ) )*( ABS( H( M-1, M-1 ) )+ABS( H( M, $ M ) )+ABS( H( M+1, M+1 ) ) ) )GO TO 60 50 CONTINUE 60 CONTINUE * * Double-shift QR step * DO 130 K = M, I - 1 * * The first iteration of this loop determines a reflection G * from the vector V and applies it from left and right to H, * thus creating a nonzero bulge below the subdiagonal. * * Each subsequent iteration determines a reflection G to * restore the Hessenberg form in the (K-1)th column, and thus * chases the bulge one step toward the bottom of the active * submatrix. NR is the order of G. * NR = MIN( 3, I-K+1 ) IF( K.GT.M ) $ CALL DCOPY( NR, H( K, K-1 ), 1, V, 1 ) CALL DLARFG( NR, V( 1 ), V( 2 ), 1, T1 ) IF( K.GT.M ) THEN H( K, K-1 ) = V( 1 ) H( K+1, K-1 ) = ZERO IF( K.LT.I-1 ) $ H( K+2, K-1 ) = ZERO ELSE IF( M.GT.L ) THEN * ==== Use the following instead of * . H( K, K-1 ) = -H( K, K-1 ) to * . avoid a bug when v(2) and v(3) * . underflow. ==== H( K, K-1 ) = H( K, K-1 )*( ONE-T1 ) END IF V2 = V( 2 ) T2 = T1*V2 IF( NR.EQ.3 ) THEN V3 = V( 3 ) T3 = T1*V3 * * Apply G from the left to transform the rows of the matrix * in columns K to I2. * DO 70 J = K, I2 SUM = H( K, J ) + V2*H( K+1, J ) + V3*H( K+2, J ) H( K, J ) = H( K, J ) - SUM*T1 H( K+1, J ) = H( K+1, J ) - SUM*T2 H( K+2, J ) = H( K+2, J ) - SUM*T3 70 CONTINUE * * Apply G from the right to transform the columns of the * matrix in rows I1 to min(K+3,I). * DO 80 J = I1, MIN( K+3, I ) SUM = H( J, K ) + V2*H( J, K+1 ) + V3*H( J, K+2 ) H( J, K ) = H( J, K ) - SUM*T1 H( J, K+1 ) = H( J, K+1 ) - SUM*T2 H( J, K+2 ) = H( J, K+2 ) - SUM*T3 80 CONTINUE * IF( WANTZ ) THEN * * Accumulate transformations in the matrix Z * DO 90 J = ILOZ, IHIZ SUM = Z( J, K ) + V2*Z( J, K+1 ) + V3*Z( J, K+2 ) Z( J, K ) = Z( J, K ) - SUM*T1 Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2 Z( J, K+2 ) = Z( J, K+2 ) - SUM*T3 90 CONTINUE END IF ELSE IF( NR.EQ.2 ) THEN * * Apply G from the left to transform the rows of the matrix * in columns K to I2. * DO 100 J = K, I2 SUM = H( K, J ) + V2*H( K+1, J ) H( K, J ) = H( K, J ) - SUM*T1 H( K+1, J ) = H( K+1, J ) - SUM*T2 100 CONTINUE * * Apply G from the right to transform the columns of the * matrix in rows I1 to min(K+3,I). * DO 110 J = I1, I SUM = H( J, K ) + V2*H( J, K+1 ) H( J, K ) = H( J, K ) - SUM*T1 H( J, K+1 ) = H( J, K+1 ) - SUM*T2 110 CONTINUE * IF( WANTZ ) THEN * * Accumulate transformations in the matrix Z * DO 120 J = ILOZ, IHIZ SUM = Z( J, K ) + V2*Z( J, K+1 ) Z( J, K ) = Z( J, K ) - SUM*T1 Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2 120 CONTINUE END IF END IF 130 CONTINUE * 140 CONTINUE * * Failure to converge in remaining number of iterations * INFO = I RETURN * 150 CONTINUE * IF( L.EQ.I ) THEN * * H(I,I-1) is negligible: one eigenvalue has converged. * WR( I ) = H( I, I ) WI( I ) = ZERO ELSE IF( L.EQ.I-1 ) THEN * * H(I-1,I-2) is negligible: a pair of eigenvalues have converged. * * Transform the 2-by-2 submatrix to standard Schur form, * and compute and store the eigenvalues. * CALL DLANV2( H( I-1, I-1 ), H( I-1, I ), H( I, I-1 ), $ H( I, I ), WR( I-1 ), WI( I-1 ), WR( I ), WI( I ), $ CS, SN ) * IF( WANTT ) THEN * * Apply the transformation to the rest of H. * IF( I2.GT.I ) $ CALL DROT( I2-I, H( I-1, I+1 ), LDH, H( I, I+1 ), LDH, $ CS, SN ) CALL DROT( I-I1-1, H( I1, I-1 ), 1, H( I1, I ), 1, CS, SN ) END IF IF( WANTZ ) THEN * * Apply the transformation to Z. * CALL DROT( NZ, Z( ILOZ, I-1 ), 1, Z( ILOZ, I ), 1, CS, SN ) END IF END IF * * return to start of the main loop with new value of I. * I = L - 1 GO TO 20 * 160 CONTINUE RETURN * * End of DLAHQR * END *> \brief \b DLAHR2 reduces the specified number of first columns of a general rectangular matrix A so that elements below the specified subdiagonal are zero, and returns auxiliary matrices which are needed to apply the transformation to the unreduced part of A. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAHR2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * * .. Scalar Arguments .. * INTEGER K, LDA, LDT, LDY, N, NB * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), T( LDT, NB ), TAU( NB ), * $ Y( LDY, NB ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1) *> matrix A so that elements below the k-th subdiagonal are zero. The *> reduction is performed by an orthogonal similarity transformation *> Q**T * A * Q. The routine returns the matrices V and T which determine *> Q as a block reflector I - V*T*V**T, and also the matrix Y = A * V * T. *> *> This is an auxiliary routine called by DGEHRD. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The offset for the reduction. Elements below the k-th *> subdiagonal in the first NB columns are reduced to zero. *> K < N. *> \endverbatim *> *> \param[in] NB *> \verbatim *> NB is INTEGER *> The number of columns to be reduced. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N-K+1) *> On entry, the n-by-(n-k+1) general matrix A. *> On exit, the elements on and above the k-th subdiagonal in *> the first NB columns are overwritten with the corresponding *> elements of the reduced matrix; the elements below the k-th *> subdiagonal, with the array TAU, represent the matrix Q as a *> product of elementary reflectors. The other columns of A are *> unchanged. See Further Details. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (NB) *> The scalar factors of the elementary reflectors. See Further *> Details. *> \endverbatim *> *> \param[out] T *> \verbatim *> T is DOUBLE PRECISION array, dimension (LDT,NB) *> The upper triangular matrix T. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= NB. *> \endverbatim *> *> \param[out] Y *> \verbatim *> Y is DOUBLE PRECISION array, dimension (LDY,NB) *> The n-by-nb matrix Y. *> \endverbatim *> *> \param[in] LDY *> \verbatim *> LDY is INTEGER *> The leading dimension of the array Y. LDY >= N. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of nb elementary reflectors *> *> Q = H(1) H(2) . . . H(nb). *> *> Each H(i) has the form *> *> H(i) = I - tau * v * v**T *> *> where tau is a real scalar, and v is a real vector with *> v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in *> A(i+k+1:n,i), and tau in TAU(i). *> *> The elements of the vectors v together form the (n-k+1)-by-nb matrix *> V which is needed, with T and Y, to apply the transformation to the *> unreduced part of the matrix, using an update of the form: *> A := (I - V*T*V**T) * (A - Y*V**T). *> *> The contents of A on exit are illustrated by the following example *> with n = 7, k = 3 and nb = 2: *> *> ( a a a a a ) *> ( a a a a a ) *> ( a a a a a ) *> ( h h a a a ) *> ( v1 h a a a ) *> ( v1 v2 a a a ) *> ( v1 v2 a 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 subroutine is a slight modification of LAPACK-3.0's DLAHRD *> incorporating improvements proposed by Quintana-Orti and Van de *> Gejin. Note that the entries of A(1:K,2:NB) differ from those *> returned by the original LAPACK-3.0's DLAHRD routine. (This *> subroutine is not backward compatible with LAPACK-3.0's DLAHRD.) *> \endverbatim * *> \par References: * ================ *> *> Gregorio Quintana-Orti and Robert van de Geijn, "Improving the *> performance of reduction to Hessenberg form," ACM Transactions on *> Mathematical Software, 32(2):180-194, June 2006. *> * ===================================================================== SUBROUTINE DLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LDT, LDY, N, NB * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), T( LDT, NB ), TAU( NB ), $ Y( LDY, NB ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, $ ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I DOUBLE PRECISION EI * .. * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DLACPY, $ DLARFG, DSCAL, DTRMM, DTRMV * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * * Quick return if possible * IF( N.LE.1 ) $ RETURN * DO 10 I = 1, NB IF( I.GT.1 ) THEN * * Update A(K+1:N,I) * * Update I-th column of A - Y * V**T * CALL DGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, Y(K+1,1), LDY, $ A( K+I-1, 1 ), LDA, ONE, A( K+1, I ), 1 ) * * Apply I - V * T**T * V**T to this column (call it b) from the * left, using the last column of T as workspace * * Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) * ( V2 ) ( b2 ) * * where V1 is unit lower triangular * * w := V1**T * b1 * CALL DCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 ) CALL DTRMV( 'Lower', 'Transpose', 'UNIT', $ I-1, A( K+1, 1 ), $ LDA, T( 1, NB ), 1 ) * * w := w + V2**T * b2 * CALL DGEMV( 'Transpose', N-K-I+1, I-1, $ ONE, A( K+I, 1 ), $ LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 ) * * w := T**T * w * CALL DTRMV( 'Upper', 'Transpose', 'NON-UNIT', $ I-1, T, LDT, $ T( 1, NB ), 1 ) * * b2 := b2 - V2*w * CALL DGEMV( 'NO TRANSPOSE', N-K-I+1, I-1, -ONE, $ A( K+I, 1 ), $ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 ) * * b1 := b1 - V1*w * CALL DTRMV( 'Lower', 'NO TRANSPOSE', $ 'UNIT', I-1, $ A( K+1, 1 ), LDA, T( 1, NB ), 1 ) CALL DAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 ) * A( K+I-1, I-1 ) = EI END IF * * Generate the elementary reflector H(I) to annihilate * A(K+I+1:N,I) * CALL DLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1, $ TAU( I ) ) EI = A( K+I, I ) A( K+I, I ) = ONE * * Compute Y(K+1:N,I) * CALL DGEMV( 'NO TRANSPOSE', N-K, N-K-I+1, $ ONE, A( K+1, I+1 ), $ LDA, A( K+I, I ), 1, ZERO, Y( K+1, I ), 1 ) CALL DGEMV( 'Transpose', N-K-I+1, I-1, $ ONE, A( K+I, 1 ), LDA, $ A( K+I, I ), 1, ZERO, T( 1, I ), 1 ) CALL DGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, $ Y( K+1, 1 ), LDY, $ T( 1, I ), 1, ONE, Y( K+1, I ), 1 ) CALL DSCAL( N-K, TAU( I ), Y( K+1, I ), 1 ) * * Compute T(1:I,I) * CALL DSCAL( I-1, -TAU( I ), T( 1, I ), 1 ) CALL DTRMV( 'Upper', 'No Transpose', 'NON-UNIT', $ I-1, T, LDT, $ T( 1, I ), 1 ) T( I, I ) = TAU( I ) * 10 CONTINUE A( K+NB, NB ) = EI * * Compute Y(1:K,1:NB) * CALL DLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY ) CALL DTRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE', $ 'UNIT', K, NB, $ ONE, A( K+1, 1 ), LDA, Y, LDY ) IF( N.GT.K+NB ) $ CALL DGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', K, $ NB, N-K-NB, ONE, $ A( 1, 2+NB ), LDA, A( K+1+NB, 1 ), LDA, ONE, Y, $ LDY ) CALL DTRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE', $ 'NON-UNIT', K, NB, $ ONE, T, LDT, Y, LDY ) * RETURN * * End of DLAHR2 * END *> \brief \b DLAHRD reduces the first nb columns of a general rectangular matrix A so that elements below the k-th subdiagonal are zero, and returns auxiliary matrices which are needed to apply the transformation to the unreduced part of A. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAHRD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * * .. Scalar Arguments .. * INTEGER K, LDA, LDT, LDY, N, NB * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), T( LDT, NB ), TAU( NB ), * $ Y( LDY, NB ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> This routine is deprecated and has been replaced by routine DLAHR2. *> *> DLAHRD reduces the first NB columns of a real general n-by-(n-k+1) *> matrix A so that elements below the k-th subdiagonal are zero. The *> reduction is performed by an orthogonal similarity transformation *> Q**T * A * Q. The routine returns the matrices V and T which determine *> Q as a block reflector I - V*T*V**T, and also the matrix Y = A * V * T. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The offset for the reduction. Elements below the k-th *> subdiagonal in the first NB columns are reduced to zero. *> \endverbatim *> *> \param[in] NB *> \verbatim *> NB is INTEGER *> The number of columns to be reduced. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N-K+1) *> On entry, the n-by-(n-k+1) general matrix A. *> On exit, the elements on and above the k-th subdiagonal in *> the first NB columns are overwritten with the corresponding *> elements of the reduced matrix; the elements below the k-th *> subdiagonal, with the array TAU, represent the matrix Q as a *> product of elementary reflectors. The other columns of A are *> unchanged. See Further Details. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (NB) *> The scalar factors of the elementary reflectors. See Further *> Details. *> \endverbatim *> *> \param[out] T *> \verbatim *> T is DOUBLE PRECISION array, dimension (LDT,NB) *> The upper triangular matrix T. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= NB. *> \endverbatim *> *> \param[out] Y *> \verbatim *> Y is DOUBLE PRECISION array, dimension (LDY,NB) *> The n-by-nb matrix Y. *> \endverbatim *> *> \param[in] LDY *> \verbatim *> LDY is INTEGER *> The leading dimension of the array Y. LDY >= N. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix Q is represented as a product of nb elementary reflectors *> *> Q = H(1) H(2) . . . H(nb). *> *> Each H(i) has the form *> *> H(i) = I - tau * v * v**T *> *> where tau is a real scalar, and v is a real vector with *> v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in *> A(i+k+1:n,i), and tau in TAU(i). *> *> The elements of the vectors v together form the (n-k+1)-by-nb matrix *> V which is needed, with T and Y, to apply the transformation to the *> unreduced part of the matrix, using an update of the form: *> A := (I - V*T*V**T) * (A - Y*V**T). *> *> The contents of A on exit are illustrated by the following example *> with n = 7, k = 3 and nb = 2: *> *> ( a h a a a ) *> ( a h a a a ) *> ( a h a a a ) *> ( h h a a a ) *> ( v1 h a a a ) *> ( v1 v2 a a a ) *> ( v1 v2 a 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). *> \endverbatim *> * ===================================================================== SUBROUTINE DLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER K, LDA, LDT, LDY, N, NB * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), T( LDT, NB ), TAU( NB ), $ Y( LDY, NB ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I DOUBLE PRECISION EI * .. * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMV, DLARFG, DSCAL, DTRMV * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * * Quick return if possible * IF( N.LE.1 ) $ RETURN * DO 10 I = 1, NB IF( I.GT.1 ) THEN * * Update A(1:n,i) * * Compute i-th column of A - Y * V**T * CALL DGEMV( 'No transpose', N, I-1, -ONE, Y, LDY, $ A( K+I-1, 1 ), LDA, ONE, A( 1, I ), 1 ) * * Apply I - V * T**T * V**T to this column (call it b) from the * left, using the last column of T as workspace * * Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) * ( V2 ) ( b2 ) * * where V1 is unit lower triangular * * w := V1**T * b1 * CALL DCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 ) CALL DTRMV( 'Lower', 'Transpose', 'Unit', I-1, A( K+1, 1 ), $ LDA, T( 1, NB ), 1 ) * * w := w + V2**T *b2 * CALL DGEMV( 'Transpose', N-K-I+1, I-1, ONE, A( K+I, 1 ), $ LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 ) * * w := T**T *w * CALL DTRMV( 'Upper', 'Transpose', 'Non-unit', I-1, T, LDT, $ T( 1, NB ), 1 ) * * b2 := b2 - V2*w * CALL DGEMV( 'No transpose', N-K-I+1, I-1, -ONE, A( K+I, 1 ), $ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 ) * * b1 := b1 - V1*w * CALL DTRMV( 'Lower', 'No transpose', 'Unit', I-1, $ A( K+1, 1 ), LDA, T( 1, NB ), 1 ) CALL DAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 ) * A( K+I-1, I-1 ) = EI END IF * * Generate the elementary reflector H(i) to annihilate * A(k+i+1:n,i) * CALL DLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1, $ TAU( I ) ) EI = A( K+I, I ) A( K+I, I ) = ONE * * Compute Y(1:n,i) * CALL DGEMV( 'No transpose', N, N-K-I+1, ONE, A( 1, I+1 ), LDA, $ A( K+I, I ), 1, ZERO, Y( 1, I ), 1 ) CALL DGEMV( 'Transpose', N-K-I+1, I-1, ONE, A( K+I, 1 ), LDA, $ A( K+I, I ), 1, ZERO, T( 1, I ), 1 ) CALL DGEMV( 'No transpose', N, I-1, -ONE, Y, LDY, T( 1, I ), 1, $ ONE, Y( 1, I ), 1 ) CALL DSCAL( N, TAU( I ), Y( 1, I ), 1 ) * * Compute T(1:i,i) * CALL DSCAL( I-1, -TAU( I ), T( 1, I ), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, LDT, $ T( 1, I ), 1 ) T( I, I ) = TAU( I ) * 10 CONTINUE A( K+NB, NB ) = EI * RETURN * * End of DLAHRD * END *> \brief \b DLAIC1 applies one step of incremental condition estimation. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAIC1 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C ) * * .. Scalar Arguments .. * INTEGER J, JOB * DOUBLE PRECISION C, GAMMA, S, SEST, SESTPR * .. * .. Array Arguments .. * DOUBLE PRECISION W( J ), X( J ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAIC1 applies one step of incremental condition estimation in *> its simplest version: *> *> Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j *> lower triangular matrix L, such that *> twonorm(L*x) = sest *> Then DLAIC1 computes sestpr, s, c such that *> the vector *> [ s*x ] *> xhat = [ c ] *> is an approximate singular vector of *> [ L 0 ] *> Lhat = [ w**T gamma ] *> in the sense that *> twonorm(Lhat*xhat) = sestpr. *> *> Depending on JOB, an estimate for the largest or smallest singular *> value is computed. *> *> Note that [s c]**T and sestpr**2 is an eigenpair of the system *> *> diag(sest*sest, 0) + [alpha gamma] * [ alpha ] *> [ gamma ] *> *> where alpha = x**T*w. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is INTEGER *> = 1: an estimate for the largest singular value is computed. *> = 2: an estimate for the smallest singular value is computed. *> \endverbatim *> *> \param[in] J *> \verbatim *> J is INTEGER *> Length of X and W *> \endverbatim *> *> \param[in] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (J) *> The j-vector x. *> \endverbatim *> *> \param[in] SEST *> \verbatim *> SEST is DOUBLE PRECISION *> Estimated singular value of j by j matrix L *> \endverbatim *> *> \param[in] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (J) *> The j-vector w. *> \endverbatim *> *> \param[in] GAMMA *> \verbatim *> GAMMA is DOUBLE PRECISION *> The diagonal element gamma. *> \endverbatim *> *> \param[out] SESTPR *> \verbatim *> SESTPR is DOUBLE PRECISION *> Estimated singular value of (j+1) by (j+1) matrix Lhat. *> \endverbatim *> *> \param[out] S *> \verbatim *> S is DOUBLE PRECISION *> Sine needed in forming xhat. *> \endverbatim *> *> \param[out] C *> \verbatim *> C is DOUBLE PRECISION *> Cosine needed in forming xhat. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER J, JOB DOUBLE PRECISION C, GAMMA, S, SEST, SESTPR * .. * .. Array Arguments .. DOUBLE PRECISION W( J ), X( J ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) DOUBLE PRECISION HALF, FOUR PARAMETER ( HALF = 0.5D0, FOUR = 4.0D0 ) * .. * .. Local Scalars .. DOUBLE PRECISION ABSALP, ABSEST, ABSGAM, ALPHA, B, COSINE, EPS, $ NORMA, S1, S2, SINE, T, TEST, TMP, ZETA1, ZETA2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SIGN, SQRT * .. * .. External Functions .. DOUBLE PRECISION DDOT, DLAMCH EXTERNAL DDOT, DLAMCH * .. * .. Executable Statements .. * EPS = DLAMCH( 'Epsilon' ) ALPHA = DDOT( J, X, 1, W, 1 ) * ABSALP = ABS( ALPHA ) ABSGAM = ABS( GAMMA ) ABSEST = ABS( SEST ) * IF( JOB.EQ.1 ) THEN * * Estimating largest singular value * * special cases * IF( SEST.EQ.ZERO ) THEN S1 = MAX( ABSGAM, ABSALP ) IF( S1.EQ.ZERO ) THEN S = ZERO C = ONE SESTPR = ZERO ELSE S = ALPHA / S1 C = GAMMA / S1 TMP = SQRT( S*S+C*C ) S = S / TMP C = C / TMP SESTPR = S1*TMP END IF RETURN ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN S = ONE C = ZERO TMP = MAX( ABSEST, ABSALP ) S1 = ABSEST / TMP S2 = ABSALP / TMP SESTPR = TMP*SQRT( S1*S1+S2*S2 ) RETURN ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN S1 = ABSGAM S2 = ABSEST IF( S1.LE.S2 ) THEN S = ONE C = ZERO SESTPR = S2 ELSE S = ZERO C = ONE SESTPR = S1 END IF RETURN ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN S1 = ABSGAM S2 = ABSALP IF( S1.LE.S2 ) THEN TMP = S1 / S2 S = SQRT( ONE+TMP*TMP ) SESTPR = S2*S C = ( GAMMA / S2 ) / S S = SIGN( ONE, ALPHA ) / S ELSE TMP = S2 / S1 C = SQRT( ONE+TMP*TMP ) SESTPR = S1*C S = ( ALPHA / S1 ) / C C = SIGN( ONE, GAMMA ) / C END IF RETURN ELSE * * normal case * ZETA1 = ALPHA / ABSEST ZETA2 = GAMMA / ABSEST * B = ( ONE-ZETA1*ZETA1-ZETA2*ZETA2 )*HALF C = ZETA1*ZETA1 IF( B.GT.ZERO ) THEN T = C / ( B+SQRT( B*B+C ) ) ELSE T = SQRT( B*B+C ) - B END IF * SINE = -ZETA1 / T COSINE = -ZETA2 / ( ONE+T ) TMP = SQRT( SINE*SINE+COSINE*COSINE ) S = SINE / TMP C = COSINE / TMP SESTPR = SQRT( T+ONE )*ABSEST RETURN END IF * ELSE IF( JOB.EQ.2 ) THEN * * Estimating smallest singular value * * special cases * IF( SEST.EQ.ZERO ) THEN SESTPR = ZERO IF( MAX( ABSGAM, ABSALP ).EQ.ZERO ) THEN SINE = ONE COSINE = ZERO ELSE SINE = -GAMMA COSINE = ALPHA END IF S1 = MAX( ABS( SINE ), ABS( COSINE ) ) S = SINE / S1 C = COSINE / S1 TMP = SQRT( S*S+C*C ) S = S / TMP C = C / TMP RETURN ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN S = ZERO C = ONE SESTPR = ABSGAM RETURN ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN S1 = ABSGAM S2 = ABSEST IF( S1.LE.S2 ) THEN S = ZERO C = ONE SESTPR = S1 ELSE S = ONE C = ZERO SESTPR = S2 END IF RETURN ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN S1 = ABSGAM S2 = ABSALP IF( S1.LE.S2 ) THEN TMP = S1 / S2 C = SQRT( ONE+TMP*TMP ) SESTPR = ABSEST*( TMP / C ) S = -( GAMMA / S2 ) / C C = SIGN( ONE, ALPHA ) / C ELSE TMP = S2 / S1 S = SQRT( ONE+TMP*TMP ) SESTPR = ABSEST / S C = ( ALPHA / S1 ) / S S = -SIGN( ONE, GAMMA ) / S END IF RETURN ELSE * * normal case * ZETA1 = ALPHA / ABSEST ZETA2 = GAMMA / ABSEST * NORMA = MAX( ONE+ZETA1*ZETA1+ABS( ZETA1*ZETA2 ), $ ABS( ZETA1*ZETA2 )+ZETA2*ZETA2 ) * * See if root is closer to zero or to ONE * TEST = ONE + TWO*( ZETA1-ZETA2 )*( ZETA1+ZETA2 ) IF( TEST.GE.ZERO ) THEN * * root is close to zero, compute directly * B = ( ZETA1*ZETA1+ZETA2*ZETA2+ONE )*HALF C = ZETA2*ZETA2 T = C / ( B+SQRT( ABS( B*B-C ) ) ) SINE = ZETA1 / ( ONE-T ) COSINE = -ZETA2 / T SESTPR = SQRT( T+FOUR*EPS*EPS*NORMA )*ABSEST ELSE * * root is closer to ONE, shift by that amount * B = ( ZETA2*ZETA2+ZETA1*ZETA1-ONE )*HALF C = ZETA1*ZETA1 IF( B.GE.ZERO ) THEN T = -C / ( B+SQRT( B*B+C ) ) ELSE T = B - SQRT( B*B+C ) END IF SINE = -ZETA1 / T COSINE = -ZETA2 / ( ONE+T ) SESTPR = SQRT( ONE+T+FOUR*EPS*EPS*NORMA )*ABSEST END IF TMP = SQRT( SINE*SINE+COSINE*COSINE ) S = SINE / TMP C = COSINE / TMP RETURN * END IF END IF RETURN * * End of DLAIC1 * END *> \brief \b DLAISNAN tests input for NaN by comparing two arguments for inequality. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAISNAN + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 ) * * .. Scalar Arguments .. * DOUBLE PRECISION, INTENT(IN) :: DIN1, DIN2 * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> This routine is not for general use. It exists solely to avoid *> over-optimization in DISNAN. *> *> DLAISNAN checks for NaNs by comparing its two arguments for *> inequality. NaN is the only floating-point value where NaN != NaN *> returns .TRUE. To check for NaNs, pass the same variable as both *> arguments. *> *> A compiler must assume that the two arguments are *> not the same variable, and the test will not be optimized away. *> Interprocedural or whole-program optimization may delete this *> test. The ISNAN functions will be replaced by the correct *> Fortran 03 intrinsic once the intrinsic is widely available. *> \endverbatim * * Arguments: * ========== * *> \param[in] DIN1 *> \verbatim *> DIN1 is DOUBLE PRECISION *> \endverbatim *> *> \param[in] DIN2 *> \verbatim *> DIN2 is DOUBLE PRECISION *> Two numbers to compare for inequality. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup OTHERauxiliary * * ===================================================================== LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 ) * * -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. DOUBLE PRECISION, INTENT(IN) :: DIN1, DIN2 * .. * * ===================================================================== * * .. Executable Statements .. DLAISNAN = (DIN1.NE.DIN2) RETURN END *> \brief \b DLALN2 solves a 1-by-1 or 2-by-2 linear system of equations of the specified form. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLALN2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, * LDB, WR, WI, X, LDX, SCALE, XNORM, INFO ) * * .. Scalar Arguments .. * LOGICAL LTRANS * INTEGER INFO, LDA, LDB, LDX, NA, NW * DOUBLE PRECISION CA, D1, D2, SCALE, SMIN, WI, WR, XNORM * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLALN2 solves a system of the form (ca A - w D ) X = s B *> or (ca A**T - w D) X = s B with possible scaling ("s") and *> perturbation of A. (A**T means A-transpose.) *> *> A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA *> real diagonal matrix, w is a real or complex value, and X and B are *> NA x 1 matrices -- real if w is real, complex if w is complex. NA *> may be 1 or 2. *> *> If w is complex, X and B are represented as NA x 2 matrices, *> the first column of each being the real part and the second *> being the imaginary part. *> *> "s" is a scaling factor (.LE. 1), computed by DLALN2, which is *> so chosen that X can be computed without overflow. X is further *> scaled if necessary to assure that norm(ca A - w D)*norm(X) is less *> than overflow. *> *> If both singular values of (ca A - w D) are less than SMIN, *> SMIN*identity will be used instead of (ca A - w D). If only one *> singular value is less than SMIN, one element of (ca A - w D) will be *> perturbed enough to make the smallest singular value roughly SMIN. *> If both singular values are at least SMIN, (ca A - w D) will not be *> perturbed. In any case, the perturbation will be at most some small *> multiple of max( SMIN, ulp*norm(ca A - w D) ). The singular values *> are computed by infinity-norm approximations, and thus will only be *> correct to a factor of 2 or so. *> *> Note: all input quantities are assumed to be smaller than overflow *> by a reasonable factor. (See BIGNUM.) *> \endverbatim * * Arguments: * ========== * *> \param[in] LTRANS *> \verbatim *> LTRANS is LOGICAL *> =.TRUE.: A-transpose will be used. *> =.FALSE.: A will be used (not transposed.) *> \endverbatim *> *> \param[in] NA *> \verbatim *> NA is INTEGER *> The size of the matrix A. It may (only) be 1 or 2. *> \endverbatim *> *> \param[in] NW *> \verbatim *> NW is INTEGER *> 1 if "w" is real, 2 if "w" is complex. It may only be 1 *> or 2. *> \endverbatim *> *> \param[in] SMIN *> \verbatim *> SMIN is DOUBLE PRECISION *> The desired lower bound on the singular values of A. This *> should be a safe distance away from underflow or overflow, *> say, between (underflow/machine precision) and (machine *> precision * overflow ). (See BIGNUM and ULP.) *> \endverbatim *> *> \param[in] CA *> \verbatim *> CA is DOUBLE PRECISION *> The coefficient c, which A is multiplied by. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,NA) *> The NA x NA matrix A. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of A. It must be at least NA. *> \endverbatim *> *> \param[in] D1 *> \verbatim *> D1 is DOUBLE PRECISION *> The 1,1 element in the diagonal matrix D. *> \endverbatim *> *> \param[in] D2 *> \verbatim *> D2 is DOUBLE PRECISION *> The 2,2 element in the diagonal matrix D. Not used if NA=1. *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NW) *> The NA x NW matrix B (right-hand side). If NW=2 ("w" is *> complex), column 1 contains the real part of B and column 2 *> contains the imaginary part. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of B. It must be at least NA. *> \endverbatim *> *> \param[in] WR *> \verbatim *> WR is DOUBLE PRECISION *> The real part of the scalar "w". *> \endverbatim *> *> \param[in] WI *> \verbatim *> WI is DOUBLE PRECISION *> The imaginary part of the scalar "w". Not used if NW=1. *> \endverbatim *> *> \param[out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,NW) *> The NA x NW matrix X (unknowns), as computed by DLALN2. *> If NW=2 ("w" is complex), on exit, column 1 will contain *> the real part of X and column 2 will contain the imaginary *> part. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of X. It must be at least NA. *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is DOUBLE PRECISION *> The scale factor that B must be multiplied by to insure *> that overflow does not occur when computing X. Thus, *> (ca A - w D) X will be SCALE*B, not B (ignoring *> perturbations of A.) It will be at most 1. *> \endverbatim *> *> \param[out] XNORM *> \verbatim *> XNORM is DOUBLE PRECISION *> The infinity-norm of X, when X is regarded as an NA x NW *> real matrix. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> An error flag. It will be set to zero if no error occurs, *> a negative number if an argument is in error, or a positive *> number if ca A - w D had to be perturbed. *> The possible values are: *> = 0: No error occurred, and (ca A - w D) did not have to be *> perturbed. *> = 1: (ca A - w D) had to be perturbed to make its smallest *> (or only) singular value greater than SMIN. *> NOTE: In the interests of speed, this routine does not *> check the inputs for errors. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, $ LDB, WR, WI, X, LDX, SCALE, XNORM, INFO ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. LOGICAL LTRANS INTEGER INFO, LDA, LDB, LDX, NA, NW DOUBLE PRECISION CA, D1, D2, SCALE, SMIN, WI, WR, XNORM * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D0 ) * .. * .. Local Scalars .. INTEGER ICMAX, J DOUBLE PRECISION BBND, BI1, BI2, BIGNUM, BNORM, BR1, BR2, CI21, $ CI22, CMAX, CNORM, CR21, CR22, CSI, CSR, LI21, $ LR21, SMINI, SMLNUM, TEMP, U22ABS, UI11, UI11R, $ UI12, UI12S, UI22, UR11, UR11R, UR12, UR12S, $ UR22, XI1, XI2, XR1, XR2 * .. * .. Local Arrays .. LOGICAL RSWAP( 4 ), ZSWAP( 4 ) INTEGER IPIVOT( 4, 4 ) DOUBLE PRECISION CI( 2, 2 ), CIV( 4 ), CR( 2, 2 ), CRV( 4 ) * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. External Subroutines .. EXTERNAL DLADIV * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Equivalences .. EQUIVALENCE ( CI( 1, 1 ), CIV( 1 ) ), $ ( CR( 1, 1 ), CRV( 1 ) ) * .. * .. Data statements .. DATA ZSWAP / .FALSE., .FALSE., .TRUE., .TRUE. / DATA RSWAP / .FALSE., .TRUE., .FALSE., .TRUE. / DATA IPIVOT / 1, 2, 3, 4, 2, 1, 4, 3, 3, 4, 1, 2, 4, $ 3, 2, 1 / * .. * .. Executable Statements .. * * Compute BIGNUM * SMLNUM = TWO*DLAMCH( 'Safe minimum' ) BIGNUM = ONE / SMLNUM SMINI = MAX( SMIN, SMLNUM ) * * Don't check for input errors * INFO = 0 * * Standard Initializations * SCALE = ONE * IF( NA.EQ.1 ) THEN * * 1 x 1 (i.e., scalar) system C X = B * IF( NW.EQ.1 ) THEN * * Real 1x1 system. * * C = ca A - w D * CSR = CA*A( 1, 1 ) - WR*D1 CNORM = ABS( CSR ) * * If | C | < SMINI, use C = SMINI * IF( CNORM.LT.SMINI ) THEN CSR = SMINI CNORM = SMINI INFO = 1 END IF * * Check scaling for X = B / C * BNORM = ABS( B( 1, 1 ) ) IF( CNORM.LT.ONE .AND. BNORM.GT.ONE ) THEN IF( BNORM.GT.BIGNUM*CNORM ) $ SCALE = ONE / BNORM END IF * * Compute X * X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / CSR XNORM = ABS( X( 1, 1 ) ) ELSE * * Complex 1x1 system (w is complex) * * C = ca A - w D * CSR = CA*A( 1, 1 ) - WR*D1 CSI = -WI*D1 CNORM = ABS( CSR ) + ABS( CSI ) * * If | C | < SMINI, use C = SMINI * IF( CNORM.LT.SMINI ) THEN CSR = SMINI CSI = ZERO CNORM = SMINI INFO = 1 END IF * * Check scaling for X = B / C * BNORM = ABS( B( 1, 1 ) ) + ABS( B( 1, 2 ) ) IF( CNORM.LT.ONE .AND. BNORM.GT.ONE ) THEN IF( BNORM.GT.BIGNUM*CNORM ) $ SCALE = ONE / BNORM END IF * * Compute X * CALL DLADIV( SCALE*B( 1, 1 ), SCALE*B( 1, 2 ), CSR, CSI, $ X( 1, 1 ), X( 1, 2 ) ) XNORM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) ) END IF * ELSE * * 2x2 System * * Compute the real part of C = ca A - w D (or ca A**T - w D ) * CR( 1, 1 ) = CA*A( 1, 1 ) - WR*D1 CR( 2, 2 ) = CA*A( 2, 2 ) - WR*D2 IF( LTRANS ) THEN CR( 1, 2 ) = CA*A( 2, 1 ) CR( 2, 1 ) = CA*A( 1, 2 ) ELSE CR( 2, 1 ) = CA*A( 2, 1 ) CR( 1, 2 ) = CA*A( 1, 2 ) END IF * IF( NW.EQ.1 ) THEN * * Real 2x2 system (w is real) * * Find the largest element in C * CMAX = ZERO ICMAX = 0 * DO 10 J = 1, 4 IF( ABS( CRV( J ) ).GT.CMAX ) THEN CMAX = ABS( CRV( J ) ) ICMAX = J END IF 10 CONTINUE * * If norm(C) < SMINI, use SMINI*identity. * IF( CMAX.LT.SMINI ) THEN BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 2, 1 ) ) ) IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN IF( BNORM.GT.BIGNUM*SMINI ) $ SCALE = ONE / BNORM END IF TEMP = SCALE / SMINI X( 1, 1 ) = TEMP*B( 1, 1 ) X( 2, 1 ) = TEMP*B( 2, 1 ) XNORM = TEMP*BNORM INFO = 1 RETURN END IF * * Gaussian elimination with complete pivoting. * UR11 = CRV( ICMAX ) CR21 = CRV( IPIVOT( 2, ICMAX ) ) UR12 = CRV( IPIVOT( 3, ICMAX ) ) CR22 = CRV( IPIVOT( 4, ICMAX ) ) UR11R = ONE / UR11 LR21 = UR11R*CR21 UR22 = CR22 - UR12*LR21 * * If smaller pivot < SMINI, use SMINI * IF( ABS( UR22 ).LT.SMINI ) THEN UR22 = SMINI INFO = 1 END IF IF( RSWAP( ICMAX ) ) THEN BR1 = B( 2, 1 ) BR2 = B( 1, 1 ) ELSE BR1 = B( 1, 1 ) BR2 = B( 2, 1 ) END IF BR2 = BR2 - LR21*BR1 BBND = MAX( ABS( BR1*( UR22*UR11R ) ), ABS( BR2 ) ) IF( BBND.GT.ONE .AND. ABS( UR22 ).LT.ONE ) THEN IF( BBND.GE.BIGNUM*ABS( UR22 ) ) $ SCALE = ONE / BBND END IF * XR2 = ( BR2*SCALE ) / UR22 XR1 = ( SCALE*BR1 )*UR11R - XR2*( UR11R*UR12 ) IF( ZSWAP( ICMAX ) ) THEN X( 1, 1 ) = XR2 X( 2, 1 ) = XR1 ELSE X( 1, 1 ) = XR1 X( 2, 1 ) = XR2 END IF XNORM = MAX( ABS( XR1 ), ABS( XR2 ) ) * * Further scaling if norm(A) norm(X) > overflow * IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN IF( XNORM.GT.BIGNUM / CMAX ) THEN TEMP = CMAX / BIGNUM X( 1, 1 ) = TEMP*X( 1, 1 ) X( 2, 1 ) = TEMP*X( 2, 1 ) XNORM = TEMP*XNORM SCALE = TEMP*SCALE END IF END IF ELSE * * Complex 2x2 system (w is complex) * * Find the largest element in C * CI( 1, 1 ) = -WI*D1 CI( 2, 1 ) = ZERO CI( 1, 2 ) = ZERO CI( 2, 2 ) = -WI*D2 CMAX = ZERO ICMAX = 0 * DO 20 J = 1, 4 IF( ABS( CRV( J ) )+ABS( CIV( J ) ).GT.CMAX ) THEN CMAX = ABS( CRV( J ) ) + ABS( CIV( J ) ) ICMAX = J END IF 20 CONTINUE * * If norm(C) < SMINI, use SMINI*identity. * IF( CMAX.LT.SMINI ) THEN BNORM = MAX( ABS( B( 1, 1 ) )+ABS( B( 1, 2 ) ), $ ABS( B( 2, 1 ) )+ABS( B( 2, 2 ) ) ) IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN IF( BNORM.GT.BIGNUM*SMINI ) $ SCALE = ONE / BNORM END IF TEMP = SCALE / SMINI X( 1, 1 ) = TEMP*B( 1, 1 ) X( 2, 1 ) = TEMP*B( 2, 1 ) X( 1, 2 ) = TEMP*B( 1, 2 ) X( 2, 2 ) = TEMP*B( 2, 2 ) XNORM = TEMP*BNORM INFO = 1 RETURN END IF * * Gaussian elimination with complete pivoting. * UR11 = CRV( ICMAX ) UI11 = CIV( ICMAX ) CR21 = CRV( IPIVOT( 2, ICMAX ) ) CI21 = CIV( IPIVOT( 2, ICMAX ) ) UR12 = CRV( IPIVOT( 3, ICMAX ) ) UI12 = CIV( IPIVOT( 3, ICMAX ) ) CR22 = CRV( IPIVOT( 4, ICMAX ) ) CI22 = CIV( IPIVOT( 4, ICMAX ) ) IF( ICMAX.EQ.1 .OR. ICMAX.EQ.4 ) THEN * * Code when off-diagonals of pivoted C are real * IF( ABS( UR11 ).GT.ABS( UI11 ) ) THEN TEMP = UI11 / UR11 UR11R = ONE / ( UR11*( ONE+TEMP**2 ) ) UI11R = -TEMP*UR11R ELSE TEMP = UR11 / UI11 UI11R = -ONE / ( UI11*( ONE+TEMP**2 ) ) UR11R = -TEMP*UI11R END IF LR21 = CR21*UR11R LI21 = CR21*UI11R UR12S = UR12*UR11R UI12S = UR12*UI11R UR22 = CR22 - UR12*LR21 UI22 = CI22 - UR12*LI21 ELSE * * Code when diagonals of pivoted C are real * UR11R = ONE / UR11 UI11R = ZERO LR21 = CR21*UR11R LI21 = CI21*UR11R UR12S = UR12*UR11R UI12S = UI12*UR11R UR22 = CR22 - UR12*LR21 + UI12*LI21 UI22 = -UR12*LI21 - UI12*LR21 END IF U22ABS = ABS( UR22 ) + ABS( UI22 ) * * If smaller pivot < SMINI, use SMINI * IF( U22ABS.LT.SMINI ) THEN UR22 = SMINI UI22 = ZERO INFO = 1 END IF IF( RSWAP( ICMAX ) ) THEN BR2 = B( 1, 1 ) BR1 = B( 2, 1 ) BI2 = B( 1, 2 ) BI1 = B( 2, 2 ) ELSE BR1 = B( 1, 1 ) BR2 = B( 2, 1 ) BI1 = B( 1, 2 ) BI2 = B( 2, 2 ) END IF BR2 = BR2 - LR21*BR1 + LI21*BI1 BI2 = BI2 - LI21*BR1 - LR21*BI1 BBND = MAX( ( ABS( BR1 )+ABS( BI1 ) )* $ ( U22ABS*( ABS( UR11R )+ABS( UI11R ) ) ), $ ABS( BR2 )+ABS( BI2 ) ) IF( BBND.GT.ONE .AND. U22ABS.LT.ONE ) THEN IF( BBND.GE.BIGNUM*U22ABS ) THEN SCALE = ONE / BBND BR1 = SCALE*BR1 BI1 = SCALE*BI1 BR2 = SCALE*BR2 BI2 = SCALE*BI2 END IF END IF * CALL DLADIV( BR2, BI2, UR22, UI22, XR2, XI2 ) XR1 = UR11R*BR1 - UI11R*BI1 - UR12S*XR2 + UI12S*XI2 XI1 = UI11R*BR1 + UR11R*BI1 - UI12S*XR2 - UR12S*XI2 IF( ZSWAP( ICMAX ) ) THEN X( 1, 1 ) = XR2 X( 2, 1 ) = XR1 X( 1, 2 ) = XI2 X( 2, 2 ) = XI1 ELSE X( 1, 1 ) = XR1 X( 2, 1 ) = XR2 X( 1, 2 ) = XI1 X( 2, 2 ) = XI2 END IF XNORM = MAX( ABS( XR1 )+ABS( XI1 ), ABS( XR2 )+ABS( XI2 ) ) * * Further scaling if norm(A) norm(X) > overflow * IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN IF( XNORM.GT.BIGNUM / CMAX ) THEN TEMP = CMAX / BIGNUM X( 1, 1 ) = TEMP*X( 1, 1 ) X( 2, 1 ) = TEMP*X( 2, 1 ) X( 1, 2 ) = TEMP*X( 1, 2 ) X( 2, 2 ) = TEMP*X( 2, 2 ) XNORM = TEMP*XNORM SCALE = TEMP*SCALE END IF END IF END IF END IF * RETURN * * End of DLALN2 * END *> \brief \b DLALS0 applies back multiplying factors in solving the least squares problem using divide and conquer SVD approach. Used by sgelsd. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLALS0 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 ) * * .. 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( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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). *> \endverbatim * * Arguments: * ========== * *> \param[in] ICOMPQ *> \verbatim *> ICOMPQ is INTEGER *> Specifies whether singular vectors are to be computed in *> factored form: *> = 0: Left singular vector matrix. *> = 1: Right singular vector matrix. *> \endverbatim *> *> \param[in] NL *> \verbatim *> NL is INTEGER *> The row dimension of the upper block. NL >= 1. *> \endverbatim *> *> \param[in] NR *> \verbatim *> NR is INTEGER *> The row dimension of the lower block. NR >= 1. *> \endverbatim *> *> \param[in] SQRE *> \verbatim *> SQRE is 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. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of columns of B and BX. NRHS must be at least 1. *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is 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. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of B. LDB must be at least *> max(1,MAX( M, N ) ). *> \endverbatim *> *> \param[out] BX *> \verbatim *> BX is DOUBLE PRECISION array, dimension ( LDBX, NRHS ) *> \endverbatim *> *> \param[in] LDBX *> \verbatim *> LDBX is INTEGER *> The leading dimension of BX. *> \endverbatim *> *> \param[in] PERM *> \verbatim *> PERM is INTEGER array, dimension ( N ) *> The permutations (from deflation and sorting) applied *> to the two blocks. *> \endverbatim *> *> \param[in] GIVPTR *> \verbatim *> GIVPTR is INTEGER *> The number of Givens rotations which took place in this *> subproblem. *> \endverbatim *> *> \param[in] GIVCOL *> \verbatim *> GIVCOL is INTEGER array, dimension ( LDGCOL, 2 ) *> Each pair of numbers indicates a pair of rows/columns *> involved in a Givens rotation. *> \endverbatim *> *> \param[in] LDGCOL *> \verbatim *> LDGCOL is INTEGER *> The leading dimension of GIVCOL, must be at least N. *> \endverbatim *> *> \param[in] GIVNUM *> \verbatim *> GIVNUM is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) *> Each number indicates the C or S value used in the *> corresponding Givens rotation. *> \endverbatim *> *> \param[in] LDGNUM *> \verbatim *> LDGNUM is INTEGER *> The leading dimension of arrays DIFR, POLES and *> GIVNUM, must be at least K. *> \endverbatim *> *> \param[in] POLES *> \verbatim *> POLES is 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. *> \endverbatim *> *> \param[in] DIFL *> \verbatim *> DIFL is 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. *> \endverbatim *> *> \param[in] DIFR *> \verbatim *> DIFR is 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. *> \endverbatim *> *> \param[in] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension ( K ) *> Contain the components of the deflation-adjusted updating row *> vector. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> Contains the dimension of the non-deflated matrix, *> This is the order of the related secular equation. 1 <= K <=N. *> \endverbatim *> *> \param[in] C *> \verbatim *> C is 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. *> \endverbatim *> *> \param[in] S *> \verbatim *> S is 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. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension ( K ) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Contributors: * ================== *> *> Ming Gu and Ren-Cang Li, Computer Science Division, University of *> California at Berkeley, USA \n *> Osni Marques, LBNL/NERSC, USA \n * * ===================================================================== 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 computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. 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( * ) * .. * * ===================================================================== * * .. 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 N = NL + NR + 1 * 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 ELSE 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 *> \brief \b DLALSA computes the SVD of the coefficient matrix in compact form. Used by sgelsd. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLALSA + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * 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 ) * * .. 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, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] ICOMPQ *> \verbatim *> ICOMPQ is INTEGER *> Specifies whether the left or the right singular vector *> matrix is involved. *> = 0: Left singular vector matrix *> = 1: Right singular vector matrix *> \endverbatim *> *> \param[in] SMLSIZ *> \verbatim *> SMLSIZ is INTEGER *> The maximum size of the subproblems at the bottom of the *> computation tree. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The row and column dimensions of the upper bidiagonal matrix. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of columns of B and BX. NRHS must be at least 1. *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is 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. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of B in the calling subprogram. *> LDB must be at least max(1,MAX( M, N ) ). *> \endverbatim *> *> \param[out] BX *> \verbatim *> BX is DOUBLE PRECISION array, dimension ( LDBX, NRHS ) *> On exit, the result of applying the left or right singular *> vector matrix to B. *> \endverbatim *> *> \param[in] LDBX *> \verbatim *> LDBX is INTEGER *> The leading dimension of BX. *> \endverbatim *> *> \param[in] U *> \verbatim *> U is DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ). *> On entry, U contains the left singular vector matrices of all *> subproblems at the bottom level. *> \endverbatim *> *> \param[in] LDU *> \verbatim *> LDU is INTEGER, LDU = > N. *> The leading dimension of arrays U, VT, DIFL, DIFR, *> POLES, GIVNUM, and Z. *> \endverbatim *> *> \param[in] VT *> \verbatim *> VT is DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ). *> On entry, VT**T contains the right singular vector matrices of *> all subproblems at the bottom level. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER array, dimension ( N ). *> \endverbatim *> *> \param[in] DIFL *> \verbatim *> DIFL is DOUBLE PRECISION array, dimension ( LDU, NLVL ). *> where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1. *> \endverbatim *> *> \param[in] DIFR *> \verbatim *> DIFR is 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. *> \endverbatim *> *> \param[in] Z *> \verbatim *> Z is 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. *> \endverbatim *> *> \param[in] POLES *> \verbatim *> POLES is 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. *> \endverbatim *> *> \param[in] GIVPTR *> \verbatim *> GIVPTR is INTEGER array, dimension ( N ). *> On entry, GIVPTR( I ) records the number of Givens *> rotations performed on the I-th problem on the computation *> tree. *> \endverbatim *> *> \param[in] GIVCOL *> \verbatim *> GIVCOL is 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. *> \endverbatim *> *> \param[in] LDGCOL *> \verbatim *> LDGCOL is INTEGER, LDGCOL = > N. *> The leading dimension of arrays GIVCOL and PERM. *> \endverbatim *> *> \param[in] PERM *> \verbatim *> PERM is INTEGER array, dimension ( LDGCOL, NLVL ). *> On entry, PERM(*, I) records permutations done on the I-th *> level of the computation tree. *> \endverbatim *> *> \param[in] GIVNUM *> \verbatim *> GIVNUM is 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. *> \endverbatim *> *> \param[in] C *> \verbatim *> C is 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. *> \endverbatim *> *> \param[in] S *> \verbatim *> S is 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. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (3*N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup doubleOTHERcomputational * *> \par Contributors: * ================== *> *> Ming Gu and Ren-Cang Li, Computer Science Division, University of *> California at Berkeley, USA \n *> Osni Marques, LBNL/NERSC, USA \n * * ===================================================================== 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 computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. 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, * ) * .. * * ===================================================================== * * .. 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 *> \brief \b DLALSD uses the singular value decomposition of A to solve the least squares problem. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLALSD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, * RANK, WORK, IWORK, INFO ) * * .. 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( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': D and E define an upper bidiagonal matrix. *> = 'L': D and E define a lower bidiagonal matrix. *> \endverbatim *> *> \param[in] SMLSIZ *> \verbatim *> SMLSIZ is INTEGER *> The maximum size of the subproblems at the bottom of the *> computation tree. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The dimension of the bidiagonal matrix. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of columns of B. NRHS must be at least 1. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is 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. *> \endverbatim *> *> \param[in,out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N-1) *> Contains the super-diagonal entries of the bidiagonal matrix. *> On exit, E has been destroyed. *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is 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. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of B in the calling subprogram. *> LDB must be at least max(1,N). *> \endverbatim *> *> \param[in] RCOND *> \verbatim *> RCOND is 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). *> \endverbatim *> *> \param[out] RANK *> \verbatim *> RANK is INTEGER *> The number of singular values of A greater than RCOND times *> the largest singular value. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is 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). *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension at least *> (3*N*NLVL + 11*N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: The algorithm failed to compute a singular value while *> working on the submatrix lying in rows and columns *> INFO/(N+1) through MOD(INFO,N+1). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Contributors: * ================== *> *> Ming Gu and Ren-Cang Li, Computer Science Division, University of *> California at Berkeley, USA \n *> Osni Marques, LBNL/NERSC, USA \n * * ===================================================================== SUBROUTINE DLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, $ RANK, WORK, IWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDB, N, NRHS, RANK, SMLSIZ DOUBLE PRECISION RCOND * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION B( LDB, * ), D( * ), E( * ), WORK( * ) * .. * * ===================================================================== * * .. 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 *> \brief \b DLAMRG creates a permutation list to merge the entries of two independently sorted sets into a single set sorted in ascending order. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAMRG + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX ) * * .. Scalar Arguments .. * INTEGER DTRD1, DTRD2, N1, N2 * .. * .. Array Arguments .. * INTEGER INDEX( * ) * DOUBLE PRECISION A( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] N1 *> \verbatim *> N1 is INTEGER *> \endverbatim *> *> \param[in] N2 *> \verbatim *> N2 is INTEGER *> These arguments contain the respective lengths of the two *> sorted lists to be merged. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is 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. *> \endverbatim *> *> \param[in] DTRD1 *> \verbatim *> DTRD1 is INTEGER *> \endverbatim *> *> \param[in] DTRD2 *> \verbatim *> DTRD2 is 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. *> \endverbatim *> *> \param[out] INDEX *> \verbatim *> INDEX is 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. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. INTEGER DTRD1, DTRD2, N1, N2 * .. * .. Array Arguments .. INTEGER INDEX( * ) DOUBLE PRECISION A( * ) * .. * * ===================================================================== * * .. 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 *> \brief \b DLANEG computes the Sturm count. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLANEG + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION DLANEG( N, D, LLD, SIGMA, PIVMIN, R ) * * .. Scalar Arguments .. * INTEGER N, R * DOUBLE PRECISION PIVMIN, SIGMA * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), LLD( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLANEG computes the Sturm count, the number of negative pivots *> encountered while factoring tridiagonal T - sigma I = L D L^T. *> This implementation works directly on the factors without forming *> the tridiagonal matrix T. The Sturm count is also the number of *> eigenvalues of T less than sigma. *> *> This routine is called from DLARRB. *> *> The current routine does not use the PIVMIN parameter but rather *> requires IEEE-754 propagation of Infinities and NaNs. This *> routine also has no input range restrictions but does require *> default exception handling such that x/0 produces Inf when x is *> non-zero, and Inf/Inf produces NaN. For more information, see: *> *> Marques, Riedy, and Voemel, "Benefits of IEEE-754 Features in *> Modern Symmetric Tridiagonal Eigensolvers," SIAM Journal on *> Scientific Computing, v28, n5, 2006. DOI 10.1137/050641624 *> (Tech report version in LAWN 172 with the same title.) *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The N diagonal elements of the diagonal matrix D. *> \endverbatim *> *> \param[in] LLD *> \verbatim *> LLD is DOUBLE PRECISION array, dimension (N-1) *> The (N-1) elements L(i)*L(i)*D(i). *> \endverbatim *> *> \param[in] SIGMA *> \verbatim *> SIGMA is DOUBLE PRECISION *> Shift amount in T - sigma I = L D L^T. *> \endverbatim *> *> \param[in] PIVMIN *> \verbatim *> PIVMIN is DOUBLE PRECISION *> The minimum pivot in the Sturm sequence. May be used *> when zero pivots are encountered on non-IEEE-754 *> architectures. *> \endverbatim *> *> \param[in] R *> \verbatim *> R is INTEGER *> The twist index for the twisted factorization that is used *> for the negcount. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * *> \par Contributors: * ================== *> *> Osni Marques, LBNL/NERSC, USA \n *> Christof Voemel, University of California, Berkeley, USA \n *> Jason Riedy, University of California, Berkeley, USA \n *> * ===================================================================== INTEGER FUNCTION DLANEG( N, D, LLD, SIGMA, PIVMIN, R ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER N, R DOUBLE PRECISION PIVMIN, SIGMA * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), LLD( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * Some architectures propagate Infinities and NaNs very slowly, so * the code computes counts in BLKLEN chunks. Then a NaN can * propagate at most BLKLEN columns before being detected. This is * not a general tuning parameter; it needs only to be just large * enough that the overhead is tiny in common cases. INTEGER BLKLEN PARAMETER ( BLKLEN = 128 ) * .. * .. Local Scalars .. INTEGER BJ, J, NEG1, NEG2, NEGCNT DOUBLE PRECISION BSAV, DMINUS, DPLUS, GAMMA, P, T, TMP LOGICAL SAWNAN * .. * .. Intrinsic Functions .. INTRINSIC MIN, MAX * .. * .. External Functions .. LOGICAL DISNAN EXTERNAL DISNAN * .. * .. Executable Statements .. NEGCNT = 0 * I) upper part: L D L^T - SIGMA I = L+ D+ L+^T T = -SIGMA DO 210 BJ = 1, R-1, BLKLEN NEG1 = 0 BSAV = T DO 21 J = BJ, MIN(BJ+BLKLEN-1, R-1) DPLUS = D( J ) + T IF( DPLUS.LT.ZERO ) NEG1 = NEG1 + 1 TMP = T / DPLUS T = TMP * LLD( J ) - SIGMA 21 CONTINUE SAWNAN = DISNAN( T ) * Run a slower version of the above loop if a NaN is detected. * A NaN should occur only with a zero pivot after an infinite * pivot. In that case, substituting 1 for T/DPLUS is the * correct limit. IF( SAWNAN ) THEN NEG1 = 0 T = BSAV DO 22 J = BJ, MIN(BJ+BLKLEN-1, R-1) DPLUS = D( J ) + T IF( DPLUS.LT.ZERO ) NEG1 = NEG1 + 1 TMP = T / DPLUS IF (DISNAN(TMP)) TMP = ONE T = TMP * LLD(J) - SIGMA 22 CONTINUE END IF NEGCNT = NEGCNT + NEG1 210 CONTINUE * * II) lower part: L D L^T - SIGMA I = U- D- U-^T P = D( N ) - SIGMA DO 230 BJ = N-1, R, -BLKLEN NEG2 = 0 BSAV = P DO 23 J = BJ, MAX(BJ-BLKLEN+1, R), -1 DMINUS = LLD( J ) + P IF( DMINUS.LT.ZERO ) NEG2 = NEG2 + 1 TMP = P / DMINUS P = TMP * D( J ) - SIGMA 23 CONTINUE SAWNAN = DISNAN( P ) * As above, run a slower version that substitutes 1 for Inf/Inf. * IF( SAWNAN ) THEN NEG2 = 0 P = BSAV DO 24 J = BJ, MAX(BJ-BLKLEN+1, R), -1 DMINUS = LLD( J ) + P IF( DMINUS.LT.ZERO ) NEG2 = NEG2 + 1 TMP = P / DMINUS IF (DISNAN(TMP)) TMP = ONE P = TMP * D(J) - SIGMA 24 CONTINUE END IF NEGCNT = NEGCNT + NEG2 230 CONTINUE * * III) Twist index * T was shifted by SIGMA initially. GAMMA = (T + SIGMA) + P IF( GAMMA.LT.ZERO ) NEGCNT = NEGCNT+1 DLANEG = NEGCNT END *> \brief \b DLANGB returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of general band matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLANGB + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLANGB( NORM, N, KL, KU, AB, LDAB, * WORK ) * * .. Scalar Arguments .. * CHARACTER NORM * INTEGER KL, KU, LDAB, N * .. * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLANGB returns the value of the one norm, or the Frobenius norm, or *> the infinity norm, or the element of largest absolute value of an *> n by n band matrix A, with kl sub-diagonals and ku super-diagonals. *> \endverbatim *> *> \return DLANGB *> \verbatim *> *> DLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm' *> ( *> ( norm1(A), NORM = '1', 'O' or 'o' *> ( *> ( normI(A), NORM = 'I' or 'i' *> ( *> ( normF(A), NORM = 'F', 'f', 'E' or 'e' *> *> where norm1 denotes the one norm of a matrix (maximum column sum), *> normI denotes the infinity norm of a matrix (maximum row sum) and *> normF denotes the Frobenius norm of a matrix (square root of sum of *> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. *> \endverbatim * * Arguments: * ========== * *> \param[in] NORM *> \verbatim *> NORM is CHARACTER*1 *> Specifies the value to be returned in DLANGB as described *> above. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. When N = 0, DLANGB is *> set to zero. *> \endverbatim *> *> \param[in] KL *> \verbatim *> KL is INTEGER *> The number of sub-diagonals of the matrix A. KL >= 0. *> \endverbatim *> *> \param[in] KU *> \verbatim *> KU is INTEGER *> The number of super-diagonals of the matrix A. KU >= 0. *> \endverbatim *> *> \param[in] AB *> \verbatim *> AB is 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(n,j+kl). *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array AB. LDAB >= KL+KU+1. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), *> where LWORK >= N when NORM = 'I'; otherwise, WORK is not *> referenced. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGBauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLANGB( NORM, N, KL, KU, AB, LDAB, $ WORK ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER NORM INTEGER KL, KU, LDAB, N * .. * .. Array Arguments .. DOUBLE PRECISION AB( LDAB, * ), WORK( * ) * .. * * ===================================================================== * * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J, K, L DOUBLE PRECISION SCALE, SUM, VALUE, TEMP * .. * .. External Subroutines .. EXTERNAL DLASSQ * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Executable Statements .. * IF( N.EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * VALUE = ZERO DO 20 J = 1, N DO 10 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 ) TEMP = ABS( AB( I, J ) ) IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP 10 CONTINUE 20 CONTINUE ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN * * Find norm1(A). * VALUE = ZERO DO 40 J = 1, N SUM = ZERO DO 30 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 ) SUM = SUM + ABS( AB( I, J ) ) 30 CONTINUE IF( VALUE.LT.SUM .OR. DISNAN( SUM ) ) VALUE = SUM 40 CONTINUE ELSE IF( LSAME( NORM, 'I' ) ) THEN * * Find normI(A). * DO 50 I = 1, N WORK( I ) = ZERO 50 CONTINUE DO 70 J = 1, N K = KU + 1 - J DO 60 I = MAX( 1, J-KU ), MIN( N, J+KL ) WORK( I ) = WORK( I ) + ABS( AB( K+I, J ) ) 60 CONTINUE 70 CONTINUE VALUE = ZERO DO 80 I = 1, N TEMP = WORK( I ) IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP 80 CONTINUE ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE DO 90 J = 1, N L = MAX( 1, J-KU ) K = KU + 1 - J + L CALL DLASSQ( MIN( N, J+KL )-L+1, AB( K, J ), 1, SCALE, SUM ) 90 CONTINUE VALUE = SCALE*SQRT( SUM ) END IF * DLANGB = VALUE RETURN * * End of DLANGB * END *> \brief \b DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of a general rectangular matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLANGE + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) * * .. Scalar Arguments .. * CHARACTER NORM * INTEGER LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLANGE returns the value of the one norm, or the Frobenius norm, or *> the infinity norm, or the element of largest absolute value of a *> real matrix A. *> \endverbatim *> *> \return DLANGE *> \verbatim *> *> DLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' *> ( *> ( norm1(A), NORM = '1', 'O' or 'o' *> ( *> ( normI(A), NORM = 'I' or 'i' *> ( *> ( normF(A), NORM = 'F', 'f', 'E' or 'e' *> *> where norm1 denotes the one norm of a matrix (maximum column sum), *> normI denotes the infinity norm of a matrix (maximum row sum) and *> normF denotes the Frobenius norm of a matrix (square root of sum of *> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. *> \endverbatim * * Arguments: * ========== * *> \param[in] NORM *> \verbatim *> NORM is CHARACTER*1 *> Specifies the value to be returned in DLANGE as described *> above. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. When M = 0, *> DLANGE is set to zero. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. When N = 0, *> DLANGE is set to zero. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The m by n matrix A. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(M,1). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), *> where LWORK >= M when NORM = 'I'; otherwise, WORK is not *> referenced. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER NORM INTEGER LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION SCALE, SUM, VALUE, TEMP * .. * .. External Subroutines .. EXTERNAL DLASSQ * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. * .. Intrinsic Functions .. INTRINSIC ABS, MIN, SQRT * .. * .. Executable Statements .. * IF( MIN( M, N ).EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * VALUE = ZERO DO 20 J = 1, N DO 10 I = 1, M TEMP = ABS( A( I, J ) ) IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP 10 CONTINUE 20 CONTINUE ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN * * Find norm1(A). * VALUE = ZERO DO 40 J = 1, N SUM = ZERO DO 30 I = 1, M SUM = SUM + ABS( A( I, J ) ) 30 CONTINUE IF( VALUE.LT.SUM .OR. DISNAN( SUM ) ) VALUE = SUM 40 CONTINUE ELSE IF( LSAME( NORM, 'I' ) ) THEN * * Find normI(A). * DO 50 I = 1, M WORK( I ) = ZERO 50 CONTINUE DO 70 J = 1, N DO 60 I = 1, M WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 60 CONTINUE 70 CONTINUE VALUE = ZERO DO 80 I = 1, M TEMP = WORK( I ) IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP 80 CONTINUE ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE DO 90 J = 1, N CALL DLASSQ( M, A( 1, J ), 1, SCALE, SUM ) 90 CONTINUE VALUE = SCALE*SQRT( SUM ) END IF * DLANGE = VALUE RETURN * * End of DLANGE * END *> \brief \b DLANGT returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of a general tridiagonal matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLANGT + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLANGT( NORM, N, DL, D, DU ) * * .. Scalar Arguments .. * CHARACTER NORM * INTEGER N * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), DL( * ), DU( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLANGT returns the value of the one norm, or the Frobenius norm, or *> the infinity norm, or the element of largest absolute value of a *> real tridiagonal matrix A. *> \endverbatim *> *> \return DLANGT *> \verbatim *> *> DLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm' *> ( *> ( norm1(A), NORM = '1', 'O' or 'o' *> ( *> ( normI(A), NORM = 'I' or 'i' *> ( *> ( normF(A), NORM = 'F', 'f', 'E' or 'e' *> *> where norm1 denotes the one norm of a matrix (maximum column sum), *> normI denotes the infinity norm of a matrix (maximum row sum) and *> normF denotes the Frobenius norm of a matrix (square root of sum of *> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. *> \endverbatim * * Arguments: * ========== * *> \param[in] NORM *> \verbatim *> NORM is CHARACTER*1 *> Specifies the value to be returned in DLANGT as described *> above. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. When N = 0, DLANGT is *> set to zero. *> \endverbatim *> *> \param[in] DL *> \verbatim *> DL is DOUBLE PRECISION array, dimension (N-1) *> The (n-1) sub-diagonal elements of A. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The diagonal elements of A. *> \endverbatim *> *> \param[in] DU *> \verbatim *> DU is DOUBLE PRECISION array, dimension (N-1) *> The (n-1) super-diagonal elements of A. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLANGT( NORM, N, DL, D, DU ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER NORM INTEGER N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), DL( * ), DU( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I DOUBLE PRECISION ANORM, SCALE, SUM, TEMP * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. * .. External Subroutines .. EXTERNAL DLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT * .. * .. Executable Statements .. * IF( N.LE.0 ) THEN ANORM = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * ANORM = ABS( D( N ) ) DO 10 I = 1, N - 1 IF( ANORM.LT.ABS( DL( I ) ) .OR. DISNAN( ABS( DL( I ) ) ) ) $ ANORM = ABS(DL(I)) IF( ANORM.LT.ABS( D( I ) ) .OR. DISNAN( ABS( D( I ) ) ) ) $ ANORM = ABS(D(I)) IF( ANORM.LT.ABS( DU( I ) ) .OR. DISNAN (ABS( DU( I ) ) ) ) $ ANORM = ABS(DU(I)) 10 CONTINUE ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' ) THEN * * Find norm1(A). * IF( N.EQ.1 ) THEN ANORM = ABS( D( 1 ) ) ELSE ANORM = ABS( D( 1 ) )+ABS( DL( 1 ) ) TEMP = ABS( D( N ) )+ABS( DU( N-1 ) ) IF( ANORM .LT. TEMP .OR. DISNAN( TEMP ) ) ANORM = TEMP DO 20 I = 2, N - 1 TEMP = ABS( D( I ) )+ABS( DL( I ) )+ABS( DU( I-1 ) ) IF( ANORM .LT. TEMP .OR. DISNAN( TEMP ) ) ANORM = TEMP 20 CONTINUE END IF ELSE IF( LSAME( NORM, 'I' ) ) THEN * * Find normI(A). * IF( N.EQ.1 ) THEN ANORM = ABS( D( 1 ) ) ELSE ANORM = ABS( D( 1 ) )+ABS( DU( 1 ) ) TEMP = ABS( D( N ) )+ABS( DL( N-1 ) ) IF( ANORM .LT. TEMP .OR. DISNAN( TEMP ) ) ANORM = TEMP DO 30 I = 2, N - 1 TEMP = ABS( D( I ) )+ABS( DU( I ) )+ABS( DL( I-1 ) ) IF( ANORM .LT. TEMP .OR. DISNAN( TEMP ) ) ANORM = TEMP 30 CONTINUE END IF ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE CALL DLASSQ( N, D, 1, SCALE, SUM ) IF( N.GT.1 ) THEN CALL DLASSQ( N-1, DL, 1, SCALE, SUM ) CALL DLASSQ( N-1, DU, 1, SCALE, SUM ) END IF ANORM = SCALE*SQRT( SUM ) END IF * DLANGT = ANORM RETURN * * End of DLANGT * END *> \brief \b DLANHS returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of an upper Hessenberg matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLANHS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK ) * * .. Scalar Arguments .. * CHARACTER NORM * INTEGER LDA, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLANHS returns the value of the one norm, or the Frobenius norm, or *> the infinity norm, or the element of largest absolute value of a *> Hessenberg matrix A. *> \endverbatim *> *> \return DLANHS *> \verbatim *> *> DLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm' *> ( *> ( norm1(A), NORM = '1', 'O' or 'o' *> ( *> ( normI(A), NORM = 'I' or 'i' *> ( *> ( normF(A), NORM = 'F', 'f', 'E' or 'e' *> *> where norm1 denotes the one norm of a matrix (maximum column sum), *> normI denotes the infinity norm of a matrix (maximum row sum) and *> normF denotes the Frobenius norm of a matrix (square root of sum of *> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. *> \endverbatim * * Arguments: * ========== * *> \param[in] NORM *> \verbatim *> NORM is CHARACTER*1 *> Specifies the value to be returned in DLANHS as described *> above. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. When N = 0, DLANHS is *> set to zero. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The n by n upper Hessenberg matrix A; the part of A below the *> first sub-diagonal is not referenced. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(N,1). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), *> where LWORK >= N when NORM = 'I'; otherwise, WORK is not *> referenced. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER NORM INTEGER LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION SCALE, SUM, VALUE * .. * .. External Subroutines .. EXTERNAL DLASSQ * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. * .. Intrinsic Functions .. INTRINSIC ABS, MIN, SQRT * .. * .. Executable Statements .. * IF( N.EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * VALUE = ZERO DO 20 J = 1, N DO 10 I = 1, MIN( N, J+1 ) SUM = ABS( A( I, J ) ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 10 CONTINUE 20 CONTINUE ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN * * Find norm1(A). * VALUE = ZERO DO 40 J = 1, N SUM = ZERO DO 30 I = 1, MIN( N, J+1 ) SUM = SUM + ABS( A( I, J ) ) 30 CONTINUE IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 40 CONTINUE ELSE IF( LSAME( NORM, 'I' ) ) THEN * * Find normI(A). * DO 50 I = 1, N WORK( I ) = ZERO 50 CONTINUE DO 70 J = 1, N DO 60 I = 1, MIN( N, J+1 ) WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 60 CONTINUE 70 CONTINUE VALUE = ZERO DO 80 I = 1, N SUM = WORK( I ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 80 CONTINUE ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE DO 90 J = 1, N CALL DLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM ) 90 CONTINUE VALUE = SCALE*SQRT( SUM ) END IF * DLANHS = VALUE RETURN * * End of DLANHS * END *> \brief \b DLANSB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a symmetric band matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLANSB + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLANSB( NORM, UPLO, N, K, AB, LDAB, * WORK ) * * .. Scalar Arguments .. * CHARACTER NORM, UPLO * INTEGER K, LDAB, N * .. * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLANSB returns the value of the one norm, or the Frobenius norm, or *> the infinity norm, or the element of largest absolute value of an *> n by n symmetric band matrix A, with k super-diagonals. *> \endverbatim *> *> \return DLANSB *> \verbatim *> *> DLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm' *> ( *> ( norm1(A), NORM = '1', 'O' or 'o' *> ( *> ( normI(A), NORM = 'I' or 'i' *> ( *> ( normF(A), NORM = 'F', 'f', 'E' or 'e' *> *> where norm1 denotes the one norm of a matrix (maximum column sum), *> normI denotes the infinity norm of a matrix (maximum row sum) and *> normF denotes the Frobenius norm of a matrix (square root of sum of *> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. *> \endverbatim * * Arguments: * ========== * *> \param[in] NORM *> \verbatim *> NORM is CHARACTER*1 *> Specifies the value to be returned in DLANSB as described *> above. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the upper or lower triangular part of the *> band matrix A is supplied. *> = 'U': Upper triangular part is supplied *> = 'L': Lower triangular part is supplied *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. When N = 0, DLANSB is *> set to zero. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The number of super-diagonals or sub-diagonals of the *> band matrix A. K >= 0. *> \endverbatim *> *> \param[in] AB *> \verbatim *> AB is DOUBLE PRECISION array, dimension (LDAB,N) *> The upper or lower triangle of the symmetric band matrix A, *> stored in the first K+1 rows of AB. The j-th column of A is *> stored in the j-th column of the array AB as follows: *> if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j; *> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k). *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array AB. LDAB >= K+1. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), *> where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, *> WORK is not referenced. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLANSB( NORM, UPLO, N, K, AB, LDAB, $ WORK ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER NORM, UPLO INTEGER K, LDAB, N * .. * .. Array Arguments .. DOUBLE PRECISION AB( LDAB, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J, L DOUBLE PRECISION ABSA, SCALE, SUM, VALUE * .. * .. External Subroutines .. EXTERNAL DLASSQ * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Executable Statements .. * IF( N.EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * VALUE = ZERO IF( LSAME( UPLO, 'U' ) ) THEN DO 20 J = 1, N DO 10 I = MAX( K+2-J, 1 ), K + 1 SUM = ABS( AB( I, J ) ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 10 CONTINUE 20 CONTINUE ELSE DO 40 J = 1, N DO 30 I = 1, MIN( N+1-J, K+1 ) SUM = ABS( AB( I, J ) ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 30 CONTINUE 40 CONTINUE END IF ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. $ ( NORM.EQ.'1' ) ) THEN * * Find normI(A) ( = norm1(A), since A is symmetric). * VALUE = ZERO IF( LSAME( UPLO, 'U' ) ) THEN DO 60 J = 1, N SUM = ZERO L = K + 1 - J DO 50 I = MAX( 1, J-K ), J - 1 ABSA = ABS( AB( L+I, J ) ) SUM = SUM + ABSA WORK( I ) = WORK( I ) + ABSA 50 CONTINUE WORK( J ) = SUM + ABS( AB( K+1, J ) ) 60 CONTINUE DO 70 I = 1, N SUM = WORK( I ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 70 CONTINUE ELSE DO 80 I = 1, N WORK( I ) = ZERO 80 CONTINUE DO 100 J = 1, N SUM = WORK( J ) + ABS( AB( 1, J ) ) L = 1 - J DO 90 I = J + 1, MIN( N, J+K ) ABSA = ABS( AB( L+I, J ) ) SUM = SUM + ABSA WORK( I ) = WORK( I ) + ABSA 90 CONTINUE IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 100 CONTINUE END IF ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE IF( K.GT.0 ) THEN IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 2, N CALL DLASSQ( MIN( J-1, K ), AB( MAX( K+2-J, 1 ), J ), $ 1, SCALE, SUM ) 110 CONTINUE L = K + 1 ELSE DO 120 J = 1, N - 1 CALL DLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE, $ SUM ) 120 CONTINUE L = 1 END IF SUM = 2*SUM ELSE L = 1 END IF CALL DLASSQ( N, AB( L, 1 ), LDAB, SCALE, SUM ) VALUE = SCALE*SQRT( SUM ) END IF * DLANSB = VALUE RETURN * * End of DLANSB * END *> \brief \b DLANSF returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a symmetric matrix in RFP format. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLANSF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLANSF( NORM, TRANSR, UPLO, N, A, WORK ) * * .. Scalar Arguments .. * CHARACTER NORM, TRANSR, UPLO * INTEGER N * .. * .. Array Arguments .. * DOUBLE PRECISION A( 0: * ), WORK( 0: * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLANSF returns the value of the one norm, or the Frobenius norm, or *> the infinity norm, or the element of largest absolute value of a *> real symmetric matrix A in RFP format. *> \endverbatim *> *> \return DLANSF *> \verbatim *> *> DLANSF = ( max(abs(A(i,j))), NORM = 'M' or 'm' *> ( *> ( norm1(A), NORM = '1', 'O' or 'o' *> ( *> ( normI(A), NORM = 'I' or 'i' *> ( *> ( normF(A), NORM = 'F', 'f', 'E' or 'e' *> *> where norm1 denotes the one norm of a matrix (maximum column sum), *> normI denotes the infinity norm of a matrix (maximum row sum) and *> normF denotes the Frobenius norm of a matrix (square root of sum of *> squares). Note that max(abs(A(i,j))) is not a matrix norm. *> \endverbatim * * Arguments: * ========== * *> \param[in] NORM *> \verbatim *> NORM is CHARACTER*1 *> Specifies the value to be returned in DLANSF as described *> above. *> \endverbatim *> *> \param[in] TRANSR *> \verbatim *> TRANSR is CHARACTER*1 *> Specifies whether the RFP format of A is normal or *> transposed format. *> = 'N': RFP format is Normal; *> = 'T': RFP format is Transpose. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> On entry, UPLO specifies whether the RFP matrix A came from *> an upper or lower triangular matrix as follows: *> = 'U': RFP A came from an upper triangular matrix; *> = 'L': RFP A came from a lower triangular matrix. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. When N = 0, DLANSF is *> set to zero. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension ( N*(N+1)/2 ); *> On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L') *> part of the symmetric matrix A stored in RFP format. See the *> "Notes" below for more details. *> Unchanged on exit. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), *> where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, *> WORK is not referenced. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> We first consider Rectangular Full Packed (RFP) Format when N is *> even. We give an example where N = 6. *> *> AP is Upper AP is Lower *> *> 00 01 02 03 04 05 00 *> 11 12 13 14 15 10 11 *> 22 23 24 25 20 21 22 *> 33 34 35 30 31 32 33 *> 44 45 40 41 42 43 44 *> 55 50 51 52 53 54 55 *> *> *> Let TRANSR = 'N'. RFP holds AP as follows: *> For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last *> three columns of AP upper. The lower triangle A(4:6,0:2) consists of *> the transpose of the first three columns of AP upper. *> For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first *> three columns of AP lower. The upper triangle A(0:2,0:2) consists of *> the transpose of the last three columns of AP lower. *> This covers the case N even and TRANSR = 'N'. *> *> RFP A RFP A *> *> 03 04 05 33 43 53 *> 13 14 15 00 44 54 *> 23 24 25 10 11 55 *> 33 34 35 20 21 22 *> 00 44 45 30 31 32 *> 01 11 55 40 41 42 *> 02 12 22 50 51 52 *> *> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the *> transpose of RFP A above. One therefore gets: *> *> *> RFP A RFP A *> *> 03 13 23 33 00 01 02 33 00 10 20 30 40 50 *> 04 14 24 34 44 11 12 43 44 11 21 31 41 51 *> 05 15 25 35 45 55 22 53 54 55 22 32 42 52 *> *> *> We then consider Rectangular Full Packed (RFP) Format when N is *> odd. We give an example where N = 5. *> *> AP is Upper AP is Lower *> *> 00 01 02 03 04 00 *> 11 12 13 14 10 11 *> 22 23 24 20 21 22 *> 33 34 30 31 32 33 *> 44 40 41 42 43 44 *> *> *> Let TRANSR = 'N'. RFP holds AP as follows: *> For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last *> three columns of AP upper. The lower triangle A(3:4,0:1) consists of *> the transpose of the first two columns of AP upper. *> For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first *> three columns of AP lower. The upper triangle A(0:1,1:2) consists of *> the transpose of the last two columns of AP lower. *> This covers the case N odd and TRANSR = 'N'. *> *> RFP A RFP A *> *> 02 03 04 00 33 43 *> 12 13 14 10 11 44 *> 22 23 24 20 21 22 *> 00 33 34 30 31 32 *> 01 11 44 40 41 42 *> *> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the *> transpose of RFP A above. One therefore gets: *> *> RFP A RFP A *> *> 02 12 22 00 01 00 10 20 30 40 50 *> 03 13 23 33 11 33 11 21 31 41 51 *> 04 14 24 34 44 43 44 22 32 42 52 *> \endverbatim * * ===================================================================== DOUBLE PRECISION FUNCTION DLANSF( NORM, TRANSR, UPLO, N, A, WORK ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER NORM, TRANSR, UPLO INTEGER N * .. * .. Array Arguments .. DOUBLE PRECISION A( 0: * ), WORK( 0: * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J, IFM, ILU, NOE, N1, K, L, LDA DOUBLE PRECISION SCALE, S, VALUE, AA, TEMP * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. * .. External Subroutines .. EXTERNAL DLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * IF( N.EQ.0 ) THEN DLANSF = ZERO RETURN ELSE IF( N.EQ.1 ) THEN DLANSF = ABS( A(0) ) RETURN END IF * * set noe = 1 if n is odd. if n is even set noe=0 * NOE = 1 IF( MOD( N, 2 ).EQ.0 ) $ NOE = 0 * * set ifm = 0 when form='T or 't' and 1 otherwise * IFM = 1 IF( LSAME( TRANSR, 'T' ) ) $ IFM = 0 * * set ilu = 0 when uplo='U or 'u' and 1 otherwise * ILU = 1 IF( LSAME( UPLO, 'U' ) ) $ ILU = 0 * * set lda = (n+1)/2 when ifm = 0 * set lda = n when ifm = 1 and noe = 1 * set lda = n+1 when ifm = 1 and noe = 0 * IF( IFM.EQ.1 ) THEN IF( NOE.EQ.1 ) THEN LDA = N ELSE * noe=0 LDA = N + 1 END IF ELSE * ifm=0 LDA = ( N+1 ) / 2 END IF * IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * K = ( N+1 ) / 2 VALUE = ZERO IF( NOE.EQ.1 ) THEN * n is odd IF( IFM.EQ.1 ) THEN * A is n by k DO J = 0, K - 1 DO I = 0, N - 1 TEMP = ABS( A( I+J*LDA ) ) IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) $ VALUE = TEMP END DO END DO ELSE * xpose case; A is k by n DO J = 0, N - 1 DO I = 0, K - 1 TEMP = ABS( A( I+J*LDA ) ) IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) $ VALUE = TEMP END DO END DO END IF ELSE * n is even IF( IFM.EQ.1 ) THEN * A is n+1 by k DO J = 0, K - 1 DO I = 0, N TEMP = ABS( A( I+J*LDA ) ) IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) $ VALUE = TEMP END DO END DO ELSE * xpose case; A is k by n+1 DO J = 0, N DO I = 0, K - 1 TEMP = ABS( A( I+J*LDA ) ) IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) $ VALUE = TEMP END DO END DO END IF END IF ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. $ ( NORM.EQ.'1' ) ) THEN * * Find normI(A) ( = norm1(A), since A is symmetric). * IF( IFM.EQ.1 ) THEN K = N / 2 IF( NOE.EQ.1 ) THEN * n is odd IF( ILU.EQ.0 ) THEN DO I = 0, K - 1 WORK( I ) = ZERO END DO DO J = 0, K S = ZERO DO I = 0, K + J - 1 AA = ABS( A( I+J*LDA ) ) * -> A(i,j+k) S = S + AA WORK( I ) = WORK( I ) + AA END DO AA = ABS( A( I+J*LDA ) ) * -> A(j+k,j+k) WORK( J+K ) = S + AA IF( I.EQ.K+K ) $ GO TO 10 I = I + 1 AA = ABS( A( I+J*LDA ) ) * -> A(j,j) WORK( J ) = WORK( J ) + AA S = ZERO DO L = J + 1, K - 1 I = I + 1 AA = ABS( A( I+J*LDA ) ) * -> A(l,j) S = S + AA WORK( L ) = WORK( L ) + AA END DO WORK( J ) = WORK( J ) + S END DO 10 CONTINUE VALUE = WORK( 0 ) DO I = 1, N-1 TEMP = WORK( I ) IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) $ VALUE = TEMP END DO ELSE * ilu = 1 K = K + 1 * k=(n+1)/2 for n odd and ilu=1 DO I = K, N - 1 WORK( I ) = ZERO END DO DO J = K - 1, 0, -1 S = ZERO DO I = 0, J - 2 AA = ABS( A( I+J*LDA ) ) * -> A(j+k,i+k) S = S + AA WORK( I+K ) = WORK( I+K ) + AA END DO IF( J.GT.0 ) THEN AA = ABS( A( I+J*LDA ) ) * -> A(j+k,j+k) S = S + AA WORK( I+K ) = WORK( I+K ) + S * i=j I = I + 1 END IF AA = ABS( A( I+J*LDA ) ) * -> A(j,j) WORK( J ) = AA S = ZERO DO L = J + 1, N - 1 I = I + 1 AA = ABS( A( I+J*LDA ) ) * -> A(l,j) S = S + AA WORK( L ) = WORK( L ) + AA END DO WORK( J ) = WORK( J ) + S END DO VALUE = WORK( 0 ) DO I = 1, N-1 TEMP = WORK( I ) IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) $ VALUE = TEMP END DO END IF ELSE * n is even IF( ILU.EQ.0 ) THEN DO I = 0, K - 1 WORK( I ) = ZERO END DO DO J = 0, K - 1 S = ZERO DO I = 0, K + J - 1 AA = ABS( A( I+J*LDA ) ) * -> A(i,j+k) S = S + AA WORK( I ) = WORK( I ) + AA END DO AA = ABS( A( I+J*LDA ) ) * -> A(j+k,j+k) WORK( J+K ) = S + AA I = I + 1 AA = ABS( A( I+J*LDA ) ) * -> A(j,j) WORK( J ) = WORK( J ) + AA S = ZERO DO L = J + 1, K - 1 I = I + 1 AA = ABS( A( I+J*LDA ) ) * -> A(l,j) S = S + AA WORK( L ) = WORK( L ) + AA END DO WORK( J ) = WORK( J ) + S END DO VALUE = WORK( 0 ) DO I = 1, N-1 TEMP = WORK( I ) IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) $ VALUE = TEMP END DO ELSE * ilu = 1 DO I = K, N - 1 WORK( I ) = ZERO END DO DO J = K - 1, 0, -1 S = ZERO DO I = 0, J - 1 AA = ABS( A( I+J*LDA ) ) * -> A(j+k,i+k) S = S + AA WORK( I+K ) = WORK( I+K ) + AA END DO AA = ABS( A( I+J*LDA ) ) * -> A(j+k,j+k) S = S + AA WORK( I+K ) = WORK( I+K ) + S * i=j I = I + 1 AA = ABS( A( I+J*LDA ) ) * -> A(j,j) WORK( J ) = AA S = ZERO DO L = J + 1, N - 1 I = I + 1 AA = ABS( A( I+J*LDA ) ) * -> A(l,j) S = S + AA WORK( L ) = WORK( L ) + AA END DO WORK( J ) = WORK( J ) + S END DO VALUE = WORK( 0 ) DO I = 1, N-1 TEMP = WORK( I ) IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) $ VALUE = TEMP END DO END IF END IF ELSE * ifm=0 K = N / 2 IF( NOE.EQ.1 ) THEN * n is odd IF( ILU.EQ.0 ) THEN N1 = K * n/2 K = K + 1 * k is the row size and lda DO I = N1, N - 1 WORK( I ) = ZERO END DO DO J = 0, N1 - 1 S = ZERO DO I = 0, K - 1 AA = ABS( A( I+J*LDA ) ) * A(j,n1+i) WORK( I+N1 ) = WORK( I+N1 ) + AA S = S + AA END DO WORK( J ) = S END DO * j=n1=k-1 is special S = ABS( A( 0+J*LDA ) ) * A(k-1,k-1) DO I = 1, K - 1 AA = ABS( A( I+J*LDA ) ) * A(k-1,i+n1) WORK( I+N1 ) = WORK( I+N1 ) + AA S = S + AA END DO WORK( J ) = WORK( J ) + S DO J = K, N - 1 S = ZERO DO I = 0, J - K - 1 AA = ABS( A( I+J*LDA ) ) * A(i,j-k) WORK( I ) = WORK( I ) + AA S = S + AA END DO * i=j-k AA = ABS( A( I+J*LDA ) ) * A(j-k,j-k) S = S + AA WORK( J-K ) = WORK( J-K ) + S I = I + 1 S = ABS( A( I+J*LDA ) ) * A(j,j) DO L = J + 1, N - 1 I = I + 1 AA = ABS( A( I+J*LDA ) ) * A(j,l) WORK( L ) = WORK( L ) + AA S = S + AA END DO WORK( J ) = WORK( J ) + S END DO VALUE = WORK( 0 ) DO I = 1, N-1 TEMP = WORK( I ) IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) $ VALUE = TEMP END DO ELSE * ilu=1 K = K + 1 * k=(n+1)/2 for n odd and ilu=1 DO I = K, N - 1 WORK( I ) = ZERO END DO DO J = 0, K - 2 * process S = ZERO DO I = 0, J - 1 AA = ABS( A( I+J*LDA ) ) * A(j,i) WORK( I ) = WORK( I ) + AA S = S + AA END DO AA = ABS( A( I+J*LDA ) ) * i=j so process of A(j,j) S = S + AA WORK( J ) = S * is initialised here I = I + 1 * i=j process A(j+k,j+k) AA = ABS( A( I+J*LDA ) ) S = AA DO L = K + J + 1, N - 1 I = I + 1 AA = ABS( A( I+J*LDA ) ) * A(l,k+j) S = S + AA WORK( L ) = WORK( L ) + AA END DO WORK( K+J ) = WORK( K+J ) + S END DO * j=k-1 is special :process col A(k-1,0:k-1) S = ZERO DO I = 0, K - 2 AA = ABS( A( I+J*LDA ) ) * A(k,i) WORK( I ) = WORK( I ) + AA S = S + AA END DO * i=k-1 AA = ABS( A( I+J*LDA ) ) * A(k-1,k-1) S = S + AA WORK( I ) = S * done with col j=k+1 DO J = K, N - 1 * process col j of A = A(j,0:k-1) S = ZERO DO I = 0, K - 1 AA = ABS( A( I+J*LDA ) ) * A(j,i) WORK( I ) = WORK( I ) + AA S = S + AA END DO WORK( J ) = WORK( J ) + S END DO VALUE = WORK( 0 ) DO I = 1, N-1 TEMP = WORK( I ) IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) $ VALUE = TEMP END DO END IF ELSE * n is even IF( ILU.EQ.0 ) THEN DO I = K, N - 1 WORK( I ) = ZERO END DO DO J = 0, K - 1 S = ZERO DO I = 0, K - 1 AA = ABS( A( I+J*LDA ) ) * A(j,i+k) WORK( I+K ) = WORK( I+K ) + AA S = S + AA END DO WORK( J ) = S END DO * j=k AA = ABS( A( 0+J*LDA ) ) * A(k,k) S = AA DO I = 1, K - 1 AA = ABS( A( I+J*LDA ) ) * A(k,k+i) WORK( I+K ) = WORK( I+K ) + AA S = S + AA END DO WORK( J ) = WORK( J ) + S DO J = K + 1, N - 1 S = ZERO DO I = 0, J - 2 - K AA = ABS( A( I+J*LDA ) ) * A(i,j-k-1) WORK( I ) = WORK( I ) + AA S = S + AA END DO * i=j-1-k AA = ABS( A( I+J*LDA ) ) * A(j-k-1,j-k-1) S = S + AA WORK( J-K-1 ) = WORK( J-K-1 ) + S I = I + 1 AA = ABS( A( I+J*LDA ) ) * A(j,j) S = AA DO L = J + 1, N - 1 I = I + 1 AA = ABS( A( I+J*LDA ) ) * A(j,l) WORK( L ) = WORK( L ) + AA S = S + AA END DO WORK( J ) = WORK( J ) + S END DO * j=n S = ZERO DO I = 0, K - 2 AA = ABS( A( I+J*LDA ) ) * A(i,k-1) WORK( I ) = WORK( I ) + AA S = S + AA END DO * i=k-1 AA = ABS( A( I+J*LDA ) ) * A(k-1,k-1) S = S + AA WORK( I ) = WORK( I ) + S VALUE = WORK( 0 ) DO I = 1, N-1 TEMP = WORK( I ) IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) $ VALUE = TEMP END DO ELSE * ilu=1 DO I = K, N - 1 WORK( I ) = ZERO END DO * j=0 is special :process col A(k:n-1,k) S = ABS( A( 0 ) ) * A(k,k) DO I = 1, K - 1 AA = ABS( A( I ) ) * A(k+i,k) WORK( I+K ) = WORK( I+K ) + AA S = S + AA END DO WORK( K ) = WORK( K ) + S DO J = 1, K - 1 * process S = ZERO DO I = 0, J - 2 AA = ABS( A( I+J*LDA ) ) * A(j-1,i) WORK( I ) = WORK( I ) + AA S = S + AA END DO AA = ABS( A( I+J*LDA ) ) * i=j-1 so process of A(j-1,j-1) S = S + AA WORK( J-1 ) = S * is initialised here I = I + 1 * i=j process A(j+k,j+k) AA = ABS( A( I+J*LDA ) ) S = AA DO L = K + J + 1, N - 1 I = I + 1 AA = ABS( A( I+J*LDA ) ) * A(l,k+j) S = S + AA WORK( L ) = WORK( L ) + AA END DO WORK( K+J ) = WORK( K+J ) + S END DO * j=k is special :process col A(k,0:k-1) S = ZERO DO I = 0, K - 2 AA = ABS( A( I+J*LDA ) ) * A(k,i) WORK( I ) = WORK( I ) + AA S = S + AA END DO * i=k-1 AA = ABS( A( I+J*LDA ) ) * A(k-1,k-1) S = S + AA WORK( I ) = S * done with col j=k+1 DO J = K + 1, N * process col j-1 of A = A(j-1,0:k-1) S = ZERO DO I = 0, K - 1 AA = ABS( A( I+J*LDA ) ) * A(j-1,i) WORK( I ) = WORK( I ) + AA S = S + AA END DO WORK( J-1 ) = WORK( J-1 ) + S END DO VALUE = WORK( 0 ) DO I = 1, N-1 TEMP = WORK( I ) IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) $ VALUE = TEMP END DO END IF END IF END IF ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * K = ( N+1 ) / 2 SCALE = ZERO S = ONE IF( NOE.EQ.1 ) THEN * n is odd IF( IFM.EQ.1 ) THEN * A is normal IF( ILU.EQ.0 ) THEN * A is upper DO J = 0, K - 3 CALL DLASSQ( K-J-2, A( K+J+1+J*LDA ), 1, SCALE, S ) * L at A(k,0) END DO DO J = 0, K - 1 CALL DLASSQ( K+J-1, A( 0+J*LDA ), 1, SCALE, S ) * trap U at A(0,0) END DO S = S + S * double s for the off diagonal elements CALL DLASSQ( K-1, A( K ), LDA+1, SCALE, S ) * tri L at A(k,0) CALL DLASSQ( K, A( K-1 ), LDA+1, SCALE, S ) * tri U at A(k-1,0) ELSE * ilu=1 & A is lower DO J = 0, K - 1 CALL DLASSQ( N-J-1, A( J+1+J*LDA ), 1, SCALE, S ) * trap L at A(0,0) END DO DO J = 0, K - 2 CALL DLASSQ( J, A( 0+( 1+J )*LDA ), 1, SCALE, S ) * U at A(0,1) END DO S = S + S * double s for the off diagonal elements CALL DLASSQ( K, A( 0 ), LDA+1, SCALE, S ) * tri L at A(0,0) CALL DLASSQ( K-1, A( 0+LDA ), LDA+1, SCALE, S ) * tri U at A(0,1) END IF ELSE * A is xpose IF( ILU.EQ.0 ) THEN * A**T is upper DO J = 1, K - 2 CALL DLASSQ( J, A( 0+( K+J )*LDA ), 1, SCALE, S ) * U at A(0,k) END DO DO J = 0, K - 2 CALL DLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) * k by k-1 rect. at A(0,0) END DO DO J = 0, K - 2 CALL DLASSQ( K-J-1, A( J+1+( J+K-1 )*LDA ), 1, $ SCALE, S ) * L at A(0,k-1) END DO S = S + S * double s for the off diagonal elements CALL DLASSQ( K-1, A( 0+K*LDA ), LDA+1, SCALE, S ) * tri U at A(0,k) CALL DLASSQ( K, A( 0+( K-1 )*LDA ), LDA+1, SCALE, S ) * tri L at A(0,k-1) ELSE * A**T is lower DO J = 1, K - 1 CALL DLASSQ( J, A( 0+J*LDA ), 1, SCALE, S ) * U at A(0,0) END DO DO J = K, N - 1 CALL DLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) * k by k-1 rect. at A(0,k) END DO DO J = 0, K - 3 CALL DLASSQ( K-J-2, A( J+2+J*LDA ), 1, SCALE, S ) * L at A(1,0) END DO S = S + S * double s for the off diagonal elements CALL DLASSQ( K, A( 0 ), LDA+1, SCALE, S ) * tri U at A(0,0) CALL DLASSQ( K-1, A( 1 ), LDA+1, SCALE, S ) * tri L at A(1,0) END IF END IF ELSE * n is even IF( IFM.EQ.1 ) THEN * A is normal IF( ILU.EQ.0 ) THEN * A is upper DO J = 0, K - 2 CALL DLASSQ( K-J-1, A( K+J+2+J*LDA ), 1, SCALE, S ) * L at A(k+1,0) END DO DO J = 0, K - 1 CALL DLASSQ( K+J, A( 0+J*LDA ), 1, SCALE, S ) * trap U at A(0,0) END DO S = S + S * double s for the off diagonal elements CALL DLASSQ( K, A( K+1 ), LDA+1, SCALE, S ) * tri L at A(k+1,0) CALL DLASSQ( K, A( K ), LDA+1, SCALE, S ) * tri U at A(k,0) ELSE * ilu=1 & A is lower DO J = 0, K - 1 CALL DLASSQ( N-J-1, A( J+2+J*LDA ), 1, SCALE, S ) * trap L at A(1,0) END DO DO J = 1, K - 1 CALL DLASSQ( J, A( 0+J*LDA ), 1, SCALE, S ) * U at A(0,0) END DO S = S + S * double s for the off diagonal elements CALL DLASSQ( K, A( 1 ), LDA+1, SCALE, S ) * tri L at A(1,0) CALL DLASSQ( K, A( 0 ), LDA+1, SCALE, S ) * tri U at A(0,0) END IF ELSE * A is xpose IF( ILU.EQ.0 ) THEN * A**T is upper DO J = 1, K - 1 CALL DLASSQ( J, A( 0+( K+1+J )*LDA ), 1, SCALE, S ) * U at A(0,k+1) END DO DO J = 0, K - 1 CALL DLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) * k by k rect. at A(0,0) END DO DO J = 0, K - 2 CALL DLASSQ( K-J-1, A( J+1+( J+K )*LDA ), 1, SCALE, $ S ) * L at A(0,k) END DO S = S + S * double s for the off diagonal elements CALL DLASSQ( K, A( 0+( K+1 )*LDA ), LDA+1, SCALE, S ) * tri U at A(0,k+1) CALL DLASSQ( K, A( 0+K*LDA ), LDA+1, SCALE, S ) * tri L at A(0,k) ELSE * A**T is lower DO J = 1, K - 1 CALL DLASSQ( J, A( 0+( J+1 )*LDA ), 1, SCALE, S ) * U at A(0,1) END DO DO J = K + 1, N CALL DLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) * k by k rect. at A(0,k+1) END DO DO J = 0, K - 2 CALL DLASSQ( K-J-1, A( J+1+J*LDA ), 1, SCALE, S ) * L at A(0,0) END DO S = S + S * double s for the off diagonal elements CALL DLASSQ( K, A( LDA ), LDA+1, SCALE, S ) * tri L at A(0,1) CALL DLASSQ( K, A( 0 ), LDA+1, SCALE, S ) * tri U at A(0,0) END IF END IF END IF VALUE = SCALE*SQRT( S ) END IF * DLANSF = VALUE RETURN * * End of DLANSF * END *> \brief \b DLANSP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a symmetric matrix supplied in packed form. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLANSP + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK ) * * .. Scalar Arguments .. * CHARACTER NORM, UPLO * INTEGER N * .. * .. Array Arguments .. * DOUBLE PRECISION AP( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLANSP returns the value of the one norm, or the Frobenius norm, or *> the infinity norm, or the element of largest absolute value of a *> real symmetric matrix A, supplied in packed form. *> \endverbatim *> *> \return DLANSP *> \verbatim *> *> DLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm' *> ( *> ( norm1(A), NORM = '1', 'O' or 'o' *> ( *> ( normI(A), NORM = 'I' or 'i' *> ( *> ( normF(A), NORM = 'F', 'f', 'E' or 'e' *> *> where norm1 denotes the one norm of a matrix (maximum column sum), *> normI denotes the infinity norm of a matrix (maximum row sum) and *> normF denotes the Frobenius norm of a matrix (square root of sum of *> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. *> \endverbatim * * Arguments: * ========== * *> \param[in] NORM *> \verbatim *> NORM is CHARACTER*1 *> Specifies the value to be returned in DLANSP as described *> above. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the upper or lower triangular part of the *> symmetric matrix A is supplied. *> = 'U': Upper triangular part of A is supplied *> = 'L': Lower triangular part of A is supplied *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. When N = 0, DLANSP is *> set to zero. *> \endverbatim *> *> \param[in] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> The upper or lower triangle of the symmetric matrix A, packed *> columnwise in a linear array. The j-th column of A is stored *> in the array AP as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), *> where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, *> WORK is not referenced. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER NORM, UPLO INTEGER N * .. * .. Array Arguments .. DOUBLE PRECISION AP( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J, K DOUBLE PRECISION ABSA, SCALE, SUM, VALUE * .. * .. External Subroutines .. EXTERNAL DLASSQ * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT * .. * .. Executable Statements .. * IF( N.EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * VALUE = ZERO IF( LSAME( UPLO, 'U' ) ) THEN K = 1 DO 20 J = 1, N DO 10 I = K, K + J - 1 SUM = ABS( AP( I ) ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 10 CONTINUE K = K + J 20 CONTINUE ELSE K = 1 DO 40 J = 1, N DO 30 I = K, K + N - J SUM = ABS( AP( I ) ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 30 CONTINUE K = K + N - J + 1 40 CONTINUE END IF ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. $ ( NORM.EQ.'1' ) ) THEN * * Find normI(A) ( = norm1(A), since A is symmetric). * VALUE = ZERO K = 1 IF( LSAME( UPLO, 'U' ) ) THEN DO 60 J = 1, N SUM = ZERO DO 50 I = 1, J - 1 ABSA = ABS( AP( K ) ) SUM = SUM + ABSA WORK( I ) = WORK( I ) + ABSA K = K + 1 50 CONTINUE WORK( J ) = SUM + ABS( AP( K ) ) K = K + 1 60 CONTINUE DO 70 I = 1, N SUM = WORK( I ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 70 CONTINUE ELSE DO 80 I = 1, N WORK( I ) = ZERO 80 CONTINUE DO 100 J = 1, N SUM = WORK( J ) + ABS( AP( K ) ) K = K + 1 DO 90 I = J + 1, N ABSA = ABS( AP( K ) ) SUM = SUM + ABSA WORK( I ) = WORK( I ) + ABSA K = K + 1 90 CONTINUE IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 100 CONTINUE END IF ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE K = 2 IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 2, N CALL DLASSQ( J-1, AP( K ), 1, SCALE, SUM ) K = K + J 110 CONTINUE ELSE DO 120 J = 1, N - 1 CALL DLASSQ( N-J, AP( K ), 1, SCALE, SUM ) K = K + N - J + 1 120 CONTINUE END IF SUM = 2*SUM K = 1 DO 130 I = 1, N IF( AP( K ).NE.ZERO ) THEN ABSA = ABS( AP( K ) ) IF( SCALE.LT.ABSA ) THEN SUM = ONE + SUM*( SCALE / ABSA )**2 SCALE = ABSA ELSE SUM = SUM + ( ABSA / SCALE )**2 END IF END IF IF( LSAME( UPLO, 'U' ) ) THEN K = K + I + 1 ELSE K = K + N - I + 1 END IF 130 CONTINUE VALUE = SCALE*SQRT( SUM ) END IF * DLANSP = VALUE RETURN * * End of DLANSP * END *> \brief \b DLANST returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric tridiagonal matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLANST + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) * * .. Scalar Arguments .. * CHARACTER NORM * INTEGER N * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), E( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLANST returns the value of the one norm, or the Frobenius norm, or *> the infinity norm, or the element of largest absolute value of a *> real symmetric tridiagonal matrix A. *> \endverbatim *> *> \return DLANST *> \verbatim *> *> DLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm' *> ( *> ( norm1(A), NORM = '1', 'O' or 'o' *> ( *> ( normI(A), NORM = 'I' or 'i' *> ( *> ( normF(A), NORM = 'F', 'f', 'E' or 'e' *> *> where norm1 denotes the one norm of a matrix (maximum column sum), *> normI denotes the infinity norm of a matrix (maximum row sum) and *> normF denotes the Frobenius norm of a matrix (square root of sum of *> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. *> \endverbatim * * Arguments: * ========== * *> \param[in] NORM *> \verbatim *> NORM is CHARACTER*1 *> Specifies the value to be returned in DLANST as described *> above. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. When N = 0, DLANST is *> set to zero. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The diagonal elements of A. *> \endverbatim *> *> \param[in] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N-1) *> The (n-1) sub-diagonal or super-diagonal elements of A. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER NORM INTEGER N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I DOUBLE PRECISION ANORM, SCALE, SUM * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. * .. External Subroutines .. EXTERNAL DLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT * .. * .. Executable Statements .. * IF( N.LE.0 ) THEN ANORM = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * ANORM = ABS( D( N ) ) DO 10 I = 1, N - 1 SUM = ABS( D( I ) ) IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM SUM = ABS( E( I ) ) IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM 10 CONTINUE ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR. $ LSAME( NORM, 'I' ) ) THEN * * Find norm1(A). * IF( N.EQ.1 ) THEN ANORM = ABS( D( 1 ) ) ELSE ANORM = ABS( D( 1 ) )+ABS( E( 1 ) ) SUM = ABS( E( N-1 ) )+ABS( D( N ) ) IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM DO 20 I = 2, N - 1 SUM = ABS( D( I ) )+ABS( E( I ) )+ABS( E( I-1 ) ) IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM 20 CONTINUE END IF ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE IF( N.GT.1 ) THEN CALL DLASSQ( N-1, E, 1, SCALE, SUM ) SUM = 2*SUM END IF CALL DLASSQ( N, D, 1, SCALE, SUM ) ANORM = SCALE*SQRT( SUM ) END IF * DLANST = ANORM RETURN * * End of DLANST * END *> \brief \b DLANSY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLANSY + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK ) * * .. Scalar Arguments .. * CHARACTER NORM, UPLO * INTEGER LDA, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLANSY returns the value of the one norm, or the Frobenius norm, or *> the infinity norm, or the element of largest absolute value of a *> real symmetric matrix A. *> \endverbatim *> *> \return DLANSY *> \verbatim *> *> DLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm' *> ( *> ( norm1(A), NORM = '1', 'O' or 'o' *> ( *> ( normI(A), NORM = 'I' or 'i' *> ( *> ( normF(A), NORM = 'F', 'f', 'E' or 'e' *> *> where norm1 denotes the one norm of a matrix (maximum column sum), *> normI denotes the infinity norm of a matrix (maximum row sum) and *> normF denotes the Frobenius norm of a matrix (square root of sum of *> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. *> \endverbatim * * Arguments: * ========== * *> \param[in] NORM *> \verbatim *> NORM is CHARACTER*1 *> Specifies the value to be returned in DLANSY as described *> above. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the upper or lower triangular part of the *> symmetric matrix A is to be referenced. *> = 'U': Upper triangular part of A is referenced *> = 'L': Lower triangular part of A is referenced *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. When N = 0, DLANSY is *> set to zero. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The symmetric matrix A. If UPLO = 'U', the leading n by n *> upper triangular part of A contains the upper triangular part *> of the matrix A, and the strictly lower triangular part of A *> is not referenced. If UPLO = 'L', the leading n by n lower *> triangular part of A contains the lower triangular part of *> the matrix A, and the strictly upper triangular part of A is *> not referenced. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(N,1). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), *> where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, *> WORK is not referenced. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleSYauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER NORM, UPLO INTEGER LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION ABSA, SCALE, SUM, VALUE * .. * .. External Subroutines .. EXTERNAL DLASSQ * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT * .. * .. Executable Statements .. * IF( N.EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * VALUE = ZERO IF( LSAME( UPLO, 'U' ) ) THEN DO 20 J = 1, N DO 10 I = 1, J SUM = ABS( A( I, J ) ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 10 CONTINUE 20 CONTINUE ELSE DO 40 J = 1, N DO 30 I = J, N SUM = ABS( A( I, J ) ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 30 CONTINUE 40 CONTINUE END IF ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. $ ( NORM.EQ.'1' ) ) THEN * * Find normI(A) ( = norm1(A), since A is symmetric). * VALUE = ZERO IF( LSAME( UPLO, 'U' ) ) THEN DO 60 J = 1, N SUM = ZERO DO 50 I = 1, J - 1 ABSA = ABS( A( I, J ) ) SUM = SUM + ABSA WORK( I ) = WORK( I ) + ABSA 50 CONTINUE WORK( J ) = SUM + ABS( A( J, J ) ) 60 CONTINUE DO 70 I = 1, N SUM = WORK( I ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 70 CONTINUE ELSE DO 80 I = 1, N WORK( I ) = ZERO 80 CONTINUE DO 100 J = 1, N SUM = WORK( J ) + ABS( A( J, J ) ) DO 90 I = J + 1, N ABSA = ABS( A( I, J ) ) SUM = SUM + ABSA WORK( I ) = WORK( I ) + ABSA 90 CONTINUE IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 100 CONTINUE END IF ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 2, N CALL DLASSQ( J-1, A( 1, J ), 1, SCALE, SUM ) 110 CONTINUE ELSE DO 120 J = 1, N - 1 CALL DLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM ) 120 CONTINUE END IF SUM = 2*SUM CALL DLASSQ( N, A, LDA+1, SCALE, SUM ) VALUE = SCALE*SQRT( SUM ) END IF * DLANSY = VALUE RETURN * * End of DLANSY * END *> \brief \b DLANTB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a triangular band matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLANTB + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLANTB( NORM, UPLO, DIAG, N, K, AB, * LDAB, WORK ) * * .. Scalar Arguments .. * CHARACTER DIAG, NORM, UPLO * INTEGER K, LDAB, N * .. * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLANTB returns the value of the one norm, or the Frobenius norm, or *> the infinity norm, or the element of largest absolute value of an *> n by n triangular band matrix A, with ( k + 1 ) diagonals. *> \endverbatim *> *> \return DLANTB *> \verbatim *> *> DLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm' *> ( *> ( norm1(A), NORM = '1', 'O' or 'o' *> ( *> ( normI(A), NORM = 'I' or 'i' *> ( *> ( normF(A), NORM = 'F', 'f', 'E' or 'e' *> *> where norm1 denotes the one norm of a matrix (maximum column sum), *> normI denotes the infinity norm of a matrix (maximum row sum) and *> normF denotes the Frobenius norm of a matrix (square root of sum of *> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. *> \endverbatim * * Arguments: * ========== * *> \param[in] NORM *> \verbatim *> NORM is CHARACTER*1 *> Specifies the value to be returned in DLANTB as described *> above. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the matrix A is upper or lower triangular. *> = 'U': Upper triangular *> = 'L': Lower triangular *> \endverbatim *> *> \param[in] DIAG *> \verbatim *> DIAG is CHARACTER*1 *> Specifies whether or not the matrix A is unit triangular. *> = 'N': Non-unit triangular *> = 'U': Unit triangular *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. When N = 0, DLANTB is *> set to zero. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The number of super-diagonals of the matrix A if UPLO = 'U', *> or the number of sub-diagonals of the matrix A if UPLO = 'L'. *> K >= 0. *> \endverbatim *> *> \param[in] AB *> \verbatim *> AB is DOUBLE PRECISION array, dimension (LDAB,N) *> The upper or lower triangular band matrix A, stored in the *> first k+1 rows of AB. The j-th column of A is stored *> in the j-th column of the array AB as follows: *> if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j; *> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k). *> Note that when DIAG = 'U', the elements of the array AB *> corresponding to the diagonal elements of the matrix A are *> not referenced, but are assumed to be one. *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array AB. LDAB >= K+1. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), *> where LWORK >= N when NORM = 'I'; otherwise, WORK is not *> referenced. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLANTB( NORM, UPLO, DIAG, N, K, AB, $ LDAB, WORK ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO INTEGER K, LDAB, N * .. * .. Array Arguments .. DOUBLE PRECISION AB( LDAB, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL UDIAG INTEGER I, J, L DOUBLE PRECISION SCALE, SUM, VALUE * .. * .. External Subroutines .. EXTERNAL DLASSQ * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Executable Statements .. * IF( N.EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * IF( LSAME( DIAG, 'U' ) ) THEN VALUE = ONE IF( LSAME( UPLO, 'U' ) ) THEN DO 20 J = 1, N DO 10 I = MAX( K+2-J, 1 ), K SUM = ABS( AB( I, J ) ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 10 CONTINUE 20 CONTINUE ELSE DO 40 J = 1, N DO 30 I = 2, MIN( N+1-J, K+1 ) SUM = ABS( AB( I, J ) ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 30 CONTINUE 40 CONTINUE END IF ELSE VALUE = ZERO IF( LSAME( UPLO, 'U' ) ) THEN DO 60 J = 1, N DO 50 I = MAX( K+2-J, 1 ), K + 1 SUM = ABS( AB( I, J ) ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 50 CONTINUE 60 CONTINUE ELSE DO 80 J = 1, N DO 70 I = 1, MIN( N+1-J, K+1 ) SUM = ABS( AB( I, J ) ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 70 CONTINUE 80 CONTINUE END IF END IF ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN * * Find norm1(A). * VALUE = ZERO UDIAG = LSAME( DIAG, 'U' ) IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 1, N IF( UDIAG ) THEN SUM = ONE DO 90 I = MAX( K+2-J, 1 ), K SUM = SUM + ABS( AB( I, J ) ) 90 CONTINUE ELSE SUM = ZERO DO 100 I = MAX( K+2-J, 1 ), K + 1 SUM = SUM + ABS( AB( I, J ) ) 100 CONTINUE END IF IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 110 CONTINUE ELSE DO 140 J = 1, N IF( UDIAG ) THEN SUM = ONE DO 120 I = 2, MIN( N+1-J, K+1 ) SUM = SUM + ABS( AB( I, J ) ) 120 CONTINUE ELSE SUM = ZERO DO 130 I = 1, MIN( N+1-J, K+1 ) SUM = SUM + ABS( AB( I, J ) ) 130 CONTINUE END IF IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 140 CONTINUE END IF ELSE IF( LSAME( NORM, 'I' ) ) THEN * * Find normI(A). * VALUE = ZERO IF( LSAME( UPLO, 'U' ) ) THEN IF( LSAME( DIAG, 'U' ) ) THEN DO 150 I = 1, N WORK( I ) = ONE 150 CONTINUE DO 170 J = 1, N L = K + 1 - J DO 160 I = MAX( 1, J-K ), J - 1 WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) ) 160 CONTINUE 170 CONTINUE ELSE DO 180 I = 1, N WORK( I ) = ZERO 180 CONTINUE DO 200 J = 1, N L = K + 1 - J DO 190 I = MAX( 1, J-K ), J WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) ) 190 CONTINUE 200 CONTINUE END IF ELSE IF( LSAME( DIAG, 'U' ) ) THEN DO 210 I = 1, N WORK( I ) = ONE 210 CONTINUE DO 230 J = 1, N L = 1 - J DO 220 I = J + 1, MIN( N, J+K ) WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) ) 220 CONTINUE 230 CONTINUE ELSE DO 240 I = 1, N WORK( I ) = ZERO 240 CONTINUE DO 260 J = 1, N L = 1 - J DO 250 I = J, MIN( N, J+K ) WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) ) 250 CONTINUE 260 CONTINUE END IF END IF DO 270 I = 1, N SUM = WORK( I ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 270 CONTINUE ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * IF( LSAME( UPLO, 'U' ) ) THEN IF( LSAME( DIAG, 'U' ) ) THEN SCALE = ONE SUM = N IF( K.GT.0 ) THEN DO 280 J = 2, N CALL DLASSQ( MIN( J-1, K ), $ AB( MAX( K+2-J, 1 ), J ), 1, SCALE, $ SUM ) 280 CONTINUE END IF ELSE SCALE = ZERO SUM = ONE DO 290 J = 1, N CALL DLASSQ( MIN( J, K+1 ), AB( MAX( K+2-J, 1 ), J ), $ 1, SCALE, SUM ) 290 CONTINUE END IF ELSE IF( LSAME( DIAG, 'U' ) ) THEN SCALE = ONE SUM = N IF( K.GT.0 ) THEN DO 300 J = 1, N - 1 CALL DLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE, $ SUM ) 300 CONTINUE END IF ELSE SCALE = ZERO SUM = ONE DO 310 J = 1, N CALL DLASSQ( MIN( N-J+1, K+1 ), AB( 1, J ), 1, SCALE, $ SUM ) 310 CONTINUE END IF END IF VALUE = SCALE*SQRT( SUM ) END IF * DLANTB = VALUE RETURN * * End of DLANTB * END *> \brief \b DLANTP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a triangular matrix supplied in packed form. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLANTP + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLANTP( NORM, UPLO, DIAG, N, AP, WORK ) * * .. Scalar Arguments .. * CHARACTER DIAG, NORM, UPLO * INTEGER N * .. * .. Array Arguments .. * DOUBLE PRECISION AP( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLANTP returns the value of the one norm, or the Frobenius norm, or *> the infinity norm, or the element of largest absolute value of a *> triangular matrix A, supplied in packed form. *> \endverbatim *> *> \return DLANTP *> \verbatim *> *> DLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm' *> ( *> ( norm1(A), NORM = '1', 'O' or 'o' *> ( *> ( normI(A), NORM = 'I' or 'i' *> ( *> ( normF(A), NORM = 'F', 'f', 'E' or 'e' *> *> where norm1 denotes the one norm of a matrix (maximum column sum), *> normI denotes the infinity norm of a matrix (maximum row sum) and *> normF denotes the Frobenius norm of a matrix (square root of sum of *> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. *> \endverbatim * * Arguments: * ========== * *> \param[in] NORM *> \verbatim *> NORM is CHARACTER*1 *> Specifies the value to be returned in DLANTP as described *> above. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the matrix A is upper or lower triangular. *> = 'U': Upper triangular *> = 'L': Lower triangular *> \endverbatim *> *> \param[in] DIAG *> \verbatim *> DIAG is CHARACTER*1 *> Specifies whether or not the matrix A is unit triangular. *> = 'N': Non-unit triangular *> = 'U': Unit triangular *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. When N = 0, DLANTP is *> set to zero. *> \endverbatim *> *> \param[in] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> The upper or lower triangular matrix A, packed columnwise in *> a linear array. The j-th column of A is stored in the array *> AP as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. *> Note that when DIAG = 'U', the elements of the array AP *> corresponding to the diagonal elements of the matrix A are *> not referenced, but are assumed to be one. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), *> where LWORK >= N when NORM = 'I'; otherwise, WORK is not *> referenced. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLANTP( NORM, UPLO, DIAG, N, AP, WORK ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO INTEGER N * .. * .. Array Arguments .. DOUBLE PRECISION AP( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL UDIAG INTEGER I, J, K DOUBLE PRECISION SCALE, SUM, VALUE * .. * .. External Subroutines .. EXTERNAL DLASSQ * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT * .. * .. Executable Statements .. * IF( N.EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * K = 1 IF( LSAME( DIAG, 'U' ) ) THEN VALUE = ONE IF( LSAME( UPLO, 'U' ) ) THEN DO 20 J = 1, N DO 10 I = K, K + J - 2 SUM = ABS( AP( I ) ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 10 CONTINUE K = K + J 20 CONTINUE ELSE DO 40 J = 1, N DO 30 I = K + 1, K + N - J SUM = ABS( AP( I ) ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 30 CONTINUE K = K + N - J + 1 40 CONTINUE END IF ELSE VALUE = ZERO IF( LSAME( UPLO, 'U' ) ) THEN DO 60 J = 1, N DO 50 I = K, K + J - 1 SUM = ABS( AP( I ) ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 50 CONTINUE K = K + J 60 CONTINUE ELSE DO 80 J = 1, N DO 70 I = K, K + N - J SUM = ABS( AP( I ) ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 70 CONTINUE K = K + N - J + 1 80 CONTINUE END IF END IF ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN * * Find norm1(A). * VALUE = ZERO K = 1 UDIAG = LSAME( DIAG, 'U' ) IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 1, N IF( UDIAG ) THEN SUM = ONE DO 90 I = K, K + J - 2 SUM = SUM + ABS( AP( I ) ) 90 CONTINUE ELSE SUM = ZERO DO 100 I = K, K + J - 1 SUM = SUM + ABS( AP( I ) ) 100 CONTINUE END IF K = K + J IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 110 CONTINUE ELSE DO 140 J = 1, N IF( UDIAG ) THEN SUM = ONE DO 120 I = K + 1, K + N - J SUM = SUM + ABS( AP( I ) ) 120 CONTINUE ELSE SUM = ZERO DO 130 I = K, K + N - J SUM = SUM + ABS( AP( I ) ) 130 CONTINUE END IF K = K + N - J + 1 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 140 CONTINUE END IF ELSE IF( LSAME( NORM, 'I' ) ) THEN * * Find normI(A). * K = 1 IF( LSAME( UPLO, 'U' ) ) THEN IF( LSAME( DIAG, 'U' ) ) THEN DO 150 I = 1, N WORK( I ) = ONE 150 CONTINUE DO 170 J = 1, N DO 160 I = 1, J - 1 WORK( I ) = WORK( I ) + ABS( AP( K ) ) K = K + 1 160 CONTINUE K = K + 1 170 CONTINUE ELSE DO 180 I = 1, N WORK( I ) = ZERO 180 CONTINUE DO 200 J = 1, N DO 190 I = 1, J WORK( I ) = WORK( I ) + ABS( AP( K ) ) K = K + 1 190 CONTINUE 200 CONTINUE END IF ELSE IF( LSAME( DIAG, 'U' ) ) THEN DO 210 I = 1, N WORK( I ) = ONE 210 CONTINUE DO 230 J = 1, N K = K + 1 DO 220 I = J + 1, N WORK( I ) = WORK( I ) + ABS( AP( K ) ) K = K + 1 220 CONTINUE 230 CONTINUE ELSE DO 240 I = 1, N WORK( I ) = ZERO 240 CONTINUE DO 260 J = 1, N DO 250 I = J, N WORK( I ) = WORK( I ) + ABS( AP( K ) ) K = K + 1 250 CONTINUE 260 CONTINUE END IF END IF VALUE = ZERO DO 270 I = 1, N SUM = WORK( I ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 270 CONTINUE ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * IF( LSAME( UPLO, 'U' ) ) THEN IF( LSAME( DIAG, 'U' ) ) THEN SCALE = ONE SUM = N K = 2 DO 280 J = 2, N CALL DLASSQ( J-1, AP( K ), 1, SCALE, SUM ) K = K + J 280 CONTINUE ELSE SCALE = ZERO SUM = ONE K = 1 DO 290 J = 1, N CALL DLASSQ( J, AP( K ), 1, SCALE, SUM ) K = K + J 290 CONTINUE END IF ELSE IF( LSAME( DIAG, 'U' ) ) THEN SCALE = ONE SUM = N K = 2 DO 300 J = 1, N - 1 CALL DLASSQ( N-J, AP( K ), 1, SCALE, SUM ) K = K + N - J + 1 300 CONTINUE ELSE SCALE = ZERO SUM = ONE K = 1 DO 310 J = 1, N CALL DLASSQ( N-J+1, AP( K ), 1, SCALE, SUM ) K = K + N - J + 1 310 CONTINUE END IF END IF VALUE = SCALE*SQRT( SUM ) END IF * DLANTP = VALUE RETURN * * End of DLANTP * END *> \brief \b DLANTR returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a trapezoidal or triangular matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLANTR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, LDA, * WORK ) * * .. Scalar Arguments .. * CHARACTER DIAG, NORM, UPLO * INTEGER LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLANTR returns the value of the one norm, or the Frobenius norm, or *> the infinity norm, or the element of largest absolute value of a *> trapezoidal or triangular matrix A. *> \endverbatim *> *> \return DLANTR *> \verbatim *> *> DLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm' *> ( *> ( norm1(A), NORM = '1', 'O' or 'o' *> ( *> ( normI(A), NORM = 'I' or 'i' *> ( *> ( normF(A), NORM = 'F', 'f', 'E' or 'e' *> *> where norm1 denotes the one norm of a matrix (maximum column sum), *> normI denotes the infinity norm of a matrix (maximum row sum) and *> normF denotes the Frobenius norm of a matrix (square root of sum of *> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. *> \endverbatim * * Arguments: * ========== * *> \param[in] NORM *> \verbatim *> NORM is CHARACTER*1 *> Specifies the value to be returned in DLANTR as described *> above. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the matrix A is upper or lower trapezoidal. *> = 'U': Upper trapezoidal *> = 'L': Lower trapezoidal *> Note that A is triangular instead of trapezoidal if M = N. *> \endverbatim *> *> \param[in] DIAG *> \verbatim *> DIAG is CHARACTER*1 *> Specifies whether or not the matrix A has unit diagonal. *> = 'N': Non-unit diagonal *> = 'U': Unit diagonal *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0, and if *> UPLO = 'U', M <= N. When M = 0, DLANTR is set to zero. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0, and if *> UPLO = 'L', N <= M. When N = 0, DLANTR is set to zero. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The trapezoidal matrix A (A is triangular if M = N). *> If UPLO = 'U', the leading m by n upper trapezoidal part of *> the array A contains the upper trapezoidal matrix, and the *> strictly lower triangular part of A is not referenced. *> If UPLO = 'L', the leading m by n lower trapezoidal part of *> the array A contains the lower trapezoidal matrix, and the *> strictly upper triangular part of A is not referenced. Note *> that when DIAG = 'U', the diagonal elements of A are not *> referenced and are assumed to be one. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(M,1). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), *> where LWORK >= M when NORM = 'I'; otherwise, WORK is not *> referenced. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, LDA, $ WORK ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO INTEGER LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL UDIAG INTEGER I, J DOUBLE PRECISION SCALE, SUM, VALUE * .. * .. External Subroutines .. EXTERNAL DLASSQ * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. * .. Intrinsic Functions .. INTRINSIC ABS, MIN, SQRT * .. * .. Executable Statements .. * IF( MIN( M, N ).EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * IF( LSAME( DIAG, 'U' ) ) THEN VALUE = ONE IF( LSAME( UPLO, 'U' ) ) THEN DO 20 J = 1, N DO 10 I = 1, MIN( M, J-1 ) SUM = ABS( A( I, J ) ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 10 CONTINUE 20 CONTINUE ELSE DO 40 J = 1, N DO 30 I = J + 1, M SUM = ABS( A( I, J ) ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 30 CONTINUE 40 CONTINUE END IF ELSE VALUE = ZERO IF( LSAME( UPLO, 'U' ) ) THEN DO 60 J = 1, N DO 50 I = 1, MIN( M, J ) SUM = ABS( A( I, J ) ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 50 CONTINUE 60 CONTINUE ELSE DO 80 J = 1, N DO 70 I = J, M SUM = ABS( A( I, J ) ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 70 CONTINUE 80 CONTINUE END IF END IF ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN * * Find norm1(A). * VALUE = ZERO UDIAG = LSAME( DIAG, 'U' ) IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 1, N IF( ( UDIAG ) .AND. ( J.LE.M ) ) THEN SUM = ONE DO 90 I = 1, J - 1 SUM = SUM + ABS( A( I, J ) ) 90 CONTINUE ELSE SUM = ZERO DO 100 I = 1, MIN( M, J ) SUM = SUM + ABS( A( I, J ) ) 100 CONTINUE END IF IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 110 CONTINUE ELSE DO 140 J = 1, N IF( UDIAG ) THEN SUM = ONE DO 120 I = J + 1, M SUM = SUM + ABS( A( I, J ) ) 120 CONTINUE ELSE SUM = ZERO DO 130 I = J, M SUM = SUM + ABS( A( I, J ) ) 130 CONTINUE END IF IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 140 CONTINUE END IF ELSE IF( LSAME( NORM, 'I' ) ) THEN * * Find normI(A). * IF( LSAME( UPLO, 'U' ) ) THEN IF( LSAME( DIAG, 'U' ) ) THEN DO 150 I = 1, M WORK( I ) = ONE 150 CONTINUE DO 170 J = 1, N DO 160 I = 1, MIN( M, J-1 ) WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 160 CONTINUE 170 CONTINUE ELSE DO 180 I = 1, M WORK( I ) = ZERO 180 CONTINUE DO 200 J = 1, N DO 190 I = 1, MIN( M, J ) WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 190 CONTINUE 200 CONTINUE END IF ELSE IF( LSAME( DIAG, 'U' ) ) THEN DO 210 I = 1, N WORK( I ) = ONE 210 CONTINUE DO 220 I = N + 1, M WORK( I ) = ZERO 220 CONTINUE DO 240 J = 1, N DO 230 I = J + 1, M WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 230 CONTINUE 240 CONTINUE ELSE DO 250 I = 1, M WORK( I ) = ZERO 250 CONTINUE DO 270 J = 1, N DO 260 I = J, M WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 260 CONTINUE 270 CONTINUE END IF END IF VALUE = ZERO DO 280 I = 1, M SUM = WORK( I ) IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 280 CONTINUE ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * IF( LSAME( UPLO, 'U' ) ) THEN IF( LSAME( DIAG, 'U' ) ) THEN SCALE = ONE SUM = MIN( M, N ) DO 290 J = 2, N CALL DLASSQ( MIN( M, J-1 ), A( 1, J ), 1, SCALE, SUM ) 290 CONTINUE ELSE SCALE = ZERO SUM = ONE DO 300 J = 1, N CALL DLASSQ( MIN( M, J ), A( 1, J ), 1, SCALE, SUM ) 300 CONTINUE END IF ELSE IF( LSAME( DIAG, 'U' ) ) THEN SCALE = ONE SUM = MIN( M, N ) DO 310 J = 1, N CALL DLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, SCALE, $ SUM ) 310 CONTINUE ELSE SCALE = ZERO SUM = ONE DO 320 J = 1, N CALL DLASSQ( M-J+1, A( J, J ), 1, SCALE, SUM ) 320 CONTINUE END IF END IF VALUE = SCALE*SQRT( SUM ) END IF * DLANTR = VALUE RETURN * * End of DLANTR * END *> \brief \b DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric matrix in standard form. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLANV2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN ) * * .. Scalar Arguments .. * DOUBLE PRECISION A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric *> matrix in standard form: *> *> [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ] *> [ C D ] [ SN CS ] [ CC DD ] [-SN CS ] *> *> where either *> 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or *> 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex *> conjugate eigenvalues. *> \endverbatim * * Arguments: * ========== * *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is DOUBLE PRECISION *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION *> On entry, the elements of the input matrix. *> On exit, they are overwritten by the elements of the *> standardised Schur form. *> \endverbatim *> *> \param[out] RT1R *> \verbatim *> RT1R is DOUBLE PRECISION *> \endverbatim *> *> \param[out] RT1I *> \verbatim *> RT1I is DOUBLE PRECISION *> \endverbatim *> *> \param[out] RT2R *> \verbatim *> RT2R is DOUBLE PRECISION *> \endverbatim *> *> \param[out] RT2I *> \verbatim *> RT2I is DOUBLE PRECISION *> The real and imaginary parts of the eigenvalues. If the *> eigenvalues are a complex conjugate pair, RT1I > 0. *> \endverbatim *> *> \param[out] CS *> \verbatim *> CS is DOUBLE PRECISION *> \endverbatim *> *> \param[out] SN *> \verbatim *> SN is DOUBLE PRECISION *> Parameters of the rotation matrix. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> Modified by V. Sima, Research Institute for Informatics, Bucharest, *> Romania, to reduce the risk of cancellation errors, *> when computing real eigenvalues, and to ensure, if possible, that *> abs(RT1R) >= abs(RT2R). *> \endverbatim *> * ===================================================================== SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 ) DOUBLE PRECISION MULTPL PARAMETER ( MULTPL = 4.0D+0 ) * .. * .. Local Scalars .. DOUBLE PRECISION AA, BB, BCMAX, BCMIS, CC, CS1, DD, EPS, P, SAB, $ SAC, SCALE, SIGMA, SN1, TAU, TEMP, Z * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLAPY2 EXTERNAL DLAMCH, DLAPY2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SIGN, SQRT * .. * .. Executable Statements .. * EPS = DLAMCH( 'P' ) IF( C.EQ.ZERO ) THEN CS = ONE SN = ZERO GO TO 10 * ELSE IF( B.EQ.ZERO ) THEN * * Swap rows and columns * CS = ZERO SN = ONE TEMP = D D = A A = TEMP B = -C C = ZERO GO TO 10 ELSE IF( ( A-D ).EQ.ZERO .AND. SIGN( ONE, B ).NE.SIGN( ONE, C ) ) $ THEN CS = ONE SN = ZERO GO TO 10 ELSE * TEMP = A - D P = HALF*TEMP BCMAX = MAX( ABS( B ), ABS( C ) ) BCMIS = MIN( ABS( B ), ABS( C ) )*SIGN( ONE, B )*SIGN( ONE, C ) SCALE = MAX( ABS( P ), BCMAX ) Z = ( P / SCALE )*P + ( BCMAX / SCALE )*BCMIS * * If Z is of the order of the machine accuracy, postpone the * decision on the nature of eigenvalues * IF( Z.GE.MULTPL*EPS ) THEN * * Real eigenvalues. Compute A and D. * Z = P + SIGN( SQRT( SCALE )*SQRT( Z ), P ) A = D + Z D = D - ( BCMAX / Z )*BCMIS * * Compute B and the rotation matrix * TAU = DLAPY2( C, Z ) CS = Z / TAU SN = C / TAU B = B - C C = ZERO ELSE * * Complex eigenvalues, or real (almost) equal eigenvalues. * Make diagonal elements equal. * SIGMA = B + C TAU = DLAPY2( SIGMA, TEMP ) CS = SQRT( HALF*( ONE+ABS( SIGMA ) / TAU ) ) SN = -( P / ( TAU*CS ) )*SIGN( ONE, SIGMA ) * * Compute [ AA BB ] = [ A B ] [ CS -SN ] * [ CC DD ] [ C D ] [ SN CS ] * AA = A*CS + B*SN BB = -A*SN + B*CS CC = C*CS + D*SN DD = -C*SN + D*CS * * Compute [ A B ] = [ CS SN ] [ AA BB ] * [ C D ] [-SN CS ] [ CC DD ] * A = AA*CS + CC*SN B = BB*CS + DD*SN C = -AA*SN + CC*CS D = -BB*SN + DD*CS * TEMP = HALF*( A+D ) A = TEMP D = TEMP * IF( C.NE.ZERO ) THEN IF( B.NE.ZERO ) THEN IF( SIGN( ONE, B ).EQ.SIGN( ONE, C ) ) THEN * * Real eigenvalues: reduce to upper triangular form * SAB = SQRT( ABS( B ) ) SAC = SQRT( ABS( C ) ) P = SIGN( SAB*SAC, C ) TAU = ONE / SQRT( ABS( B+C ) ) A = TEMP + P D = TEMP - P B = B - C C = ZERO CS1 = SAB*TAU SN1 = SAC*TAU TEMP = CS*CS1 - SN*SN1 SN = CS*SN1 + SN*CS1 CS = TEMP END IF ELSE B = -C C = ZERO TEMP = CS CS = -SN SN = TEMP END IF END IF END IF * END IF * 10 CONTINUE * * Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I). * RT1R = A RT2R = D IF( C.EQ.ZERO ) THEN RT1I = ZERO RT2I = ZERO ELSE RT1I = SQRT( ABS( B ) )*SQRT( ABS( C ) ) RT2I = -RT1I END IF RETURN * * End of DLANV2 * END *> \brief \b DLAPLL measures the linear dependence of two vectors. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAPLL + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAPLL( N, X, INCX, Y, INCY, SSMIN ) * * .. Scalar Arguments .. * INTEGER INCX, INCY, N * DOUBLE PRECISION SSMIN * .. * .. Array Arguments .. * DOUBLE PRECISION X( * ), Y( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> Given two column vectors X and Y, let *> *> A = ( X Y ). *> *> The subroutine first computes the QR factorization of A = Q*R, *> and then computes the SVD of the 2-by-2 upper triangular matrix R. *> The smaller singular value of R is returned in SSMIN, which is used *> as the measurement of the linear dependency of the vectors X and Y. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The length of the vectors X and Y. *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is DOUBLE PRECISION array, *> dimension (1+(N-1)*INCX) *> On entry, X contains the N-vector X. *> On exit, X is overwritten. *> \endverbatim *> *> \param[in] INCX *> \verbatim *> INCX is INTEGER *> The increment between successive elements of X. INCX > 0. *> \endverbatim *> *> \param[in,out] Y *> \verbatim *> Y is DOUBLE PRECISION array, *> dimension (1+(N-1)*INCY) *> On entry, Y contains the N-vector Y. *> On exit, Y is overwritten. *> \endverbatim *> *> \param[in] INCY *> \verbatim *> INCY is INTEGER *> The increment between successive elements of Y. INCY > 0. *> \endverbatim *> *> \param[out] SSMIN *> \verbatim *> SSMIN is DOUBLE PRECISION *> The smallest singular value of the N-by-2 matrix A = ( X Y ). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLAPLL( N, X, INCX, Y, INCY, SSMIN ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INCX, INCY, N DOUBLE PRECISION SSMIN * .. * .. Array Arguments .. DOUBLE PRECISION X( * ), Y( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. DOUBLE PRECISION A11, A12, A22, C, SSMAX, TAU * .. * .. External Functions .. DOUBLE PRECISION DDOT EXTERNAL DDOT * .. * .. External Subroutines .. EXTERNAL DAXPY, DLARFG, DLAS2 * .. * .. Executable Statements .. * * Quick return if possible * IF( N.LE.1 ) THEN SSMIN = ZERO RETURN END IF * * Compute the QR factorization of the N-by-2 matrix ( X Y ) * CALL DLARFG( N, X( 1 ), X( 1+INCX ), INCX, TAU ) A11 = X( 1 ) X( 1 ) = ONE * C = -TAU*DDOT( N, X, INCX, Y, INCY ) CALL DAXPY( N, C, X, INCX, Y, INCY ) * CALL DLARFG( N-1, Y( 1+INCY ), Y( 1+2*INCY ), INCY, TAU ) * A12 = Y( 1 ) A22 = Y( 1+INCY ) * * Compute the SVD of 2-by-2 Upper triangular matrix. * CALL DLAS2( A11, A12, A22, SSMIN, SSMAX ) * RETURN * * End of DLAPLL * END *> \brief \b DLAPMR rearranges rows of a matrix as specified by a permutation vector. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAPMR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAPMR( FORWRD, M, N, X, LDX, K ) * * .. Scalar Arguments .. * LOGICAL FORWRD * INTEGER LDX, M, N * .. * .. Array Arguments .. * INTEGER K( * ) * DOUBLE PRECISION X( LDX, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAPMR rearranges the rows of the M by N matrix X as specified *> by the permutation K(1),K(2),...,K(M) of the integers 1,...,M. *> If FORWRD = .TRUE., forward permutation: *> *> X(K(I),*) is moved X(I,*) for I = 1,2,...,M. *> *> If FORWRD = .FALSE., backward permutation: *> *> X(I,*) is moved to X(K(I),*) for I = 1,2,...,M. *> \endverbatim * * Arguments: * ========== * *> \param[in] FORWRD *> \verbatim *> FORWRD is LOGICAL *> = .TRUE., forward permutation *> = .FALSE., backward permutation *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix X. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix X. N >= 0. *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,N) *> On entry, the M by N matrix X. *> On exit, X contains the permuted matrix X. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the array X, LDX >= MAX(1,M). *> \endverbatim *> *> \param[in,out] K *> \verbatim *> K is INTEGER array, dimension (M) *> On entry, K contains the permutation vector. K is used as *> internal workspace, but reset to its original value on *> output. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLAPMR( FORWRD, M, N, X, LDX, K ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. LOGICAL FORWRD INTEGER LDX, M, N * .. * .. Array Arguments .. INTEGER K( * ) DOUBLE PRECISION X( LDX, * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I, IN, J, JJ DOUBLE PRECISION TEMP * .. * .. Executable Statements .. * IF( M.LE.1 ) $ RETURN * DO 10 I = 1, M K( I ) = -K( I ) 10 CONTINUE * IF( FORWRD ) THEN * * Forward permutation * DO 50 I = 1, M * IF( K( I ).GT.0 ) $ GO TO 40 * J = I K( J ) = -K( J ) IN = K( J ) * 20 CONTINUE IF( K( IN ).GT.0 ) $ GO TO 40 * DO 30 JJ = 1, N TEMP = X( J, JJ ) X( J, JJ ) = X( IN, JJ ) X( IN, JJ ) = TEMP 30 CONTINUE * K( IN ) = -K( IN ) J = IN IN = K( IN ) GO TO 20 * 40 CONTINUE * 50 CONTINUE * ELSE * * Backward permutation * DO 90 I = 1, M * IF( K( I ).GT.0 ) $ GO TO 80 * K( I ) = -K( I ) J = K( I ) 60 CONTINUE IF( J.EQ.I ) $ GO TO 80 * DO 70 JJ = 1, N TEMP = X( I, JJ ) X( I, JJ ) = X( J, JJ ) X( J, JJ ) = TEMP 70 CONTINUE * K( J ) = -K( J ) J = K( J ) GO TO 60 * 80 CONTINUE * 90 CONTINUE * END IF * RETURN * * End of ZLAPMT * END *> \brief \b DLAPMT performs a forward or backward permutation of the columns of a matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAPMT + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAPMT( FORWRD, M, N, X, LDX, K ) * * .. Scalar Arguments .. * LOGICAL FORWRD * INTEGER LDX, M, N * .. * .. Array Arguments .. * INTEGER K( * ) * DOUBLE PRECISION X( LDX, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAPMT rearranges the columns of the M by N matrix X as specified *> by the permutation K(1),K(2),...,K(N) of the integers 1,...,N. *> If FORWRD = .TRUE., forward permutation: *> *> X(*,K(J)) is moved X(*,J) for J = 1,2,...,N. *> *> If FORWRD = .FALSE., backward permutation: *> *> X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N. *> \endverbatim * * Arguments: * ========== * *> \param[in] FORWRD *> \verbatim *> FORWRD is LOGICAL *> = .TRUE., forward permutation *> = .FALSE., backward permutation *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix X. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix X. N >= 0. *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,N) *> On entry, the M by N matrix X. *> On exit, X contains the permuted matrix X. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the array X, LDX >= MAX(1,M). *> \endverbatim *> *> \param[in,out] K *> \verbatim *> K is INTEGER array, dimension (N) *> On entry, K contains the permutation vector. K is used as *> internal workspace, but reset to its original value on *> output. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLAPMT( FORWRD, M, N, X, LDX, K ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. LOGICAL FORWRD INTEGER LDX, M, N * .. * .. Array Arguments .. INTEGER K( * ) DOUBLE PRECISION X( LDX, * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I, II, IN, J DOUBLE PRECISION TEMP * .. * .. Executable Statements .. * IF( N.LE.1 ) $ RETURN * DO 10 I = 1, N K( I ) = -K( I ) 10 CONTINUE * IF( FORWRD ) THEN * * Forward permutation * DO 50 I = 1, N * IF( K( I ).GT.0 ) $ GO TO 40 * J = I K( J ) = -K( J ) IN = K( J ) * 20 CONTINUE IF( K( IN ).GT.0 ) $ GO TO 40 * DO 30 II = 1, M TEMP = X( II, J ) X( II, J ) = X( II, IN ) X( II, IN ) = TEMP 30 CONTINUE * K( IN ) = -K( IN ) J = IN IN = K( IN ) GO TO 20 * 40 CONTINUE * 50 CONTINUE * ELSE * * Backward permutation * DO 90 I = 1, N * IF( K( I ).GT.0 ) $ GO TO 80 * K( I ) = -K( I ) J = K( I ) 60 CONTINUE IF( J.EQ.I ) $ GO TO 80 * DO 70 II = 1, M TEMP = X( II, I ) X( II, I ) = X( II, J ) X( II, J ) = TEMP 70 CONTINUE * K( J ) = -K( J ) J = K( J ) GO TO 60 * 80 CONTINUE * 90 CONTINUE * END IF * RETURN * * End of DLAPMT * END *> \brief \b DLAPY2 returns sqrt(x2+y2). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAPY2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) * * .. Scalar Arguments .. * DOUBLE PRECISION X, Y * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary *> overflow. *> \endverbatim * * Arguments: * ========== * *> \param[in] X *> \verbatim *> X is DOUBLE PRECISION *> \endverbatim *> *> \param[in] Y *> \verbatim *> Y is DOUBLE PRECISION *> X and Y specify the values x and y. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup OTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) * * -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. DOUBLE PRECISION X, Y * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) * .. * .. Local Scalars .. DOUBLE PRECISION W, XABS, YABS, Z LOGICAL X_IS_NAN, Y_IS_NAN * .. * .. External Functions .. LOGICAL DISNAN EXTERNAL DISNAN * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Executable Statements .. * X_IS_NAN = DISNAN( X ) Y_IS_NAN = DISNAN( Y ) IF ( X_IS_NAN ) DLAPY2 = X IF ( Y_IS_NAN ) DLAPY2 = Y * IF ( .NOT.( X_IS_NAN.OR.Y_IS_NAN ) ) THEN XABS = ABS( X ) YABS = ABS( Y ) W = MAX( XABS, YABS ) Z = MIN( XABS, YABS ) IF( Z.EQ.ZERO ) THEN DLAPY2 = W ELSE DLAPY2 = W*SQRT( ONE+( Z / W )**2 ) END IF END IF RETURN * * End of DLAPY2 * END *> \brief \b DLAPY3 returns sqrt(x2+y2+z2). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAPY3 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z ) * * .. Scalar Arguments .. * DOUBLE PRECISION X, Y, Z * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause *> unnecessary overflow. *> \endverbatim * * Arguments: * ========== * *> \param[in] X *> \verbatim *> X is DOUBLE PRECISION *> \endverbatim *> *> \param[in] Y *> \verbatim *> Y is DOUBLE PRECISION *> \endverbatim *> *> \param[in] Z *> \verbatim *> Z is DOUBLE PRECISION *> X, Y and Z specify the values x, y and z. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION X, Y, Z * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) * .. * .. Local Scalars .. DOUBLE PRECISION W, XABS, YABS, ZABS * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * XABS = ABS( X ) YABS = ABS( Y ) ZABS = ABS( Z ) W = MAX( XABS, YABS, ZABS ) IF( W.EQ.ZERO ) THEN * W can be zero for max(0,nan,0) * adding all three entries together will make sure * NaN will not disappear. DLAPY3 = XABS + YABS + ZABS ELSE DLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+ $ ( ZABS / W )**2 ) END IF RETURN * * End of DLAPY3 * END *> \brief \b DLAQGB scales a general band matrix, using row and column scaling factors computed by sgbequ. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAQGB + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, * AMAX, EQUED ) * * .. Scalar Arguments .. * CHARACTER EQUED * INTEGER KL, KU, LDAB, M, N * DOUBLE PRECISION AMAX, COLCND, ROWCND * .. * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ), C( * ), R( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAQGB equilibrates a general M by N band matrix A with KL *> subdiagonals and KU superdiagonals using the row and scaling factors *> in the vectors R and C. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] KL *> \verbatim *> KL is INTEGER *> The number of subdiagonals within the band of A. KL >= 0. *> \endverbatim *> *> \param[in] KU *> \verbatim *> KU is INTEGER *> The number of superdiagonals within the band of A. KU >= 0. *> \endverbatim *> *> \param[in,out] AB *> \verbatim *> AB is DOUBLE PRECISION array, dimension (LDAB,N) *> On entry, the matrix A in band storage, 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, the equilibrated matrix, in the same storage format *> as A. See EQUED for the form of the equilibrated matrix. *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array AB. LDA >= KL+KU+1. *> \endverbatim *> *> \param[in] R *> \verbatim *> R is DOUBLE PRECISION array, dimension (M) *> The row scale factors for A. *> \endverbatim *> *> \param[in] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (N) *> The column scale factors for A. *> \endverbatim *> *> \param[in] ROWCND *> \verbatim *> ROWCND is DOUBLE PRECISION *> Ratio of the smallest R(i) to the largest R(i). *> \endverbatim *> *> \param[in] COLCND *> \verbatim *> COLCND is DOUBLE PRECISION *> Ratio of the smallest C(i) to the largest C(i). *> \endverbatim *> *> \param[in] AMAX *> \verbatim *> AMAX is DOUBLE PRECISION *> Absolute value of largest matrix entry. *> \endverbatim *> *> \param[out] EQUED *> \verbatim *> EQUED is CHARACTER*1 *> Specifies the form of equilibration that was done. *> = 'N': No equilibration *> = 'R': Row equilibration, i.e., A has been premultiplied by *> diag(R). *> = 'C': Column equilibration, i.e., A has been postmultiplied *> by diag(C). *> = 'B': Both row and column equilibration, i.e., A has been *> replaced by diag(R) * A * diag(C). *> \endverbatim * *> \par Internal Parameters: * ========================= *> *> \verbatim *> THRESH is a threshold value used to decide if row or column scaling *> should be done based on the ratio of the row or column scaling *> factors. If ROWCND < THRESH, row scaling is done, and if *> COLCND < THRESH, column scaling is done. *> *> LARGE and SMALL are threshold values used to decide if row scaling *> should be done based on the absolute size of the largest matrix *> element. If AMAX > LARGE or AMAX < SMALL, row scaling is done. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGBauxiliary * * ===================================================================== SUBROUTINE DLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, $ AMAX, EQUED ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER EQUED INTEGER KL, KU, LDAB, M, N DOUBLE PRECISION AMAX, COLCND, ROWCND * .. * .. Array Arguments .. DOUBLE PRECISION AB( LDAB, * ), C( * ), R( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, THRESH PARAMETER ( ONE = 1.0D+0, THRESH = 0.1D+0 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION CJ, LARGE, SMALL * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 ) THEN EQUED = 'N' RETURN END IF * * Initialize LARGE and SMALL. * SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) LARGE = ONE / SMALL * IF( ROWCND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) $ THEN * * No row scaling * IF( COLCND.GE.THRESH ) THEN * * No column scaling * EQUED = 'N' ELSE * * Column scaling * DO 20 J = 1, N CJ = C( J ) DO 10 I = MAX( 1, J-KU ), MIN( M, J+KL ) AB( KU+1+I-J, J ) = CJ*AB( KU+1+I-J, J ) 10 CONTINUE 20 CONTINUE EQUED = 'C' END IF ELSE IF( COLCND.GE.THRESH ) THEN * * Row scaling, no column scaling * DO 40 J = 1, N DO 30 I = MAX( 1, J-KU ), MIN( M, J+KL ) AB( KU+1+I-J, J ) = R( I )*AB( KU+1+I-J, J ) 30 CONTINUE 40 CONTINUE EQUED = 'R' ELSE * * Row and column scaling * DO 60 J = 1, N CJ = C( J ) DO 50 I = MAX( 1, J-KU ), MIN( M, J+KL ) AB( KU+1+I-J, J ) = CJ*R( I )*AB( KU+1+I-J, J ) 50 CONTINUE 60 CONTINUE EQUED = 'B' END IF * RETURN * * End of DLAQGB * END *> \brief \b DLAQGE scales a general rectangular matrix, using row and column scaling factors computed by sgeequ. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAQGE + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, * EQUED ) * * .. Scalar Arguments .. * CHARACTER EQUED * INTEGER LDA, M, N * DOUBLE PRECISION AMAX, COLCND, ROWCND * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( * ), R( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAQGE equilibrates a general M by N matrix A using the row and *> column scaling factors in the vectors R and C. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the M by N matrix A. *> On exit, the equilibrated matrix. See EQUED for the form of *> the equilibrated matrix. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(M,1). *> \endverbatim *> *> \param[in] R *> \verbatim *> R is DOUBLE PRECISION array, dimension (M) *> The row scale factors for A. *> \endverbatim *> *> \param[in] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (N) *> The column scale factors for A. *> \endverbatim *> *> \param[in] ROWCND *> \verbatim *> ROWCND is DOUBLE PRECISION *> Ratio of the smallest R(i) to the largest R(i). *> \endverbatim *> *> \param[in] COLCND *> \verbatim *> COLCND is DOUBLE PRECISION *> Ratio of the smallest C(i) to the largest C(i). *> \endverbatim *> *> \param[in] AMAX *> \verbatim *> AMAX is DOUBLE PRECISION *> Absolute value of largest matrix entry. *> \endverbatim *> *> \param[out] EQUED *> \verbatim *> EQUED is CHARACTER*1 *> Specifies the form of equilibration that was done. *> = 'N': No equilibration *> = 'R': Row equilibration, i.e., A has been premultiplied by *> diag(R). *> = 'C': Column equilibration, i.e., A has been postmultiplied *> by diag(C). *> = 'B': Both row and column equilibration, i.e., A has been *> replaced by diag(R) * A * diag(C). *> \endverbatim * *> \par Internal Parameters: * ========================= *> *> \verbatim *> THRESH is a threshold value used to decide if row or column scaling *> should be done based on the ratio of the row or column scaling *> factors. If ROWCND < THRESH, row scaling is done, and if *> COLCND < THRESH, column scaling is done. *> *> LARGE and SMALL are threshold values used to decide if row scaling *> should be done based on the absolute size of the largest matrix *> element. If AMAX > LARGE or AMAX < SMALL, row scaling is done. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEauxiliary * * ===================================================================== SUBROUTINE DLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, $ EQUED ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER EQUED INTEGER LDA, M, N DOUBLE PRECISION AMAX, COLCND, ROWCND * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( * ), R( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, THRESH PARAMETER ( ONE = 1.0D+0, THRESH = 0.1D+0 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION CJ, LARGE, SMALL * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. Executable Statements .. * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 ) THEN EQUED = 'N' RETURN END IF * * Initialize LARGE and SMALL. * SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) LARGE = ONE / SMALL * IF( ROWCND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) $ THEN * * No row scaling * IF( COLCND.GE.THRESH ) THEN * * No column scaling * EQUED = 'N' ELSE * * Column scaling * DO 20 J = 1, N CJ = C( J ) DO 10 I = 1, M A( I, J ) = CJ*A( I, J ) 10 CONTINUE 20 CONTINUE EQUED = 'C' END IF ELSE IF( COLCND.GE.THRESH ) THEN * * Row scaling, no column scaling * DO 40 J = 1, N DO 30 I = 1, M A( I, J ) = R( I )*A( I, J ) 30 CONTINUE 40 CONTINUE EQUED = 'R' ELSE * * Row and column scaling * DO 60 J = 1, N CJ = C( J ) DO 50 I = 1, M A( I, J ) = CJ*R( I )*A( I, J ) 50 CONTINUE 60 CONTINUE EQUED = 'B' END IF * RETURN * * End of DLAQGE * END *> \brief \b DLAQP2 computes a QR factorization with column pivoting of the matrix block. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAQP2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, * WORK ) * * .. Scalar Arguments .. * INTEGER LDA, M, N, OFFSET * .. * .. Array Arguments .. * INTEGER JPVT( * ) * DOUBLE PRECISION A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAQP2 computes a QR factorization with column pivoting of *> the block A(OFFSET+1:M,1:N). *> The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] OFFSET *> \verbatim *> OFFSET is INTEGER *> The number of rows of the matrix A that must be pivoted *> but no factorized. OFFSET >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the M-by-N matrix A. *> On exit, the upper triangle of block A(OFFSET+1:M,1:N) is *> the triangular factor obtained; the elements in block *> A(OFFSET+1:M,1:N) below the diagonal, together with the *> array TAU, represent the orthogonal matrix Q as a product of *> elementary reflectors. Block A(1:OFFSET,1:N) has been *> accordingly pivoted, but no factorized. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in,out] JPVT *> \verbatim *> JPVT is 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. *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors. *> \endverbatim *> *> \param[in,out] VN1 *> \verbatim *> VN1 is DOUBLE PRECISION array, dimension (N) *> The vector with the partial column norms. *> \endverbatim *> *> \param[in,out] VN2 *> \verbatim *> VN2 is DOUBLE PRECISION array, dimension (N) *> The vector with the exact column norms. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (N) *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Contributors: * ================== *> *> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain *> X. Sun, Computer Science Dept., Duke University, USA *> \n *> Partial column norm updating strategy modified on April 2011 *> Z. Drmac and Z. Bujanovic, Dept. of Mathematics, *> University of Zagreb, Croatia. * *> \par References: * ================ *> *> LAPACK Working Note 176 * *> \htmlonly *> [PDF] *> \endhtmlonly * * ===================================================================== SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, $ WORK ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER LDA, M, N, OFFSET * .. * .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), $ WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, ITEMP, J, MN, OFFPI, PVT DOUBLE PRECISION AII, TEMP, TEMP2, TOL3Z * .. * .. External Subroutines .. EXTERNAL DLARF, DLARFG, DSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DNRM2 EXTERNAL IDAMAX, DLAMCH, DNRM2 * .. * .. Executable Statements .. * MN = MIN( M-OFFSET, N ) TOL3Z = SQRT(DLAMCH('Epsilon')) * * Compute factorization. * DO 20 I = 1, MN * OFFPI = OFFSET + I * * Determine ith pivot column and swap if necessary. * PVT = ( I-1 ) + IDAMAX( N-I+1, VN1( 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 VN1( PVT ) = VN1( I ) VN2( PVT ) = VN2( I ) END IF * * Generate elementary reflector H(i). * IF( OFFPI.LT.M ) THEN CALL DLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1, $ TAU( I ) ) ELSE CALL DLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) ) END IF * IF( I.LT.N ) THEN * * Apply H(i)**T to A(offset+i:m,i+1:n) from the left. * AII = A( OFFPI, I ) A( OFFPI, I ) = ONE CALL DLARF( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1, $ TAU( I ), A( OFFPI, I+1 ), LDA, WORK( 1 ) ) A( OFFPI, I ) = AII END IF * * Update partial column norms. * DO 10 J = I + 1, N IF( VN1( J ).NE.ZERO ) THEN * * NOTE: The following 4 lines follow from the analysis in * Lapack Working Note 176. * TEMP = ONE - ( ABS( A( OFFPI, J ) ) / VN1( J ) )**2 TEMP = MAX( TEMP, ZERO ) TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 IF( TEMP2 .LE. TOL3Z ) THEN IF( OFFPI.LT.M ) THEN VN1( J ) = DNRM2( M-OFFPI, A( OFFPI+1, J ), 1 ) VN2( J ) = VN1( J ) ELSE VN1( J ) = ZERO VN2( J ) = ZERO END IF ELSE VN1( J ) = VN1( J )*SQRT( TEMP ) END IF END IF 10 CONTINUE * 20 CONTINUE * RETURN * * End of DLAQP2 * END *> \brief \b DLAQPS computes a step of QR factorization with column pivoting of a real m-by-n matrix A by using BLAS level 3. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAQPS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, * VN2, AUXV, F, LDF ) * * .. Scalar Arguments .. * INTEGER KB, LDA, LDF, M, N, NB, OFFSET * .. * .. Array Arguments .. * INTEGER JPVT( * ) * DOUBLE PRECISION A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ), * $ VN1( * ), VN2( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAQPS computes a step of QR factorization with column pivoting *> of a real M-by-N matrix A by using Blas-3. It tries to factorize *> NB columns from A starting from the row OFFSET+1, and updates all *> of the matrix with Blas-3 xGEMM. *> *> In some cases, due to catastrophic cancellations, it cannot *> factorize NB columns. Hence, the actual number of factorized *> columns is returned in KB. *> *> Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0 *> \endverbatim *> *> \param[in] OFFSET *> \verbatim *> OFFSET is INTEGER *> The number of rows of A that have been factorized in *> previous steps. *> \endverbatim *> *> \param[in] NB *> \verbatim *> NB is INTEGER *> The number of columns to factorize. *> \endverbatim *> *> \param[out] KB *> \verbatim *> KB is INTEGER *> The number of columns actually factorized. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the M-by-N matrix A. *> On exit, block A(OFFSET+1:M,1:KB) is the triangular *> factor obtained and block A(1:OFFSET,1:N) has been *> accordingly pivoted, but no factorized. *> The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has *> been updated. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in,out] JPVT *> \verbatim *> JPVT is INTEGER array, dimension (N) *> JPVT(I) = K <==> Column K of the full matrix A has been *> permuted into position I in AP. *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (KB) *> The scalar factors of the elementary reflectors. *> \endverbatim *> *> \param[in,out] VN1 *> \verbatim *> VN1 is DOUBLE PRECISION array, dimension (N) *> The vector with the partial column norms. *> \endverbatim *> *> \param[in,out] VN2 *> \verbatim *> VN2 is DOUBLE PRECISION array, dimension (N) *> The vector with the exact column norms. *> \endverbatim *> *> \param[in,out] AUXV *> \verbatim *> AUXV is DOUBLE PRECISION array, dimension (NB) *> Auxiliar vector. *> \endverbatim *> *> \param[in,out] F *> \verbatim *> F is DOUBLE PRECISION array, dimension (LDF,NB) *> Matrix F**T = L*Y**T*A. *> \endverbatim *> *> \param[in] LDF *> \verbatim *> LDF is INTEGER *> The leading dimension of the array F. LDF >= max(1,N). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Contributors: * ================== *> *> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain *> X. Sun, Computer Science Dept., Duke University, USA *> \n *> Partial column norm updating strategy modified on April 2011 *> Z. Drmac and Z. Bujanovic, Dept. of Mathematics, *> University of Zagreb, Croatia. * *> \par References: * ================ *> *> LAPACK Working Note 176 * *> \htmlonly *> [PDF] *> \endhtmlonly * * ===================================================================== SUBROUTINE DLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, $ VN2, AUXV, F, LDF ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER KB, LDA, LDF, M, N, NB, OFFSET * .. * .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ), $ VN1( * ), VN2( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER ITEMP, J, K, LASTRK, LSTICC, PVT, RK DOUBLE PRECISION AKK, TEMP, TEMP2, TOL3Z * .. * .. External Subroutines .. EXTERNAL DGEMM, DGEMV, DLARFG, DSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN, NINT, SQRT * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DNRM2 EXTERNAL IDAMAX, DLAMCH, DNRM2 * .. * .. Executable Statements .. * LASTRK = MIN( M, N+OFFSET ) LSTICC = 0 K = 0 TOL3Z = SQRT(DLAMCH('Epsilon')) * * Beginning of while loop. * 10 CONTINUE IF( ( K.LT.NB ) .AND. ( LSTICC.EQ.0 ) ) THEN K = K + 1 RK = OFFSET + K * * Determine ith pivot column and swap if necessary * PVT = ( K-1 ) + IDAMAX( N-K+1, VN1( K ), 1 ) IF( PVT.NE.K ) THEN CALL DSWAP( M, A( 1, PVT ), 1, A( 1, K ), 1 ) CALL DSWAP( K-1, F( PVT, 1 ), LDF, F( K, 1 ), LDF ) ITEMP = JPVT( PVT ) JPVT( PVT ) = JPVT( K ) JPVT( K ) = ITEMP VN1( PVT ) = VN1( K ) VN2( PVT ) = VN2( K ) END IF * * Apply previous Householder reflectors to column K: * A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)**T. * IF( K.GT.1 ) THEN CALL DGEMV( 'No transpose', M-RK+1, K-1, -ONE, A( RK, 1 ), $ LDA, F( K, 1 ), LDF, ONE, A( RK, K ), 1 ) END IF * * Generate elementary reflector H(k). * IF( RK.LT.M ) THEN CALL DLARFG( M-RK+1, A( RK, K ), A( RK+1, K ), 1, TAU( K ) ) ELSE CALL DLARFG( 1, A( RK, K ), A( RK, K ), 1, TAU( K ) ) END IF * AKK = A( RK, K ) A( RK, K ) = ONE * * Compute Kth column of F: * * Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)**T*A(RK:M,K). * IF( K.LT.N ) THEN CALL DGEMV( 'Transpose', M-RK+1, N-K, TAU( K ), $ A( RK, K+1 ), LDA, A( RK, K ), 1, ZERO, $ F( K+1, K ), 1 ) END IF * * Padding F(1:K,K) with zeros. * DO 20 J = 1, K F( J, K ) = ZERO 20 CONTINUE * * Incremental updating of F: * F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)**T * *A(RK:M,K). * IF( K.GT.1 ) THEN CALL DGEMV( 'Transpose', M-RK+1, K-1, -TAU( K ), A( RK, 1 ), $ LDA, A( RK, K ), 1, ZERO, AUXV( 1 ), 1 ) * CALL DGEMV( 'No transpose', N, K-1, ONE, F( 1, 1 ), LDF, $ AUXV( 1 ), 1, ONE, F( 1, K ), 1 ) END IF * * Update the current row of A: * A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)**T. * IF( K.LT.N ) THEN CALL DGEMV( 'No transpose', N-K, K, -ONE, F( K+1, 1 ), LDF, $ A( RK, 1 ), LDA, ONE, A( RK, K+1 ), LDA ) END IF * * Update partial column norms. * IF( RK.LT.LASTRK ) THEN DO 30 J = K + 1, N IF( VN1( J ).NE.ZERO ) THEN * * NOTE: The following 4 lines follow from the analysis in * Lapack Working Note 176. * TEMP = ABS( A( RK, J ) ) / VN1( J ) TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 IF( TEMP2 .LE. TOL3Z ) THEN VN2( J ) = DBLE( LSTICC ) LSTICC = J ELSE VN1( J ) = VN1( J )*SQRT( TEMP ) END IF END IF 30 CONTINUE END IF * A( RK, K ) = AKK * * End of while loop. * GO TO 10 END IF KB = K RK = OFFSET + KB * * Apply the block reflector to the rest of the matrix: * A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) - * A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)**T. * IF( KB.LT.MIN( N, M-OFFSET ) ) THEN CALL DGEMM( 'No transpose', 'Transpose', M-RK, N-KB, KB, -ONE, $ A( RK+1, 1 ), LDA, F( KB+1, 1 ), LDF, ONE, $ A( RK+1, KB+1 ), LDA ) END IF * * Recomputation of difficult columns. * 40 CONTINUE IF( LSTICC.GT.0 ) THEN ITEMP = NINT( VN2( LSTICC ) ) VN1( LSTICC ) = DNRM2( M-RK, A( RK+1, LSTICC ), 1 ) * * NOTE: The computation of VN1( LSTICC ) relies on the fact that * SNRM2 does not fail on vectors with norm below the value of * SQRT(DLAMCH('S')) * VN2( LSTICC ) = VN1( LSTICC ) LSTICC = ITEMP GO TO 40 END IF * RETURN * * End of DLAQPS * END *> \brief \b DLAQR0 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAQR0 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, * ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N * LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. * DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAQR0 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTT *> \verbatim *> WANTT is LOGICAL *> = .TRUE. : the full Schur form T is required; *> = .FALSE.: only eigenvalues are required. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> = .TRUE. : the matrix of Schur vectors Z is required; *> = .FALSE.: Schur vectors are not required. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix H. N .GE. 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> It is assumed that H is already upper triangular in rows *> and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, *> H(ILO,ILO-1) is zero. 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. *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is DOUBLE PRECISION array, dimension (LDH,N) *> On entry, the upper Hessenberg matrix H. *> On exit, if INFO = 0 and WANTT is .TRUE., 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 WANTT is *> .FALSE., then 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.) *> *> This subroutine may explicitly set H(i,j) = 0 for i.GT.j and *> j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is INTEGER *> The leading dimension of the array H. LDH .GE. max(1,N). *> \endverbatim *> *> \param[out] WR *> \verbatim *> WR is DOUBLE PRECISION array, dimension (IHI) *> \endverbatim *> *> \param[out] WI *> \verbatim *> WI is DOUBLE PRECISION array, dimension (IHI) *> The real and imaginary parts, respectively, of the computed *> eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI) *> and WI(ILO:IHI). 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 WANTT is .TRUE., then *> 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). *> \endverbatim *> *> \param[in] ILOZ *> \verbatim *> ILOZ is INTEGER *> \endverbatim *> *> \param[in] IHIZ *> \verbatim *> IHIZ is INTEGER *> Specify the rows of Z to which transformations must be *> applied if WANTZ is .TRUE.. *> 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ,IHI) *> If WANTZ is .FALSE., then Z is not referenced. *> If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is *> replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the *> orthogonal Schur factor of H(ILO:IHI,ILO:IHI). *> (The output value of Z when INFO.GT.0 is given under *> the description of INFO below.) *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. if WANTZ is .TRUE. *> then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension LWORK *> On exit, if LWORK = -1, WORK(1) returns an estimate of *> the optimal value for LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is 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 DLAQR0 does a workspace query. *> In this case, DLAQR0 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> .GT. 0: if INFO = i, DLAQR0 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 WANT is .FALSE., 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 WANTT is .TRUE., 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 WANTZ is .TRUE., then on exit *> *> (final value of Z(ILO:IHI,ILOZ:IHIZ) *> = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U *> *> where U is the orthogonal matrix in (*) (regard- *> less of the value of WANTT.) *> *> If INFO .GT. 0 and WANTZ is .FALSE., then Z is not *> accessed. *> \endverbatim * *> \par Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA * *> \par 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. *> \n *> 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. * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), $ Z( LDZ, * ) * .. * * ================================================================ * * .. Parameters .. * * ==== Matrices of order NTINY or smaller must be processed by * . DLAHQR because of insufficient subdiagonal scratch space. * . (This is a hard limit.) ==== INTEGER NTINY PARAMETER ( NTINY = 11 ) * * ==== Exceptional deflation windows: try to cure rare * . slow convergence by varying the size of the * . deflation window after KEXNW iterations. ==== INTEGER KEXNW PARAMETER ( KEXNW = 5 ) * * ==== Exceptional shifts: try to cure rare slow convergence * . with ad-hoc exceptional shifts every KEXSH iterations. * . ==== INTEGER KEXSH PARAMETER ( KEXSH = 6 ) * * ==== The constants WILK1 and WILK2 are used to form the * . exceptional shifts. ==== DOUBLE PRECISION WILK1, WILK2 PARAMETER ( WILK1 = 0.75d0, WILK2 = -0.4375d0 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) * .. * .. Local Scalars .. DOUBLE PRECISION AA, BB, CC, CS, DD, SN, SS, SWAP INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, $ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS, $ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD LOGICAL SORTED CHARACTER JBCMPZ*2 * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Local Arrays .. DOUBLE PRECISION ZDUM( 1, 1 ) * .. * .. External Subroutines .. EXTERNAL DLACPY, DLAHQR, DLANV2, DLAQR3, DLAQR4, DLAQR5 * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MIN, MOD * .. * .. Executable Statements .. INFO = 0 * * ==== Quick return for N = 0: nothing to do. ==== * IF( N.EQ.0 ) THEN WORK( 1 ) = ONE RETURN END IF * IF( N.LE.NTINY ) THEN * * ==== Tiny matrices must use DLAHQR. ==== * LWKOPT = 1 IF( LWORK.NE.-1 ) $ CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, INFO ) ELSE * * ==== Use small bulge multi-shift QR with aggressive early * . deflation on larger-than-tiny matrices. ==== * * ==== Hope for the best. ==== * INFO = 0 * * ==== Set up job flags for ILAENV. ==== * IF( WANTT ) THEN JBCMPZ( 1: 1 ) = 'S' ELSE JBCMPZ( 1: 1 ) = 'E' END IF IF( WANTZ ) THEN JBCMPZ( 2: 2 ) = 'V' ELSE JBCMPZ( 2: 2 ) = 'N' END IF * * ==== NWR = recommended deflation window size. At this * . point, N .GT. NTINY = 11, so there is enough * . subdiagonal workspace for NWR.GE.2 as required. * . (In fact, there is enough subdiagonal space for * . NWR.GE.3.) ==== * NWR = ILAENV( 13, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) NWR = MAX( 2, NWR ) NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) * * ==== NSR = recommended number of simultaneous shifts. * . At this point N .GT. NTINY = 11, so there is at * . enough subdiagonal workspace for NSR to be even * . and greater than or equal to two as required. ==== * NSR = ILAENV( 15, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) * * ==== Estimate optimal workspace ==== * * ==== Workspace query call to DLAQR3 ==== * CALL DLAQR3( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, $ IHIZ, Z, LDZ, LS, LD, WR, WI, H, LDH, N, H, LDH, $ N, H, LDH, WORK, -1 ) * * ==== Optimal workspace = MAX(DLAQR5, DLAQR3) ==== * LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) * * ==== Quick return in case of workspace query. ==== * IF( LWORK.EQ.-1 ) THEN WORK( 1 ) = DBLE( LWKOPT ) RETURN END IF * * ==== DLAHQR/DLAQR0 crossover point ==== * NMIN = ILAENV( 12, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) NMIN = MAX( NTINY, NMIN ) * * ==== Nibble crossover point ==== * NIBBLE = ILAENV( 14, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) NIBBLE = MAX( 0, NIBBLE ) * * ==== Accumulate reflections during ttswp? Use block * . 2-by-2 structure during matrix-matrix multiply? ==== * KACC22 = ILAENV( 16, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) KACC22 = MAX( 0, KACC22 ) KACC22 = MIN( 2, KACC22 ) * * ==== NWMAX = the largest possible deflation window for * . which there is sufficient workspace. ==== * NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) NW = NWMAX * * ==== NSMAX = the Largest number of simultaneous shifts * . for which there is sufficient workspace. ==== * NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) NSMAX = NSMAX - MOD( NSMAX, 2 ) * * ==== NDFL: an iteration count restarted at deflation. ==== * NDFL = 1 * * ==== ITMAX = iteration limit ==== * ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) * * ==== Last row and column in the active block ==== * KBOT = IHI * * ==== Main Loop ==== * DO 80 IT = 1, ITMAX * * ==== Done when KBOT falls below ILO ==== * IF( KBOT.LT.ILO ) $ GO TO 90 * * ==== Locate active block ==== * DO 10 K = KBOT, ILO + 1, -1 IF( H( K, K-1 ).EQ.ZERO ) $ GO TO 20 10 CONTINUE K = ILO 20 CONTINUE KTOP = K * * ==== Select deflation window size: * . Typical Case: * . If possible and advisable, nibble the entire * . active block. If not, use size MIN(NWR,NWMAX) * . or MIN(NWR+1,NWMAX) depending upon which has * . the smaller corresponding subdiagonal entry * . (a heuristic). * . * . Exceptional Case: * . If there have been no deflations in KEXNW or * . more iterations, then vary the deflation window * . size. At first, because, larger windows are, * . in general, more powerful than smaller ones, * . rapidly increase the window to the maximum possible. * . Then, gradually reduce the window size. ==== * NH = KBOT - KTOP + 1 NWUPBD = MIN( NH, NWMAX ) IF( NDFL.LT.KEXNW ) THEN NW = MIN( NWUPBD, NWR ) ELSE NW = MIN( NWUPBD, 2*NW ) END IF IF( NW.LT.NWMAX ) THEN IF( NW.GE.NH-1 ) THEN NW = NH ELSE KWTOP = KBOT - NW + 1 IF( ABS( H( KWTOP, KWTOP-1 ) ).GT. $ ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 END IF END IF IF( NDFL.LT.KEXNW ) THEN NDEC = -1 ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN NDEC = NDEC + 1 IF( NW-NDEC.LT.2 ) $ NDEC = 0 NW = NW - NDEC END IF * * ==== Aggressive early deflation: * . split workspace under the subdiagonal into * . - an nw-by-nw work array V in the lower * . left-hand-corner, * . - an NW-by-at-least-NW-but-more-is-better * . (NW-by-NHO) horizontal work array along * . the bottom edge, * . - an at-least-NW-but-more-is-better (NHV-by-NW) * . vertical work array along the left-hand-edge. * . ==== * KV = N - NW + 1 KT = NW + 1 NHO = ( N-NW-1 ) - KT + 1 KWV = NW + 2 NVE = ( N-NW ) - KWV + 1 * * ==== Aggressive early deflation ==== * CALL DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, $ IHIZ, Z, LDZ, LS, LD, WR, WI, H( KV, 1 ), LDH, $ NHO, H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, $ WORK, LWORK ) * * ==== Adjust KBOT accounting for new deflations. ==== * KBOT = KBOT - LD * * ==== KS points to the shifts. ==== * KS = KBOT - LS + 1 * * ==== Skip an expensive QR sweep if there is a (partly * . heuristic) reason to expect that many eigenvalues * . will deflate without it. Here, the QR sweep is * . skipped if many eigenvalues have just been deflated * . or if the remaining active block is small. * IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN * * ==== NS = nominal number of simultaneous shifts. * . This may be lowered (slightly) if DLAQR3 * . did not provide that many shifts. ==== * NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) NS = NS - MOD( NS, 2 ) * * ==== If there have been no deflations * . in a multiple of KEXSH iterations, * . then try exceptional shifts. * . Otherwise use shifts provided by * . DLAQR3 above or from the eigenvalues * . of a trailing principal submatrix. ==== * IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN KS = KBOT - NS + 1 DO 30 I = KBOT, MAX( KS+1, KTOP+2 ), -2 SS = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) ) AA = WILK1*SS + H( I, I ) BB = SS CC = WILK2*SS DD = AA CALL DLANV2( AA, BB, CC, DD, WR( I-1 ), WI( I-1 ), $ WR( I ), WI( I ), CS, SN ) 30 CONTINUE IF( KS.EQ.KTOP ) THEN WR( KS+1 ) = H( KS+1, KS+1 ) WI( KS+1 ) = ZERO WR( KS ) = WR( KS+1 ) WI( KS ) = WI( KS+1 ) END IF ELSE * * ==== Got NS/2 or fewer shifts? Use DLAQR4 or * . DLAHQR on a trailing principal submatrix to * . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, * . there is enough space below the subdiagonal * . to fit an NS-by-NS scratch array.) ==== * IF( KBOT-KS+1.LE.NS / 2 ) THEN KS = KBOT - NS + 1 KT = N - NS + 1 CALL DLACPY( 'A', NS, NS, H( KS, KS ), LDH, $ H( KT, 1 ), LDH ) IF( NS.GT.NMIN ) THEN CALL DLAQR4( .false., .false., NS, 1, NS, $ H( KT, 1 ), LDH, WR( KS ), $ WI( KS ), 1, 1, ZDUM, 1, WORK, $ LWORK, INF ) ELSE CALL DLAHQR( .false., .false., NS, 1, NS, $ H( KT, 1 ), LDH, WR( KS ), $ WI( KS ), 1, 1, ZDUM, 1, INF ) END IF KS = KS + INF * * ==== In case of a rare QR failure use * . eigenvalues of the trailing 2-by-2 * . principal submatrix. ==== * IF( KS.GE.KBOT ) THEN AA = H( KBOT-1, KBOT-1 ) CC = H( KBOT, KBOT-1 ) BB = H( KBOT-1, KBOT ) DD = H( KBOT, KBOT ) CALL DLANV2( AA, BB, CC, DD, WR( KBOT-1 ), $ WI( KBOT-1 ), WR( KBOT ), $ WI( KBOT ), CS, SN ) KS = KBOT - 1 END IF END IF * IF( KBOT-KS+1.GT.NS ) THEN * * ==== Sort the shifts (Helps a little) * . Bubble sort keeps complex conjugate * . pairs together. ==== * SORTED = .false. DO 50 K = KBOT, KS + 1, -1 IF( SORTED ) $ GO TO 60 SORTED = .true. DO 40 I = KS, K - 1 IF( ABS( WR( I ) )+ABS( WI( I ) ).LT. $ ABS( WR( I+1 ) )+ABS( WI( I+1 ) ) ) THEN SORTED = .false. * SWAP = WR( I ) WR( I ) = WR( I+1 ) WR( I+1 ) = SWAP * SWAP = WI( I ) WI( I ) = WI( I+1 ) WI( I+1 ) = SWAP END IF 40 CONTINUE 50 CONTINUE 60 CONTINUE END IF * * ==== Shuffle shifts into pairs of real shifts * . and pairs of complex conjugate shifts * . assuming complex conjugate shifts are * . already adjacent to one another. (Yes, * . they are.) ==== * DO 70 I = KBOT, KS + 2, -2 IF( WI( I ).NE.-WI( I-1 ) ) THEN * SWAP = WR( I ) WR( I ) = WR( I-1 ) WR( I-1 ) = WR( I-2 ) WR( I-2 ) = SWAP * SWAP = WI( I ) WI( I ) = WI( I-1 ) WI( I-1 ) = WI( I-2 ) WI( I-2 ) = SWAP END IF 70 CONTINUE END IF * * ==== If there are only two shifts and both are * . real, then use only one. ==== * IF( KBOT-KS+1.EQ.2 ) THEN IF( WI( KBOT ).EQ.ZERO ) THEN IF( ABS( WR( KBOT )-H( KBOT, KBOT ) ).LT. $ ABS( WR( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN WR( KBOT-1 ) = WR( KBOT ) ELSE WR( KBOT ) = WR( KBOT-1 ) END IF END IF END IF * * ==== Use up to NS of the the smallest magnatiude * . shifts. If there aren't NS shifts available, * . then use them all, possibly dropping one to * . make the number of shifts even. ==== * NS = MIN( NS, KBOT-KS+1 ) NS = NS - MOD( NS, 2 ) KS = KBOT - NS + 1 * * ==== Small-bulge multi-shift QR sweep: * . split workspace under the subdiagonal into * . - a KDU-by-KDU work array U in the lower * . left-hand-corner, * . - a KDU-by-at-least-KDU-but-more-is-better * . (KDU-by-NHo) horizontal work array WH along * . the bottom edge, * . - and an at-least-KDU-but-more-is-better-by-KDU * . (NVE-by-KDU) vertical work WV arrow along * . the left-hand-edge. ==== * KDU = 3*NS - 3 KU = N - KDU + 1 KWH = KDU + 1 NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 KWV = KDU + 4 NVE = N - KDU - KWV + 1 * * ==== Small-bulge multi-shift QR sweep ==== * CALL DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, $ WR( KS ), WI( KS ), H, LDH, ILOZ, IHIZ, Z, $ LDZ, WORK, 3, H( KU, 1 ), LDH, NVE, $ H( KWV, 1 ), LDH, NHO, H( KU, KWH ), LDH ) END IF * * ==== Note progress (or the lack of it). ==== * IF( LD.GT.0 ) THEN NDFL = 1 ELSE NDFL = NDFL + 1 END IF * * ==== End of main loop ==== 80 CONTINUE * * ==== Iteration limit exceeded. Set INFO to show where * . the problem occurred and exit. ==== * INFO = KBOT 90 CONTINUE END IF * * ==== Return the optimal value of LWORK. ==== * WORK( 1 ) = DBLE( LWKOPT ) * * ==== End of DLAQR0 ==== * END *> \brief \b DLAQR1 sets a scalar multiple of the first column of the product of 2-by-2 or 3-by-3 matrix H and specified shifts. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAQR1 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V ) * * .. Scalar Arguments .. * DOUBLE PRECISION SI1, SI2, SR1, SR2 * INTEGER LDH, N * .. * .. Array Arguments .. * DOUBLE PRECISION H( LDH, * ), V( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> Given a 2-by-2 or 3-by-3 matrix H, DLAQR1 sets v to a *> scalar multiple of the first column of the product *> *> (*) K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I) *> *> scaling to avoid overflows and most underflows. It *> is assumed that either *> *> 1) sr1 = sr2 and si1 = -si2 *> or *> 2) si1 = si2 = 0. *> *> This is useful for starting double implicit shift bulges *> in the QR algorithm. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> Order of the matrix H. N must be either 2 or 3. *> \endverbatim *> *> \param[in] H *> \verbatim *> H is DOUBLE PRECISION array, dimension (LDH,N) *> The 2-by-2 or 3-by-3 matrix H in (*). *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is INTEGER *> The leading dimension of H as declared in *> the calling procedure. LDH.GE.N *> \endverbatim *> *> \param[in] SR1 *> \verbatim *> SR1 is DOUBLE PRECISION *> \endverbatim *> *> \param[in] SI1 *> \verbatim *> SI1 is DOUBLE PRECISION *> \endverbatim *> *> \param[in] SR2 *> \verbatim *> SR2 is DOUBLE PRECISION *> \endverbatim *> *> \param[in] SI2 *> \verbatim *> SI2 is DOUBLE PRECISION *> The shifts in (*). *> \endverbatim *> *> \param[out] V *> \verbatim *> V is DOUBLE PRECISION array, dimension (N) *> A scalar multiple of the first column of the *> matrix K in (*). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup doubleOTHERauxiliary * *> \par Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA *> * ===================================================================== SUBROUTINE DLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V ) * * -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. DOUBLE PRECISION SI1, SI2, SR1, SR2 INTEGER LDH, N * .. * .. Array Arguments .. DOUBLE PRECISION H( LDH, * ), V( * ) * .. * * ================================================================ * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0d0 ) * .. * .. Local Scalars .. DOUBLE PRECISION H21S, H31S, S * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. IF( N.EQ.2 ) THEN S = ABS( H( 1, 1 )-SR2 ) + ABS( SI2 ) + ABS( H( 2, 1 ) ) IF( S.EQ.ZERO ) THEN V( 1 ) = ZERO V( 2 ) = ZERO ELSE H21S = H( 2, 1 ) / S V( 1 ) = H21S*H( 1, 2 ) + ( H( 1, 1 )-SR1 )* $ ( ( H( 1, 1 )-SR2 ) / S ) - SI1*( SI2 / S ) V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-SR1-SR2 ) END IF ELSE S = ABS( H( 1, 1 )-SR2 ) + ABS( SI2 ) + ABS( H( 2, 1 ) ) + $ ABS( H( 3, 1 ) ) IF( S.EQ.ZERO ) THEN V( 1 ) = ZERO V( 2 ) = ZERO V( 3 ) = ZERO ELSE H21S = H( 2, 1 ) / S H31S = H( 3, 1 ) / S V( 1 ) = ( H( 1, 1 )-SR1 )*( ( H( 1, 1 )-SR2 ) / S ) - $ SI1*( SI2 / S ) + H( 1, 2 )*H21S + H( 1, 3 )*H31S V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-SR1-SR2 ) + $ H( 2, 3 )*H31S V( 3 ) = H31S*( H( 1, 1 )+H( 3, 3 )-SR1-SR2 ) + $ H21S*H( 3, 2 ) END IF END IF END *> \brief \b DLAQR2 performs the orthogonal similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAQR2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, * IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, * LDT, NV, WV, LDWV, WORK, LWORK ) * * .. Scalar Arguments .. * INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, * $ LDZ, LWORK, N, ND, NH, NS, NV, NW * LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. * DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), * $ V( LDV, * ), WORK( * ), WV( LDWV, * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAQR2 is identical to DLAQR3 except that it avoids *> recursion by calling DLAHQR instead of DLAQR4. *> *> Aggressive early deflation: *> *> This subroutine accepts as input an upper Hessenberg matrix *> H and performs an orthogonal similarity transformation *> designed to detect and deflate fully converged eigenvalues from *> a trailing principal submatrix. On output H has been over- *> written by a new Hessenberg matrix that is a perturbation of *> an orthogonal similarity transformation of H. It is to be *> hoped that the final version of H has many zero subdiagonal *> entries. *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTT *> \verbatim *> WANTT is LOGICAL *> If .TRUE., then the Hessenberg matrix H is fully updated *> so that the quasi-triangular Schur factor may be *> computed (in cooperation with the calling subroutine). *> If .FALSE., then only enough of H is updated to preserve *> the eigenvalues. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> If .TRUE., then the orthogonal matrix Z is updated so *> so that the orthogonal Schur factor may be computed *> (in cooperation with the calling subroutine). *> If .FALSE., then Z is not referenced. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix H and (if WANTZ is .TRUE.) the *> order of the orthogonal matrix Z. *> \endverbatim *> *> \param[in] KTOP *> \verbatim *> KTOP is INTEGER *> It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. *> KBOT and KTOP together determine an isolated block *> along the diagonal of the Hessenberg matrix. *> \endverbatim *> *> \param[in] KBOT *> \verbatim *> KBOT is INTEGER *> It is assumed without a check that either *> KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together *> determine an isolated block along the diagonal of the *> Hessenberg matrix. *> \endverbatim *> *> \param[in] NW *> \verbatim *> NW is INTEGER *> Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is DOUBLE PRECISION array, dimension (LDH,N) *> On input the initial N-by-N section of H stores the *> Hessenberg matrix undergoing aggressive early deflation. *> On output H has been transformed by an orthogonal *> similarity transformation, perturbed, and the returned *> to Hessenberg form that (it is to be hoped) has some *> zero subdiagonal entries. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is INTEGER *> Leading dimension of H just as declared in the calling *> subroutine. N .LE. LDH *> \endverbatim *> *> \param[in] ILOZ *> \verbatim *> ILOZ is INTEGER *> \endverbatim *> *> \param[in] IHIZ *> \verbatim *> IHIZ is INTEGER *> Specify the rows of Z to which transformations must be *> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ,N) *> IF WANTZ is .TRUE., then on output, the orthogonal *> similarity transformation mentioned above has been *> accumulated into Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. *> If WANTZ is .FALSE., then Z is unreferenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of Z just as declared in the *> calling subroutine. 1 .LE. LDZ. *> \endverbatim *> *> \param[out] NS *> \verbatim *> NS is INTEGER *> The number of unconverged (ie approximate) eigenvalues *> returned in SR and SI that may be used as shifts by the *> calling subroutine. *> \endverbatim *> *> \param[out] ND *> \verbatim *> ND is INTEGER *> The number of converged eigenvalues uncovered by this *> subroutine. *> \endverbatim *> *> \param[out] SR *> \verbatim *> SR is DOUBLE PRECISION array, dimension (KBOT) *> \endverbatim *> *> \param[out] SI *> \verbatim *> SI is DOUBLE PRECISION array, dimension (KBOT) *> On output, the real and imaginary parts of approximate *> eigenvalues that may be used for shifts are stored in *> SR(KBOT-ND-NS+1) through SR(KBOT-ND) and *> SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. *> The real and imaginary parts of converged eigenvalues *> are stored in SR(KBOT-ND+1) through SR(KBOT) and *> SI(KBOT-ND+1) through SI(KBOT), respectively. *> \endverbatim *> *> \param[out] V *> \verbatim *> V is DOUBLE PRECISION array, dimension (LDV,NW) *> An NW-by-NW work array. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of V just as declared in the *> calling subroutine. NW .LE. LDV *> \endverbatim *> *> \param[in] NH *> \verbatim *> NH is INTEGER *> The number of columns of T. NH.GE.NW. *> \endverbatim *> *> \param[out] T *> \verbatim *> T is DOUBLE PRECISION array, dimension (LDT,NW) *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of T just as declared in the *> calling subroutine. NW .LE. LDT *> \endverbatim *> *> \param[in] NV *> \verbatim *> NV is INTEGER *> The number of rows of work array WV available for *> workspace. NV.GE.NW. *> \endverbatim *> *> \param[out] WV *> \verbatim *> WV is DOUBLE PRECISION array, dimension (LDWV,NW) *> \endverbatim *> *> \param[in] LDWV *> \verbatim *> LDWV is INTEGER *> The leading dimension of W just as declared in the *> calling subroutine. NW .LE. LDV *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (LWORK) *> On exit, WORK(1) is set to an estimate of the optimal value *> of LWORK for the given values of N, NW, KTOP and KBOT. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the work array WORK. LWORK = 2*NW *> suffices, but greater efficiency may result from larger *> values of LWORK. *> *> If LWORK = -1, then a workspace query is assumed; DLAQR2 *> only estimates the optimal workspace size for the given *> values of N, NW, KTOP and KBOT. The estimate is returned *> in WORK(1). No error message related to LWORK is issued *> by XERBLA. Neither H nor Z are accessed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup doubleOTHERauxiliary * *> \par Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA *> * ===================================================================== SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, $ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, $ LDT, NV, WV, LDWV, WORK, LWORK ) * * -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, $ LDZ, LWORK, N, ND, NH, NS, NV, NW LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), $ V( LDV, * ), WORK( * ), WV( LDWV, * ), $ Z( LDZ, * ) * .. * * ================================================================ * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) * .. * .. Local Scalars .. DOUBLE PRECISION AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S, $ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL, $ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2, $ LWKOPT LOGICAL BULGE, SORTED * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. External Subroutines .. EXTERNAL DCOPY, DGEHRD, DGEMM, DLABAD, DLACPY, DLAHQR, $ DLANV2, DLARF, DLARFG, DLASET, DORMHR, DTREXC * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT * .. * .. Executable Statements .. * * ==== Estimate optimal workspace. ==== * JW = MIN( NW, KBOT-KTOP+1 ) IF( JW.LE.2 ) THEN LWKOPT = 1 ELSE * * ==== Workspace query call to DGEHRD ==== * CALL DGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) LWK1 = INT( WORK( 1 ) ) * * ==== Workspace query call to DORMHR ==== * CALL DORMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, $ WORK, -1, INFO ) LWK2 = INT( WORK( 1 ) ) * * ==== Optimal workspace ==== * LWKOPT = JW + MAX( LWK1, LWK2 ) END IF * * ==== Quick return in case of workspace query. ==== * IF( LWORK.EQ.-1 ) THEN WORK( 1 ) = DBLE( LWKOPT ) RETURN END IF * * ==== Nothing to do ... * ... for an empty active block ... ==== NS = 0 ND = 0 WORK( 1 ) = ONE IF( KTOP.GT.KBOT ) $ RETURN * ... nor for an empty deflation window. ==== IF( NW.LT.1 ) $ RETURN * * ==== Machine constants ==== * SAFMIN = DLAMCH( 'SAFE MINIMUM' ) SAFMAX = ONE / SAFMIN CALL DLABAD( SAFMIN, SAFMAX ) ULP = DLAMCH( 'PRECISION' ) SMLNUM = SAFMIN*( DBLE( N ) / ULP ) * * ==== Setup deflation window ==== * JW = MIN( NW, KBOT-KTOP+1 ) KWTOP = KBOT - JW + 1 IF( KWTOP.EQ.KTOP ) THEN S = ZERO ELSE S = H( KWTOP, KWTOP-1 ) END IF * IF( KBOT.EQ.KWTOP ) THEN * * ==== 1-by-1 deflation window: not much to do ==== * SR( KWTOP ) = H( KWTOP, KWTOP ) SI( KWTOP ) = ZERO NS = 1 ND = 0 IF( ABS( S ).LE.MAX( SMLNUM, ULP*ABS( H( KWTOP, KWTOP ) ) ) ) $ THEN NS = 0 ND = 1 IF( KWTOP.GT.KTOP ) $ H( KWTOP, KWTOP-1 ) = ZERO END IF WORK( 1 ) = ONE RETURN END IF * * ==== Convert to spike-triangular form. (In case of a * . rare QR failure, this routine continues to do * . aggressive early deflation using that part of * . the deflation window that converged using INFQR * . here and there to keep track.) ==== * CALL DLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) CALL DCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) * CALL DLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) CALL DLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ), $ SI( KWTOP ), 1, JW, V, LDV, INFQR ) * * ==== DTREXC needs a clean margin near the diagonal ==== * DO 10 J = 1, JW - 3 T( J+2, J ) = ZERO T( J+3, J ) = ZERO 10 CONTINUE IF( JW.GT.2 ) $ T( JW, JW-2 ) = ZERO * * ==== Deflation detection loop ==== * NS = JW ILST = INFQR + 1 20 CONTINUE IF( ILST.LE.NS ) THEN IF( NS.EQ.1 ) THEN BULGE = .FALSE. ELSE BULGE = T( NS, NS-1 ).NE.ZERO END IF * * ==== Small spike tip test for deflation ==== * IF( .NOT.BULGE ) THEN * * ==== Real eigenvalue ==== * FOO = ABS( T( NS, NS ) ) IF( FOO.EQ.ZERO ) $ FOO = ABS( S ) IF( ABS( S*V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN * * ==== Deflatable ==== * NS = NS - 1 ELSE * * ==== Undeflatable. Move it up out of the way. * . (DTREXC can not fail in this case.) ==== * IFST = NS CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, $ INFO ) ILST = ILST + 1 END IF ELSE * * ==== Complex conjugate pair ==== * FOO = ABS( T( NS, NS ) ) + SQRT( ABS( T( NS, NS-1 ) ) )* $ SQRT( ABS( T( NS-1, NS ) ) ) IF( FOO.EQ.ZERO ) $ FOO = ABS( S ) IF( MAX( ABS( S*V( 1, NS ) ), ABS( S*V( 1, NS-1 ) ) ).LE. $ MAX( SMLNUM, ULP*FOO ) ) THEN * * ==== Deflatable ==== * NS = NS - 2 ELSE * * ==== Undeflatable. Move them up out of the way. * . Fortunately, DTREXC does the right thing with * . ILST in case of a rare exchange failure. ==== * IFST = NS CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, $ INFO ) ILST = ILST + 2 END IF END IF * * ==== End deflation detection loop ==== * GO TO 20 END IF * * ==== Return to Hessenberg form ==== * IF( NS.EQ.0 ) $ S = ZERO * IF( NS.LT.JW ) THEN * * ==== sorting diagonal blocks of T improves accuracy for * . graded matrices. Bubble sort deals well with * . exchange failures. ==== * SORTED = .false. I = NS + 1 30 CONTINUE IF( SORTED ) $ GO TO 50 SORTED = .true. * KEND = I - 1 I = INFQR + 1 IF( I.EQ.NS ) THEN K = I + 1 ELSE IF( T( I+1, I ).EQ.ZERO ) THEN K = I + 1 ELSE K = I + 2 END IF 40 CONTINUE IF( K.LE.KEND ) THEN IF( K.EQ.I+1 ) THEN EVI = ABS( T( I, I ) ) ELSE EVI = ABS( T( I, I ) ) + SQRT( ABS( T( I+1, I ) ) )* $ SQRT( ABS( T( I, I+1 ) ) ) END IF * IF( K.EQ.KEND ) THEN EVK = ABS( T( K, K ) ) ELSE IF( T( K+1, K ).EQ.ZERO ) THEN EVK = ABS( T( K, K ) ) ELSE EVK = ABS( T( K, K ) ) + SQRT( ABS( T( K+1, K ) ) )* $ SQRT( ABS( T( K, K+1 ) ) ) END IF * IF( EVI.GE.EVK ) THEN I = K ELSE SORTED = .false. IFST = I ILST = K CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, $ INFO ) IF( INFO.EQ.0 ) THEN I = ILST ELSE I = K END IF END IF IF( I.EQ.KEND ) THEN K = I + 1 ELSE IF( T( I+1, I ).EQ.ZERO ) THEN K = I + 1 ELSE K = I + 2 END IF GO TO 40 END IF GO TO 30 50 CONTINUE END IF * * ==== Restore shift/eigenvalue array from T ==== * I = JW 60 CONTINUE IF( I.GE.INFQR+1 ) THEN IF( I.EQ.INFQR+1 ) THEN SR( KWTOP+I-1 ) = T( I, I ) SI( KWTOP+I-1 ) = ZERO I = I - 1 ELSE IF( T( I, I-1 ).EQ.ZERO ) THEN SR( KWTOP+I-1 ) = T( I, I ) SI( KWTOP+I-1 ) = ZERO I = I - 1 ELSE AA = T( I-1, I-1 ) CC = T( I, I-1 ) BB = T( I-1, I ) DD = T( I, I ) CALL DLANV2( AA, BB, CC, DD, SR( KWTOP+I-2 ), $ SI( KWTOP+I-2 ), SR( KWTOP+I-1 ), $ SI( KWTOP+I-1 ), CS, SN ) I = I - 2 END IF GO TO 60 END IF * IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN IF( NS.GT.1 .AND. S.NE.ZERO ) THEN * * ==== Reflect spike back into lower triangle ==== * CALL DCOPY( NS, V, LDV, WORK, 1 ) BETA = WORK( 1 ) CALL DLARFG( NS, BETA, WORK( 2 ), 1, TAU ) WORK( 1 ) = ONE * CALL DLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) * CALL DLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT, $ WORK( JW+1 ) ) CALL DLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, $ WORK( JW+1 ) ) CALL DLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, $ WORK( JW+1 ) ) * CALL DGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), $ LWORK-JW, INFO ) END IF * * ==== Copy updated reduced window into place ==== * IF( KWTOP.GT.1 ) $ H( KWTOP, KWTOP-1 ) = S*V( 1, 1 ) CALL DLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) CALL DCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), $ LDH+1 ) * * ==== Accumulate orthogonal matrix in order update * . H and Z, if requested. ==== * IF( NS.GT.1 .AND. S.NE.ZERO ) $ CALL DORMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, $ WORK( JW+1 ), LWORK-JW, INFO ) * * ==== Update vertical slab in H ==== * IF( WANTT ) THEN LTOP = 1 ELSE LTOP = KTOP END IF DO 70 KROW = LTOP, KWTOP - 1, NV KLN = MIN( NV, KWTOP-KROW ) CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), $ LDH, V, LDV, ZERO, WV, LDWV ) CALL DLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) 70 CONTINUE * * ==== Update horizontal slab in H ==== * IF( WANTT ) THEN DO 80 KCOL = KBOT + 1, N, NH KLN = MIN( NH, N-KCOL+1 ) CALL DGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) CALL DLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), $ LDH ) 80 CONTINUE END IF * * ==== Update vertical slab in Z ==== * IF( WANTZ ) THEN DO 90 KROW = ILOZ, IHIZ, NV KLN = MIN( NV, IHIZ-KROW+1 ) CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), $ LDZ, V, LDV, ZERO, WV, LDWV ) CALL DLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), $ LDZ ) 90 CONTINUE END IF END IF * * ==== Return the number of deflations ... ==== * ND = JW - NS * * ==== ... and the number of shifts. (Subtracting * . INFQR from the spike length takes care * . of the case of a rare QR failure while * . calculating eigenvalues of the deflation * . window.) ==== * NS = NS - INFQR * * ==== Return optimal workspace. ==== * WORK( 1 ) = DBLE( LWKOPT ) * * ==== End of DLAQR2 ==== * END *> \brief \b DLAQR3 performs the orthogonal similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAQR3 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, * IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, * LDT, NV, WV, LDWV, WORK, LWORK ) * * .. Scalar Arguments .. * INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, * $ LDZ, LWORK, N, ND, NH, NS, NV, NW * LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. * DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), * $ V( LDV, * ), WORK( * ), WV( LDWV, * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> Aggressive early deflation: *> *> DLAQR3 accepts as input an upper Hessenberg matrix *> H and performs an orthogonal similarity transformation *> designed to detect and deflate fully converged eigenvalues from *> a trailing principal submatrix. On output H has been over- *> written by a new Hessenberg matrix that is a perturbation of *> an orthogonal similarity transformation of H. It is to be *> hoped that the final version of H has many zero subdiagonal *> entries. *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTT *> \verbatim *> WANTT is LOGICAL *> If .TRUE., then the Hessenberg matrix H is fully updated *> so that the quasi-triangular Schur factor may be *> computed (in cooperation with the calling subroutine). *> If .FALSE., then only enough of H is updated to preserve *> the eigenvalues. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> If .TRUE., then the orthogonal matrix Z is updated so *> so that the orthogonal Schur factor may be computed *> (in cooperation with the calling subroutine). *> If .FALSE., then Z is not referenced. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix H and (if WANTZ is .TRUE.) the *> order of the orthogonal matrix Z. *> \endverbatim *> *> \param[in] KTOP *> \verbatim *> KTOP is INTEGER *> It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. *> KBOT and KTOP together determine an isolated block *> along the diagonal of the Hessenberg matrix. *> \endverbatim *> *> \param[in] KBOT *> \verbatim *> KBOT is INTEGER *> It is assumed without a check that either *> KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together *> determine an isolated block along the diagonal of the *> Hessenberg matrix. *> \endverbatim *> *> \param[in] NW *> \verbatim *> NW is INTEGER *> Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is DOUBLE PRECISION array, dimension (LDH,N) *> On input the initial N-by-N section of H stores the *> Hessenberg matrix undergoing aggressive early deflation. *> On output H has been transformed by an orthogonal *> similarity transformation, perturbed, and the returned *> to Hessenberg form that (it is to be hoped) has some *> zero subdiagonal entries. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is INTEGER *> Leading dimension of H just as declared in the calling *> subroutine. N .LE. LDH *> \endverbatim *> *> \param[in] ILOZ *> \verbatim *> ILOZ is INTEGER *> \endverbatim *> *> \param[in] IHIZ *> \verbatim *> IHIZ is INTEGER *> Specify the rows of Z to which transformations must be *> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ,N) *> IF WANTZ is .TRUE., then on output, the orthogonal *> similarity transformation mentioned above has been *> accumulated into Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. *> If WANTZ is .FALSE., then Z is unreferenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of Z just as declared in the *> calling subroutine. 1 .LE. LDZ. *> \endverbatim *> *> \param[out] NS *> \verbatim *> NS is INTEGER *> The number of unconverged (ie approximate) eigenvalues *> returned in SR and SI that may be used as shifts by the *> calling subroutine. *> \endverbatim *> *> \param[out] ND *> \verbatim *> ND is INTEGER *> The number of converged eigenvalues uncovered by this *> subroutine. *> \endverbatim *> *> \param[out] SR *> \verbatim *> SR is DOUBLE PRECISION array, dimension (KBOT) *> \endverbatim *> *> \param[out] SI *> \verbatim *> SI is DOUBLE PRECISION array, dimension (KBOT) *> On output, the real and imaginary parts of approximate *> eigenvalues that may be used for shifts are stored in *> SR(KBOT-ND-NS+1) through SR(KBOT-ND) and *> SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. *> The real and imaginary parts of converged eigenvalues *> are stored in SR(KBOT-ND+1) through SR(KBOT) and *> SI(KBOT-ND+1) through SI(KBOT), respectively. *> \endverbatim *> *> \param[out] V *> \verbatim *> V is DOUBLE PRECISION array, dimension (LDV,NW) *> An NW-by-NW work array. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of V just as declared in the *> calling subroutine. NW .LE. LDV *> \endverbatim *> *> \param[in] NH *> \verbatim *> NH is INTEGER *> The number of columns of T. NH.GE.NW. *> \endverbatim *> *> \param[out] T *> \verbatim *> T is DOUBLE PRECISION array, dimension (LDT,NW) *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of T just as declared in the *> calling subroutine. NW .LE. LDT *> \endverbatim *> *> \param[in] NV *> \verbatim *> NV is INTEGER *> The number of rows of work array WV available for *> workspace. NV.GE.NW. *> \endverbatim *> *> \param[out] WV *> \verbatim *> WV is DOUBLE PRECISION array, dimension (LDWV,NW) *> \endverbatim *> *> \param[in] LDWV *> \verbatim *> LDWV is INTEGER *> The leading dimension of W just as declared in the *> calling subroutine. NW .LE. LDV *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (LWORK) *> On exit, WORK(1) is set to an estimate of the optimal value *> of LWORK for the given values of N, NW, KTOP and KBOT. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the work array WORK. LWORK = 2*NW *> suffices, but greater efficiency may result from larger *> values of LWORK. *> *> If LWORK = -1, then a workspace query is assumed; DLAQR3 *> only estimates the optimal workspace size for the given *> values of N, NW, KTOP and KBOT. The estimate is returned *> in WORK(1). No error message related to LWORK is issued *> by XERBLA. Neither H nor Z are accessed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA *> * ===================================================================== SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, $ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, $ LDT, NV, WV, LDWV, WORK, LWORK ) * * -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, $ LDZ, LWORK, N, ND, NH, NS, NV, NW LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), $ V( LDV, * ), WORK( * ), WV( LDWV, * ), $ Z( LDZ, * ) * .. * * ================================================================ * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) * .. * .. Local Scalars .. DOUBLE PRECISION AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S, $ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL, $ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3, $ LWKOPT, NMIN LOGICAL BULGE, SORTED * .. * .. External Functions .. DOUBLE PRECISION DLAMCH INTEGER ILAENV EXTERNAL DLAMCH, ILAENV * .. * .. External Subroutines .. EXTERNAL DCOPY, DGEHRD, DGEMM, DLABAD, DLACPY, DLAHQR, $ DLANV2, DLAQR4, DLARF, DLARFG, DLASET, DORMHR, $ DTREXC * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT * .. * .. Executable Statements .. * * ==== Estimate optimal workspace. ==== * JW = MIN( NW, KBOT-KTOP+1 ) IF( JW.LE.2 ) THEN LWKOPT = 1 ELSE * * ==== Workspace query call to DGEHRD ==== * CALL DGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) LWK1 = INT( WORK( 1 ) ) * * ==== Workspace query call to DORMHR ==== * CALL DORMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, $ WORK, -1, INFO ) LWK2 = INT( WORK( 1 ) ) * * ==== Workspace query call to DLAQR4 ==== * CALL DLAQR4( .true., .true., JW, 1, JW, T, LDT, SR, SI, 1, JW, $ V, LDV, WORK, -1, INFQR ) LWK3 = INT( WORK( 1 ) ) * * ==== Optimal workspace ==== * LWKOPT = MAX( JW+MAX( LWK1, LWK2 ), LWK3 ) END IF * * ==== Quick return in case of workspace query. ==== * IF( LWORK.EQ.-1 ) THEN WORK( 1 ) = DBLE( LWKOPT ) RETURN END IF * * ==== Nothing to do ... * ... for an empty active block ... ==== NS = 0 ND = 0 WORK( 1 ) = ONE IF( KTOP.GT.KBOT ) $ RETURN * ... nor for an empty deflation window. ==== IF( NW.LT.1 ) $ RETURN * * ==== Machine constants ==== * SAFMIN = DLAMCH( 'SAFE MINIMUM' ) SAFMAX = ONE / SAFMIN CALL DLABAD( SAFMIN, SAFMAX ) ULP = DLAMCH( 'PRECISION' ) SMLNUM = SAFMIN*( DBLE( N ) / ULP ) * * ==== Setup deflation window ==== * JW = MIN( NW, KBOT-KTOP+1 ) KWTOP = KBOT - JW + 1 IF( KWTOP.EQ.KTOP ) THEN S = ZERO ELSE S = H( KWTOP, KWTOP-1 ) END IF * IF( KBOT.EQ.KWTOP ) THEN * * ==== 1-by-1 deflation window: not much to do ==== * SR( KWTOP ) = H( KWTOP, KWTOP ) SI( KWTOP ) = ZERO NS = 1 ND = 0 IF( ABS( S ).LE.MAX( SMLNUM, ULP*ABS( H( KWTOP, KWTOP ) ) ) ) $ THEN NS = 0 ND = 1 IF( KWTOP.GT.KTOP ) $ H( KWTOP, KWTOP-1 ) = ZERO END IF WORK( 1 ) = ONE RETURN END IF * * ==== Convert to spike-triangular form. (In case of a * . rare QR failure, this routine continues to do * . aggressive early deflation using that part of * . the deflation window that converged using INFQR * . here and there to keep track.) ==== * CALL DLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) CALL DCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) * CALL DLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) NMIN = ILAENV( 12, 'DLAQR3', 'SV', JW, 1, JW, LWORK ) IF( JW.GT.NMIN ) THEN CALL DLAQR4( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ), $ SI( KWTOP ), 1, JW, V, LDV, WORK, LWORK, INFQR ) ELSE CALL DLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ), $ SI( KWTOP ), 1, JW, V, LDV, INFQR ) END IF * * ==== DTREXC needs a clean margin near the diagonal ==== * DO 10 J = 1, JW - 3 T( J+2, J ) = ZERO T( J+3, J ) = ZERO 10 CONTINUE IF( JW.GT.2 ) $ T( JW, JW-2 ) = ZERO * * ==== Deflation detection loop ==== * NS = JW ILST = INFQR + 1 20 CONTINUE IF( ILST.LE.NS ) THEN IF( NS.EQ.1 ) THEN BULGE = .FALSE. ELSE BULGE = T( NS, NS-1 ).NE.ZERO END IF * * ==== Small spike tip test for deflation ==== * IF( .NOT. BULGE ) THEN * * ==== Real eigenvalue ==== * FOO = ABS( T( NS, NS ) ) IF( FOO.EQ.ZERO ) $ FOO = ABS( S ) IF( ABS( S*V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN * * ==== Deflatable ==== * NS = NS - 1 ELSE * * ==== Undeflatable. Move it up out of the way. * . (DTREXC can not fail in this case.) ==== * IFST = NS CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, $ INFO ) ILST = ILST + 1 END IF ELSE * * ==== Complex conjugate pair ==== * FOO = ABS( T( NS, NS ) ) + SQRT( ABS( T( NS, NS-1 ) ) )* $ SQRT( ABS( T( NS-1, NS ) ) ) IF( FOO.EQ.ZERO ) $ FOO = ABS( S ) IF( MAX( ABS( S*V( 1, NS ) ), ABS( S*V( 1, NS-1 ) ) ).LE. $ MAX( SMLNUM, ULP*FOO ) ) THEN * * ==== Deflatable ==== * NS = NS - 2 ELSE * * ==== Undeflatable. Move them up out of the way. * . Fortunately, DTREXC does the right thing with * . ILST in case of a rare exchange failure. ==== * IFST = NS CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, $ INFO ) ILST = ILST + 2 END IF END IF * * ==== End deflation detection loop ==== * GO TO 20 END IF * * ==== Return to Hessenberg form ==== * IF( NS.EQ.0 ) $ S = ZERO * IF( NS.LT.JW ) THEN * * ==== sorting diagonal blocks of T improves accuracy for * . graded matrices. Bubble sort deals well with * . exchange failures. ==== * SORTED = .false. I = NS + 1 30 CONTINUE IF( SORTED ) $ GO TO 50 SORTED = .true. * KEND = I - 1 I = INFQR + 1 IF( I.EQ.NS ) THEN K = I + 1 ELSE IF( T( I+1, I ).EQ.ZERO ) THEN K = I + 1 ELSE K = I + 2 END IF 40 CONTINUE IF( K.LE.KEND ) THEN IF( K.EQ.I+1 ) THEN EVI = ABS( T( I, I ) ) ELSE EVI = ABS( T( I, I ) ) + SQRT( ABS( T( I+1, I ) ) )* $ SQRT( ABS( T( I, I+1 ) ) ) END IF * IF( K.EQ.KEND ) THEN EVK = ABS( T( K, K ) ) ELSE IF( T( K+1, K ).EQ.ZERO ) THEN EVK = ABS( T( K, K ) ) ELSE EVK = ABS( T( K, K ) ) + SQRT( ABS( T( K+1, K ) ) )* $ SQRT( ABS( T( K, K+1 ) ) ) END IF * IF( EVI.GE.EVK ) THEN I = K ELSE SORTED = .false. IFST = I ILST = K CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, $ INFO ) IF( INFO.EQ.0 ) THEN I = ILST ELSE I = K END IF END IF IF( I.EQ.KEND ) THEN K = I + 1 ELSE IF( T( I+1, I ).EQ.ZERO ) THEN K = I + 1 ELSE K = I + 2 END IF GO TO 40 END IF GO TO 30 50 CONTINUE END IF * * ==== Restore shift/eigenvalue array from T ==== * I = JW 60 CONTINUE IF( I.GE.INFQR+1 ) THEN IF( I.EQ.INFQR+1 ) THEN SR( KWTOP+I-1 ) = T( I, I ) SI( KWTOP+I-1 ) = ZERO I = I - 1 ELSE IF( T( I, I-1 ).EQ.ZERO ) THEN SR( KWTOP+I-1 ) = T( I, I ) SI( KWTOP+I-1 ) = ZERO I = I - 1 ELSE AA = T( I-1, I-1 ) CC = T( I, I-1 ) BB = T( I-1, I ) DD = T( I, I ) CALL DLANV2( AA, BB, CC, DD, SR( KWTOP+I-2 ), $ SI( KWTOP+I-2 ), SR( KWTOP+I-1 ), $ SI( KWTOP+I-1 ), CS, SN ) I = I - 2 END IF GO TO 60 END IF * IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN IF( NS.GT.1 .AND. S.NE.ZERO ) THEN * * ==== Reflect spike back into lower triangle ==== * CALL DCOPY( NS, V, LDV, WORK, 1 ) BETA = WORK( 1 ) CALL DLARFG( NS, BETA, WORK( 2 ), 1, TAU ) WORK( 1 ) = ONE * CALL DLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) * CALL DLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT, $ WORK( JW+1 ) ) CALL DLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, $ WORK( JW+1 ) ) CALL DLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, $ WORK( JW+1 ) ) * CALL DGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), $ LWORK-JW, INFO ) END IF * * ==== Copy updated reduced window into place ==== * IF( KWTOP.GT.1 ) $ H( KWTOP, KWTOP-1 ) = S*V( 1, 1 ) CALL DLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) CALL DCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), $ LDH+1 ) * * ==== Accumulate orthogonal matrix in order update * . H and Z, if requested. ==== * IF( NS.GT.1 .AND. S.NE.ZERO ) $ CALL DORMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, $ WORK( JW+1 ), LWORK-JW, INFO ) * * ==== Update vertical slab in H ==== * IF( WANTT ) THEN LTOP = 1 ELSE LTOP = KTOP END IF DO 70 KROW = LTOP, KWTOP - 1, NV KLN = MIN( NV, KWTOP-KROW ) CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), $ LDH, V, LDV, ZERO, WV, LDWV ) CALL DLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) 70 CONTINUE * * ==== Update horizontal slab in H ==== * IF( WANTT ) THEN DO 80 KCOL = KBOT + 1, N, NH KLN = MIN( NH, N-KCOL+1 ) CALL DGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) CALL DLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), $ LDH ) 80 CONTINUE END IF * * ==== Update vertical slab in Z ==== * IF( WANTZ ) THEN DO 90 KROW = ILOZ, IHIZ, NV KLN = MIN( NV, IHIZ-KROW+1 ) CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), $ LDZ, V, LDV, ZERO, WV, LDWV ) CALL DLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), $ LDZ ) 90 CONTINUE END IF END IF * * ==== Return the number of deflations ... ==== * ND = JW - NS * * ==== ... and the number of shifts. (Subtracting * . INFQR from the spike length takes care * . of the case of a rare QR failure while * . calculating eigenvalues of the deflation * . window.) ==== * NS = NS - INFQR * * ==== Return optimal workspace. ==== * WORK( 1 ) = DBLE( LWKOPT ) * * ==== End of DLAQR3 ==== * END *> \brief \b DLAQR4 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAQR4 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, * ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N * LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. * DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAQR4 implements one level of recursion for DLAQR0. *> It is a complete implementation of the small bulge multi-shift *> QR algorithm. It may be called by DLAQR0 and, for large enough *> deflation window size, it may be called by DLAQR3. This *> subroutine is identical to DLAQR0 except that it calls DLAQR2 *> instead of DLAQR3. *> *> DLAQR4 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTT *> \verbatim *> WANTT is LOGICAL *> = .TRUE. : the full Schur form T is required; *> = .FALSE.: only eigenvalues are required. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> = .TRUE. : the matrix of Schur vectors Z is required; *> = .FALSE.: Schur vectors are not required. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix H. N .GE. 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> It is assumed that H is already upper triangular in rows *> and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, *> H(ILO,ILO-1) is zero. 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. *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is DOUBLE PRECISION array, dimension (LDH,N) *> On entry, the upper Hessenberg matrix H. *> On exit, if INFO = 0 and WANTT is .TRUE., 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 WANTT is *> .FALSE., then 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.) *> *> This subroutine may explicitly set H(i,j) = 0 for i.GT.j and *> j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is INTEGER *> The leading dimension of the array H. LDH .GE. max(1,N). *> \endverbatim *> *> \param[out] WR *> \verbatim *> WR is DOUBLE PRECISION array, dimension (IHI) *> \endverbatim *> *> \param[out] WI *> \verbatim *> WI is DOUBLE PRECISION array, dimension (IHI) *> The real and imaginary parts, respectively, of the computed *> eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI) *> and WI(ILO:IHI). 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 WANTT is .TRUE., then *> 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). *> \endverbatim *> *> \param[in] ILOZ *> \verbatim *> ILOZ is INTEGER *> \endverbatim *> *> \param[in] IHIZ *> \verbatim *> IHIZ is INTEGER *> Specify the rows of Z to which transformations must be *> applied if WANTZ is .TRUE.. *> 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ,IHI) *> If WANTZ is .FALSE., then Z is not referenced. *> If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is *> replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the *> orthogonal Schur factor of H(ILO:IHI,ILO:IHI). *> (The output value of Z when INFO.GT.0 is given under *> the description of INFO below.) *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. if WANTZ is .TRUE. *> then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension LWORK *> On exit, if LWORK = -1, WORK(1) returns an estimate of *> the optimal value for LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is 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 DLAQR4 does a workspace query. *> In this case, DLAQR4 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> .GT. 0: if INFO = i, DLAQR4 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 WANT is .FALSE., 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 WANTT is .TRUE., then on exit *> *> (*) (initial value of H)*U = U*(final value of H) *> *> where U is a orthogonal matrix. The final *> value of H is upper Hessenberg and triangular in *> rows and columns INFO+1 through IHI. *> *> If INFO .GT. 0 and WANTZ is .TRUE., then on exit *> *> (final value of Z(ILO:IHI,ILOZ:IHIZ) *> = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U *> *> where U is the orthogonal matrix in (*) (regard- *> less of the value of WANTT.) *> *> If INFO .GT. 0 and WANTZ is .FALSE., then Z is not *> accessed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA * *> \par 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. *> \n *> 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. *> * ===================================================================== SUBROUTINE DLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), $ Z( LDZ, * ) * .. * * ================================================================ * .. Parameters .. * * ==== Matrices of order NTINY or smaller must be processed by * . DLAHQR because of insufficient subdiagonal scratch space. * . (This is a hard limit.) ==== INTEGER NTINY PARAMETER ( NTINY = 11 ) * * ==== Exceptional deflation windows: try to cure rare * . slow convergence by varying the size of the * . deflation window after KEXNW iterations. ==== INTEGER KEXNW PARAMETER ( KEXNW = 5 ) * * ==== Exceptional shifts: try to cure rare slow convergence * . with ad-hoc exceptional shifts every KEXSH iterations. * . ==== INTEGER KEXSH PARAMETER ( KEXSH = 6 ) * * ==== The constants WILK1 and WILK2 are used to form the * . exceptional shifts. ==== DOUBLE PRECISION WILK1, WILK2 PARAMETER ( WILK1 = 0.75d0, WILK2 = -0.4375d0 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) * .. * .. Local Scalars .. DOUBLE PRECISION AA, BB, CC, CS, DD, SN, SS, SWAP INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, $ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS, $ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD LOGICAL SORTED CHARACTER JBCMPZ*2 * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Local Arrays .. DOUBLE PRECISION ZDUM( 1, 1 ) * .. * .. External Subroutines .. EXTERNAL DLACPY, DLAHQR, DLANV2, DLAQR2, DLAQR5 * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MIN, MOD * .. * .. Executable Statements .. INFO = 0 * * ==== Quick return for N = 0: nothing to do. ==== * IF( N.EQ.0 ) THEN WORK( 1 ) = ONE RETURN END IF * IF( N.LE.NTINY ) THEN * * ==== Tiny matrices must use DLAHQR. ==== * LWKOPT = 1 IF( LWORK.NE.-1 ) $ CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, INFO ) ELSE * * ==== Use small bulge multi-shift QR with aggressive early * . deflation on larger-than-tiny matrices. ==== * * ==== Hope for the best. ==== * INFO = 0 * * ==== Set up job flags for ILAENV. ==== * IF( WANTT ) THEN JBCMPZ( 1: 1 ) = 'S' ELSE JBCMPZ( 1: 1 ) = 'E' END IF IF( WANTZ ) THEN JBCMPZ( 2: 2 ) = 'V' ELSE JBCMPZ( 2: 2 ) = 'N' END IF * * ==== NWR = recommended deflation window size. At this * . point, N .GT. NTINY = 11, so there is enough * . subdiagonal workspace for NWR.GE.2 as required. * . (In fact, there is enough subdiagonal space for * . NWR.GE.3.) ==== * NWR = ILAENV( 13, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) NWR = MAX( 2, NWR ) NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) * * ==== NSR = recommended number of simultaneous shifts. * . At this point N .GT. NTINY = 11, so there is at * . enough subdiagonal workspace for NSR to be even * . and greater than or equal to two as required. ==== * NSR = ILAENV( 15, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) * * ==== Estimate optimal workspace ==== * * ==== Workspace query call to DLAQR2 ==== * CALL DLAQR2( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, $ IHIZ, Z, LDZ, LS, LD, WR, WI, H, LDH, N, H, LDH, $ N, H, LDH, WORK, -1 ) * * ==== Optimal workspace = MAX(DLAQR5, DLAQR2) ==== * LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) * * ==== Quick return in case of workspace query. ==== * IF( LWORK.EQ.-1 ) THEN WORK( 1 ) = DBLE( LWKOPT ) RETURN END IF * * ==== DLAHQR/DLAQR0 crossover point ==== * NMIN = ILAENV( 12, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) NMIN = MAX( NTINY, NMIN ) * * ==== Nibble crossover point ==== * NIBBLE = ILAENV( 14, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) NIBBLE = MAX( 0, NIBBLE ) * * ==== Accumulate reflections during ttswp? Use block * . 2-by-2 structure during matrix-matrix multiply? ==== * KACC22 = ILAENV( 16, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) KACC22 = MAX( 0, KACC22 ) KACC22 = MIN( 2, KACC22 ) * * ==== NWMAX = the largest possible deflation window for * . which there is sufficient workspace. ==== * NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) NW = NWMAX * * ==== NSMAX = the Largest number of simultaneous shifts * . for which there is sufficient workspace. ==== * NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) NSMAX = NSMAX - MOD( NSMAX, 2 ) * * ==== NDFL: an iteration count restarted at deflation. ==== * NDFL = 1 * * ==== ITMAX = iteration limit ==== * ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) * * ==== Last row and column in the active block ==== * KBOT = IHI * * ==== Main Loop ==== * DO 80 IT = 1, ITMAX * * ==== Done when KBOT falls below ILO ==== * IF( KBOT.LT.ILO ) $ GO TO 90 * * ==== Locate active block ==== * DO 10 K = KBOT, ILO + 1, -1 IF( H( K, K-1 ).EQ.ZERO ) $ GO TO 20 10 CONTINUE K = ILO 20 CONTINUE KTOP = K * * ==== Select deflation window size: * . Typical Case: * . If possible and advisable, nibble the entire * . active block. If not, use size MIN(NWR,NWMAX) * . or MIN(NWR+1,NWMAX) depending upon which has * . the smaller corresponding subdiagonal entry * . (a heuristic). * . * . Exceptional Case: * . If there have been no deflations in KEXNW or * . more iterations, then vary the deflation window * . size. At first, because, larger windows are, * . in general, more powerful than smaller ones, * . rapidly increase the window to the maximum possible. * . Then, gradually reduce the window size. ==== * NH = KBOT - KTOP + 1 NWUPBD = MIN( NH, NWMAX ) IF( NDFL.LT.KEXNW ) THEN NW = MIN( NWUPBD, NWR ) ELSE NW = MIN( NWUPBD, 2*NW ) END IF IF( NW.LT.NWMAX ) THEN IF( NW.GE.NH-1 ) THEN NW = NH ELSE KWTOP = KBOT - NW + 1 IF( ABS( H( KWTOP, KWTOP-1 ) ).GT. $ ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 END IF END IF IF( NDFL.LT.KEXNW ) THEN NDEC = -1 ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN NDEC = NDEC + 1 IF( NW-NDEC.LT.2 ) $ NDEC = 0 NW = NW - NDEC END IF * * ==== Aggressive early deflation: * . split workspace under the subdiagonal into * . - an nw-by-nw work array V in the lower * . left-hand-corner, * . - an NW-by-at-least-NW-but-more-is-better * . (NW-by-NHO) horizontal work array along * . the bottom edge, * . - an at-least-NW-but-more-is-better (NHV-by-NW) * . vertical work array along the left-hand-edge. * . ==== * KV = N - NW + 1 KT = NW + 1 NHO = ( N-NW-1 ) - KT + 1 KWV = NW + 2 NVE = ( N-NW ) - KWV + 1 * * ==== Aggressive early deflation ==== * CALL DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, $ IHIZ, Z, LDZ, LS, LD, WR, WI, H( KV, 1 ), LDH, $ NHO, H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, $ WORK, LWORK ) * * ==== Adjust KBOT accounting for new deflations. ==== * KBOT = KBOT - LD * * ==== KS points to the shifts. ==== * KS = KBOT - LS + 1 * * ==== Skip an expensive QR sweep if there is a (partly * . heuristic) reason to expect that many eigenvalues * . will deflate without it. Here, the QR sweep is * . skipped if many eigenvalues have just been deflated * . or if the remaining active block is small. * IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN * * ==== NS = nominal number of simultaneous shifts. * . This may be lowered (slightly) if DLAQR2 * . did not provide that many shifts. ==== * NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) NS = NS - MOD( NS, 2 ) * * ==== If there have been no deflations * . in a multiple of KEXSH iterations, * . then try exceptional shifts. * . Otherwise use shifts provided by * . DLAQR2 above or from the eigenvalues * . of a trailing principal submatrix. ==== * IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN KS = KBOT - NS + 1 DO 30 I = KBOT, MAX( KS+1, KTOP+2 ), -2 SS = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) ) AA = WILK1*SS + H( I, I ) BB = SS CC = WILK2*SS DD = AA CALL DLANV2( AA, BB, CC, DD, WR( I-1 ), WI( I-1 ), $ WR( I ), WI( I ), CS, SN ) 30 CONTINUE IF( KS.EQ.KTOP ) THEN WR( KS+1 ) = H( KS+1, KS+1 ) WI( KS+1 ) = ZERO WR( KS ) = WR( KS+1 ) WI( KS ) = WI( KS+1 ) END IF ELSE * * ==== Got NS/2 or fewer shifts? Use DLAHQR * . on a trailing principal submatrix to * . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, * . there is enough space below the subdiagonal * . to fit an NS-by-NS scratch array.) ==== * IF( KBOT-KS+1.LE.NS / 2 ) THEN KS = KBOT - NS + 1 KT = N - NS + 1 CALL DLACPY( 'A', NS, NS, H( KS, KS ), LDH, $ H( KT, 1 ), LDH ) CALL DLAHQR( .false., .false., NS, 1, NS, $ H( KT, 1 ), LDH, WR( KS ), WI( KS ), $ 1, 1, ZDUM, 1, INF ) KS = KS + INF * * ==== In case of a rare QR failure use * . eigenvalues of the trailing 2-by-2 * . principal submatrix. ==== * IF( KS.GE.KBOT ) THEN AA = H( KBOT-1, KBOT-1 ) CC = H( KBOT, KBOT-1 ) BB = H( KBOT-1, KBOT ) DD = H( KBOT, KBOT ) CALL DLANV2( AA, BB, CC, DD, WR( KBOT-1 ), $ WI( KBOT-1 ), WR( KBOT ), $ WI( KBOT ), CS, SN ) KS = KBOT - 1 END IF END IF * IF( KBOT-KS+1.GT.NS ) THEN * * ==== Sort the shifts (Helps a little) * . Bubble sort keeps complex conjugate * . pairs together. ==== * SORTED = .false. DO 50 K = KBOT, KS + 1, -1 IF( SORTED ) $ GO TO 60 SORTED = .true. DO 40 I = KS, K - 1 IF( ABS( WR( I ) )+ABS( WI( I ) ).LT. $ ABS( WR( I+1 ) )+ABS( WI( I+1 ) ) ) THEN SORTED = .false. * SWAP = WR( I ) WR( I ) = WR( I+1 ) WR( I+1 ) = SWAP * SWAP = WI( I ) WI( I ) = WI( I+1 ) WI( I+1 ) = SWAP END IF 40 CONTINUE 50 CONTINUE 60 CONTINUE END IF * * ==== Shuffle shifts into pairs of real shifts * . and pairs of complex conjugate shifts * . assuming complex conjugate shifts are * . already adjacent to one another. (Yes, * . they are.) ==== * DO 70 I = KBOT, KS + 2, -2 IF( WI( I ).NE.-WI( I-1 ) ) THEN * SWAP = WR( I ) WR( I ) = WR( I-1 ) WR( I-1 ) = WR( I-2 ) WR( I-2 ) = SWAP * SWAP = WI( I ) WI( I ) = WI( I-1 ) WI( I-1 ) = WI( I-2 ) WI( I-2 ) = SWAP END IF 70 CONTINUE END IF * * ==== If there are only two shifts and both are * . real, then use only one. ==== * IF( KBOT-KS+1.EQ.2 ) THEN IF( WI( KBOT ).EQ.ZERO ) THEN IF( ABS( WR( KBOT )-H( KBOT, KBOT ) ).LT. $ ABS( WR( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN WR( KBOT-1 ) = WR( KBOT ) ELSE WR( KBOT ) = WR( KBOT-1 ) END IF END IF END IF * * ==== Use up to NS of the the smallest magnatiude * . shifts. If there aren't NS shifts available, * . then use them all, possibly dropping one to * . make the number of shifts even. ==== * NS = MIN( NS, KBOT-KS+1 ) NS = NS - MOD( NS, 2 ) KS = KBOT - NS + 1 * * ==== Small-bulge multi-shift QR sweep: * . split workspace under the subdiagonal into * . - a KDU-by-KDU work array U in the lower * . left-hand-corner, * . - a KDU-by-at-least-KDU-but-more-is-better * . (KDU-by-NHo) horizontal work array WH along * . the bottom edge, * . - and an at-least-KDU-but-more-is-better-by-KDU * . (NVE-by-KDU) vertical work WV arrow along * . the left-hand-edge. ==== * KDU = 3*NS - 3 KU = N - KDU + 1 KWH = KDU + 1 NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 KWV = KDU + 4 NVE = N - KDU - KWV + 1 * * ==== Small-bulge multi-shift QR sweep ==== * CALL DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, $ WR( KS ), WI( KS ), H, LDH, ILOZ, IHIZ, Z, $ LDZ, WORK, 3, H( KU, 1 ), LDH, NVE, $ H( KWV, 1 ), LDH, NHO, H( KU, KWH ), LDH ) END IF * * ==== Note progress (or the lack of it). ==== * IF( LD.GT.0 ) THEN NDFL = 1 ELSE NDFL = NDFL + 1 END IF * * ==== End of main loop ==== 80 CONTINUE * * ==== Iteration limit exceeded. Set INFO to show where * . the problem occurred and exit. ==== * INFO = KBOT 90 CONTINUE END IF * * ==== Return the optimal value of LWORK. ==== * WORK( 1 ) = DBLE( LWKOPT ) * * ==== End of DLAQR4 ==== * END *> \brief \b DLAQR5 performs a single small-bulge multi-shift QR sweep. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAQR5 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, * SR, SI, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, * LDU, NV, WV, LDWV, NH, WH, LDWH ) * * .. Scalar Arguments .. * INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, * $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV * LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. * DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), U( LDU, * ), * $ V( LDV, * ), WH( LDWH, * ), WV( LDWV, * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAQR5, called by DLAQR0, performs a *> single small-bulge multi-shift QR sweep. *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTT *> \verbatim *> WANTT is LOGICAL *> WANTT = .true. if the quasi-triangular Schur factor *> is being computed. WANTT is set to .false. otherwise. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> WANTZ = .true. if the orthogonal Schur factor is being *> computed. WANTZ is set to .false. otherwise. *> \endverbatim *> *> \param[in] KACC22 *> \verbatim *> KACC22 is INTEGER with value 0, 1, or 2. *> Specifies the computation mode of far-from-diagonal *> orthogonal updates. *> = 0: DLAQR5 does not accumulate reflections and does not *> use matrix-matrix multiply to update far-from-diagonal *> matrix entries. *> = 1: DLAQR5 accumulates reflections and uses matrix-matrix *> multiply to update the far-from-diagonal matrix entries. *> = 2: DLAQR5 accumulates reflections, uses matrix-matrix *> multiply to update the far-from-diagonal matrix entries, *> and takes advantage of 2-by-2 block structure during *> matrix multiplies. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> N is the order of the Hessenberg matrix H upon which this *> subroutine operates. *> \endverbatim *> *> \param[in] KTOP *> \verbatim *> KTOP is INTEGER *> \endverbatim *> *> \param[in] KBOT *> \verbatim *> KBOT is INTEGER *> These are the first and last rows and columns of an *> isolated diagonal block upon which the QR sweep is to be *> applied. It is assumed without a check that *> either KTOP = 1 or H(KTOP,KTOP-1) = 0 *> and *> either KBOT = N or H(KBOT+1,KBOT) = 0. *> \endverbatim *> *> \param[in] NSHFTS *> \verbatim *> NSHFTS is INTEGER *> NSHFTS gives the number of simultaneous shifts. NSHFTS *> must be positive and even. *> \endverbatim *> *> \param[in,out] SR *> \verbatim *> SR is DOUBLE PRECISION array, dimension (NSHFTS) *> \endverbatim *> *> \param[in,out] SI *> \verbatim *> SI is DOUBLE PRECISION array, dimension (NSHFTS) *> SR contains the real parts and SI contains the imaginary *> parts of the NSHFTS shifts of origin that define the *> multi-shift QR sweep. On output SR and SI may be *> reordered. *> \endverbatim *> *> \param[in,out] H *> \verbatim *> H is DOUBLE PRECISION array, dimension (LDH,N) *> On input H contains a Hessenberg matrix. On output a *> multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied *> to the isolated diagonal block in rows and columns KTOP *> through KBOT. *> \endverbatim *> *> \param[in] LDH *> \verbatim *> LDH is INTEGER *> LDH is the leading dimension of H just as declared in the *> calling procedure. LDH.GE.MAX(1,N). *> \endverbatim *> *> \param[in] ILOZ *> \verbatim *> ILOZ is INTEGER *> \endverbatim *> *> \param[in] IHIZ *> \verbatim *> IHIZ is INTEGER *> Specify the rows of Z to which transformations must be *> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ,IHIZ) *> If WANTZ = .TRUE., then the QR Sweep orthogonal *> similarity transformation is accumulated into *> Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. *> If WANTZ = .FALSE., then Z is unreferenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> LDA is the leading dimension of Z just as declared in *> the calling procedure. LDZ.GE.N. *> \endverbatim *> *> \param[out] V *> \verbatim *> V is DOUBLE PRECISION array, dimension (LDV,NSHFTS/2) *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> LDV is the leading dimension of V as declared in the *> calling procedure. LDV.GE.3. *> \endverbatim *> *> \param[out] U *> \verbatim *> U is DOUBLE PRECISION array, dimension (LDU,3*NSHFTS-3) *> \endverbatim *> *> \param[in] LDU *> \verbatim *> LDU is INTEGER *> LDU is the leading dimension of U just as declared in the *> in the calling subroutine. LDU.GE.3*NSHFTS-3. *> \endverbatim *> *> \param[in] NH *> \verbatim *> NH is INTEGER *> NH is the number of columns in array WH available for *> workspace. NH.GE.1. *> \endverbatim *> *> \param[out] WH *> \verbatim *> WH is DOUBLE PRECISION array, dimension (LDWH,NH) *> \endverbatim *> *> \param[in] LDWH *> \verbatim *> LDWH is INTEGER *> Leading dimension of WH just as declared in the *> calling procedure. LDWH.GE.3*NSHFTS-3. *> \endverbatim *> *> \param[in] NV *> \verbatim *> NV is INTEGER *> NV is the number of rows in WV agailable for workspace. *> NV.GE.1. *> \endverbatim *> *> \param[out] WV *> \verbatim *> WV is DOUBLE PRECISION array, dimension (LDWV,3*NSHFTS-3) *> \endverbatim *> *> \param[in] LDWV *> \verbatim *> LDWV is INTEGER *> LDWV is the leading dimension of WV as declared in the *> in the calling subroutine. LDWV.GE.NV. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Contributors: * ================== *> *> Karen Braman and Ralph Byers, Department of Mathematics, *> University of Kansas, USA * *> \par 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. *> * ===================================================================== SUBROUTINE DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, $ SR, SI, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, $ LDU, NV, WV, LDWV, NH, WH, LDWH ) * * -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV LOGICAL WANTT, WANTZ * .. * .. Array Arguments .. DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), U( LDU, * ), $ V( LDV, * ), WH( LDWH, * ), WV( LDWV, * ), $ Z( LDZ, * ) * .. * * ================================================================ * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) * .. * .. Local Scalars .. DOUBLE PRECISION ALPHA, BETA, H11, H12, H21, H22, REFSUM, $ SAFMAX, SAFMIN, SCL, SMLNUM, SWAP, TST1, TST2, $ ULP INTEGER I, I2, I4, INCOL, J, J2, J4, JBOT, JCOL, JLEN, $ JROW, JTOP, K, K1, KDU, KMS, KNZ, KRCOL, KZS, $ M, M22, MBOT, MEND, MSTART, MTOP, NBMPS, NDCOL, $ NS, NU LOGICAL ACCUM, BLK22, BMP22 * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. Intrinsic Functions .. * INTRINSIC ABS, DBLE, MAX, MIN, MOD * .. * .. Local Arrays .. DOUBLE PRECISION VT( 3 ) * .. * .. External Subroutines .. EXTERNAL DGEMM, DLABAD, DLACPY, DLAQR1, DLARFG, DLASET, $ DTRMM * .. * .. Executable Statements .. * * ==== If there are no shifts, then there is nothing to do. ==== * IF( NSHFTS.LT.2 ) $ RETURN * * ==== If the active block is empty or 1-by-1, then there * . is nothing to do. ==== * IF( KTOP.GE.KBOT ) $ RETURN * * ==== Shuffle shifts into pairs of real shifts and pairs * . of complex conjugate shifts assuming complex * . conjugate shifts are already adjacent to one * . another. ==== * DO 10 I = 1, NSHFTS - 2, 2 IF( SI( I ).NE.-SI( I+1 ) ) THEN * SWAP = SR( I ) SR( I ) = SR( I+1 ) SR( I+1 ) = SR( I+2 ) SR( I+2 ) = SWAP * SWAP = SI( I ) SI( I ) = SI( I+1 ) SI( I+1 ) = SI( I+2 ) SI( I+2 ) = SWAP END IF 10 CONTINUE * * ==== NSHFTS is supposed to be even, but if it is odd, * . then simply reduce it by one. The shuffle above * . ensures that the dropped shift is real and that * . the remaining shifts are paired. ==== * NS = NSHFTS - MOD( NSHFTS, 2 ) * * ==== Machine constants for deflation ==== * SAFMIN = DLAMCH( 'SAFE MINIMUM' ) SAFMAX = ONE / SAFMIN CALL DLABAD( SAFMIN, SAFMAX ) ULP = DLAMCH( 'PRECISION' ) SMLNUM = SAFMIN*( DBLE( N ) / ULP ) * * ==== Use accumulated reflections to update far-from-diagonal * . entries ? ==== * ACCUM = ( KACC22.EQ.1 ) .OR. ( KACC22.EQ.2 ) * * ==== If so, exploit the 2-by-2 block structure? ==== * BLK22 = ( NS.GT.2 ) .AND. ( KACC22.EQ.2 ) * * ==== clear trash ==== * IF( KTOP+2.LE.KBOT ) $ H( KTOP+2, KTOP ) = ZERO * * ==== NBMPS = number of 2-shift bulges in the chain ==== * NBMPS = NS / 2 * * ==== KDU = width of slab ==== * KDU = 6*NBMPS - 3 * * ==== Create and chase chains of NBMPS bulges ==== * DO 220 INCOL = 3*( 1-NBMPS ) + KTOP - 1, KBOT - 2, 3*NBMPS - 2 NDCOL = INCOL + KDU IF( ACCUM ) $ CALL DLASET( 'ALL', KDU, KDU, ZERO, ONE, U, LDU ) * * ==== Near-the-diagonal bulge chase. The following loop * . performs the near-the-diagonal part of a small bulge * . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal * . chunk extends from column INCOL to column NDCOL * . (including both column INCOL and column NDCOL). The * . following loop chases a 3*NBMPS column long chain of * . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL * . may be less than KTOP and and NDCOL may be greater than * . KBOT indicating phantom columns from which to chase * . bulges before they are actually introduced or to which * . to chase bulges beyond column KBOT.) ==== * DO 150 KRCOL = INCOL, MIN( INCOL+3*NBMPS-3, KBOT-2 ) * * ==== Bulges number MTOP to MBOT are active double implicit * . shift bulges. There may or may not also be small * . 2-by-2 bulge, if there is room. The inactive bulges * . (if any) must wait until the active bulges have moved * . down the diagonal to make room. The phantom matrix * . paradigm described above helps keep track. ==== * MTOP = MAX( 1, ( ( KTOP-1 )-KRCOL+2 ) / 3+1 ) MBOT = MIN( NBMPS, ( KBOT-KRCOL ) / 3 ) M22 = MBOT + 1 BMP22 = ( MBOT.LT.NBMPS ) .AND. ( KRCOL+3*( M22-1 ) ).EQ. $ ( KBOT-2 ) * * ==== Generate reflections to chase the chain right * . one column. (The minimum value of K is KTOP-1.) ==== * DO 20 M = MTOP, MBOT K = KRCOL + 3*( M-1 ) IF( K.EQ.KTOP-1 ) THEN CALL DLAQR1( 3, H( KTOP, KTOP ), LDH, SR( 2*M-1 ), $ SI( 2*M-1 ), SR( 2*M ), SI( 2*M ), $ V( 1, M ) ) ALPHA = V( 1, M ) CALL DLARFG( 3, ALPHA, V( 2, M ), 1, V( 1, M ) ) ELSE BETA = H( K+1, K ) V( 2, M ) = H( K+2, K ) V( 3, M ) = H( K+3, K ) CALL DLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) ) * * ==== A Bulge may collapse because of vigilant * . deflation or destructive underflow. In the * . underflow case, try the two-small-subdiagonals * . trick to try to reinflate the bulge. ==== * IF( H( K+3, K ).NE.ZERO .OR. H( K+3, K+1 ).NE. $ ZERO .OR. H( K+3, K+2 ).EQ.ZERO ) THEN * * ==== Typical case: not collapsed (yet). ==== * H( K+1, K ) = BETA H( K+2, K ) = ZERO H( K+3, K ) = ZERO ELSE * * ==== Atypical case: collapsed. Attempt to * . reintroduce ignoring H(K+1,K) and H(K+2,K). * . If the fill resulting from the new * . reflector is too large, then abandon it. * . Otherwise, use the new one. ==== * CALL DLAQR1( 3, H( K+1, K+1 ), LDH, SR( 2*M-1 ), $ SI( 2*M-1 ), SR( 2*M ), SI( 2*M ), $ VT ) ALPHA = VT( 1 ) CALL DLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) REFSUM = VT( 1 )*( H( K+1, K )+VT( 2 )* $ H( K+2, K ) ) * IF( ABS( H( K+2, K )-REFSUM*VT( 2 ) )+ $ ABS( REFSUM*VT( 3 ) ).GT.ULP* $ ( ABS( H( K, K ) )+ABS( H( K+1, $ K+1 ) )+ABS( H( K+2, K+2 ) ) ) ) THEN * * ==== Starting a new bulge here would * . create non-negligible fill. Use * . the old one with trepidation. ==== * H( K+1, K ) = BETA H( K+2, K ) = ZERO H( K+3, K ) = ZERO ELSE * * ==== Stating a new bulge here would * . create only negligible fill. * . Replace the old reflector with * . the new one. ==== * H( K+1, K ) = H( K+1, K ) - REFSUM H( K+2, K ) = ZERO H( K+3, K ) = ZERO V( 1, M ) = VT( 1 ) V( 2, M ) = VT( 2 ) V( 3, M ) = VT( 3 ) END IF END IF END IF 20 CONTINUE * * ==== Generate a 2-by-2 reflection, if needed. ==== * K = KRCOL + 3*( M22-1 ) IF( BMP22 ) THEN IF( K.EQ.KTOP-1 ) THEN CALL DLAQR1( 2, H( K+1, K+1 ), LDH, SR( 2*M22-1 ), $ SI( 2*M22-1 ), SR( 2*M22 ), SI( 2*M22 ), $ V( 1, M22 ) ) BETA = V( 1, M22 ) CALL DLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) ELSE BETA = H( K+1, K ) V( 2, M22 ) = H( K+2, K ) CALL DLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) H( K+1, K ) = BETA H( K+2, K ) = ZERO END IF END IF * * ==== Multiply H by reflections from the left ==== * IF( ACCUM ) THEN JBOT = MIN( NDCOL, KBOT ) ELSE IF( WANTT ) THEN JBOT = N ELSE JBOT = KBOT END IF DO 40 J = MAX( KTOP, KRCOL ), JBOT MEND = MIN( MBOT, ( J-KRCOL+2 ) / 3 ) DO 30 M = MTOP, MEND K = KRCOL + 3*( M-1 ) REFSUM = V( 1, M )*( H( K+1, J )+V( 2, M )* $ H( K+2, J )+V( 3, M )*H( K+3, J ) ) H( K+1, J ) = H( K+1, J ) - REFSUM H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M ) H( K+3, J ) = H( K+3, J ) - REFSUM*V( 3, M ) 30 CONTINUE 40 CONTINUE IF( BMP22 ) THEN K = KRCOL + 3*( M22-1 ) DO 50 J = MAX( K+1, KTOP ), JBOT REFSUM = V( 1, M22 )*( H( K+1, J )+V( 2, M22 )* $ H( K+2, J ) ) H( K+1, J ) = H( K+1, J ) - REFSUM H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M22 ) 50 CONTINUE END IF * * ==== Multiply H by reflections from the right. * . Delay filling in the last row until the * . vigilant deflation check is complete. ==== * IF( ACCUM ) THEN JTOP = MAX( KTOP, INCOL ) ELSE IF( WANTT ) THEN JTOP = 1 ELSE JTOP = KTOP END IF DO 90 M = MTOP, MBOT IF( V( 1, M ).NE.ZERO ) THEN K = KRCOL + 3*( M-1 ) DO 60 J = JTOP, MIN( KBOT, K+3 ) REFSUM = V( 1, M )*( H( J, K+1 )+V( 2, M )* $ H( J, K+2 )+V( 3, M )*H( J, K+3 ) ) H( J, K+1 ) = H( J, K+1 ) - REFSUM H( J, K+2 ) = H( J, K+2 ) - REFSUM*V( 2, M ) H( J, K+3 ) = H( J, K+3 ) - REFSUM*V( 3, M ) 60 CONTINUE * IF( ACCUM ) THEN * * ==== Accumulate U. (If necessary, update Z later * . with with an efficient matrix-matrix * . multiply.) ==== * KMS = K - INCOL DO 70 J = MAX( 1, KTOP-INCOL ), KDU REFSUM = V( 1, M )*( U( J, KMS+1 )+V( 2, M )* $ U( J, KMS+2 )+V( 3, M )*U( J, KMS+3 ) ) U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM U( J, KMS+2 ) = U( J, KMS+2 ) - REFSUM*V( 2, M ) U( J, KMS+3 ) = U( J, KMS+3 ) - REFSUM*V( 3, M ) 70 CONTINUE ELSE IF( WANTZ ) THEN * * ==== U is not accumulated, so update Z * . now by multiplying by reflections * . from the right. ==== * DO 80 J = ILOZ, IHIZ REFSUM = V( 1, M )*( Z( J, K+1 )+V( 2, M )* $ Z( J, K+2 )+V( 3, M )*Z( J, K+3 ) ) Z( J, K+1 ) = Z( J, K+1 ) - REFSUM Z( J, K+2 ) = Z( J, K+2 ) - REFSUM*V( 2, M ) Z( J, K+3 ) = Z( J, K+3 ) - REFSUM*V( 3, M ) 80 CONTINUE END IF END IF 90 CONTINUE * * ==== Special case: 2-by-2 reflection (if needed) ==== * K = KRCOL + 3*( M22-1 ) IF( BMP22 ) THEN IF ( V( 1, M22 ).NE.ZERO ) THEN DO 100 J = JTOP, MIN( KBOT, K+3 ) REFSUM = V( 1, M22 )*( H( J, K+1 )+V( 2, M22 )* $ H( J, K+2 ) ) H( J, K+1 ) = H( J, K+1 ) - REFSUM H( J, K+2 ) = H( J, K+2 ) - REFSUM*V( 2, M22 ) 100 CONTINUE * IF( ACCUM ) THEN KMS = K - INCOL DO 110 J = MAX( 1, KTOP-INCOL ), KDU REFSUM = V( 1, M22 )*( U( J, KMS+1 )+ $ V( 2, M22 )*U( J, KMS+2 ) ) U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM U( J, KMS+2 ) = U( J, KMS+2 ) - $ REFSUM*V( 2, M22 ) 110 CONTINUE ELSE IF( WANTZ ) THEN DO 120 J = ILOZ, IHIZ REFSUM = V( 1, M22 )*( Z( J, K+1 )+V( 2, M22 )* $ Z( J, K+2 ) ) Z( J, K+1 ) = Z( J, K+1 ) - REFSUM Z( J, K+2 ) = Z( J, K+2 ) - REFSUM*V( 2, M22 ) 120 CONTINUE END IF END IF END IF * * ==== Vigilant deflation check ==== * MSTART = MTOP IF( KRCOL+3*( MSTART-1 ).LT.KTOP ) $ MSTART = MSTART + 1 MEND = MBOT IF( BMP22 ) $ MEND = MEND + 1 IF( KRCOL.EQ.KBOT-2 ) $ MEND = MEND + 1 DO 130 M = MSTART, MEND K = MIN( KBOT-1, KRCOL+3*( M-1 ) ) * * ==== The following convergence test requires that * . the tradition small-compared-to-nearby-diagonals * . criterion and the Ahues & Tisseur (LAWN 122, 1997) * . criteria both be satisfied. The latter improves * . accuracy in some examples. Falling back on an * . alternate convergence criterion when TST1 or TST2 * . is zero (as done here) is traditional but probably * . unnecessary. ==== * IF( H( K+1, K ).NE.ZERO ) THEN TST1 = ABS( H( K, K ) ) + ABS( H( K+1, K+1 ) ) IF( TST1.EQ.ZERO ) THEN IF( K.GE.KTOP+1 ) $ TST1 = TST1 + ABS( H( K, K-1 ) ) IF( K.GE.KTOP+2 ) $ TST1 = TST1 + ABS( H( K, K-2 ) ) IF( K.GE.KTOP+3 ) $ TST1 = TST1 + ABS( H( K, K-3 ) ) IF( K.LE.KBOT-2 ) $ TST1 = TST1 + ABS( H( K+2, K+1 ) ) IF( K.LE.KBOT-3 ) $ TST1 = TST1 + ABS( H( K+3, K+1 ) ) IF( K.LE.KBOT-4 ) $ TST1 = TST1 + ABS( H( K+4, K+1 ) ) END IF IF( ABS( H( K+1, K ) ).LE.MAX( SMLNUM, ULP*TST1 ) ) $ THEN H12 = MAX( ABS( H( K+1, K ) ), ABS( H( K, K+1 ) ) ) H21 = MIN( ABS( H( K+1, K ) ), ABS( H( K, K+1 ) ) ) H11 = MAX( ABS( H( K+1, K+1 ) ), $ ABS( H( K, K )-H( K+1, K+1 ) ) ) H22 = MIN( ABS( H( K+1, K+1 ) ), $ ABS( H( K, K )-H( K+1, K+1 ) ) ) SCL = H11 + H12 TST2 = H22*( H11 / SCL ) * IF( TST2.EQ.ZERO .OR. H21*( H12 / SCL ).LE. $ MAX( SMLNUM, ULP*TST2 ) )H( K+1, K ) = ZERO END IF END IF 130 CONTINUE * * ==== Fill in the last row of each bulge. ==== * MEND = MIN( NBMPS, ( KBOT-KRCOL-1 ) / 3 ) DO 140 M = MTOP, MEND K = KRCOL + 3*( M-1 ) REFSUM = V( 1, M )*V( 3, M )*H( K+4, K+3 ) H( K+4, K+1 ) = -REFSUM H( K+4, K+2 ) = -REFSUM*V( 2, M ) H( K+4, K+3 ) = H( K+4, K+3 ) - REFSUM*V( 3, M ) 140 CONTINUE * * ==== End of near-the-diagonal bulge chase. ==== * 150 CONTINUE * * ==== Use U (if accumulated) to update far-from-diagonal * . entries in H. If required, use U to update Z as * . well. ==== * IF( ACCUM ) THEN IF( WANTT ) THEN JTOP = 1 JBOT = N ELSE JTOP = KTOP JBOT = KBOT END IF IF( ( .NOT.BLK22 ) .OR. ( INCOL.LT.KTOP ) .OR. $ ( NDCOL.GT.KBOT ) .OR. ( NS.LE.2 ) ) THEN * * ==== Updates not exploiting the 2-by-2 block * . structure of U. K1 and NU keep track of * . the location and size of U in the special * . cases of introducing bulges and chasing * . bulges off the bottom. In these special * . cases and in case the number of shifts * . is NS = 2, there is no 2-by-2 block * . structure to exploit. ==== * K1 = MAX( 1, KTOP-INCOL ) NU = ( KDU-MAX( 0, NDCOL-KBOT ) ) - K1 + 1 * * ==== Horizontal Multiply ==== * DO 160 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH JLEN = MIN( NH, JBOT-JCOL+1 ) CALL DGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ), $ LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH, $ LDWH ) CALL DLACPY( 'ALL', NU, JLEN, WH, LDWH, $ H( INCOL+K1, JCOL ), LDH ) 160 CONTINUE * * ==== Vertical multiply ==== * DO 170 JROW = JTOP, MAX( KTOP, INCOL ) - 1, NV JLEN = MIN( NV, MAX( KTOP, INCOL )-JROW ) CALL DGEMM( 'N', 'N', JLEN, NU, NU, ONE, $ H( JROW, INCOL+K1 ), LDH, U( K1, K1 ), $ LDU, ZERO, WV, LDWV ) CALL DLACPY( 'ALL', JLEN, NU, WV, LDWV, $ H( JROW, INCOL+K1 ), LDH ) 170 CONTINUE * * ==== Z multiply (also vertical) ==== * IF( WANTZ ) THEN DO 180 JROW = ILOZ, IHIZ, NV JLEN = MIN( NV, IHIZ-JROW+1 ) CALL DGEMM( 'N', 'N', JLEN, NU, NU, ONE, $ Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ), $ LDU, ZERO, WV, LDWV ) CALL DLACPY( 'ALL', JLEN, NU, WV, LDWV, $ Z( JROW, INCOL+K1 ), LDZ ) 180 CONTINUE END IF ELSE * * ==== Updates exploiting U's 2-by-2 block structure. * . (I2, I4, J2, J4 are the last rows and columns * . of the blocks.) ==== * I2 = ( KDU+1 ) / 2 I4 = KDU J2 = I4 - I2 J4 = KDU * * ==== KZS and KNZ deal with the band of zeros * . along the diagonal of one of the triangular * . blocks. ==== * KZS = ( J4-J2 ) - ( NS+1 ) KNZ = NS + 1 * * ==== Horizontal multiply ==== * DO 190 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH JLEN = MIN( NH, JBOT-JCOL+1 ) * * ==== Copy bottom of H to top+KZS of scratch ==== * (The first KZS rows get multiplied by zero.) ==== * CALL DLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ), $ LDH, WH( KZS+1, 1 ), LDWH ) * * ==== Multiply by U21**T ==== * CALL DLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH ) CALL DTRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE, $ U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ), $ LDWH ) * * ==== Multiply top of H by U11**T ==== * CALL DGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU, $ H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH ) * * ==== Copy top of H to bottom of WH ==== * CALL DLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH, $ WH( I2+1, 1 ), LDWH ) * * ==== Multiply by U21**T ==== * CALL DTRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE, $ U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH ) * * ==== Multiply by U22 ==== * CALL DGEMM( 'C', 'N', I4-I2, JLEN, J4-J2, ONE, $ U( J2+1, I2+1 ), LDU, $ H( INCOL+1+J2, JCOL ), LDH, ONE, $ WH( I2+1, 1 ), LDWH ) * * ==== Copy it back ==== * CALL DLACPY( 'ALL', KDU, JLEN, WH, LDWH, $ H( INCOL+1, JCOL ), LDH ) 190 CONTINUE * * ==== Vertical multiply ==== * DO 200 JROW = JTOP, MAX( INCOL, KTOP ) - 1, NV JLEN = MIN( NV, MAX( INCOL, KTOP )-JROW ) * * ==== Copy right of H to scratch (the first KZS * . columns get multiplied by zero) ==== * CALL DLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ), $ LDH, WV( 1, 1+KZS ), LDWV ) * * ==== Multiply by U21 ==== * CALL DLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV ) CALL DTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), $ LDWV ) * * ==== Multiply by U11 ==== * CALL DGEMM( 'N', 'N', JLEN, I2, J2, ONE, $ H( JROW, INCOL+1 ), LDH, U, LDU, ONE, WV, $ LDWV ) * * ==== Copy left of H to right of scratch ==== * CALL DLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH, $ WV( 1, 1+I2 ), LDWV ) * * ==== Multiply by U21 ==== * CALL DTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV ) * * ==== Multiply by U22 ==== * CALL DGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, $ H( JROW, INCOL+1+J2 ), LDH, $ U( J2+1, I2+1 ), LDU, ONE, WV( 1, 1+I2 ), $ LDWV ) * * ==== Copy it back ==== * CALL DLACPY( 'ALL', JLEN, KDU, WV, LDWV, $ H( JROW, INCOL+1 ), LDH ) 200 CONTINUE * * ==== Multiply Z (also vertical) ==== * IF( WANTZ ) THEN DO 210 JROW = ILOZ, IHIZ, NV JLEN = MIN( NV, IHIZ-JROW+1 ) * * ==== Copy right of Z to left of scratch (first * . KZS columns get multiplied by zero) ==== * CALL DLACPY( 'ALL', JLEN, KNZ, $ Z( JROW, INCOL+1+J2 ), LDZ, $ WV( 1, 1+KZS ), LDWV ) * * ==== Multiply by U12 ==== * CALL DLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, $ LDWV ) CALL DTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), $ LDWV ) * * ==== Multiply by U11 ==== * CALL DGEMM( 'N', 'N', JLEN, I2, J2, ONE, $ Z( JROW, INCOL+1 ), LDZ, U, LDU, ONE, $ WV, LDWV ) * * ==== Copy left of Z to right of scratch ==== * CALL DLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ), $ LDZ, WV( 1, 1+I2 ), LDWV ) * * ==== Multiply by U21 ==== * CALL DTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), $ LDWV ) * * ==== Multiply by U22 ==== * CALL DGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, $ Z( JROW, INCOL+1+J2 ), LDZ, $ U( J2+1, I2+1 ), LDU, ONE, $ WV( 1, 1+I2 ), LDWV ) * * ==== Copy the result back to Z ==== * CALL DLACPY( 'ALL', JLEN, KDU, WV, LDWV, $ Z( JROW, INCOL+1 ), LDZ ) 210 CONTINUE END IF END IF END IF 220 CONTINUE * * ==== End of DLAQR5 ==== * END *> \brief \b DLAQSB scales a symmetric/Hermitian band matrix, using scaling factors computed by spbequ. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAQSB + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED ) * * .. Scalar Arguments .. * CHARACTER EQUED, UPLO * INTEGER KD, LDAB, N * DOUBLE PRECISION AMAX, SCOND * .. * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ), S( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAQSB equilibrates a symmetric band matrix A using the scaling *> factors in the vector S. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the upper or lower triangular part of the *> symmetric matrix A is stored. *> = 'U': Upper triangular *> = 'L': Lower triangular *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] KD *> \verbatim *> KD is INTEGER *> The number of super-diagonals of the matrix A if UPLO = 'U', *> or the number of sub-diagonals if UPLO = 'L'. KD >= 0. *> \endverbatim *> *> \param[in,out] AB *> \verbatim *> AB is DOUBLE PRECISION array, dimension (LDAB,N) *> On entry, the upper or lower triangle of the symmetric band *> matrix A, stored in the first KD+1 rows of the array. The *> j-th column of A is stored in the j-th column of the array AB *> as follows: *> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; *> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). *> *> On exit, if INFO = 0, the triangular factor U or L from the *> Cholesky factorization A = U**T*U or A = L*L**T of the band *> matrix A, in the same storage format as A. *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array AB. LDAB >= KD+1. *> \endverbatim *> *> \param[in] S *> \verbatim *> S is DOUBLE PRECISION array, dimension (N) *> The scale factors for A. *> \endverbatim *> *> \param[in] SCOND *> \verbatim *> SCOND is DOUBLE PRECISION *> Ratio of the smallest S(i) to the largest S(i). *> \endverbatim *> *> \param[in] AMAX *> \verbatim *> AMAX is DOUBLE PRECISION *> Absolute value of largest matrix entry. *> \endverbatim *> *> \param[out] EQUED *> \verbatim *> EQUED is CHARACTER*1 *> Specifies whether or not equilibration was done. *> = 'N': No equilibration. *> = 'Y': Equilibration was done, i.e., A has been replaced by *> diag(S) * A * diag(S). *> \endverbatim * *> \par Internal Parameters: * ========================= *> *> \verbatim *> THRESH is a threshold value used to decide if scaling should be done *> based on the ratio of the scaling factors. If SCOND < THRESH, *> scaling is done. *> *> LARGE and SMALL are threshold values used to decide if scaling should *> be done based on the absolute size of the largest matrix element. *> If AMAX > LARGE or AMAX < SMALL, scaling is done. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER EQUED, UPLO INTEGER KD, LDAB, N DOUBLE PRECISION AMAX, SCOND * .. * .. Array Arguments .. DOUBLE PRECISION AB( LDAB, * ), S( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, THRESH PARAMETER ( ONE = 1.0D+0, THRESH = 0.1D+0 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION CJ, LARGE, SMALL * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL LSAME, DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Quick return if possible * IF( N.LE.0 ) THEN EQUED = 'N' RETURN END IF * * Initialize LARGE and SMALL. * SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) LARGE = ONE / SMALL * IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN * * No equilibration * EQUED = 'N' ELSE * * Replace A by diag(S) * A * diag(S). * IF( LSAME( UPLO, 'U' ) ) THEN * * Upper triangle of A is stored in band format. * DO 20 J = 1, N CJ = S( J ) DO 10 I = MAX( 1, J-KD ), J AB( KD+1+I-J, J ) = CJ*S( I )*AB( KD+1+I-J, J ) 10 CONTINUE 20 CONTINUE ELSE * * Lower triangle of A is stored. * DO 40 J = 1, N CJ = S( J ) DO 30 I = J, MIN( N, J+KD ) AB( 1+I-J, J ) = CJ*S( I )*AB( 1+I-J, J ) 30 CONTINUE 40 CONTINUE END IF EQUED = 'Y' END IF * RETURN * * End of DLAQSB * END *> \brief \b DLAQSP scales a symmetric/Hermitian matrix in packed storage, using scaling factors computed by sppequ. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAQSP + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED ) * * .. Scalar Arguments .. * CHARACTER EQUED, UPLO * INTEGER N * DOUBLE PRECISION AMAX, SCOND * .. * .. Array Arguments .. * DOUBLE PRECISION AP( * ), S( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAQSP equilibrates a symmetric matrix A using the scaling factors *> in the vector S. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the upper or lower triangular part of the *> symmetric matrix A is stored. *> = 'U': Upper triangular *> = 'L': Lower triangular *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> On entry, the upper or lower triangle of the symmetric matrix *> A, packed columnwise in a linear array. The j-th column of A *> is stored in the array AP as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. *> *> On exit, the equilibrated matrix: diag(S) * A * diag(S), in *> the same storage format as A. *> \endverbatim *> *> \param[in] S *> \verbatim *> S is DOUBLE PRECISION array, dimension (N) *> The scale factors for A. *> \endverbatim *> *> \param[in] SCOND *> \verbatim *> SCOND is DOUBLE PRECISION *> Ratio of the smallest S(i) to the largest S(i). *> \endverbatim *> *> \param[in] AMAX *> \verbatim *> AMAX is DOUBLE PRECISION *> Absolute value of largest matrix entry. *> \endverbatim *> *> \param[out] EQUED *> \verbatim *> EQUED is CHARACTER*1 *> Specifies whether or not equilibration was done. *> = 'N': No equilibration. *> = 'Y': Equilibration was done, i.e., A has been replaced by *> diag(S) * A * diag(S). *> \endverbatim * *> \par Internal Parameters: * ========================= *> *> \verbatim *> THRESH is a threshold value used to decide if scaling should be done *> based on the ratio of the scaling factors. If SCOND < THRESH, *> scaling is done. *> *> LARGE and SMALL are threshold values used to decide if scaling should *> be done based on the absolute size of the largest matrix element. *> If AMAX > LARGE or AMAX < SMALL, scaling is done. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER EQUED, UPLO INTEGER N DOUBLE PRECISION AMAX, SCOND * .. * .. Array Arguments .. DOUBLE PRECISION AP( * ), S( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, THRESH PARAMETER ( ONE = 1.0D+0, THRESH = 0.1D+0 ) * .. * .. Local Scalars .. INTEGER I, J, JC DOUBLE PRECISION CJ, LARGE, SMALL * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL LSAME, DLAMCH * .. * .. Executable Statements .. * * Quick return if possible * IF( N.LE.0 ) THEN EQUED = 'N' RETURN END IF * * Initialize LARGE and SMALL. * SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) LARGE = ONE / SMALL * IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN * * No equilibration * EQUED = 'N' ELSE * * Replace A by diag(S) * A * diag(S). * IF( LSAME( UPLO, 'U' ) ) THEN * * Upper triangle of A is stored. * JC = 1 DO 20 J = 1, N CJ = S( J ) DO 10 I = 1, J AP( JC+I-1 ) = CJ*S( I )*AP( JC+I-1 ) 10 CONTINUE JC = JC + J 20 CONTINUE ELSE * * Lower triangle of A is stored. * JC = 1 DO 40 J = 1, N CJ = S( J ) DO 30 I = J, N AP( JC+I-J ) = CJ*S( I )*AP( JC+I-J ) 30 CONTINUE JC = JC + N - J + 1 40 CONTINUE END IF EQUED = 'Y' END IF * RETURN * * End of DLAQSP * END *> \brief \b DLAQSY scales a symmetric/Hermitian matrix, using scaling factors computed by spoequ. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAQSY + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) * * .. Scalar Arguments .. * CHARACTER EQUED, UPLO * INTEGER LDA, N * DOUBLE PRECISION AMAX, SCOND * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), S( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAQSY equilibrates a symmetric matrix A using the scaling factors *> in the vector S. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the upper or lower triangular part of the *> symmetric matrix A is stored. *> = 'U': Upper triangular *> = 'L': Lower triangular *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the symmetric matrix A. If UPLO = 'U', the leading *> n by n upper triangular part of A contains the upper *> triangular part of the matrix A, and the strictly lower *> triangular part of A is not referenced. If UPLO = 'L', the *> leading n by n lower triangular part of A contains the lower *> triangular part of the matrix A, and the strictly upper *> triangular part of A is not referenced. *> *> On exit, if EQUED = 'Y', the equilibrated matrix: *> diag(S) * A * diag(S). *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(N,1). *> \endverbatim *> *> \param[in] S *> \verbatim *> S is DOUBLE PRECISION array, dimension (N) *> The scale factors for A. *> \endverbatim *> *> \param[in] SCOND *> \verbatim *> SCOND is DOUBLE PRECISION *> Ratio of the smallest S(i) to the largest S(i). *> \endverbatim *> *> \param[in] AMAX *> \verbatim *> AMAX is DOUBLE PRECISION *> Absolute value of largest matrix entry. *> \endverbatim *> *> \param[out] EQUED *> \verbatim *> EQUED is CHARACTER*1 *> Specifies whether or not equilibration was done. *> = 'N': No equilibration. *> = 'Y': Equilibration was done, i.e., A has been replaced by *> diag(S) * A * diag(S). *> \endverbatim * *> \par Internal Parameters: * ========================= *> *> \verbatim *> THRESH is a threshold value used to decide if scaling should be done *> based on the ratio of the scaling factors. If SCOND < THRESH, *> scaling is done. *> *> LARGE and SMALL are threshold values used to decide if scaling should *> be done based on the absolute size of the largest matrix element. *> If AMAX > LARGE or AMAX < SMALL, scaling is done. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleSYauxiliary * * ===================================================================== SUBROUTINE DLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER EQUED, UPLO INTEGER LDA, N DOUBLE PRECISION AMAX, SCOND * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), S( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, THRESH PARAMETER ( ONE = 1.0D+0, THRESH = 0.1D+0 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION CJ, LARGE, SMALL * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL LSAME, DLAMCH * .. * .. Executable Statements .. * * Quick return if possible * IF( N.LE.0 ) THEN EQUED = 'N' RETURN END IF * * Initialize LARGE and SMALL. * SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) LARGE = ONE / SMALL * IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN * * No equilibration * EQUED = 'N' ELSE * * Replace A by diag(S) * A * diag(S). * IF( LSAME( UPLO, 'U' ) ) THEN * * Upper triangle of A is stored. * DO 20 J = 1, N CJ = S( J ) DO 10 I = 1, J A( I, J ) = CJ*S( I )*A( I, J ) 10 CONTINUE 20 CONTINUE ELSE * * Lower triangle of A is stored. * DO 40 J = 1, N CJ = S( J ) DO 30 I = J, N A( I, J ) = CJ*S( I )*A( I, J ) 30 CONTINUE 40 CONTINUE END IF EQUED = 'Y' END IF * RETURN * * End of DLAQSY * END *> \brief \b DLAQTR solves a real quasi-triangular system of equations, or a complex quasi-triangular system of special form, in real arithmetic. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAQTR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAQTR( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK, * INFO ) * * .. Scalar Arguments .. * LOGICAL LREAL, LTRAN * INTEGER INFO, LDT, N * DOUBLE PRECISION SCALE, W * .. * .. Array Arguments .. * DOUBLE PRECISION B( * ), T( LDT, * ), WORK( * ), X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAQTR solves the real quasi-triangular system *> *> op(T)*p = scale*c, if LREAL = .TRUE. *> *> or the complex quasi-triangular systems *> *> op(T + iB)*(p+iq) = scale*(c+id), if LREAL = .FALSE. *> *> in real arithmetic, where T is upper quasi-triangular. *> If LREAL = .FALSE., then the first diagonal block of T must be *> 1 by 1, B is the specially structured matrix *> *> B = [ b(1) b(2) ... b(n) ] *> [ w ] *> [ w ] *> [ . ] *> [ w ] *> *> op(A) = A or A**T, A**T denotes the transpose of *> matrix A. *> *> On input, X = [ c ]. On output, X = [ p ]. *> [ d ] [ q ] *> *> This subroutine is designed for the condition number estimation *> in routine DTRSNA. *> \endverbatim * * Arguments: * ========== * *> \param[in] LTRAN *> \verbatim *> LTRAN is LOGICAL *> On entry, LTRAN specifies the option of conjugate transpose: *> = .FALSE., op(T+i*B) = T+i*B, *> = .TRUE., op(T+i*B) = (T+i*B)**T. *> \endverbatim *> *> \param[in] LREAL *> \verbatim *> LREAL is LOGICAL *> On entry, LREAL specifies the input matrix structure: *> = .FALSE., the input is complex *> = .TRUE., the input is real *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> On entry, N specifies the order of T+i*B. N >= 0. *> \endverbatim *> *> \param[in] T *> \verbatim *> T is DOUBLE PRECISION array, dimension (LDT,N) *> On entry, T contains a matrix in Schur canonical form. *> If LREAL = .FALSE., then the first diagonal block of T mu *> be 1 by 1. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the matrix T. LDT >= max(1,N). *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (N) *> On entry, B contains the elements to form the matrix *> B as described above. *> If LREAL = .TRUE., B is not referenced. *> \endverbatim *> *> \param[in] W *> \verbatim *> W is DOUBLE PRECISION *> On entry, W is the diagonal element of the matrix B. *> If LREAL = .TRUE., W is not referenced. *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is DOUBLE PRECISION *> On exit, SCALE is the scale factor. *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (2*N) *> On entry, X contains the right hand side of the system. *> On exit, X is overwritten by the solution. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> On exit, INFO is set to *> 0: successful exit. *> 1: the some diagonal 1 by 1 block has been perturbed by *> a small number SMIN to keep nonsingularity. *> 2: the some diagonal 2 by 2 block has been perturbed by *> a small number in DLALN2 to keep nonsingularity. *> NOTE: In the interests of speed, this routine does not *> check the inputs for errors. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLAQTR( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK, $ INFO ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. LOGICAL LREAL, LTRAN INTEGER INFO, LDT, N DOUBLE PRECISION SCALE, W * .. * .. Array Arguments .. DOUBLE PRECISION B( * ), T( LDT, * ), WORK( * ), X( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOTRAN INTEGER I, IERR, J, J1, J2, JNEXT, K, N1, N2 DOUBLE PRECISION BIGNUM, EPS, REC, SCALOC, SI, SMIN, SMINW, $ SMLNUM, SR, TJJ, TMP, XJ, XMAX, XNORM, Z * .. * .. Local Arrays .. DOUBLE PRECISION D( 2, 2 ), V( 2, 2 ) * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DASUM, DDOT, DLAMCH, DLANGE EXTERNAL IDAMAX, DASUM, DDOT, DLAMCH, DLANGE * .. * .. External Subroutines .. EXTERNAL DAXPY, DLADIV, DLALN2, DSCAL * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Executable Statements .. * * Do not test the input parameters for errors * NOTRAN = .NOT.LTRAN INFO = 0 * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Set constants to control overflow * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) / EPS BIGNUM = ONE / SMLNUM * XNORM = DLANGE( 'M', N, N, T, LDT, D ) IF( .NOT.LREAL ) $ XNORM = MAX( XNORM, ABS( W ), DLANGE( 'M', N, 1, B, N, D ) ) SMIN = MAX( SMLNUM, EPS*XNORM ) * * Compute 1-norm of each column of strictly upper triangular * part of T to control overflow in triangular solver. * WORK( 1 ) = ZERO DO 10 J = 2, N WORK( J ) = DASUM( J-1, T( 1, J ), 1 ) 10 CONTINUE * IF( .NOT.LREAL ) THEN DO 20 I = 2, N WORK( I ) = WORK( I ) + ABS( B( I ) ) 20 CONTINUE END IF * N2 = 2*N N1 = N IF( .NOT.LREAL ) $ N1 = N2 K = IDAMAX( N1, X, 1 ) XMAX = ABS( X( K ) ) SCALE = ONE * IF( XMAX.GT.BIGNUM ) THEN SCALE = BIGNUM / XMAX CALL DSCAL( N1, SCALE, X, 1 ) XMAX = BIGNUM END IF * IF( LREAL ) THEN * IF( NOTRAN ) THEN * * Solve T*p = scale*c * JNEXT = N DO 30 J = N, 1, -1 IF( J.GT.JNEXT ) $ GO TO 30 J1 = J J2 = J JNEXT = J - 1 IF( J.GT.1 ) THEN IF( T( J, J-1 ).NE.ZERO ) THEN J1 = J - 1 JNEXT = J - 2 END IF END IF * IF( J1.EQ.J2 ) THEN * * Meet 1 by 1 diagonal block * * Scale to avoid overflow when computing * x(j) = b(j)/T(j,j) * XJ = ABS( X( J1 ) ) TJJ = ABS( T( J1, J1 ) ) TMP = T( J1, J1 ) IF( TJJ.LT.SMIN ) THEN TMP = SMIN TJJ = SMIN INFO = 1 END IF * IF( XJ.EQ.ZERO ) $ GO TO 30 * IF( TJJ.LT.ONE ) THEN IF( XJ.GT.BIGNUM*TJJ ) THEN REC = ONE / XJ CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF X( J1 ) = X( J1 ) / TMP XJ = ABS( X( J1 ) ) * * Scale x if necessary to avoid overflow when adding a * multiple of column j1 of T. * IF( XJ.GT.ONE ) THEN REC = ONE / XJ IF( WORK( J1 ).GT.( BIGNUM-XMAX )*REC ) THEN CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC END IF END IF IF( J1.GT.1 ) THEN CALL DAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 ) K = IDAMAX( J1-1, X, 1 ) XMAX = ABS( X( K ) ) END IF * ELSE * * Meet 2 by 2 diagonal block * * Call 2 by 2 linear system solve, to take * care of possible overflow by scaling factor. * D( 1, 1 ) = X( J1 ) D( 2, 1 ) = X( J2 ) CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, T( J1, J1 ), $ LDT, ONE, ONE, D, 2, ZERO, ZERO, V, 2, $ SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 2 * IF( SCALOC.NE.ONE ) THEN CALL DSCAL( N, SCALOC, X, 1 ) SCALE = SCALE*SCALOC END IF X( J1 ) = V( 1, 1 ) X( J2 ) = V( 2, 1 ) * * Scale V(1,1) (= X(J1)) and/or V(2,1) (=X(J2)) * to avoid overflow in updating right-hand side. * XJ = MAX( ABS( V( 1, 1 ) ), ABS( V( 2, 1 ) ) ) IF( XJ.GT.ONE ) THEN REC = ONE / XJ IF( MAX( WORK( J1 ), WORK( J2 ) ).GT. $ ( BIGNUM-XMAX )*REC ) THEN CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC END IF END IF * * Update right-hand side * IF( J1.GT.1 ) THEN CALL DAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 ) CALL DAXPY( J1-1, -X( J2 ), T( 1, J2 ), 1, X, 1 ) K = IDAMAX( J1-1, X, 1 ) XMAX = ABS( X( K ) ) END IF * END IF * 30 CONTINUE * ELSE * * Solve T**T*p = scale*c * JNEXT = 1 DO 40 J = 1, N IF( J.LT.JNEXT ) $ GO TO 40 J1 = J J2 = J JNEXT = J + 1 IF( J.LT.N ) THEN IF( T( J+1, J ).NE.ZERO ) THEN J2 = J + 1 JNEXT = J + 2 END IF END IF * IF( J1.EQ.J2 ) THEN * * 1 by 1 diagonal block * * Scale if necessary to avoid overflow in forming the * right-hand side element by inner product. * XJ = ABS( X( J1 ) ) IF( XMAX.GT.ONE ) THEN REC = ONE / XMAX IF( WORK( J1 ).GT.( BIGNUM-XJ )*REC ) THEN CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF * X( J1 ) = X( J1 ) - DDOT( J1-1, T( 1, J1 ), 1, X, 1 ) * XJ = ABS( X( J1 ) ) TJJ = ABS( T( J1, J1 ) ) TMP = T( J1, J1 ) IF( TJJ.LT.SMIN ) THEN TMP = SMIN TJJ = SMIN INFO = 1 END IF * IF( TJJ.LT.ONE ) THEN IF( XJ.GT.BIGNUM*TJJ ) THEN REC = ONE / XJ CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF X( J1 ) = X( J1 ) / TMP XMAX = MAX( XMAX, ABS( X( J1 ) ) ) * ELSE * * 2 by 2 diagonal block * * Scale if necessary to avoid overflow in forming the * right-hand side elements by inner product. * XJ = MAX( ABS( X( J1 ) ), ABS( X( J2 ) ) ) IF( XMAX.GT.ONE ) THEN REC = ONE / XMAX IF( MAX( WORK( J2 ), WORK( J1 ) ).GT.( BIGNUM-XJ )* $ REC ) THEN CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF * D( 1, 1 ) = X( J1 ) - DDOT( J1-1, T( 1, J1 ), 1, X, $ 1 ) D( 2, 1 ) = X( J2 ) - DDOT( J1-1, T( 1, J2 ), 1, X, $ 1 ) * CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, T( J1, J1 ), $ LDT, ONE, ONE, D, 2, ZERO, ZERO, V, 2, $ SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 2 * IF( SCALOC.NE.ONE ) THEN CALL DSCAL( N, SCALOC, X, 1 ) SCALE = SCALE*SCALOC END IF X( J1 ) = V( 1, 1 ) X( J2 ) = V( 2, 1 ) XMAX = MAX( ABS( X( J1 ) ), ABS( X( J2 ) ), XMAX ) * END IF 40 CONTINUE END IF * ELSE * SMINW = MAX( EPS*ABS( W ), SMIN ) IF( NOTRAN ) THEN * * Solve (T + iB)*(p+iq) = c+id * JNEXT = N DO 70 J = N, 1, -1 IF( J.GT.JNEXT ) $ GO TO 70 J1 = J J2 = J JNEXT = J - 1 IF( J.GT.1 ) THEN IF( T( J, J-1 ).NE.ZERO ) THEN J1 = J - 1 JNEXT = J - 2 END IF END IF * IF( J1.EQ.J2 ) THEN * * 1 by 1 diagonal block * * Scale if necessary to avoid overflow in division * Z = W IF( J1.EQ.1 ) $ Z = B( 1 ) XJ = ABS( X( J1 ) ) + ABS( X( N+J1 ) ) TJJ = ABS( T( J1, J1 ) ) + ABS( Z ) TMP = T( J1, J1 ) IF( TJJ.LT.SMINW ) THEN TMP = SMINW TJJ = SMINW INFO = 1 END IF * IF( XJ.EQ.ZERO ) $ GO TO 70 * IF( TJJ.LT.ONE ) THEN IF( XJ.GT.BIGNUM*TJJ ) THEN REC = ONE / XJ CALL DSCAL( N2, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF CALL DLADIV( X( J1 ), X( N+J1 ), TMP, Z, SR, SI ) X( J1 ) = SR X( N+J1 ) = SI XJ = ABS( X( J1 ) ) + ABS( X( N+J1 ) ) * * Scale x if necessary to avoid overflow when adding a * multiple of column j1 of T. * IF( XJ.GT.ONE ) THEN REC = ONE / XJ IF( WORK( J1 ).GT.( BIGNUM-XMAX )*REC ) THEN CALL DSCAL( N2, REC, X, 1 ) SCALE = SCALE*REC END IF END IF * IF( J1.GT.1 ) THEN CALL DAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 ) CALL DAXPY( J1-1, -X( N+J1 ), T( 1, J1 ), 1, $ X( N+1 ), 1 ) * X( 1 ) = X( 1 ) + B( J1 )*X( N+J1 ) X( N+1 ) = X( N+1 ) - B( J1 )*X( J1 ) * XMAX = ZERO DO 50 K = 1, J1 - 1 XMAX = MAX( XMAX, ABS( X( K ) )+ $ ABS( X( K+N ) ) ) 50 CONTINUE END IF * ELSE * * Meet 2 by 2 diagonal block * D( 1, 1 ) = X( J1 ) D( 2, 1 ) = X( J2 ) D( 1, 2 ) = X( N+J1 ) D( 2, 2 ) = X( N+J2 ) CALL DLALN2( .FALSE., 2, 2, SMINW, ONE, T( J1, J1 ), $ LDT, ONE, ONE, D, 2, ZERO, -W, V, 2, $ SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 2 * IF( SCALOC.NE.ONE ) THEN CALL DSCAL( 2*N, SCALOC, X, 1 ) SCALE = SCALOC*SCALE END IF X( J1 ) = V( 1, 1 ) X( J2 ) = V( 2, 1 ) X( N+J1 ) = V( 1, 2 ) X( N+J2 ) = V( 2, 2 ) * * Scale X(J1), .... to avoid overflow in * updating right hand side. * XJ = MAX( ABS( V( 1, 1 ) )+ABS( V( 1, 2 ) ), $ ABS( V( 2, 1 ) )+ABS( V( 2, 2 ) ) ) IF( XJ.GT.ONE ) THEN REC = ONE / XJ IF( MAX( WORK( J1 ), WORK( J2 ) ).GT. $ ( BIGNUM-XMAX )*REC ) THEN CALL DSCAL( N2, REC, X, 1 ) SCALE = SCALE*REC END IF END IF * * Update the right-hand side. * IF( J1.GT.1 ) THEN CALL DAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 ) CALL DAXPY( J1-1, -X( J2 ), T( 1, J2 ), 1, X, 1 ) * CALL DAXPY( J1-1, -X( N+J1 ), T( 1, J1 ), 1, $ X( N+1 ), 1 ) CALL DAXPY( J1-1, -X( N+J2 ), T( 1, J2 ), 1, $ X( N+1 ), 1 ) * X( 1 ) = X( 1 ) + B( J1 )*X( N+J1 ) + $ B( J2 )*X( N+J2 ) X( N+1 ) = X( N+1 ) - B( J1 )*X( J1 ) - $ B( J2 )*X( J2 ) * XMAX = ZERO DO 60 K = 1, J1 - 1 XMAX = MAX( ABS( X( K ) )+ABS( X( K+N ) ), $ XMAX ) 60 CONTINUE END IF * END IF 70 CONTINUE * ELSE * * Solve (T + iB)**T*(p+iq) = c+id * JNEXT = 1 DO 80 J = 1, N IF( J.LT.JNEXT ) $ GO TO 80 J1 = J J2 = J JNEXT = J + 1 IF( J.LT.N ) THEN IF( T( J+1, J ).NE.ZERO ) THEN J2 = J + 1 JNEXT = J + 2 END IF END IF * IF( J1.EQ.J2 ) THEN * * 1 by 1 diagonal block * * Scale if necessary to avoid overflow in forming the * right-hand side element by inner product. * XJ = ABS( X( J1 ) ) + ABS( X( J1+N ) ) IF( XMAX.GT.ONE ) THEN REC = ONE / XMAX IF( WORK( J1 ).GT.( BIGNUM-XJ )*REC ) THEN CALL DSCAL( N2, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF * X( J1 ) = X( J1 ) - DDOT( J1-1, T( 1, J1 ), 1, X, 1 ) X( N+J1 ) = X( N+J1 ) - DDOT( J1-1, T( 1, J1 ), 1, $ X( N+1 ), 1 ) IF( J1.GT.1 ) THEN X( J1 ) = X( J1 ) - B( J1 )*X( N+1 ) X( N+J1 ) = X( N+J1 ) + B( J1 )*X( 1 ) END IF XJ = ABS( X( J1 ) ) + ABS( X( J1+N ) ) * Z = W IF( J1.EQ.1 ) $ Z = B( 1 ) * * Scale if necessary to avoid overflow in * complex division * TJJ = ABS( T( J1, J1 ) ) + ABS( Z ) TMP = T( J1, J1 ) IF( TJJ.LT.SMINW ) THEN TMP = SMINW TJJ = SMINW INFO = 1 END IF * IF( TJJ.LT.ONE ) THEN IF( XJ.GT.BIGNUM*TJJ ) THEN REC = ONE / XJ CALL DSCAL( N2, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF CALL DLADIV( X( J1 ), X( N+J1 ), TMP, -Z, SR, SI ) X( J1 ) = SR X( J1+N ) = SI XMAX = MAX( ABS( X( J1 ) )+ABS( X( J1+N ) ), XMAX ) * ELSE * * 2 by 2 diagonal block * * Scale if necessary to avoid overflow in forming the * right-hand side element by inner product. * XJ = MAX( ABS( X( J1 ) )+ABS( X( N+J1 ) ), $ ABS( X( J2 ) )+ABS( X( N+J2 ) ) ) IF( XMAX.GT.ONE ) THEN REC = ONE / XMAX IF( MAX( WORK( J1 ), WORK( J2 ) ).GT. $ ( BIGNUM-XJ ) / XMAX ) THEN CALL DSCAL( N2, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF * D( 1, 1 ) = X( J1 ) - DDOT( J1-1, T( 1, J1 ), 1, X, $ 1 ) D( 2, 1 ) = X( J2 ) - DDOT( J1-1, T( 1, J2 ), 1, X, $ 1 ) D( 1, 2 ) = X( N+J1 ) - DDOT( J1-1, T( 1, J1 ), 1, $ X( N+1 ), 1 ) D( 2, 2 ) = X( N+J2 ) - DDOT( J1-1, T( 1, J2 ), 1, $ X( N+1 ), 1 ) D( 1, 1 ) = D( 1, 1 ) - B( J1 )*X( N+1 ) D( 2, 1 ) = D( 2, 1 ) - B( J2 )*X( N+1 ) D( 1, 2 ) = D( 1, 2 ) + B( J1 )*X( 1 ) D( 2, 2 ) = D( 2, 2 ) + B( J2 )*X( 1 ) * CALL DLALN2( .TRUE., 2, 2, SMINW, ONE, T( J1, J1 ), $ LDT, ONE, ONE, D, 2, ZERO, W, V, 2, $ SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 2 * IF( SCALOC.NE.ONE ) THEN CALL DSCAL( N2, SCALOC, X, 1 ) SCALE = SCALOC*SCALE END IF X( J1 ) = V( 1, 1 ) X( J2 ) = V( 2, 1 ) X( N+J1 ) = V( 1, 2 ) X( N+J2 ) = V( 2, 2 ) XMAX = MAX( ABS( X( J1 ) )+ABS( X( N+J1 ) ), $ ABS( X( J2 ) )+ABS( X( N+J2 ) ), XMAX ) * END IF * 80 CONTINUE * END IF * END IF * RETURN * * End of DLAQTR * END *> \brief \b DLAR1V computes the (scaled) r-th column of the inverse of the submatrix in rows b1 through bn of the tridiagonal matrix LDLT - λI. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAR1V + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD, * PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, * R, ISUPPZ, NRMINV, RESID, RQCORR, WORK ) * * .. Scalar Arguments .. * LOGICAL WANTNC * INTEGER B1, BN, N, NEGCNT, R * DOUBLE PRECISION GAPTOL, LAMBDA, MINGMA, NRMINV, PIVMIN, RESID, * $ RQCORR, ZTZ * .. * .. Array Arguments .. * INTEGER ISUPPZ( * ) * DOUBLE PRECISION D( * ), L( * ), LD( * ), LLD( * ), * $ WORK( * ) * DOUBLE PRECISION Z( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAR1V computes the (scaled) r-th column of the inverse of *> the sumbmatrix in rows B1 through BN of the tridiagonal matrix *> L D L**T - sigma I. When sigma is close to an eigenvalue, the *> computed vector is an accurate eigenvector. Usually, r corresponds *> to the index where the eigenvector is largest in magnitude. *> The following steps accomplish this computation : *> (a) Stationary qd transform, L D L**T - sigma I = L(+) D(+) L(+)**T, *> (b) Progressive qd transform, L D L**T - sigma I = U(-) D(-) U(-)**T, *> (c) Computation of the diagonal elements of the inverse of *> L D L**T - sigma I by combining the above transforms, and choosing *> r as the index where the diagonal of the inverse is (one of the) *> largest in magnitude. *> (d) Computation of the (scaled) r-th column of the inverse using the *> twisted factorization obtained by combining the top part of the *> the stationary and the bottom part of the progressive transform. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix L D L**T. *> \endverbatim *> *> \param[in] B1 *> \verbatim *> B1 is INTEGER *> First index of the submatrix of L D L**T. *> \endverbatim *> *> \param[in] BN *> \verbatim *> BN is INTEGER *> Last index of the submatrix of L D L**T. *> \endverbatim *> *> \param[in] LAMBDA *> \verbatim *> LAMBDA is DOUBLE PRECISION *> The shift. In order to compute an accurate eigenvector, *> LAMBDA should be a good approximation to an eigenvalue *> of L D L**T. *> \endverbatim *> *> \param[in] L *> \verbatim *> L is DOUBLE PRECISION array, dimension (N-1) *> The (n-1) subdiagonal elements of the unit bidiagonal matrix *> L, in elements 1 to N-1. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The n diagonal elements of the diagonal matrix D. *> \endverbatim *> *> \param[in] LD *> \verbatim *> LD is DOUBLE PRECISION array, dimension (N-1) *> The n-1 elements L(i)*D(i). *> \endverbatim *> *> \param[in] LLD *> \verbatim *> LLD is DOUBLE PRECISION array, dimension (N-1) *> The n-1 elements L(i)*L(i)*D(i). *> \endverbatim *> *> \param[in] PIVMIN *> \verbatim *> PIVMIN is DOUBLE PRECISION *> The minimum pivot in the Sturm sequence. *> \endverbatim *> *> \param[in] GAPTOL *> \verbatim *> GAPTOL is DOUBLE PRECISION *> Tolerance that indicates when eigenvector entries are negligible *> w.r.t. their contribution to the residual. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (N) *> On input, all entries of Z must be set to 0. *> On output, Z contains the (scaled) r-th column of the *> inverse. The scaling is such that Z(R) equals 1. *> \endverbatim *> *> \param[in] WANTNC *> \verbatim *> WANTNC is LOGICAL *> Specifies whether NEGCNT has to be computed. *> \endverbatim *> *> \param[out] NEGCNT *> \verbatim *> NEGCNT is INTEGER *> If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin *> in the matrix factorization L D L**T, and NEGCNT = -1 otherwise. *> \endverbatim *> *> \param[out] ZTZ *> \verbatim *> ZTZ is DOUBLE PRECISION *> The square of the 2-norm of Z. *> \endverbatim *> *> \param[out] MINGMA *> \verbatim *> MINGMA is DOUBLE PRECISION *> The reciprocal of the largest (in magnitude) diagonal *> element of the inverse of L D L**T - sigma I. *> \endverbatim *> *> \param[in,out] R *> \verbatim *> R is INTEGER *> The twist index for the twisted factorization used to *> compute Z. *> On input, 0 <= R <= N. If R is input as 0, R is set to *> the index where (L D L**T - sigma I)^{-1} is largest *> in magnitude. If 1 <= R <= N, R is unchanged. *> On output, R contains the twist index used to compute Z. *> Ideally, R designates the position of the maximum entry in the *> eigenvector. *> \endverbatim *> *> \param[out] ISUPPZ *> \verbatim *> ISUPPZ is INTEGER array, dimension (2) *> The support of the vector in Z, i.e., the vector Z is *> nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ). *> \endverbatim *> *> \param[out] NRMINV *> \verbatim *> NRMINV is DOUBLE PRECISION *> NRMINV = 1/SQRT( ZTZ ) *> \endverbatim *> *> \param[out] RESID *> \verbatim *> RESID is DOUBLE PRECISION *> The residual of the FP vector. *> RESID = ABS( MINGMA )/SQRT( ZTZ ) *> \endverbatim *> *> \param[out] RQCORR *> \verbatim *> RQCORR is DOUBLE PRECISION *> The Rayleigh Quotient correction to LAMBDA. *> RQCORR = MINGMA*TMP *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (4*N) *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Contributors: * ================== *> *> Beresford Parlett, University of California, Berkeley, USA \n *> Jim Demmel, University of California, Berkeley, USA \n *> Inderjit Dhillon, University of Texas, Austin, USA \n *> Osni Marques, LBNL/NERSC, USA \n *> Christof Voemel, University of California, Berkeley, USA * * ===================================================================== SUBROUTINE DLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD, $ PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, $ R, ISUPPZ, NRMINV, RESID, RQCORR, WORK ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. LOGICAL WANTNC INTEGER B1, BN, N, NEGCNT, R DOUBLE PRECISION GAPTOL, LAMBDA, MINGMA, NRMINV, PIVMIN, RESID, $ RQCORR, ZTZ * .. * .. Array Arguments .. INTEGER ISUPPZ( * ) DOUBLE PRECISION D( * ), L( * ), LD( * ), LLD( * ), $ WORK( * ) DOUBLE PRECISION Z( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL SAWNAN1, SAWNAN2 INTEGER I, INDLPL, INDP, INDS, INDUMN, NEG1, NEG2, R1, $ R2 DOUBLE PRECISION DMINUS, DPLUS, EPS, S, TMP * .. * .. External Functions .. LOGICAL DISNAN DOUBLE PRECISION DLAMCH EXTERNAL DISNAN, DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * EPS = DLAMCH( 'Precision' ) IF( R.EQ.0 ) THEN R1 = B1 R2 = BN ELSE R1 = R R2 = R END IF * Storage for LPLUS INDLPL = 0 * Storage for UMINUS INDUMN = N INDS = 2*N + 1 INDP = 3*N + 1 IF( B1.EQ.1 ) THEN WORK( INDS ) = ZERO ELSE WORK( INDS+B1-1 ) = LLD( B1-1 ) END IF * * Compute the stationary transform (using the differential form) * until the index R2. * SAWNAN1 = .FALSE. NEG1 = 0 S = WORK( INDS+B1-1 ) - LAMBDA DO 50 I = B1, R1 - 1 DPLUS = D( I ) + S WORK( INDLPL+I ) = LD( I ) / DPLUS IF(DPLUS.LT.ZERO) NEG1 = NEG1 + 1 WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I ) S = WORK( INDS+I ) - LAMBDA 50 CONTINUE SAWNAN1 = DISNAN( S ) IF( SAWNAN1 ) GOTO 60 DO 51 I = R1, R2 - 1 DPLUS = D( I ) + S WORK( INDLPL+I ) = LD( I ) / DPLUS WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I ) S = WORK( INDS+I ) - LAMBDA 51 CONTINUE SAWNAN1 = DISNAN( S ) * 60 CONTINUE IF( SAWNAN1 ) THEN * Runs a slower version of the above loop if a NaN is detected NEG1 = 0 S = WORK( INDS+B1-1 ) - LAMBDA DO 70 I = B1, R1 - 1 DPLUS = D( I ) + S IF(ABS(DPLUS).LT.PIVMIN) DPLUS = -PIVMIN WORK( INDLPL+I ) = LD( I ) / DPLUS IF(DPLUS.LT.ZERO) NEG1 = NEG1 + 1 WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I ) IF( WORK( INDLPL+I ).EQ.ZERO ) $ WORK( INDS+I ) = LLD( I ) S = WORK( INDS+I ) - LAMBDA 70 CONTINUE DO 71 I = R1, R2 - 1 DPLUS = D( I ) + S IF(ABS(DPLUS).LT.PIVMIN) DPLUS = -PIVMIN WORK( INDLPL+I ) = LD( I ) / DPLUS WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I ) IF( WORK( INDLPL+I ).EQ.ZERO ) $ WORK( INDS+I ) = LLD( I ) S = WORK( INDS+I ) - LAMBDA 71 CONTINUE END IF * * Compute the progressive transform (using the differential form) * until the index R1 * SAWNAN2 = .FALSE. NEG2 = 0 WORK( INDP+BN-1 ) = D( BN ) - LAMBDA DO 80 I = BN - 1, R1, -1 DMINUS = LLD( I ) + WORK( INDP+I ) TMP = D( I ) / DMINUS IF(DMINUS.LT.ZERO) NEG2 = NEG2 + 1 WORK( INDUMN+I ) = L( I )*TMP WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - LAMBDA 80 CONTINUE TMP = WORK( INDP+R1-1 ) SAWNAN2 = DISNAN( TMP ) IF( SAWNAN2 ) THEN * Runs a slower version of the above loop if a NaN is detected NEG2 = 0 DO 100 I = BN-1, R1, -1 DMINUS = LLD( I ) + WORK( INDP+I ) IF(ABS(DMINUS).LT.PIVMIN) DMINUS = -PIVMIN TMP = D( I ) / DMINUS IF(DMINUS.LT.ZERO) NEG2 = NEG2 + 1 WORK( INDUMN+I ) = L( I )*TMP WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - LAMBDA IF( TMP.EQ.ZERO ) $ WORK( INDP+I-1 ) = D( I ) - LAMBDA 100 CONTINUE END IF * * Find the index (from R1 to R2) of the largest (in magnitude) * diagonal element of the inverse * MINGMA = WORK( INDS+R1-1 ) + WORK( INDP+R1-1 ) IF( MINGMA.LT.ZERO ) NEG1 = NEG1 + 1 IF( WANTNC ) THEN NEGCNT = NEG1 + NEG2 ELSE NEGCNT = -1 ENDIF IF( ABS(MINGMA).EQ.ZERO ) $ MINGMA = EPS*WORK( INDS+R1-1 ) R = R1 DO 110 I = R1, R2 - 1 TMP = WORK( INDS+I ) + WORK( INDP+I ) IF( TMP.EQ.ZERO ) $ TMP = EPS*WORK( INDS+I ) IF( ABS( TMP ).LE.ABS( MINGMA ) ) THEN MINGMA = TMP R = I + 1 END IF 110 CONTINUE * * Compute the FP vector: solve N^T v = e_r * ISUPPZ( 1 ) = B1 ISUPPZ( 2 ) = BN Z( R ) = ONE ZTZ = ONE * * Compute the FP vector upwards from R * IF( .NOT.SAWNAN1 .AND. .NOT.SAWNAN2 ) THEN DO 210 I = R-1, B1, -1 Z( I ) = -( WORK( INDLPL+I )*Z( I+1 ) ) IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL ) $ THEN Z( I ) = ZERO ISUPPZ( 1 ) = I + 1 GOTO 220 ENDIF ZTZ = ZTZ + Z( I )*Z( I ) 210 CONTINUE 220 CONTINUE ELSE * Run slower loop if NaN occurred. DO 230 I = R - 1, B1, -1 IF( Z( I+1 ).EQ.ZERO ) THEN Z( I ) = -( LD( I+1 ) / LD( I ) )*Z( I+2 ) ELSE Z( I ) = -( WORK( INDLPL+I )*Z( I+1 ) ) END IF IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL ) $ THEN Z( I ) = ZERO ISUPPZ( 1 ) = I + 1 GO TO 240 END IF ZTZ = ZTZ + Z( I )*Z( I ) 230 CONTINUE 240 CONTINUE ENDIF * Compute the FP vector downwards from R in blocks of size BLKSIZ IF( .NOT.SAWNAN1 .AND. .NOT.SAWNAN2 ) THEN DO 250 I = R, BN-1 Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) ) IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL ) $ THEN Z( I+1 ) = ZERO ISUPPZ( 2 ) = I GO TO 260 END IF ZTZ = ZTZ + Z( I+1 )*Z( I+1 ) 250 CONTINUE 260 CONTINUE ELSE * Run slower loop if NaN occurred. DO 270 I = R, BN - 1 IF( Z( I ).EQ.ZERO ) THEN Z( I+1 ) = -( LD( I-1 ) / LD( I ) )*Z( I-1 ) ELSE Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) ) END IF IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL ) $ THEN Z( I+1 ) = ZERO ISUPPZ( 2 ) = I GO TO 280 END IF ZTZ = ZTZ + Z( I+1 )*Z( I+1 ) 270 CONTINUE 280 CONTINUE END IF * * Compute quantities for convergence test * TMP = ONE / ZTZ NRMINV = SQRT( TMP ) RESID = ABS( MINGMA )*NRMINV RQCORR = MINGMA*TMP * * RETURN * * End of DLAR1V * END *> \brief \b DLAR2V applies a vector of plane rotations with real cosines and real sines from both sides to a sequence of 2-by-2 symmetric/Hermitian matrices. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAR2V + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAR2V( N, X, Y, Z, INCX, C, S, INCC ) * * .. Scalar Arguments .. * INTEGER INCC, INCX, N * .. * .. Array Arguments .. * DOUBLE PRECISION C( * ), S( * ), X( * ), Y( * ), Z( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAR2V applies a vector of real plane rotations from both sides to *> a sequence of 2-by-2 real symmetric matrices, defined by the elements *> of the vectors x, y and z. For i = 1,2,...,n *> *> ( x(i) z(i) ) := ( c(i) s(i) ) ( x(i) z(i) ) ( c(i) -s(i) ) *> ( z(i) y(i) ) ( -s(i) c(i) ) ( z(i) y(i) ) ( s(i) c(i) ) *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The number of plane rotations to be applied. *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is DOUBLE PRECISION array, *> dimension (1+(N-1)*INCX) *> The vector x. *> \endverbatim *> *> \param[in,out] Y *> \verbatim *> Y is DOUBLE PRECISION array, *> dimension (1+(N-1)*INCX) *> The vector y. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is DOUBLE PRECISION array, *> dimension (1+(N-1)*INCX) *> The vector z. *> \endverbatim *> *> \param[in] INCX *> \verbatim *> INCX is INTEGER *> The increment between elements of X, Y and Z. INCX > 0. *> \endverbatim *> *> \param[in] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (1+(N-1)*INCC) *> The cosines of the plane rotations. *> \endverbatim *> *> \param[in] S *> \verbatim *> S is DOUBLE PRECISION array, dimension (1+(N-1)*INCC) *> The sines of the plane rotations. *> \endverbatim *> *> \param[in] INCC *> \verbatim *> INCC is INTEGER *> The increment between elements of C and S. INCC > 0. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLAR2V( N, X, Y, Z, INCX, C, S, INCC ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INCC, INCX, N * .. * .. Array Arguments .. DOUBLE PRECISION C( * ), S( * ), X( * ), Y( * ), Z( * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I, IC, IX DOUBLE PRECISION CI, SI, T1, T2, T3, T4, T5, T6, XI, YI, ZI * .. * .. Executable Statements .. * IX = 1 IC = 1 DO 10 I = 1, N XI = X( IX ) YI = Y( IX ) ZI = Z( IX ) CI = C( IC ) SI = S( IC ) T1 = SI*ZI T2 = CI*ZI T3 = T2 - SI*XI T4 = T2 + SI*YI T5 = CI*XI + T1 T6 = CI*YI - T1 X( IX ) = CI*T5 + SI*T4 Y( IX ) = CI*T6 - SI*T3 Z( IX ) = CI*T4 - SI*T5 IX = IX + INCX IC = IC + INCC 10 CONTINUE * * End of DLAR2V * RETURN END *> \brief \b DLARF applies an elementary reflector to a general rectangular matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER INCV, LDC, M, N * DOUBLE PRECISION TAU * .. * .. Array Arguments .. * DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLARF applies a real elementary reflector H to a real m by n matrix *> C, from either the left or the right. H is represented in the form *> *> H = I - tau * v * v**T *> *> where tau is a real scalar and v is a real vector. *> *> If tau = 0, then H is taken to be the unit matrix. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': form H * C *> = 'R': form C * H *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is DOUBLE PRECISION array, dimension *> (1 + (M-1)*abs(INCV)) if SIDE = 'L' *> or (1 + (N-1)*abs(INCV)) if SIDE = 'R' *> The vector v in the representation of H. V is not used if *> TAU = 0. *> \endverbatim *> *> \param[in] INCV *> \verbatim *> INCV is INTEGER *> The increment between elements of v. INCV <> 0. *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION *> The value tau in the representation of H. *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is 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'. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDC >= max(1,M). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension *> (N) if SIDE = 'L' *> or (M) if SIDE = 'R' *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER SIDE INTEGER INCV, LDC, M, N DOUBLE PRECISION TAU * .. * .. Array Arguments .. DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL APPLYLEFT INTEGER I, LASTV, LASTC * .. * .. External Subroutines .. EXTERNAL DGEMV, DGER * .. * .. External Functions .. LOGICAL LSAME INTEGER ILADLR, ILADLC EXTERNAL LSAME, ILADLR, ILADLC * .. * .. Executable Statements .. * APPLYLEFT = LSAME( SIDE, 'L' ) LASTV = 0 LASTC = 0 IF( TAU.NE.ZERO ) THEN ! Set up variables for scanning V. LASTV begins pointing to the end ! of V. IF( APPLYLEFT ) THEN LASTV = M ELSE LASTV = N END IF IF( INCV.GT.0 ) THEN I = 1 + (LASTV-1) * INCV ELSE I = 1 END IF ! Look for the last non-zero row in V. DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) LASTV = LASTV - 1 I = I - INCV END DO IF( APPLYLEFT ) THEN ! Scan for the last non-zero column in C(1:lastv,:). LASTC = ILADLC(LASTV, N, C, LDC) ELSE ! Scan for the last non-zero row in C(:,1:lastv). LASTC = ILADLR(M, LASTV, C, LDC) END IF END IF ! Note that lastc.eq.0 renders the BLAS operations null; no special ! case is needed at this level. IF( APPLYLEFT ) THEN * * Form H * C * IF( LASTV.GT.0 ) THEN * * w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1) * CALL DGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V, INCV, $ ZERO, WORK, 1 ) * * C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**T * CALL DGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC ) END IF ELSE * * Form C * H * IF( LASTV.GT.0 ) THEN * * w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) * CALL DGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC, $ V, INCV, ZERO, WORK, 1 ) * * C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**T * CALL DGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC ) END IF END IF RETURN * * End of DLARF * END *> \brief \b DLARFB applies a block reflector or its transpose to a general rectangular matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARFB + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, * T, LDT, C, LDC, WORK, LDWORK ) * * .. Scalar Arguments .. * CHARACTER DIRECT, SIDE, STOREV, TRANS * INTEGER K, LDC, LDT, LDV, LDWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), * $ WORK( LDWORK, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLARFB applies a real block reflector H or its transpose H**T to a *> real m by n matrix C, from either the left or the right. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply H or H**T from the Left *> = 'R': apply H or H**T from the Right *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': apply H (No transpose) *> = 'T': apply H**T (Transpose) *> \endverbatim *> *> \param[in] DIRECT *> \verbatim *> DIRECT is CHARACTER*1 *> Indicates how H is formed from a product of elementary *> reflectors *> = 'F': H = H(1) H(2) . . . H(k) (Forward) *> = 'B': H = H(k) . . . H(2) H(1) (Backward) *> \endverbatim *> *> \param[in] STOREV *> \verbatim *> STOREV is CHARACTER*1 *> Indicates how the vectors which define the elementary *> reflectors are stored: *> = 'C': Columnwise *> = 'R': Rowwise *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The order of the matrix T (= the number of elementary *> reflectors whose product defines the block reflector). *> \endverbatim *> *> \param[in] V *> \verbatim *> V is DOUBLE PRECISION array, dimension *> (LDV,K) if STOREV = 'C' *> (LDV,M) if STOREV = 'R' and SIDE = 'L' *> (LDV,N) if STOREV = 'R' and SIDE = 'R' *> The matrix V. See Further Details. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the array V. *> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); *> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); *> if STOREV = 'R', LDV >= K. *> \endverbatim *> *> \param[in] T *> \verbatim *> T is DOUBLE PRECISION array, dimension (LDT,K) *> The triangular k by k matrix T in the representation of the *> block reflector. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= K. *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (LDC,N) *> On entry, the m by n matrix C. *> On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDC >= max(1,M). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (LDWORK,K) *> \endverbatim *> *> \param[in] LDWORK *> \verbatim *> LDWORK is INTEGER *> The leading dimension of the array WORK. *> If SIDE = 'L', LDWORK >= max(1,N); *> if SIDE = 'R', LDWORK >= max(1,M). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2013 * *> \ingroup doubleOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> The shape of the matrix V and the storage of the vectors which define *> the H(i) is best illustrated by the following example with n = 5 and *> k = 3. The elements equal to 1 are not stored; the corresponding *> array elements are modified but restored on exit. The rest of the *> array is not used. *> *> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': *> *> V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) *> ( v1 1 ) ( 1 v2 v2 v2 ) *> ( v1 v2 1 ) ( 1 v3 v3 ) *> ( v1 v2 v3 ) *> ( v1 v2 v3 ) *> *> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': *> *> V = ( v1 v2 v3 ) V = ( v1 v1 1 ) *> ( v1 v2 v3 ) ( v2 v2 v2 1 ) *> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) *> ( 1 v3 ) *> ( 1 ) *> \endverbatim *> * ===================================================================== SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, $ T, LDT, C, LDC, WORK, LDWORK ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2013 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS INTEGER K, LDC, LDT, LDV, LDWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), $ WORK( LDWORK, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. CHARACTER TRANST INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DTRMM * .. * .. Executable Statements .. * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 ) $ RETURN * IF( LSAME( TRANS, 'N' ) ) THEN TRANST = 'T' ELSE TRANST = 'N' END IF * IF( LSAME( STOREV, 'C' ) ) THEN * IF( LSAME( DIRECT, 'F' ) ) THEN * * Let V = ( V1 ) (first K rows) * ( V2 ) * where V1 is unit lower triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H**T * C where C = ( C1 ) * ( C2 ) * * W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK) * * W := C1**T * DO 10 J = 1, K CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 10 CONTINUE * * W := W * V1 * CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, $ K, ONE, V, LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C2**T * V2 * CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, $ ONE, WORK, LDWORK ) END IF * * W := W * T**T or W * T * CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W**T * IF( M.GT.K ) THEN * * C2 := C2 - V2 * W**T * CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, $ C( K+1, 1 ), LDC ) END IF * * W := W * V1**T * CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, $ ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W**T * DO 30 J = 1, K DO 20 I = 1, N C( J, I ) = C( J, I ) - WORK( I, J ) 20 CONTINUE 30 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**T where C = ( C1 C2 ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C1 * DO 40 J = 1, K CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 40 CONTINUE * * W := W * V1 * CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, $ K, ONE, V, LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C2 * V2 * CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, $ ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**T * CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V**T * IF( N.GT.K ) THEN * * C2 := C2 - W * V2**T * CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, $ C( 1, K+1 ), LDC ) END IF * * W := W * V1**T * CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, $ ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 60 J = 1, K DO 50 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 50 CONTINUE 60 CONTINUE END IF * ELSE * * Let V = ( V1 ) * ( V2 ) (last K rows) * where V2 is unit upper triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H**T * C where C = ( C1 ) * ( C2 ) * * W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK) * * W := C2**T * DO 70 J = 1, K CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) 70 CONTINUE * * W := W * V2 * CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C1**T * V1 * CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T**T or W * T * CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W**T * IF( M.GT.K ) THEN * * C1 := C1 - V1 * W**T * CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) END IF * * W := W * V2**T * CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W**T * DO 90 J = 1, K DO 80 I = 1, N C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) 80 CONTINUE 90 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**T where C = ( C1 C2 ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C2 * DO 100 J = 1, K CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 100 CONTINUE * * W := W * V2 * CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1 * CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**T * CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V**T * IF( N.GT.K ) THEN * * C1 := C1 - W * V1**T * CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) END IF * * W := W * V2**T * CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, $ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W * DO 120 J = 1, K DO 110 I = 1, M C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 110 CONTINUE 120 CONTINUE END IF END IF * ELSE IF( LSAME( STOREV, 'R' ) ) THEN * IF( LSAME( DIRECT, 'F' ) ) THEN * * Let V = ( V1 V2 ) (V1: first K columns) * where V1 is unit upper triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H**T * C where C = ( C1 ) * ( C2 ) * * W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK) * * W := C1**T * DO 130 J = 1, K CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 130 CONTINUE * * W := W * V1**T * CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, $ ONE, V, LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C2**T * V2**T * CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, $ WORK, LDWORK ) END IF * * W := W * T**T or W * T * CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V**T * W**T * IF( M.GT.K ) THEN * * C2 := C2 - V2**T * W**T * CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE, $ C( K+1, 1 ), LDC ) END IF * * W := W * V1 * CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W**T * DO 150 J = 1, K DO 140 I = 1, N C( J, I ) = C( J, I ) - WORK( I, J ) 140 CONTINUE 150 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**T where C = ( C1 C2 ) * * W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) * * W := C1 * DO 160 J = 1, K CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 160 CONTINUE * * W := W * V1**T * CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, $ ONE, V, LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C2 * V2**T * CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, $ ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**T * CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * IF( N.GT.K ) THEN * * C2 := C2 - W * V2 * CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, $ C( 1, K+1 ), LDC ) END IF * * W := W * V1 * CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 180 J = 1, K DO 170 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 170 CONTINUE 180 CONTINUE * END IF * ELSE * * Let V = ( V1 V2 ) (V2: last K columns) * where V2 is unit lower triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H**T * C where C = ( C1 ) * ( C2 ) * * W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK) * * W := C2**T * DO 190 J = 1, K CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) 190 CONTINUE * * W := W * V2**T * CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, $ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C1**T * V1**T * CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, $ C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T**T or W * T * CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V**T * W**T * IF( M.GT.K ) THEN * * C1 := C1 - V1**T * W**T * CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, $ V, LDV, WORK, LDWORK, ONE, C, LDC ) END IF * * W := W * V2 * CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W**T * DO 210 J = 1, K DO 200 I = 1, N C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) 200 CONTINUE 210 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H' where C = ( C1 C2 ) * * W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) * * W := C2 * DO 220 J = 1, K CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 220 CONTINUE * * W := W * V2**T * CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, $ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1**T * CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**T * CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * IF( N.GT.K ) THEN * * C1 := C1 - W * V1 * CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) END IF * * W := W * V2 * CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 240 J = 1, K DO 230 I = 1, M C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 230 CONTINUE 240 CONTINUE * END IF * END IF END IF * RETURN * * End of DLARFB * END *> \brief \b DLARFG generates an elementary reflector (Householder matrix). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARFG + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) * * .. Scalar Arguments .. * INTEGER INCX, N * DOUBLE PRECISION ALPHA, TAU * .. * .. Array Arguments .. * DOUBLE PRECISION X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLARFG generates a real elementary reflector H of order n, such *> that *> *> H * ( alpha ) = ( beta ), H**T * H = I. *> ( x ) ( 0 ) *> *> where alpha and beta are scalars, and x is an (n-1)-element real *> vector. H is represented in the form *> *> H = I - tau * ( 1 ) * ( 1 v**T ) , *> ( v ) *> *> where tau is a real scalar and v is a real (n-1)-element *> vector. *> *> If the elements of x are all zero, then tau = 0 and H is taken to be *> the unit matrix. *> *> Otherwise 1 <= tau <= 2. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the elementary reflector. *> \endverbatim *> *> \param[in,out] ALPHA *> \verbatim *> ALPHA is DOUBLE PRECISION *> On entry, the value alpha. *> On exit, it is overwritten with the value beta. *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension *> (1+(N-2)*abs(INCX)) *> On entry, the vector x. *> On exit, it is overwritten with the vector v. *> \endverbatim *> *> \param[in] INCX *> \verbatim *> INCX is INTEGER *> The increment between elements of X. INCX > 0. *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION *> The value tau. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date November 2017 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) * * -- LAPACK auxiliary routine (version 3.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. Scalar Arguments .. INTEGER INCX, N DOUBLE PRECISION ALPHA, TAU * .. * .. Array Arguments .. DOUBLE PRECISION X( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER J, KNT DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 EXTERNAL DLAMCH, DLAPY2, DNRM2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, SIGN * .. * .. External Subroutines .. EXTERNAL DSCAL * .. * .. Executable Statements .. * IF( N.LE.1 ) THEN TAU = ZERO RETURN END IF * XNORM = DNRM2( N-1, X, INCX ) * IF( XNORM.EQ.ZERO ) THEN * * H = I * TAU = ZERO ELSE * * general case * BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) KNT = 0 IF( ABS( BETA ).LT.SAFMIN ) THEN * * XNORM, BETA may be inaccurate; scale X and recompute them * RSAFMN = ONE / SAFMIN 10 CONTINUE KNT = KNT + 1 CALL DSCAL( N-1, RSAFMN, X, INCX ) BETA = BETA*RSAFMN ALPHA = ALPHA*RSAFMN IF( (ABS( BETA ).LT.SAFMIN) .AND. (KNT .LT. 20) ) $ GO TO 10 * * New BETA is at most 1, at least SAFMIN * XNORM = DNRM2( N-1, X, INCX ) BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) END IF TAU = ( BETA-ALPHA ) / BETA CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) * * If ALPHA is subnormal, it may lose relative accuracy * DO 20 J = 1, KNT BETA = BETA*SAFMIN 20 CONTINUE ALPHA = BETA END IF * RETURN * * End of DLARFG * END *> \brief \b DLARFGP generates an elementary reflector (Householder matrix) with non-negative beta. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARFGP + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARFGP( N, ALPHA, X, INCX, TAU ) * * .. Scalar Arguments .. * INTEGER INCX, N * DOUBLE PRECISION ALPHA, TAU * .. * .. Array Arguments .. * DOUBLE PRECISION X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLARFGP generates a real elementary reflector H of order n, such *> that *> *> H * ( alpha ) = ( beta ), H**T * H = I. *> ( x ) ( 0 ) *> *> where alpha and beta are scalars, beta is non-negative, and x is *> an (n-1)-element real vector. H is represented in the form *> *> H = I - tau * ( 1 ) * ( 1 v**T ) , *> ( v ) *> *> where tau is a real scalar and v is a real (n-1)-element *> vector. *> *> If the elements of x are all zero, then tau = 0 and H is taken to be *> the unit matrix. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the elementary reflector. *> \endverbatim *> *> \param[in,out] ALPHA *> \verbatim *> ALPHA is DOUBLE PRECISION *> On entry, the value alpha. *> On exit, it is overwritten with the value beta. *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension *> (1+(N-2)*abs(INCX)) *> On entry, the vector x. *> On exit, it is overwritten with the vector v. *> \endverbatim *> *> \param[in] INCX *> \verbatim *> INCX is INTEGER *> The increment between elements of X. INCX > 0. *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION *> The value tau. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date November 2017 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLARFGP( N, ALPHA, X, INCX, TAU ) * * -- LAPACK auxiliary routine (version 3.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. Scalar Arguments .. INTEGER INCX, N DOUBLE PRECISION ALPHA, TAU * .. * .. Array Arguments .. DOUBLE PRECISION X( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION TWO, ONE, ZERO PARAMETER ( TWO = 2.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER J, KNT DOUBLE PRECISION BETA, BIGNUM, SAVEALPHA, SMLNUM, XNORM * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 EXTERNAL DLAMCH, DLAPY2, DNRM2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, SIGN * .. * .. External Subroutines .. EXTERNAL DSCAL * .. * .. Executable Statements .. * IF( N.LE.0 ) THEN TAU = ZERO RETURN END IF * XNORM = DNRM2( N-1, X, INCX ) * IF( XNORM.EQ.ZERO ) THEN * * H = [+/-1, 0; I], sign chosen so ALPHA >= 0 * IF( ALPHA.GE.ZERO ) THEN * When TAU.eq.ZERO, the vector is special-cased to be * all zeros in the application routines. We do not need * to clear it. TAU = ZERO ELSE * However, the application routines rely on explicit * zero checks when TAU.ne.ZERO, and we must clear X. TAU = TWO DO J = 1, N-1 X( 1 + (J-1)*INCX ) = 0 END DO ALPHA = -ALPHA END IF ELSE * * general case * BETA = SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'E' ) KNT = 0 IF( ABS( BETA ).LT.SMLNUM ) THEN * * XNORM, BETA may be inaccurate; scale X and recompute them * BIGNUM = ONE / SMLNUM 10 CONTINUE KNT = KNT + 1 CALL DSCAL( N-1, BIGNUM, X, INCX ) BETA = BETA*BIGNUM ALPHA = ALPHA*BIGNUM IF( (ABS( BETA ).LT.SMLNUM) .AND. (KNT .LT. 20) ) $ GO TO 10 * * New BETA is at most 1, at least SMLNUM * XNORM = DNRM2( N-1, X, INCX ) BETA = SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) END IF SAVEALPHA = ALPHA ALPHA = ALPHA + BETA IF( BETA.LT.ZERO ) THEN BETA = -BETA TAU = -ALPHA / BETA ELSE ALPHA = XNORM * (XNORM/ALPHA) TAU = ALPHA / BETA ALPHA = -ALPHA END IF * IF ( ABS(TAU).LE.SMLNUM ) THEN * * In the case where the computed TAU ends up being a denormalized number, * it loses relative accuracy. This is a BIG problem. Solution: flush TAU * to ZERO. This explains the next IF statement. * * (Bug report provided by Pat Quillen from MathWorks on Jul 29, 2009.) * (Thanks Pat. Thanks MathWorks.) * IF( SAVEALPHA.GE.ZERO ) THEN TAU = ZERO ELSE TAU = TWO DO J = 1, N-1 X( 1 + (J-1)*INCX ) = 0 END DO BETA = -SAVEALPHA END IF * ELSE * * This is the general case. * CALL DSCAL( N-1, ONE / ALPHA, X, INCX ) * END IF * * If BETA is subnormal, it may lose relative accuracy * DO 20 J = 1, KNT BETA = BETA*SMLNUM 20 CONTINUE ALPHA = BETA END IF * RETURN * * End of DLARFGP * END *> \brief \b DLARFT forms the triangular factor T of a block reflector H = I - vtvH * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARFT + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * * .. Scalar Arguments .. * CHARACTER DIRECT, STOREV * INTEGER K, LDT, LDV, N * .. * .. Array Arguments .. * DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLARFT forms the triangular factor T of a real block reflector H *> of order n, which is defined as a product of k elementary reflectors. *> *> If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; *> *> If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. *> *> If STOREV = 'C', the vector which defines the elementary reflector *> H(i) is stored in the i-th column of the array V, and *> *> H = I - V * T * V**T *> *> 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 * T * V *> \endverbatim * * Arguments: * ========== * *> \param[in] DIRECT *> \verbatim *> DIRECT is CHARACTER*1 *> Specifies the order in which the elementary reflectors are *> multiplied to form the block reflector: *> = 'F': H = H(1) H(2) . . . H(k) (Forward) *> = 'B': H = H(k) . . . H(2) H(1) (Backward) *> \endverbatim *> *> \param[in] STOREV *> \verbatim *> STOREV is CHARACTER*1 *> Specifies how the vectors which define the elementary *> reflectors are stored (see also Further Details): *> = 'C': columnwise *> = 'R': rowwise *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the block reflector H. N >= 0. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The order of the triangular factor T (= the number of *> elementary reflectors). K >= 1. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is DOUBLE PRECISION array, dimension *> (LDV,K) if STOREV = 'C' *> (LDV,N) if STOREV = 'R' *> The matrix V. See further details. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the array V. *> If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i). *> \endverbatim *> *> \param[out] T *> \verbatim *> T is 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. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= K. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> 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. *> *> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': *> *> V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) *> ( v1 1 ) ( 1 v2 v2 v2 ) *> ( v1 v2 1 ) ( 1 v3 v3 ) *> ( v1 v2 v3 ) *> ( v1 v2 v3 ) *> *> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': *> *> V = ( v1 v2 v3 ) V = ( v1 v1 1 ) *> ( v1 v2 v3 ) ( v2 v2 v2 1 ) *> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) *> ( 1 v3 ) *> ( 1 ) *> \endverbatim *> * ===================================================================== SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER DIRECT, STOREV INTEGER K, LDT, LDV, N * .. * .. Array Arguments .. DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J, PREVLASTV, LASTV * .. * .. External Subroutines .. EXTERNAL DGEMV, DTRMV * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Executable Statements .. * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( LSAME( DIRECT, 'F' ) ) THEN PREVLASTV = N DO I = 1, K PREVLASTV = MAX( I, PREVLASTV ) IF( TAU( I ).EQ.ZERO ) THEN * * H(i) = I * DO J = 1, I T( J, I ) = ZERO END DO ELSE * * general case * IF( LSAME( STOREV, 'C' ) ) THEN * Skip any trailing zeros. DO LASTV = N, I+1, -1 IF( V( LASTV, I ).NE.ZERO ) EXIT END DO DO J = 1, I-1 T( J, I ) = -TAU( I ) * V( I , J ) END DO J = MIN( LASTV, PREVLASTV ) * * T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i) * CALL DGEMV( 'Transpose', J-I, I-1, -TAU( I ), $ V( I+1, 1 ), LDV, V( I+1, I ), 1, ONE, $ T( 1, I ), 1 ) ELSE * Skip any trailing zeros. DO LASTV = N, I+1, -1 IF( V( I, LASTV ).NE.ZERO ) EXIT END DO DO J = 1, I-1 T( J, I ) = -TAU( I ) * V( J , I ) END DO J = MIN( LASTV, PREVLASTV ) * * T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T * CALL DGEMV( 'No transpose', I-1, J-I, -TAU( I ), $ V( 1, I+1 ), LDV, V( I, I+1 ), LDV, ONE, $ T( 1, I ), 1 ) END IF * * T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) * CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, $ LDT, T( 1, I ), 1 ) T( I, I ) = TAU( I ) IF( I.GT.1 ) THEN PREVLASTV = MAX( PREVLASTV, LASTV ) ELSE PREVLASTV = LASTV END IF END IF END DO ELSE PREVLASTV = 1 DO I = K, 1, -1 IF( TAU( I ).EQ.ZERO ) THEN * * H(i) = I * DO J = I, K T( J, I ) = ZERO END DO ELSE * * general case * IF( I.LT.K ) THEN IF( LSAME( STOREV, 'C' ) ) THEN * Skip any leading zeros. DO LASTV = 1, I-1 IF( V( LASTV, I ).NE.ZERO ) EXIT END DO DO J = I+1, K T( J, I ) = -TAU( I ) * V( N-K+I , J ) END DO J = MAX( LASTV, PREVLASTV ) * * T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**T * V(j:n-k+i,i) * CALL DGEMV( 'Transpose', N-K+I-J, K-I, -TAU( I ), $ V( J, I+1 ), LDV, V( J, I ), 1, ONE, $ T( I+1, I ), 1 ) ELSE * Skip any leading zeros. DO LASTV = 1, I-1 IF( V( I, LASTV ).NE.ZERO ) EXIT END DO DO J = I+1, K T( J, I ) = -TAU( I ) * V( J, N-K+I ) END DO J = MAX( LASTV, PREVLASTV ) * * T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**T * CALL DGEMV( 'No transpose', K-I, N-K+I-J, $ -TAU( I ), V( I+1, J ), LDV, V( I, J ), LDV, $ ONE, T( I+1, I ), 1 ) END IF * * T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) * CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) IF( I.GT.1 ) THEN PREVLASTV = MIN( PREVLASTV, LASTV ) ELSE PREVLASTV = LASTV END IF END IF T( I, I ) = TAU( I ) END IF END DO END IF RETURN * * End of DLARFT * END *> \brief \b DLARFX applies an elementary reflector to a general rectangular matrix, with loop unrolling when the reflector has order ≤ 10. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARFX + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) * * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER LDC, M, N * DOUBLE PRECISION TAU * .. * .. Array Arguments .. * DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLARFX 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**T *> *> where tau is a real scalar and v is a real vector. *> *> If tau = 0, then H is taken to be the unit matrix *> *> This version uses inline code if H has order < 11. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': form H * C *> = 'R': form C * H *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is DOUBLE PRECISION array, dimension (M) if SIDE = 'L' *> or (N) if SIDE = 'R' *> The vector v in the representation of H. *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION *> The value tau in the representation of H. *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is 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'. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDA >= (1,M). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension *> (N) if SIDE = 'L' *> or (M) if SIDE = 'R' *> WORK is not referenced if H has order < 11. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER SIDE INTEGER LDC, M, N DOUBLE PRECISION TAU * .. * .. Array Arguments .. DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER J DOUBLE PRECISION SUM, T1, T10, T2, T3, T4, T5, T6, T7, T8, T9, $ V1, V10, V2, V3, V4, V5, V6, V7, V8, V9 * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLARF * .. * .. Executable Statements .. * IF( TAU.EQ.ZERO ) $ RETURN IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C, where H has order m. * GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, $ 170, 190 )M * * Code for general M * CALL DLARF( SIDE, M, N, V, 1, TAU, C, LDC, WORK ) GO TO 410 10 CONTINUE * * Special code for 1 x 1 Householder * T1 = ONE - TAU*V( 1 )*V( 1 ) DO 20 J = 1, N C( 1, J ) = T1*C( 1, J ) 20 CONTINUE GO TO 410 30 CONTINUE * * Special code for 2 x 2 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 DO 40 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 40 CONTINUE GO TO 410 50 CONTINUE * * Special code for 3 x 3 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 DO 60 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 60 CONTINUE GO TO 410 70 CONTINUE * * Special code for 4 x 4 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 DO 80 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 80 CONTINUE GO TO 410 90 CONTINUE * * Special code for 5 x 5 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 DO 100 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 100 CONTINUE GO TO 410 110 CONTINUE * * Special code for 6 x 6 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 DO 120 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 120 CONTINUE GO TO 410 130 CONTINUE * * Special code for 7 x 7 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 DO 140 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 140 CONTINUE GO TO 410 150 CONTINUE * * Special code for 8 x 8 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 DO 160 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 160 CONTINUE GO TO 410 170 CONTINUE * * Special code for 9 x 9 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 V9 = V( 9 ) T9 = TAU*V9 DO 180 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 C( 9, J ) = C( 9, J ) - SUM*T9 180 CONTINUE GO TO 410 190 CONTINUE * * Special code for 10 x 10 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 V9 = V( 9 ) T9 = TAU*V9 V10 = V( 10 ) T10 = TAU*V10 DO 200 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) + $ V10*C( 10, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 C( 9, J ) = C( 9, J ) - SUM*T9 C( 10, J ) = C( 10, J ) - SUM*T10 200 CONTINUE GO TO 410 ELSE * * Form C * H, where H has order n. * GO TO ( 210, 230, 250, 270, 290, 310, 330, 350, $ 370, 390 )N * * Code for general N * CALL DLARF( SIDE, M, N, V, 1, TAU, C, LDC, WORK ) GO TO 410 210 CONTINUE * * Special code for 1 x 1 Householder * T1 = ONE - TAU*V( 1 )*V( 1 ) DO 220 J = 1, M C( J, 1 ) = T1*C( J, 1 ) 220 CONTINUE GO TO 410 230 CONTINUE * * Special code for 2 x 2 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 DO 240 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 240 CONTINUE GO TO 410 250 CONTINUE * * Special code for 3 x 3 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 DO 260 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 260 CONTINUE GO TO 410 270 CONTINUE * * Special code for 4 x 4 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 DO 280 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 280 CONTINUE GO TO 410 290 CONTINUE * * Special code for 5 x 5 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 DO 300 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 300 CONTINUE GO TO 410 310 CONTINUE * * Special code for 6 x 6 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 DO 320 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 320 CONTINUE GO TO 410 330 CONTINUE * * Special code for 7 x 7 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 DO 340 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 340 CONTINUE GO TO 410 350 CONTINUE * * Special code for 8 x 8 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 DO 360 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 360 CONTINUE GO TO 410 370 CONTINUE * * Special code for 9 x 9 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 V9 = V( 9 ) T9 = TAU*V9 DO 380 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 C( J, 9 ) = C( J, 9 ) - SUM*T9 380 CONTINUE GO TO 410 390 CONTINUE * * Special code for 10 x 10 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 V9 = V( 9 ) T9 = TAU*V9 V10 = V( 10 ) T10 = TAU*V10 DO 400 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) + $ V10*C( J, 10 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 C( J, 9 ) = C( J, 9 ) - SUM*T9 C( J, 10 ) = C( J, 10 ) - SUM*T10 400 CONTINUE GO TO 410 END IF 410 CONTINUE RETURN * * End of DLARFX * END *> \brief \b DLARGV generates a vector of plane rotations with real cosines and real sines. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARGV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARGV( N, X, INCX, Y, INCY, C, INCC ) * * .. Scalar Arguments .. * INTEGER INCC, INCX, INCY, N * .. * .. Array Arguments .. * DOUBLE PRECISION C( * ), X( * ), Y( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLARGV generates a vector of real plane rotations, determined by *> elements of the real vectors x and y. For i = 1,2,...,n *> *> ( c(i) s(i) ) ( x(i) ) = ( a(i) ) *> ( -s(i) c(i) ) ( y(i) ) = ( 0 ) *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The number of plane rotations to be generated. *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is DOUBLE PRECISION array, *> dimension (1+(N-1)*INCX) *> On entry, the vector x. *> On exit, x(i) is overwritten by a(i), for i = 1,...,n. *> \endverbatim *> *> \param[in] INCX *> \verbatim *> INCX is INTEGER *> The increment between elements of X. INCX > 0. *> \endverbatim *> *> \param[in,out] Y *> \verbatim *> Y is DOUBLE PRECISION array, *> dimension (1+(N-1)*INCY) *> On entry, the vector y. *> On exit, the sines of the plane rotations. *> \endverbatim *> *> \param[in] INCY *> \verbatim *> INCY is INTEGER *> The increment between elements of Y. INCY > 0. *> \endverbatim *> *> \param[out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (1+(N-1)*INCC) *> The cosines of the plane rotations. *> \endverbatim *> *> \param[in] INCC *> \verbatim *> INCC is INTEGER *> The increment between elements of C. INCC > 0. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLARGV( N, X, INCX, Y, INCY, C, INCC ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INCC, INCX, INCY, N * .. * .. Array Arguments .. DOUBLE PRECISION C( * ), X( * ), Y( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, IC, IX, IY DOUBLE PRECISION F, G, T, TT * .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT * .. * .. Executable Statements .. * IX = 1 IY = 1 IC = 1 DO 10 I = 1, N F = X( IX ) G = Y( IY ) IF( G.EQ.ZERO ) THEN C( IC ) = ONE ELSE IF( F.EQ.ZERO ) THEN C( IC ) = ZERO Y( IY ) = ONE X( IX ) = G ELSE IF( ABS( F ).GT.ABS( G ) ) THEN T = G / F TT = SQRT( ONE+T*T ) C( IC ) = ONE / TT Y( IY ) = T*C( IC ) X( IX ) = F*TT ELSE T = F / G TT = SQRT( ONE+T*T ) Y( IY ) = ONE / TT C( IC ) = T*Y( IY ) X( IX ) = G*TT END IF IC = IC + INCC IY = IY + INCY IX = IX + INCX 10 CONTINUE RETURN * * End of DLARGV * END *> \brief \b DLARNV returns a vector of random numbers from a uniform or normal distribution. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARNV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARNV( IDIST, ISEED, N, X ) * * .. Scalar Arguments .. * INTEGER IDIST, N * .. * .. Array Arguments .. * INTEGER ISEED( 4 ) * DOUBLE PRECISION X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLARNV returns a vector of n random real numbers from a uniform or *> normal distribution. *> \endverbatim * * Arguments: * ========== * *> \param[in] IDIST *> \verbatim *> IDIST is INTEGER *> Specifies the distribution of the random numbers: *> = 1: uniform (0,1) *> = 2: uniform (-1,1) *> = 3: normal (0,1) *> \endverbatim *> *> \param[in,out] ISEED *> \verbatim *> ISEED is INTEGER array, dimension (4) *> On entry, the seed of the random number generator; the array *> elements must be between 0 and 4095, and ISEED(4) must be *> odd. *> On exit, the seed is updated. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of random numbers to be generated. *> \endverbatim *> *> \param[out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (N) *> The generated random numbers. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> This routine calls the auxiliary routine DLARUV to generate random *> real numbers from a uniform (0,1) distribution, in batches of up to *> 128 using vectorisable code. The Box-Muller method is used to *> transform numbers from a uniform to a normal distribution. *> \endverbatim *> * ===================================================================== SUBROUTINE DLARNV( IDIST, ISEED, N, X ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER IDIST, N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) DOUBLE PRECISION X( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, TWO PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 ) INTEGER LV PARAMETER ( LV = 128 ) DOUBLE PRECISION TWOPI PARAMETER ( TWOPI = 6.2831853071795864769252867663D+0 ) * .. * .. Local Scalars .. INTEGER I, IL, IL2, IV * .. * .. Local Arrays .. DOUBLE PRECISION U( LV ) * .. * .. Intrinsic Functions .. INTRINSIC COS, LOG, MIN, SQRT * .. * .. External Subroutines .. EXTERNAL DLARUV * .. * .. Executable Statements .. * DO 40 IV = 1, N, LV / 2 IL = MIN( LV / 2, N-IV+1 ) IF( IDIST.EQ.3 ) THEN IL2 = 2*IL ELSE IL2 = IL END IF * * Call DLARUV to generate IL2 numbers from a uniform (0,1) * distribution (IL2 <= LV) * CALL DLARUV( ISEED, IL2, U ) * IF( IDIST.EQ.1 ) THEN * * Copy generated numbers * DO 10 I = 1, IL X( IV+I-1 ) = U( I ) 10 CONTINUE ELSE IF( IDIST.EQ.2 ) THEN * * Convert generated numbers to uniform (-1,1) distribution * DO 20 I = 1, IL X( IV+I-1 ) = TWO*U( I ) - ONE 20 CONTINUE ELSE IF( IDIST.EQ.3 ) THEN * * Convert generated numbers to normal (0,1) distribution * DO 30 I = 1, IL X( IV+I-1 ) = SQRT( -TWO*LOG( U( 2*I-1 ) ) )* $ COS( TWOPI*U( 2*I ) ) 30 CONTINUE END IF 40 CONTINUE RETURN * * End of DLARNV * END *> \brief \b DLARRA computes the splitting points with the specified threshold. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARRA + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARRA( N, D, E, E2, SPLTOL, TNRM, * NSPLIT, ISPLIT, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, N, NSPLIT * DOUBLE PRECISION SPLTOL, TNRM * .. * .. Array Arguments .. * INTEGER ISPLIT( * ) * DOUBLE PRECISION D( * ), E( * ), E2( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> Compute the splitting points with threshold SPLTOL. *> DLARRA sets any "small" off-diagonal elements to zero. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix. N > 0. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> On entry, the N diagonal elements of the tridiagonal *> matrix T. *> \endverbatim *> *> \param[in,out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N) *> On entry, the first (N-1) entries contain the subdiagonal *> elements of the tridiagonal matrix T; E(N) need not be set. *> On exit, the entries E( ISPLIT( I ) ), 1 <= I <= NSPLIT, *> are set to zero, the other entries of E are untouched. *> \endverbatim *> *> \param[in,out] E2 *> \verbatim *> E2 is DOUBLE PRECISION array, dimension (N) *> On entry, the first (N-1) entries contain the SQUARES of the *> subdiagonal elements of the tridiagonal matrix T; *> E2(N) need not be set. *> On exit, the entries E2( ISPLIT( I ) ), *> 1 <= I <= NSPLIT, have been set to zero *> \endverbatim *> *> \param[in] SPLTOL *> \verbatim *> SPLTOL is DOUBLE PRECISION *> The threshold for splitting. Two criteria can be used: *> SPLTOL<0 : criterion based on absolute off-diagonal value *> SPLTOL>0 : criterion that preserves relative accuracy *> \endverbatim *> *> \param[in] TNRM *> \verbatim *> TNRM is DOUBLE PRECISION *> The norm of the matrix. *> \endverbatim *> *> \param[out] NSPLIT *> \verbatim *> NSPLIT is INTEGER *> The number of blocks T splits into. 1 <= NSPLIT <= N. *> \endverbatim *> *> \param[out] ISPLIT *> \verbatim *> ISPLIT is INTEGER array, dimension (N) *> The splitting points, at which T breaks up into blocks. *> The first block consists of rows/columns 1 to ISPLIT(1), *> the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), *> etc., and the NSPLIT-th consists of rows/columns *> ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup OTHERauxiliary * *> \par Contributors: * ================== *> *> Beresford Parlett, University of California, Berkeley, USA \n *> Jim Demmel, University of California, Berkeley, USA \n *> Inderjit Dhillon, University of Texas, Austin, USA \n *> Osni Marques, LBNL/NERSC, USA \n *> Christof Voemel, University of California, Berkeley, USA * * ===================================================================== SUBROUTINE DLARRA( N, D, E, E2, SPLTOL, TNRM, $ NSPLIT, ISPLIT, INFO ) * * -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. INTEGER INFO, N, NSPLIT DOUBLE PRECISION SPLTOL, TNRM * .. * .. Array Arguments .. INTEGER ISPLIT( * ) DOUBLE PRECISION D( * ), E( * ), E2( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) * .. * .. Local Scalars .. INTEGER I DOUBLE PRECISION EABS, TMP1 * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.LE.0 ) THEN RETURN END IF * * Compute splitting points NSPLIT = 1 IF(SPLTOL.LT.ZERO) THEN * Criterion based on absolute off-diagonal value TMP1 = ABS(SPLTOL)* TNRM DO 9 I = 1, N-1 EABS = ABS( E(I) ) IF( EABS .LE. TMP1) THEN E(I) = ZERO E2(I) = ZERO ISPLIT( NSPLIT ) = I NSPLIT = NSPLIT + 1 END IF 9 CONTINUE ELSE * Criterion that guarantees relative accuracy DO 10 I = 1, N-1 EABS = ABS( E(I) ) IF( EABS .LE. SPLTOL * SQRT(ABS(D(I)))*SQRT(ABS(D(I+1))) ) $ THEN E(I) = ZERO E2(I) = ZERO ISPLIT( NSPLIT ) = I NSPLIT = NSPLIT + 1 END IF 10 CONTINUE ENDIF ISPLIT( NSPLIT ) = N RETURN * * End of DLARRA * END *> \brief \b DLARRB provides limited bisection to locate eigenvalues for more accuracy. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARRB + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARRB( N, D, LLD, IFIRST, ILAST, RTOL1, * RTOL2, OFFSET, W, WGAP, WERR, WORK, IWORK, * PIVMIN, SPDIAM, TWIST, INFO ) * * .. Scalar Arguments .. * INTEGER IFIRST, ILAST, INFO, N, OFFSET, TWIST * DOUBLE PRECISION PIVMIN, RTOL1, RTOL2, SPDIAM * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION D( * ), LLD( * ), W( * ), * $ WERR( * ), WGAP( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> Given the relatively robust representation(RRR) L D L^T, DLARRB *> does "limited" bisection to refine the eigenvalues of L D L^T, *> W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial *> guesses for these eigenvalues are input in W, the corresponding estimate *> of the error in these guesses and their gaps are input in WERR *> and WGAP, respectively. During bisection, intervals *> [left, right] are maintained by storing their mid-points and *> semi-widths in the arrays W and WERR respectively. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The N diagonal elements of the diagonal matrix D. *> \endverbatim *> *> \param[in] LLD *> \verbatim *> LLD is DOUBLE PRECISION array, dimension (N-1) *> The (N-1) elements L(i)*L(i)*D(i). *> \endverbatim *> *> \param[in] IFIRST *> \verbatim *> IFIRST is INTEGER *> The index of the first eigenvalue to be computed. *> \endverbatim *> *> \param[in] ILAST *> \verbatim *> ILAST is INTEGER *> The index of the last eigenvalue to be computed. *> \endverbatim *> *> \param[in] RTOL1 *> \verbatim *> RTOL1 is DOUBLE PRECISION *> \endverbatim *> *> \param[in] RTOL2 *> \verbatim *> RTOL2 is DOUBLE PRECISION *> Tolerance for the convergence of the bisection intervals. *> An interval [LEFT,RIGHT] has converged if *> RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) *> where GAP is the (estimated) distance to the nearest *> eigenvalue. *> \endverbatim *> *> \param[in] OFFSET *> \verbatim *> OFFSET is INTEGER *> Offset for the arrays W, WGAP and WERR, i.e., the IFIRST-OFFSET *> through ILAST-OFFSET elements of these arrays are to be used. *> \endverbatim *> *> \param[in,out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are *> estimates of the eigenvalues of L D L^T indexed IFIRST through *> ILAST. *> On output, these estimates are refined. *> \endverbatim *> *> \param[in,out] WGAP *> \verbatim *> WGAP is DOUBLE PRECISION array, dimension (N-1) *> On input, the (estimated) gaps between consecutive *> eigenvalues of L D L^T, i.e., WGAP(I-OFFSET) is the gap between *> eigenvalues I and I+1. Note that if IFIRST.EQ.ILAST *> then WGAP(IFIRST-OFFSET) must be set to ZERO. *> On output, these gaps are refined. *> \endverbatim *> *> \param[in,out] WERR *> \verbatim *> WERR is DOUBLE PRECISION array, dimension (N) *> On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are *> the errors in the estimates of the corresponding elements in W. *> On output, these errors are refined. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (2*N) *> Workspace. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (2*N) *> Workspace. *> \endverbatim *> *> \param[in] PIVMIN *> \verbatim *> PIVMIN is DOUBLE PRECISION *> The minimum pivot in the Sturm sequence. *> \endverbatim *> *> \param[in] SPDIAM *> \verbatim *> SPDIAM is DOUBLE PRECISION *> The spectral diameter of the matrix. *> \endverbatim *> *> \param[in] TWIST *> \verbatim *> TWIST is INTEGER *> The twist index for the twisted factorization that is used *> for the negcount. *> TWIST = N: Compute negcount from L D L^T - LAMBDA I = L+ D+ L+^T *> TWIST = 1: Compute negcount from L D L^T - LAMBDA I = U- D- U-^T *> TWIST = R: Compute negcount from L D L^T - LAMBDA I = N(r) D(r) N(r) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> Error flag. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup OTHERauxiliary * *> \par Contributors: * ================== *> *> Beresford Parlett, University of California, Berkeley, USA \n *> Jim Demmel, University of California, Berkeley, USA \n *> Inderjit Dhillon, University of Texas, Austin, USA \n *> Osni Marques, LBNL/NERSC, USA \n *> Christof Voemel, University of California, Berkeley, USA * * ===================================================================== SUBROUTINE DLARRB( N, D, LLD, IFIRST, ILAST, RTOL1, $ RTOL2, OFFSET, W, WGAP, WERR, WORK, IWORK, $ PIVMIN, SPDIAM, TWIST, INFO ) * * -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. INTEGER IFIRST, ILAST, INFO, N, OFFSET, TWIST DOUBLE PRECISION PIVMIN, RTOL1, RTOL2, SPDIAM * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION D( * ), LLD( * ), W( * ), $ WERR( * ), WGAP( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, TWO, HALF PARAMETER ( ZERO = 0.0D0, TWO = 2.0D0, $ HALF = 0.5D0 ) INTEGER MAXITR * .. * .. Local Scalars .. INTEGER I, I1, II, IP, ITER, K, NEGCNT, NEXT, NINT, $ OLNINT, PREV, R DOUBLE PRECISION BACK, CVRGD, GAP, LEFT, LGAP, MID, MNWDTH, $ RGAP, RIGHT, TMP, WIDTH * .. * .. External Functions .. INTEGER DLANEG EXTERNAL DLANEG * * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.LE.0 ) THEN RETURN END IF * MAXITR = INT( ( LOG( SPDIAM+PIVMIN )-LOG( PIVMIN ) ) / $ LOG( TWO ) ) + 2 MNWDTH = TWO * PIVMIN * R = TWIST IF((R.LT.1).OR.(R.GT.N)) R = N * * Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ]. * The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while * Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 ) * for an unconverged interval is set to the index of the next unconverged * interval, and is -1 or 0 for a converged interval. Thus a linked * list of unconverged intervals is set up. * I1 = IFIRST * The number of unconverged intervals NINT = 0 * The last unconverged interval found PREV = 0 RGAP = WGAP( I1-OFFSET ) DO 75 I = I1, ILAST K = 2*I II = I - OFFSET LEFT = W( II ) - WERR( II ) RIGHT = W( II ) + WERR( II ) LGAP = RGAP RGAP = WGAP( II ) GAP = MIN( LGAP, RGAP ) * Make sure that [LEFT,RIGHT] contains the desired eigenvalue * Compute negcount from dstqds facto L+D+L+^T = L D L^T - LEFT * * Do while( NEGCNT(LEFT).GT.I-1 ) * BACK = WERR( II ) 20 CONTINUE NEGCNT = DLANEG( N, D, LLD, LEFT, PIVMIN, R ) IF( NEGCNT.GT.I-1 ) THEN LEFT = LEFT - BACK BACK = TWO*BACK GO TO 20 END IF * * Do while( NEGCNT(RIGHT).LT.I ) * Compute negcount from dstqds facto L+D+L+^T = L D L^T - RIGHT * BACK = WERR( II ) 50 CONTINUE NEGCNT = DLANEG( N, D, LLD, RIGHT, PIVMIN, R ) IF( NEGCNT.LT.I ) THEN RIGHT = RIGHT + BACK BACK = TWO*BACK GO TO 50 END IF WIDTH = HALF*ABS( LEFT - RIGHT ) TMP = MAX( ABS( LEFT ), ABS( RIGHT ) ) CVRGD = MAX(RTOL1*GAP,RTOL2*TMP) IF( WIDTH.LE.CVRGD .OR. WIDTH.LE.MNWDTH ) THEN * This interval has already converged and does not need refinement. * (Note that the gaps might change through refining the * eigenvalues, however, they can only get bigger.) * Remove it from the list. IWORK( K-1 ) = -1 * Make sure that I1 always points to the first unconverged interval IF((I.EQ.I1).AND.(I.LT.ILAST)) I1 = I + 1 IF((PREV.GE.I1).AND.(I.LE.ILAST)) IWORK( 2*PREV-1 ) = I + 1 ELSE * unconverged interval found PREV = I NINT = NINT + 1 IWORK( K-1 ) = I + 1 IWORK( K ) = NEGCNT END IF WORK( K-1 ) = LEFT WORK( K ) = RIGHT 75 CONTINUE * * Do while( NINT.GT.0 ), i.e. there are still unconverged intervals * and while (ITER.LT.MAXITR) * ITER = 0 80 CONTINUE PREV = I1 - 1 I = I1 OLNINT = NINT DO 100 IP = 1, OLNINT K = 2*I II = I - OFFSET RGAP = WGAP( II ) LGAP = RGAP IF(II.GT.1) LGAP = WGAP( II-1 ) GAP = MIN( LGAP, RGAP ) NEXT = IWORK( K-1 ) LEFT = WORK( K-1 ) RIGHT = WORK( K ) MID = HALF*( LEFT + RIGHT ) * semiwidth of interval WIDTH = RIGHT - MID TMP = MAX( ABS( LEFT ), ABS( RIGHT ) ) CVRGD = MAX(RTOL1*GAP,RTOL2*TMP) IF( ( WIDTH.LE.CVRGD ) .OR. ( WIDTH.LE.MNWDTH ).OR. $ ( ITER.EQ.MAXITR ) )THEN * reduce number of unconverged intervals NINT = NINT - 1 * Mark interval as converged. IWORK( K-1 ) = 0 IF( I1.EQ.I ) THEN I1 = NEXT ELSE * Prev holds the last unconverged interval previously examined IF(PREV.GE.I1) IWORK( 2*PREV-1 ) = NEXT END IF I = NEXT GO TO 100 END IF PREV = I * * Perform one bisection step * NEGCNT = DLANEG( N, D, LLD, MID, PIVMIN, R ) IF( NEGCNT.LE.I-1 ) THEN WORK( K-1 ) = MID ELSE WORK( K ) = MID END IF I = NEXT 100 CONTINUE ITER = ITER + 1 * do another loop if there are still unconverged intervals * However, in the last iteration, all intervals are accepted * since this is the best we can do. IF( ( NINT.GT.0 ).AND.(ITER.LE.MAXITR) ) GO TO 80 * * * At this point, all the intervals have converged DO 110 I = IFIRST, ILAST K = 2*I II = I - OFFSET * All intervals marked by '0' have been refined. IF( IWORK( K-1 ).EQ.0 ) THEN W( II ) = HALF*( WORK( K-1 )+WORK( K ) ) WERR( II ) = WORK( K ) - W( II ) END IF 110 CONTINUE * DO 111 I = IFIRST+1, ILAST K = 2*I II = I - OFFSET WGAP( II-1 ) = MAX( ZERO, $ W(II) - WERR (II) - W( II-1 ) - WERR( II-1 )) 111 CONTINUE RETURN * * End of DLARRB * END *> \brief \b DLARRC computes the number of eigenvalues of the symmetric tridiagonal matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARRC + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARRC( JOBT, N, VL, VU, D, E, PIVMIN, * EIGCNT, LCNT, RCNT, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBT * INTEGER EIGCNT, INFO, LCNT, N, RCNT * DOUBLE PRECISION PIVMIN, VL, VU * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), E( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> Find the number of eigenvalues of the symmetric tridiagonal matrix T *> that are in the interval (VL,VU] if JOBT = 'T', and of L D L^T *> if JOBT = 'L'. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBT *> \verbatim *> JOBT is CHARACTER*1 *> = 'T': Compute Sturm count for matrix T. *> = 'L': Compute Sturm count for matrix L D L^T. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix. N > 0. *> \endverbatim *> *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION *> The lower bound for the eigenvalues. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION *> The upper bound for the eigenvalues. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> JOBT = 'T': The N diagonal elements of the tridiagonal matrix T. *> JOBT = 'L': The N diagonal elements of the diagonal matrix D. *> \endverbatim *> *> \param[in] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N) *> JOBT = 'T': The N-1 offdiagonal elements of the matrix T. *> JOBT = 'L': The N-1 offdiagonal elements of the matrix L. *> \endverbatim *> *> \param[in] PIVMIN *> \verbatim *> PIVMIN is DOUBLE PRECISION *> The minimum pivot in the Sturm sequence for T. *> \endverbatim *> *> \param[out] EIGCNT *> \verbatim *> EIGCNT is INTEGER *> The number of eigenvalues of the symmetric tridiagonal matrix T *> that are in the interval (VL,VU] *> \endverbatim *> *> \param[out] LCNT *> \verbatim *> LCNT is INTEGER *> \endverbatim *> *> \param[out] RCNT *> \verbatim *> RCNT is INTEGER *> The left and right negcounts of the interval. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup OTHERauxiliary * *> \par Contributors: * ================== *> *> Beresford Parlett, University of California, Berkeley, USA \n *> Jim Demmel, University of California, Berkeley, USA \n *> Inderjit Dhillon, University of Texas, Austin, USA \n *> Osni Marques, LBNL/NERSC, USA \n *> Christof Voemel, University of California, Berkeley, USA * * ===================================================================== SUBROUTINE DLARRC( JOBT, N, VL, VU, D, E, PIVMIN, $ EIGCNT, LCNT, RCNT, INFO ) * * -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. CHARACTER JOBT INTEGER EIGCNT, INFO, LCNT, N, RCNT DOUBLE PRECISION PIVMIN, VL, VU * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) * .. * .. Local Scalars .. INTEGER I LOGICAL MATT DOUBLE PRECISION LPIVOT, RPIVOT, SL, SU, TMP, TMP2 * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.LE.0 ) THEN RETURN END IF * LCNT = 0 RCNT = 0 EIGCNT = 0 MATT = LSAME( JOBT, 'T' ) IF (MATT) THEN * Sturm sequence count on T LPIVOT = D( 1 ) - VL RPIVOT = D( 1 ) - VU IF( LPIVOT.LE.ZERO ) THEN LCNT = LCNT + 1 ENDIF IF( RPIVOT.LE.ZERO ) THEN RCNT = RCNT + 1 ENDIF DO 10 I = 1, N-1 TMP = E(I)**2 LPIVOT = ( D( I+1 )-VL ) - TMP/LPIVOT RPIVOT = ( D( I+1 )-VU ) - TMP/RPIVOT IF( LPIVOT.LE.ZERO ) THEN LCNT = LCNT + 1 ENDIF IF( RPIVOT.LE.ZERO ) THEN RCNT = RCNT + 1 ENDIF 10 CONTINUE ELSE * Sturm sequence count on L D L^T SL = -VL SU = -VU DO 20 I = 1, N - 1 LPIVOT = D( I ) + SL RPIVOT = D( I ) + SU IF( LPIVOT.LE.ZERO ) THEN LCNT = LCNT + 1 ENDIF IF( RPIVOT.LE.ZERO ) THEN RCNT = RCNT + 1 ENDIF TMP = E(I) * D(I) * E(I) * TMP2 = TMP / LPIVOT IF( TMP2.EQ.ZERO ) THEN SL = TMP - VL ELSE SL = SL*TMP2 - VL END IF * TMP2 = TMP / RPIVOT IF( TMP2.EQ.ZERO ) THEN SU = TMP - VU ELSE SU = SU*TMP2 - VU END IF 20 CONTINUE LPIVOT = D( N ) + SL RPIVOT = D( N ) + SU IF( LPIVOT.LE.ZERO ) THEN LCNT = LCNT + 1 ENDIF IF( RPIVOT.LE.ZERO ) THEN RCNT = RCNT + 1 ENDIF ENDIF EIGCNT = RCNT - LCNT RETURN * * end of DLARRC * END *> \brief \b DLARRD computes the eigenvalues of a symmetric tridiagonal matrix to suitable accuracy. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARRD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARRD( RANGE, ORDER, N, VL, VU, IL, IU, GERS, * RELTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT, * M, W, WERR, WL, WU, IBLOCK, INDEXW, * WORK, IWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER ORDER, RANGE * INTEGER IL, INFO, IU, M, N, NSPLIT * DOUBLE PRECISION PIVMIN, RELTOL, VL, VU, WL, WU * .. * .. Array Arguments .. * INTEGER IBLOCK( * ), INDEXW( * ), * $ ISPLIT( * ), IWORK( * ) * DOUBLE PRECISION D( * ), E( * ), E2( * ), * $ GERS( * ), W( * ), WERR( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLARRD computes the eigenvalues of a symmetric tridiagonal *> matrix T to suitable accuracy. This is an auxiliary code to be *> called from DSTEMR. *> The user may ask for all eigenvalues, all eigenvalues *> in the half-open interval (VL, VU], or the IL-th through IU-th *> eigenvalues. *> *> To avoid overflow, the matrix must be scaled so that its *> largest element is no greater than overflow**(1/2) * underflow**(1/4) in absolute value, and for greatest *> accuracy, it should not be much smaller than that. *> *> See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal *> Matrix", Report CS41, Computer Science Dept., Stanford *> University, July 21, 1966. *> \endverbatim * * Arguments: * ========== * *> \param[in] RANGE *> \verbatim *> RANGE is CHARACTER*1 *> = 'A': ("All") all eigenvalues will be found. *> = 'V': ("Value") all eigenvalues in the half-open interval *> (VL, VU] will be found. *> = 'I': ("Index") the IL-th through IU-th eigenvalues (of the *> entire matrix) will be found. *> \endverbatim *> *> \param[in] ORDER *> \verbatim *> ORDER is CHARACTER*1 *> = 'B': ("By Block") the eigenvalues will be grouped by *> split-off block (see IBLOCK, ISPLIT) and *> ordered from smallest to largest within *> the block. *> = 'E': ("Entire matrix") *> the eigenvalues for the entire matrix *> will be ordered from smallest to *> largest. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the tridiagonal matrix T. N >= 0. *> \endverbatim *> *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION *> If RANGE='V', the lower bound of the interval to *> be searched for eigenvalues. Eigenvalues less than or equal *> to VL, or greater than VU, will not be returned. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION *> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. Eigenvalues less than or equal *> to VL, or greater than VU, will not be returned. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] IL *> \verbatim *> IL is INTEGER *> If RANGE='I', the index of the *> smallest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> If RANGE='I', the index of the *> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] GERS *> \verbatim *> GERS is DOUBLE PRECISION array, dimension (2*N) *> The N Gerschgorin intervals (the i-th Gerschgorin interval *> is (GERS(2*i-1), GERS(2*i)). *> \endverbatim *> *> \param[in] RELTOL *> \verbatim *> RELTOL is DOUBLE PRECISION *> The minimum relative width of an interval. When an interval *> is narrower than RELTOL times the larger (in *> magnitude) endpoint, then it is considered to be *> sufficiently small, i.e., converged. Note: this should *> always be at least radix*machine epsilon. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The n diagonal elements of the tridiagonal matrix T. *> \endverbatim *> *> \param[in] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N-1) *> The (n-1) off-diagonal elements of the tridiagonal matrix T. *> \endverbatim *> *> \param[in] E2 *> \verbatim *> E2 is DOUBLE PRECISION array, dimension (N-1) *> The (n-1) squared off-diagonal elements of the tridiagonal matrix T. *> \endverbatim *> *> \param[in] PIVMIN *> \verbatim *> PIVMIN is DOUBLE PRECISION *> The minimum pivot allowed in the Sturm sequence for T. *> \endverbatim *> *> \param[in] NSPLIT *> \verbatim *> NSPLIT is INTEGER *> The number of diagonal blocks in the matrix T. *> 1 <= NSPLIT <= N. *> \endverbatim *> *> \param[in] ISPLIT *> \verbatim *> ISPLIT is INTEGER array, dimension (N) *> The splitting points, at which T breaks up into submatrices. *> The first submatrix consists of rows/columns 1 to ISPLIT(1), *> the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), *> etc., and the NSPLIT-th consists of rows/columns *> ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. *> (Only the first NSPLIT elements will actually be used, but *> since the user cannot know a priori what value NSPLIT will *> have, N words must be reserved for ISPLIT.) *> \endverbatim *> *> \param[out] M *> \verbatim *> M is INTEGER *> The actual number of eigenvalues found. 0 <= M <= N. *> (See also the description of INFO=2,3.) *> \endverbatim *> *> \param[out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> On exit, the first M elements of W will contain the *> eigenvalue approximations. DLARRD computes an interval *> I_j = (a_j, b_j] that includes eigenvalue j. The eigenvalue *> approximation is given as the interval midpoint *> W(j)= ( a_j + b_j)/2. The corresponding error is bounded by *> WERR(j) = abs( a_j - b_j)/2 *> \endverbatim *> *> \param[out] WERR *> \verbatim *> WERR is DOUBLE PRECISION array, dimension (N) *> The error bound on the corresponding eigenvalue approximation *> in W. *> \endverbatim *> *> \param[out] WL *> \verbatim *> WL is DOUBLE PRECISION *> \endverbatim *> *> \param[out] WU *> \verbatim *> WU is DOUBLE PRECISION *> The interval (WL, WU] contains all the wanted eigenvalues. *> If RANGE='V', then WL=VL and WU=VU. *> If RANGE='A', then WL and WU are the global Gerschgorin bounds *> on the spectrum. *> If RANGE='I', then WL and WU are computed by DLAEBZ from the *> index range specified. *> \endverbatim *> *> \param[out] IBLOCK *> \verbatim *> IBLOCK is INTEGER array, dimension (N) *> At each row/column j where E(j) is zero or small, the *> matrix T is considered to split into a block diagonal *> matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which *> block (from 1 to the number of blocks) the eigenvalue W(i) *> belongs. (DLARRD may use the remaining N-M elements as *> workspace.) *> \endverbatim *> *> \param[out] INDEXW *> \verbatim *> INDEXW is INTEGER array, dimension (N) *> The indices of the eigenvalues within each block (submatrix); *> for example, INDEXW(i)= j and IBLOCK(i)=k imply that the *> i-th eigenvalue W(i) is the j-th eigenvalue in block k. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (4*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (3*N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: some or all of the eigenvalues failed to converge or *> were not computed: *> =1 or 3: Bisection failed to converge for some *> eigenvalues; these eigenvalues are flagged by a *> negative block number. The effect is that the *> eigenvalues may not be as accurate as the *> absolute and relative tolerances. This is *> generally caused by unexpectedly inaccurate *> arithmetic. *> =2 or 3: RANGE='I' only: Not all of the eigenvalues *> IL:IU were found. *> Effect: M < IU+1-IL *> Cause: non-monotonic arithmetic, causing the *> Sturm sequence to be non-monotonic. *> Cure: recalculate, using RANGE='A', and pick *> out eigenvalues IL:IU. In some cases, *> increasing the PARAMETER "FUDGE" may *> make things work. *> = 4: RANGE='I', and the Gershgorin interval *> initially used was too small. No eigenvalues *> were computed. *> Probable cause: your machine has sloppy *> floating-point arithmetic. *> Cure: Increase the PARAMETER "FUDGE", *> recompile, and try again. *> \endverbatim * *> \par Internal Parameters: * ========================= *> *> \verbatim *> FUDGE DOUBLE PRECISION, default = 2 *> A "fudge factor" to widen the Gershgorin intervals. Ideally, *> a value of 1 should work, but on machines with sloppy *> arithmetic, this needs to be larger. The default for *> publicly released versions should be large enough to handle *> the worst machine around. Note that this has no effect *> on accuracy of the solution. *> \endverbatim *> *> \par Contributors: * ================== *> *> W. Kahan, University of California, Berkeley, USA \n *> Beresford Parlett, University of California, Berkeley, USA \n *> Jim Demmel, University of California, Berkeley, USA \n *> Inderjit Dhillon, University of Texas, Austin, USA \n *> Osni Marques, LBNL/NERSC, USA \n *> Christof Voemel, University of California, Berkeley, USA \n * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLARRD( RANGE, ORDER, N, VL, VU, IL, IU, GERS, $ RELTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT, $ M, W, WERR, WL, WU, IBLOCK, INDEXW, $ WORK, IWORK, INFO ) * * -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. CHARACTER ORDER, RANGE INTEGER IL, INFO, IU, M, N, NSPLIT DOUBLE PRECISION PIVMIN, RELTOL, VL, VU, WL, WU * .. * .. Array Arguments .. INTEGER IBLOCK( * ), INDEXW( * ), $ ISPLIT( * ), IWORK( * ) DOUBLE PRECISION D( * ), E( * ), E2( * ), $ GERS( * ), W( * ), WERR( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, HALF, FUDGE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, $ TWO = 2.0D0, HALF = ONE/TWO, $ FUDGE = TWO ) INTEGER ALLRNG, VALRNG, INDRNG PARAMETER ( ALLRNG = 1, VALRNG = 2, INDRNG = 3 ) * .. * .. Local Scalars .. LOGICAL NCNVRG, TOOFEW INTEGER I, IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO, $ IM, IN, IOFF, IOUT, IRANGE, ITMAX, ITMP1, $ ITMP2, IW, IWOFF, J, JBLK, JDISC, JE, JEE, NB, $ NWL, NWU DOUBLE PRECISION ATOLI, EPS, GL, GU, RTOLI, TMP1, TMP2, $ TNORM, UFLOW, WKILL, WLU, WUL * .. * .. Local Arrays .. INTEGER IDUMMA( 1 ) * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH EXTERNAL LSAME, ILAENV, DLAMCH * .. * .. External Subroutines .. EXTERNAL DLAEBZ * .. * .. Intrinsic Functions .. INTRINSIC ABS, INT, LOG, MAX, MIN * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.LE.0 ) THEN RETURN END IF * * Decode RANGE * IF( LSAME( RANGE, 'A' ) ) THEN IRANGE = ALLRNG ELSE IF( LSAME( RANGE, 'V' ) ) THEN IRANGE = VALRNG ELSE IF( LSAME( RANGE, 'I' ) ) THEN IRANGE = INDRNG ELSE IRANGE = 0 END IF * * Check for Errors * IF( IRANGE.LE.0 ) THEN INFO = -1 ELSE IF( .NOT.(LSAME(ORDER,'B').OR.LSAME(ORDER,'E')) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( IRANGE.EQ.VALRNG ) THEN IF( VL.GE.VU ) $ INFO = -5 ELSE IF( IRANGE.EQ.INDRNG .AND. $ ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) ) THEN INFO = -6 ELSE IF( IRANGE.EQ.INDRNG .AND. $ ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) THEN INFO = -7 END IF * IF( INFO.NE.0 ) THEN RETURN END IF * Initialize error flags INFO = 0 NCNVRG = .FALSE. TOOFEW = .FALSE. * Quick return if possible M = 0 IF( N.EQ.0 ) RETURN * Simplification: IF( IRANGE.EQ.INDRNG .AND. IL.EQ.1 .AND. IU.EQ.N ) IRANGE = 1 * Get machine constants EPS = DLAMCH( 'P' ) UFLOW = DLAMCH( 'U' ) * Special Case when N=1 * Treat case of 1x1 matrix for quick return IF( N.EQ.1 ) THEN IF( (IRANGE.EQ.ALLRNG).OR. $ ((IRANGE.EQ.VALRNG).AND.(D(1).GT.VL).AND.(D(1).LE.VU)).OR. $ ((IRANGE.EQ.INDRNG).AND.(IL.EQ.1).AND.(IU.EQ.1)) ) THEN M = 1 W(1) = D(1) * The computation error of the eigenvalue is zero WERR(1) = ZERO IBLOCK( 1 ) = 1 INDEXW( 1 ) = 1 ENDIF RETURN END IF * NB is the minimum vector length for vector bisection, or 0 * if only scalar is to be done. NB = ILAENV( 1, 'DSTEBZ', ' ', N, -1, -1, -1 ) IF( NB.LE.1 ) NB = 0 * Find global spectral radius GL = D(1) GU = D(1) DO 5 I = 1,N GL = MIN( GL, GERS( 2*I - 1)) GU = MAX( GU, GERS(2*I) ) 5 CONTINUE * Compute global Gerschgorin bounds and spectral diameter TNORM = MAX( ABS( GL ), ABS( GU ) ) GL = GL - FUDGE*TNORM*EPS*N - FUDGE*TWO*PIVMIN GU = GU + FUDGE*TNORM*EPS*N + FUDGE*TWO*PIVMIN * [JAN/28/2009] remove the line below since SPDIAM variable not use * SPDIAM = GU - GL * Input arguments for DLAEBZ: * The relative tolerance. An interval (a,b] lies within * "relative tolerance" if b-a < RELTOL*max(|a|,|b|), RTOLI = RELTOL * Set the absolute tolerance for interval convergence to zero to force * interval convergence based on relative size of the interval. * This is dangerous because intervals might not converge when RELTOL is * small. But at least a very small number should be selected so that for * strongly graded matrices, the code can get relatively accurate * eigenvalues. ATOLI = FUDGE*TWO*UFLOW + FUDGE*TWO*PIVMIN IF( IRANGE.EQ.INDRNG ) THEN * RANGE='I': Compute an interval containing eigenvalues * IL through IU. The initial interval [GL,GU] from the global * Gerschgorin bounds GL and GU is refined by DLAEBZ. ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) / $ LOG( TWO ) ) + 2 WORK( N+1 ) = GL WORK( N+2 ) = GL WORK( N+3 ) = GU WORK( N+4 ) = GU WORK( N+5 ) = GL WORK( N+6 ) = GU IWORK( 1 ) = -1 IWORK( 2 ) = -1 IWORK( 3 ) = N + 1 IWORK( 4 ) = N + 1 IWORK( 5 ) = IL - 1 IWORK( 6 ) = IU * CALL DLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN, $ D, E, E2, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT, $ IWORK, W, IBLOCK, IINFO ) IF( IINFO .NE. 0 ) THEN INFO = IINFO RETURN END IF * On exit, output intervals may not be ordered by ascending negcount IF( IWORK( 6 ).EQ.IU ) THEN WL = WORK( N+1 ) WLU = WORK( N+3 ) NWL = IWORK( 1 ) WU = WORK( N+4 ) WUL = WORK( N+2 ) NWU = IWORK( 4 ) ELSE WL = WORK( N+2 ) WLU = WORK( N+4 ) NWL = IWORK( 2 ) WU = WORK( N+3 ) WUL = WORK( N+1 ) NWU = IWORK( 3 ) END IF * On exit, the interval [WL, WLU] contains a value with negcount NWL, * and [WUL, WU] contains a value with negcount NWU. IF( NWL.LT.0 .OR. NWL.GE.N .OR. NWU.LT.1 .OR. NWU.GT.N ) THEN INFO = 4 RETURN END IF ELSEIF( IRANGE.EQ.VALRNG ) THEN WL = VL WU = VU ELSEIF( IRANGE.EQ.ALLRNG ) THEN WL = GL WU = GU ENDIF * Find Eigenvalues -- Loop Over blocks and recompute NWL and NWU. * NWL accumulates the number of eigenvalues .le. WL, * NWU accumulates the number of eigenvalues .le. WU M = 0 IEND = 0 INFO = 0 NWL = 0 NWU = 0 * DO 70 JBLK = 1, NSPLIT IOFF = IEND IBEGIN = IOFF + 1 IEND = ISPLIT( JBLK ) IN = IEND - IOFF * IF( IN.EQ.1 ) THEN * 1x1 block IF( WL.GE.D( IBEGIN )-PIVMIN ) $ NWL = NWL + 1 IF( WU.GE.D( IBEGIN )-PIVMIN ) $ NWU = NWU + 1 IF( IRANGE.EQ.ALLRNG .OR. $ ( WL.LT.D( IBEGIN )-PIVMIN $ .AND. WU.GE. D( IBEGIN )-PIVMIN ) ) THEN M = M + 1 W( M ) = D( IBEGIN ) WERR(M) = ZERO * The gap for a single block doesn't matter for the later * algorithm and is assigned an arbitrary large value IBLOCK( M ) = JBLK INDEXW( M ) = 1 END IF * Disabled 2x2 case because of a failure on the following matrix * RANGE = 'I', IL = IU = 4 * Original Tridiagonal, d = [ * -0.150102010615740E+00 * -0.849897989384260E+00 * -0.128208148052635E-15 * 0.128257718286320E-15 * ]; * e = [ * -0.357171383266986E+00 * -0.180411241501588E-15 * -0.175152352710251E-15 * ]; * * ELSE IF( IN.EQ.2 ) THEN ** 2x2 block * DISC = SQRT( (HALF*(D(IBEGIN)-D(IEND)))**2 + E(IBEGIN)**2 ) * TMP1 = HALF*(D(IBEGIN)+D(IEND)) * L1 = TMP1 - DISC * IF( WL.GE. L1-PIVMIN ) * $ NWL = NWL + 1 * IF( WU.GE. L1-PIVMIN ) * $ NWU = NWU + 1 * IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L1-PIVMIN .AND. WU.GE. * $ L1-PIVMIN ) ) THEN * M = M + 1 * W( M ) = L1 ** The uncertainty of eigenvalues of a 2x2 matrix is very small * WERR( M ) = EPS * ABS( W( M ) ) * TWO * IBLOCK( M ) = JBLK * INDEXW( M ) = 1 * ENDIF * L2 = TMP1 + DISC * IF( WL.GE. L2-PIVMIN ) * $ NWL = NWL + 1 * IF( WU.GE. L2-PIVMIN ) * $ NWU = NWU + 1 * IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L2-PIVMIN .AND. WU.GE. * $ L2-PIVMIN ) ) THEN * M = M + 1 * W( M ) = L2 ** The uncertainty of eigenvalues of a 2x2 matrix is very small * WERR( M ) = EPS * ABS( W( M ) ) * TWO * IBLOCK( M ) = JBLK * INDEXW( M ) = 2 * ENDIF ELSE * General Case - block of size IN >= 2 * Compute local Gerschgorin interval and use it as the initial * interval for DLAEBZ GU = D( IBEGIN ) GL = D( IBEGIN ) TMP1 = ZERO DO 40 J = IBEGIN, IEND GL = MIN( GL, GERS( 2*J - 1)) GU = MAX( GU, GERS(2*J) ) 40 CONTINUE * [JAN/28/2009] * change SPDIAM by TNORM in lines 2 and 3 thereafter * line 1: remove computation of SPDIAM (not useful anymore) * SPDIAM = GU - GL * GL = GL - FUDGE*SPDIAM*EPS*IN - FUDGE*PIVMIN * GU = GU + FUDGE*SPDIAM*EPS*IN + FUDGE*PIVMIN GL = GL - FUDGE*TNORM*EPS*IN - FUDGE*PIVMIN GU = GU + FUDGE*TNORM*EPS*IN + FUDGE*PIVMIN * IF( IRANGE.GT.1 ) THEN IF( GU.LT.WL ) THEN * the local block contains none of the wanted eigenvalues NWL = NWL + IN NWU = NWU + IN GO TO 70 END IF * refine search interval if possible, only range (WL,WU] matters GL = MAX( GL, WL ) GU = MIN( GU, WU ) IF( GL.GE.GU ) $ GO TO 70 END IF * Find negcount of initial interval boundaries GL and GU WORK( N+1 ) = GL WORK( N+IN+1 ) = GU CALL DLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN, $ D( IBEGIN ), E( IBEGIN ), E2( IBEGIN ), $ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM, $ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO ) IF( IINFO .NE. 0 ) THEN INFO = IINFO RETURN END IF * NWL = NWL + IWORK( 1 ) NWU = NWU + IWORK( IN+1 ) IWOFF = M - IWORK( 1 ) * Compute Eigenvalues ITMAX = INT( ( LOG( GU-GL+PIVMIN )-LOG( PIVMIN ) ) / $ LOG( TWO ) ) + 2 CALL DLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN, $ D( IBEGIN ), E( IBEGIN ), E2( IBEGIN ), $ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT, $ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO ) IF( IINFO .NE. 0 ) THEN INFO = IINFO RETURN END IF * * Copy eigenvalues into W and IBLOCK * Use -JBLK for block number for unconverged eigenvalues. * Loop over the number of output intervals from DLAEBZ DO 60 J = 1, IOUT * eigenvalue approximation is middle point of interval TMP1 = HALF*( WORK( J+N )+WORK( J+IN+N ) ) * semi length of error interval TMP2 = HALF*ABS( WORK( J+N )-WORK( J+IN+N ) ) IF( J.GT.IOUT-IINFO ) THEN * Flag non-convergence. NCNVRG = .TRUE. IB = -JBLK ELSE IB = JBLK END IF DO 50 JE = IWORK( J ) + 1 + IWOFF, $ IWORK( J+IN ) + IWOFF W( JE ) = TMP1 WERR( JE ) = TMP2 INDEXW( JE ) = JE - IWOFF IBLOCK( JE ) = IB 50 CONTINUE 60 CONTINUE * M = M + IM END IF 70 CONTINUE * If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU * If NWL+1 < IL or NWU > IU, discard extra eigenvalues. IF( IRANGE.EQ.INDRNG ) THEN IDISCL = IL - 1 - NWL IDISCU = NWU - IU * IF( IDISCL.GT.0 ) THEN IM = 0 DO 80 JE = 1, M * Remove some of the smallest eigenvalues from the left so that * at the end IDISCL =0. Move all eigenvalues up to the left. IF( W( JE ).LE.WLU .AND. IDISCL.GT.0 ) THEN IDISCL = IDISCL - 1 ELSE IM = IM + 1 W( IM ) = W( JE ) WERR( IM ) = WERR( JE ) INDEXW( IM ) = INDEXW( JE ) IBLOCK( IM ) = IBLOCK( JE ) END IF 80 CONTINUE M = IM END IF IF( IDISCU.GT.0 ) THEN * Remove some of the largest eigenvalues from the right so that * at the end IDISCU =0. Move all eigenvalues up to the left. IM=M+1 DO 81 JE = M, 1, -1 IF( W( JE ).GE.WUL .AND. IDISCU.GT.0 ) THEN IDISCU = IDISCU - 1 ELSE IM = IM - 1 W( IM ) = W( JE ) WERR( IM ) = WERR( JE ) INDEXW( IM ) = INDEXW( JE ) IBLOCK( IM ) = IBLOCK( JE ) END IF 81 CONTINUE JEE = 0 DO 82 JE = IM, M JEE = JEE + 1 W( JEE ) = W( JE ) WERR( JEE ) = WERR( JE ) INDEXW( JEE ) = INDEXW( JE ) IBLOCK( JEE ) = IBLOCK( JE ) 82 CONTINUE M = M-IM+1 END IF IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN * Code to deal with effects of bad arithmetic. (If N(w) is * monotone non-decreasing, this should never happen.) * Some low eigenvalues to be discarded are not in (WL,WLU], * or high eigenvalues to be discarded are not in (WUL,WU] * so just kill off the smallest IDISCL/largest IDISCU * eigenvalues, by marking the corresponding IBLOCK = 0 IF( IDISCL.GT.0 ) THEN WKILL = WU DO 100 JDISC = 1, IDISCL IW = 0 DO 90 JE = 1, M IF( IBLOCK( JE ).NE.0 .AND. $ ( W( JE ).LT.WKILL .OR. IW.EQ.0 ) ) THEN IW = JE WKILL = W( JE ) END IF 90 CONTINUE IBLOCK( IW ) = 0 100 CONTINUE END IF IF( IDISCU.GT.0 ) THEN WKILL = WL DO 120 JDISC = 1, IDISCU IW = 0 DO 110 JE = 1, M IF( IBLOCK( JE ).NE.0 .AND. $ ( W( JE ).GE.WKILL .OR. IW.EQ.0 ) ) THEN IW = JE WKILL = W( JE ) END IF 110 CONTINUE IBLOCK( IW ) = 0 120 CONTINUE END IF * Now erase all eigenvalues with IBLOCK set to zero IM = 0 DO 130 JE = 1, M IF( IBLOCK( JE ).NE.0 ) THEN IM = IM + 1 W( IM ) = W( JE ) WERR( IM ) = WERR( JE ) INDEXW( IM ) = INDEXW( JE ) IBLOCK( IM ) = IBLOCK( JE ) END IF 130 CONTINUE M = IM END IF IF( IDISCL.LT.0 .OR. IDISCU.LT.0 ) THEN TOOFEW = .TRUE. END IF END IF * IF(( IRANGE.EQ.ALLRNG .AND. M.NE.N ).OR. $ ( IRANGE.EQ.INDRNG .AND. M.NE.IU-IL+1 ) ) THEN TOOFEW = .TRUE. END IF * If ORDER='B', do nothing the eigenvalues are already sorted by * block. * If ORDER='E', sort the eigenvalues from smallest to largest IF( LSAME(ORDER,'E') .AND. NSPLIT.GT.1 ) THEN DO 150 JE = 1, M - 1 IE = 0 TMP1 = W( JE ) DO 140 J = JE + 1, M IF( W( J ).LT.TMP1 ) THEN IE = J TMP1 = W( J ) END IF 140 CONTINUE IF( IE.NE.0 ) THEN TMP2 = WERR( IE ) ITMP1 = IBLOCK( IE ) ITMP2 = INDEXW( IE ) W( IE ) = W( JE ) WERR( IE ) = WERR( JE ) IBLOCK( IE ) = IBLOCK( JE ) INDEXW( IE ) = INDEXW( JE ) W( JE ) = TMP1 WERR( JE ) = TMP2 IBLOCK( JE ) = ITMP1 INDEXW( JE ) = ITMP2 END IF 150 CONTINUE END IF * INFO = 0 IF( NCNVRG ) $ INFO = INFO + 1 IF( TOOFEW ) $ INFO = INFO + 2 RETURN * * End of DLARRD * END *> \brief \b DLARRE given the tridiagonal matrix T, sets small off-diagonal elements to zero and for each unreduced block Ti, finds base representations and eigenvalues. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARRE + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARRE( RANGE, N, VL, VU, IL, IU, D, E, E2, * RTOL1, RTOL2, SPLTOL, NSPLIT, ISPLIT, M, * W, WERR, WGAP, IBLOCK, INDEXW, GERS, PIVMIN, * WORK, IWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER RANGE * INTEGER IL, INFO, IU, M, N, NSPLIT * DOUBLE PRECISION PIVMIN, RTOL1, RTOL2, SPLTOL, VL, VU * .. * .. Array Arguments .. * INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * ), * $ INDEXW( * ) * DOUBLE PRECISION D( * ), E( * ), E2( * ), GERS( * ), * $ W( * ),WERR( * ), WGAP( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> To find the desired eigenvalues of a given real symmetric *> tridiagonal matrix T, DLARRE sets any "small" off-diagonal *> elements to zero, and for each unreduced block T_i, it finds *> (a) a suitable shift at one end of the block's spectrum, *> (b) the base representation, T_i - sigma_i I = L_i D_i L_i^T, and *> (c) eigenvalues of each L_i D_i L_i^T. *> The representations and eigenvalues found are then used by *> DSTEMR to compute the eigenvectors of T. *> The accuracy varies depending on whether bisection is used to *> find a few eigenvalues or the dqds algorithm (subroutine DLASQ2) to *> conpute all and then discard any unwanted one. *> As an added benefit, DLARRE also outputs the n *> Gerschgorin intervals for the matrices L_i D_i L_i^T. *> \endverbatim * * Arguments: * ========== * *> \param[in] RANGE *> \verbatim *> RANGE is CHARACTER*1 *> = 'A': ("All") all eigenvalues will be found. *> = 'V': ("Value") all eigenvalues in the half-open interval *> (VL, VU] will be found. *> = 'I': ("Index") the IL-th through IU-th eigenvalues (of the *> entire matrix) will be found. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix. N > 0. *> \endverbatim *> *> \param[in,out] VL *> \verbatim *> VL is DOUBLE PRECISION *> If RANGE='V', the lower bound for the eigenvalues. *> Eigenvalues less than or equal to VL, or greater than VU, *> will not be returned. VL < VU. *> If RANGE='I' or ='A', DLARRE computes bounds on the desired *> part of the spectrum. *> \endverbatim *> *> \param[in,out] VU *> \verbatim *> VU is DOUBLE PRECISION *> If RANGE='V', the upper bound for the eigenvalues. *> Eigenvalues less than or equal to VL, or greater than VU, *> will not be returned. VL < VU. *> If RANGE='I' or ='A', DLARRE computes bounds on the desired *> part of the spectrum. *> \endverbatim *> *> \param[in] IL *> \verbatim *> IL is INTEGER *> If RANGE='I', the index of the *> smallest eigenvalue to be returned. *> 1 <= IL <= IU <= N. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> If RANGE='I', the index of the *> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> On entry, the N diagonal elements of the tridiagonal *> matrix T. *> On exit, the N diagonal elements of the diagonal *> matrices D_i. *> \endverbatim *> *> \param[in,out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N) *> On entry, the first (N-1) entries contain the subdiagonal *> elements of the tridiagonal matrix T; E(N) need not be set. *> On exit, E contains the subdiagonal elements of the unit *> bidiagonal matrices L_i. The entries E( ISPLIT( I ) ), *> 1 <= I <= NSPLIT, contain the base points sigma_i on output. *> \endverbatim *> *> \param[in,out] E2 *> \verbatim *> E2 is DOUBLE PRECISION array, dimension (N) *> On entry, the first (N-1) entries contain the SQUARES of the *> subdiagonal elements of the tridiagonal matrix T; *> E2(N) need not be set. *> On exit, the entries E2( ISPLIT( I ) ), *> 1 <= I <= NSPLIT, have been set to zero *> \endverbatim *> *> \param[in] RTOL1 *> \verbatim *> RTOL1 is DOUBLE PRECISION *> \endverbatim *> *> \param[in] RTOL2 *> \verbatim *> RTOL2 is DOUBLE PRECISION *> Parameters for bisection. *> An interval [LEFT,RIGHT] has converged if *> RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) *> \endverbatim *> *> \param[in] SPLTOL *> \verbatim *> SPLTOL is DOUBLE PRECISION *> The threshold for splitting. *> \endverbatim *> *> \param[out] NSPLIT *> \verbatim *> NSPLIT is INTEGER *> The number of blocks T splits into. 1 <= NSPLIT <= N. *> \endverbatim *> *> \param[out] ISPLIT *> \verbatim *> ISPLIT is INTEGER array, dimension (N) *> The splitting points, at which T breaks up into blocks. *> The first block consists of rows/columns 1 to ISPLIT(1), *> the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), *> etc., and the NSPLIT-th consists of rows/columns *> ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. *> \endverbatim *> *> \param[out] M *> \verbatim *> M is INTEGER *> The total number of eigenvalues (of all L_i D_i L_i^T) *> found. *> \endverbatim *> *> \param[out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> The first M elements contain the eigenvalues. The *> eigenvalues of each of the blocks, L_i D_i L_i^T, are *> sorted in ascending order ( DLARRE may use the *> remaining N-M elements as workspace). *> \endverbatim *> *> \param[out] WERR *> \verbatim *> WERR is DOUBLE PRECISION array, dimension (N) *> The error bound on the corresponding eigenvalue in W. *> \endverbatim *> *> \param[out] WGAP *> \verbatim *> WGAP is DOUBLE PRECISION array, dimension (N) *> The separation from the right neighbor eigenvalue in W. *> The gap is only with respect to the eigenvalues of the same block *> as each block has its own representation tree. *> Exception: at the right end of a block we store the left gap *> \endverbatim *> *> \param[out] IBLOCK *> \verbatim *> IBLOCK is INTEGER array, dimension (N) *> The indices of the blocks (submatrices) associated with the *> corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue *> W(i) belongs to the first block from the top, =2 if W(i) *> belongs to the second block, etc. *> \endverbatim *> *> \param[out] INDEXW *> \verbatim *> INDEXW is INTEGER array, dimension (N) *> The indices of the eigenvalues within each block (submatrix); *> for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the *> i-th eigenvalue W(i) is the 10-th eigenvalue in block 2 *> \endverbatim *> *> \param[out] GERS *> \verbatim *> GERS is DOUBLE PRECISION array, dimension (2*N) *> The N Gerschgorin intervals (the i-th Gerschgorin interval *> is (GERS(2*i-1), GERS(2*i)). *> \endverbatim *> *> \param[out] PIVMIN *> \verbatim *> PIVMIN is DOUBLE PRECISION *> The minimum pivot in the Sturm sequence for T. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (6*N) *> Workspace. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (5*N) *> Workspace. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> > 0: A problem occurred in DLARRE. *> < 0: One of the called subroutines signaled an internal problem. *> Needs inspection of the corresponding parameter IINFO *> for further information. *> *> =-1: Problem in DLARRD. *> = 2: No base representation could be found in MAXTRY iterations. *> Increasing MAXTRY and recompilation might be a remedy. *> =-3: Problem in DLARRB when computing the refined root *> representation for DLASQ2. *> =-4: Problem in DLARRB when preforming bisection on the *> desired part of the spectrum. *> =-5: Problem in DLASQ2. *> =-6: Problem in DLASQ2. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> The base representations are required to suffer very little *> element growth and consequently define all their eigenvalues to *> high relative accuracy. *> \endverbatim * *> \par Contributors: * ================== *> *> Beresford Parlett, University of California, Berkeley, USA \n *> Jim Demmel, University of California, Berkeley, USA \n *> Inderjit Dhillon, University of Texas, Austin, USA \n *> Osni Marques, LBNL/NERSC, USA \n *> Christof Voemel, University of California, Berkeley, USA \n *> * ===================================================================== SUBROUTINE DLARRE( RANGE, N, VL, VU, IL, IU, D, E, E2, $ RTOL1, RTOL2, SPLTOL, NSPLIT, ISPLIT, M, $ W, WERR, WGAP, IBLOCK, INDEXW, GERS, PIVMIN, $ WORK, IWORK, INFO ) * * -- LAPACK auxiliary routine (version 3.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. CHARACTER RANGE INTEGER IL, INFO, IU, M, N, NSPLIT DOUBLE PRECISION PIVMIN, RTOL1, RTOL2, SPLTOL, VL, VU * .. * .. Array Arguments .. INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * ), $ INDEXW( * ) DOUBLE PRECISION D( * ), E( * ), E2( * ), GERS( * ), $ W( * ),WERR( * ), WGAP( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION FAC, FOUR, FOURTH, FUDGE, HALF, HNDRD, $ MAXGROWTH, ONE, PERT, TWO, ZERO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, $ TWO = 2.0D0, FOUR=4.0D0, $ HNDRD = 100.0D0, $ PERT = 8.0D0, $ HALF = ONE/TWO, FOURTH = ONE/FOUR, FAC= HALF, $ MAXGROWTH = 64.0D0, FUDGE = 2.0D0 ) INTEGER MAXTRY, ALLRNG, INDRNG, VALRNG PARAMETER ( MAXTRY = 6, ALLRNG = 1, INDRNG = 2, $ VALRNG = 3 ) * .. * .. Local Scalars .. LOGICAL FORCEB, NOREP, USEDQD INTEGER CNT, CNT1, CNT2, I, IBEGIN, IDUM, IEND, IINFO, $ IN, INDL, INDU, IRANGE, J, JBLK, MB, MM, $ WBEGIN, WEND DOUBLE PRECISION AVGAP, BSRTOL, CLWDTH, DMAX, DPIVOT, EABS, $ EMAX, EOLD, EPS, GL, GU, ISLEFT, ISRGHT, RTL, $ RTOL, S1, S2, SAFMIN, SGNDEF, SIGMA, SPDIAM, $ TAU, TMP, TMP1 * .. * .. Local Arrays .. INTEGER ISEED( 4 ) * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME * .. * .. External Subroutines .. EXTERNAL DCOPY, DLARNV, DLARRA, DLARRB, DLARRC, DLARRD, $ DLASQ2, DLARRK * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.LE.0 ) THEN RETURN END IF * * Decode RANGE * IF( LSAME( RANGE, 'A' ) ) THEN IRANGE = ALLRNG ELSE IF( LSAME( RANGE, 'V' ) ) THEN IRANGE = VALRNG ELSE IF( LSAME( RANGE, 'I' ) ) THEN IRANGE = INDRNG END IF M = 0 * Get machine constants SAFMIN = DLAMCH( 'S' ) EPS = DLAMCH( 'P' ) * Set parameters RTL = SQRT(EPS) BSRTOL = SQRT(EPS) * Treat case of 1x1 matrix for quick return IF( N.EQ.1 ) THEN IF( (IRANGE.EQ.ALLRNG).OR. $ ((IRANGE.EQ.VALRNG).AND.(D(1).GT.VL).AND.(D(1).LE.VU)).OR. $ ((IRANGE.EQ.INDRNG).AND.(IL.EQ.1).AND.(IU.EQ.1)) ) THEN M = 1 W(1) = D(1) * The computation error of the eigenvalue is zero WERR(1) = ZERO WGAP(1) = ZERO IBLOCK( 1 ) = 1 INDEXW( 1 ) = 1 GERS(1) = D( 1 ) GERS(2) = D( 1 ) ENDIF * store the shift for the initial RRR, which is zero in this case E(1) = ZERO RETURN END IF * General case: tridiagonal matrix of order > 1 * * Init WERR, WGAP. Compute Gerschgorin intervals and spectral diameter. * Compute maximum off-diagonal entry and pivmin. GL = D(1) GU = D(1) EOLD = ZERO EMAX = ZERO E(N) = ZERO DO 5 I = 1,N WERR(I) = ZERO WGAP(I) = ZERO EABS = ABS( E(I) ) IF( EABS .GE. EMAX ) THEN EMAX = EABS END IF TMP1 = EABS + EOLD GERS( 2*I-1) = D(I) - TMP1 GL = MIN( GL, GERS( 2*I - 1)) GERS( 2*I ) = D(I) + TMP1 GU = MAX( GU, GERS(2*I) ) EOLD = EABS 5 CONTINUE * The minimum pivot allowed in the Sturm sequence for T PIVMIN = SAFMIN * MAX( ONE, EMAX**2 ) * Compute spectral diameter. The Gerschgorin bounds give an * estimate that is wrong by at most a factor of SQRT(2) SPDIAM = GU - GL * Compute splitting points CALL DLARRA( N, D, E, E2, SPLTOL, SPDIAM, $ NSPLIT, ISPLIT, IINFO ) * Can force use of bisection instead of faster DQDS. * Option left in the code for future multisection work. FORCEB = .FALSE. * Initialize USEDQD, DQDS should be used for ALLRNG unless someone * explicitly wants bisection. USEDQD = (( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB)) IF( (IRANGE.EQ.ALLRNG) .AND. (.NOT. FORCEB) ) THEN * Set interval [VL,VU] that contains all eigenvalues VL = GL VU = GU ELSE * We call DLARRD to find crude approximations to the eigenvalues * in the desired range. In case IRANGE = INDRNG, we also obtain the * interval (VL,VU] that contains all the wanted eigenvalues. * An interval [LEFT,RIGHT] has converged if * RIGHT-LEFT.LT.RTOL*MAX(ABS(LEFT),ABS(RIGHT)) * DLARRD needs a WORK of size 4*N, IWORK of size 3*N CALL DLARRD( RANGE, 'B', N, VL, VU, IL, IU, GERS, $ BSRTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT, $ MM, W, WERR, VL, VU, IBLOCK, INDEXW, $ WORK, IWORK, IINFO ) IF( IINFO.NE.0 ) THEN INFO = -1 RETURN ENDIF * Make sure that the entries M+1 to N in W, WERR, IBLOCK, INDEXW are 0 DO 14 I = MM+1,N W( I ) = ZERO WERR( I ) = ZERO IBLOCK( I ) = 0 INDEXW( I ) = 0 14 CONTINUE END IF *** * Loop over unreduced blocks IBEGIN = 1 WBEGIN = 1 DO 170 JBLK = 1, NSPLIT IEND = ISPLIT( JBLK ) IN = IEND - IBEGIN + 1 * 1 X 1 block IF( IN.EQ.1 ) THEN IF( (IRANGE.EQ.ALLRNG).OR.( (IRANGE.EQ.VALRNG).AND. $ ( D( IBEGIN ).GT.VL ).AND.( D( IBEGIN ).LE.VU ) ) $ .OR. ( (IRANGE.EQ.INDRNG).AND.(IBLOCK(WBEGIN).EQ.JBLK)) $ ) THEN M = M + 1 W( M ) = D( IBEGIN ) WERR(M) = ZERO * The gap for a single block doesn't matter for the later * algorithm and is assigned an arbitrary large value WGAP(M) = ZERO IBLOCK( M ) = JBLK INDEXW( M ) = 1 WBEGIN = WBEGIN + 1 ENDIF * E( IEND ) holds the shift for the initial RRR E( IEND ) = ZERO IBEGIN = IEND + 1 GO TO 170 END IF * * Blocks of size larger than 1x1 * * E( IEND ) will hold the shift for the initial RRR, for now set it =0 E( IEND ) = ZERO * * Find local outer bounds GL,GU for the block GL = D(IBEGIN) GU = D(IBEGIN) DO 15 I = IBEGIN , IEND GL = MIN( GERS( 2*I-1 ), GL ) GU = MAX( GERS( 2*I ), GU ) 15 CONTINUE SPDIAM = GU - GL IF(.NOT. ((IRANGE.EQ.ALLRNG).AND.(.NOT.FORCEB)) ) THEN * Count the number of eigenvalues in the current block. MB = 0 DO 20 I = WBEGIN,MM IF( IBLOCK(I).EQ.JBLK ) THEN MB = MB+1 ELSE GOTO 21 ENDIF 20 CONTINUE 21 CONTINUE IF( MB.EQ.0) THEN * No eigenvalue in the current block lies in the desired range * E( IEND ) holds the shift for the initial RRR E( IEND ) = ZERO IBEGIN = IEND + 1 GO TO 170 ELSE * Decide whether dqds or bisection is more efficient USEDQD = ( (MB .GT. FAC*IN) .AND. (.NOT.FORCEB) ) WEND = WBEGIN + MB - 1 * Calculate gaps for the current block * In later stages, when representations for individual * eigenvalues are different, we use SIGMA = E( IEND ). SIGMA = ZERO DO 30 I = WBEGIN, WEND - 1 WGAP( I ) = MAX( ZERO, $ W(I+1)-WERR(I+1) - (W(I)+WERR(I)) ) 30 CONTINUE WGAP( WEND ) = MAX( ZERO, $ VU - SIGMA - (W( WEND )+WERR( WEND ))) * Find local index of the first and last desired evalue. INDL = INDEXW(WBEGIN) INDU = INDEXW( WEND ) ENDIF ENDIF IF(( (IRANGE.EQ.ALLRNG) .AND. (.NOT. FORCEB) ).OR.USEDQD) THEN * Case of DQDS * Find approximations to the extremal eigenvalues of the block CALL DLARRK( IN, 1, GL, GU, D(IBEGIN), $ E2(IBEGIN), PIVMIN, RTL, TMP, TMP1, IINFO ) IF( IINFO.NE.0 ) THEN INFO = -1 RETURN ENDIF ISLEFT = MAX(GL, TMP - TMP1 $ - HNDRD * EPS* ABS(TMP - TMP1)) CALL DLARRK( IN, IN, GL, GU, D(IBEGIN), $ E2(IBEGIN), PIVMIN, RTL, TMP, TMP1, IINFO ) IF( IINFO.NE.0 ) THEN INFO = -1 RETURN ENDIF ISRGHT = MIN(GU, TMP + TMP1 $ + HNDRD * EPS * ABS(TMP + TMP1)) * Improve the estimate of the spectral diameter SPDIAM = ISRGHT - ISLEFT ELSE * Case of bisection * Find approximations to the wanted extremal eigenvalues ISLEFT = MAX(GL, W(WBEGIN) - WERR(WBEGIN) $ - HNDRD * EPS*ABS(W(WBEGIN)- WERR(WBEGIN) )) ISRGHT = MIN(GU,W(WEND) + WERR(WEND) $ + HNDRD * EPS * ABS(W(WEND)+ WERR(WEND))) ENDIF * Decide whether the base representation for the current block * L_JBLK D_JBLK L_JBLK^T = T_JBLK - sigma_JBLK I * should be on the left or the right end of the current block. * The strategy is to shift to the end which is "more populated" * Furthermore, decide whether to use DQDS for the computation of * the eigenvalue approximations at the end of DLARRE or bisection. * dqds is chosen if all eigenvalues are desired or the number of * eigenvalues to be computed is large compared to the blocksize. IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN * If all the eigenvalues have to be computed, we use dqd USEDQD = .TRUE. * INDL is the local index of the first eigenvalue to compute INDL = 1 INDU = IN * MB = number of eigenvalues to compute MB = IN WEND = WBEGIN + MB - 1 * Define 1/4 and 3/4 points of the spectrum S1 = ISLEFT + FOURTH * SPDIAM S2 = ISRGHT - FOURTH * SPDIAM ELSE * DLARRD has computed IBLOCK and INDEXW for each eigenvalue * approximation. * choose sigma IF( USEDQD ) THEN S1 = ISLEFT + FOURTH * SPDIAM S2 = ISRGHT - FOURTH * SPDIAM ELSE TMP = MIN(ISRGHT,VU) - MAX(ISLEFT,VL) S1 = MAX(ISLEFT,VL) + FOURTH * TMP S2 = MIN(ISRGHT,VU) - FOURTH * TMP ENDIF ENDIF * Compute the negcount at the 1/4 and 3/4 points IF(MB.GT.1) THEN CALL DLARRC( 'T', IN, S1, S2, D(IBEGIN), $ E(IBEGIN), PIVMIN, CNT, CNT1, CNT2, IINFO) ENDIF IF(MB.EQ.1) THEN SIGMA = GL SGNDEF = ONE ELSEIF( CNT1 - INDL .GE. INDU - CNT2 ) THEN IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN SIGMA = MAX(ISLEFT,GL) ELSEIF( USEDQD ) THEN * use Gerschgorin bound as shift to get pos def matrix * for dqds SIGMA = ISLEFT ELSE * use approximation of the first desired eigenvalue of the * block as shift SIGMA = MAX(ISLEFT,VL) ENDIF SGNDEF = ONE ELSE IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN SIGMA = MIN(ISRGHT,GU) ELSEIF( USEDQD ) THEN * use Gerschgorin bound as shift to get neg def matrix * for dqds SIGMA = ISRGHT ELSE * use approximation of the first desired eigenvalue of the * block as shift SIGMA = MIN(ISRGHT,VU) ENDIF SGNDEF = -ONE ENDIF * An initial SIGMA has been chosen that will be used for computing * T - SIGMA I = L D L^T * Define the increment TAU of the shift in case the initial shift * needs to be refined to obtain a factorization with not too much * element growth. IF( USEDQD ) THEN * The initial SIGMA was to the outer end of the spectrum * the matrix is definite and we need not retreat. TAU = SPDIAM*EPS*N + TWO*PIVMIN TAU = MAX( TAU,TWO*EPS*ABS(SIGMA) ) ELSE IF(MB.GT.1) THEN CLWDTH = W(WEND) + WERR(WEND) - W(WBEGIN) - WERR(WBEGIN) AVGAP = ABS(CLWDTH / DBLE(WEND-WBEGIN)) IF( SGNDEF.EQ.ONE ) THEN TAU = HALF*MAX(WGAP(WBEGIN),AVGAP) TAU = MAX(TAU,WERR(WBEGIN)) ELSE TAU = HALF*MAX(WGAP(WEND-1),AVGAP) TAU = MAX(TAU,WERR(WEND)) ENDIF ELSE TAU = WERR(WBEGIN) ENDIF ENDIF * DO 80 IDUM = 1, MAXTRY * Compute L D L^T factorization of tridiagonal matrix T - sigma I. * Store D in WORK(1:IN), L in WORK(IN+1:2*IN), and reciprocals of * pivots in WORK(2*IN+1:3*IN) DPIVOT = D( IBEGIN ) - SIGMA WORK( 1 ) = DPIVOT DMAX = ABS( WORK(1) ) J = IBEGIN DO 70 I = 1, IN - 1 WORK( 2*IN+I ) = ONE / WORK( I ) TMP = E( J )*WORK( 2*IN+I ) WORK( IN+I ) = TMP DPIVOT = ( D( J+1 )-SIGMA ) - TMP*E( J ) WORK( I+1 ) = DPIVOT DMAX = MAX( DMAX, ABS(DPIVOT) ) J = J + 1 70 CONTINUE * check for element growth IF( DMAX .GT. MAXGROWTH*SPDIAM ) THEN NOREP = .TRUE. ELSE NOREP = .FALSE. ENDIF IF( USEDQD .AND. .NOT.NOREP ) THEN * Ensure the definiteness of the representation * All entries of D (of L D L^T) must have the same sign DO 71 I = 1, IN TMP = SGNDEF*WORK( I ) IF( TMP.LT.ZERO ) NOREP = .TRUE. 71 CONTINUE ENDIF IF(NOREP) THEN * Note that in the case of IRANGE=ALLRNG, we use the Gerschgorin * shift which makes the matrix definite. So we should end up * here really only in the case of IRANGE = VALRNG or INDRNG. IF( IDUM.EQ.MAXTRY-1 ) THEN IF( SGNDEF.EQ.ONE ) THEN * The fudged Gerschgorin shift should succeed SIGMA = $ GL - FUDGE*SPDIAM*EPS*N - FUDGE*TWO*PIVMIN ELSE SIGMA = $ GU + FUDGE*SPDIAM*EPS*N + FUDGE*TWO*PIVMIN END IF ELSE SIGMA = SIGMA - SGNDEF * TAU TAU = TWO * TAU END IF ELSE * an initial RRR is found GO TO 83 END IF 80 CONTINUE * if the program reaches this point, no base representation could be * found in MAXTRY iterations. INFO = 2 RETURN 83 CONTINUE * At this point, we have found an initial base representation * T - SIGMA I = L D L^T with not too much element growth. * Store the shift. E( IEND ) = SIGMA * Store D and L. CALL DCOPY( IN, WORK, 1, D( IBEGIN ), 1 ) CALL DCOPY( IN-1, WORK( IN+1 ), 1, E( IBEGIN ), 1 ) IF(MB.GT.1 ) THEN * * Perturb each entry of the base representation by a small * (but random) relative amount to overcome difficulties with * glued matrices. * DO 122 I = 1, 4 ISEED( I ) = 1 122 CONTINUE CALL DLARNV(2, ISEED, 2*IN-1, WORK(1)) DO 125 I = 1,IN-1 D(IBEGIN+I-1) = D(IBEGIN+I-1)*(ONE+EPS*PERT*WORK(I)) E(IBEGIN+I-1) = E(IBEGIN+I-1)*(ONE+EPS*PERT*WORK(IN+I)) 125 CONTINUE D(IEND) = D(IEND)*(ONE+EPS*FOUR*WORK(IN)) * ENDIF * * Don't update the Gerschgorin intervals because keeping track * of the updates would be too much work in DLARRV. * We update W instead and use it to locate the proper Gerschgorin * intervals. * Compute the required eigenvalues of L D L' by bisection or dqds IF ( .NOT.USEDQD ) THEN * If DLARRD has been used, shift the eigenvalue approximations * according to their representation. This is necessary for * a uniform DLARRV since dqds computes eigenvalues of the * shifted representation. In DLARRV, W will always hold the * UNshifted eigenvalue approximation. DO 134 J=WBEGIN,WEND W(J) = W(J) - SIGMA WERR(J) = WERR(J) + ABS(W(J)) * EPS 134 CONTINUE * call DLARRB to reduce eigenvalue error of the approximations * from DLARRD DO 135 I = IBEGIN, IEND-1 WORK( I ) = D( I ) * E( I )**2 135 CONTINUE * use bisection to find EV from INDL to INDU CALL DLARRB(IN, D(IBEGIN), WORK(IBEGIN), $ INDL, INDU, RTOL1, RTOL2, INDL-1, $ W(WBEGIN), WGAP(WBEGIN), WERR(WBEGIN), $ WORK( 2*N+1 ), IWORK, PIVMIN, SPDIAM, $ IN, IINFO ) IF( IINFO .NE. 0 ) THEN INFO = -4 RETURN END IF * DLARRB computes all gaps correctly except for the last one * Record distance to VU/GU WGAP( WEND ) = MAX( ZERO, $ ( VU-SIGMA ) - ( W( WEND ) + WERR( WEND ) ) ) DO 138 I = INDL, INDU M = M + 1 IBLOCK(M) = JBLK INDEXW(M) = I 138 CONTINUE ELSE * Call dqds to get all eigs (and then possibly delete unwanted * eigenvalues). * Note that dqds finds the eigenvalues of the L D L^T representation * of T to high relative accuracy. High relative accuracy * might be lost when the shift of the RRR is subtracted to obtain * the eigenvalues of T. However, T is not guaranteed to define its * eigenvalues to high relative accuracy anyway. * Set RTOL to the order of the tolerance used in DLASQ2 * This is an ESTIMATED error, the worst case bound is 4*N*EPS * which is usually too large and requires unnecessary work to be * done by bisection when computing the eigenvectors RTOL = LOG(DBLE(IN)) * FOUR * EPS J = IBEGIN DO 140 I = 1, IN - 1 WORK( 2*I-1 ) = ABS( D( J ) ) WORK( 2*I ) = E( J )*E( J )*WORK( 2*I-1 ) J = J + 1 140 CONTINUE WORK( 2*IN-1 ) = ABS( D( IEND ) ) WORK( 2*IN ) = ZERO CALL DLASQ2( IN, WORK, IINFO ) IF( IINFO .NE. 0 ) THEN * If IINFO = -5 then an index is part of a tight cluster * and should be changed. The index is in IWORK(1) and the * gap is in WORK(N+1) INFO = -5 RETURN ELSE * Test that all eigenvalues are positive as expected DO 149 I = 1, IN IF( WORK( I ).LT.ZERO ) THEN INFO = -6 RETURN ENDIF 149 CONTINUE END IF IF( SGNDEF.GT.ZERO ) THEN DO 150 I = INDL, INDU M = M + 1 W( M ) = WORK( IN-I+1 ) IBLOCK( M ) = JBLK INDEXW( M ) = I 150 CONTINUE ELSE DO 160 I = INDL, INDU M = M + 1 W( M ) = -WORK( I ) IBLOCK( M ) = JBLK INDEXW( M ) = I 160 CONTINUE END IF DO 165 I = M - MB + 1, M * the value of RTOL below should be the tolerance in DLASQ2 WERR( I ) = RTOL * ABS( W(I) ) 165 CONTINUE DO 166 I = M - MB + 1, M - 1 * compute the right gap between the intervals WGAP( I ) = MAX( ZERO, $ W(I+1)-WERR(I+1) - (W(I)+WERR(I)) ) 166 CONTINUE WGAP( M ) = MAX( ZERO, $ ( VU-SIGMA ) - ( W( M ) + WERR( M ) ) ) END IF * proceed with next block IBEGIN = IEND + 1 WBEGIN = WEND + 1 170 CONTINUE * RETURN * * end of DLARRE * END *> \brief \b DLARRF finds a new relatively robust representation such that at least one of the eigenvalues is relatively isolated. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARRF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARRF( N, D, L, LD, CLSTRT, CLEND, * W, WGAP, WERR, * SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA, * DPLUS, LPLUS, WORK, INFO ) * * .. Scalar Arguments .. * INTEGER CLSTRT, CLEND, INFO, N * DOUBLE PRECISION CLGAPL, CLGAPR, PIVMIN, SIGMA, SPDIAM * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), DPLUS( * ), L( * ), LD( * ), * $ LPLUS( * ), W( * ), WGAP( * ), WERR( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> Given the initial representation L D L^T and its cluster of close *> eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ... *> W( CLEND ), DLARRF finds a new relatively robust representation *> L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the *> eigenvalues of L(+) D(+) L(+)^T is relatively isolated. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix (subblock, if the matrix split). *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The N diagonal elements of the diagonal matrix D. *> \endverbatim *> *> \param[in] L *> \verbatim *> L is DOUBLE PRECISION array, dimension (N-1) *> The (N-1) subdiagonal elements of the unit bidiagonal *> matrix L. *> \endverbatim *> *> \param[in] LD *> \verbatim *> LD is DOUBLE PRECISION array, dimension (N-1) *> The (N-1) elements L(i)*D(i). *> \endverbatim *> *> \param[in] CLSTRT *> \verbatim *> CLSTRT is INTEGER *> The index of the first eigenvalue in the cluster. *> \endverbatim *> *> \param[in] CLEND *> \verbatim *> CLEND is INTEGER *> The index of the last eigenvalue in the cluster. *> \endverbatim *> *> \param[in] W *> \verbatim *> W is DOUBLE PRECISION array, dimension *> dimension is >= (CLEND-CLSTRT+1) *> The eigenvalue APPROXIMATIONS of L D L^T in ascending order. *> W( CLSTRT ) through W( CLEND ) form the cluster of relatively *> close eigenalues. *> \endverbatim *> *> \param[in,out] WGAP *> \verbatim *> WGAP is DOUBLE PRECISION array, dimension *> dimension is >= (CLEND-CLSTRT+1) *> The separation from the right neighbor eigenvalue in W. *> \endverbatim *> *> \param[in] WERR *> \verbatim *> WERR is DOUBLE PRECISION array, dimension *> dimension is >= (CLEND-CLSTRT+1) *> WERR contain the semiwidth of the uncertainty *> interval of the corresponding eigenvalue APPROXIMATION in W *> \endverbatim *> *> \param[in] SPDIAM *> \verbatim *> SPDIAM is DOUBLE PRECISION *> estimate of the spectral diameter obtained from the *> Gerschgorin intervals *> \endverbatim *> *> \param[in] CLGAPL *> \verbatim *> CLGAPL is DOUBLE PRECISION *> \endverbatim *> *> \param[in] CLGAPR *> \verbatim *> CLGAPR is DOUBLE PRECISION *> absolute gap on each end of the cluster. *> Set by the calling routine to protect against shifts too close *> to eigenvalues outside the cluster. *> \endverbatim *> *> \param[in] PIVMIN *> \verbatim *> PIVMIN is DOUBLE PRECISION *> The minimum pivot allowed in the Sturm sequence. *> \endverbatim *> *> \param[out] SIGMA *> \verbatim *> SIGMA is DOUBLE PRECISION *> The shift used to form L(+) D(+) L(+)^T. *> \endverbatim *> *> \param[out] DPLUS *> \verbatim *> DPLUS is DOUBLE PRECISION array, dimension (N) *> The N diagonal elements of the diagonal matrix D(+). *> \endverbatim *> *> \param[out] LPLUS *> \verbatim *> LPLUS is DOUBLE PRECISION array, dimension (N-1) *> The first (N-1) elements of LPLUS contain the subdiagonal *> elements of the unit bidiagonal matrix L(+). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (2*N) *> Workspace. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> Signals processing OK (=0) or failure (=1) *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup OTHERauxiliary * *> \par Contributors: * ================== *> *> Beresford Parlett, University of California, Berkeley, USA \n *> Jim Demmel, University of California, Berkeley, USA \n *> Inderjit Dhillon, University of Texas, Austin, USA \n *> Osni Marques, LBNL/NERSC, USA \n *> Christof Voemel, University of California, Berkeley, USA * * ===================================================================== SUBROUTINE DLARRF( N, D, L, LD, CLSTRT, CLEND, $ W, WGAP, WERR, $ SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA, $ DPLUS, LPLUS, WORK, INFO ) * * -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. INTEGER CLSTRT, CLEND, INFO, N DOUBLE PRECISION CLGAPL, CLGAPR, PIVMIN, SIGMA, SPDIAM * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), DPLUS( * ), L( * ), LD( * ), $ LPLUS( * ), W( * ), WGAP( * ), WERR( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION FOUR, MAXGROWTH1, MAXGROWTH2, ONE, QUART, TWO PARAMETER ( ONE = 1.0D0, TWO = 2.0D0, FOUR = 4.0D0, $ QUART = 0.25D0, $ MAXGROWTH1 = 8.D0, $ MAXGROWTH2 = 8.D0 ) * .. * .. Local Scalars .. LOGICAL DORRR1, FORCER, NOFAIL, SAWNAN1, SAWNAN2, TRYRRR1 INTEGER I, INDX, KTRY, KTRYMAX, SLEFT, SRIGHT, SHIFT PARAMETER ( KTRYMAX = 1, SLEFT = 1, SRIGHT = 2 ) DOUBLE PRECISION AVGAP, BESTSHIFT, CLWDTH, EPS, FACT, FAIL, $ FAIL2, GROWTHBOUND, LDELTA, LDMAX, LSIGMA, $ MAX1, MAX2, MINGAP, OLDP, PROD, RDELTA, RDMAX, $ RRR1, RRR2, RSIGMA, S, SMLGROWTH, TMP, ZNM2 * .. * .. External Functions .. LOGICAL DISNAN DOUBLE PRECISION DLAMCH EXTERNAL DISNAN, DLAMCH * .. * .. External Subroutines .. EXTERNAL DCOPY * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.LE.0 ) THEN RETURN END IF * FACT = DBLE(2**KTRYMAX) EPS = DLAMCH( 'Precision' ) SHIFT = 0 FORCER = .FALSE. * Note that we cannot guarantee that for any of the shifts tried, * the factorization has a small or even moderate element growth. * There could be Ritz values at both ends of the cluster and despite * backing off, there are examples where all factorizations tried * (in IEEE mode, allowing zero pivots & infinities) have INFINITE * element growth. * For this reason, we should use PIVMIN in this subroutine so that at * least the L D L^T factorization exists. It can be checked afterwards * whether the element growth caused bad residuals/orthogonality. * Decide whether the code should accept the best among all * representations despite large element growth or signal INFO=1 * Setting NOFAIL to .FALSE. for quick fix for bug 113 NOFAIL = .FALSE. * * Compute the average gap length of the cluster CLWDTH = ABS(W(CLEND)-W(CLSTRT)) + WERR(CLEND) + WERR(CLSTRT) AVGAP = CLWDTH / DBLE(CLEND-CLSTRT) MINGAP = MIN(CLGAPL, CLGAPR) * Initial values for shifts to both ends of cluster LSIGMA = MIN(W( CLSTRT ),W( CLEND )) - WERR( CLSTRT ) RSIGMA = MAX(W( CLSTRT ),W( CLEND )) + WERR( CLEND ) * Use a small fudge to make sure that we really shift to the outside LSIGMA = LSIGMA - ABS(LSIGMA)* FOUR * EPS RSIGMA = RSIGMA + ABS(RSIGMA)* FOUR * EPS * Compute upper bounds for how much to back off the initial shifts LDMAX = QUART * MINGAP + TWO * PIVMIN RDMAX = QUART * MINGAP + TWO * PIVMIN LDELTA = MAX(AVGAP,WGAP( CLSTRT ))/FACT RDELTA = MAX(AVGAP,WGAP( CLEND-1 ))/FACT * * Initialize the record of the best representation found * S = DLAMCH( 'S' ) SMLGROWTH = ONE / S FAIL = DBLE(N-1)*MINGAP/(SPDIAM*EPS) FAIL2 = DBLE(N-1)*MINGAP/(SPDIAM*SQRT(EPS)) BESTSHIFT = LSIGMA * * while (KTRY <= KTRYMAX) KTRY = 0 GROWTHBOUND = MAXGROWTH1*SPDIAM 5 CONTINUE SAWNAN1 = .FALSE. SAWNAN2 = .FALSE. * Ensure that we do not back off too much of the initial shifts LDELTA = MIN(LDMAX,LDELTA) RDELTA = MIN(RDMAX,RDELTA) * Compute the element growth when shifting to both ends of the cluster * accept the shift if there is no element growth at one of the two ends * Left end S = -LSIGMA DPLUS( 1 ) = D( 1 ) + S IF(ABS(DPLUS(1)).LT.PIVMIN) THEN DPLUS(1) = -PIVMIN * Need to set SAWNAN1 because refined RRR test should not be used * in this case SAWNAN1 = .TRUE. ENDIF MAX1 = ABS( DPLUS( 1 ) ) DO 6 I = 1, N - 1 LPLUS( I ) = LD( I ) / DPLUS( I ) S = S*LPLUS( I )*L( I ) - LSIGMA DPLUS( I+1 ) = D( I+1 ) + S IF(ABS(DPLUS(I+1)).LT.PIVMIN) THEN DPLUS(I+1) = -PIVMIN * Need to set SAWNAN1 because refined RRR test should not be used * in this case SAWNAN1 = .TRUE. ENDIF MAX1 = MAX( MAX1,ABS(DPLUS(I+1)) ) 6 CONTINUE SAWNAN1 = SAWNAN1 .OR. DISNAN( MAX1 ) IF( FORCER .OR. $ (MAX1.LE.GROWTHBOUND .AND. .NOT.SAWNAN1 ) ) THEN SIGMA = LSIGMA SHIFT = SLEFT GOTO 100 ENDIF * Right end S = -RSIGMA WORK( 1 ) = D( 1 ) + S IF(ABS(WORK(1)).LT.PIVMIN) THEN WORK(1) = -PIVMIN * Need to set SAWNAN2 because refined RRR test should not be used * in this case SAWNAN2 = .TRUE. ENDIF MAX2 = ABS( WORK( 1 ) ) DO 7 I = 1, N - 1 WORK( N+I ) = LD( I ) / WORK( I ) S = S*WORK( N+I )*L( I ) - RSIGMA WORK( I+1 ) = D( I+1 ) + S IF(ABS(WORK(I+1)).LT.PIVMIN) THEN WORK(I+1) = -PIVMIN * Need to set SAWNAN2 because refined RRR test should not be used * in this case SAWNAN2 = .TRUE. ENDIF MAX2 = MAX( MAX2,ABS(WORK(I+1)) ) 7 CONTINUE SAWNAN2 = SAWNAN2 .OR. DISNAN( MAX2 ) IF( FORCER .OR. $ (MAX2.LE.GROWTHBOUND .AND. .NOT.SAWNAN2 ) ) THEN SIGMA = RSIGMA SHIFT = SRIGHT GOTO 100 ENDIF * If we are at this point, both shifts led to too much element growth * Record the better of the two shifts (provided it didn't lead to NaN) IF(SAWNAN1.AND.SAWNAN2) THEN * both MAX1 and MAX2 are NaN GOTO 50 ELSE IF( .NOT.SAWNAN1 ) THEN INDX = 1 IF(MAX1.LE.SMLGROWTH) THEN SMLGROWTH = MAX1 BESTSHIFT = LSIGMA ENDIF ENDIF IF( .NOT.SAWNAN2 ) THEN IF(SAWNAN1 .OR. MAX2.LE.MAX1) INDX = 2 IF(MAX2.LE.SMLGROWTH) THEN SMLGROWTH = MAX2 BESTSHIFT = RSIGMA ENDIF ENDIF ENDIF * If we are here, both the left and the right shift led to * element growth. If the element growth is moderate, then * we may still accept the representation, if it passes a * refined test for RRR. This test supposes that no NaN occurred. * Moreover, we use the refined RRR test only for isolated clusters. IF((CLWDTH.LT.MINGAP/DBLE(128)) .AND. $ (MIN(MAX1,MAX2).LT.FAIL2) $ .AND.(.NOT.SAWNAN1).AND.(.NOT.SAWNAN2)) THEN DORRR1 = .TRUE. ELSE DORRR1 = .FALSE. ENDIF TRYRRR1 = .TRUE. IF( TRYRRR1 .AND. DORRR1 ) THEN IF(INDX.EQ.1) THEN TMP = ABS( DPLUS( N ) ) ZNM2 = ONE PROD = ONE OLDP = ONE DO 15 I = N-1, 1, -1 IF( PROD .LE. EPS ) THEN PROD = $ ((DPLUS(I+1)*WORK(N+I+1))/(DPLUS(I)*WORK(N+I)))*OLDP ELSE PROD = PROD*ABS(WORK(N+I)) END IF OLDP = PROD ZNM2 = ZNM2 + PROD**2 TMP = MAX( TMP, ABS( DPLUS( I ) * PROD )) 15 CONTINUE RRR1 = TMP/( SPDIAM * SQRT( ZNM2 ) ) IF (RRR1.LE.MAXGROWTH2) THEN SIGMA = LSIGMA SHIFT = SLEFT GOTO 100 ENDIF ELSE IF(INDX.EQ.2) THEN TMP = ABS( WORK( N ) ) ZNM2 = ONE PROD = ONE OLDP = ONE DO 16 I = N-1, 1, -1 IF( PROD .LE. EPS ) THEN PROD = ((WORK(I+1)*LPLUS(I+1))/(WORK(I)*LPLUS(I)))*OLDP ELSE PROD = PROD*ABS(LPLUS(I)) END IF OLDP = PROD ZNM2 = ZNM2 + PROD**2 TMP = MAX( TMP, ABS( WORK( I ) * PROD )) 16 CONTINUE RRR2 = TMP/( SPDIAM * SQRT( ZNM2 ) ) IF (RRR2.LE.MAXGROWTH2) THEN SIGMA = RSIGMA SHIFT = SRIGHT GOTO 100 ENDIF END IF ENDIF 50 CONTINUE IF (KTRY.LT.KTRYMAX) THEN * If we are here, both shifts failed also the RRR test. * Back off to the outside LSIGMA = MAX( LSIGMA - LDELTA, $ LSIGMA - LDMAX) RSIGMA = MIN( RSIGMA + RDELTA, $ RSIGMA + RDMAX ) LDELTA = TWO * LDELTA RDELTA = TWO * RDELTA KTRY = KTRY + 1 GOTO 5 ELSE * None of the representations investigated satisfied our * criteria. Take the best one we found. IF((SMLGROWTH.LT.FAIL).OR.NOFAIL) THEN LSIGMA = BESTSHIFT RSIGMA = BESTSHIFT FORCER = .TRUE. GOTO 5 ELSE INFO = 1 RETURN ENDIF END IF 100 CONTINUE IF (SHIFT.EQ.SLEFT) THEN ELSEIF (SHIFT.EQ.SRIGHT) THEN * store new L and D back into DPLUS, LPLUS CALL DCOPY( N, WORK, 1, DPLUS, 1 ) CALL DCOPY( N-1, WORK(N+1), 1, LPLUS, 1 ) ENDIF RETURN * * End of DLARRF * END *> \brief \b DLARRJ performs refinement of the initial estimates of the eigenvalues of the matrix T. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARRJ + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARRJ( N, D, E2, IFIRST, ILAST, * RTOL, OFFSET, W, WERR, WORK, IWORK, * PIVMIN, SPDIAM, INFO ) * * .. Scalar Arguments .. * INTEGER IFIRST, ILAST, INFO, N, OFFSET * DOUBLE PRECISION PIVMIN, RTOL, SPDIAM * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION D( * ), E2( * ), W( * ), * $ WERR( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> Given the initial eigenvalue approximations of T, DLARRJ *> does bisection to refine the eigenvalues of T, *> W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial *> guesses for these eigenvalues are input in W, the corresponding estimate *> of the error in these guesses in WERR. During bisection, intervals *> [left, right] are maintained by storing their mid-points and *> semi-widths in the arrays W and WERR respectively. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The N diagonal elements of T. *> \endverbatim *> *> \param[in] E2 *> \verbatim *> E2 is DOUBLE PRECISION array, dimension (N-1) *> The Squares of the (N-1) subdiagonal elements of T. *> \endverbatim *> *> \param[in] IFIRST *> \verbatim *> IFIRST is INTEGER *> The index of the first eigenvalue to be computed. *> \endverbatim *> *> \param[in] ILAST *> \verbatim *> ILAST is INTEGER *> The index of the last eigenvalue to be computed. *> \endverbatim *> *> \param[in] RTOL *> \verbatim *> RTOL is DOUBLE PRECISION *> Tolerance for the convergence of the bisection intervals. *> An interval [LEFT,RIGHT] has converged if *> RIGHT-LEFT.LT.RTOL*MAX(|LEFT|,|RIGHT|). *> \endverbatim *> *> \param[in] OFFSET *> \verbatim *> OFFSET is INTEGER *> Offset for the arrays W and WERR, i.e., the IFIRST-OFFSET *> through ILAST-OFFSET elements of these arrays are to be used. *> \endverbatim *> *> \param[in,out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are *> estimates of the eigenvalues of L D L^T indexed IFIRST through *> ILAST. *> On output, these estimates are refined. *> \endverbatim *> *> \param[in,out] WERR *> \verbatim *> WERR is DOUBLE PRECISION array, dimension (N) *> On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are *> the errors in the estimates of the corresponding elements in W. *> On output, these errors are refined. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (2*N) *> Workspace. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (2*N) *> Workspace. *> \endverbatim *> *> \param[in] PIVMIN *> \verbatim *> PIVMIN is DOUBLE PRECISION *> The minimum pivot in the Sturm sequence for T. *> \endverbatim *> *> \param[in] SPDIAM *> \verbatim *> SPDIAM is DOUBLE PRECISION *> The spectral diameter of T. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> Error flag. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup OTHERauxiliary * *> \par Contributors: * ================== *> *> Beresford Parlett, University of California, Berkeley, USA \n *> Jim Demmel, University of California, Berkeley, USA \n *> Inderjit Dhillon, University of Texas, Austin, USA \n *> Osni Marques, LBNL/NERSC, USA \n *> Christof Voemel, University of California, Berkeley, USA * * ===================================================================== SUBROUTINE DLARRJ( N, D, E2, IFIRST, ILAST, $ RTOL, OFFSET, W, WERR, WORK, IWORK, $ PIVMIN, SPDIAM, INFO ) * * -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. INTEGER IFIRST, ILAST, INFO, N, OFFSET DOUBLE PRECISION PIVMIN, RTOL, SPDIAM * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION D( * ), E2( * ), W( * ), $ WERR( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, HALF PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, $ HALF = 0.5D0 ) INTEGER MAXITR * .. * .. Local Scalars .. INTEGER CNT, I, I1, I2, II, ITER, J, K, NEXT, NINT, $ OLNINT, P, PREV, SAVI1 DOUBLE PRECISION DPLUS, FAC, LEFT, MID, RIGHT, S, TMP, WIDTH * * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.LE.0 ) THEN RETURN END IF * MAXITR = INT( ( LOG( SPDIAM+PIVMIN )-LOG( PIVMIN ) ) / $ LOG( TWO ) ) + 2 * * Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ]. * The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while * Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 ) * for an unconverged interval is set to the index of the next unconverged * interval, and is -1 or 0 for a converged interval. Thus a linked * list of unconverged intervals is set up. * I1 = IFIRST I2 = ILAST * The number of unconverged intervals NINT = 0 * The last unconverged interval found PREV = 0 DO 75 I = I1, I2 K = 2*I II = I - OFFSET LEFT = W( II ) - WERR( II ) MID = W(II) RIGHT = W( II ) + WERR( II ) WIDTH = RIGHT - MID TMP = MAX( ABS( LEFT ), ABS( RIGHT ) ) * The following test prevents the test of converged intervals IF( WIDTH.LT.RTOL*TMP ) THEN * This interval has already converged and does not need refinement. * (Note that the gaps might change through refining the * eigenvalues, however, they can only get bigger.) * Remove it from the list. IWORK( K-1 ) = -1 * Make sure that I1 always points to the first unconverged interval IF((I.EQ.I1).AND.(I.LT.I2)) I1 = I + 1 IF((PREV.GE.I1).AND.(I.LE.I2)) IWORK( 2*PREV-1 ) = I + 1 ELSE * unconverged interval found PREV = I * Make sure that [LEFT,RIGHT] contains the desired eigenvalue * * Do while( CNT(LEFT).GT.I-1 ) * FAC = ONE 20 CONTINUE CNT = 0 S = LEFT DPLUS = D( 1 ) - S IF( DPLUS.LT.ZERO ) CNT = CNT + 1 DO 30 J = 2, N DPLUS = D( J ) - S - E2( J-1 )/DPLUS IF( DPLUS.LT.ZERO ) CNT = CNT + 1 30 CONTINUE IF( CNT.GT.I-1 ) THEN LEFT = LEFT - WERR( II )*FAC FAC = TWO*FAC GO TO 20 END IF * * Do while( CNT(RIGHT).LT.I ) * FAC = ONE 50 CONTINUE CNT = 0 S = RIGHT DPLUS = D( 1 ) - S IF( DPLUS.LT.ZERO ) CNT = CNT + 1 DO 60 J = 2, N DPLUS = D( J ) - S - E2( J-1 )/DPLUS IF( DPLUS.LT.ZERO ) CNT = CNT + 1 60 CONTINUE IF( CNT.LT.I ) THEN RIGHT = RIGHT + WERR( II )*FAC FAC = TWO*FAC GO TO 50 END IF NINT = NINT + 1 IWORK( K-1 ) = I + 1 IWORK( K ) = CNT END IF WORK( K-1 ) = LEFT WORK( K ) = RIGHT 75 CONTINUE SAVI1 = I1 * * Do while( NINT.GT.0 ), i.e. there are still unconverged intervals * and while (ITER.LT.MAXITR) * ITER = 0 80 CONTINUE PREV = I1 - 1 I = I1 OLNINT = NINT DO 100 P = 1, OLNINT K = 2*I II = I - OFFSET NEXT = IWORK( K-1 ) LEFT = WORK( K-1 ) RIGHT = WORK( K ) MID = HALF*( LEFT + RIGHT ) * semiwidth of interval WIDTH = RIGHT - MID TMP = MAX( ABS( LEFT ), ABS( RIGHT ) ) IF( ( WIDTH.LT.RTOL*TMP ) .OR. $ (ITER.EQ.MAXITR) )THEN * reduce number of unconverged intervals NINT = NINT - 1 * Mark interval as converged. IWORK( K-1 ) = 0 IF( I1.EQ.I ) THEN I1 = NEXT ELSE * Prev holds the last unconverged interval previously examined IF(PREV.GE.I1) IWORK( 2*PREV-1 ) = NEXT END IF I = NEXT GO TO 100 END IF PREV = I * * Perform one bisection step * CNT = 0 S = MID DPLUS = D( 1 ) - S IF( DPLUS.LT.ZERO ) CNT = CNT + 1 DO 90 J = 2, N DPLUS = D( J ) - S - E2( J-1 )/DPLUS IF( DPLUS.LT.ZERO ) CNT = CNT + 1 90 CONTINUE IF( CNT.LE.I-1 ) THEN WORK( K-1 ) = MID ELSE WORK( K ) = MID END IF I = NEXT 100 CONTINUE ITER = ITER + 1 * do another loop if there are still unconverged intervals * However, in the last iteration, all intervals are accepted * since this is the best we can do. IF( ( NINT.GT.0 ).AND.(ITER.LE.MAXITR) ) GO TO 80 * * * At this point, all the intervals have converged DO 110 I = SAVI1, ILAST K = 2*I II = I - OFFSET * All intervals marked by '0' have been refined. IF( IWORK( K-1 ).EQ.0 ) THEN W( II ) = HALF*( WORK( K-1 )+WORK( K ) ) WERR( II ) = WORK( K ) - W( II ) END IF 110 CONTINUE * RETURN * * End of DLARRJ * END *> \brief \b DLARRK computes one eigenvalue of a symmetric tridiagonal matrix T to suitable accuracy. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARRK + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARRK( N, IW, GL, GU, * D, E2, PIVMIN, RELTOL, W, WERR, INFO) * * .. Scalar Arguments .. * INTEGER INFO, IW, N * DOUBLE PRECISION PIVMIN, RELTOL, GL, GU, W, WERR * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), E2( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLARRK computes one eigenvalue of a symmetric tridiagonal *> matrix T to suitable accuracy. This is an auxiliary code to be *> called from DSTEMR. *> *> To avoid overflow, the matrix must be scaled so that its *> largest element is no greater than overflow**(1/2) * underflow**(1/4) in absolute value, and for greatest *> accuracy, it should not be much smaller than that. *> *> See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal *> Matrix", Report CS41, Computer Science Dept., Stanford *> University, July 21, 1966. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the tridiagonal matrix T. N >= 0. *> \endverbatim *> *> \param[in] IW *> \verbatim *> IW is INTEGER *> The index of the eigenvalues to be returned. *> \endverbatim *> *> \param[in] GL *> \verbatim *> GL is DOUBLE PRECISION *> \endverbatim *> *> \param[in] GU *> \verbatim *> GU is DOUBLE PRECISION *> An upper and a lower bound on the eigenvalue. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The n diagonal elements of the tridiagonal matrix T. *> \endverbatim *> *> \param[in] E2 *> \verbatim *> E2 is DOUBLE PRECISION array, dimension (N-1) *> The (n-1) squared off-diagonal elements of the tridiagonal matrix T. *> \endverbatim *> *> \param[in] PIVMIN *> \verbatim *> PIVMIN is DOUBLE PRECISION *> The minimum pivot allowed in the Sturm sequence for T. *> \endverbatim *> *> \param[in] RELTOL *> \verbatim *> RELTOL is DOUBLE PRECISION *> The minimum relative width of an interval. When an interval *> is narrower than RELTOL times the larger (in *> magnitude) endpoint, then it is considered to be *> sufficiently small, i.e., converged. Note: this should *> always be at least radix*machine epsilon. *> \endverbatim *> *> \param[out] W *> \verbatim *> W is DOUBLE PRECISION *> \endverbatim *> *> \param[out] WERR *> \verbatim *> WERR is DOUBLE PRECISION *> The error bound on the corresponding eigenvalue approximation *> in W. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: Eigenvalue converged *> = -1: Eigenvalue did NOT converge *> \endverbatim * *> \par Internal Parameters: * ========================= *> *> \verbatim *> FUDGE DOUBLE PRECISION, default = 2 *> A "fudge factor" to widen the Gershgorin intervals. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLARRK( N, IW, GL, GU, $ D, E2, PIVMIN, RELTOL, W, WERR, INFO) * * -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. INTEGER INFO, IW, N DOUBLE PRECISION PIVMIN, RELTOL, GL, GU, W, WERR * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E2( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION FUDGE, HALF, TWO, ZERO PARAMETER ( HALF = 0.5D0, TWO = 2.0D0, $ FUDGE = TWO, ZERO = 0.0D0 ) * .. * .. Local Scalars .. INTEGER I, IT, ITMAX, NEGCNT DOUBLE PRECISION ATOLI, EPS, LEFT, MID, RIGHT, RTOLI, TMP1, $ TMP2, TNORM * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, INT, LOG, MAX * .. * .. Executable Statements .. * * Quick return if possible * IF( N.LE.0 ) THEN INFO = 0 RETURN END IF * * Get machine constants EPS = DLAMCH( 'P' ) TNORM = MAX( ABS( GL ), ABS( GU ) ) RTOLI = RELTOL ATOLI = FUDGE*TWO*PIVMIN ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) / $ LOG( TWO ) ) + 2 INFO = -1 LEFT = GL - FUDGE*TNORM*EPS*N - FUDGE*TWO*PIVMIN RIGHT = GU + FUDGE*TNORM*EPS*N + FUDGE*TWO*PIVMIN IT = 0 10 CONTINUE * * Check if interval converged or maximum number of iterations reached * TMP1 = ABS( RIGHT - LEFT ) TMP2 = MAX( ABS(RIGHT), ABS(LEFT) ) IF( TMP1.LT.MAX( ATOLI, PIVMIN, RTOLI*TMP2 ) ) THEN INFO = 0 GOTO 30 ENDIF IF(IT.GT.ITMAX) $ GOTO 30 * * Count number of negative pivots for mid-point * IT = IT + 1 MID = HALF * (LEFT + RIGHT) NEGCNT = 0 TMP1 = D( 1 ) - MID IF( ABS( TMP1 ).LT.PIVMIN ) $ TMP1 = -PIVMIN IF( TMP1.LE.ZERO ) $ NEGCNT = NEGCNT + 1 * DO 20 I = 2, N TMP1 = D( I ) - E2( I-1 ) / TMP1 - MID IF( ABS( TMP1 ).LT.PIVMIN ) $ TMP1 = -PIVMIN IF( TMP1.LE.ZERO ) $ NEGCNT = NEGCNT + 1 20 CONTINUE IF(NEGCNT.GE.IW) THEN RIGHT = MID ELSE LEFT = MID ENDIF GOTO 10 30 CONTINUE * * Converged or maximum number of iterations reached * W = HALF * (LEFT + RIGHT) WERR = HALF * ABS( RIGHT - LEFT ) RETURN * * End of DLARRK * END *> \brief \b DLARRR performs tests to decide whether the symmetric tridiagonal matrix T warrants expensive computations which guarantee high relative accuracy in the eigenvalues. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARRR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARRR( N, D, E, INFO ) * * .. Scalar Arguments .. * INTEGER N, INFO * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), E( * ) * .. * * * *> \par Purpose: * ============= *> *> \verbatim *> *> Perform tests to decide whether the symmetric tridiagonal matrix T *> warrants expensive computations which guarantee high relative accuracy *> in the eigenvalues. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix. N > 0. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The N diagonal elements of the tridiagonal matrix T. *> \endverbatim *> *> \param[in,out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N) *> On entry, the first (N-1) entries contain the subdiagonal *> elements of the tridiagonal matrix T; E(N) is set to ZERO. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> INFO = 0(default) : the matrix warrants computations preserving *> relative accuracy. *> INFO = 1 : the matrix warrants computations guaranteeing *> only absolute accuracy. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup OTHERauxiliary * *> \par Contributors: * ================== *> *> Beresford Parlett, University of California, Berkeley, USA \n *> Jim Demmel, University of California, Berkeley, USA \n *> Inderjit Dhillon, University of Texas, Austin, USA \n *> Osni Marques, LBNL/NERSC, USA \n *> Christof Voemel, University of California, Berkeley, USA * * ===================================================================== SUBROUTINE DLARRR( N, D, E, INFO ) * * -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. INTEGER N, INFO * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ) * .. * * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, RELCOND PARAMETER ( ZERO = 0.0D0, $ RELCOND = 0.999D0 ) * .. * .. Local Scalars .. INTEGER I LOGICAL YESREL DOUBLE PRECISION EPS, SAFMIN, SMLNUM, RMIN, TMP, TMP2, $ OFFDIG, OFFDIG2 * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * * Quick return if possible * IF( N.LE.0 ) THEN INFO = 0 RETURN END IF * * As a default, do NOT go for relative-accuracy preserving computations. INFO = 1 SAFMIN = DLAMCH( 'Safe minimum' ) EPS = DLAMCH( 'Precision' ) SMLNUM = SAFMIN / EPS RMIN = SQRT( SMLNUM ) * Tests for relative accuracy * * Test for scaled diagonal dominance * Scale the diagonal entries to one and check whether the sum of the * off-diagonals is less than one * * The sdd relative error bounds have a 1/(1- 2*x) factor in them, * x = max(OFFDIG + OFFDIG2), so when x is close to 1/2, no relative * accuracy is promised. In the notation of the code fragment below, * 1/(1 - (OFFDIG + OFFDIG2)) is the condition number. * We don't think it is worth going into "sdd mode" unless the relative * condition number is reasonable, not 1/macheps. * The threshold should be compatible with other thresholds used in the * code. We set OFFDIG + OFFDIG2 <= .999 =: RELCOND, it corresponds * to losing at most 3 decimal digits: 1 / (1 - (OFFDIG + OFFDIG2)) <= 1000 * instead of the current OFFDIG + OFFDIG2 < 1 * YESREL = .TRUE. OFFDIG = ZERO TMP = SQRT(ABS(D(1))) IF (TMP.LT.RMIN) YESREL = .FALSE. IF(.NOT.YESREL) GOTO 11 DO 10 I = 2, N TMP2 = SQRT(ABS(D(I))) IF (TMP2.LT.RMIN) YESREL = .FALSE. IF(.NOT.YESREL) GOTO 11 OFFDIG2 = ABS(E(I-1))/(TMP*TMP2) IF(OFFDIG+OFFDIG2.GE.RELCOND) YESREL = .FALSE. IF(.NOT.YESREL) GOTO 11 TMP = TMP2 OFFDIG = OFFDIG2 10 CONTINUE 11 CONTINUE IF( YESREL ) THEN INFO = 0 RETURN ELSE ENDIF * * * *** MORE TO BE IMPLEMENTED *** * * * Test if the lower bidiagonal matrix L from T = L D L^T * (zero shift facto) is well conditioned * * * Test if the upper bidiagonal matrix U from T = U D U^T * (zero shift facto) is well conditioned. * In this case, the matrix needs to be flipped and, at the end * of the eigenvector computation, the flip needs to be applied * to the computed eigenvectors (and the support) * * RETURN * * END OF DLARRR * END *> \brief \b DLARRV computes the eigenvectors of the tridiagonal matrix T = L D LT given L, D and the eigenvalues of L D LT. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARRV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARRV( N, VL, VU, D, L, PIVMIN, * ISPLIT, M, DOL, DOU, MINRGP, * RTOL1, RTOL2, W, WERR, WGAP, * IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, * WORK, IWORK, INFO ) * * .. Scalar Arguments .. * INTEGER DOL, DOU, INFO, LDZ, M, N * DOUBLE PRECISION MINRGP, PIVMIN, RTOL1, RTOL2, VL, VU * .. * .. Array Arguments .. * INTEGER IBLOCK( * ), INDEXW( * ), ISPLIT( * ), * $ ISUPPZ( * ), IWORK( * ) * DOUBLE PRECISION D( * ), GERS( * ), L( * ), W( * ), WERR( * ), * $ WGAP( * ), WORK( * ) * DOUBLE PRECISION Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLARRV computes the eigenvectors of the tridiagonal matrix *> T = L D L**T given L, D and APPROXIMATIONS to the eigenvalues of L D L**T. *> The input eigenvalues should have been computed by DLARRE. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix. N >= 0. *> \endverbatim *> *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION *> Lower bound of the interval that contains the desired *> eigenvalues. VL < VU. Needed to compute gaps on the left or right *> end of the extremal eigenvalues in the desired RANGE. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION *> Upper bound of the interval that contains the desired *> eigenvalues. VL < VU. *> Note: VU is currently not used by this implementation of DLARRV, VU is *> passed to DLARRV because it could be used compute gaps on the right end *> of the extremal eigenvalues. However, with not much initial accuracy in *> LAMBDA and VU, the formula can lead to an overestimation of the right gap *> and thus to inadequately early RQI 'convergence'. This is currently *> prevented this by forcing a small right gap. And so it turns out that VU *> is currently not used by this implementation of DLARRV. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> On entry, the N diagonal elements of the diagonal matrix D. *> On exit, D may be overwritten. *> \endverbatim *> *> \param[in,out] L *> \verbatim *> L is DOUBLE PRECISION array, dimension (N) *> On entry, the (N-1) subdiagonal elements of the unit *> bidiagonal matrix L are in elements 1 to N-1 of L *> (if the matrix is not split.) At the end of each block *> is stored the corresponding shift as given by DLARRE. *> On exit, L is overwritten. *> \endverbatim *> *> \param[in] PIVMIN *> \verbatim *> PIVMIN is DOUBLE PRECISION *> The minimum pivot allowed in the Sturm sequence. *> \endverbatim *> *> \param[in] ISPLIT *> \verbatim *> ISPLIT is INTEGER array, dimension (N) *> The splitting points, at which T breaks up into blocks. *> The first block consists of rows/columns 1 to *> ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 *> through ISPLIT( 2 ), etc. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The total number of input eigenvalues. 0 <= M <= N. *> \endverbatim *> *> \param[in] DOL *> \verbatim *> DOL is INTEGER *> \endverbatim *> *> \param[in] DOU *> \verbatim *> DOU is INTEGER *> If the user wants to compute only selected eigenvectors from all *> the eigenvalues supplied, he can specify an index range DOL:DOU. *> Or else the setting DOL=1, DOU=M should be applied. *> Note that DOL and DOU refer to the order in which the eigenvalues *> are stored in W. *> If the user wants to compute only selected eigenpairs, then *> the columns DOL-1 to DOU+1 of the eigenvector space Z contain the *> computed eigenvectors. All other columns of Z are set to zero. *> \endverbatim *> *> \param[in] MINRGP *> \verbatim *> MINRGP is DOUBLE PRECISION *> \endverbatim *> *> \param[in] RTOL1 *> \verbatim *> RTOL1 is DOUBLE PRECISION *> \endverbatim *> *> \param[in] RTOL2 *> \verbatim *> RTOL2 is DOUBLE PRECISION *> Parameters for bisection. *> An interval [LEFT,RIGHT] has converged if *> RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) *> \endverbatim *> *> \param[in,out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> The first M elements of W contain the APPROXIMATE eigenvalues for *> which eigenvectors are to be computed. The eigenvalues *> should be grouped by split-off block and ordered from *> smallest to largest within the block ( The output array *> W from DLARRE is expected here ). Furthermore, they are with *> respect to the shift of the corresponding root representation *> for their block. On exit, W holds the eigenvalues of the *> UNshifted matrix. *> \endverbatim *> *> \param[in,out] WERR *> \verbatim *> WERR is DOUBLE PRECISION array, dimension (N) *> The first M elements contain the semiwidth of the uncertainty *> interval of the corresponding eigenvalue in W *> \endverbatim *> *> \param[in,out] WGAP *> \verbatim *> WGAP is DOUBLE PRECISION array, dimension (N) *> The separation from the right neighbor eigenvalue in W. *> \endverbatim *> *> \param[in] IBLOCK *> \verbatim *> IBLOCK is INTEGER array, dimension (N) *> The indices of the blocks (submatrices) associated with the *> corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue *> W(i) belongs to the first block from the top, =2 if W(i) *> belongs to the second block, etc. *> \endverbatim *> *> \param[in] INDEXW *> \verbatim *> INDEXW is INTEGER array, dimension (N) *> The indices of the eigenvalues within each block (submatrix); *> for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the *> i-th eigenvalue W(i) is the 10-th eigenvalue in the second block. *> \endverbatim *> *> \param[in] GERS *> \verbatim *> GERS is DOUBLE PRECISION array, dimension (2*N) *> The N Gerschgorin intervals (the i-th Gerschgorin interval *> is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should *> be computed from the original UNshifted matrix. *> \endverbatim *> *> \param[out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M) ) *> If INFO = 0, the first M columns of Z contain the *> orthonormal eigenvectors of the matrix T *> corresponding to the input eigenvalues, with the i-th *> column of Z holding the eigenvector associated with W(i). *> Note: the user must ensure that at least max(1,M) columns are *> supplied in the array Z. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1, and if *> JOBZ = 'V', LDZ >= max(1,N). *> \endverbatim *> *> \param[out] ISUPPZ *> \verbatim *> ISUPPZ is INTEGER array, dimension ( 2*max(1,M) ) *> The support of the eigenvectors in Z, i.e., the indices *> indicating the nonzero elements in Z. The I-th eigenvector *> is nonzero only in elements ISUPPZ( 2*I-1 ) through *> ISUPPZ( 2*I ). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (12*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (7*N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> *> > 0: A problem occurred in DLARRV. *> < 0: One of the called subroutines signaled an internal problem. *> Needs inspection of the corresponding parameter IINFO *> for further information. *> *> =-1: Problem in DLARRB when refining a child's eigenvalues. *> =-2: Problem in DLARRF when computing the RRR of a child. *> When a child is inside a tight cluster, it can be difficult *> to find an RRR. A partial remedy from the user's point of *> view is to make the parameter MINRGP smaller and recompile. *> However, as the orthogonality of the computed vectors is *> proportional to 1/MINRGP, the user should be aware that *> he might be trading in precision when he decreases MINRGP. *> =-3: Problem in DLARRB when refining a single eigenvalue *> after the Rayleigh correction was rejected. *> = 5: The Rayleigh Quotient Iteration failed to converge to *> full accuracy in MAXITR steps. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Contributors: * ================== *> *> Beresford Parlett, University of California, Berkeley, USA \n *> Jim Demmel, University of California, Berkeley, USA \n *> Inderjit Dhillon, University of Texas, Austin, USA \n *> Osni Marques, LBNL/NERSC, USA \n *> Christof Voemel, University of California, Berkeley, USA * * ===================================================================== SUBROUTINE DLARRV( N, VL, VU, D, L, PIVMIN, $ ISPLIT, M, DOL, DOU, MINRGP, $ RTOL1, RTOL2, W, WERR, WGAP, $ IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, $ WORK, IWORK, INFO ) * * -- LAPACK auxiliary routine (version 3.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. INTEGER DOL, DOU, INFO, LDZ, M, N DOUBLE PRECISION MINRGP, PIVMIN, RTOL1, RTOL2, VL, VU * .. * .. Array Arguments .. INTEGER IBLOCK( * ), INDEXW( * ), ISPLIT( * ), $ ISUPPZ( * ), IWORK( * ) DOUBLE PRECISION D( * ), GERS( * ), L( * ), W( * ), WERR( * ), $ WGAP( * ), WORK( * ) DOUBLE PRECISION Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER MAXITR PARAMETER ( MAXITR = 10 ) DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, HALF PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, $ TWO = 2.0D0, THREE = 3.0D0, $ FOUR = 4.0D0, HALF = 0.5D0) * .. * .. Local Scalars .. LOGICAL ESKIP, NEEDBS, STP2II, TRYRQC, USEDBS, USEDRQ INTEGER DONE, I, IBEGIN, IDONE, IEND, II, IINDC1, $ IINDC2, IINDR, IINDWK, IINFO, IM, IN, INDEIG, $ INDLD, INDLLD, INDWRK, ISUPMN, ISUPMX, ITER, $ ITMP1, J, JBLK, K, MINIWSIZE, MINWSIZE, NCLUS, $ NDEPTH, NEGCNT, NEWCLS, NEWFST, NEWFTT, NEWLST, $ NEWSIZ, OFFSET, OLDCLS, OLDFST, OLDIEN, OLDLST, $ OLDNCL, P, PARITY, Q, WBEGIN, WEND, WINDEX, $ WINDMN, WINDPL, ZFROM, ZTO, ZUSEDL, ZUSEDU, $ ZUSEDW DOUBLE PRECISION BSTRES, BSTW, EPS, FUDGE, GAP, GAPTOL, GL, GU, $ LAMBDA, LEFT, LGAP, MINGMA, NRMINV, RESID, $ RGAP, RIGHT, RQCORR, RQTOL, SAVGAP, SGNDEF, $ SIGMA, SPDIAM, SSIGMA, TAU, TMP, TOL, ZTZ * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. External Subroutines .. EXTERNAL DCOPY, DLAR1V, DLARRB, DLARRF, DLASET, $ DSCAL * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN * .. * .. Executable Statements .. * .. INFO = 0 * * Quick return if possible * IF( N.LE.0 ) THEN RETURN END IF * * The first N entries of WORK are reserved for the eigenvalues INDLD = N+1 INDLLD= 2*N+1 INDWRK= 3*N+1 MINWSIZE = 12 * N DO 5 I= 1,MINWSIZE WORK( I ) = ZERO 5 CONTINUE * IWORK(IINDR+1:IINDR+N) hold the twist indices R for the * factorization used to compute the FP vector IINDR = 0 * IWORK(IINDC1+1:IINC2+N) are used to store the clusters of the current * layer and the one above. IINDC1 = N IINDC2 = 2*N IINDWK = 3*N + 1 MINIWSIZE = 7 * N DO 10 I= 1,MINIWSIZE IWORK( I ) = 0 10 CONTINUE ZUSEDL = 1 IF(DOL.GT.1) THEN * Set lower bound for use of Z ZUSEDL = DOL-1 ENDIF ZUSEDU = M IF(DOU.LT.M) THEN * Set lower bound for use of Z ZUSEDU = DOU+1 ENDIF * The width of the part of Z that is used ZUSEDW = ZUSEDU - ZUSEDL + 1 CALL DLASET( 'Full', N, ZUSEDW, ZERO, ZERO, $ Z(1,ZUSEDL), LDZ ) EPS = DLAMCH( 'Precision' ) RQTOL = TWO * EPS * * Set expert flags for standard code. TRYRQC = .TRUE. IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN ELSE * Only selected eigenpairs are computed. Since the other evalues * are not refined by RQ iteration, bisection has to compute to full * accuracy. RTOL1 = FOUR * EPS RTOL2 = FOUR * EPS ENDIF * The entries WBEGIN:WEND in W, WERR, WGAP correspond to the * desired eigenvalues. The support of the nonzero eigenvector * entries is contained in the interval IBEGIN:IEND. * Remark that if k eigenpairs are desired, then the eigenvectors * are stored in k contiguous columns of Z. * DONE is the number of eigenvectors already computed DONE = 0 IBEGIN = 1 WBEGIN = 1 DO 170 JBLK = 1, IBLOCK( M ) IEND = ISPLIT( JBLK ) SIGMA = L( IEND ) * Find the eigenvectors of the submatrix indexed IBEGIN * through IEND. WEND = WBEGIN - 1 15 CONTINUE IF( WEND.LT.M ) THEN IF( IBLOCK( WEND+1 ).EQ.JBLK ) THEN WEND = WEND + 1 GO TO 15 END IF END IF IF( WEND.LT.WBEGIN ) THEN IBEGIN = IEND + 1 GO TO 170 ELSEIF( (WEND.LT.DOL).OR.(WBEGIN.GT.DOU) ) THEN IBEGIN = IEND + 1 WBEGIN = WEND + 1 GO TO 170 END IF * Find local spectral diameter of the block GL = GERS( 2*IBEGIN-1 ) GU = GERS( 2*IBEGIN ) DO 20 I = IBEGIN+1 , IEND GL = MIN( GERS( 2*I-1 ), GL ) GU = MAX( GERS( 2*I ), GU ) 20 CONTINUE SPDIAM = GU - GL * OLDIEN is the last index of the previous block OLDIEN = IBEGIN - 1 * Calculate the size of the current block IN = IEND - IBEGIN + 1 * The number of eigenvalues in the current block IM = WEND - WBEGIN + 1 * This is for a 1x1 block IF( IBEGIN.EQ.IEND ) THEN DONE = DONE+1 Z( IBEGIN, WBEGIN ) = ONE ISUPPZ( 2*WBEGIN-1 ) = IBEGIN ISUPPZ( 2*WBEGIN ) = IBEGIN W( WBEGIN ) = W( WBEGIN ) + SIGMA WORK( WBEGIN ) = W( WBEGIN ) IBEGIN = IEND + 1 WBEGIN = WBEGIN + 1 GO TO 170 END IF * The desired (shifted) eigenvalues are stored in W(WBEGIN:WEND) * Note that these can be approximations, in this case, the corresp. * entries of WERR give the size of the uncertainty interval. * The eigenvalue approximations will be refined when necessary as * high relative accuracy is required for the computation of the * corresponding eigenvectors. CALL DCOPY( IM, W( WBEGIN ), 1, $ WORK( WBEGIN ), 1 ) * We store in W the eigenvalue approximations w.r.t. the original * matrix T. DO 30 I=1,IM W(WBEGIN+I-1) = W(WBEGIN+I-1)+SIGMA 30 CONTINUE * NDEPTH is the current depth of the representation tree NDEPTH = 0 * PARITY is either 1 or 0 PARITY = 1 * NCLUS is the number of clusters for the next level of the * representation tree, we start with NCLUS = 1 for the root NCLUS = 1 IWORK( IINDC1+1 ) = 1 IWORK( IINDC1+2 ) = IM * IDONE is the number of eigenvectors already computed in the current * block IDONE = 0 * loop while( IDONE.LT.IM ) * generate the representation tree for the current block and * compute the eigenvectors 40 CONTINUE IF( IDONE.LT.IM ) THEN * This is a crude protection against infinitely deep trees IF( NDEPTH.GT.M ) THEN INFO = -2 RETURN ENDIF * breadth first processing of the current level of the representation * tree: OLDNCL = number of clusters on current level OLDNCL = NCLUS * reset NCLUS to count the number of child clusters NCLUS = 0 * PARITY = 1 - PARITY IF( PARITY.EQ.0 ) THEN OLDCLS = IINDC1 NEWCLS = IINDC2 ELSE OLDCLS = IINDC2 NEWCLS = IINDC1 END IF * Process the clusters on the current level DO 150 I = 1, OLDNCL J = OLDCLS + 2*I * OLDFST, OLDLST = first, last index of current cluster. * cluster indices start with 1 and are relative * to WBEGIN when accessing W, WGAP, WERR, Z OLDFST = IWORK( J-1 ) OLDLST = IWORK( J ) IF( NDEPTH.GT.0 ) THEN * Retrieve relatively robust representation (RRR) of cluster * that has been computed at the previous level * The RRR is stored in Z and overwritten once the eigenvectors * have been computed or when the cluster is refined IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN * Get representation from location of the leftmost evalue * of the cluster J = WBEGIN + OLDFST - 1 ELSE IF(WBEGIN+OLDFST-1.LT.DOL) THEN * Get representation from the left end of Z array J = DOL - 1 ELSEIF(WBEGIN+OLDFST-1.GT.DOU) THEN * Get representation from the right end of Z array J = DOU ELSE J = WBEGIN + OLDFST - 1 ENDIF ENDIF CALL DCOPY( IN, Z( IBEGIN, J ), 1, D( IBEGIN ), 1 ) CALL DCOPY( IN-1, Z( IBEGIN, J+1 ), 1, L( IBEGIN ), $ 1 ) SIGMA = Z( IEND, J+1 ) * Set the corresponding entries in Z to zero CALL DLASET( 'Full', IN, 2, ZERO, ZERO, $ Z( IBEGIN, J), LDZ ) END IF * Compute DL and DLL of current RRR DO 50 J = IBEGIN, IEND-1 TMP = D( J )*L( J ) WORK( INDLD-1+J ) = TMP WORK( INDLLD-1+J ) = TMP*L( J ) 50 CONTINUE IF( NDEPTH.GT.0 ) THEN * P and Q are index of the first and last eigenvalue to compute * within the current block P = INDEXW( WBEGIN-1+OLDFST ) Q = INDEXW( WBEGIN-1+OLDLST ) * Offset for the arrays WORK, WGAP and WERR, i.e., the P-OFFSET * through the Q-OFFSET elements of these arrays are to be used. * OFFSET = P-OLDFST OFFSET = INDEXW( WBEGIN ) - 1 * perform limited bisection (if necessary) to get approximate * eigenvalues to the precision needed. CALL DLARRB( IN, D( IBEGIN ), $ WORK(INDLLD+IBEGIN-1), $ P, Q, RTOL1, RTOL2, OFFSET, $ WORK(WBEGIN),WGAP(WBEGIN),WERR(WBEGIN), $ WORK( INDWRK ), IWORK( IINDWK ), $ PIVMIN, SPDIAM, IN, IINFO ) IF( IINFO.NE.0 ) THEN INFO = -1 RETURN ENDIF * We also recompute the extremal gaps. W holds all eigenvalues * of the unshifted matrix and must be used for computation * of WGAP, the entries of WORK might stem from RRRs with * different shifts. The gaps from WBEGIN-1+OLDFST to * WBEGIN-1+OLDLST are correctly computed in DLARRB. * However, we only allow the gaps to become greater since * this is what should happen when we decrease WERR IF( OLDFST.GT.1) THEN WGAP( WBEGIN+OLDFST-2 ) = $ MAX(WGAP(WBEGIN+OLDFST-2), $ W(WBEGIN+OLDFST-1)-WERR(WBEGIN+OLDFST-1) $ - W(WBEGIN+OLDFST-2)-WERR(WBEGIN+OLDFST-2) ) ENDIF IF( WBEGIN + OLDLST -1 .LT. WEND ) THEN WGAP( WBEGIN+OLDLST-1 ) = $ MAX(WGAP(WBEGIN+OLDLST-1), $ W(WBEGIN+OLDLST)-WERR(WBEGIN+OLDLST) $ - W(WBEGIN+OLDLST-1)-WERR(WBEGIN+OLDLST-1) ) ENDIF * Each time the eigenvalues in WORK get refined, we store * the newly found approximation with all shifts applied in W DO 53 J=OLDFST,OLDLST W(WBEGIN+J-1) = WORK(WBEGIN+J-1)+SIGMA 53 CONTINUE END IF * Process the current node. NEWFST = OLDFST DO 140 J = OLDFST, OLDLST IF( J.EQ.OLDLST ) THEN * we are at the right end of the cluster, this is also the * boundary of the child cluster NEWLST = J ELSE IF ( WGAP( WBEGIN + J -1).GE. $ MINRGP* ABS( WORK(WBEGIN + J -1) ) ) THEN * the right relative gap is big enough, the child cluster * (NEWFST,..,NEWLST) is well separated from the following NEWLST = J ELSE * inside a child cluster, the relative gap is not * big enough. GOTO 140 END IF * Compute size of child cluster found NEWSIZ = NEWLST - NEWFST + 1 * NEWFTT is the place in Z where the new RRR or the computed * eigenvector is to be stored IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN * Store representation at location of the leftmost evalue * of the cluster NEWFTT = WBEGIN + NEWFST - 1 ELSE IF(WBEGIN+NEWFST-1.LT.DOL) THEN * Store representation at the left end of Z array NEWFTT = DOL - 1 ELSEIF(WBEGIN+NEWFST-1.GT.DOU) THEN * Store representation at the right end of Z array NEWFTT = DOU ELSE NEWFTT = WBEGIN + NEWFST - 1 ENDIF ENDIF IF( NEWSIZ.GT.1) THEN * * Current child is not a singleton but a cluster. * Compute and store new representation of child. * * * Compute left and right cluster gap. * * LGAP and RGAP are not computed from WORK because * the eigenvalue approximations may stem from RRRs * different shifts. However, W hold all eigenvalues * of the unshifted matrix. Still, the entries in WGAP * have to be computed from WORK since the entries * in W might be of the same order so that gaps are not * exhibited correctly for very close eigenvalues. IF( NEWFST.EQ.1 ) THEN LGAP = MAX( ZERO, $ W(WBEGIN)-WERR(WBEGIN) - VL ) ELSE LGAP = WGAP( WBEGIN+NEWFST-2 ) ENDIF RGAP = WGAP( WBEGIN+NEWLST-1 ) * * Compute left- and rightmost eigenvalue of child * to high precision in order to shift as close * as possible and obtain as large relative gaps * as possible * DO 55 K =1,2 IF(K.EQ.1) THEN P = INDEXW( WBEGIN-1+NEWFST ) ELSE P = INDEXW( WBEGIN-1+NEWLST ) ENDIF OFFSET = INDEXW( WBEGIN ) - 1 CALL DLARRB( IN, D(IBEGIN), $ WORK( INDLLD+IBEGIN-1 ),P,P, $ RQTOL, RQTOL, OFFSET, $ WORK(WBEGIN),WGAP(WBEGIN), $ WERR(WBEGIN),WORK( INDWRK ), $ IWORK( IINDWK ), PIVMIN, SPDIAM, $ IN, IINFO ) 55 CONTINUE * IF((WBEGIN+NEWLST-1.LT.DOL).OR. $ (WBEGIN+NEWFST-1.GT.DOU)) THEN * if the cluster contains no desired eigenvalues * skip the computation of that branch of the rep. tree * * We could skip before the refinement of the extremal * eigenvalues of the child, but then the representation * tree could be different from the one when nothing is * skipped. For this reason we skip at this place. IDONE = IDONE + NEWLST - NEWFST + 1 GOTO 139 ENDIF * * Compute RRR of child cluster. * Note that the new RRR is stored in Z * * DLARRF needs LWORK = 2*N CALL DLARRF( IN, D( IBEGIN ), L( IBEGIN ), $ WORK(INDLD+IBEGIN-1), $ NEWFST, NEWLST, WORK(WBEGIN), $ WGAP(WBEGIN), WERR(WBEGIN), $ SPDIAM, LGAP, RGAP, PIVMIN, TAU, $ Z(IBEGIN, NEWFTT),Z(IBEGIN, NEWFTT+1), $ WORK( INDWRK ), IINFO ) IF( IINFO.EQ.0 ) THEN * a new RRR for the cluster was found by DLARRF * update shift and store it SSIGMA = SIGMA + TAU Z( IEND, NEWFTT+1 ) = SSIGMA * WORK() are the midpoints and WERR() the semi-width * Note that the entries in W are unchanged. DO 116 K = NEWFST, NEWLST FUDGE = $ THREE*EPS*ABS(WORK(WBEGIN+K-1)) WORK( WBEGIN + K - 1 ) = $ WORK( WBEGIN + K - 1) - TAU FUDGE = FUDGE + $ FOUR*EPS*ABS(WORK(WBEGIN+K-1)) * Fudge errors WERR( WBEGIN + K - 1 ) = $ WERR( WBEGIN + K - 1 ) + FUDGE * Gaps are not fudged. Provided that WERR is small * when eigenvalues are close, a zero gap indicates * that a new representation is needed for resolving * the cluster. A fudge could lead to a wrong decision * of judging eigenvalues 'separated' which in * reality are not. This could have a negative impact * on the orthogonality of the computed eigenvectors. 116 CONTINUE NCLUS = NCLUS + 1 K = NEWCLS + 2*NCLUS IWORK( K-1 ) = NEWFST IWORK( K ) = NEWLST ELSE INFO = -2 RETURN ENDIF ELSE * * Compute eigenvector of singleton * ITER = 0 * TOL = FOUR * LOG(DBLE(IN)) * EPS * K = NEWFST WINDEX = WBEGIN + K - 1 WINDMN = MAX(WINDEX - 1,1) WINDPL = MIN(WINDEX + 1,M) LAMBDA = WORK( WINDEX ) DONE = DONE + 1 * Check if eigenvector computation is to be skipped IF((WINDEX.LT.DOL).OR. $ (WINDEX.GT.DOU)) THEN ESKIP = .TRUE. GOTO 125 ELSE ESKIP = .FALSE. ENDIF LEFT = WORK( WINDEX ) - WERR( WINDEX ) RIGHT = WORK( WINDEX ) + WERR( WINDEX ) INDEIG = INDEXW( WINDEX ) * Note that since we compute the eigenpairs for a child, * all eigenvalue approximations are w.r.t the same shift. * In this case, the entries in WORK should be used for * computing the gaps since they exhibit even very small * differences in the eigenvalues, as opposed to the * entries in W which might "look" the same. IF( K .EQ. 1) THEN * In the case RANGE='I' and with not much initial * accuracy in LAMBDA and VL, the formula * LGAP = MAX( ZERO, (SIGMA - VL) + LAMBDA ) * can lead to an overestimation of the left gap and * thus to inadequately early RQI 'convergence'. * Prevent this by forcing a small left gap. LGAP = EPS*MAX(ABS(LEFT),ABS(RIGHT)) ELSE LGAP = WGAP(WINDMN) ENDIF IF( K .EQ. IM) THEN * In the case RANGE='I' and with not much initial * accuracy in LAMBDA and VU, the formula * can lead to an overestimation of the right gap and * thus to inadequately early RQI 'convergence'. * Prevent this by forcing a small right gap. RGAP = EPS*MAX(ABS(LEFT),ABS(RIGHT)) ELSE RGAP = WGAP(WINDEX) ENDIF GAP = MIN( LGAP, RGAP ) IF(( K .EQ. 1).OR.(K .EQ. IM)) THEN * The eigenvector support can become wrong * because significant entries could be cut off due to a * large GAPTOL parameter in LAR1V. Prevent this. GAPTOL = ZERO ELSE GAPTOL = GAP * EPS ENDIF ISUPMN = IN ISUPMX = 1 * Update WGAP so that it holds the minimum gap * to the left or the right. This is crucial in the * case where bisection is used to ensure that the * eigenvalue is refined up to the required precision. * The correct value is restored afterwards. SAVGAP = WGAP(WINDEX) WGAP(WINDEX) = GAP * We want to use the Rayleigh Quotient Correction * as often as possible since it converges quadratically * when we are close enough to the desired eigenvalue. * However, the Rayleigh Quotient can have the wrong sign * and lead us away from the desired eigenvalue. In this * case, the best we can do is to use bisection. USEDBS = .FALSE. USEDRQ = .FALSE. * Bisection is initially turned off unless it is forced NEEDBS = .NOT.TRYRQC 120 CONTINUE * Check if bisection should be used to refine eigenvalue IF(NEEDBS) THEN * Take the bisection as new iterate USEDBS = .TRUE. ITMP1 = IWORK( IINDR+WINDEX ) OFFSET = INDEXW( WBEGIN ) - 1 CALL DLARRB( IN, D(IBEGIN), $ WORK(INDLLD+IBEGIN-1),INDEIG,INDEIG, $ ZERO, TWO*EPS, OFFSET, $ WORK(WBEGIN),WGAP(WBEGIN), $ WERR(WBEGIN),WORK( INDWRK ), $ IWORK( IINDWK ), PIVMIN, SPDIAM, $ ITMP1, IINFO ) IF( IINFO.NE.0 ) THEN INFO = -3 RETURN ENDIF LAMBDA = WORK( WINDEX ) * Reset twist index from inaccurate LAMBDA to * force computation of true MINGMA IWORK( IINDR+WINDEX ) = 0 ENDIF * Given LAMBDA, compute the eigenvector. CALL DLAR1V( IN, 1, IN, LAMBDA, D( IBEGIN ), $ L( IBEGIN ), WORK(INDLD+IBEGIN-1), $ WORK(INDLLD+IBEGIN-1), $ PIVMIN, GAPTOL, Z( IBEGIN, WINDEX ), $ .NOT.USEDBS, NEGCNT, ZTZ, MINGMA, $ IWORK( IINDR+WINDEX ), ISUPPZ( 2*WINDEX-1 ), $ NRMINV, RESID, RQCORR, WORK( INDWRK ) ) IF(ITER .EQ. 0) THEN BSTRES = RESID BSTW = LAMBDA ELSEIF(RESID.LT.BSTRES) THEN BSTRES = RESID BSTW = LAMBDA ENDIF ISUPMN = MIN(ISUPMN,ISUPPZ( 2*WINDEX-1 )) ISUPMX = MAX(ISUPMX,ISUPPZ( 2*WINDEX )) ITER = ITER + 1 * sin alpha <= |resid|/gap * Note that both the residual and the gap are * proportional to the matrix, so ||T|| doesn't play * a role in the quotient * * Convergence test for Rayleigh-Quotient iteration * (omitted when Bisection has been used) * IF( RESID.GT.TOL*GAP .AND. ABS( RQCORR ).GT. $ RQTOL*ABS( LAMBDA ) .AND. .NOT. USEDBS) $ THEN * We need to check that the RQCORR update doesn't * move the eigenvalue away from the desired one and * towards a neighbor. -> protection with bisection IF(INDEIG.LE.NEGCNT) THEN * The wanted eigenvalue lies to the left SGNDEF = -ONE ELSE * The wanted eigenvalue lies to the right SGNDEF = ONE ENDIF * We only use the RQCORR if it improves the * the iterate reasonably. IF( ( RQCORR*SGNDEF.GE.ZERO ) $ .AND.( LAMBDA + RQCORR.LE. RIGHT) $ .AND.( LAMBDA + RQCORR.GE. LEFT) $ ) THEN USEDRQ = .TRUE. * Store new midpoint of bisection interval in WORK IF(SGNDEF.EQ.ONE) THEN * The current LAMBDA is on the left of the true * eigenvalue LEFT = LAMBDA * We prefer to assume that the error estimate * is correct. We could make the interval not * as a bracket but to be modified if the RQCORR * chooses to. In this case, the RIGHT side should * be modified as follows: * RIGHT = MAX(RIGHT, LAMBDA + RQCORR) ELSE * The current LAMBDA is on the right of the true * eigenvalue RIGHT = LAMBDA * See comment about assuming the error estimate is * correct above. * LEFT = MIN(LEFT, LAMBDA + RQCORR) ENDIF WORK( WINDEX ) = $ HALF * (RIGHT + LEFT) * Take RQCORR since it has the correct sign and * improves the iterate reasonably LAMBDA = LAMBDA + RQCORR * Update width of error interval WERR( WINDEX ) = $ HALF * (RIGHT-LEFT) ELSE NEEDBS = .TRUE. ENDIF IF(RIGHT-LEFT.LT.RQTOL*ABS(LAMBDA)) THEN * The eigenvalue is computed to bisection accuracy * compute eigenvector and stop USEDBS = .TRUE. GOTO 120 ELSEIF( ITER.LT.MAXITR ) THEN GOTO 120 ELSEIF( ITER.EQ.MAXITR ) THEN NEEDBS = .TRUE. GOTO 120 ELSE INFO = 5 RETURN END IF ELSE STP2II = .FALSE. IF(USEDRQ .AND. USEDBS .AND. $ BSTRES.LE.RESID) THEN LAMBDA = BSTW STP2II = .TRUE. ENDIF IF (STP2II) THEN * improve error angle by second step CALL DLAR1V( IN, 1, IN, LAMBDA, $ D( IBEGIN ), L( IBEGIN ), $ WORK(INDLD+IBEGIN-1), $ WORK(INDLLD+IBEGIN-1), $ PIVMIN, GAPTOL, Z( IBEGIN, WINDEX ), $ .NOT.USEDBS, NEGCNT, ZTZ, MINGMA, $ IWORK( IINDR+WINDEX ), $ ISUPPZ( 2*WINDEX-1 ), $ NRMINV, RESID, RQCORR, WORK( INDWRK ) ) ENDIF WORK( WINDEX ) = LAMBDA END IF * * Compute FP-vector support w.r.t. whole matrix * ISUPPZ( 2*WINDEX-1 ) = ISUPPZ( 2*WINDEX-1 )+OLDIEN ISUPPZ( 2*WINDEX ) = ISUPPZ( 2*WINDEX )+OLDIEN ZFROM = ISUPPZ( 2*WINDEX-1 ) ZTO = ISUPPZ( 2*WINDEX ) ISUPMN = ISUPMN + OLDIEN ISUPMX = ISUPMX + OLDIEN * Ensure vector is ok if support in the RQI has changed IF(ISUPMN.LT.ZFROM) THEN DO 122 II = ISUPMN,ZFROM-1 Z( II, WINDEX ) = ZERO 122 CONTINUE ENDIF IF(ISUPMX.GT.ZTO) THEN DO 123 II = ZTO+1,ISUPMX Z( II, WINDEX ) = ZERO 123 CONTINUE ENDIF CALL DSCAL( ZTO-ZFROM+1, NRMINV, $ Z( ZFROM, WINDEX ), 1 ) 125 CONTINUE * Update W W( WINDEX ) = LAMBDA+SIGMA * Recompute the gaps on the left and right * But only allow them to become larger and not * smaller (which can only happen through "bad" * cancellation and doesn't reflect the theory * where the initial gaps are underestimated due * to WERR being too crude.) IF(.NOT.ESKIP) THEN IF( K.GT.1) THEN WGAP( WINDMN ) = MAX( WGAP(WINDMN), $ W(WINDEX)-WERR(WINDEX) $ - W(WINDMN)-WERR(WINDMN) ) ENDIF IF( WINDEX.LT.WEND ) THEN WGAP( WINDEX ) = MAX( SAVGAP, $ W( WINDPL )-WERR( WINDPL ) $ - W( WINDEX )-WERR( WINDEX) ) ENDIF ENDIF IDONE = IDONE + 1 ENDIF * here ends the code for the current child * 139 CONTINUE * Proceed to any remaining child nodes NEWFST = J + 1 140 CONTINUE 150 CONTINUE NDEPTH = NDEPTH + 1 GO TO 40 END IF IBEGIN = IEND + 1 WBEGIN = WEND + 1 170 CONTINUE * RETURN * * End of DLARRV * END *> \brief \b DLARSCL2 performs reciprocal diagonal scaling on a vector. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARSCL2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARSCL2 ( M, N, D, X, LDX ) * * .. Scalar Arguments .. * INTEGER M, N, LDX * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), X( LDX, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLARSCL2 performs a reciprocal diagonal scaling on an vector: *> x <-- inv(D) * x *> where the diagonal matrix D is stored as a vector. *> *> Eventually to be replaced by BLAS_dge_diag_scale in the new BLAS *> standard. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of D and X. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of X. N >= 0. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (M) *> Diagonal matrix D, stored as a vector of length M. *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,N) *> On entry, the vector X to be scaled by D. *> On exit, the scaled vector. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the vector X. LDX >= M. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DLARSCL2 ( M, N, D, X, LDX ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. INTEGER M, N, LDX * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), X( LDX, * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I, J * .. * .. Executable Statements .. * DO J = 1, N DO I = 1, M X( I, J ) = X( I, J ) / D( I ) END DO END DO RETURN END *> \brief \b DLARTG generates a plane rotation with real cosine and real sine. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARTG + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARTG( F, G, CS, SN, R ) * * .. Scalar Arguments .. * DOUBLE PRECISION CS, F, G, R, SN * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLARTG generate a plane rotation so that *> *> [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. *> [ -SN CS ] [ G ] [ 0 ] *> *> This is a slower, more accurate version of the BLAS1 routine DROTG, *> with the following other differences: *> F and G are unchanged on return. *> If G=0, then CS=1 and SN=0. *> If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any *> floating point operations (saves work in DBDSQR when *> there are zeros on the diagonal). *> *> If F exceeds G in magnitude, CS will be positive. *> \endverbatim * * Arguments: * ========== * *> \param[in] F *> \verbatim *> F is DOUBLE PRECISION *> The first component of vector to be rotated. *> \endverbatim *> *> \param[in] G *> \verbatim *> G is DOUBLE PRECISION *> The second component of vector to be rotated. *> \endverbatim *> *> \param[out] CS *> \verbatim *> CS is DOUBLE PRECISION *> The cosine of the rotation. *> \endverbatim *> *> \param[out] SN *> \verbatim *> SN is DOUBLE PRECISION *> The sine of the rotation. *> \endverbatim *> *> \param[out] R *> \verbatim *> R is DOUBLE PRECISION *> The nonzero component of the rotated vector. *> *> This version has a few statements commented out for thread safety *> (machine parameters are computed on each entry). 10 feb 03, SJH. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLARTG( F, G, CS, SN, R ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION CS, F, G, R, SN * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D0 ) * .. * .. Local Scalars .. * LOGICAL FIRST INTEGER COUNT, I DOUBLE PRECISION EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, INT, LOG, MAX, SQRT * .. * .. Save statement .. * SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 * .. * .. Data statements .. * DATA FIRST / .TRUE. / * .. * .. Executable Statements .. * * IF( FIRST ) THEN SAFMIN = DLAMCH( 'S' ) EPS = DLAMCH( 'E' ) SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / $ LOG( DLAMCH( 'B' ) ) / TWO ) SAFMX2 = ONE / SAFMN2 * FIRST = .FALSE. * END IF IF( G.EQ.ZERO ) THEN CS = ONE SN = ZERO R = F ELSE IF( F.EQ.ZERO ) THEN CS = ZERO SN = ONE R = G ELSE F1 = F G1 = G SCALE = MAX( ABS( F1 ), ABS( G1 ) ) IF( SCALE.GE.SAFMX2 ) THEN COUNT = 0 10 CONTINUE COUNT = COUNT + 1 F1 = F1*SAFMN2 G1 = G1*SAFMN2 SCALE = MAX( ABS( F1 ), ABS( G1 ) ) IF( SCALE.GE.SAFMX2 ) $ GO TO 10 R = SQRT( F1**2+G1**2 ) CS = F1 / R SN = G1 / R DO 20 I = 1, COUNT R = R*SAFMX2 20 CONTINUE ELSE IF( SCALE.LE.SAFMN2 ) THEN COUNT = 0 30 CONTINUE COUNT = COUNT + 1 F1 = F1*SAFMX2 G1 = G1*SAFMX2 SCALE = MAX( ABS( F1 ), ABS( G1 ) ) IF( SCALE.LE.SAFMN2 ) $ GO TO 30 R = SQRT( F1**2+G1**2 ) CS = F1 / R SN = G1 / R DO 40 I = 1, COUNT R = R*SAFMN2 40 CONTINUE ELSE R = SQRT( F1**2+G1**2 ) CS = F1 / R SN = G1 / R END IF IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN CS = -CS SN = -SN R = -R END IF END IF RETURN * * End of DLARTG * END *> \brief \b DLARTGP generates a plane rotation so that the diagonal is nonnegative. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARTGP + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARTGP( F, G, CS, SN, R ) * * .. Scalar Arguments .. * DOUBLE PRECISION CS, F, G, R, SN * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLARTGP generates a plane rotation so that *> *> [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. *> [ -SN CS ] [ G ] [ 0 ] *> *> This is a slower, more accurate version of the Level 1 BLAS routine DROTG, *> with the following other differences: *> F and G are unchanged on return. *> If G=0, then CS=(+/-)1 and SN=0. *> If F=0 and (G .ne. 0), then CS=0 and SN=(+/-)1. *> *> The sign is chosen so that R >= 0. *> \endverbatim * * Arguments: * ========== * *> \param[in] F *> \verbatim *> F is DOUBLE PRECISION *> The first component of vector to be rotated. *> \endverbatim *> *> \param[in] G *> \verbatim *> G is DOUBLE PRECISION *> The second component of vector to be rotated. *> \endverbatim *> *> \param[out] CS *> \verbatim *> CS is DOUBLE PRECISION *> The cosine of the rotation. *> \endverbatim *> *> \param[out] SN *> \verbatim *> SN is DOUBLE PRECISION *> The sine of the rotation. *> \endverbatim *> *> \param[out] R *> \verbatim *> R is DOUBLE PRECISION *> The nonzero component of the rotated vector. *> *> This version has a few statements commented out for thread safety *> (machine parameters are computed on each entry). 10 feb 03, SJH. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLARTGP( F, G, CS, SN, R ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION CS, F, G, R, SN * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D0 ) * .. * .. Local Scalars .. * LOGICAL FIRST INTEGER COUNT, I DOUBLE PRECISION EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, INT, LOG, MAX, SIGN, SQRT * .. * .. Save statement .. * SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 * .. * .. Data statements .. * DATA FIRST / .TRUE. / * .. * .. Executable Statements .. * * IF( FIRST ) THEN SAFMIN = DLAMCH( 'S' ) EPS = DLAMCH( 'E' ) SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / $ LOG( DLAMCH( 'B' ) ) / TWO ) SAFMX2 = ONE / SAFMN2 * FIRST = .FALSE. * END IF IF( G.EQ.ZERO ) THEN CS = SIGN( ONE, F ) SN = ZERO R = ABS( F ) ELSE IF( F.EQ.ZERO ) THEN CS = ZERO SN = SIGN( ONE, G ) R = ABS( G ) ELSE F1 = F G1 = G SCALE = MAX( ABS( F1 ), ABS( G1 ) ) IF( SCALE.GE.SAFMX2 ) THEN COUNT = 0 10 CONTINUE COUNT = COUNT + 1 F1 = F1*SAFMN2 G1 = G1*SAFMN2 SCALE = MAX( ABS( F1 ), ABS( G1 ) ) IF( SCALE.GE.SAFMX2 ) $ GO TO 10 R = SQRT( F1**2+G1**2 ) CS = F1 / R SN = G1 / R DO 20 I = 1, COUNT R = R*SAFMX2 20 CONTINUE ELSE IF( SCALE.LE.SAFMN2 ) THEN COUNT = 0 30 CONTINUE COUNT = COUNT + 1 F1 = F1*SAFMX2 G1 = G1*SAFMX2 SCALE = MAX( ABS( F1 ), ABS( G1 ) ) IF( SCALE.LE.SAFMN2 ) $ GO TO 30 R = SQRT( F1**2+G1**2 ) CS = F1 / R SN = G1 / R DO 40 I = 1, COUNT R = R*SAFMN2 40 CONTINUE ELSE R = SQRT( F1**2+G1**2 ) CS = F1 / R SN = G1 / R END IF IF( R.LT.ZERO ) THEN CS = -CS SN = -SN R = -R END IF END IF RETURN * * End of DLARTGP * END *> \brief \b DLARTGS generates a plane rotation designed to introduce a bulge in implicit QR iteration for the bidiagonal SVD problem. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARTGS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARTGS( X, Y, SIGMA, CS, SN ) * * .. Scalar Arguments .. * DOUBLE PRECISION CS, SIGMA, SN, X, Y * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLARTGS generates a plane rotation designed to introduce a bulge in *> Golub-Reinsch-style implicit QR iteration for the bidiagonal SVD *> problem. X and Y are the top-row entries, and SIGMA is the shift. *> The computed CS and SN define a plane rotation satisfying *> *> [ CS SN ] . [ X^2 - SIGMA ] = [ R ], *> [ -SN CS ] [ X * Y ] [ 0 ] *> *> with R nonnegative. If X^2 - SIGMA and X * Y are 0, then the *> rotation is by PI/2. *> \endverbatim * * Arguments: * ========== * *> \param[in] X *> \verbatim *> X is DOUBLE PRECISION *> The (1,1) entry of an upper bidiagonal matrix. *> \endverbatim *> *> \param[in] Y *> \verbatim *> Y is DOUBLE PRECISION *> The (1,2) entry of an upper bidiagonal matrix. *> \endverbatim *> *> \param[in] SIGMA *> \verbatim *> SIGMA is DOUBLE PRECISION *> The shift. *> \endverbatim *> *> \param[out] CS *> \verbatim *> CS is DOUBLE PRECISION *> The cosine of the rotation. *> \endverbatim *> *> \param[out] SN *> \verbatim *> SN is DOUBLE PRECISION *> The sine of the rotation. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date November 2017 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE DLARTGS( X, Y, SIGMA, CS, SN ) * * -- LAPACK computational routine (version 3.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. Scalar Arguments .. DOUBLE PRECISION CS, SIGMA, SN, X, Y * .. * * =================================================================== * * .. Parameters .. DOUBLE PRECISION NEGONE, ONE, ZERO PARAMETER ( NEGONE = -1.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) * .. * .. Local Scalars .. DOUBLE PRECISION R, S, THRESH, W, Z * .. * .. External Subroutines .. EXTERNAL DLARTGP * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. Executable Statements .. * THRESH = DLAMCH('E') * * Compute the first column of B**T*B - SIGMA^2*I, up to a scale * factor. * IF( (SIGMA .EQ. ZERO .AND. ABS(X) .LT. THRESH) .OR. $ (ABS(X) .EQ. SIGMA .AND. Y .EQ. ZERO) ) THEN Z = ZERO W = ZERO ELSE IF( SIGMA .EQ. ZERO ) THEN IF( X .GE. ZERO ) THEN Z = X W = Y ELSE Z = -X W = -Y END IF ELSE IF( ABS(X) .LT. THRESH ) THEN Z = -SIGMA*SIGMA W = ZERO ELSE IF( X .GE. ZERO ) THEN S = ONE ELSE S = NEGONE END IF Z = S * (ABS(X)-SIGMA) * (S+SIGMA/X) W = S * Y END IF * * Generate the rotation. * CALL DLARTGP( Z, W, CS, SN, R ) might seem more natural; * reordering the arguments ensures that if Z = 0 then the rotation * is by PI/2. * CALL DLARTGP( W, Z, SN, CS, R ) * RETURN * * End DLARTGS * END *> \brief \b DLARTV applies a vector of plane rotations with real cosines and real sines to the elements of a pair of vectors. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARTV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARTV( N, X, INCX, Y, INCY, C, S, INCC ) * * .. Scalar Arguments .. * INTEGER INCC, INCX, INCY, N * .. * .. Array Arguments .. * DOUBLE PRECISION C( * ), S( * ), X( * ), Y( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLARTV applies a vector of real plane rotations to elements of the *> real vectors x and y. For i = 1,2,...,n *> *> ( x(i) ) := ( c(i) s(i) ) ( x(i) ) *> ( y(i) ) ( -s(i) c(i) ) ( y(i) ) *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The number of plane rotations to be applied. *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is DOUBLE PRECISION array, *> dimension (1+(N-1)*INCX) *> The vector x. *> \endverbatim *> *> \param[in] INCX *> \verbatim *> INCX is INTEGER *> The increment between elements of X. INCX > 0. *> \endverbatim *> *> \param[in,out] Y *> \verbatim *> Y is DOUBLE PRECISION array, *> dimension (1+(N-1)*INCY) *> The vector y. *> \endverbatim *> *> \param[in] INCY *> \verbatim *> INCY is INTEGER *> The increment between elements of Y. INCY > 0. *> \endverbatim *> *> \param[in] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (1+(N-1)*INCC) *> The cosines of the plane rotations. *> \endverbatim *> *> \param[in] S *> \verbatim *> S is DOUBLE PRECISION array, dimension (1+(N-1)*INCC) *> The sines of the plane rotations. *> \endverbatim *> *> \param[in] INCC *> \verbatim *> INCC is INTEGER *> The increment between elements of C and S. INCC > 0. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLARTV( N, X, INCX, Y, INCY, C, S, INCC ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INCC, INCX, INCY, N * .. * .. Array Arguments .. DOUBLE PRECISION C( * ), S( * ), X( * ), Y( * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I, IC, IX, IY DOUBLE PRECISION XI, YI * .. * .. Executable Statements .. * IX = 1 IY = 1 IC = 1 DO 10 I = 1, N XI = X( IX ) YI = Y( IY ) X( IX ) = C( IC )*XI + S( IC )*YI Y( IY ) = C( IC )*YI - S( IC )*XI IX = IX + INCX IY = IY + INCY IC = IC + INCC 10 CONTINUE RETURN * * End of DLARTV * END *> \brief \b DLARUV returns a vector of n random real numbers from a uniform distribution. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARUV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARUV( ISEED, N, X ) * * .. Scalar Arguments .. * INTEGER N * .. * .. Array Arguments .. * INTEGER ISEED( 4 ) * DOUBLE PRECISION X( N ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLARUV returns a vector of n random real numbers from a uniform (0,1) *> distribution (n <= 128). *> *> This is an auxiliary routine called by DLARNV and ZLARNV. *> \endverbatim * * Arguments: * ========== * *> \param[in,out] ISEED *> \verbatim *> ISEED is INTEGER array, dimension (4) *> On entry, the seed of the random number generator; the array *> elements must be between 0 and 4095, and ISEED(4) must be *> odd. *> On exit, the seed is updated. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of random numbers to be generated. N <= 128. *> \endverbatim *> *> \param[out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (N) *> The generated random numbers. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> This routine uses a multiplicative congruential method with modulus *> 2**48 and multiplier 33952834046453 (see G.S.Fishman, *> 'Multiplicative congruential random number generators with modulus *> 2**b: an exhaustive analysis for b = 32 and a partial analysis for *> b = 48', Math. Comp. 189, pp 331-344, 1990). *> *> 48-bit integers are stored in 4 integer array elements with 12 bits *> per element. Hence the routine is portable across machines with *> integers of 32 bits or more. *> \endverbatim *> * ===================================================================== SUBROUTINE DLARUV( ISEED, N, X ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) DOUBLE PRECISION X( N ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) INTEGER LV, IPW2 DOUBLE PRECISION R PARAMETER ( LV = 128, IPW2 = 4096, R = ONE / IPW2 ) * .. * .. Local Scalars .. INTEGER I, I1, I2, I3, I4, IT1, IT2, IT3, IT4, J * .. * .. Local Arrays .. INTEGER MM( LV, 4 ) * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MIN, MOD * .. * .. Data statements .. DATA ( MM( 1, J ), J = 1, 4 ) / 494, 322, 2508, $ 2549 / DATA ( MM( 2, J ), J = 1, 4 ) / 2637, 789, 3754, $ 1145 / DATA ( MM( 3, J ), J = 1, 4 ) / 255, 1440, 1766, $ 2253 / DATA ( MM( 4, J ), J = 1, 4 ) / 2008, 752, 3572, $ 305 / DATA ( MM( 5, J ), J = 1, 4 ) / 1253, 2859, 2893, $ 3301 / DATA ( MM( 6, J ), J = 1, 4 ) / 3344, 123, 307, $ 1065 / DATA ( MM( 7, J ), J = 1, 4 ) / 4084, 1848, 1297, $ 3133 / DATA ( MM( 8, J ), J = 1, 4 ) / 1739, 643, 3966, $ 2913 / DATA ( MM( 9, J ), J = 1, 4 ) / 3143, 2405, 758, $ 3285 / DATA ( MM( 10, J ), J = 1, 4 ) / 3468, 2638, 2598, $ 1241 / DATA ( MM( 11, J ), J = 1, 4 ) / 688, 2344, 3406, $ 1197 / DATA ( MM( 12, J ), J = 1, 4 ) / 1657, 46, 2922, $ 3729 / DATA ( MM( 13, J ), J = 1, 4 ) / 1238, 3814, 1038, $ 2501 / DATA ( MM( 14, J ), J = 1, 4 ) / 3166, 913, 2934, $ 1673 / DATA ( MM( 15, J ), J = 1, 4 ) / 1292, 3649, 2091, $ 541 / DATA ( MM( 16, J ), J = 1, 4 ) / 3422, 339, 2451, $ 2753 / DATA ( MM( 17, J ), J = 1, 4 ) / 1270, 3808, 1580, $ 949 / DATA ( MM( 18, J ), J = 1, 4 ) / 2016, 822, 1958, $ 2361 / DATA ( MM( 19, J ), J = 1, 4 ) / 154, 2832, 2055, $ 1165 / DATA ( MM( 20, J ), J = 1, 4 ) / 2862, 3078, 1507, $ 4081 / DATA ( MM( 21, J ), J = 1, 4 ) / 697, 3633, 1078, $ 2725 / DATA ( MM( 22, J ), J = 1, 4 ) / 1706, 2970, 3273, $ 3305 / DATA ( MM( 23, J ), J = 1, 4 ) / 491, 637, 17, $ 3069 / DATA ( MM( 24, J ), J = 1, 4 ) / 931, 2249, 854, $ 3617 / DATA ( MM( 25, J ), J = 1, 4 ) / 1444, 2081, 2916, $ 3733 / DATA ( MM( 26, J ), J = 1, 4 ) / 444, 4019, 3971, $ 409 / DATA ( MM( 27, J ), J = 1, 4 ) / 3577, 1478, 2889, $ 2157 / DATA ( MM( 28, J ), J = 1, 4 ) / 3944, 242, 3831, $ 1361 / DATA ( MM( 29, J ), J = 1, 4 ) / 2184, 481, 2621, $ 3973 / DATA ( MM( 30, J ), J = 1, 4 ) / 1661, 2075, 1541, $ 1865 / DATA ( MM( 31, J ), J = 1, 4 ) / 3482, 4058, 893, $ 2525 / DATA ( MM( 32, J ), J = 1, 4 ) / 657, 622, 736, $ 1409 / DATA ( MM( 33, J ), J = 1, 4 ) / 3023, 3376, 3992, $ 3445 / DATA ( MM( 34, J ), J = 1, 4 ) / 3618, 812, 787, $ 3577 / DATA ( MM( 35, J ), J = 1, 4 ) / 1267, 234, 2125, $ 77 / DATA ( MM( 36, J ), J = 1, 4 ) / 1828, 641, 2364, $ 3761 / DATA ( MM( 37, J ), J = 1, 4 ) / 164, 4005, 2460, $ 2149 / DATA ( MM( 38, J ), J = 1, 4 ) / 3798, 1122, 257, $ 1449 / DATA ( MM( 39, J ), J = 1, 4 ) / 3087, 3135, 1574, $ 3005 / DATA ( MM( 40, J ), J = 1, 4 ) / 2400, 2640, 3912, $ 225 / DATA ( MM( 41, J ), J = 1, 4 ) / 2870, 2302, 1216, $ 85 / DATA ( MM( 42, J ), J = 1, 4 ) / 3876, 40, 3248, $ 3673 / DATA ( MM( 43, J ), J = 1, 4 ) / 1905, 1832, 3401, $ 3117 / DATA ( MM( 44, J ), J = 1, 4 ) / 1593, 2247, 2124, $ 3089 / DATA ( MM( 45, J ), J = 1, 4 ) / 1797, 2034, 2762, $ 1349 / DATA ( MM( 46, J ), J = 1, 4 ) / 1234, 2637, 149, $ 2057 / DATA ( MM( 47, J ), J = 1, 4 ) / 3460, 1287, 2245, $ 413 / DATA ( MM( 48, J ), J = 1, 4 ) / 328, 1691, 166, $ 65 / DATA ( MM( 49, J ), J = 1, 4 ) / 2861, 496, 466, $ 1845 / DATA ( MM( 50, J ), J = 1, 4 ) / 1950, 1597, 4018, $ 697 / DATA ( MM( 51, J ), J = 1, 4 ) / 617, 2394, 1399, $ 3085 / DATA ( MM( 52, J ), J = 1, 4 ) / 2070, 2584, 190, $ 3441 / DATA ( MM( 53, J ), J = 1, 4 ) / 3331, 1843, 2879, $ 1573 / DATA ( MM( 54, J ), J = 1, 4 ) / 769, 336, 153, $ 3689 / DATA ( MM( 55, J ), J = 1, 4 ) / 1558, 1472, 2320, $ 2941 / DATA ( MM( 56, J ), J = 1, 4 ) / 2412, 2407, 18, $ 929 / DATA ( MM( 57, J ), J = 1, 4 ) / 2800, 433, 712, $ 533 / DATA ( MM( 58, J ), J = 1, 4 ) / 189, 2096, 2159, $ 2841 / DATA ( MM( 59, J ), J = 1, 4 ) / 287, 1761, 2318, $ 4077 / DATA ( MM( 60, J ), J = 1, 4 ) / 2045, 2810, 2091, $ 721 / DATA ( MM( 61, J ), J = 1, 4 ) / 1227, 566, 3443, $ 2821 / DATA ( MM( 62, J ), J = 1, 4 ) / 2838, 442, 1510, $ 2249 / DATA ( MM( 63, J ), J = 1, 4 ) / 209, 41, 449, $ 2397 / DATA ( MM( 64, J ), J = 1, 4 ) / 2770, 1238, 1956, $ 2817 / DATA ( MM( 65, J ), J = 1, 4 ) / 3654, 1086, 2201, $ 245 / DATA ( MM( 66, J ), J = 1, 4 ) / 3993, 603, 3137, $ 1913 / DATA ( MM( 67, J ), J = 1, 4 ) / 192, 840, 3399, $ 1997 / DATA ( MM( 68, J ), J = 1, 4 ) / 2253, 3168, 1321, $ 3121 / DATA ( MM( 69, J ), J = 1, 4 ) / 3491, 1499, 2271, $ 997 / DATA ( MM( 70, J ), J = 1, 4 ) / 2889, 1084, 3667, $ 1833 / DATA ( MM( 71, J ), J = 1, 4 ) / 2857, 3438, 2703, $ 2877 / DATA ( MM( 72, J ), J = 1, 4 ) / 2094, 2408, 629, $ 1633 / DATA ( MM( 73, J ), J = 1, 4 ) / 1818, 1589, 2365, $ 981 / DATA ( MM( 74, J ), J = 1, 4 ) / 688, 2391, 2431, $ 2009 / DATA ( MM( 75, J ), J = 1, 4 ) / 1407, 288, 1113, $ 941 / DATA ( MM( 76, J ), J = 1, 4 ) / 634, 26, 3922, $ 2449 / DATA ( MM( 77, J ), J = 1, 4 ) / 3231, 512, 2554, $ 197 / DATA ( MM( 78, J ), J = 1, 4 ) / 815, 1456, 184, $ 2441 / DATA ( MM( 79, J ), J = 1, 4 ) / 3524, 171, 2099, $ 285 / DATA ( MM( 80, J ), J = 1, 4 ) / 1914, 1677, 3228, $ 1473 / DATA ( MM( 81, J ), J = 1, 4 ) / 516, 2657, 4012, $ 2741 / DATA ( MM( 82, J ), J = 1, 4 ) / 164, 2270, 1921, $ 3129 / DATA ( MM( 83, J ), J = 1, 4 ) / 303, 2587, 3452, $ 909 / DATA ( MM( 84, J ), J = 1, 4 ) / 2144, 2961, 3901, $ 2801 / DATA ( MM( 85, J ), J = 1, 4 ) / 3480, 1970, 572, $ 421 / DATA ( MM( 86, J ), J = 1, 4 ) / 119, 1817, 3309, $ 4073 / DATA ( MM( 87, J ), J = 1, 4 ) / 3357, 676, 3171, $ 2813 / DATA ( MM( 88, J ), J = 1, 4 ) / 837, 1410, 817, $ 2337 / DATA ( MM( 89, J ), J = 1, 4 ) / 2826, 3723, 3039, $ 1429 / DATA ( MM( 90, J ), J = 1, 4 ) / 2332, 2803, 1696, $ 1177 / DATA ( MM( 91, J ), J = 1, 4 ) / 2089, 3185, 1256, $ 1901 / DATA ( MM( 92, J ), J = 1, 4 ) / 3780, 184, 3715, $ 81 / DATA ( MM( 93, J ), J = 1, 4 ) / 1700, 663, 2077, $ 1669 / DATA ( MM( 94, J ), J = 1, 4 ) / 3712, 499, 3019, $ 2633 / DATA ( MM( 95, J ), J = 1, 4 ) / 150, 3784, 1497, $ 2269 / DATA ( MM( 96, J ), J = 1, 4 ) / 2000, 1631, 1101, $ 129 / DATA ( MM( 97, J ), J = 1, 4 ) / 3375, 1925, 717, $ 1141 / DATA ( MM( 98, J ), J = 1, 4 ) / 1621, 3912, 51, $ 249 / DATA ( MM( 99, J ), J = 1, 4 ) / 3090, 1398, 981, $ 3917 / DATA ( MM( 100, J ), J = 1, 4 ) / 3765, 1349, 1978, $ 2481 / DATA ( MM( 101, J ), J = 1, 4 ) / 1149, 1441, 1813, $ 3941 / DATA ( MM( 102, J ), J = 1, 4 ) / 3146, 2224, 3881, $ 2217 / DATA ( MM( 103, J ), J = 1, 4 ) / 33, 2411, 76, $ 2749 / DATA ( MM( 104, J ), J = 1, 4 ) / 3082, 1907, 3846, $ 3041 / DATA ( MM( 105, J ), J = 1, 4 ) / 2741, 3192, 3694, $ 1877 / DATA ( MM( 106, J ), J = 1, 4 ) / 359, 2786, 1682, $ 345 / DATA ( MM( 107, J ), J = 1, 4 ) / 3316, 382, 124, $ 2861 / DATA ( MM( 108, J ), J = 1, 4 ) / 1749, 37, 1660, $ 1809 / DATA ( MM( 109, J ), J = 1, 4 ) / 185, 759, 3997, $ 3141 / DATA ( MM( 110, J ), J = 1, 4 ) / 2784, 2948, 479, $ 2825 / DATA ( MM( 111, J ), J = 1, 4 ) / 2202, 1862, 1141, $ 157 / DATA ( MM( 112, J ), J = 1, 4 ) / 2199, 3802, 886, $ 2881 / DATA ( MM( 113, J ), J = 1, 4 ) / 1364, 2423, 3514, $ 3637 / DATA ( MM( 114, J ), J = 1, 4 ) / 1244, 2051, 1301, $ 1465 / DATA ( MM( 115, J ), J = 1, 4 ) / 2020, 2295, 3604, $ 2829 / DATA ( MM( 116, J ), J = 1, 4 ) / 3160, 1332, 1888, $ 2161 / DATA ( MM( 117, J ), J = 1, 4 ) / 2785, 1832, 1836, $ 3365 / DATA ( MM( 118, J ), J = 1, 4 ) / 2772, 2405, 1990, $ 361 / DATA ( MM( 119, J ), J = 1, 4 ) / 1217, 3638, 2058, $ 2685 / DATA ( MM( 120, J ), J = 1, 4 ) / 1822, 3661, 692, $ 3745 / DATA ( MM( 121, J ), J = 1, 4 ) / 1245, 327, 1194, $ 2325 / DATA ( MM( 122, J ), J = 1, 4 ) / 2252, 3660, 20, $ 3609 / DATA ( MM( 123, J ), J = 1, 4 ) / 3904, 716, 3285, $ 3821 / DATA ( MM( 124, J ), J = 1, 4 ) / 2774, 1842, 2046, $ 3537 / DATA ( MM( 125, J ), J = 1, 4 ) / 997, 3987, 2107, $ 517 / DATA ( MM( 126, J ), J = 1, 4 ) / 2573, 1368, 3508, $ 3017 / DATA ( MM( 127, J ), J = 1, 4 ) / 1148, 1848, 3525, $ 2141 / DATA ( MM( 128, J ), J = 1, 4 ) / 545, 2366, 3801, $ 1537 / * .. * .. Executable Statements .. * I1 = ISEED( 1 ) I2 = ISEED( 2 ) I3 = ISEED( 3 ) I4 = ISEED( 4 ) * DO 10 I = 1, MIN( N, LV ) * 20 CONTINUE * * Multiply the seed by i-th power of the multiplier modulo 2**48 * IT4 = I4*MM( I, 4 ) IT3 = IT4 / IPW2 IT4 = IT4 - IPW2*IT3 IT3 = IT3 + I3*MM( I, 4 ) + I4*MM( I, 3 ) IT2 = IT3 / IPW2 IT3 = IT3 - IPW2*IT2 IT2 = IT2 + I2*MM( I, 4 ) + I3*MM( I, 3 ) + I4*MM( I, 2 ) IT1 = IT2 / IPW2 IT2 = IT2 - IPW2*IT1 IT1 = IT1 + I1*MM( I, 4 ) + I2*MM( I, 3 ) + I3*MM( I, 2 ) + $ I4*MM( I, 1 ) IT1 = MOD( IT1, IPW2 ) * * Convert 48-bit integer to a real number in the interval (0,1) * X( I ) = R*( DBLE( IT1 )+R*( DBLE( IT2 )+R*( DBLE( IT3 )+R* $ DBLE( IT4 ) ) ) ) * IF (X( I ).EQ.1.0D0) THEN * If a real number has n bits of precision, and the first * n bits of the 48-bit integer above happen to be all 1 (which * will occur about once every 2**n calls), then X( I ) will * be rounded to exactly 1.0. * Since X( I ) is not supposed to return exactly 0.0 or 1.0, * the statistically correct thing to do in this situation is * simply to iterate again. * N.B. the case X( I ) = 0.0 should not be possible. I1 = I1 + 2 I2 = I2 + 2 I3 = I3 + 2 I4 = I4 + 2 GOTO 20 END IF * 10 CONTINUE * * Return final value of seed * ISEED( 1 ) = IT1 ISEED( 2 ) = IT2 ISEED( 3 ) = IT3 ISEED( 4 ) = IT4 RETURN * * End of DLARUV * END *> \brief \b DLARZ applies an elementary reflector (as returned by stzrzf) to a general matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARZ + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK ) * * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER INCV, L, LDC, M, N * DOUBLE PRECISION TAU * .. * .. Array Arguments .. * DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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**T *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': form H * C *> = 'R': form C * H *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. *> \endverbatim *> *> \param[in] L *> \verbatim *> L is 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. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is 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. *> \endverbatim *> *> \param[in] INCV *> \verbatim *> INCV is INTEGER *> The increment between elements of v. INCV <> 0. *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION *> The value tau in the representation of H. *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is 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'. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDC >= max(1,M). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension *> (N) if SIDE = 'L' *> or (M) if SIDE = 'R' *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Contributors: * ================== *> *> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA * *> \par Further Details: * ===================== *> *> \verbatim *> \endverbatim *> * ===================================================================== SUBROUTINE DLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER SIDE INTEGER INCV, L, LDC, M, N DOUBLE PRECISION TAU * .. * .. Array Arguments .. DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) * .. * * ===================================================================== * * .. 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 )**T * 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 )**T * 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 )**T * CALL DGER( M, L, -TAU, WORK, 1, V, INCV, C( 1, N-L+1 ), $ LDC ) * END IF * END IF * RETURN * * End of DLARZ * END *> \brief \b DLARZB applies a block reflector or its transpose to a general matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARZB + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, * LDV, T, LDT, C, LDC, WORK, LDWORK ) * * .. 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, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply H or H**T from the Left *> = 'R': apply H or H**T from the Right *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': apply H (No transpose) *> = 'C': apply H**T (Transpose) *> \endverbatim *> *> \param[in] DIRECT *> \verbatim *> DIRECT is 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) *> \endverbatim *> *> \param[in] STOREV *> \verbatim *> STOREV is CHARACTER*1 *> Indicates how the vectors which define the elementary *> reflectors are stored: *> = 'C': Columnwise (not supported yet) *> = 'R': Rowwise *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The order of the matrix T (= the number of elementary *> reflectors whose product defines the block reflector). *> \endverbatim *> *> \param[in] L *> \verbatim *> L is 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. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is DOUBLE PRECISION array, dimension (LDV,NV). *> If STOREV = 'C', NV = K; if STOREV = 'R', NV = L. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the array V. *> If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K. *> \endverbatim *> *> \param[in] T *> \verbatim *> T is DOUBLE PRECISION array, dimension (LDT,K) *> The triangular K-by-K matrix T in the representation of the *> block reflector. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= K. *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (LDC,N) *> On entry, the M-by-N matrix C. *> On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDC >= max(1,M). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (LDWORK,K) *> \endverbatim *> *> \param[in] LDWORK *> \verbatim *> LDWORK is INTEGER *> The leading dimension of the array WORK. *> If SIDE = 'L', LDWORK >= max(1,N); *> if SIDE = 'R', LDWORK >= max(1,M). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Contributors: * ================== *> *> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA * *> \par Further Details: * ===================== *> *> \verbatim *> \endverbatim *> * ===================================================================== SUBROUTINE DLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, $ LDV, T, LDT, C, LDC, WORK, LDWORK ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER 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, * ) * .. * * ===================================================================== * * .. 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**T * C * * W( 1:n, 1:k ) = C( 1:k, 1:n )**T * 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 )**T * V( 1:k, 1:l )**T * 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**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 )**T * 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 )**T * W( 1:n, 1:k )**T * 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**T * * 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 )**T * 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**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 *> \brief \b DLARZT forms the triangular factor T of a block reflector H = I - vtvH. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLARZT + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * * .. Scalar Arguments .. * CHARACTER DIRECT, STOREV * INTEGER K, LDT, LDV, N * .. * .. Array Arguments .. * DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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**T *> *> 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 * T * V *> *> Currently, only STOREV = 'R' and DIRECT = 'B' are supported. *> \endverbatim * * Arguments: * ========== * *> \param[in] DIRECT *> \verbatim *> DIRECT is 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) *> \endverbatim *> *> \param[in] STOREV *> \verbatim *> STOREV is CHARACTER*1 *> Specifies how the vectors which define the elementary *> reflectors are stored (see also Further Details): *> = 'C': columnwise (not supported yet) *> = 'R': rowwise *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the block reflector H. N >= 0. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The order of the triangular factor T (= the number of *> elementary reflectors). K >= 1. *> \endverbatim *> *> \param[in,out] V *> \verbatim *> V is DOUBLE PRECISION array, dimension *> (LDV,K) if STOREV = 'C' *> (LDV,N) if STOREV = 'R' *> The matrix V. See further details. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the array V. *> If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i). *> \endverbatim *> *> \param[out] T *> \verbatim *> T is 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. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= K. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Contributors: * ================== *> *> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA * *> \par Further Details: * ===================== *> *> \verbatim *> *> 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 ) *> \endverbatim *> * ===================================================================== SUBROUTINE DLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER DIRECT, STOREV INTEGER K, LDT, LDV, N * .. * .. Array Arguments .. DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) * .. * * ===================================================================== * * .. 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)**T * 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 *> \brief \b DLAS2 computes singular values of a 2-by-2 triangular matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAS2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX ) * * .. Scalar Arguments .. * DOUBLE PRECISION F, G, H, SSMAX, SSMIN * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAS2 computes the singular values of the 2-by-2 matrix *> [ F G ] *> [ 0 H ]. *> On return, SSMIN is the smaller singular value and SSMAX is the *> larger singular value. *> \endverbatim * * Arguments: * ========== * *> \param[in] F *> \verbatim *> F is DOUBLE PRECISION *> The (1,1) element of the 2-by-2 matrix. *> \endverbatim *> *> \param[in] G *> \verbatim *> G is DOUBLE PRECISION *> The (1,2) element of the 2-by-2 matrix. *> \endverbatim *> *> \param[in] H *> \verbatim *> H is DOUBLE PRECISION *> The (2,2) element of the 2-by-2 matrix. *> \endverbatim *> *> \param[out] SSMIN *> \verbatim *> SSMIN is DOUBLE PRECISION *> The smaller singular value. *> \endverbatim *> *> \param[out] SSMAX *> \verbatim *> SSMAX is DOUBLE PRECISION *> The larger singular value. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> Barring over/underflow, all output quantities are correct to within *> a few units in the last place (ulps), even in the absence of a guard *> digit in addition/subtraction. *> *> In IEEE arithmetic, the code works correctly if one matrix element is *> infinite. *> *> Overflow will not occur unless the largest singular value itself *> overflows, or is within a few ulps of overflow. (On machines with *> partial overflow, like the Cray, overflow may occur if the largest *> singular value is within a factor of 2 of overflow.) *> *> Underflow is harmless if underflow is gradual. Otherwise, results *> may correspond to a matrix modified by perturbations of size near *> the underflow threshold. *> \endverbatim *> * ===================================================================== SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION F, G, H, SSMAX, SSMIN * .. * * ==================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D0 ) * .. * .. Local Scalars .. DOUBLE PRECISION AS, AT, AU, C, FA, FHMN, FHMX, GA, HA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Executable Statements .. * FA = ABS( F ) GA = ABS( G ) HA = ABS( H ) FHMN = MIN( FA, HA ) FHMX = MAX( FA, HA ) IF( FHMN.EQ.ZERO ) THEN SSMIN = ZERO IF( FHMX.EQ.ZERO ) THEN SSMAX = GA ELSE SSMAX = MAX( FHMX, GA )*SQRT( ONE+ $ ( MIN( FHMX, GA ) / MAX( FHMX, GA ) )**2 ) END IF ELSE IF( GA.LT.FHMX ) THEN AS = ONE + FHMN / FHMX AT = ( FHMX-FHMN ) / FHMX AU = ( GA / FHMX )**2 C = TWO / ( SQRT( AS*AS+AU )+SQRT( AT*AT+AU ) ) SSMIN = FHMN*C SSMAX = FHMX / C ELSE AU = FHMX / GA IF( AU.EQ.ZERO ) THEN * * Avoid possible harmful underflow if exponent range * asymmetric (true SSMIN may not underflow even if * AU underflows) * SSMIN = ( FHMN*FHMX ) / GA SSMAX = GA ELSE AS = ONE + FHMN / FHMX AT = ( FHMX-FHMN ) / FHMX C = ONE / ( SQRT( ONE+( AS*AU )**2 )+ $ SQRT( ONE+( AT*AU )**2 ) ) SSMIN = ( FHMN*C )*AU SSMIN = SSMIN + SSMIN SSMAX = GA / ( C+C ) END IF END IF END IF RETURN * * End of DLAS2 * END *> \brief \b DLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASCL + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) * * .. Scalar Arguments .. * CHARACTER TYPE * INTEGER INFO, KL, KU, LDA, M, N * DOUBLE PRECISION CFROM, CTO * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLASCL multiplies the M by N real matrix A by the real scalar *> CTO/CFROM. This is done without over/underflow as long as the final *> result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that *> A may be full, upper triangular, lower triangular, upper Hessenberg, *> or banded. *> \endverbatim * * Arguments: * ========== * *> \param[in] TYPE *> \verbatim *> TYPE is CHARACTER*1 *> TYPE indices the storage type of the input matrix. *> = 'G': A is a full matrix. *> = 'L': A is a lower triangular matrix. *> = 'U': A is an upper triangular matrix. *> = 'H': A is an upper Hessenberg matrix. *> = 'B': A is a symmetric band matrix with lower bandwidth KL *> and upper bandwidth KU and with the only the lower *> half stored. *> = 'Q': A is a symmetric band matrix with lower bandwidth KL *> and upper bandwidth KU and with the only the upper *> half stored. *> = 'Z': A is a band matrix with lower bandwidth KL and upper *> bandwidth KU. See DGBTRF for storage details. *> \endverbatim *> *> \param[in] KL *> \verbatim *> KL is INTEGER *> The lower bandwidth of A. Referenced only if TYPE = 'B', *> 'Q' or 'Z'. *> \endverbatim *> *> \param[in] KU *> \verbatim *> KU is INTEGER *> The upper bandwidth of A. Referenced only if TYPE = 'B', *> 'Q' or 'Z'. *> \endverbatim *> *> \param[in] CFROM *> \verbatim *> CFROM is DOUBLE PRECISION *> \endverbatim *> *> \param[in] CTO *> \verbatim *> CTO is DOUBLE PRECISION *> *> The matrix A is multiplied by CTO/CFROM. A(I,J) is computed *> without over/underflow if the final result CTO*A(I,J)/CFROM *> can be represented without over/underflow. CFROM must be *> nonzero. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The matrix to be multiplied by CTO/CFROM. See TYPE for the *> storage type. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. *> If TYPE = 'G', 'L', 'U', 'H', LDA >= max(1,M); *> TYPE = 'B', LDA >= KL+1; *> TYPE = 'Q', LDA >= KU+1; *> TYPE = 'Z', LDA >= 2*KL+KU+1. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> 0 - successful exit *> <0 - if INFO = -i, the i-th argument had an illegal value. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. CHARACTER TYPE INTEGER INFO, KL, KU, LDA, M, N DOUBLE PRECISION CFROM, CTO * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL DONE INTEGER I, ITYPE, J, K1, K2, K3, K4 DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM * .. * .. External Functions .. LOGICAL LSAME, DISNAN DOUBLE PRECISION DLAMCH EXTERNAL LSAME, DLAMCH, DISNAN * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 * IF( LSAME( TYPE, 'G' ) ) THEN ITYPE = 0 ELSE IF( LSAME( TYPE, 'L' ) ) THEN ITYPE = 1 ELSE IF( LSAME( TYPE, 'U' ) ) THEN ITYPE = 2 ELSE IF( LSAME( TYPE, 'H' ) ) THEN ITYPE = 3 ELSE IF( LSAME( TYPE, 'B' ) ) THEN ITYPE = 4 ELSE IF( LSAME( TYPE, 'Q' ) ) THEN ITYPE = 5 ELSE IF( LSAME( TYPE, 'Z' ) ) THEN ITYPE = 6 ELSE ITYPE = -1 END IF * IF( ITYPE.EQ.-1 ) THEN INFO = -1 ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN INFO = -4 ELSE IF( DISNAN(CTO) ) THEN INFO = -5 ELSE IF( M.LT.0 ) THEN INFO = -6 ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN INFO = -7 ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN INFO = -9 ELSE IF( ITYPE.GE.4 ) THEN IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN INFO = -2 ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) $ THEN INFO = -3 ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN INFO = -9 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLASCL', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. M.EQ.0 ) $ RETURN * * Get machine parameters * SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM * CFROMC = CFROM CTOC = CTO * 10 CONTINUE CFROM1 = CFROMC*SMLNUM IF( CFROM1.EQ.CFROMC ) THEN ! CFROMC is an inf. Multiply by a correctly signed zero for ! finite CTOC, or a NaN if CTOC is infinite. MUL = CTOC / CFROMC DONE = .TRUE. CTO1 = CTOC ELSE CTO1 = CTOC / BIGNUM IF( CTO1.EQ.CTOC ) THEN ! CTOC is either 0 or an inf. In both cases, CTOC itself ! serves as the correct multiplication factor. MUL = CTOC DONE = .TRUE. CFROMC = ONE ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN MUL = SMLNUM DONE = .FALSE. CFROMC = CFROM1 ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN MUL = BIGNUM DONE = .FALSE. CTOC = CTO1 ELSE MUL = CTOC / CFROMC DONE = .TRUE. END IF END IF * IF( ITYPE.EQ.0 ) THEN * * Full matrix * DO 30 J = 1, N DO 20 I = 1, M A( I, J ) = A( I, J )*MUL 20 CONTINUE 30 CONTINUE * ELSE IF( ITYPE.EQ.1 ) THEN * * Lower triangular matrix * DO 50 J = 1, N DO 40 I = J, M A( I, J ) = A( I, J )*MUL 40 CONTINUE 50 CONTINUE * ELSE IF( ITYPE.EQ.2 ) THEN * * Upper triangular matrix * DO 70 J = 1, N DO 60 I = 1, MIN( J, M ) A( I, J ) = A( I, J )*MUL 60 CONTINUE 70 CONTINUE * ELSE IF( ITYPE.EQ.3 ) THEN * * Upper Hessenberg matrix * DO 90 J = 1, N DO 80 I = 1, MIN( J+1, M ) A( I, J ) = A( I, J )*MUL 80 CONTINUE 90 CONTINUE * ELSE IF( ITYPE.EQ.4 ) THEN * * Lower half of a symmetric band matrix * K3 = KL + 1 K4 = N + 1 DO 110 J = 1, N DO 100 I = 1, MIN( K3, K4-J ) A( I, J ) = A( I, J )*MUL 100 CONTINUE 110 CONTINUE * ELSE IF( ITYPE.EQ.5 ) THEN * * Upper half of a symmetric band matrix * K1 = KU + 2 K3 = KU + 1 DO 130 J = 1, N DO 120 I = MAX( K1-J, 1 ), K3 A( I, J ) = A( I, J )*MUL 120 CONTINUE 130 CONTINUE * ELSE IF( ITYPE.EQ.6 ) THEN * * Band matrix * K1 = KL + KU + 2 K2 = KL + 1 K3 = 2*KL + KU + 1 K4 = KL + KU + 1 + M DO 150 J = 1, N DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) A( I, J ) = A( I, J )*MUL 140 CONTINUE 150 CONTINUE * END IF * IF( .NOT.DONE ) $ GO TO 10 * RETURN * * End of DLASCL * END *> \brief \b DLASCL2 performs diagonal scaling on a vector. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASCL2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASCL2 ( M, N, D, X, LDX ) * * .. Scalar Arguments .. * INTEGER M, N, LDX * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), X( LDX, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLASCL2 performs a diagonal scaling on a vector: *> x <-- D * x *> where the diagonal matrix D is stored as a vector. *> *> Eventually to be replaced by BLAS_dge_diag_scale in the new BLAS *> standard. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of D and X. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of X. N >= 0. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, length M *> Diagonal matrix D, stored as a vector of length M. *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,N) *> On entry, the vector X to be scaled by D. *> On exit, the scaled vector. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the vector X. LDX >= M. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DLASCL2 ( M, N, D, X, LDX ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. INTEGER M, N, LDX * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), X( LDX, * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I, J * .. * .. Executable Statements .. * DO J = 1, N DO I = 1, M X( I, J ) = X( I, J ) * D( I ) END DO END DO RETURN END *> \brief \b DLASD0 computes the singular values of a real upper bidiagonal n-by-m matrix B with diagonal d and off-diagonal e. Used by sbdsdc. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASD0 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASD0( N, SQRE, D, E, U, LDU, VT, LDVT, SMLSIZ, IWORK, * WORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDU, LDVT, N, SMLSIZ, SQRE * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION D( * ), E( * ), U( LDU, * ), VT( LDVT, * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> Using a divide and conquer approach, DLASD0 computes the singular *> value decomposition (SVD) of a real upper bidiagonal N-by-M *> matrix B with diagonal D and offdiagonal E, where M = N + SQRE. *> The algorithm computes orthogonal matrices U and VT such that *> B = U * S * VT. The singular values S are overwritten on D. *> *> A related subroutine, DLASDA, computes only the singular values, *> and optionally, the singular vectors in compact form. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> On entry, the row dimension of the upper bidiagonal matrix. *> This is also the dimension of the main diagonal array D. *> \endverbatim *> *> \param[in] SQRE *> \verbatim *> SQRE is INTEGER *> Specifies the column dimension of the bidiagonal matrix. *> = 0: The bidiagonal matrix has column dimension M = N; *> = 1: The bidiagonal matrix has column dimension M = N+1; *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> On entry D contains the main diagonal of the bidiagonal *> matrix. *> On exit D, if INFO = 0, contains its singular values. *> \endverbatim *> *> \param[in,out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (M-1) *> Contains the subdiagonal entries of the bidiagonal matrix. *> On exit, E has been destroyed. *> \endverbatim *> *> \param[out] U *> \verbatim *> U is DOUBLE PRECISION array, dimension (LDU, N) *> On exit, U contains the left singular vectors. *> \endverbatim *> *> \param[in] LDU *> \verbatim *> LDU is INTEGER *> On entry, leading dimension of U. *> \endverbatim *> *> \param[out] VT *> \verbatim *> VT is DOUBLE PRECISION array, dimension (LDVT, M) *> On exit, VT**T contains the right singular vectors. *> \endverbatim *> *> \param[in] LDVT *> \verbatim *> LDVT is INTEGER *> On entry, leading dimension of VT. *> \endverbatim *> *> \param[in] SMLSIZ *> \verbatim *> SMLSIZ is INTEGER *> On entry, maximum size of the subproblems at the *> bottom of the computation tree. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (8*N) *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*M**2+2*M) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: if INFO = 1, a singular value did not converge *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup OTHERauxiliary * *> \par Contributors: * ================== *> *> Ming Gu and Huan Ren, Computer Science Division, University of *> California at Berkeley, USA *> * ===================================================================== SUBROUTINE DLASD0( N, SQRE, D, E, U, LDU, VT, LDVT, SMLSIZ, IWORK, $ WORK, INFO ) * * -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. INTEGER INFO, LDU, LDVT, N, SMLSIZ, SQRE * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION D( * ), E( * ), U( LDU, * ), VT( LDVT, * ), $ WORK( * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I, I1, IC, IDXQ, IDXQC, IM1, INODE, ITEMP, IWK, $ J, LF, LL, LVL, M, NCC, ND, NDB1, NDIML, NDIMR, $ NL, NLF, NLP1, NLVL, NR, NRF, NRP1, SQREI DOUBLE PRECISION ALPHA, BETA * .. * .. External Subroutines .. EXTERNAL DLASD1, DLASDQ, DLASDT, XERBLA * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 * IF( N.LT.0 ) THEN INFO = -1 ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN INFO = -2 END IF * M = N + SQRE * IF( LDU.LT.N ) THEN INFO = -6 ELSE IF( LDVT.LT.M ) THEN INFO = -8 ELSE IF( SMLSIZ.LT.3 ) THEN INFO = -9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLASD0', -INFO ) RETURN END IF * * If the input matrix is too small, call DLASDQ to find the SVD. * IF( N.LE.SMLSIZ ) THEN CALL DLASDQ( 'U', SQRE, N, M, N, 0, D, E, VT, LDVT, U, LDU, U, $ LDU, WORK, INFO ) RETURN END IF * * Set up the computation tree. * INODE = 1 NDIML = INODE + N NDIMR = NDIML + N IDXQ = NDIMR + N IWK = IDXQ + N CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ), $ IWORK( NDIMR ), SMLSIZ ) * * For the nodes on bottom level of the tree, solve * their subproblems by DLASDQ. * NDB1 = ( ND+1 ) / 2 NCC = 0 DO 30 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 ) NLP1 = NL + 1 NR = IWORK( NDIMR+I1 ) NRP1 = NR + 1 NLF = IC - NL NRF = IC + 1 SQREI = 1 CALL DLASDQ( 'U', SQREI, NL, NLP1, NL, NCC, D( NLF ), E( NLF ), $ VT( NLF, NLF ), LDVT, U( NLF, NLF ), LDU, $ U( NLF, NLF ), LDU, WORK, INFO ) IF( INFO.NE.0 ) THEN RETURN END IF ITEMP = IDXQ + NLF - 2 DO 10 J = 1, NL IWORK( ITEMP+J ) = J 10 CONTINUE IF( I.EQ.ND ) THEN SQREI = SQRE ELSE SQREI = 1 END IF NRP1 = NR + SQREI CALL DLASDQ( 'U', SQREI, NR, NRP1, NR, NCC, D( NRF ), E( NRF ), $ VT( NRF, NRF ), LDVT, U( NRF, NRF ), LDU, $ U( NRF, NRF ), LDU, WORK, INFO ) IF( INFO.NE.0 ) THEN RETURN END IF ITEMP = IDXQ + IC DO 20 J = 1, NR IWORK( ITEMP+J-1 ) = J 20 CONTINUE 30 CONTINUE * * Now conquer each subproblem bottom-up. * DO 50 LVL = NLVL, 1, -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 40 I = LF, LL IM1 = I - 1 IC = IWORK( INODE+IM1 ) NL = IWORK( NDIML+IM1 ) NR = IWORK( NDIMR+IM1 ) NLF = IC - NL IF( ( SQRE.EQ.0 ) .AND. ( I.EQ.LL ) ) THEN SQREI = SQRE ELSE SQREI = 1 END IF IDXQC = IDXQ + NLF - 1 ALPHA = D( IC ) BETA = E( IC ) CALL DLASD1( NL, NR, SQREI, D( NLF ), ALPHA, BETA, $ U( NLF, NLF ), LDU, VT( NLF, NLF ), LDVT, $ IWORK( IDXQC ), IWORK( IWK ), WORK, INFO ) * * Report the possible convergence failure. * IF( INFO.NE.0 ) THEN RETURN END IF 40 CONTINUE 50 CONTINUE * RETURN * * End of DLASD0 * END *> \brief \b DLASD1 computes the SVD of an upper bidiagonal matrix B of the specified size. Used by sbdsdc. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASD1 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT, * IDXQ, IWORK, WORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDU, LDVT, NL, NR, SQRE * DOUBLE PRECISION ALPHA, BETA * .. * .. Array Arguments .. * INTEGER IDXQ( * ), IWORK( * ) * DOUBLE PRECISION D( * ), U( LDU, * ), VT( LDVT, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B, *> where N = NL + NR + 1 and M = N + SQRE. DLASD1 is called from DLASD0. *> *> A related subroutine DLASD7 handles the case in which the singular *> values (and the singular vectors in factored form) are desired. *> *> DLASD1 computes the SVD as follows: *> *> ( D1(in) 0 0 0 ) *> B = U(in) * ( Z1**T a Z2**T b ) * VT(in) *> ( 0 0 D2(in) 0 ) *> *> = U(out) * ( D(out) 0) * VT(out) *> *> where Z**T = (Z1**T a Z2**T b) = u**T VT**T, and u is a vector of dimension M *> with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros *> elsewhere; and the entry b is empty if SQRE = 0. *> *> The left singular vectors of the original matrix are stored in U, and *> the transpose of the right singular vectors are stored in VT, and the *> singular values are in D. The algorithm consists of three stages: *> *> The first stage consists of deflating the size of the problem *> when there are multiple singular values or when there are zeros in *> the Z vector. For each such occurrence the dimension of the *> secular equation problem is reduced by one. This stage is *> performed by the routine DLASD2. *> *> The second stage consists of calculating the updated *> singular values. This is done by finding the square roots of the *> roots of the secular equation via the routine DLASD4 (as called *> by DLASD3). This routine also calculates the singular vectors of *> the current problem. *> *> The final stage consists of computing the updated singular vectors *> directly using the updated singular values. The singular vectors *> for the current problem are multiplied with the singular vectors *> from the overall problem. *> \endverbatim * * Arguments: * ========== * *> \param[in] NL *> \verbatim *> NL is INTEGER *> The row dimension of the upper block. NL >= 1. *> \endverbatim *> *> \param[in] NR *> \verbatim *> NR is INTEGER *> The row dimension of the lower block. NR >= 1. *> \endverbatim *> *> \param[in] SQRE *> \verbatim *> SQRE is 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. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION array, *> dimension (N = NL+NR+1). *> On entry D(1:NL,1:NL) contains the singular values of the *> upper block; and D(NL+2:N) contains the singular values of *> the lower block. On exit D(1:N) contains the singular values *> of the modified matrix. *> \endverbatim *> *> \param[in,out] ALPHA *> \verbatim *> ALPHA is DOUBLE PRECISION *> Contains the diagonal element associated with the added row. *> \endverbatim *> *> \param[in,out] BETA *> \verbatim *> BETA is DOUBLE PRECISION *> Contains the off-diagonal element associated with the added *> row. *> \endverbatim *> *> \param[in,out] U *> \verbatim *> U is DOUBLE PRECISION array, dimension(LDU,N) *> On entry U(1:NL, 1:NL) contains the left singular vectors of *> the upper block; U(NL+2:N, NL+2:N) contains the left singular *> vectors of the lower block. On exit U contains the left *> singular vectors of the bidiagonal matrix. *> \endverbatim *> *> \param[in] LDU *> \verbatim *> LDU is INTEGER *> The leading dimension of the array U. LDU >= max( 1, N ). *> \endverbatim *> *> \param[in,out] VT *> \verbatim *> VT is DOUBLE PRECISION array, dimension(LDVT,M) *> where M = N + SQRE. *> On entry VT(1:NL+1, 1:NL+1)**T contains the right singular *> vectors of the upper block; VT(NL+2:M, NL+2:M)**T contains *> the right singular vectors of the lower block. On exit *> VT**T contains the right singular vectors of the *> bidiagonal matrix. *> \endverbatim *> *> \param[in] LDVT *> \verbatim *> LDVT is INTEGER *> The leading dimension of the array VT. LDVT >= max( 1, M ). *> \endverbatim *> *> \param[in,out] IDXQ *> \verbatim *> IDXQ is INTEGER array, dimension(N) *> This contains the permutation which will reintegrate the *> subproblem just solved back into sorted order, i.e. *> D( IDXQ( I = 1, N ) ) will be in ascending order. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension( 4 * N ) *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension( 3*M**2 + 2*M ) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: if INFO = 1, a singular value did not converge *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup OTHERauxiliary * *> \par Contributors: * ================== *> *> Ming Gu and Huan Ren, Computer Science Division, University of *> California at Berkeley, USA *> * ===================================================================== SUBROUTINE DLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT, $ IDXQ, IWORK, WORK, INFO ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. INTEGER INFO, LDU, LDVT, NL, NR, SQRE DOUBLE PRECISION ALPHA, BETA * .. * .. Array Arguments .. INTEGER IDXQ( * ), IWORK( * ) DOUBLE PRECISION D( * ), U( LDU, * ), VT( LDVT, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. * DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER COLTYP, I, IDX, IDXC, IDXP, IQ, ISIGMA, IU2, $ IVT2, IZ, K, LDQ, LDU2, LDVT2, M, N, N1, N2 DOUBLE PRECISION ORGNRM * .. * .. External Subroutines .. EXTERNAL DLAMRG, DLASCL, DLASD2, DLASD3, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 * IF( NL.LT.1 ) THEN INFO = -1 ELSE IF( NR.LT.1 ) THEN INFO = -2 ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN INFO = -3 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLASD1', -INFO ) RETURN END IF * N = NL + NR + 1 M = N + SQRE * * 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 DLASD2 and DLASD3. * LDU2 = N LDVT2 = M * IZ = 1 ISIGMA = IZ + M IU2 = ISIGMA + N IVT2 = IU2 + LDU2*N IQ = IVT2 + LDVT2*M * IDX = 1 IDXC = IDX + N COLTYP = IDXC + N IDXP = COLTYP + N * * Scale. * ORGNRM = MAX( ABS( ALPHA ), ABS( BETA ) ) D( NL+1 ) = ZERO DO 10 I = 1, N IF( ABS( D( I ) ).GT.ORGNRM ) THEN ORGNRM = ABS( D( I ) ) END IF 10 CONTINUE CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO ) ALPHA = ALPHA / ORGNRM BETA = BETA / ORGNRM * * Deflate singular values. * CALL DLASD2( NL, NR, SQRE, K, D, WORK( IZ ), ALPHA, BETA, U, LDU, $ VT, LDVT, WORK( ISIGMA ), WORK( IU2 ), LDU2, $ WORK( IVT2 ), LDVT2, IWORK( IDXP ), IWORK( IDX ), $ IWORK( IDXC ), IDXQ, IWORK( COLTYP ), INFO ) * * Solve Secular Equation and update singular vectors. * LDQ = K CALL DLASD3( NL, NR, SQRE, K, D, WORK( IQ ), LDQ, WORK( ISIGMA ), $ U, LDU, WORK( IU2 ), LDU2, VT, LDVT, WORK( IVT2 ), $ LDVT2, IWORK( IDXC ), IWORK( COLTYP ), WORK( IZ ), $ INFO ) * * Report the convergence failure. * IF( INFO.NE.0 ) THEN RETURN END IF * * Unscale. * CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO ) * * Prepare the IDXQ sorting permutation. * N1 = K N2 = N - K CALL DLAMRG( N1, N2, D, 1, -1, IDXQ ) * RETURN * * End of DLASD1 * END *> \brief \b DLASD2 merges the two sets of singular values together into a single sorted set. Used by sbdsdc. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASD2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, * LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX, * IDXC, IDXQ, COLTYP, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, K, LDU, LDU2, LDVT, LDVT2, NL, NR, SQRE * DOUBLE PRECISION ALPHA, BETA * .. * .. Array Arguments .. * INTEGER COLTYP( * ), IDX( * ), IDXC( * ), IDXP( * ), * $ IDXQ( * ) * DOUBLE PRECISION D( * ), DSIGMA( * ), U( LDU, * ), * $ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ), * $ Z( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLASD2 merges the two sets of singular values 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 *> singular values 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. *> *> DLASD2 is called from DLASD1. *> \endverbatim * * Arguments: * ========== * *> \param[in] NL *> \verbatim *> NL is INTEGER *> The row dimension of the upper block. NL >= 1. *> \endverbatim *> *> \param[in] NR *> \verbatim *> NR is INTEGER *> The row dimension of the lower block. NR >= 1. *> \endverbatim *> *> \param[in] SQRE *> \verbatim *> SQRE is 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 N = NL + NR + 1 rows and *> M = N + SQRE >= N columns. *> \endverbatim *> *> \param[out] K *> \verbatim *> K is INTEGER *> Contains the dimension of the non-deflated matrix, *> This is the order of the related secular equation. 1 <= K <=N. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension(N) *> On entry D contains the singular values of the two submatrices *> to be combined. On exit D contains the trailing (N-K) updated *> singular values (those which were deflated) sorted into *> increasing order. *> \endverbatim *> *> \param[out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension(N) *> On exit Z contains the updating row vector in the secular *> equation. *> \endverbatim *> *> \param[in] ALPHA *> \verbatim *> ALPHA is DOUBLE PRECISION *> Contains the diagonal element associated with the added row. *> \endverbatim *> *> \param[in] BETA *> \verbatim *> BETA is DOUBLE PRECISION *> Contains the off-diagonal element associated with the added *> row. *> \endverbatim *> *> \param[in,out] U *> \verbatim *> U is DOUBLE PRECISION array, dimension(LDU,N) *> On entry U contains the left singular vectors of two *> submatrices in the two square blocks with corners at (1,1), *> (NL, NL), and (NL+2, NL+2), (N,N). *> On exit U contains the trailing (N-K) updated left singular *> vectors (those which were deflated) in its last N-K columns. *> \endverbatim *> *> \param[in] LDU *> \verbatim *> LDU is INTEGER *> The leading dimension of the array U. LDU >= N. *> \endverbatim *> *> \param[in,out] VT *> \verbatim *> VT is DOUBLE PRECISION array, dimension(LDVT,M) *> On entry VT**T contains the right singular vectors of two *> submatrices in the two square blocks with corners at (1,1), *> (NL+1, NL+1), and (NL+2, NL+2), (M,M). *> On exit VT**T contains the trailing (N-K) updated right singular *> vectors (those which were deflated) in its last N-K columns. *> In case SQRE =1, the last row of VT spans the right null *> space. *> \endverbatim *> *> \param[in] LDVT *> \verbatim *> LDVT is INTEGER *> The leading dimension of the array VT. LDVT >= M. *> \endverbatim *> *> \param[out] DSIGMA *> \verbatim *> DSIGMA is DOUBLE PRECISION array, dimension (N) *> Contains a copy of the diagonal elements (K-1 singular values *> and one zero) in the secular equation. *> \endverbatim *> *> \param[out] U2 *> \verbatim *> U2 is DOUBLE PRECISION array, dimension(LDU2,N) *> Contains a copy of the first K-1 left singular vectors which *> will be used by DLASD3 in a matrix multiply (DGEMM) to solve *> for the new left singular vectors. U2 is arranged into four *> blocks. The first block contains a column with 1 at NL+1 and *> zero everywhere else; the second block contains non-zero *> entries only at and above NL; the third contains non-zero *> entries only below NL+1; and the fourth is dense. *> \endverbatim *> *> \param[in] LDU2 *> \verbatim *> LDU2 is INTEGER *> The leading dimension of the array U2. LDU2 >= N. *> \endverbatim *> *> \param[out] VT2 *> \verbatim *> VT2 is DOUBLE PRECISION array, dimension(LDVT2,N) *> VT2**T contains a copy of the first K right singular vectors *> which will be used by DLASD3 in a matrix multiply (DGEMM) to *> solve for the new right singular vectors. VT2 is arranged into *> three blocks. The first block contains a row that corresponds *> to the special 0 diagonal element in SIGMA; the second block *> contains non-zeros only at and before NL +1; the third block *> contains non-zeros only at and after NL +2. *> \endverbatim *> *> \param[in] LDVT2 *> \verbatim *> LDVT2 is INTEGER *> The leading dimension of the array VT2. LDVT2 >= M. *> \endverbatim *> *> \param[out] IDXP *> \verbatim *> IDXP is INTEGER array, dimension(N) *> This will contain the permutation used to place deflated *> values of D at the end of the array. On output IDXP(2:K) *> points to the nondeflated D-values and IDXP(K+1:N) *> points to the deflated singular values. *> \endverbatim *> *> \param[out] IDX *> \verbatim *> IDX is INTEGER array, dimension(N) *> This will contain the permutation used to sort the contents of *> D into ascending order. *> \endverbatim *> *> \param[out] IDXC *> \verbatim *> IDXC is INTEGER array, dimension(N) *> This will contain the permutation used to arrange the columns *> of the deflated U matrix into three groups: the first group *> contains non-zero entries only at and above NL, the second *> contains non-zero entries only below NL+2, and the third is *> dense. *> \endverbatim *> *> \param[in,out] IDXQ *> \verbatim *> IDXQ is INTEGER array, dimension(N) *> This contains the permutation which separately sorts the two *> sub-problems in D into ascending order. Note that entries in *> the first hlaf of this permutation must first be moved one *> position backward; and entries in the second half *> must first have NL+1 added to their values. *> \endverbatim *> *> \param[out] COLTYP *> \verbatim *> COLTYP is INTEGER array, dimension(N) *> As workspace, this will contain a label which will indicate *> which of the following types a column in the U2 matrix or a *> row in the VT2 matrix is: *> 1 : non-zero in the upper half only *> 2 : non-zero in the lower half only *> 3 : dense *> 4 : deflated *> *> On exit, it is an array of dimension 4, with COLTYP(I) being *> the dimension of the I-th type columns. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup OTHERauxiliary * *> \par Contributors: * ================== *> *> Ming Gu and Huan Ren, Computer Science Division, University of *> California at Berkeley, USA *> * ===================================================================== SUBROUTINE DLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, $ LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX, $ IDXC, IDXQ, COLTYP, INFO ) * * -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. INTEGER INFO, K, LDU, LDU2, LDVT, LDVT2, NL, NR, SQRE DOUBLE PRECISION ALPHA, BETA * .. * .. Array Arguments .. INTEGER COLTYP( * ), IDX( * ), IDXC( * ), IDXP( * ), $ IDXQ( * ) DOUBLE PRECISION D( * ), DSIGMA( * ), U( LDU, * ), $ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ), $ Z( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, EIGHT PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, $ EIGHT = 8.0D+0 ) * .. * .. Local Arrays .. INTEGER CTOT( 4 ), PSM( 4 ) * .. * .. Local Scalars .. INTEGER CT, I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M, $ N, NLP1, NLP2 DOUBLE PRECISION C, EPS, HLFTOL, S, TAU, TOL, Z1 * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLAPY2 EXTERNAL DLAMCH, DLAPY2 * .. * .. External Subroutines .. EXTERNAL DCOPY, DLACPY, DLAMRG, DLASET, DROT, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 * IF( NL.LT.1 ) THEN INFO = -1 ELSE IF( NR.LT.1 ) THEN INFO = -2 ELSE IF( ( SQRE.NE.1 ) .AND. ( SQRE.NE.0 ) ) THEN INFO = -3 END IF * N = NL + NR + 1 M = N + SQRE * IF( LDU.LT.N ) THEN INFO = -10 ELSE IF( LDVT.LT.M ) THEN INFO = -12 ELSE IF( LDU2.LT.N ) THEN INFO = -15 ELSE IF( LDVT2.LT.M ) THEN INFO = -17 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLASD2', -INFO ) RETURN END IF * NLP1 = NL + 1 NLP2 = NL + 2 * * Generate the first part of the vector Z; and move the singular * values in the first part of D one position backward. * Z1 = ALPHA*VT( NLP1, NLP1 ) Z( 1 ) = Z1 DO 10 I = NL, 1, -1 Z( I+1 ) = ALPHA*VT( I, NLP1 ) D( I+1 ) = D( I ) IDXQ( I+1 ) = IDXQ( I ) + 1 10 CONTINUE * * Generate the second part of the vector Z. * DO 20 I = NLP2, M Z( I ) = BETA*VT( I, NLP2 ) 20 CONTINUE * * Initialize some reference arrays. * DO 30 I = 2, NLP1 COLTYP( I ) = 1 30 CONTINUE DO 40 I = NLP2, N COLTYP( I ) = 2 40 CONTINUE * * Sort the singular values into increasing order * DO 50 I = NLP2, N IDXQ( I ) = IDXQ( I ) + NLP1 50 CONTINUE * * DSIGMA, IDXC, IDXC, and the first column of U2 * are used as storage space. * DO 60 I = 2, N DSIGMA( I ) = D( IDXQ( I ) ) U2( I, 1 ) = Z( IDXQ( I ) ) IDXC( I ) = COLTYP( IDXQ( I ) ) 60 CONTINUE * CALL DLAMRG( NL, NR, DSIGMA( 2 ), 1, 1, IDX( 2 ) ) * DO 70 I = 2, N IDXI = 1 + IDX( I ) D( I ) = DSIGMA( IDXI ) Z( I ) = U2( IDXI, 1 ) COLTYP( I ) = IDXC( IDXI ) 70 CONTINUE * * Calculate the allowable deflation tolerance * EPS = DLAMCH( 'Epsilon' ) TOL = MAX( ABS( ALPHA ), ABS( BETA ) ) TOL = EIGHT*EPS*MAX( ABS( D( N ) ), TOL ) * * There are 2 kinds of deflation -- first a value in the z-vector * is small, second two (or more) singular values are very close * together (their difference is small). * * If the value in the z-vector is small, we simply permute the * array so that the corresponding singular value is moved to the * end. * * If two values in the D-vector are close, we perform a two-sided * rotation designed to make one of the corresponding z-vector * entries zero, and then permute the array so that the deflated * singular value is moved to the end. * * If there are multiple singular values then the problem deflates. * Here the number of equal singular values are found. As each equal * singular value is found, an elementary reflector is computed to * rotate the corresponding singular subspace so that the * corresponding components of Z are zero in this new basis. * K = 1 K2 = N + 1 DO 80 J = 2, N IF( ABS( Z( J ) ).LE.TOL ) THEN * * Deflate due to small z component. * K2 = K2 - 1 IDXP( K2 ) = J COLTYP( J ) = 4 IF( J.EQ.N ) $ GO TO 120 ELSE JPREV = J GO TO 90 END IF 80 CONTINUE 90 CONTINUE J = JPREV 100 CONTINUE J = J + 1 IF( J.GT.N ) $ GO TO 110 IF( ABS( Z( J ) ).LE.TOL ) THEN * * Deflate due to small z component. * K2 = K2 - 1 IDXP( K2 ) = J COLTYP( J ) = 4 ELSE * * Check if singular values are close enough to allow deflation. * IF( ABS( D( J )-D( JPREV ) ).LE.TOL ) THEN * * Deflation is possible. * S = Z( JPREV ) C = Z( J ) * * Find sqrt(a**2+b**2) without overflow or * destructive underflow. * TAU = DLAPY2( C, S ) C = C / TAU S = -S / TAU Z( J ) = TAU Z( JPREV ) = ZERO * * Apply back the Givens rotation to the left and right * singular vector matrices. * IDXJP = IDXQ( IDX( JPREV )+1 ) IDXJ = IDXQ( IDX( J )+1 ) IF( IDXJP.LE.NLP1 ) THEN IDXJP = IDXJP - 1 END IF IF( IDXJ.LE.NLP1 ) THEN IDXJ = IDXJ - 1 END IF CALL DROT( N, U( 1, IDXJP ), 1, U( 1, IDXJ ), 1, C, S ) CALL DROT( M, VT( IDXJP, 1 ), LDVT, VT( IDXJ, 1 ), LDVT, C, $ S ) IF( COLTYP( J ).NE.COLTYP( JPREV ) ) THEN COLTYP( J ) = 3 END IF COLTYP( JPREV ) = 4 K2 = K2 - 1 IDXP( K2 ) = JPREV JPREV = J ELSE K = K + 1 U2( K, 1 ) = Z( JPREV ) DSIGMA( K ) = D( JPREV ) IDXP( K ) = JPREV JPREV = J END IF END IF GO TO 100 110 CONTINUE * * Record the last singular value. * K = K + 1 U2( K, 1 ) = Z( JPREV ) DSIGMA( K ) = D( JPREV ) IDXP( K ) = JPREV * 120 CONTINUE * * Count up the total number of the various types of columns, then * form a permutation which positions the four column types into * four groups of uniform structure (although one or more of these * groups may be empty). * DO 130 J = 1, 4 CTOT( J ) = 0 130 CONTINUE DO 140 J = 2, N CT = COLTYP( J ) CTOT( CT ) = CTOT( CT ) + 1 140 CONTINUE * * PSM(*) = Position in SubMatrix (of types 1 through 4) * PSM( 1 ) = 2 PSM( 2 ) = 2 + CTOT( 1 ) PSM( 3 ) = PSM( 2 ) + CTOT( 2 ) PSM( 4 ) = PSM( 3 ) + CTOT( 3 ) * * Fill out the IDXC 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, starting from the * second column. This applies similarly to the rows of VT. * DO 150 J = 2, N JP = IDXP( J ) CT = COLTYP( JP ) IDXC( PSM( CT ) ) = J PSM( CT ) = PSM( CT ) + 1 150 CONTINUE * * Sort the singular values and corresponding singular vectors into * DSIGMA, U2, and VT2 respectively. The singular values/vectors * which were not deflated go into the first K slots of DSIGMA, U2, * and VT2 respectively, while those which were deflated go into the * last N - K slots, except that the first column/row will be treated * separately. * DO 160 J = 2, N JP = IDXP( J ) DSIGMA( J ) = D( JP ) IDXJ = IDXQ( IDX( IDXP( IDXC( J ) ) )+1 ) IF( IDXJ.LE.NLP1 ) THEN IDXJ = IDXJ - 1 END IF CALL DCOPY( N, U( 1, IDXJ ), 1, U2( 1, J ), 1 ) CALL DCOPY( M, VT( IDXJ, 1 ), LDVT, VT2( J, 1 ), LDVT2 ) 160 CONTINUE * * Determine DSIGMA(1), DSIGMA(2) and Z(1) * DSIGMA( 1 ) = ZERO HLFTOL = TOL / TWO IF( ABS( DSIGMA( 2 ) ).LE.HLFTOL ) $ DSIGMA( 2 ) = HLFTOL IF( M.GT.N ) THEN Z( 1 ) = DLAPY2( Z1, Z( M ) ) IF( Z( 1 ).LE.TOL ) THEN C = ONE S = ZERO Z( 1 ) = TOL ELSE C = Z1 / Z( 1 ) S = Z( M ) / Z( 1 ) END IF ELSE IF( ABS( Z1 ).LE.TOL ) THEN Z( 1 ) = TOL ELSE Z( 1 ) = Z1 END IF END IF * * Move the rest of the updating row to Z. * CALL DCOPY( K-1, U2( 2, 1 ), 1, Z( 2 ), 1 ) * * Determine the first column of U2, the first row of VT2 and the * last row of VT. * CALL DLASET( 'A', N, 1, ZERO, ZERO, U2, LDU2 ) U2( NLP1, 1 ) = ONE IF( M.GT.N ) THEN DO 170 I = 1, NLP1 VT( M, I ) = -S*VT( NLP1, I ) VT2( 1, I ) = C*VT( NLP1, I ) 170 CONTINUE DO 180 I = NLP2, M VT2( 1, I ) = S*VT( M, I ) VT( M, I ) = C*VT( M, I ) 180 CONTINUE ELSE CALL DCOPY( M, VT( NLP1, 1 ), LDVT, VT2( 1, 1 ), LDVT2 ) END IF IF( M.GT.N ) THEN CALL DCOPY( M, VT( M, 1 ), LDVT, VT2( M, 1 ), LDVT2 ) END IF * * The deflated singular values and their corresponding vectors go * into the back of D, U, and V respectively. * IF( N.GT.K ) THEN CALL DCOPY( N-K, DSIGMA( K+1 ), 1, D( K+1 ), 1 ) CALL DLACPY( 'A', N, N-K, U2( 1, K+1 ), LDU2, U( 1, K+1 ), $ LDU ) CALL DLACPY( 'A', N-K, M, VT2( K+1, 1 ), LDVT2, VT( K+1, 1 ), $ LDVT ) END IF * * Copy CTOT into COLTYP for referencing in DLASD3. * DO 190 J = 1, 4 COLTYP( J ) = CTOT( J ) 190 CONTINUE * RETURN * * End of DLASD2 * END *> \brief \b DLASD3 finds all square roots of the roots of the secular equation, as defined by the values in D and Z, and then updates the singular vectors by matrix multiplication. Used by sbdsdc. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASD3 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASD3( NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2, * LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z, * INFO ) * * .. Scalar Arguments .. * INTEGER INFO, K, LDQ, LDU, LDU2, LDVT, LDVT2, NL, NR, * $ SQRE * .. * .. Array Arguments .. * INTEGER CTOT( * ), IDXC( * ) * DOUBLE PRECISION D( * ), DSIGMA( * ), Q( LDQ, * ), U( LDU, * ), * $ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ), * $ Z( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLASD3 finds all the square roots of the roots of the secular *> equation, as defined by the values in D and Z. It makes the *> appropriate calls to DLASD4 and then updates the singular *> vectors by matrix multiplication. *> *> 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. *> *> DLASD3 is called from DLASD1. *> \endverbatim * * Arguments: * ========== * *> \param[in] NL *> \verbatim *> NL is INTEGER *> The row dimension of the upper block. NL >= 1. *> \endverbatim *> *> \param[in] NR *> \verbatim *> NR is INTEGER *> The row dimension of the lower block. NR >= 1. *> \endverbatim *> *> \param[in] SQRE *> \verbatim *> SQRE is 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 N = NL + NR + 1 rows and *> M = N + SQRE >= N columns. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The size of the secular equation, 1 =< K = < N. *> \endverbatim *> *> \param[out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension(K) *> On exit the square roots of the roots of the secular equation, *> in ascending order. *> \endverbatim *> *> \param[out] Q *> \verbatim *> Q is DOUBLE PRECISION array, dimension (LDQ,K) *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= K. *> \endverbatim *> *> \param[in,out] DSIGMA *> \verbatim *> DSIGMA is 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. *> \endverbatim *> *> \param[out] U *> \verbatim *> U is DOUBLE PRECISION array, dimension (LDU, N) *> The last N - K columns of this matrix contain the deflated *> left singular vectors. *> \endverbatim *> *> \param[in] LDU *> \verbatim *> LDU is INTEGER *> The leading dimension of the array U. LDU >= N. *> \endverbatim *> *> \param[in] U2 *> \verbatim *> U2 is DOUBLE PRECISION array, dimension (LDU2, N) *> The first K columns of this matrix contain the non-deflated *> left singular vectors for the split problem. *> \endverbatim *> *> \param[in] LDU2 *> \verbatim *> LDU2 is INTEGER *> The leading dimension of the array U2. LDU2 >= N. *> \endverbatim *> *> \param[out] VT *> \verbatim *> VT is DOUBLE PRECISION array, dimension (LDVT, M) *> The last M - K columns of VT**T contain the deflated *> right singular vectors. *> \endverbatim *> *> \param[in] LDVT *> \verbatim *> LDVT is INTEGER *> The leading dimension of the array VT. LDVT >= N. *> \endverbatim *> *> \param[in,out] VT2 *> \verbatim *> VT2 is DOUBLE PRECISION array, dimension (LDVT2, N) *> The first K columns of VT2**T contain the non-deflated *> right singular vectors for the split problem. *> \endverbatim *> *> \param[in] LDVT2 *> \verbatim *> LDVT2 is INTEGER *> The leading dimension of the array VT2. LDVT2 >= N. *> \endverbatim *> *> \param[in] IDXC *> \verbatim *> IDXC is INTEGER array, dimension ( N ) *> The permutation used to arrange the columns of U (and rows of *> VT) into three groups: the first group contains non-zero *> entries only at and above (or before) NL +1; the second *> contains non-zero entries only at and below (or after) NL+2; *> and the third is dense. The first column of U and the row of *> VT are treated separately, however. *> *> The rows of the singular vectors found by DLASD4 *> must be likewise permuted before the matrix multiplies can *> take place. *> \endverbatim *> *> \param[in] CTOT *> \verbatim *> CTOT is INTEGER array, dimension ( 4 ) *> A count of the total number of the various types of columns *> in U (or rows in VT), as described in IDXC. The fourth column *> type is any column which has been deflated. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (K) *> The first K elements of this array contain the components *> of the deflation-adjusted updating row vector. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: if INFO = 1, a singular value did not converge *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup OTHERauxiliary * *> \par Contributors: * ================== *> *> Ming Gu and Huan Ren, Computer Science Division, University of *> California at Berkeley, USA *> * ===================================================================== SUBROUTINE DLASD3( NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2, $ LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z, $ INFO ) * * -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. INTEGER INFO, K, LDQ, LDU, LDU2, LDVT, LDVT2, NL, NR, $ SQRE * .. * .. Array Arguments .. INTEGER CTOT( * ), IDXC( * ) DOUBLE PRECISION D( * ), DSIGMA( * ), Q( LDQ, * ), U( LDU, * ), $ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ), $ Z( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO, NEGONE PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0, $ NEGONE = -1.0D+0 ) * .. * .. Local Scalars .. INTEGER CTEMP, I, J, JC, KTEMP, M, N, NLP1, NLP2, NRP1 DOUBLE PRECISION RHO, TEMP * .. * .. External Functions .. DOUBLE PRECISION DLAMC3, DNRM2 EXTERNAL DLAMC3, DNRM2 * .. * .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DLACPY, DLASCL, DLASD4, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, SIGN, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 * IF( NL.LT.1 ) THEN INFO = -1 ELSE IF( NR.LT.1 ) THEN INFO = -2 ELSE IF( ( SQRE.NE.1 ) .AND. ( SQRE.NE.0 ) ) THEN INFO = -3 END IF * N = NL + NR + 1 M = N + SQRE NLP1 = NL + 1 NLP2 = NL + 2 * IF( ( K.LT.1 ) .OR. ( K.GT.N ) ) THEN INFO = -4 ELSE IF( LDQ.LT.K ) THEN INFO = -7 ELSE IF( LDU.LT.N ) THEN INFO = -10 ELSE IF( LDU2.LT.N ) THEN INFO = -12 ELSE IF( LDVT.LT.M ) THEN INFO = -14 ELSE IF( LDVT2.LT.M ) THEN INFO = -16 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLASD3', -INFO ) RETURN END IF * * Quick return if possible * IF( K.EQ.1 ) THEN D( 1 ) = ABS( Z( 1 ) ) CALL DCOPY( M, VT2( 1, 1 ), LDVT2, VT( 1, 1 ), LDVT ) IF( Z( 1 ).GT.ZERO ) THEN CALL DCOPY( N, U2( 1, 1 ), 1, U( 1, 1 ), 1 ) ELSE DO 10 I = 1, N U( I, 1 ) = -U2( I, 1 ) 10 CONTINUE END IF RETURN END IF * * Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(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 DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I), * which on any of these machines zeros out the bottommost * bit of DSIGMA(I) if it is 1; this makes the subsequent * subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation * occurs. On binary machines with a guard digit (almost all * machines) it does not change DSIGMA(I) at all. On hexadecimal * and decimal machines with a guard digit, it slightly * changes the bottommost bits of DSIGMA(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*DSIGMA(I) to prevent optimizing compilers from eliminating * this code. * DO 20 I = 1, K DSIGMA( I ) = DLAMC3( DSIGMA( I ), DSIGMA( I ) ) - DSIGMA( I ) 20 CONTINUE * * Keep a copy of Z. * CALL DCOPY( K, Z, 1, Q, 1 ) * * Normalize Z. * RHO = DNRM2( K, Z, 1 ) CALL DLASCL( 'G', 0, 0, RHO, ONE, K, 1, Z, K, INFO ) RHO = RHO*RHO * * Find the new singular values. * DO 30 J = 1, K CALL DLASD4( K, J, DSIGMA, Z, U( 1, J ), RHO, D( J ), $ VT( 1, J ), INFO ) * * If the zero finder fails, report the convergence failure. * IF( INFO.NE.0 ) THEN RETURN END IF 30 CONTINUE * * Compute updated Z. * DO 60 I = 1, K Z( I ) = U( I, K )*VT( I, K ) DO 40 J = 1, I - 1 Z( I ) = Z( I )*( U( I, J )*VT( I, J ) / $ ( DSIGMA( I )-DSIGMA( J ) ) / $ ( DSIGMA( I )+DSIGMA( J ) ) ) 40 CONTINUE DO 50 J = I, K - 1 Z( I ) = Z( I )*( U( I, J )*VT( I, J ) / $ ( DSIGMA( I )-DSIGMA( J+1 ) ) / $ ( DSIGMA( I )+DSIGMA( J+1 ) ) ) 50 CONTINUE Z( I ) = SIGN( SQRT( ABS( Z( I ) ) ), Q( I, 1 ) ) 60 CONTINUE * * Compute left singular vectors of the modified diagonal matrix, * and store related information for the right singular vectors. * DO 90 I = 1, K VT( 1, I ) = Z( 1 ) / U( 1, I ) / VT( 1, I ) U( 1, I ) = NEGONE DO 70 J = 2, K VT( J, I ) = Z( J ) / U( J, I ) / VT( J, I ) U( J, I ) = DSIGMA( J )*VT( J, I ) 70 CONTINUE TEMP = DNRM2( K, U( 1, I ), 1 ) Q( 1, I ) = U( 1, I ) / TEMP DO 80 J = 2, K JC = IDXC( J ) Q( J, I ) = U( JC, I ) / TEMP 80 CONTINUE 90 CONTINUE * * Update the left singular vector matrix. * IF( K.EQ.2 ) THEN CALL DGEMM( 'N', 'N', N, K, K, ONE, U2, LDU2, Q, LDQ, ZERO, U, $ LDU ) GO TO 100 END IF IF( CTOT( 1 ).GT.0 ) THEN CALL DGEMM( 'N', 'N', NL, K, CTOT( 1 ), ONE, U2( 1, 2 ), LDU2, $ Q( 2, 1 ), LDQ, ZERO, U( 1, 1 ), LDU ) IF( CTOT( 3 ).GT.0 ) THEN KTEMP = 2 + CTOT( 1 ) + CTOT( 2 ) CALL DGEMM( 'N', 'N', NL, K, CTOT( 3 ), ONE, U2( 1, KTEMP ), $ LDU2, Q( KTEMP, 1 ), LDQ, ONE, U( 1, 1 ), LDU ) END IF ELSE IF( CTOT( 3 ).GT.0 ) THEN KTEMP = 2 + CTOT( 1 ) + CTOT( 2 ) CALL DGEMM( 'N', 'N', NL, K, CTOT( 3 ), ONE, U2( 1, KTEMP ), $ LDU2, Q( KTEMP, 1 ), LDQ, ZERO, U( 1, 1 ), LDU ) ELSE CALL DLACPY( 'F', NL, K, U2, LDU2, U, LDU ) END IF CALL DCOPY( K, Q( 1, 1 ), LDQ, U( NLP1, 1 ), LDU ) KTEMP = 2 + CTOT( 1 ) CTEMP = CTOT( 2 ) + CTOT( 3 ) CALL DGEMM( 'N', 'N', NR, K, CTEMP, ONE, U2( NLP2, KTEMP ), LDU2, $ Q( KTEMP, 1 ), LDQ, ZERO, U( NLP2, 1 ), LDU ) * * Generate the right singular vectors. * 100 CONTINUE DO 120 I = 1, K TEMP = DNRM2( K, VT( 1, I ), 1 ) Q( I, 1 ) = VT( 1, I ) / TEMP DO 110 J = 2, K JC = IDXC( J ) Q( I, J ) = VT( JC, I ) / TEMP 110 CONTINUE 120 CONTINUE * * Update the right singular vector matrix. * IF( K.EQ.2 ) THEN CALL DGEMM( 'N', 'N', K, M, K, ONE, Q, LDQ, VT2, LDVT2, ZERO, $ VT, LDVT ) RETURN END IF KTEMP = 1 + CTOT( 1 ) CALL DGEMM( 'N', 'N', K, NLP1, KTEMP, ONE, Q( 1, 1 ), LDQ, $ VT2( 1, 1 ), LDVT2, ZERO, VT( 1, 1 ), LDVT ) KTEMP = 2 + CTOT( 1 ) + CTOT( 2 ) IF( KTEMP.LE.LDVT2 ) $ CALL DGEMM( 'N', 'N', K, NLP1, CTOT( 3 ), ONE, Q( 1, KTEMP ), $ LDQ, VT2( KTEMP, 1 ), LDVT2, ONE, VT( 1, 1 ), $ LDVT ) * KTEMP = CTOT( 1 ) + 1 NRP1 = NR + SQRE IF( KTEMP.GT.1 ) THEN DO 130 I = 1, K Q( I, KTEMP ) = Q( I, 1 ) 130 CONTINUE DO 140 I = NLP2, M VT2( KTEMP, I ) = VT2( 1, I ) 140 CONTINUE END IF CTEMP = 1 + CTOT( 2 ) + CTOT( 3 ) CALL DGEMM( 'N', 'N', K, NRP1, CTEMP, ONE, Q( 1, KTEMP ), LDQ, $ VT2( KTEMP, NLP2 ), LDVT2, ZERO, VT( 1, NLP2 ), LDVT ) * RETURN * * End of DLASD3 * END *> \brief \b DLASD4 computes the square root of the i-th updated eigenvalue of a positive symmetric rank-one modification to a positive diagonal matrix. Used by dbdsdc. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASD4 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) * * .. Scalar Arguments .. * INTEGER I, INFO, N * DOUBLE PRECISION RHO, SIGMA * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), DELTA( * ), WORK( * ), Z( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> This subroutine computes the square root of the I-th updated *> eigenvalue of a positive symmetric rank-one modification to *> a positive diagonal matrix whose entries are given as the squares *> of the corresponding entries in the array d, and that *> *> 0 <= 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 ) * 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The length of all arrays. *> \endverbatim *> *> \param[in] I *> \verbatim *> I is INTEGER *> The index of the eigenvalue to be computed. 1 <= I <= N. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension ( N ) *> The original eigenvalues. It is assumed that they are in *> order, 0 <= D(I) < D(J) for I < J. *> \endverbatim *> *> \param[in] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension ( N ) *> The components of the updating vector. *> \endverbatim *> *> \param[out] DELTA *> \verbatim *> DELTA is DOUBLE PRECISION array, dimension ( N ) *> If N .ne. 1, DELTA contains (D(j) - sigma_I) in its j-th *> component. If N = 1, then DELTA(1) = 1. The vector DELTA *> contains the information necessary to construct the *> (singular) eigenvectors. *> \endverbatim *> *> \param[in] RHO *> \verbatim *> RHO is DOUBLE PRECISION *> The scalar in the symmetric updating formula. *> \endverbatim *> *> \param[out] SIGMA *> \verbatim *> SIGMA is DOUBLE PRECISION *> The computed sigma_I, the I-th updated eigenvalue. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension ( N ) *> If N .ne. 1, WORK contains (D(j) + sigma_I) in its j-th *> component. If N = 1, then WORK( 1 ) = 1. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> > 0: if INFO = 1, the updating process failed. *> \endverbatim * *> \par Internal Parameters: * ========================= *> *> \verbatim *> 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. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * *> \par Contributors: * ================== *> *> Ren-Cang Li, Computer Science Division, University of California *> at Berkeley, USA *> * ===================================================================== SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER I, INFO, N DOUBLE PRECISION RHO, SIGMA * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), DELTA( * ), WORK( * ), Z( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER MAXIT PARAMETER ( MAXIT = 400 ) DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, $ THREE = 3.0D+0, FOUR = 4.0D+0, EIGHT = 8.0D+0, $ TEN = 10.0D+0 ) * .. * .. Local Scalars .. LOGICAL ORGATI, SWTCH, SWTCH3, GEOMAVG INTEGER II, IIM1, IIP1, IP1, ITER, J, NITER DOUBLE PRECISION A, B, C, DELSQ, DELSQ2, SQ2, DPHI, DPSI, DTIIM, $ DTIIP, DTIPSQ, DTISQ, DTNSQ, DTNSQ1, DW, EPS, $ ERRETM, ETA, PHI, PREW, PSI, RHOINV, SGLB, $ SGUB, TAU, TAU2, TEMP, TEMP1, TEMP2, W * .. * .. Local Arrays .. DOUBLE PRECISION DD( 3 ), ZZ( 3 ) * .. * .. External Subroutines .. EXTERNAL DLAED6, DLASD5 * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. 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 * SIGMA = SQRT( D( 1 )*D( 1 )+RHO*Z( 1 )*Z( 1 ) ) DELTA( 1 ) = ONE WORK( 1 ) = ONE RETURN END IF IF( N.EQ.2 ) THEN CALL DLASD5( I, D, Z, DELTA, RHO, SIGMA, WORK ) RETURN END IF * * Compute machine epsilon * EPS = DLAMCH( 'Epsilon' ) RHOINV = ONE / RHO TAU2= ZERO * * The case I = N * IF( I.EQ.N ) THEN * * Initialize some basic variables * II = N - 1 NITER = 1 * * Calculate initial guess * TEMP = RHO / TWO * * If ||Z||_2 is not one, then TEMP should be set to * RHO * ||Z||_2^2 / TWO * TEMP1 = TEMP / ( D( N )+SQRT( D( N )*D( N )+TEMP ) ) DO 10 J = 1, N WORK( J ) = D( J ) + D( N ) + TEMP1 DELTA( J ) = ( D( J )-D( N ) ) - TEMP1 10 CONTINUE * PSI = ZERO DO 20 J = 1, N - 2 PSI = PSI + Z( J )*Z( J ) / ( DELTA( J )*WORK( J ) ) 20 CONTINUE * C = RHOINV + PSI W = C + Z( II )*Z( II ) / ( DELTA( II )*WORK( II ) ) + $ Z( N )*Z( N ) / ( DELTA( N )*WORK( N ) ) * IF( W.LE.ZERO ) THEN TEMP1 = SQRT( D( N )*D( N )+RHO ) TEMP = Z( N-1 )*Z( N-1 ) / ( ( D( N-1 )+TEMP1 )* $ ( D( N )-D( N-1 )+RHO / ( D( N )+TEMP1 ) ) ) + $ Z( N )*Z( N ) / RHO * * The following TAU2 is to approximate * SIGMA_n^2 - D( N )*D( N ) * IF( C.LE.TEMP ) THEN TAU = RHO ELSE DELSQ = ( D( N )-D( N-1 ) )*( D( N )+D( N-1 ) ) A = -C*DELSQ + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N ) B = Z( N )*Z( N )*DELSQ IF( A.LT.ZERO ) THEN TAU2 = TWO*B / ( SQRT( A*A+FOUR*B*C )-A ) ELSE TAU2 = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C ) END IF TAU = TAU2 / ( D( N )+SQRT( D( N )*D( N )+TAU2 ) ) END IF * * It can be proved that * D(N)^2+RHO/2 <= SIGMA_n^2 < D(N)^2+TAU2 <= D(N)^2+RHO * ELSE DELSQ = ( D( N )-D( N-1 ) )*( D( N )+D( N-1 ) ) A = -C*DELSQ + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N ) B = Z( N )*Z( N )*DELSQ * * The following TAU2 is to approximate * SIGMA_n^2 - D( N )*D( N ) * IF( A.LT.ZERO ) THEN TAU2 = TWO*B / ( SQRT( A*A+FOUR*B*C )-A ) ELSE TAU2 = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C ) END IF TAU = TAU2 / ( D( N )+SQRT( D( N )*D( N )+TAU2 ) ) * * It can be proved that * D(N)^2 < D(N)^2+TAU2 < SIGMA(N)^2 < D(N)^2+RHO/2 * END IF * * The following TAU is to approximate SIGMA_n - D( N ) * * TAU = TAU2 / ( D( N )+SQRT( D( N )*D( N )+TAU2 ) ) * SIGMA = D( N ) + TAU DO 30 J = 1, N DELTA( J ) = ( D( J )-D( N ) ) - TAU WORK( J ) = D( J ) + D( N ) + 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 )*WORK( 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 )*WORK( N ) ) PHI = Z( N )*TEMP DPHI = TEMP*TEMP ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV * $ + ABS( TAU2 )*( DPSI+DPHI ) * W = RHOINV + PHI + PSI * * Test for convergence * IF( ABS( W ).LE.EPS*ERRETM ) THEN GO TO 240 END IF * * Calculate the new step * NITER = NITER + 1 DTNSQ1 = WORK( N-1 )*DELTA( N-1 ) DTNSQ = WORK( N )*DELTA( N ) C = W - DTNSQ1*DPSI - DTNSQ*DPHI A = ( DTNSQ+DTNSQ1 )*W - DTNSQ*DTNSQ1*( DPSI+DPHI ) B = DTNSQ*DTNSQ1*W IF( C.LT.ZERO ) $ C = ABS( C ) IF( C.EQ.ZERO ) THEN ETA = RHO - SIGMA*SIGMA 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 = ETA - DTNSQ IF( TEMP.GT.RHO ) $ ETA = RHO + DTNSQ * ETA = ETA / ( SIGMA+SQRT( ETA+SIGMA*SIGMA ) ) TAU = TAU + ETA SIGMA = SIGMA + ETA * DO 50 J = 1, N DELTA( J ) = DELTA( J ) - ETA WORK( J ) = WORK( J ) + ETA 50 CONTINUE * * Evaluate PSI and the derivative DPSI * DPSI = ZERO PSI = ZERO ERRETM = ZERO DO 60 J = 1, II TEMP = Z( J ) / ( WORK( 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 * TAU2 = WORK( N )*DELTA( N ) TEMP = Z( N ) / TAU2 PHI = Z( N )*TEMP DPHI = TEMP*TEMP ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV * $ + ABS( TAU2 )*( 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 GO TO 240 END IF * * Calculate the new step * DTNSQ1 = WORK( N-1 )*DELTA( N-1 ) DTNSQ = WORK( N )*DELTA( N ) C = W - DTNSQ1*DPSI - DTNSQ*DPHI A = ( DTNSQ+DTNSQ1 )*W - DTNSQ1*DTNSQ*( DPSI+DPHI ) B = DTNSQ1*DTNSQ*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 = ETA - DTNSQ IF( TEMP.LE.ZERO ) $ ETA = ETA / TWO * ETA = ETA / ( SIGMA+SQRT( ETA+SIGMA*SIGMA ) ) TAU = TAU + ETA SIGMA = SIGMA + ETA * DO 70 J = 1, N DELTA( J ) = DELTA( J ) - ETA WORK( J ) = WORK( J ) + ETA 70 CONTINUE * * Evaluate PSI and the derivative DPSI * DPSI = ZERO PSI = ZERO ERRETM = ZERO DO 80 J = 1, II TEMP = Z( J ) / ( WORK( 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 * TAU2 = WORK( N )*DELTA( N ) TEMP = Z( N ) / TAU2 PHI = Z( N )*TEMP DPHI = TEMP*TEMP ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV * $ + ABS( TAU2 )*( DPSI+DPHI ) * W = RHOINV + PHI + PSI 90 CONTINUE * * Return with INFO = 1, NITER = MAXIT and not converged * INFO = 1 GO TO 240 * * End for the case I = N * ELSE * * The case for I < N * NITER = 1 IP1 = I + 1 * * Calculate initial guess * DELSQ = ( D( IP1 )-D( I ) )*( D( IP1 )+D( I ) ) DELSQ2 = DELSQ / TWO SQ2=SQRT( ( D( I )*D( I )+D( IP1 )*D( IP1 ) ) / TWO ) TEMP = DELSQ2 / ( D( I )+SQ2 ) DO 100 J = 1, N WORK( J ) = D( J ) + D( I ) + TEMP DELTA( J ) = ( D( J )-D( I ) ) - TEMP 100 CONTINUE * PSI = ZERO DO 110 J = 1, I - 1 PSI = PSI + Z( J )*Z( J ) / ( WORK( J )*DELTA( J ) ) 110 CONTINUE * PHI = ZERO DO 120 J = N, I + 2, -1 PHI = PHI + Z( J )*Z( J ) / ( WORK( J )*DELTA( J ) ) 120 CONTINUE C = RHOINV + PSI + PHI W = C + Z( I )*Z( I ) / ( WORK( I )*DELTA( I ) ) + $ Z( IP1 )*Z( IP1 ) / ( WORK( IP1 )*DELTA( IP1 ) ) * GEOMAVG = .FALSE. IF( W.GT.ZERO ) THEN * * d(i)^2 < the ith sigma^2 < (d(i)^2+d(i+1)^2)/2 * * We choose d(i) as origin. * ORGATI = .TRUE. II = I SGLB = ZERO SGUB = DELSQ2 / ( D( I )+SQ2 ) A = C*DELSQ + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 ) B = Z( I )*Z( I )*DELSQ IF( A.GT.ZERO ) THEN TAU2 = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) ELSE TAU2 = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) END IF * * TAU2 now is an estimation of SIGMA^2 - D( I )^2. The * following, however, is the corresponding estimation of * SIGMA - D( I ). * TAU = TAU2 / ( D( I )+SQRT( D( I )*D( I )+TAU2 ) ) TEMP = SQRT(EPS) IF( (D(I).LE.TEMP*D(IP1)).AND.(ABS(Z(I)).LE.TEMP) $ .AND.(D(I).GT.ZERO) ) THEN TAU = MIN( TEN*D(I), SGUB ) GEOMAVG = .TRUE. END IF ELSE * * (d(i)^2+d(i+1)^2)/2 <= the ith sigma^2 < d(i+1)^2/2 * * We choose d(i+1) as origin. * ORGATI = .FALSE. II = IP1 SGLB = -DELSQ2 / ( D( II )+SQ2 ) SGUB = ZERO A = C*DELSQ - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 ) B = Z( IP1 )*Z( IP1 )*DELSQ IF( A.LT.ZERO ) THEN TAU2 = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) ) ELSE TAU2 = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C ) END IF * * TAU2 now is an estimation of SIGMA^2 - D( IP1 )^2. The * following, however, is the corresponding estimation of * SIGMA - D( IP1 ). * TAU = TAU2 / ( D( IP1 )+SQRT( ABS( D( IP1 )*D( IP1 )+ $ TAU2 ) ) ) END IF * SIGMA = D( II ) + TAU DO 130 J = 1, N WORK( J ) = D( J ) + D( II ) + TAU DELTA( J ) = ( D( J )-D( II ) ) - TAU 130 CONTINUE 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 ) / ( WORK( 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 ) / ( WORK( 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 ) / ( WORK( 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( TAU2 )*DW * * Test for convergence * IF( ABS( W ).LE.EPS*ERRETM ) THEN GO TO 240 END IF * IF( W.LE.ZERO ) THEN SGLB = MAX( SGLB, TAU ) ELSE SGUB = MIN( SGUB, TAU ) END IF * * Calculate the new step * NITER = NITER + 1 IF( .NOT.SWTCH3 ) THEN DTIPSQ = WORK( IP1 )*DELTA( IP1 ) DTISQ = WORK( I )*DELTA( I ) IF( ORGATI ) THEN C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2 ELSE C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2 END IF A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW B = DTIPSQ*DTISQ*W IF( C.EQ.ZERO ) THEN IF( A.EQ.ZERO ) THEN IF( ORGATI ) THEN A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ*( DPSI+DPHI ) ELSE A = Z( IP1 )*Z( IP1 ) + DTISQ*DTISQ*( 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 * DTIIM = WORK( IIM1 )*DELTA( IIM1 ) DTIIP = WORK( IIP1 )*DELTA( IIP1 ) TEMP = RHOINV + PSI + PHI IF( ORGATI ) THEN TEMP1 = Z( IIM1 ) / DTIIM TEMP1 = TEMP1*TEMP1 C = ( TEMP - DTIIP*( DPSI+DPHI ) ) - $ ( D( IIM1 )-D( IIP1 ) )*( D( IIM1 )+D( IIP1 ) )*TEMP1 ZZ( 1 ) = Z( IIM1 )*Z( IIM1 ) IF( DPSI.LT.TEMP1 ) THEN ZZ( 3 ) = DTIIP*DTIIP*DPHI ELSE ZZ( 3 ) = DTIIP*DTIIP*( ( DPSI-TEMP1 )+DPHI ) END IF ELSE TEMP1 = Z( IIP1 ) / DTIIP TEMP1 = TEMP1*TEMP1 C = ( TEMP - DTIIM*( DPSI+DPHI ) ) - $ ( D( IIP1 )-D( IIM1 ) )*( D( IIM1 )+D( IIP1 ) )*TEMP1 IF( DPHI.LT.TEMP1 ) THEN ZZ( 1 ) = DTIIM*DTIIM*DPSI ELSE ZZ( 1 ) = DTIIM*DTIIM*( DPSI+( DPHI-TEMP1 ) ) END IF ZZ( 3 ) = Z( IIP1 )*Z( IIP1 ) END IF ZZ( 2 ) = Z( II )*Z( II ) DD( 1 ) = DTIIM DD( 2 ) = DELTA( II )*WORK( II ) DD( 3 ) = DTIIP CALL DLAED6( NITER, ORGATI, C, DD, ZZ, W, ETA, INFO ) * IF( INFO.NE.0 ) THEN * * If INFO is not 0, i.e., DLAED6 failed, switch back * to 2 pole interpolation. * SWTCH3 = .FALSE. INFO = 0 DTIPSQ = WORK( IP1 )*DELTA( IP1 ) DTISQ = WORK( I )*DELTA( I ) IF( ORGATI ) THEN C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2 ELSE C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2 END IF A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW B = DTIPSQ*DTISQ*W IF( C.EQ.ZERO ) THEN IF( A.EQ.ZERO ) THEN IF( ORGATI ) THEN A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ*( DPSI+DPHI ) ELSE A = Z( IP1 )*Z( IP1 ) + DTISQ*DTISQ*( 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 END IF 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 * ETA = ETA / ( SIGMA+SQRT( SIGMA*SIGMA+ETA ) ) TEMP = TAU + ETA IF( TEMP.GT.SGUB .OR. TEMP.LT.SGLB ) THEN IF( W.LT.ZERO ) THEN ETA = ( SGUB-TAU ) / TWO ELSE ETA = ( SGLB-TAU ) / TWO END IF IF( GEOMAVG ) THEN IF( W .LT. ZERO ) THEN IF( TAU .GT. ZERO ) THEN ETA = SQRT(SGUB*TAU)-TAU END IF ELSE IF( SGLB .GT. ZERO ) THEN ETA = SQRT(SGLB*TAU)-TAU END IF END IF END IF END IF * PREW = W * TAU = TAU + ETA SIGMA = SIGMA + ETA * DO 170 J = 1, N WORK( J ) = WORK( J ) + ETA DELTA( J ) = DELTA( J ) - ETA 170 CONTINUE * * Evaluate PSI and the derivative DPSI * DPSI = ZERO PSI = ZERO ERRETM = ZERO DO 180 J = 1, IIM1 TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) PSI = PSI + Z( J )*TEMP DPSI = DPSI + TEMP*TEMP ERRETM = ERRETM + PSI 180 CONTINUE ERRETM = ABS( ERRETM ) * * Evaluate PHI and the derivative DPHI * DPHI = ZERO PHI = ZERO DO 190 J = N, IIP1, -1 TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) PHI = PHI + Z( J )*TEMP DPHI = DPHI + TEMP*TEMP ERRETM = ERRETM + PHI 190 CONTINUE * TAU2 = WORK( II )*DELTA( II ) TEMP = Z( II ) / TAU2 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( TAU2 )*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 * * Main loop to update the values of the array DELTA and WORK * ITER = NITER + 1 * DO 230 NITER = ITER, MAXIT * * Test for convergence * IF( ABS( W ).LE.EPS*ERRETM ) THEN * $ .OR. (SGUB-SGLB).LE.EIGHT*ABS(SGUB+SGLB) ) THEN GO TO 240 END IF * IF( W.LE.ZERO ) THEN SGLB = MAX( SGLB, TAU ) ELSE SGUB = MIN( SGUB, TAU ) END IF * * Calculate the new step * IF( .NOT.SWTCH3 ) THEN DTIPSQ = WORK( IP1 )*DELTA( IP1 ) DTISQ = WORK( I )*DELTA( I ) IF( .NOT.SWTCH ) THEN IF( ORGATI ) THEN C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2 ELSE C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2 END IF ELSE TEMP = Z( II ) / ( WORK( II )*DELTA( II ) ) IF( ORGATI ) THEN DPSI = DPSI + TEMP*TEMP ELSE DPHI = DPHI + TEMP*TEMP END IF C = W - DTISQ*DPSI - DTIPSQ*DPHI END IF A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW B = DTIPSQ*DTISQ*W IF( C.EQ.ZERO ) THEN IF( A.EQ.ZERO ) THEN IF( .NOT.SWTCH ) THEN IF( ORGATI ) THEN A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ* $ ( DPSI+DPHI ) ELSE A = Z( IP1 )*Z( IP1 ) + $ DTISQ*DTISQ*( DPSI+DPHI ) END IF ELSE A = DTISQ*DTISQ*DPSI + DTIPSQ*DTIPSQ*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 * DTIIM = WORK( IIM1 )*DELTA( IIM1 ) DTIIP = WORK( IIP1 )*DELTA( IIP1 ) TEMP = RHOINV + PSI + PHI IF( SWTCH ) THEN C = TEMP - DTIIM*DPSI - DTIIP*DPHI ZZ( 1 ) = DTIIM*DTIIM*DPSI ZZ( 3 ) = DTIIP*DTIIP*DPHI ELSE IF( ORGATI ) THEN TEMP1 = Z( IIM1 ) / DTIIM TEMP1 = TEMP1*TEMP1 TEMP2 = ( D( IIM1 )-D( IIP1 ) )* $ ( D( IIM1 )+D( IIP1 ) )*TEMP1 C = TEMP - DTIIP*( DPSI+DPHI ) - TEMP2 ZZ( 1 ) = Z( IIM1 )*Z( IIM1 ) IF( DPSI.LT.TEMP1 ) THEN ZZ( 3 ) = DTIIP*DTIIP*DPHI ELSE ZZ( 3 ) = DTIIP*DTIIP*( ( DPSI-TEMP1 )+DPHI ) END IF ELSE TEMP1 = Z( IIP1 ) / DTIIP TEMP1 = TEMP1*TEMP1 TEMP2 = ( D( IIP1 )-D( IIM1 ) )* $ ( D( IIM1 )+D( IIP1 ) )*TEMP1 C = TEMP - DTIIM*( DPSI+DPHI ) - TEMP2 IF( DPHI.LT.TEMP1 ) THEN ZZ( 1 ) = DTIIM*DTIIM*DPSI ELSE ZZ( 1 ) = DTIIM*DTIIM*( DPSI+( DPHI-TEMP1 ) ) END IF ZZ( 3 ) = Z( IIP1 )*Z( IIP1 ) END IF END IF DD( 1 ) = DTIIM DD( 2 ) = DELTA( II )*WORK( II ) DD( 3 ) = DTIIP CALL DLAED6( NITER, ORGATI, C, DD, ZZ, W, ETA, INFO ) * IF( INFO.NE.0 ) THEN * * If INFO is not 0, i.e., DLAED6 failed, switch * back to two pole interpolation * SWTCH3 = .FALSE. INFO = 0 DTIPSQ = WORK( IP1 )*DELTA( IP1 ) DTISQ = WORK( I )*DELTA( I ) IF( .NOT.SWTCH ) THEN IF( ORGATI ) THEN C = W - DTIPSQ*DW + DELSQ*( Z( I )/DTISQ )**2 ELSE C = W - DTISQ*DW - DELSQ*( Z( IP1 )/DTIPSQ )**2 END IF ELSE TEMP = Z( II ) / ( WORK( II )*DELTA( II ) ) IF( ORGATI ) THEN DPSI = DPSI + TEMP*TEMP ELSE DPHI = DPHI + TEMP*TEMP END IF C = W - DTISQ*DPSI - DTIPSQ*DPHI END IF A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW B = DTIPSQ*DTISQ*W IF( C.EQ.ZERO ) THEN IF( A.EQ.ZERO ) THEN IF( .NOT.SWTCH ) THEN IF( ORGATI ) THEN A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ* $ ( DPSI+DPHI ) ELSE A = Z( IP1 )*Z( IP1 ) + $ DTISQ*DTISQ*( DPSI+DPHI ) END IF ELSE A = DTISQ*DTISQ*DPSI + DTIPSQ*DTIPSQ*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 END IF 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 * ETA = ETA / ( SIGMA+SQRT( SIGMA*SIGMA+ETA ) ) TEMP=TAU+ETA IF( TEMP.GT.SGUB .OR. TEMP.LT.SGLB ) THEN IF( W.LT.ZERO ) THEN ETA = ( SGUB-TAU ) / TWO ELSE ETA = ( SGLB-TAU ) / TWO END IF IF( GEOMAVG ) THEN IF( W .LT. ZERO ) THEN IF( TAU .GT. ZERO ) THEN ETA = SQRT(SGUB*TAU)-TAU END IF ELSE IF( SGLB .GT. ZERO ) THEN ETA = SQRT(SGLB*TAU)-TAU END IF END IF END IF END IF * PREW = W * TAU = TAU + ETA SIGMA = SIGMA + ETA * DO 200 J = 1, N WORK( J ) = WORK( J ) + ETA DELTA( J ) = DELTA( J ) - ETA 200 CONTINUE * * Evaluate PSI and the derivative DPSI * DPSI = ZERO PSI = ZERO ERRETM = ZERO DO 210 J = 1, IIM1 TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) PSI = PSI + Z( J )*TEMP DPSI = DPSI + TEMP*TEMP ERRETM = ERRETM + PSI 210 CONTINUE ERRETM = ABS( ERRETM ) * * Evaluate PHI and the derivative DPHI * DPHI = ZERO PHI = ZERO DO 220 J = N, IIP1, -1 TEMP = Z( J ) / ( WORK( J )*DELTA( J ) ) PHI = PHI + Z( J )*TEMP DPHI = DPHI + TEMP*TEMP ERRETM = ERRETM + PHI 220 CONTINUE * TAU2 = WORK( II )*DELTA( II ) TEMP = Z( II ) / TAU2 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( TAU2 )*DW * IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN ) $ SWTCH = .NOT.SWTCH * 230 CONTINUE * * Return with INFO = 1, NITER = MAXIT and not converged * INFO = 1 * END IF * 240 CONTINUE RETURN * * End of DLASD4 * END *> \brief \b DLASD5 computes the square root of the i-th eigenvalue of a positive symmetric rank-one modification of a 2-by-2 diagonal matrix. Used by sbdsdc. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASD5 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK ) * * .. Scalar Arguments .. * INTEGER I * DOUBLE PRECISION DSIGMA, RHO * .. * .. Array Arguments .. * DOUBLE PRECISION D( 2 ), DELTA( 2 ), WORK( 2 ), Z( 2 ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> This subroutine computes the square root of the I-th eigenvalue *> of a positive symmetric rank-one modification of a 2-by-2 diagonal *> matrix *> *> diag( D ) * diag( D ) + RHO * Z * transpose(Z) . *> *> The diagonal entries in the array D are assumed to satisfy *> *> 0 <= D(i) < D(j) for i < j . *> *> We also assume RHO > 0 and that the Euclidean norm of the vector *> Z is one. *> \endverbatim * * Arguments: * ========== * *> \param[in] I *> \verbatim *> I is INTEGER *> The index of the eigenvalue to be computed. I = 1 or I = 2. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension ( 2 ) *> The original eigenvalues. We assume 0 <= D(1) < D(2). *> \endverbatim *> *> \param[in] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension ( 2 ) *> The components of the updating vector. *> \endverbatim *> *> \param[out] DELTA *> \verbatim *> DELTA is DOUBLE PRECISION array, dimension ( 2 ) *> Contains (D(j) - sigma_I) in its j-th component. *> The vector DELTA contains the information necessary *> to construct the eigenvectors. *> \endverbatim *> *> \param[in] RHO *> \verbatim *> RHO is DOUBLE PRECISION *> The scalar in the symmetric updating formula. *> \endverbatim *> *> \param[out] DSIGMA *> \verbatim *> DSIGMA is DOUBLE PRECISION *> The computed sigma_I, the I-th updated eigenvalue. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension ( 2 ) *> WORK contains (D(j) + sigma_I) in its j-th component. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * *> \par Contributors: * ================== *> *> Ren-Cang Li, Computer Science Division, University of California *> at Berkeley, USA *> * ===================================================================== SUBROUTINE DLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER I DOUBLE PRECISION DSIGMA, RHO * .. * .. Array Arguments .. DOUBLE PRECISION D( 2 ), DELTA( 2 ), WORK( 2 ), Z( 2 ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, $ THREE = 3.0D+0, FOUR = 4.0D+0 ) * .. * .. Local Scalars .. DOUBLE PRECISION B, C, DEL, DELSQ, TAU, W * .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT * .. * .. Executable Statements .. * DEL = D( 2 ) - D( 1 ) DELSQ = DEL*( D( 2 )+D( 1 ) ) IF( I.EQ.1 ) THEN W = ONE + FOUR*RHO*( Z( 2 )*Z( 2 ) / ( D( 1 )+THREE*D( 2 ) )- $ Z( 1 )*Z( 1 ) / ( THREE*D( 1 )+D( 2 ) ) ) / DEL IF( W.GT.ZERO ) THEN B = DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) C = RHO*Z( 1 )*Z( 1 )*DELSQ * * B > ZERO, always * * The following TAU is DSIGMA * DSIGMA - D( 1 ) * D( 1 ) * TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) ) * * The following TAU is DSIGMA - D( 1 ) * TAU = TAU / ( D( 1 )+SQRT( D( 1 )*D( 1 )+TAU ) ) DSIGMA = D( 1 ) + TAU DELTA( 1 ) = -TAU DELTA( 2 ) = DEL - TAU WORK( 1 ) = TWO*D( 1 ) + TAU WORK( 2 ) = ( D( 1 )+TAU ) + D( 2 ) * DELTA( 1 ) = -Z( 1 ) / TAU * DELTA( 2 ) = Z( 2 ) / ( DEL-TAU ) ELSE B = -DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) C = RHO*Z( 2 )*Z( 2 )*DELSQ * * The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) * 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 * * The following TAU is DSIGMA - D( 2 ) * TAU = TAU / ( D( 2 )+SQRT( ABS( D( 2 )*D( 2 )+TAU ) ) ) DSIGMA = D( 2 ) + TAU DELTA( 1 ) = -( DEL+TAU ) DELTA( 2 ) = -TAU WORK( 1 ) = D( 1 ) + TAU + D( 2 ) WORK( 2 ) = TWO*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 = -DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) C = RHO*Z( 2 )*Z( 2 )*DELSQ * * The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) * 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 * * The following TAU is DSIGMA - D( 2 ) * TAU = TAU / ( D( 2 )+SQRT( D( 2 )*D( 2 )+TAU ) ) DSIGMA = D( 2 ) + TAU DELTA( 1 ) = -( DEL+TAU ) DELTA( 2 ) = -TAU WORK( 1 ) = D( 1 ) + TAU + D( 2 ) WORK( 2 ) = TWO*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 DLASD5 * END *> \brief \b DLASD6 computes the SVD of an updated upper bidiagonal matrix obtained by merging two smaller ones by appending a row. Used by sbdsdc. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASD6 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASD6( ICOMPQ, NL, NR, SQRE, D, VF, VL, ALPHA, BETA, * IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, * LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, * IWORK, INFO ) * * .. Scalar Arguments .. * INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, * $ NR, SQRE * DOUBLE PRECISION ALPHA, BETA, C, S * .. * .. Array Arguments .. * INTEGER GIVCOL( LDGCOL, * ), IDXQ( * ), IWORK( * ), * $ PERM( * ) * DOUBLE PRECISION D( * ), DIFL( * ), DIFR( * ), * $ GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ), * $ VF( * ), VL( * ), WORK( * ), Z( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLASD6 computes the SVD of an updated upper bidiagonal matrix B *> obtained by merging two smaller ones by appending a row. This *> routine is used only for the problem which requires all singular *> values and optionally singular vector matrices in factored form. *> B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE. *> A related subroutine, DLASD1, handles the case in which all singular *> values and singular vectors of the bidiagonal matrix are desired. *> *> DLASD6 computes the SVD as follows: *> *> ( D1(in) 0 0 0 ) *> B = U(in) * ( Z1**T a Z2**T b ) * VT(in) *> ( 0 0 D2(in) 0 ) *> *> = U(out) * ( D(out) 0) * VT(out) *> *> where Z**T = (Z1**T a Z2**T b) = u**T VT**T, and u is a vector of dimension M *> with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros *> elsewhere; and the entry b is empty if SQRE = 0. *> *> The singular values of B can be computed using D1, D2, the first *> components of all the right singular vectors of the lower block, and *> the last components of all the right singular vectors of the upper *> block. These components are stored and updated in VF and VL, *> respectively, in DLASD6. Hence U and VT are not explicitly *> referenced. *> *> The singular values are stored in D. The algorithm consists of two *> stages: *> *> The first stage consists of deflating the size of the problem *> when there are multiple singular values or if there is a zero *> in the Z vector. For each such occurrence the dimension of the *> secular equation problem is reduced by one. This stage is *> performed by the routine DLASD7. *> *> The second stage consists of calculating the updated *> singular values. This is done by finding the roots of the *> secular equation via the routine DLASD4 (as called by DLASD8). *> This routine also updates VF and VL and computes the distances *> between the updated singular values and the old singular *> values. *> *> DLASD6 is called from DLASDA. *> \endverbatim * * Arguments: * ========== * *> \param[in] ICOMPQ *> \verbatim *> ICOMPQ is INTEGER *> Specifies whether singular vectors are to be computed in *> factored form: *> = 0: Compute singular values only. *> = 1: Compute singular vectors in factored form as well. *> \endverbatim *> *> \param[in] NL *> \verbatim *> NL is INTEGER *> The row dimension of the upper block. NL >= 1. *> \endverbatim *> *> \param[in] NR *> \verbatim *> NR is INTEGER *> The row dimension of the lower block. NR >= 1. *> \endverbatim *> *> \param[in] SQRE *> \verbatim *> SQRE is 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. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension ( NL+NR+1 ). *> On entry D(1:NL,1:NL) contains the singular values of the *> upper block, and D(NL+2:N) contains the singular values *> of the lower block. On exit D(1:N) contains the singular *> values of the modified matrix. *> \endverbatim *> *> \param[in,out] VF *> \verbatim *> VF is DOUBLE PRECISION array, dimension ( M ) *> On entry, VF(1:NL+1) contains the first components of all *> right singular vectors of the upper block; and VF(NL+2:M) *> contains the first components of all right singular vectors *> of the lower block. On exit, VF contains the first components *> of all right singular vectors of the bidiagonal matrix. *> \endverbatim *> *> \param[in,out] VL *> \verbatim *> VL is DOUBLE PRECISION array, dimension ( M ) *> On entry, VL(1:NL+1) contains the last components of all *> right singular vectors of the upper block; and VL(NL+2:M) *> contains the last components of all right singular vectors of *> the lower block. On exit, VL contains the last components of *> all right singular vectors of the bidiagonal matrix. *> \endverbatim *> *> \param[in,out] ALPHA *> \verbatim *> ALPHA is DOUBLE PRECISION *> Contains the diagonal element associated with the added row. *> \endverbatim *> *> \param[in,out] BETA *> \verbatim *> BETA is DOUBLE PRECISION *> Contains the off-diagonal element associated with the added *> row. *> \endverbatim *> *> \param[in,out] IDXQ *> \verbatim *> IDXQ is INTEGER array, dimension ( N ) *> This contains the permutation which will reintegrate the *> subproblem just solved back into sorted order, i.e. *> D( IDXQ( I = 1, N ) ) will be in ascending order. *> \endverbatim *> *> \param[out] PERM *> \verbatim *> PERM is INTEGER array, dimension ( N ) *> The permutations (from deflation and sorting) to be applied *> to each block. Not referenced if ICOMPQ = 0. *> \endverbatim *> *> \param[out] GIVPTR *> \verbatim *> GIVPTR is INTEGER *> The number of Givens rotations which took place in this *> subproblem. Not referenced if ICOMPQ = 0. *> \endverbatim *> *> \param[out] GIVCOL *> \verbatim *> GIVCOL is INTEGER array, dimension ( LDGCOL, 2 ) *> Each pair of numbers indicates a pair of columns to take place *> in a Givens rotation. Not referenced if ICOMPQ = 0. *> \endverbatim *> *> \param[in] LDGCOL *> \verbatim *> LDGCOL is INTEGER *> leading dimension of GIVCOL, must be at least N. *> \endverbatim *> *> \param[out] GIVNUM *> \verbatim *> GIVNUM is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) *> Each number indicates the C or S value to be used in the *> corresponding Givens rotation. Not referenced if ICOMPQ = 0. *> \endverbatim *> *> \param[in] LDGNUM *> \verbatim *> LDGNUM is INTEGER *> The leading dimension of GIVNUM and POLES, must be at least N. *> \endverbatim *> *> \param[out] POLES *> \verbatim *> POLES is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) *> On exit, POLES(1,*) is an array containing the new singular *> values obtained from solving the secular equation, and *> POLES(2,*) is an array containing the poles in the secular *> equation. Not referenced if ICOMPQ = 0. *> \endverbatim *> *> \param[out] DIFL *> \verbatim *> DIFL is DOUBLE PRECISION array, dimension ( N ) *> On exit, DIFL(I) is the distance between I-th updated *> (undeflated) singular value and the I-th (undeflated) old *> singular value. *> \endverbatim *> *> \param[out] DIFR *> \verbatim *> DIFR is DOUBLE PRECISION array, *> dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and *> dimension ( K ) if ICOMPQ = 0. *> On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not *> defined and will not be referenced. *> *> If ICOMPQ = 1, DIFR(1:K,2) is an array containing the *> normalizing factors for the right singular vector matrix. *> *> See DLASD8 for details on DIFL and DIFR. *> \endverbatim *> *> \param[out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension ( M ) *> The first elements of this array contain the components *> of the deflation-adjusted updating row vector. *> \endverbatim *> *> \param[out] K *> \verbatim *> K is INTEGER *> Contains the dimension of the non-deflated matrix, *> This is the order of the related secular equation. 1 <= K <=N. *> \endverbatim *> *> \param[out] C *> \verbatim *> C is 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. *> \endverbatim *> *> \param[out] S *> \verbatim *> S is 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. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension ( 4 * M ) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension ( 3 * N ) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: if INFO = 1, a singular value did not converge *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup OTHERauxiliary * *> \par Contributors: * ================== *> *> Ming Gu and Huan Ren, Computer Science Division, University of *> California at Berkeley, USA *> * ===================================================================== SUBROUTINE DLASD6( ICOMPQ, NL, NR, SQRE, D, VF, VL, ALPHA, BETA, $ IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, $ LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, $ IWORK, INFO ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, $ NR, SQRE DOUBLE PRECISION ALPHA, BETA, C, S * .. * .. Array Arguments .. INTEGER GIVCOL( LDGCOL, * ), IDXQ( * ), IWORK( * ), $ PERM( * ) DOUBLE PRECISION D( * ), DIFL( * ), DIFR( * ), $ GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ), $ VF( * ), VL( * ), WORK( * ), Z( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, IDX, IDXC, IDXP, ISIGMA, IVFW, IVLW, IW, M, $ N, N1, N2 DOUBLE PRECISION ORGNRM * .. * .. External Subroutines .. EXTERNAL DCOPY, DLAMRG, DLASCL, DLASD7, DLASD8, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 N = NL + NR + 1 M = N + SQRE * 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 ELSE IF( LDGCOL.LT.N ) THEN INFO = -14 ELSE IF( LDGNUM.LT.N ) THEN INFO = -16 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLASD6', -INFO ) RETURN END IF * * 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 DLASD7 and DLASD8. * ISIGMA = 1 IW = ISIGMA + N IVFW = IW + M IVLW = IVFW + M * IDX = 1 IDXC = IDX + N IDXP = IDXC + N * * Scale. * ORGNRM = MAX( ABS( ALPHA ), ABS( BETA ) ) D( NL+1 ) = ZERO DO 10 I = 1, N IF( ABS( D( I ) ).GT.ORGNRM ) THEN ORGNRM = ABS( D( I ) ) END IF 10 CONTINUE CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO ) ALPHA = ALPHA / ORGNRM BETA = BETA / ORGNRM * * Sort and Deflate singular values. * CALL DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, WORK( IW ), VF, $ WORK( IVFW ), VL, WORK( IVLW ), ALPHA, BETA, $ WORK( ISIGMA ), IWORK( IDX ), IWORK( IDXP ), IDXQ, $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, C, S, $ INFO ) * * Solve Secular Equation, compute DIFL, DIFR, and update VF, VL. * CALL DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDGNUM, $ WORK( ISIGMA ), WORK( IW ), INFO ) * * Report the possible convergence failure. * IF( INFO.NE.0 ) THEN RETURN END IF * * Save the poles if ICOMPQ = 1. * IF( ICOMPQ.EQ.1 ) THEN CALL DCOPY( K, D, 1, POLES( 1, 1 ), 1 ) CALL DCOPY( K, WORK( ISIGMA ), 1, POLES( 1, 2 ), 1 ) END IF * * Unscale. * CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO ) * * Prepare the IDXQ sorting permutation. * N1 = K N2 = N - K CALL DLAMRG( N1, N2, D, 1, -1, IDXQ ) * RETURN * * End of DLASD6 * END *> \brief \b DLASD7 merges the two sets of singular values together into a single sorted set. Then it tries to deflate the size of the problem. Used by sbdsdc. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASD7 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL, * VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ, * PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, * C, S, INFO ) * * .. Scalar Arguments .. * INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, * $ NR, SQRE * DOUBLE PRECISION ALPHA, BETA, C, S * .. * .. Array Arguments .. * INTEGER GIVCOL( LDGCOL, * ), IDX( * ), IDXP( * ), * $ IDXQ( * ), PERM( * ) * DOUBLE PRECISION D( * ), DSIGMA( * ), GIVNUM( LDGNUM, * ), * $ VF( * ), VFW( * ), VL( * ), VLW( * ), Z( * ), * $ ZW( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLASD7 merges the two sets of singular values 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 singular *> values 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. *> *> DLASD7 is called from DLASD6. *> \endverbatim * * Arguments: * ========== * *> \param[in] ICOMPQ *> \verbatim *> ICOMPQ is INTEGER *> Specifies whether singular vectors are to be computed *> in compact form, as follows: *> = 0: Compute singular values only. *> = 1: Compute singular vectors of upper *> bidiagonal matrix in compact form. *> \endverbatim *> *> \param[in] NL *> \verbatim *> NL is INTEGER *> The row dimension of the upper block. NL >= 1. *> \endverbatim *> *> \param[in] NR *> \verbatim *> NR is INTEGER *> The row dimension of the lower block. NR >= 1. *> \endverbatim *> *> \param[in] SQRE *> \verbatim *> SQRE is 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 *> N = NL + NR + 1 rows and *> M = N + SQRE >= N columns. *> \endverbatim *> *> \param[out] K *> \verbatim *> K is INTEGER *> Contains the dimension of the non-deflated matrix, this is *> the order of the related secular equation. 1 <= K <=N. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension ( N ) *> On entry D contains the singular values of the two submatrices *> to be combined. On exit D contains the trailing (N-K) updated *> singular values (those which were deflated) sorted into *> increasing order. *> \endverbatim *> *> \param[out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension ( M ) *> On exit Z contains the updating row vector in the secular *> equation. *> \endverbatim *> *> \param[out] ZW *> \verbatim *> ZW is DOUBLE PRECISION array, dimension ( M ) *> Workspace for Z. *> \endverbatim *> *> \param[in,out] VF *> \verbatim *> VF is DOUBLE PRECISION array, dimension ( M ) *> On entry, VF(1:NL+1) contains the first components of all *> right singular vectors of the upper block; and VF(NL+2:M) *> contains the first components of all right singular vectors *> of the lower block. On exit, VF contains the first components *> of all right singular vectors of the bidiagonal matrix. *> \endverbatim *> *> \param[out] VFW *> \verbatim *> VFW is DOUBLE PRECISION array, dimension ( M ) *> Workspace for VF. *> \endverbatim *> *> \param[in,out] VL *> \verbatim *> VL is DOUBLE PRECISION array, dimension ( M ) *> On entry, VL(1:NL+1) contains the last components of all *> right singular vectors of the upper block; and VL(NL+2:M) *> contains the last components of all right singular vectors *> of the lower block. On exit, VL contains the last components *> of all right singular vectors of the bidiagonal matrix. *> \endverbatim *> *> \param[out] VLW *> \verbatim *> VLW is DOUBLE PRECISION array, dimension ( M ) *> Workspace for VL. *> \endverbatim *> *> \param[in] ALPHA *> \verbatim *> ALPHA is DOUBLE PRECISION *> Contains the diagonal element associated with the added row. *> \endverbatim *> *> \param[in] BETA *> \verbatim *> BETA is DOUBLE PRECISION *> Contains the off-diagonal element associated with the added *> row. *> \endverbatim *> *> \param[out] DSIGMA *> \verbatim *> DSIGMA is DOUBLE PRECISION array, dimension ( N ) *> Contains a copy of the diagonal elements (K-1 singular values *> and one zero) in the secular equation. *> \endverbatim *> *> \param[out] IDX *> \verbatim *> IDX is INTEGER array, dimension ( N ) *> This will contain the permutation used to sort the contents of *> D into ascending order. *> \endverbatim *> *> \param[out] IDXP *> \verbatim *> IDXP is INTEGER array, dimension ( N ) *> This will contain the permutation used to place deflated *> values of D at the end of the array. On output IDXP(2:K) *> points to the nondeflated D-values and IDXP(K+1:N) *> points to the deflated singular values. *> \endverbatim *> *> \param[in] IDXQ *> \verbatim *> IDXQ is INTEGER array, dimension ( N ) *> This contains the permutation which separately sorts the two *> sub-problems in D into ascending order. Note that entries in *> the first half of this permutation must first be moved one *> position backward; and entries in the second half *> must first have NL+1 added to their values. *> \endverbatim *> *> \param[out] PERM *> \verbatim *> PERM is INTEGER array, dimension ( N ) *> The permutations (from deflation and sorting) to be applied *> to each singular block. Not referenced if ICOMPQ = 0. *> \endverbatim *> *> \param[out] GIVPTR *> \verbatim *> GIVPTR is INTEGER *> The number of Givens rotations which took place in this *> subproblem. Not referenced if ICOMPQ = 0. *> \endverbatim *> *> \param[out] GIVCOL *> \verbatim *> GIVCOL is INTEGER array, dimension ( LDGCOL, 2 ) *> Each pair of numbers indicates a pair of columns to take place *> in a Givens rotation. Not referenced if ICOMPQ = 0. *> \endverbatim *> *> \param[in] LDGCOL *> \verbatim *> LDGCOL is INTEGER *> The leading dimension of GIVCOL, must be at least N. *> \endverbatim *> *> \param[out] GIVNUM *> \verbatim *> GIVNUM is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) *> Each number indicates the C or S value to be used in the *> corresponding Givens rotation. Not referenced if ICOMPQ = 0. *> \endverbatim *> *> \param[in] LDGNUM *> \verbatim *> LDGNUM is INTEGER *> The leading dimension of GIVNUM, must be at least N. *> \endverbatim *> *> \param[out] C *> \verbatim *> C is 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. *> \endverbatim *> *> \param[out] S *> \verbatim *> S is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * *> \par Contributors: * ================== *> *> Ming Gu and Huan Ren, Computer Science Division, University of *> California at Berkeley, USA *> * ===================================================================== SUBROUTINE DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL, $ VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ, $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, $ C, S, INFO ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, $ NR, SQRE DOUBLE PRECISION ALPHA, BETA, C, S * .. * .. Array Arguments .. INTEGER GIVCOL( LDGCOL, * ), IDX( * ), IDXP( * ), $ IDXQ( * ), PERM( * ) DOUBLE PRECISION D( * ), DSIGMA( * ), GIVNUM( LDGNUM, * ), $ VF( * ), VFW( * ), VL( * ), VLW( * ), Z( * ), $ ZW( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, EIGHT PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, $ EIGHT = 8.0D+0 ) * .. * .. Local Scalars .. * INTEGER I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M, N, $ NLP1, NLP2 DOUBLE PRECISION EPS, HLFTOL, TAU, TOL, Z1 * .. * .. External Subroutines .. EXTERNAL DCOPY, DLAMRG, DROT, XERBLA * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLAPY2 EXTERNAL DLAMCH, DLAPY2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 N = NL + NR + 1 M = N + SQRE * 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 ELSE IF( LDGCOL.LT.N ) THEN INFO = -22 ELSE IF( LDGNUM.LT.N ) THEN INFO = -24 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLASD7', -INFO ) RETURN END IF * NLP1 = NL + 1 NLP2 = NL + 2 IF( ICOMPQ.EQ.1 ) THEN GIVPTR = 0 END IF * * Generate the first part of the vector Z and move the singular * values in the first part of D one position backward. * Z1 = ALPHA*VL( NLP1 ) VL( NLP1 ) = ZERO TAU = VF( NLP1 ) DO 10 I = NL, 1, -1 Z( I+1 ) = ALPHA*VL( I ) VL( I ) = ZERO VF( I+1 ) = VF( I ) D( I+1 ) = D( I ) IDXQ( I+1 ) = IDXQ( I ) + 1 10 CONTINUE VF( 1 ) = TAU * * Generate the second part of the vector Z. * DO 20 I = NLP2, M Z( I ) = BETA*VF( I ) VF( I ) = ZERO 20 CONTINUE * * Sort the singular values into increasing order * DO 30 I = NLP2, N IDXQ( I ) = IDXQ( I ) + NLP1 30 CONTINUE * * DSIGMA, IDXC, IDXC, and ZW are used as storage space. * DO 40 I = 2, N DSIGMA( I ) = D( IDXQ( I ) ) ZW( I ) = Z( IDXQ( I ) ) VFW( I ) = VF( IDXQ( I ) ) VLW( I ) = VL( IDXQ( I ) ) 40 CONTINUE * CALL DLAMRG( NL, NR, DSIGMA( 2 ), 1, 1, IDX( 2 ) ) * DO 50 I = 2, N IDXI = 1 + IDX( I ) D( I ) = DSIGMA( IDXI ) Z( I ) = ZW( IDXI ) VF( I ) = VFW( IDXI ) VL( I ) = VLW( IDXI ) 50 CONTINUE * * Calculate the allowable deflation tolerence * EPS = DLAMCH( 'Epsilon' ) TOL = MAX( ABS( ALPHA ), ABS( BETA ) ) TOL = EIGHT*EIGHT*EPS*MAX( ABS( D( N ) ), TOL ) * * There are 2 kinds of deflation -- first a value in the z-vector * is small, second two (or more) singular values are very close * together (their difference is small). * * If the value in the z-vector is small, we simply permute the * array so that the corresponding singular value is moved to the * end. * * If two values in the D-vector are close, we perform a two-sided * rotation designed to make one of the corresponding z-vector * entries zero, and then permute the array so that the deflated * singular value is moved to the end. * * If there are multiple singular values then the problem deflates. * Here the number of equal singular values are found. As each equal * singular value is found, an elementary reflector is computed to * rotate the corresponding singular subspace so that the * corresponding components of Z are zero in this new basis. * K = 1 K2 = N + 1 DO 60 J = 2, N IF( ABS( Z( J ) ).LE.TOL ) THEN * * Deflate due to small z component. * K2 = K2 - 1 IDXP( K2 ) = J IF( J.EQ.N ) $ GO TO 100 ELSE JPREV = J GO TO 70 END IF 60 CONTINUE 70 CONTINUE J = JPREV 80 CONTINUE J = J + 1 IF( J.GT.N ) $ GO TO 90 IF( ABS( Z( J ) ).LE.TOL ) THEN * * Deflate due to small z component. * K2 = K2 - 1 IDXP( K2 ) = J ELSE * * Check if singular values are close enough to allow deflation. * IF( ABS( D( J )-D( JPREV ) ).LE.TOL ) THEN * * Deflation is possible. * S = Z( JPREV ) C = Z( J ) * * Find sqrt(a**2+b**2) without overflow or * destructive underflow. * TAU = DLAPY2( C, S ) Z( J ) = TAU Z( JPREV ) = ZERO C = C / TAU S = -S / TAU * * Record the appropriate Givens rotation * IF( ICOMPQ.EQ.1 ) THEN GIVPTR = GIVPTR + 1 IDXJP = IDXQ( IDX( JPREV )+1 ) IDXJ = IDXQ( IDX( J )+1 ) IF( IDXJP.LE.NLP1 ) THEN IDXJP = IDXJP - 1 END IF IF( IDXJ.LE.NLP1 ) THEN IDXJ = IDXJ - 1 END IF GIVCOL( GIVPTR, 2 ) = IDXJP GIVCOL( GIVPTR, 1 ) = IDXJ GIVNUM( GIVPTR, 2 ) = C GIVNUM( GIVPTR, 1 ) = S END IF CALL DROT( 1, VF( JPREV ), 1, VF( J ), 1, C, S ) CALL DROT( 1, VL( JPREV ), 1, VL( J ), 1, C, S ) K2 = K2 - 1 IDXP( K2 ) = JPREV JPREV = J ELSE K = K + 1 ZW( K ) = Z( JPREV ) DSIGMA( K ) = D( JPREV ) IDXP( K ) = JPREV JPREV = J END IF END IF GO TO 80 90 CONTINUE * * Record the last singular value. * K = K + 1 ZW( K ) = Z( JPREV ) DSIGMA( K ) = D( JPREV ) IDXP( K ) = JPREV * 100 CONTINUE * * Sort the singular values into DSIGMA. The singular values which * were not deflated go into the first K slots of DSIGMA, except * that DSIGMA(1) is treated separately. * DO 110 J = 2, N JP = IDXP( J ) DSIGMA( J ) = D( JP ) VFW( J ) = VF( JP ) VLW( J ) = VL( JP ) 110 CONTINUE IF( ICOMPQ.EQ.1 ) THEN DO 120 J = 2, N JP = IDXP( J ) PERM( J ) = IDXQ( IDX( JP )+1 ) IF( PERM( J ).LE.NLP1 ) THEN PERM( J ) = PERM( J ) - 1 END IF 120 CONTINUE END IF * * The deflated singular values go back into the last N - K slots of * D. * CALL DCOPY( N-K, DSIGMA( K+1 ), 1, D( K+1 ), 1 ) * * Determine DSIGMA(1), DSIGMA(2), Z(1), VF(1), VL(1), VF(M), and * VL(M). * DSIGMA( 1 ) = ZERO HLFTOL = TOL / TWO IF( ABS( DSIGMA( 2 ) ).LE.HLFTOL ) $ DSIGMA( 2 ) = HLFTOL IF( M.GT.N ) THEN Z( 1 ) = DLAPY2( Z1, Z( M ) ) IF( Z( 1 ).LE.TOL ) THEN C = ONE S = ZERO Z( 1 ) = TOL ELSE C = Z1 / Z( 1 ) S = -Z( M ) / Z( 1 ) END IF CALL DROT( 1, VF( M ), 1, VF( 1 ), 1, C, S ) CALL DROT( 1, VL( M ), 1, VL( 1 ), 1, C, S ) ELSE IF( ABS( Z1 ).LE.TOL ) THEN Z( 1 ) = TOL ELSE Z( 1 ) = Z1 END IF END IF * * Restore Z, VF, and VL. * CALL DCOPY( K-1, ZW( 2 ), 1, Z( 2 ), 1 ) CALL DCOPY( N-1, VFW( 2 ), 1, VF( 2 ), 1 ) CALL DCOPY( N-1, VLW( 2 ), 1, VL( 2 ), 1 ) * RETURN * * End of DLASD7 * END *> \brief \b DLASD8 finds the square roots of the roots of the secular equation, and stores, for each element in D, the distance to its two nearest poles. Used by sbdsdc. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASD8 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR, * DSIGMA, WORK, INFO ) * * .. Scalar Arguments .. * INTEGER ICOMPQ, INFO, K, LDDIFR * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), DIFL( * ), DIFR( LDDIFR, * ), * $ DSIGMA( * ), VF( * ), VL( * ), WORK( * ), * $ Z( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLASD8 finds the square roots of the roots of the secular equation, *> as defined by the values in DSIGMA and Z. It makes the appropriate *> calls to DLASD4, and stores, for each element in D, the distance *> to its two nearest poles (elements in DSIGMA). It also updates *> the arrays VF and VL, the first and last components of all the *> right singular vectors of the original bidiagonal matrix. *> *> DLASD8 is called from DLASD6. *> \endverbatim * * Arguments: * ========== * *> \param[in] ICOMPQ *> \verbatim *> ICOMPQ is INTEGER *> Specifies whether singular vectors are to be computed in *> factored form in the calling routine: *> = 0: Compute singular values only. *> = 1: Compute singular vectors in factored form as well. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The number of terms in the rational function to be solved *> by DLASD4. K >= 1. *> \endverbatim *> *> \param[out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension ( K ) *> On output, D contains the updated singular values. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension ( K ) *> On entry, the first K elements of this array contain the *> components of the deflation-adjusted updating row vector. *> On exit, Z is updated. *> \endverbatim *> *> \param[in,out] VF *> \verbatim *> VF is DOUBLE PRECISION array, dimension ( K ) *> On entry, VF contains information passed through DBEDE8. *> On exit, VF contains the first K components of the first *> components of all right singular vectors of the bidiagonal *> matrix. *> \endverbatim *> *> \param[in,out] VL *> \verbatim *> VL is DOUBLE PRECISION array, dimension ( K ) *> On entry, VL contains information passed through DBEDE8. *> On exit, VL contains the first K components of the last *> components of all right singular vectors of the bidiagonal *> matrix. *> \endverbatim *> *> \param[out] DIFL *> \verbatim *> DIFL is DOUBLE PRECISION array, dimension ( K ) *> On exit, DIFL(I) = D(I) - DSIGMA(I). *> \endverbatim *> *> \param[out] DIFR *> \verbatim *> DIFR is DOUBLE PRECISION array, *> dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and *> dimension ( K ) if ICOMPQ = 0. *> On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not *> defined and will not be referenced. *> *> If ICOMPQ = 1, DIFR(1:K,2) is an array containing the *> normalizing factors for the right singular vector matrix. *> \endverbatim *> *> \param[in] LDDIFR *> \verbatim *> LDDIFR is INTEGER *> The leading dimension of DIFR, must be at least K. *> \endverbatim *> *> \param[in,out] DSIGMA *> \verbatim *> DSIGMA is DOUBLE PRECISION array, dimension ( K ) *> On entry, the first K elements of this array contain the old *> roots of the deflated updating problem. These are the poles *> of the secular equation. *> On exit, the elements of DSIGMA may be very slightly altered *> in value. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*K) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: if INFO = 1, a singular value did not converge *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup OTHERauxiliary * *> \par Contributors: * ================== *> *> Ming Gu and Huan Ren, Computer Science Division, University of *> California at Berkeley, USA *> * ===================================================================== SUBROUTINE DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR, $ DSIGMA, WORK, INFO ) * * -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. INTEGER ICOMPQ, INFO, K, LDDIFR * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), DIFL( * ), DIFR( LDDIFR, * ), $ DSIGMA( * ), VF( * ), VL( * ), WORK( * ), $ Z( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, IWK1, IWK2, IWK2I, IWK3, IWK3I, J DOUBLE PRECISION DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, RHO, TEMP * .. * .. External Subroutines .. EXTERNAL DCOPY, DLASCL, DLASD4, DLASET, XERBLA * .. * .. External Functions .. DOUBLE PRECISION DDOT, DLAMC3, DNRM2 EXTERNAL DDOT, DLAMC3, DNRM2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, SIGN, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 * IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN INFO = -1 ELSE IF( K.LT.1 ) THEN INFO = -2 ELSE IF( LDDIFR.LT.K ) THEN INFO = -9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLASD8', -INFO ) RETURN END IF * * Quick return if possible * IF( K.EQ.1 ) THEN D( 1 ) = ABS( Z( 1 ) ) DIFL( 1 ) = D( 1 ) IF( ICOMPQ.EQ.1 ) THEN DIFL( 2 ) = ONE DIFR( 1, 2 ) = ONE END IF RETURN END IF * * Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(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 DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I), * which on any of these machines zeros out the bottommost * bit of DSIGMA(I) if it is 1; this makes the subsequent * subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation * occurs. On binary machines with a guard digit (almost all * machines) it does not change DSIGMA(I) at all. On hexadecimal * and decimal machines with a guard digit, it slightly * changes the bottommost bits of DSIGMA(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 DSIGMA( I ) = DLAMC3( DSIGMA( I ), DSIGMA( I ) ) - DSIGMA( I ) 10 CONTINUE * * Book keeping. * IWK1 = 1 IWK2 = IWK1 + K IWK3 = IWK2 + K IWK2I = IWK2 - 1 IWK3I = IWK3 - 1 * * Normalize Z. * RHO = DNRM2( K, Z, 1 ) CALL DLASCL( 'G', 0, 0, RHO, ONE, K, 1, Z, K, INFO ) RHO = RHO*RHO * * Initialize WORK(IWK3). * CALL DLASET( 'A', K, 1, ONE, ONE, WORK( IWK3 ), K ) * * Compute the updated singular values, the arrays DIFL, DIFR, * and the updated Z. * DO 40 J = 1, K CALL DLASD4( K, J, DSIGMA, Z, WORK( IWK1 ), RHO, D( J ), $ WORK( IWK2 ), INFO ) * * If the root finder fails, report the convergence failure. * IF( INFO.NE.0 ) THEN RETURN END IF WORK( IWK3I+J ) = WORK( IWK3I+J )*WORK( J )*WORK( IWK2I+J ) DIFL( J ) = -WORK( J ) DIFR( J, 1 ) = -WORK( J+1 ) DO 20 I = 1, J - 1 WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )* $ WORK( IWK2I+I ) / ( DSIGMA( I )- $ DSIGMA( J ) ) / ( DSIGMA( I )+ $ DSIGMA( J ) ) 20 CONTINUE DO 30 I = J + 1, K WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )* $ WORK( IWK2I+I ) / ( DSIGMA( I )- $ DSIGMA( J ) ) / ( DSIGMA( I )+ $ DSIGMA( J ) ) 30 CONTINUE 40 CONTINUE * * Compute updated Z. * DO 50 I = 1, K Z( I ) = SIGN( SQRT( ABS( WORK( IWK3I+I ) ) ), Z( I ) ) 50 CONTINUE * * Update VF and VL. * DO 80 J = 1, K DIFLJ = DIFL( J ) DJ = D( J ) DSIGJ = -DSIGMA( J ) IF( J.LT.K ) THEN DIFRJ = -DIFR( J, 1 ) DSIGJP = -DSIGMA( J+1 ) END IF WORK( J ) = -Z( J ) / DIFLJ / ( DSIGMA( J )+DJ ) DO 60 I = 1, J - 1 WORK( I ) = Z( I ) / ( DLAMC3( DSIGMA( I ), DSIGJ )-DIFLJ ) $ / ( DSIGMA( I )+DJ ) 60 CONTINUE DO 70 I = J + 1, K WORK( I ) = Z( I ) / ( DLAMC3( DSIGMA( I ), DSIGJP )+DIFRJ ) $ / ( DSIGMA( I )+DJ ) 70 CONTINUE TEMP = DNRM2( K, WORK, 1 ) WORK( IWK2I+J ) = DDOT( K, WORK, 1, VF, 1 ) / TEMP WORK( IWK3I+J ) = DDOT( K, WORK, 1, VL, 1 ) / TEMP IF( ICOMPQ.EQ.1 ) THEN DIFR( J, 2 ) = TEMP END IF 80 CONTINUE * CALL DCOPY( K, WORK( IWK2 ), 1, VF, 1 ) CALL DCOPY( K, WORK( IWK3 ), 1, VL, 1 ) * RETURN * * End of DLASD8 * END *> \brief \b DLASDA computes the singular value decomposition (SVD) of a real upper bidiagonal matrix with diagonal d and off-diagonal e. Used by sbdsdc. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASDA + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K, * DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, * PERM, GIVNUM, C, S, WORK, IWORK, INFO ) * * .. Scalar Arguments .. * INTEGER ICOMPQ, INFO, LDGCOL, LDU, N, SMLSIZ, SQRE * .. * .. Array Arguments .. * INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ), * $ K( * ), PERM( LDGCOL, * ) * DOUBLE PRECISION C( * ), D( * ), DIFL( LDU, * ), DIFR( LDU, * ), * $ E( * ), GIVNUM( LDU, * ), POLES( LDU, * ), * $ S( * ), U( LDU, * ), VT( LDU, * ), WORK( * ), * $ Z( LDU, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> Using a divide and conquer approach, DLASDA computes the singular *> value decomposition (SVD) of a real upper bidiagonal N-by-M matrix *> B with diagonal D and offdiagonal E, where M = N + SQRE. The *> algorithm computes the singular values in the SVD B = U * S * VT. *> The orthogonal matrices U and VT are optionally computed in *> compact form. *> *> A related subroutine, DLASD0, computes the singular values and *> the singular vectors in explicit form. *> \endverbatim * * Arguments: * ========== * *> \param[in] ICOMPQ *> \verbatim *> ICOMPQ is INTEGER *> Specifies whether singular vectors are to be computed *> in compact form, as follows *> = 0: Compute singular values only. *> = 1: Compute singular vectors of upper bidiagonal *> matrix in compact form. *> \endverbatim *> *> \param[in] SMLSIZ *> \verbatim *> SMLSIZ is INTEGER *> The maximum size of the subproblems at the bottom of the *> computation tree. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The row dimension of the upper bidiagonal matrix. This is *> also the dimension of the main diagonal array D. *> \endverbatim *> *> \param[in] SQRE *> \verbatim *> SQRE is INTEGER *> Specifies the column dimension of the bidiagonal matrix. *> = 0: The bidiagonal matrix has column dimension M = N; *> = 1: The bidiagonal matrix has column dimension M = N + 1. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension ( N ) *> On entry D contains the main diagonal of the bidiagonal *> matrix. On exit D, if INFO = 0, contains its singular values. *> \endverbatim *> *> \param[in] E *> \verbatim *> E is DOUBLE PRECISION array, dimension ( M-1 ) *> Contains the subdiagonal entries of the bidiagonal matrix. *> On exit, E has been destroyed. *> \endverbatim *> *> \param[out] U *> \verbatim *> U is DOUBLE PRECISION array, *> dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced *> if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left *> singular vector matrices of all subproblems at the bottom *> level. *> \endverbatim *> *> \param[in] LDU *> \verbatim *> LDU is INTEGER, LDU = > N. *> The leading dimension of arrays U, VT, DIFL, DIFR, POLES, *> GIVNUM, and Z. *> \endverbatim *> *> \param[out] VT *> \verbatim *> VT is DOUBLE PRECISION array, *> dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced *> if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT**T contains the right *> singular vector matrices of all subproblems at the bottom *> level. *> \endverbatim *> *> \param[out] K *> \verbatim *> K is INTEGER array, *> dimension ( N ) if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0. *> If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th *> secular equation on the computation tree. *> \endverbatim *> *> \param[out] DIFL *> \verbatim *> DIFL is DOUBLE PRECISION array, dimension ( LDU, NLVL ), *> where NLVL = floor(log_2 (N/SMLSIZ))). *> \endverbatim *> *> \param[out] DIFR *> \verbatim *> DIFR is DOUBLE PRECISION array, *> dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and *> dimension ( N ) if ICOMPQ = 0. *> If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1) *> record distances between singular values on the I-th *> level and singular values on the (I -1)-th level, and *> DIFR(1:N, 2 * I ) contains the normalizing factors for *> the right singular vector matrix. See DLASD8 for details. *> \endverbatim *> *> \param[out] Z *> \verbatim *> Z is DOUBLE PRECISION array, *> dimension ( LDU, NLVL ) if ICOMPQ = 1 and *> dimension ( N ) if ICOMPQ = 0. *> The first K elements of Z(1, I) contain the components of *> the deflation-adjusted updating row vector for subproblems *> on the I-th level. *> \endverbatim *> *> \param[out] POLES *> \verbatim *> POLES is DOUBLE PRECISION array, *> dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced *> if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and *> POLES(1, 2*I) contain the new and old singular values *> involved in the secular equations on the I-th level. *> \endverbatim *> *> \param[out] GIVPTR *> \verbatim *> GIVPTR is INTEGER array, *> dimension ( N ) if ICOMPQ = 1, and not referenced if *> ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records *> the number of Givens rotations performed on the I-th *> problem on the computation tree. *> \endverbatim *> *> \param[out] GIVCOL *> \verbatim *> GIVCOL is INTEGER array, *> dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not *> referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, *> GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations *> of Givens rotations performed on the I-th level on the *> computation tree. *> \endverbatim *> *> \param[in] LDGCOL *> \verbatim *> LDGCOL is INTEGER, LDGCOL = > N. *> The leading dimension of arrays GIVCOL and PERM. *> \endverbatim *> *> \param[out] PERM *> \verbatim *> PERM is INTEGER array, *> dimension ( LDGCOL, NLVL ) if ICOMPQ = 1, and not referenced *> if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records *> permutations done on the I-th level of the computation tree. *> \endverbatim *> *> \param[out] GIVNUM *> \verbatim *> GIVNUM is DOUBLE PRECISION array, *> dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not *> referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, *> GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S- *> values of Givens rotations performed on the I-th level on *> the computation tree. *> \endverbatim *> *> \param[out] C *> \verbatim *> C is DOUBLE PRECISION array, *> dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. *> If ICOMPQ = 1 and the I-th subproblem is not square, on exit, *> C( I ) contains the C-value of a Givens rotation related to *> the right null space of the I-th subproblem. *> \endverbatim *> *> \param[out] S *> \verbatim *> S is DOUBLE PRECISION array, dimension ( N ) if *> ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1 *> and the I-th subproblem is not square, on exit, S( I ) *> contains the S-value of a Givens rotation related to *> the right null space of the I-th subproblem. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension *> (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)). *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (7*N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: if INFO = 1, a singular value did not converge *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup OTHERauxiliary * *> \par Contributors: * ================== *> *> Ming Gu and Huan Ren, Computer Science Division, University of *> California at Berkeley, USA *> * ===================================================================== SUBROUTINE DLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K, $ DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, $ PERM, GIVNUM, C, S, WORK, IWORK, INFO ) * * -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. INTEGER ICOMPQ, INFO, LDGCOL, LDU, N, SMLSIZ, SQRE * .. * .. Array Arguments .. INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ), $ K( * ), PERM( LDGCOL, * ) DOUBLE PRECISION C( * ), D( * ), DIFL( LDU, * ), DIFR( LDU, * ), $ E( * ), GIVNUM( LDU, * ), POLES( LDU, * ), $ S( * ), U( LDU, * ), VT( LDU, * ), WORK( * ), $ Z( LDU, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, I1, IC, IDXQ, IDXQI, IM1, INODE, ITEMP, IWK, $ J, LF, LL, LVL, LVL2, M, NCC, ND, NDB1, NDIML, $ NDIMR, NL, NLF, NLP1, NLVL, NR, NRF, NRP1, NRU, $ NWORK1, NWORK2, SMLSZP, SQREI, VF, VFI, VL, VLI DOUBLE PRECISION ALPHA, BETA * .. * .. External Subroutines .. EXTERNAL DCOPY, DLASD6, DLASDQ, DLASDT, DLASET, 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.0 ) THEN INFO = -3 ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN INFO = -4 ELSE IF( LDU.LT.( N+SQRE ) ) THEN INFO = -8 ELSE IF( LDGCOL.LT.N ) THEN INFO = -17 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLASDA', -INFO ) RETURN END IF * M = N + SQRE * * If the input matrix is too small, call DLASDQ to find the SVD. * IF( N.LE.SMLSIZ ) THEN IF( ICOMPQ.EQ.0 ) THEN CALL DLASDQ( 'U', SQRE, N, 0, 0, 0, D, E, VT, LDU, U, LDU, $ U, LDU, WORK, INFO ) ELSE CALL DLASDQ( 'U', SQRE, N, M, N, 0, D, E, VT, LDU, U, LDU, $ U, LDU, WORK, INFO ) END IF RETURN END IF * * Book-keeping and set up the computation tree. * INODE = 1 NDIML = INODE + N NDIMR = NDIML + N IDXQ = NDIMR + N IWK = IDXQ + N * NCC = 0 NRU = 0 * SMLSZP = SMLSIZ + 1 VF = 1 VL = VF + M NWORK1 = VL + M NWORK2 = NWORK1 + SMLSZP*SMLSZP * CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ), $ IWORK( NDIMR ), SMLSIZ ) * * for the nodes on bottom level of the tree, solve * their subproblems by DLASDQ. * NDB1 = ( ND+1 ) / 2 DO 30 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 ) NLP1 = NL + 1 NR = IWORK( NDIMR+I1 ) NLF = IC - NL NRF = IC + 1 IDXQI = IDXQ + NLF - 2 VFI = VF + NLF - 1 VLI = VL + NLF - 1 SQREI = 1 IF( ICOMPQ.EQ.0 ) THEN CALL DLASET( 'A', NLP1, NLP1, ZERO, ONE, WORK( NWORK1 ), $ SMLSZP ) CALL DLASDQ( 'U', SQREI, NL, NLP1, NRU, NCC, D( NLF ), $ E( NLF ), WORK( NWORK1 ), SMLSZP, $ WORK( NWORK2 ), NL, WORK( NWORK2 ), NL, $ WORK( NWORK2 ), INFO ) ITEMP = NWORK1 + NL*SMLSZP CALL DCOPY( NLP1, WORK( NWORK1 ), 1, WORK( VFI ), 1 ) CALL DCOPY( NLP1, WORK( ITEMP ), 1, WORK( VLI ), 1 ) ELSE CALL DLASET( 'A', NL, NL, ZERO, ONE, U( NLF, 1 ), LDU ) CALL DLASET( 'A', NLP1, NLP1, ZERO, ONE, VT( NLF, 1 ), LDU ) CALL DLASDQ( 'U', SQREI, NL, NLP1, NL, NCC, D( NLF ), $ E( NLF ), VT( NLF, 1 ), LDU, U( NLF, 1 ), LDU, $ U( NLF, 1 ), LDU, WORK( NWORK1 ), INFO ) CALL DCOPY( NLP1, VT( NLF, 1 ), 1, WORK( VFI ), 1 ) CALL DCOPY( NLP1, VT( NLF, NLP1 ), 1, WORK( VLI ), 1 ) END IF IF( INFO.NE.0 ) THEN RETURN END IF DO 10 J = 1, NL IWORK( IDXQI+J ) = J 10 CONTINUE IF( ( I.EQ.ND ) .AND. ( SQRE.EQ.0 ) ) THEN SQREI = 0 ELSE SQREI = 1 END IF IDXQI = IDXQI + NLP1 VFI = VFI + NLP1 VLI = VLI + NLP1 NRP1 = NR + SQREI IF( ICOMPQ.EQ.0 ) THEN CALL DLASET( 'A', NRP1, NRP1, ZERO, ONE, WORK( NWORK1 ), $ SMLSZP ) CALL DLASDQ( 'U', SQREI, NR, NRP1, NRU, NCC, D( NRF ), $ E( NRF ), WORK( NWORK1 ), SMLSZP, $ WORK( NWORK2 ), NR, WORK( NWORK2 ), NR, $ WORK( NWORK2 ), INFO ) ITEMP = NWORK1 + ( NRP1-1 )*SMLSZP CALL DCOPY( NRP1, WORK( NWORK1 ), 1, WORK( VFI ), 1 ) CALL DCOPY( NRP1, WORK( ITEMP ), 1, WORK( VLI ), 1 ) ELSE CALL DLASET( 'A', NR, NR, ZERO, ONE, U( NRF, 1 ), LDU ) CALL DLASET( 'A', NRP1, NRP1, ZERO, ONE, VT( NRF, 1 ), LDU ) CALL DLASDQ( 'U', SQREI, NR, NRP1, NR, NCC, D( NRF ), $ E( NRF ), VT( NRF, 1 ), LDU, U( NRF, 1 ), LDU, $ U( NRF, 1 ), LDU, WORK( NWORK1 ), INFO ) CALL DCOPY( NRP1, VT( NRF, 1 ), 1, WORK( VFI ), 1 ) CALL DCOPY( NRP1, VT( NRF, NRP1 ), 1, WORK( VLI ), 1 ) END IF IF( INFO.NE.0 ) THEN RETURN END IF DO 20 J = 1, NR IWORK( IDXQI+J ) = J 20 CONTINUE 30 CONTINUE * * Now conquer each subproblem bottom-up. * J = 2**NLVL DO 50 LVL = NLVL, 1, -1 LVL2 = LVL*2 - 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 40 I = LF, LL 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 SQREI = SQRE ELSE SQREI = 1 END IF VFI = VF + NLF - 1 VLI = VL + NLF - 1 IDXQI = IDXQ + NLF - 1 ALPHA = D( IC ) BETA = E( IC ) IF( ICOMPQ.EQ.0 ) THEN CALL DLASD6( ICOMPQ, NL, NR, SQREI, D( NLF ), $ WORK( VFI ), WORK( VLI ), ALPHA, BETA, $ IWORK( IDXQI ), PERM, GIVPTR( 1 ), GIVCOL, $ LDGCOL, GIVNUM, LDU, POLES, DIFL, DIFR, Z, $ K( 1 ), C( 1 ), S( 1 ), WORK( NWORK1 ), $ IWORK( IWK ), INFO ) ELSE J = J - 1 CALL DLASD6( ICOMPQ, NL, NR, SQREI, D( NLF ), $ WORK( VFI ), WORK( VLI ), ALPHA, BETA, $ IWORK( IDXQI ), 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( NWORK1 ), $ IWORK( IWK ), INFO ) END IF IF( INFO.NE.0 ) THEN RETURN END IF 40 CONTINUE 50 CONTINUE * RETURN * * End of DLASDA * END *> \brief \b DLASDQ computes the SVD of a real bidiagonal matrix with diagonal d and off-diagonal e. Used by sbdsdc. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASDQ + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT, * U, LDU, C, LDC, WORK, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU, SQRE * .. * .. Array Arguments .. * DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ), * $ VT( LDVT, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLASDQ computes the singular value decomposition (SVD) of a real *> (upper or lower) bidiagonal matrix with diagonal D and offdiagonal *> E, accumulating the transformations if desired. Letting B denote *> the input bidiagonal matrix, the algorithm computes orthogonal *> matrices Q and P such that B = Q * S * P**T (P**T denotes the transpose *> of P). The singular values S are overwritten on D. *> *> The input matrix U is changed to U * Q if desired. *> The input matrix VT is changed to P**T * VT if desired. *> The input matrix C is changed to Q**T * C if desired. *> *> See "Computing Small Singular Values of Bidiagonal Matrices With *> Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, *> LAPACK Working Note #3, for a detailed description of the algorithm. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> On entry, UPLO specifies whether the input bidiagonal matrix *> is upper or lower bidiagonal, and whether it is square are *> not. *> UPLO = 'U' or 'u' B is upper bidiagonal. *> UPLO = 'L' or 'l' B is lower bidiagonal. *> \endverbatim *> *> \param[in] SQRE *> \verbatim *> SQRE is INTEGER *> = 0: then the input matrix is N-by-N. *> = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and *> (N+1)-by-N if UPLU = 'L'. *> *> The bidiagonal matrix has *> N = NL + NR + 1 rows and *> M = N + SQRE >= N columns. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> On entry, N specifies the number of rows and columns *> in the matrix. N must be at least 0. *> \endverbatim *> *> \param[in] NCVT *> \verbatim *> NCVT is INTEGER *> On entry, NCVT specifies the number of columns of *> the matrix VT. NCVT must be at least 0. *> \endverbatim *> *> \param[in] NRU *> \verbatim *> NRU is INTEGER *> On entry, NRU specifies the number of rows of *> the matrix U. NRU must be at least 0. *> \endverbatim *> *> \param[in] NCC *> \verbatim *> NCC is INTEGER *> On entry, NCC specifies the number of columns of *> the matrix C. NCC must be at least 0. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> On entry, D contains the diagonal entries of the *> bidiagonal matrix whose SVD is desired. On normal exit, *> D contains the singular values in ascending order. *> \endverbatim *> *> \param[in,out] E *> \verbatim *> E is DOUBLE PRECISION array. *> dimension is (N-1) if SQRE = 0 and N if SQRE = 1. *> On entry, the entries of E contain the offdiagonal entries *> of the bidiagonal matrix whose SVD is desired. On normal *> exit, E will contain 0. If the algorithm does not converge, *> D and E will contain the diagonal and superdiagonal entries *> of a bidiagonal matrix orthogonally equivalent to the one *> given as input. *> \endverbatim *> *> \param[in,out] VT *> \verbatim *> VT is DOUBLE PRECISION array, dimension (LDVT, NCVT) *> On entry, contains a matrix which on exit has been *> premultiplied by P**T, dimension N-by-NCVT if SQRE = 0 *> and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0). *> \endverbatim *> *> \param[in] LDVT *> \verbatim *> LDVT is INTEGER *> On entry, LDVT specifies the leading dimension of VT as *> declared in the calling (sub) program. LDVT must be at *> least 1. If NCVT is nonzero LDVT must also be at least N. *> \endverbatim *> *> \param[in,out] U *> \verbatim *> U is DOUBLE PRECISION array, dimension (LDU, N) *> On entry, contains a matrix which on exit has been *> postmultiplied by Q, dimension NRU-by-N if SQRE = 0 *> and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0). *> \endverbatim *> *> \param[in] LDU *> \verbatim *> LDU is INTEGER *> On entry, LDU specifies the leading dimension of U as *> declared in the calling (sub) program. LDU must be at *> least max( 1, NRU ) . *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (LDC, NCC) *> On entry, contains an N-by-NCC matrix which on exit *> has been premultiplied by Q**T dimension N-by-NCC if SQRE = 0 *> and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0). *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> On entry, LDC specifies the leading dimension of C as *> declared in the calling (sub) program. LDC must be at *> least 1. If NCC is nonzero, LDC must also be at least N. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (4*N) *> Workspace. Only referenced if one of NCVT, NRU, or NCC is *> nonzero, and if N is at least 2. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> On exit, a value of 0 indicates a successful exit. *> If INFO < 0, argument number -INFO is illegal. *> If INFO > 0, the algorithm did not converge, and INFO *> specifies how many superdiagonals did not converge. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup OTHERauxiliary * *> \par Contributors: * ================== *> *> Ming Gu and Huan Ren, Computer Science Division, University of *> California at Berkeley, USA *> * ===================================================================== SUBROUTINE DLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT, $ U, LDU, C, LDC, WORK, INFO ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU, SQRE * .. * .. Array Arguments .. DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ), $ VT( LDVT, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL ROTATE INTEGER I, ISUB, IUPLO, J, NP1, SQRE1 DOUBLE PRECISION CS, R, SMIN, SN * .. * .. External Subroutines .. EXTERNAL DBDSQR, DLARTG, DLASR, DSWAP, XERBLA * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IUPLO = 0 IF( LSAME( UPLO, 'U' ) ) $ IUPLO = 1 IF( LSAME( UPLO, 'L' ) ) $ IUPLO = 2 IF( IUPLO.EQ.0 ) THEN INFO = -1 ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( NCVT.LT.0 ) THEN INFO = -4 ELSE IF( NRU.LT.0 ) THEN INFO = -5 ELSE IF( NCC.LT.0 ) THEN INFO = -6 ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR. $ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN INFO = -10 ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN INFO = -12 ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR. $ ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN INFO = -14 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLASDQ', -INFO ) RETURN END IF IF( N.EQ.0 ) $ RETURN * * ROTATE is true if any singular vectors desired, false otherwise * ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 ) NP1 = N + 1 SQRE1 = SQRE * * If matrix non-square upper bidiagonal, rotate to be lower * bidiagonal. The rotations are on the right. * IF( ( IUPLO.EQ.1 ) .AND. ( SQRE1.EQ.1 ) ) 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( ROTATE ) THEN WORK( I ) = CS WORK( N+I ) = SN END IF 10 CONTINUE CALL DLARTG( D( N ), E( N ), CS, SN, R ) D( N ) = R E( N ) = ZERO IF( ROTATE ) THEN WORK( N ) = CS WORK( N+N ) = SN END IF IUPLO = 2 SQRE1 = 0 * * Update singular vectors if desired. * IF( NCVT.GT.0 ) $ CALL DLASR( 'L', 'V', 'F', NP1, NCVT, WORK( 1 ), $ WORK( NP1 ), VT, LDVT ) END IF * * If matrix lower bidiagonal, rotate to be upper bidiagonal * by applying Givens rotations on the left. * IF( IUPLO.EQ.2 ) THEN DO 20 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( ROTATE ) THEN WORK( I ) = CS WORK( N+I ) = SN END IF 20 CONTINUE * * If matrix (N+1)-by-N lower bidiagonal, one additional * rotation is needed. * IF( SQRE1.EQ.1 ) THEN CALL DLARTG( D( N ), E( N ), CS, SN, R ) D( N ) = R IF( ROTATE ) THEN WORK( N ) = CS WORK( N+N ) = SN END IF END IF * * Update singular vectors if desired. * IF( NRU.GT.0 ) THEN IF( SQRE1.EQ.0 ) THEN CALL DLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ), $ WORK( NP1 ), U, LDU ) ELSE CALL DLASR( 'R', 'V', 'F', NRU, NP1, WORK( 1 ), $ WORK( NP1 ), U, LDU ) END IF END IF IF( NCC.GT.0 ) THEN IF( SQRE1.EQ.0 ) THEN CALL DLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ), $ WORK( NP1 ), C, LDC ) ELSE CALL DLASR( 'L', 'V', 'F', NP1, NCC, WORK( 1 ), $ WORK( NP1 ), C, LDC ) END IF END IF END IF * * Call DBDSQR to compute the SVD of the reduced real * N-by-N upper bidiagonal matrix. * CALL DBDSQR( 'U', N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, $ LDC, WORK, INFO ) * * Sort the singular values into ascending order (insertion sort on * singular values, but only one transposition per singular vector) * DO 40 I = 1, N * * Scan for smallest D(I). * ISUB = I SMIN = D( I ) DO 30 J = I + 1, N IF( D( J ).LT.SMIN ) THEN ISUB = J SMIN = D( J ) END IF 30 CONTINUE IF( ISUB.NE.I ) THEN * * Swap singular values and vectors. * D( ISUB ) = D( I ) D( I ) = SMIN IF( NCVT.GT.0 ) $ CALL DSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( I, 1 ), LDVT ) IF( NRU.GT.0 ) $ CALL DSWAP( NRU, U( 1, ISUB ), 1, U( 1, I ), 1 ) IF( NCC.GT.0 ) $ CALL DSWAP( NCC, C( ISUB, 1 ), LDC, C( I, 1 ), LDC ) END IF 40 CONTINUE * RETURN * * End of DLASDQ * END *> \brief \b DLASDT creates a tree of subproblems for bidiagonal divide and conquer. Used by sbdsdc. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASDT + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB ) * * .. Scalar Arguments .. * INTEGER LVL, MSUB, N, ND * .. * .. Array Arguments .. * INTEGER INODE( * ), NDIML( * ), NDIMR( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLASDT creates a tree of subproblems for bidiagonal divide and *> conquer. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> On entry, the number of diagonal elements of the *> bidiagonal matrix. *> \endverbatim *> *> \param[out] LVL *> \verbatim *> LVL is INTEGER *> On exit, the number of levels on the computation tree. *> \endverbatim *> *> \param[out] ND *> \verbatim *> ND is INTEGER *> On exit, the number of nodes on the tree. *> \endverbatim *> *> \param[out] INODE *> \verbatim *> INODE is INTEGER array, dimension ( N ) *> On exit, centers of subproblems. *> \endverbatim *> *> \param[out] NDIML *> \verbatim *> NDIML is INTEGER array, dimension ( N ) *> On exit, row dimensions of left children. *> \endverbatim *> *> \param[out] NDIMR *> \verbatim *> NDIMR is INTEGER array, dimension ( N ) *> On exit, row dimensions of right children. *> \endverbatim *> *> \param[in] MSUB *> \verbatim *> MSUB is INTEGER *> On entry, the maximum row dimension each subproblem at the *> bottom of the tree can be of. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * *> \par Contributors: * ================== *> *> Ming Gu and Huan Ren, Computer Science Division, University of *> California at Berkeley, USA *> * ===================================================================== SUBROUTINE DLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER LVL, MSUB, N, ND * .. * .. Array Arguments .. INTEGER INODE( * ), NDIML( * ), NDIMR( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D+0 ) * .. * .. Local Scalars .. INTEGER I, IL, IR, LLST, MAXN, NCRNT, NLVL DOUBLE PRECISION TEMP * .. * .. Intrinsic Functions .. INTRINSIC DBLE, INT, LOG, MAX * .. * .. Executable Statements .. * * Find the number of levels on the tree. * MAXN = MAX( 1, N ) TEMP = LOG( DBLE( MAXN ) / DBLE( MSUB+1 ) ) / LOG( TWO ) LVL = INT( TEMP ) + 1 * I = N / 2 INODE( 1 ) = I + 1 NDIML( 1 ) = I NDIMR( 1 ) = N - I - 1 IL = 0 IR = 1 LLST = 1 DO 20 NLVL = 1, LVL - 1 * * Constructing the tree at (NLVL+1)-st level. The number of * nodes created on this level is LLST * 2. * DO 10 I = 0, LLST - 1 IL = IL + 2 IR = IR + 2 NCRNT = LLST + I NDIML( IL ) = NDIML( NCRNT ) / 2 NDIMR( IL ) = NDIML( NCRNT ) - NDIML( IL ) - 1 INODE( IL ) = INODE( NCRNT ) - NDIMR( IL ) - 1 NDIML( IR ) = NDIMR( NCRNT ) / 2 NDIMR( IR ) = NDIMR( NCRNT ) - NDIML( IR ) - 1 INODE( IR ) = INODE( NCRNT ) + NDIML( IR ) + 1 10 CONTINUE LLST = LLST*2 20 CONTINUE ND = LLST*2 - 1 * RETURN * * End of DLASDT * END *> \brief \b DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASET + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, M, N * DOUBLE PRECISION ALPHA, BETA * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLASET initializes an m-by-n matrix A to BETA on the diagonal and *> ALPHA on the offdiagonals. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies the part of the matrix A to be set. *> = 'U': Upper triangular part is set; the strictly lower *> triangular part of A is not changed. *> = 'L': Lower triangular part is set; the strictly upper *> triangular part of A is not changed. *> Otherwise: All of the matrix A is set. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] ALPHA *> \verbatim *> ALPHA is DOUBLE PRECISION *> The constant to which the offdiagonal elements are to be set. *> \endverbatim *> *> \param[in] BETA *> \verbatim *> BETA is DOUBLE PRECISION *> The constant to which the diagonal elements are to be set. *> \endverbatim *> *> \param[out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On exit, the leading m-by-n submatrix of A is set as follows: *> *> if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n, *> if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n, *> otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j, *> *> and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n). *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER LDA, M, N DOUBLE PRECISION ALPHA, BETA * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * IF( LSAME( UPLO, 'U' ) ) THEN * * Set the strictly upper triangular or trapezoidal part of the * array to ALPHA. * DO 20 J = 2, N DO 10 I = 1, MIN( J-1, M ) A( I, J ) = ALPHA 10 CONTINUE 20 CONTINUE * ELSE IF( LSAME( UPLO, 'L' ) ) THEN * * Set the strictly lower triangular or trapezoidal part of the * array to ALPHA. * DO 40 J = 1, MIN( M, N ) DO 30 I = J + 1, M A( I, J ) = ALPHA 30 CONTINUE 40 CONTINUE * ELSE * * Set the leading m-by-n submatrix to ALPHA. * DO 60 J = 1, N DO 50 I = 1, M A( I, J ) = ALPHA 50 CONTINUE 60 CONTINUE END IF * * Set the first min(M,N) diagonal elements to BETA. * DO 70 I = 1, MIN( M, N ) A( I, I ) = BETA 70 CONTINUE * RETURN * * End of DLASET * END *> \brief \b DLASQ1 computes the singular values of a real square bidiagonal matrix. Used by sbdsqr. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASQ1 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASQ1( N, D, E, WORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, N * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), E( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The number of rows and columns in the matrix. N >= 0. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is 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. *> \endverbatim *> *> \param[in,out] E *> \verbatim *> E is 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. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (4*N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is 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 100*N *> iterations (in inner while loop) On exit D and E *> represent a matrix with the same singular values *> which the calling subroutine could use to finish the *> computation, or even feed back into DLASQ1 *> = 3, termination criterion of outer while loop not met *> (program created more than N unreduced blocks) *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE DLASQ1( N, D, E, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ), WORK( * ) * .. * * ===================================================================== * * .. 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 = -1 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 ) ELSE IF( INFO.EQ.2 ) THEN * * Maximum number of iterations exceeded. Move data from WORK * into D and E so the calling subroutine can try to finish * DO I = 1, N D( I ) = SQRT( WORK( 2*I-1 ) ) E( I ) = SQRT( WORK( 2*I ) ) END DO CALL DLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, D, N, IINFO ) CALL DLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, E, N, IINFO ) END IF * RETURN * * End of DLASQ1 * END *> \brief \b DLASQ2 computes all the eigenvalues of the symmetric positive definite tridiagonal matrix associated with the qd Array Z to high relative accuracy. Used by sbdsqr and sstegr. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASQ2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASQ2( N, Z, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, N * .. * .. Array Arguments .. * DOUBLE PRECISION Z( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLASQ2 computes all the eigenvalues of the symmetric positive *> definite tridiagonal matrix associated with the qd array Z to high *> relative accuracy are computed to high relative accuracy, in the *> absence of denormalization, underflow and overflow. *> *> To see the relation of Z to the tridiagonal matrix, let L be a *> unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and *> let U be an upper bidiagonal matrix with 1's above and diagonal *> Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the *> symmetric tridiagonal to which it is similar. *> *> Note : DLASQ2 defines a logical variable, IEEE, which is true *> on machines which follow ieee-754 floating-point standard in their *> handling of infinities and NaNs, and false otherwise. This variable *> is passed to DLASQ3. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The number of rows and columns in the matrix. N >= 0. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is 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 100*N *> iterations (in inner while loop). On exit Z holds *> a qd array with the same eigenvalues as the given Z. *> = 3, termination criterion of outer while loop not met *> (program created more than N unreduced blocks) *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup auxOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> 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). *> \endverbatim *> * ===================================================================== SUBROUTINE DLASQ2( N, Z, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, N * .. * .. Array Arguments .. DOUBLE PRECISION Z( * ) * .. * * ===================================================================== * * .. 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, I1, I4, IINFO, IPN4, ITER, IWHILA, IWHILB, $ K, KMIN, N0, N1, NBIG, NDIV, NFAIL, PP, SPLT, $ TTYPE DOUBLE PRECISION D, DEE, DEEMIN, DESIG, DMIN, DMIN1, DMIN2, DN, $ DN1, DN2, E, EMAX, EMIN, EPS, G, OLDEMN, QMAX, $ QMIN, S, SAFMIN, SIGMA, T, TAU, TEMP, TOL, $ TOL2, TRACE, ZMAX, TEMPE, TEMPQ * .. * .. External Subroutines .. EXTERNAL DLASQ3, DLASRT, XERBLA * .. * .. External Functions .. INTEGER ILAENV DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, ILAENV * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN, SQRT * .. * .. Executable Statements .. * * Test the input arguments. * (in case DLASQ2 is not called by DLASQ1) * INFO = 0 EPS = DLAMCH( 'Precision' ) SAFMIN = DLAMCH( 'Safe minimum' ) TOL = EPS*HUNDRD TOL2 = TOL**2 * IF( N.LT.0 ) THEN INFO = -1 CALL XERBLA( 'DLASQ2', 1 ) RETURN ELSE IF( N.EQ.0 ) THEN RETURN ELSE IF( N.EQ.1 ) THEN * * 1-by-1 case. * IF( Z( 1 ).LT.ZERO ) THEN INFO = -201 CALL XERBLA( 'DLASQ2', 2 ) END IF RETURN ELSE IF( N.EQ.2 ) THEN * * 2-by-2 case. * IF( Z( 2 ).LT.ZERO .OR. Z( 3 ).LT.ZERO ) THEN INFO = -2 CALL XERBLA( 'DLASQ2', 2 ) RETURN ELSE IF( Z( 3 ).GT.Z( 1 ) ) THEN D = Z( 3 ) Z( 3 ) = Z( 1 ) Z( 1 ) = D END IF Z( 5 ) = Z( 1 ) + Z( 2 ) + Z( 3 ) IF( Z( 2 ).GT.Z( 3 )*TOL2 ) THEN T = HALF*( ( Z( 1 )-Z( 3 ) )+Z( 2 ) ) S = Z( 3 )*( Z( 2 ) / T ) IF( S.LE.T ) THEN S = Z( 3 )*( Z( 2 ) / ( T*( ONE+SQRT( ONE+S / T ) ) ) ) ELSE S = Z( 3 )*( Z( 2 ) / ( T+SQRT( T )*SQRT( T+S ) ) ) END IF T = Z( 1 ) + ( S+Z( 2 ) ) Z( 3 ) = Z( 3 )*( Z( 1 ) / T ) Z( 1 ) = T END IF Z( 2 ) = Z( 3 ) Z( 6 ) = Z( 2 ) + Z( 1 ) RETURN END IF * * Check for negative data and compute sums of q's and e's. * Z( 2*N ) = ZERO EMIN = Z( 2 ) QMAX = ZERO ZMAX = ZERO D = ZERO E = ZERO * DO 10 K = 1, 2*( N-1 ), 2 IF( Z( K ).LT.ZERO ) THEN INFO = -( 200+K ) CALL XERBLA( 'DLASQ2', 2 ) RETURN ELSE IF( Z( K+1 ).LT.ZERO ) THEN INFO = -( 200+K+1 ) CALL XERBLA( 'DLASQ2', 2 ) RETURN END IF D = D + Z( K ) E = E + Z( K+1 ) QMAX = MAX( QMAX, Z( K ) ) EMIN = MIN( EMIN, Z( K+1 ) ) ZMAX = MAX( QMAX, ZMAX, Z( K+1 ) ) 10 CONTINUE IF( Z( 2*N-1 ).LT.ZERO ) THEN INFO = -( 200+2*N-1 ) CALL XERBLA( 'DLASQ2', 2 ) RETURN END IF D = D + Z( 2*N-1 ) QMAX = MAX( QMAX, Z( 2*N-1 ) ) ZMAX = MAX( QMAX, ZMAX ) * * Check for diagonality. * IF( E.EQ.ZERO ) THEN DO 20 K = 2, N Z( K ) = Z( 2*K-1 ) 20 CONTINUE CALL DLASRT( 'D', N, Z, IINFO ) Z( 2*N-1 ) = D RETURN END IF * TRACE = D + E * * Check for zero data. * IF( TRACE.EQ.ZERO ) THEN Z( 2*N-1 ) = ZERO RETURN END IF * * Check whether the machine is IEEE conformable. * IEEE = ILAENV( 10, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 .AND. $ ILAENV( 11, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 * * Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...). * DO 30 K = 2*N, 2, -2 Z( 2*K ) = ZERO Z( 2*K-1 ) = Z( K ) Z( 2*K-2 ) = ZERO Z( 2*K-3 ) = Z( K-1 ) 30 CONTINUE * I0 = 1 N0 = N * * Reverse the qd-array, if warranted. * IF( CBIAS*Z( 4*I0-3 ).LT.Z( 4*N0-3 ) ) THEN IPN4 = 4*( I0+N0 ) DO 40 I4 = 4*I0, 2*( I0+N0-1 ), 4 TEMP = Z( I4-3 ) Z( I4-3 ) = Z( IPN4-I4-3 ) Z( IPN4-I4-3 ) = TEMP TEMP = Z( I4-1 ) Z( I4-1 ) = Z( IPN4-I4-5 ) Z( IPN4-I4-5 ) = TEMP 40 CONTINUE END IF * * Initial split checking via dqd and Li's test. * PP = 0 * DO 80 K = 1, 2 * D = Z( 4*N0+PP-3 ) DO 50 I4 = 4*( N0-1 ) + PP, 4*I0 + PP, -4 IF( Z( I4-1 ).LE.TOL2*D ) THEN Z( I4-1 ) = -ZERO D = Z( I4-3 ) ELSE D = Z( I4-3 )*( D / ( D+Z( I4-1 ) ) ) END IF 50 CONTINUE * * dqd maps Z to ZZ plus Li's test. * EMIN = Z( 4*I0+PP+1 ) D = Z( 4*I0+PP-3 ) DO 60 I4 = 4*I0 + PP, 4*( N0-1 ) + PP, 4 Z( I4-2*PP-2 ) = D + Z( I4-1 ) IF( Z( I4-1 ).LE.TOL2*D ) THEN Z( I4-1 ) = -ZERO Z( I4-2*PP-2 ) = D Z( I4-2*PP ) = ZERO D = Z( I4+1 ) ELSE IF( SAFMIN*Z( I4+1 ).LT.Z( I4-2*PP-2 ) .AND. $ SAFMIN*Z( I4-2*PP-2 ).LT.Z( I4+1 ) ) THEN TEMP = Z( I4+1 ) / Z( I4-2*PP-2 ) Z( I4-2*PP ) = Z( I4-1 )*TEMP D = D*TEMP ELSE Z( I4-2*PP ) = Z( I4+1 )*( Z( I4-1 ) / Z( I4-2*PP-2 ) ) D = Z( I4+1 )*( D / Z( I4-2*PP-2 ) ) END IF EMIN = MIN( EMIN, Z( I4-2*PP ) ) 60 CONTINUE Z( 4*N0-PP-2 ) = D * * Now find qmax. * QMAX = Z( 4*I0-PP-2 ) DO 70 I4 = 4*I0 - PP + 2, 4*N0 - PP - 2, 4 QMAX = MAX( QMAX, Z( I4 ) ) 70 CONTINUE * * Prepare for the next iteration on K. * PP = 1 - PP 80 CONTINUE * * Initialise variables to pass to DLASQ3. * TTYPE = 0 DMIN1 = ZERO DMIN2 = ZERO DN = ZERO DN1 = ZERO DN2 = ZERO G = ZERO TAU = ZERO * ITER = 2 NFAIL = 0 NDIV = 2*( N0-I0 ) * DO 160 IWHILA = 1, N + 1 IF( N0.LT.1 ) $ GO TO 170 * * While array unfinished do * * E(N0) holds the value of SIGMA when submatrix in I0:N0 * splits from the rest of the array, but is negated. * DESIG = ZERO IF( N0.EQ.N ) THEN SIGMA = ZERO ELSE SIGMA = -Z( 4*N0-1 ) END IF IF( SIGMA.LT.ZERO ) THEN INFO = 1 RETURN END IF * * Find last unreduced submatrix's top index I0, find QMAX and * EMIN. Find Gershgorin-type bound if Q's much greater than E's. * EMAX = ZERO IF( N0.GT.I0 ) THEN EMIN = ABS( Z( 4*N0-5 ) ) ELSE EMIN = ZERO END IF QMIN = Z( 4*N0-3 ) QMAX = QMIN DO 90 I4 = 4*N0, 8, -4 IF( Z( I4-5 ).LE.ZERO ) $ GO TO 100 IF( QMIN.GE.FOUR*EMAX ) THEN QMIN = MIN( QMIN, Z( I4-3 ) ) EMAX = MAX( EMAX, Z( I4-5 ) ) END IF QMAX = MAX( QMAX, Z( I4-7 )+Z( I4-5 ) ) EMIN = MIN( EMIN, Z( I4-5 ) ) 90 CONTINUE I4 = 4 * 100 CONTINUE I0 = I4 / 4 PP = 0 * IF( N0-I0.GT.1 ) THEN DEE = Z( 4*I0-3 ) DEEMIN = DEE KMIN = I0 DO 110 I4 = 4*I0+1, 4*N0-3, 4 DEE = Z( I4 )*( DEE /( DEE+Z( I4-2 ) ) ) IF( DEE.LE.DEEMIN ) THEN DEEMIN = DEE KMIN = ( I4+3 )/4 END IF 110 CONTINUE IF( (KMIN-I0)*2.LT.N0-KMIN .AND. $ DEEMIN.LE.HALF*Z(4*N0-3) ) THEN IPN4 = 4*( I0+N0 ) PP = 2 DO 120 I4 = 4*I0, 2*( I0+N0-1 ), 4 TEMP = Z( I4-3 ) Z( I4-3 ) = Z( IPN4-I4-3 ) Z( IPN4-I4-3 ) = TEMP TEMP = Z( I4-2 ) Z( I4-2 ) = Z( IPN4-I4-2 ) Z( IPN4-I4-2 ) = TEMP TEMP = Z( I4-1 ) Z( I4-1 ) = Z( IPN4-I4-5 ) Z( IPN4-I4-5 ) = TEMP TEMP = Z( I4 ) Z( I4 ) = Z( IPN4-I4-4 ) Z( IPN4-I4-4 ) = TEMP 120 CONTINUE END IF END IF * * Put -(initial shift) into DMIN. * DMIN = -MAX( ZERO, QMIN-TWO*SQRT( QMIN )*SQRT( EMAX ) ) * * Now I0:N0 is unreduced. * PP = 0 for ping, PP = 1 for pong. * PP = 2 indicates that flipping was applied to the Z array and * and that the tests for deflation upon entry in DLASQ3 * should not be performed. * NBIG = 100*( N0-I0+1 ) DO 140 IWHILB = 1, NBIG IF( I0.GT.N0 ) $ GO TO 150 * * While submatrix unfinished take a good dqds step. * CALL DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, $ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, $ DN2, G, TAU ) * PP = 1 - PP * * When EMIN is very small check for splits. * IF( PP.EQ.0 .AND. N0-I0.GE.3 ) THEN IF( Z( 4*N0 ).LE.TOL2*QMAX .OR. $ Z( 4*N0-1 ).LE.TOL2*SIGMA ) THEN SPLT = I0 - 1 QMAX = Z( 4*I0-3 ) EMIN = Z( 4*I0-1 ) OLDEMN = Z( 4*I0 ) DO 130 I4 = 4*I0, 4*( N0-3 ), 4 IF( Z( I4 ).LE.TOL2*Z( I4-3 ) .OR. $ Z( I4-1 ).LE.TOL2*SIGMA ) THEN Z( I4-1 ) = -SIGMA SPLT = I4 / 4 QMAX = ZERO EMIN = Z( I4+3 ) OLDEMN = Z( I4+4 ) ELSE QMAX = MAX( QMAX, Z( I4+1 ) ) EMIN = MIN( EMIN, Z( I4-1 ) ) OLDEMN = MIN( OLDEMN, Z( I4 ) ) END IF 130 CONTINUE Z( 4*N0-1 ) = EMIN Z( 4*N0 ) = OLDEMN I0 = SPLT + 1 END IF END IF * 140 CONTINUE * INFO = 2 * * Maximum number of iterations exceeded, restore the shift * SIGMA and place the new d's and e's in a qd array. * This might need to be done for several blocks * I1 = I0 N1 = N0 145 CONTINUE TEMPQ = Z( 4*I0-3 ) Z( 4*I0-3 ) = Z( 4*I0-3 ) + SIGMA DO K = I0+1, N0 TEMPE = Z( 4*K-5 ) Z( 4*K-5 ) = Z( 4*K-5 ) * (TEMPQ / Z( 4*K-7 )) TEMPQ = Z( 4*K-3 ) Z( 4*K-3 ) = Z( 4*K-3 ) + SIGMA + TEMPE - Z( 4*K-5 ) END DO * * Prepare to do this on the previous block if there is one * IF( I1.GT.1 ) THEN N1 = I1-1 DO WHILE( ( I1.GE.2 ) .AND. ( Z(4*I1-5).GE.ZERO ) ) I1 = I1 - 1 END DO SIGMA = -Z(4*N1-1) GO TO 145 END IF DO K = 1, N Z( 2*K-1 ) = Z( 4*K-3 ) * * Only the block 1..N0 is unfinished. The rest of the e's * must be essentially zero, although sometimes other data * has been stored in them. * IF( K.LT.N0 ) THEN Z( 2*K ) = Z( 4*K-1 ) ELSE Z( 2*K ) = 0 END IF END DO RETURN * * end IWHILB * 150 CONTINUE * 160 CONTINUE * INFO = 3 RETURN * * end IWHILA * 170 CONTINUE * * Move q's to the front. * DO 180 K = 2, N Z( K ) = Z( 4*K-3 ) 180 CONTINUE * * Sort and compute sum of eigenvalues. * CALL DLASRT( 'D', N, Z, IINFO ) * E = ZERO DO 190 K = N, 1, -1 E = E + Z( K ) 190 CONTINUE * * Store trace, sum(eigenvalues) and information on performance. * Z( 2*N+1 ) = TRACE Z( 2*N+2 ) = E Z( 2*N+3 ) = DBLE( ITER ) Z( 2*N+4 ) = DBLE( NDIV ) / DBLE( N**2 ) Z( 2*N+5 ) = HUNDRD*NFAIL / DBLE( ITER ) RETURN * * End of DLASQ2 * END *> \brief \b DLASQ3 checks for deflation, computes a shift and calls dqds. Used by sbdsqr. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASQ3 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, * ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, * DN2, G, TAU ) * * .. Scalar Arguments .. * LOGICAL IEEE * INTEGER I0, ITER, N0, NDIV, NFAIL, PP * DOUBLE PRECISION DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, * $ QMAX, SIGMA, TAU * .. * .. Array Arguments .. * DOUBLE PRECISION Z( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLASQ3 checks for deflation, computes a shift (TAU) and calls dqds. *> In case of failure it changes shifts, and tries again until output *> is positive. *> \endverbatim * * Arguments: * ========== * *> \param[in] I0 *> \verbatim *> I0 is INTEGER *> First index. *> \endverbatim *> *> \param[in,out] N0 *> \verbatim *> N0 is INTEGER *> Last index. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension ( 4*N0 ) *> Z holds the qd array. *> \endverbatim *> *> \param[in,out] PP *> \verbatim *> PP is INTEGER *> PP=0 for ping, PP=1 for pong. *> PP=2 indicates that flipping was applied to the Z array *> and that the initial tests for deflation should not be *> performed. *> \endverbatim *> *> \param[out] DMIN *> \verbatim *> DMIN is DOUBLE PRECISION *> Minimum value of d. *> \endverbatim *> *> \param[out] SIGMA *> \verbatim *> SIGMA is DOUBLE PRECISION *> Sum of shifts used in current segment. *> \endverbatim *> *> \param[in,out] DESIG *> \verbatim *> DESIG is DOUBLE PRECISION *> Lower order part of SIGMA *> \endverbatim *> *> \param[in] QMAX *> \verbatim *> QMAX is DOUBLE PRECISION *> Maximum value of q. *> \endverbatim *> *> \param[in,out] NFAIL *> \verbatim *> NFAIL is INTEGER *> Increment NFAIL by 1 each time the shift was too big. *> \endverbatim *> *> \param[in,out] ITER *> \verbatim *> ITER is INTEGER *> Increment ITER by 1 for each iteration. *> \endverbatim *> *> \param[in,out] NDIV *> \verbatim *> NDIV is INTEGER *> Increment NDIV by 1 for each division. *> \endverbatim *> *> \param[in] IEEE *> \verbatim *> IEEE is LOGICAL *> Flag for IEEE or non IEEE arithmetic (passed to DLASQ5). *> \endverbatim *> *> \param[in,out] TTYPE *> \verbatim *> TTYPE is INTEGER *> Shift type. *> \endverbatim *> *> \param[in,out] DMIN1 *> \verbatim *> DMIN1 is DOUBLE PRECISION *> \endverbatim *> *> \param[in,out] DMIN2 *> \verbatim *> DMIN2 is DOUBLE PRECISION *> \endverbatim *> *> \param[in,out] DN *> \verbatim *> DN is DOUBLE PRECISION *> \endverbatim *> *> \param[in,out] DN1 *> \verbatim *> DN1 is DOUBLE PRECISION *> \endverbatim *> *> \param[in,out] DN2 *> \verbatim *> DN2 is DOUBLE PRECISION *> \endverbatim *> *> \param[in,out] G *> \verbatim *> G is DOUBLE PRECISION *> \endverbatim *> *> \param[in,out] TAU *> \verbatim *> TAU is DOUBLE PRECISION *> *> These are passed as arguments in order to save their values *> between calls to DLASQ3. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, $ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, $ DN2, G, TAU ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. LOGICAL IEEE INTEGER I0, ITER, N0, NDIV, NFAIL, PP DOUBLE PRECISION DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, $ QMAX, SIGMA, TAU * .. * .. Array Arguments .. DOUBLE PRECISION Z( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION CBIAS PARAMETER ( CBIAS = 1.50D0 ) DOUBLE PRECISION ZERO, QURTR, HALF, ONE, TWO, HUNDRD PARAMETER ( ZERO = 0.0D0, QURTR = 0.250D0, HALF = 0.5D0, $ ONE = 1.0D0, TWO = 2.0D0, HUNDRD = 100.0D0 ) * .. * .. Local Scalars .. INTEGER IPN4, J4, N0IN, NN, TTYPE DOUBLE PRECISION EPS, S, T, TEMP, TOL, TOL2 * .. * .. External Subroutines .. EXTERNAL DLASQ4, DLASQ5, DLASQ6 * .. * .. External Function .. DOUBLE PRECISION DLAMCH LOGICAL DISNAN EXTERNAL DISNAN, DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Executable Statements .. * N0IN = N0 EPS = DLAMCH( 'Precision' ) TOL = EPS*HUNDRD TOL2 = TOL**2 * * Check for deflation. * 10 CONTINUE * IF( N0.LT.I0 ) $ RETURN IF( N0.EQ.I0 ) $ GO TO 20 NN = 4*N0 + PP IF( N0.EQ.( I0+1 ) ) $ GO TO 40 * * Check whether E(N0-1) is negligible, 1 eigenvalue. * IF( Z( NN-5 ).GT.TOL2*( SIGMA+Z( NN-3 ) ) .AND. $ Z( NN-2*PP-4 ).GT.TOL2*Z( NN-7 ) ) $ GO TO 30 * 20 CONTINUE * Z( 4*N0-3 ) = Z( 4*N0+PP-3 ) + SIGMA N0 = N0 - 1 GO TO 10 * * Check whether E(N0-2) is negligible, 2 eigenvalues. * 30 CONTINUE * IF( Z( NN-9 ).GT.TOL2*SIGMA .AND. $ Z( NN-2*PP-8 ).GT.TOL2*Z( NN-11 ) ) $ GO TO 50 * 40 CONTINUE * IF( Z( NN-3 ).GT.Z( NN-7 ) ) THEN S = Z( NN-3 ) Z( NN-3 ) = Z( NN-7 ) Z( NN-7 ) = S END IF T = HALF*( ( Z( NN-7 )-Z( NN-3 ) )+Z( NN-5 ) ) IF( Z( NN-5 ).GT.Z( NN-3 )*TOL2.AND.T.NE.ZERO ) THEN S = Z( NN-3 )*( Z( NN-5 ) / T ) IF( S.LE.T ) THEN S = Z( NN-3 )*( Z( NN-5 ) / $ ( T*( ONE+SQRT( ONE+S / T ) ) ) ) ELSE S = Z( NN-3 )*( Z( NN-5 ) / ( T+SQRT( T )*SQRT( T+S ) ) ) END IF T = Z( NN-7 ) + ( S+Z( NN-5 ) ) Z( NN-3 ) = Z( NN-3 )*( Z( NN-7 ) / T ) Z( NN-7 ) = T END IF Z( 4*N0-7 ) = Z( NN-7 ) + SIGMA Z( 4*N0-3 ) = Z( NN-3 ) + SIGMA N0 = N0 - 2 GO TO 10 * 50 CONTINUE IF( PP.EQ.2 ) $ PP = 0 * * Reverse the qd-array, if warranted. * IF( DMIN.LE.ZERO .OR. N0.LT.N0IN ) THEN IF( CBIAS*Z( 4*I0+PP-3 ).LT.Z( 4*N0+PP-3 ) ) THEN IPN4 = 4*( I0+N0 ) DO 60 J4 = 4*I0, 2*( I0+N0-1 ), 4 TEMP = Z( J4-3 ) Z( J4-3 ) = Z( IPN4-J4-3 ) Z( IPN4-J4-3 ) = TEMP TEMP = Z( J4-2 ) Z( J4-2 ) = Z( IPN4-J4-2 ) Z( IPN4-J4-2 ) = TEMP TEMP = Z( J4-1 ) Z( J4-1 ) = Z( IPN4-J4-5 ) Z( IPN4-J4-5 ) = TEMP TEMP = Z( J4 ) Z( J4 ) = Z( IPN4-J4-4 ) Z( IPN4-J4-4 ) = TEMP 60 CONTINUE IF( N0-I0.LE.4 ) THEN Z( 4*N0+PP-1 ) = Z( 4*I0+PP-1 ) Z( 4*N0-PP ) = Z( 4*I0-PP ) END IF DMIN2 = MIN( DMIN2, Z( 4*N0+PP-1 ) ) Z( 4*N0+PP-1 ) = MIN( Z( 4*N0+PP-1 ), Z( 4*I0+PP-1 ), $ Z( 4*I0+PP+3 ) ) Z( 4*N0-PP ) = MIN( Z( 4*N0-PP ), Z( 4*I0-PP ), $ Z( 4*I0-PP+4 ) ) QMAX = MAX( QMAX, Z( 4*I0+PP-3 ), Z( 4*I0+PP+1 ) ) DMIN = -ZERO END IF END IF * * Choose a shift. * CALL DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1, $ DN2, TAU, TTYPE, G ) * * Call dqds until DMIN > 0. * 70 CONTINUE * CALL DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, DN, $ DN1, DN2, IEEE, EPS ) * NDIV = NDIV + ( N0-I0+2 ) ITER = ITER + 1 * * Check status. * IF( DMIN.GE.ZERO .AND. DMIN1.GE.ZERO ) THEN * * Success. * GO TO 90 * ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND. $ Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND. $ ABS( DN ).LT.TOL*SIGMA ) THEN * * Convergence hidden by negative DN. * Z( 4*( N0-1 )-PP+2 ) = ZERO DMIN = ZERO GO TO 90 ELSE IF( DMIN.LT.ZERO ) THEN * * TAU too big. Select new TAU and try again. * NFAIL = NFAIL + 1 IF( TTYPE.LT.-22 ) THEN * * Failed twice. Play it safe. * TAU = ZERO ELSE IF( DMIN1.GT.ZERO ) THEN * * Late failure. Gives excellent shift. * TAU = ( TAU+DMIN )*( ONE-TWO*EPS ) TTYPE = TTYPE - 11 ELSE * * Early failure. Divide by 4. * TAU = QURTR*TAU TTYPE = TTYPE - 12 END IF GO TO 70 ELSE IF( DISNAN( DMIN ) ) THEN * * NaN. * IF( TAU.EQ.ZERO ) THEN GO TO 80 ELSE TAU = ZERO GO TO 70 END IF ELSE * * Possible underflow. Play it safe. * GO TO 80 END IF * * Risk of underflow. * 80 CONTINUE CALL DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DN1, DN2 ) NDIV = NDIV + ( N0-I0+2 ) ITER = ITER + 1 TAU = ZERO * 90 CONTINUE IF( TAU.LT.SIGMA ) THEN DESIG = DESIG + TAU T = SIGMA + DESIG DESIG = DESIG - ( T-SIGMA ) ELSE T = SIGMA + TAU DESIG = SIGMA - ( T-TAU ) + DESIG END IF SIGMA = T * RETURN * * End of DLASQ3 * END *> \brief \b DLASQ4 computes an approximation to the smallest eigenvalue using values of d from the previous transform. Used by sbdsqr. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASQ4 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, * DN1, DN2, TAU, TTYPE, G ) * * .. Scalar Arguments .. * INTEGER I0, N0, N0IN, PP, TTYPE * DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU * .. * .. Array Arguments .. * DOUBLE PRECISION Z( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLASQ4 computes an approximation TAU to the smallest eigenvalue *> using values of d from the previous transform. *> \endverbatim * * Arguments: * ========== * *> \param[in] I0 *> \verbatim *> I0 is INTEGER *> First index. *> \endverbatim *> *> \param[in] N0 *> \verbatim *> N0 is INTEGER *> Last index. *> \endverbatim *> *> \param[in] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension ( 4*N0 ) *> Z holds the qd array. *> \endverbatim *> *> \param[in] PP *> \verbatim *> PP is INTEGER *> PP=0 for ping, PP=1 for pong. *> \endverbatim *> *> \param[in] N0IN *> \verbatim *> N0IN is INTEGER *> The value of N0 at start of EIGTEST. *> \endverbatim *> *> \param[in] DMIN *> \verbatim *> DMIN is DOUBLE PRECISION *> Minimum value of d. *> \endverbatim *> *> \param[in] DMIN1 *> \verbatim *> DMIN1 is DOUBLE PRECISION *> Minimum value of d, excluding D( N0 ). *> \endverbatim *> *> \param[in] DMIN2 *> \verbatim *> DMIN2 is DOUBLE PRECISION *> Minimum value of d, excluding D( N0 ) and D( N0-1 ). *> \endverbatim *> *> \param[in] DN *> \verbatim *> DN is DOUBLE PRECISION *> d(N) *> \endverbatim *> *> \param[in] DN1 *> \verbatim *> DN1 is DOUBLE PRECISION *> d(N-1) *> \endverbatim *> *> \param[in] DN2 *> \verbatim *> DN2 is DOUBLE PRECISION *> d(N-2) *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION *> This is the shift. *> \endverbatim *> *> \param[out] TTYPE *> \verbatim *> TTYPE is INTEGER *> Shift type. *> \endverbatim *> *> \param[in,out] G *> \verbatim *> G is DOUBLE PRECISION *> G is passed as an argument in order to save its value between *> calls to DLASQ4. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup auxOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> CNST1 = 9/16 *> \endverbatim *> * ===================================================================== SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, $ DN1, DN2, TAU, TTYPE, G ) * * -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. INTEGER I0, N0, N0IN, PP, TTYPE DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU * .. * .. Array Arguments .. DOUBLE PRECISION Z( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION CNST1, CNST2, CNST3 PARAMETER ( CNST1 = 0.5630D0, CNST2 = 1.010D0, $ CNST3 = 1.050D0 ) DOUBLE PRECISION QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD PARAMETER ( QURTR = 0.250D0, THIRD = 0.3330D0, $ HALF = 0.50D0, ZERO = 0.0D0, ONE = 1.0D0, $ TWO = 2.0D0, HUNDRD = 100.0D0 ) * .. * .. Local Scalars .. INTEGER I4, NN, NP DOUBLE PRECISION A2, B1, B2, GAM, GAP1, GAP2, S * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT * .. * .. Executable Statements .. * * A negative DMIN forces the shift to take that absolute value * TTYPE records the type of shift. * IF( DMIN.LE.ZERO ) THEN TAU = -DMIN TTYPE = -1 RETURN END IF * NN = 4*N0 + PP IF( N0IN.EQ.N0 ) THEN * * No eigenvalues deflated. * IF( DMIN.EQ.DN .OR. DMIN.EQ.DN1 ) THEN * B1 = SQRT( Z( NN-3 ) )*SQRT( Z( NN-5 ) ) B2 = SQRT( Z( NN-7 ) )*SQRT( Z( NN-9 ) ) A2 = Z( NN-7 ) + Z( NN-5 ) * * Cases 2 and 3. * IF( DMIN.EQ.DN .AND. DMIN1.EQ.DN1 ) THEN GAP2 = DMIN2 - A2 - DMIN2*QURTR IF( GAP2.GT.ZERO .AND. GAP2.GT.B2 ) THEN GAP1 = A2 - DN - ( B2 / GAP2 )*B2 ELSE GAP1 = A2 - DN - ( B1+B2 ) END IF IF( GAP1.GT.ZERO .AND. GAP1.GT.B1 ) THEN S = MAX( DN-( B1 / GAP1 )*B1, HALF*DMIN ) TTYPE = -2 ELSE S = ZERO IF( DN.GT.B1 ) $ S = DN - B1 IF( A2.GT.( B1+B2 ) ) $ S = MIN( S, A2-( B1+B2 ) ) S = MAX( S, THIRD*DMIN ) TTYPE = -3 END IF ELSE * * Case 4. * TTYPE = -4 S = QURTR*DMIN IF( DMIN.EQ.DN ) THEN GAM = DN A2 = ZERO IF( Z( NN-5 ) .GT. Z( NN-7 ) ) $ RETURN B2 = Z( NN-5 ) / Z( NN-7 ) NP = NN - 9 ELSE NP = NN - 2*PP GAM = DN1 IF( Z( NP-4 ) .GT. Z( NP-2 ) ) $ RETURN A2 = Z( NP-4 ) / Z( NP-2 ) IF( Z( NN-9 ) .GT. Z( NN-11 ) ) $ RETURN B2 = Z( NN-9 ) / Z( NN-11 ) NP = NN - 13 END IF * * Approximate contribution to norm squared from I < NN-1. * A2 = A2 + B2 DO 10 I4 = NP, 4*I0 - 1 + PP, -4 IF( B2.EQ.ZERO ) $ GO TO 20 B1 = B2 IF( Z( I4 ) .GT. Z( I4-2 ) ) $ RETURN B2 = B2*( Z( I4 ) / Z( I4-2 ) ) A2 = A2 + B2 IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) $ GO TO 20 10 CONTINUE 20 CONTINUE A2 = CNST3*A2 * * Rayleigh quotient residual bound. * IF( A2.LT.CNST1 ) $ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 ) END IF ELSE IF( DMIN.EQ.DN2 ) THEN * * Case 5. * TTYPE = -5 S = QURTR*DMIN * * Compute contribution to norm squared from I > NN-2. * NP = NN - 2*PP B1 = Z( NP-2 ) B2 = Z( NP-6 ) GAM = DN2 IF( Z( NP-8 ).GT.B2 .OR. Z( NP-4 ).GT.B1 ) $ RETURN A2 = ( Z( NP-8 ) / B2 )*( ONE+Z( NP-4 ) / B1 ) * * Approximate contribution to norm squared from I < NN-2. * IF( N0-I0.GT.2 ) THEN B2 = Z( NN-13 ) / Z( NN-15 ) A2 = A2 + B2 DO 30 I4 = NN - 17, 4*I0 - 1 + PP, -4 IF( B2.EQ.ZERO ) $ GO TO 40 B1 = B2 IF( Z( I4 ) .GT. Z( I4-2 ) ) $ RETURN B2 = B2*( Z( I4 ) / Z( I4-2 ) ) A2 = A2 + B2 IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) $ GO TO 40 30 CONTINUE 40 CONTINUE A2 = CNST3*A2 END IF * IF( A2.LT.CNST1 ) $ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 ) ELSE * * Case 6, no information to guide us. * IF( TTYPE.EQ.-6 ) THEN G = G + THIRD*( ONE-G ) ELSE IF( TTYPE.EQ.-18 ) THEN G = QURTR*THIRD ELSE G = QURTR END IF S = G*DMIN TTYPE = -6 END IF * ELSE IF( N0IN.EQ.( N0+1 ) ) THEN * * One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN. * IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN * * Cases 7 and 8. * TTYPE = -7 S = THIRD*DMIN1 IF( Z( NN-5 ).GT.Z( NN-7 ) ) $ RETURN B1 = Z( NN-5 ) / Z( NN-7 ) B2 = B1 IF( B2.EQ.ZERO ) $ GO TO 60 DO 50 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4 A2 = B1 IF( Z( I4 ).GT.Z( I4-2 ) ) $ RETURN B1 = B1*( Z( I4 ) / Z( I4-2 ) ) B2 = B2 + B1 IF( HUNDRD*MAX( B1, A2 ).LT.B2 ) $ GO TO 60 50 CONTINUE 60 CONTINUE B2 = SQRT( CNST3*B2 ) A2 = DMIN1 / ( ONE+B2**2 ) GAP2 = HALF*DMIN2 - A2 IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) ) ELSE S = MAX( S, A2*( ONE-CNST2*B2 ) ) TTYPE = -8 END IF ELSE * * Case 9. * S = QURTR*DMIN1 IF( DMIN1.EQ.DN1 ) $ S = HALF*DMIN1 TTYPE = -9 END IF * ELSE IF( N0IN.EQ.( N0+2 ) ) THEN * * Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN. * * Cases 10 and 11. * IF( DMIN2.EQ.DN2 .AND. TWO*Z( NN-5 ).LT.Z( NN-7 ) ) THEN TTYPE = -10 S = THIRD*DMIN2 IF( Z( NN-5 ).GT.Z( NN-7 ) ) $ RETURN B1 = Z( NN-5 ) / Z( NN-7 ) B2 = B1 IF( B2.EQ.ZERO ) $ GO TO 80 DO 70 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4 IF( Z( I4 ).GT.Z( I4-2 ) ) $ RETURN B1 = B1*( Z( I4 ) / Z( I4-2 ) ) B2 = B2 + B1 IF( HUNDRD*B1.LT.B2 ) $ GO TO 80 70 CONTINUE 80 CONTINUE B2 = SQRT( CNST3*B2 ) A2 = DMIN2 / ( ONE+B2**2 ) GAP2 = Z( NN-7 ) + Z( NN-9 ) - $ SQRT( Z( NN-11 ) )*SQRT( Z( NN-9 ) ) - A2 IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) ) ELSE S = MAX( S, A2*( ONE-CNST2*B2 ) ) END IF ELSE S = QURTR*DMIN2 TTYPE = -11 END IF ELSE IF( N0IN.GT.( N0+2 ) ) THEN * * Case 12, more than two eigenvalues deflated. No information. * S = ZERO TTYPE = -12 END IF * TAU = S RETURN * * End of DLASQ4 * END *> \brief \b DLASQ5 computes one dqds transform in ping-pong form. Used by sbdsqr and sstegr. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASQ5 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, DN, * DNM1, DNM2, IEEE, EPS ) * * .. Scalar Arguments .. * LOGICAL IEEE * INTEGER I0, N0, PP * DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU, SIGMA, EPS * .. * .. Array Arguments .. * DOUBLE PRECISION Z( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLASQ5 computes one dqds transform in ping-pong form, one *> version for IEEE machines another for non IEEE machines. *> \endverbatim * * Arguments: * ========== * *> \param[in] I0 *> \verbatim *> I0 is INTEGER *> First index. *> \endverbatim *> *> \param[in] N0 *> \verbatim *> N0 is INTEGER *> Last index. *> \endverbatim *> *> \param[in] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension ( 4*N ) *> Z holds the qd array. EMIN is stored in Z(4*N0) to avoid *> an extra argument. *> \endverbatim *> *> \param[in] PP *> \verbatim *> PP is INTEGER *> PP=0 for ping, PP=1 for pong. *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION *> This is the shift. *> \endverbatim *> *> \param[in] SIGMA *> \verbatim *> SIGMA is DOUBLE PRECISION *> This is the accumulated shift up to this step. *> \endverbatim *> *> \param[out] DMIN *> \verbatim *> DMIN is DOUBLE PRECISION *> Minimum value of d. *> \endverbatim *> *> \param[out] DMIN1 *> \verbatim *> DMIN1 is DOUBLE PRECISION *> Minimum value of d, excluding D( N0 ). *> \endverbatim *> *> \param[out] DMIN2 *> \verbatim *> DMIN2 is DOUBLE PRECISION *> Minimum value of d, excluding D( N0 ) and D( N0-1 ). *> \endverbatim *> *> \param[out] DN *> \verbatim *> DN is DOUBLE PRECISION *> d(N0), the last value of d. *> \endverbatim *> *> \param[out] DNM1 *> \verbatim *> DNM1 is DOUBLE PRECISION *> d(N0-1). *> \endverbatim *> *> \param[out] DNM2 *> \verbatim *> DNM2 is DOUBLE PRECISION *> d(N0-2). *> \endverbatim *> *> \param[in] IEEE *> \verbatim *> IEEE is LOGICAL *> Flag for IEEE or non IEEE arithmetic. *> \endverbatim *> *> \param[in] EPS *> \verbatim *> EPS is DOUBLE PRECISION *> This is the value of epsilon used. *> \endverbatim *> * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, $ DN, DNM1, DNM2, IEEE, EPS ) * * -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. LOGICAL IEEE INTEGER I0, N0, PP DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU, $ SIGMA, EPS * .. * .. Array Arguments .. DOUBLE PRECISION Z( * ) * .. * * ===================================================================== * * .. Parameter .. DOUBLE PRECISION ZERO, HALF PARAMETER ( ZERO = 0.0D0, HALF = 0.5 ) * .. * .. Local Scalars .. INTEGER J4, J4P2 DOUBLE PRECISION D, EMIN, TEMP, DTHRESH * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * IF( ( N0-I0-1 ).LE.0 ) $ RETURN * DTHRESH = EPS*(SIGMA+TAU) IF( TAU.LT.DTHRESH*HALF ) TAU = ZERO IF( TAU.NE.ZERO ) THEN J4 = 4*I0 + PP - 3 EMIN = Z( J4+4 ) D = Z( J4 ) - TAU DMIN = D DMIN1 = -Z( J4 ) * IF( IEEE ) THEN * * Code for IEEE arithmetic. * IF( PP.EQ.0 ) THEN DO 10 J4 = 4*I0, 4*( N0-3 ), 4 Z( J4-2 ) = D + Z( J4-1 ) TEMP = Z( J4+1 ) / Z( J4-2 ) D = D*TEMP - TAU DMIN = MIN( DMIN, D ) Z( J4 ) = Z( J4-1 )*TEMP EMIN = MIN( Z( J4 ), EMIN ) 10 CONTINUE ELSE DO 20 J4 = 4*I0, 4*( N0-3 ), 4 Z( J4-3 ) = D + Z( J4 ) TEMP = Z( J4+2 ) / Z( J4-3 ) D = D*TEMP - TAU DMIN = MIN( DMIN, D ) Z( J4-1 ) = Z( J4 )*TEMP EMIN = MIN( Z( J4-1 ), EMIN ) 20 CONTINUE END IF * * Unroll last two steps. * DNM2 = D DMIN2 = DMIN J4 = 4*( N0-2 ) - PP J4P2 = J4 + 2*PP - 1 Z( J4-2 ) = DNM2 + Z( J4P2 ) Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU DMIN = MIN( DMIN, DNM1 ) * DMIN1 = DMIN J4 = J4 + 4 J4P2 = J4 + 2*PP - 1 Z( J4-2 ) = DNM1 + Z( J4P2 ) Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU DMIN = MIN( DMIN, DN ) * ELSE * * Code for non IEEE arithmetic. * IF( PP.EQ.0 ) THEN DO 30 J4 = 4*I0, 4*( N0-3 ), 4 Z( J4-2 ) = D + Z( J4-1 ) IF( D.LT.ZERO ) THEN RETURN ELSE Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) ) D = Z( J4+1 )*( D / Z( J4-2 ) ) - TAU END IF DMIN = MIN( DMIN, D ) EMIN = MIN( EMIN, Z( J4 ) ) 30 CONTINUE ELSE DO 40 J4 = 4*I0, 4*( N0-3 ), 4 Z( J4-3 ) = D + Z( J4 ) IF( D.LT.ZERO ) THEN RETURN ELSE Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) ) D = Z( J4+2 )*( D / Z( J4-3 ) ) - TAU END IF DMIN = MIN( DMIN, D ) EMIN = MIN( EMIN, Z( J4-1 ) ) 40 CONTINUE END IF * * Unroll last two steps. * DNM2 = D DMIN2 = DMIN J4 = 4*( N0-2 ) - PP J4P2 = J4 + 2*PP - 1 Z( J4-2 ) = DNM2 + Z( J4P2 ) IF( DNM2.LT.ZERO ) THEN RETURN ELSE Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU END IF DMIN = MIN( DMIN, DNM1 ) * DMIN1 = DMIN J4 = J4 + 4 J4P2 = J4 + 2*PP - 1 Z( J4-2 ) = DNM1 + Z( J4P2 ) IF( DNM1.LT.ZERO ) THEN RETURN ELSE Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU END IF DMIN = MIN( DMIN, DN ) * END IF ELSE * This is the version that sets d's to zero if they are small enough J4 = 4*I0 + PP - 3 EMIN = Z( J4+4 ) D = Z( J4 ) - TAU DMIN = D DMIN1 = -Z( J4 ) IF( IEEE ) THEN * * Code for IEEE arithmetic. * IF( PP.EQ.0 ) THEN DO 50 J4 = 4*I0, 4*( N0-3 ), 4 Z( J4-2 ) = D + Z( J4-1 ) TEMP = Z( J4+1 ) / Z( J4-2 ) D = D*TEMP - TAU IF( D.LT.DTHRESH ) D = ZERO DMIN = MIN( DMIN, D ) Z( J4 ) = Z( J4-1 )*TEMP EMIN = MIN( Z( J4 ), EMIN ) 50 CONTINUE ELSE DO 60 J4 = 4*I0, 4*( N0-3 ), 4 Z( J4-3 ) = D + Z( J4 ) TEMP = Z( J4+2 ) / Z( J4-3 ) D = D*TEMP - TAU IF( D.LT.DTHRESH ) D = ZERO DMIN = MIN( DMIN, D ) Z( J4-1 ) = Z( J4 )*TEMP EMIN = MIN( Z( J4-1 ), EMIN ) 60 CONTINUE END IF * * Unroll last two steps. * DNM2 = D DMIN2 = DMIN J4 = 4*( N0-2 ) - PP J4P2 = J4 + 2*PP - 1 Z( J4-2 ) = DNM2 + Z( J4P2 ) Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU DMIN = MIN( DMIN, DNM1 ) * DMIN1 = DMIN J4 = J4 + 4 J4P2 = J4 + 2*PP - 1 Z( J4-2 ) = DNM1 + Z( J4P2 ) Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU DMIN = MIN( DMIN, DN ) * ELSE * * Code for non IEEE arithmetic. * IF( PP.EQ.0 ) THEN DO 70 J4 = 4*I0, 4*( N0-3 ), 4 Z( J4-2 ) = D + Z( J4-1 ) IF( D.LT.ZERO ) THEN RETURN ELSE Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) ) D = Z( J4+1 )*( D / Z( J4-2 ) ) - TAU END IF IF( D.LT.DTHRESH) D = ZERO DMIN = MIN( DMIN, D ) EMIN = MIN( EMIN, Z( J4 ) ) 70 CONTINUE ELSE DO 80 J4 = 4*I0, 4*( N0-3 ), 4 Z( J4-3 ) = D + Z( J4 ) IF( D.LT.ZERO ) THEN RETURN ELSE Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) ) D = Z( J4+2 )*( D / Z( J4-3 ) ) - TAU END IF IF( D.LT.DTHRESH) D = ZERO DMIN = MIN( DMIN, D ) EMIN = MIN( EMIN, Z( J4-1 ) ) 80 CONTINUE END IF * * Unroll last two steps. * DNM2 = D DMIN2 = DMIN J4 = 4*( N0-2 ) - PP J4P2 = J4 + 2*PP - 1 Z( J4-2 ) = DNM2 + Z( J4P2 ) IF( DNM2.LT.ZERO ) THEN RETURN ELSE Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU END IF DMIN = MIN( DMIN, DNM1 ) * DMIN1 = DMIN J4 = J4 + 4 J4P2 = J4 + 2*PP - 1 Z( J4-2 ) = DNM1 + Z( J4P2 ) IF( DNM1.LT.ZERO ) THEN RETURN ELSE Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU END IF DMIN = MIN( DMIN, DN ) * END IF END IF * Z( J4+2 ) = DN Z( 4*N0-PP ) = EMIN RETURN * * End of DLASQ5 * END *> \brief \b DLASQ6 computes one dqd transform in ping-pong form. Used by sbdsqr and sstegr. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASQ6 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, * DNM1, DNM2 ) * * .. Scalar Arguments .. * INTEGER I0, N0, PP * DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2 * .. * .. Array Arguments .. * DOUBLE PRECISION Z( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLASQ6 computes one dqd (shift equal to zero) transform in *> ping-pong form, with protection against underflow and overflow. *> \endverbatim * * Arguments: * ========== * *> \param[in] I0 *> \verbatim *> I0 is INTEGER *> First index. *> \endverbatim *> *> \param[in] N0 *> \verbatim *> N0 is INTEGER *> Last index. *> \endverbatim *> *> \param[in] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension ( 4*N ) *> Z holds the qd array. EMIN is stored in Z(4*N0) to avoid *> an extra argument. *> \endverbatim *> *> \param[in] PP *> \verbatim *> PP is INTEGER *> PP=0 for ping, PP=1 for pong. *> \endverbatim *> *> \param[out] DMIN *> \verbatim *> DMIN is DOUBLE PRECISION *> Minimum value of d. *> \endverbatim *> *> \param[out] DMIN1 *> \verbatim *> DMIN1 is DOUBLE PRECISION *> Minimum value of d, excluding D( N0 ). *> \endverbatim *> *> \param[out] DMIN2 *> \verbatim *> DMIN2 is DOUBLE PRECISION *> Minimum value of d, excluding D( N0 ) and D( N0-1 ). *> \endverbatim *> *> \param[out] DN *> \verbatim *> DN is DOUBLE PRECISION *> d(N0), the last value of d. *> \endverbatim *> *> \param[out] DNM1 *> \verbatim *> DNM1 is DOUBLE PRECISION *> d(N0-1). *> \endverbatim *> *> \param[out] DNM2 *> \verbatim *> DNM2 is DOUBLE PRECISION *> d(N0-2). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, $ DNM1, DNM2 ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER I0, N0, PP DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2 * .. * .. Array Arguments .. DOUBLE PRECISION Z( * ) * .. * * ===================================================================== * * .. Parameter .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) * .. * .. Local Scalars .. INTEGER J4, J4P2 DOUBLE PRECISION D, EMIN, SAFMIN, TEMP * .. * .. External Function .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * IF( ( N0-I0-1 ).LE.0 ) $ RETURN * SAFMIN = DLAMCH( 'Safe minimum' ) J4 = 4*I0 + PP - 3 EMIN = Z( J4+4 ) D = Z( J4 ) DMIN = D * IF( PP.EQ.0 ) THEN DO 10 J4 = 4*I0, 4*( N0-3 ), 4 Z( J4-2 ) = D + Z( J4-1 ) IF( Z( J4-2 ).EQ.ZERO ) THEN Z( J4 ) = ZERO D = Z( J4+1 ) DMIN = D EMIN = ZERO ELSE IF( SAFMIN*Z( J4+1 ).LT.Z( J4-2 ) .AND. $ SAFMIN*Z( J4-2 ).LT.Z( J4+1 ) ) THEN TEMP = Z( J4+1 ) / Z( J4-2 ) Z( J4 ) = Z( J4-1 )*TEMP D = D*TEMP ELSE Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) ) D = Z( J4+1 )*( D / Z( J4-2 ) ) END IF DMIN = MIN( DMIN, D ) EMIN = MIN( EMIN, Z( J4 ) ) 10 CONTINUE ELSE DO 20 J4 = 4*I0, 4*( N0-3 ), 4 Z( J4-3 ) = D + Z( J4 ) IF( Z( J4-3 ).EQ.ZERO ) THEN Z( J4-1 ) = ZERO D = Z( J4+2 ) DMIN = D EMIN = ZERO ELSE IF( SAFMIN*Z( J4+2 ).LT.Z( J4-3 ) .AND. $ SAFMIN*Z( J4-3 ).LT.Z( J4+2 ) ) THEN TEMP = Z( J4+2 ) / Z( J4-3 ) Z( J4-1 ) = Z( J4 )*TEMP D = D*TEMP ELSE Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) ) D = Z( J4+2 )*( D / Z( J4-3 ) ) END IF DMIN = MIN( DMIN, D ) EMIN = MIN( EMIN, Z( J4-1 ) ) 20 CONTINUE END IF * * Unroll last two steps. * DNM2 = D DMIN2 = DMIN J4 = 4*( N0-2 ) - PP J4P2 = J4 + 2*PP - 1 Z( J4-2 ) = DNM2 + Z( J4P2 ) IF( Z( J4-2 ).EQ.ZERO ) THEN Z( J4 ) = ZERO DNM1 = Z( J4P2+2 ) DMIN = DNM1 EMIN = ZERO ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND. $ SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN TEMP = Z( J4P2+2 ) / Z( J4-2 ) Z( J4 ) = Z( J4P2 )*TEMP DNM1 = DNM2*TEMP ELSE Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) END IF DMIN = MIN( DMIN, DNM1 ) * DMIN1 = DMIN J4 = J4 + 4 J4P2 = J4 + 2*PP - 1 Z( J4-2 ) = DNM1 + Z( J4P2 ) IF( Z( J4-2 ).EQ.ZERO ) THEN Z( J4 ) = ZERO DN = Z( J4P2+2 ) DMIN = DN EMIN = ZERO ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND. $ SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN TEMP = Z( J4P2+2 ) / Z( J4-2 ) Z( J4 ) = Z( J4P2 )*TEMP DN = DNM1*TEMP ELSE Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) END IF DMIN = MIN( DMIN, DN ) * Z( J4+2 ) = DN Z( 4*N0-PP ) = EMIN RETURN * * End of DLASQ6 * END *> \brief \b DLASR applies a sequence of plane rotations to a general rectangular matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * * .. Scalar Arguments .. * CHARACTER DIRECT, PIVOT, SIDE * INTEGER LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( * ), S( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLASR applies a sequence of plane rotations to a real matrix A, *> from either the left or the right. *> *> When SIDE = 'L', the transformation takes the form *> *> A := P*A *> *> and when SIDE = 'R', the transformation takes the form *> *> A := A*P**T *> *> where P is an orthogonal matrix consisting of a sequence of z plane *> rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R', *> and P**T is the transpose of P. *> *> When DIRECT = 'F' (Forward sequence), then *> *> P = P(z-1) * ... * P(2) * P(1) *> *> and when DIRECT = 'B' (Backward sequence), then *> *> P = P(1) * P(2) * ... * P(z-1) *> *> where P(k) is a plane rotation matrix defined by the 2-by-2 rotation *> *> R(k) = ( c(k) s(k) ) *> = ( -s(k) c(k) ). *> *> When PIVOT = 'V' (Variable pivot), the rotation is performed *> for the plane (k,k+1), i.e., P(k) has the form *> *> P(k) = ( 1 ) *> ( ... ) *> ( 1 ) *> ( c(k) s(k) ) *> ( -s(k) c(k) ) *> ( 1 ) *> ( ... ) *> ( 1 ) *> *> where R(k) appears as a rank-2 modification to the identity matrix in *> rows and columns k and k+1. *> *> When PIVOT = 'T' (Top pivot), the rotation is performed for the *> plane (1,k+1), so P(k) has the form *> *> P(k) = ( c(k) s(k) ) *> ( 1 ) *> ( ... ) *> ( 1 ) *> ( -s(k) c(k) ) *> ( 1 ) *> ( ... ) *> ( 1 ) *> *> where R(k) appears in rows and columns 1 and k+1. *> *> Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is *> performed for the plane (k,z), giving P(k) the form *> *> P(k) = ( 1 ) *> ( ... ) *> ( 1 ) *> ( c(k) s(k) ) *> ( 1 ) *> ( ... ) *> ( 1 ) *> ( -s(k) c(k) ) *> *> where R(k) appears in rows and columns k and z. The rotations are *> performed without ever forming P(k) explicitly. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> Specifies whether the plane rotation matrix P is applied to *> A on the left or the right. *> = 'L': Left, compute A := P*A *> = 'R': Right, compute A:= A*P**T *> \endverbatim *> *> \param[in] PIVOT *> \verbatim *> PIVOT is CHARACTER*1 *> Specifies the plane for which P(k) is a plane rotation *> matrix. *> = 'V': Variable pivot, the plane (k,k+1) *> = 'T': Top pivot, the plane (1,k+1) *> = 'B': Bottom pivot, the plane (k,z) *> \endverbatim *> *> \param[in] DIRECT *> \verbatim *> DIRECT is CHARACTER*1 *> Specifies whether P is a forward or backward sequence of *> plane rotations. *> = 'F': Forward, P = P(z-1)*...*P(2)*P(1) *> = 'B': Backward, P = P(1)*P(2)*...*P(z-1) *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. If m <= 1, an immediate *> return is effected. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. If n <= 1, an *> immediate return is effected. *> \endverbatim *> *> \param[in] C *> \verbatim *> C is DOUBLE PRECISION array, dimension *> (M-1) if SIDE = 'L' *> (N-1) if SIDE = 'R' *> The cosines c(k) of the plane rotations. *> \endverbatim *> *> \param[in] S *> \verbatim *> S is DOUBLE PRECISION array, dimension *> (M-1) if SIDE = 'L' *> (N-1) if SIDE = 'R' *> The sines s(k) of the plane rotations. The 2-by-2 plane *> rotation part of the matrix P(k), R(k), has the form *> R(k) = ( c(k) s(k) ) *> ( -s(k) c(k) ). *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The M-by-N matrix A. On exit, A is overwritten by P*A if *> SIDE = 'R' or by A*P**T if SIDE = 'L'. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER DIRECT, PIVOT, SIDE INTEGER LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( * ), S( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, INFO, J DOUBLE PRECISION CTEMP, STEMP, TEMP * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN INFO = 1 ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT, $ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN INFO = 2 ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) ) $ THEN INFO = 3 ELSE IF( M.LT.0 ) THEN INFO = 4 ELSE IF( N.LT.0 ) THEN INFO = 5 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = 9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLASR ', INFO ) RETURN END IF * * Quick return if possible * IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) $ RETURN IF( LSAME( SIDE, 'L' ) ) THEN * * Form P * A * IF( LSAME( PIVOT, 'V' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 20 J = 1, M - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 10 I = 1, N TEMP = A( J+1, I ) A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) 10 CONTINUE END IF 20 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 40 J = M - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 30 I = 1, N TEMP = A( J+1, I ) A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) 30 CONTINUE END IF 40 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'T' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 60 J = 2, M CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 50 I = 1, N TEMP = A( J, I ) A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) 50 CONTINUE END IF 60 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 80 J = M, 2, -1 CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 70 I = 1, N TEMP = A( J, I ) A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) 70 CONTINUE END IF 80 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'B' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 100 J = 1, M - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 90 I = 1, N TEMP = A( J, I ) A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP 90 CONTINUE END IF 100 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 120 J = M - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 110 I = 1, N TEMP = A( J, I ) A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP 110 CONTINUE END IF 120 CONTINUE END IF END IF ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form A * P**T * IF( LSAME( PIVOT, 'V' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 140 J = 1, N - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 130 I = 1, M TEMP = A( I, J+1 ) A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) 130 CONTINUE END IF 140 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 160 J = N - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 150 I = 1, M TEMP = A( I, J+1 ) A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) 150 CONTINUE END IF 160 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'T' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 180 J = 2, N CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 170 I = 1, M TEMP = A( I, J ) A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) 170 CONTINUE END IF 180 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 200 J = N, 2, -1 CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 190 I = 1, M TEMP = A( I, J ) A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) 190 CONTINUE END IF 200 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'B' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 220 J = 1, N - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 210 I = 1, M TEMP = A( I, J ) A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP 210 CONTINUE END IF 220 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 240 J = N - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 230 I = 1, M TEMP = A( I, J ) A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP 230 CONTINUE END IF 240 CONTINUE END IF END IF END IF * RETURN * * End of DLASR * END *> \brief \b DLASRT sorts numbers in increasing or decreasing order. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASRT + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASRT( ID, N, D, INFO ) * * .. Scalar Arguments .. * CHARACTER ID * INTEGER INFO, N * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] ID *> \verbatim *> ID is CHARACTER*1 *> = 'I': sort D in increasing order; *> = 'D': sort D in decreasing order. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The length of the array D. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE DLASRT( ID, N, D, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. CHARACTER ID INTEGER INFO, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ) * .. * * ===================================================================== * * .. 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 parameters. * 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 *> \brief \b DLASSQ updates a sum of squares represented in scaled form. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASSQ + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) * * .. Scalar Arguments .. * INTEGER INCX, N * DOUBLE PRECISION SCALE, SUMSQ * .. * .. Array Arguments .. * DOUBLE PRECISION X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLASSQ returns the values scl and smsq such that *> *> ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, *> *> where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is *> assumed to be non-negative and scl returns the value *> *> scl = max( scale, abs( x( i ) ) ). *> *> scale and sumsq must be supplied in SCALE and SUMSQ and *> scl and smsq are overwritten on SCALE and SUMSQ respectively. *> *> The routine makes only one pass through the vector x. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The number of elements to be used from the vector X. *> \endverbatim *> *> \param[in] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (N) *> The vector for which a scaled sum of squares is computed. *> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. *> \endverbatim *> *> \param[in] INCX *> \verbatim *> INCX is INTEGER *> The increment between successive values of the vector X. *> INCX > 0. *> \endverbatim *> *> \param[in,out] SCALE *> \verbatim *> SCALE is DOUBLE PRECISION *> On entry, the value scale in the equation above. *> On exit, SCALE is overwritten with scl , the scaling factor *> for the sum of squares. *> \endverbatim *> *> \param[in,out] SUMSQ *> \verbatim *> SUMSQ is DOUBLE PRECISION *> On entry, the value sumsq in the equation above. *> On exit, SUMSQ is overwritten with smsq , the basic sum of *> squares from which scl has been factored out. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INCX, N DOUBLE PRECISION SCALE, SUMSQ * .. * .. Array Arguments .. DOUBLE PRECISION X( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER IX DOUBLE PRECISION ABSXI * .. * .. External Functions .. LOGICAL DISNAN EXTERNAL DISNAN * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * IF( N.GT.0 ) THEN DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX ABSXI = ABS( X( IX ) ) IF( ABSXI.GT.ZERO.OR.DISNAN( ABSXI ) ) THEN IF( SCALE.LT.ABSXI ) THEN SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2 SCALE = ABSXI ELSE SUMSQ = SUMSQ + ( ABSXI / SCALE )**2 END IF END IF 10 CONTINUE END IF RETURN * * End of DLASSQ * END *> \brief \b DLASV2 computes the singular value decomposition of a 2-by-2 triangular matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASV2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL ) * * .. Scalar Arguments .. * DOUBLE PRECISION CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLASV2 computes the singular value decomposition of a 2-by-2 *> triangular matrix *> [ F G ] *> [ 0 H ]. *> On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the *> smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and *> right singular vectors for abs(SSMAX), giving the decomposition *> *> [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ] *> [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ]. *> \endverbatim * * Arguments: * ========== * *> \param[in] F *> \verbatim *> F is DOUBLE PRECISION *> The (1,1) element of the 2-by-2 matrix. *> \endverbatim *> *> \param[in] G *> \verbatim *> G is DOUBLE PRECISION *> The (1,2) element of the 2-by-2 matrix. *> \endverbatim *> *> \param[in] H *> \verbatim *> H is DOUBLE PRECISION *> The (2,2) element of the 2-by-2 matrix. *> \endverbatim *> *> \param[out] SSMIN *> \verbatim *> SSMIN is DOUBLE PRECISION *> abs(SSMIN) is the smaller singular value. *> \endverbatim *> *> \param[out] SSMAX *> \verbatim *> SSMAX is DOUBLE PRECISION *> abs(SSMAX) is the larger singular value. *> \endverbatim *> *> \param[out] SNL *> \verbatim *> SNL is DOUBLE PRECISION *> \endverbatim *> *> \param[out] CSL *> \verbatim *> CSL is DOUBLE PRECISION *> The vector (CSL, SNL) is a unit left singular vector for the *> singular value abs(SSMAX). *> \endverbatim *> *> \param[out] SNR *> \verbatim *> SNR is DOUBLE PRECISION *> \endverbatim *> *> \param[out] CSR *> \verbatim *> CSR is DOUBLE PRECISION *> The vector (CSR, SNR) is a unit right singular vector for the *> singular value abs(SSMAX). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> Any input parameter may be aliased with any output parameter. *> *> Barring over/underflow and assuming a guard digit in subtraction, all *> output quantities are correct to within a few units in the last *> place (ulps). *> *> In IEEE arithmetic, the code works correctly if one matrix element is *> infinite. *> *> Overflow will not occur unless the largest singular value itself *> overflows or is within a few ulps of overflow. (On machines with *> partial overflow, like the Cray, overflow may occur if the largest *> singular value is within a factor of 2 of overflow.) *> *> Underflow is harmless if underflow is gradual. Otherwise, results *> may correspond to a matrix modified by perturbations of size near *> the underflow threshold. *> \endverbatim *> * ===================================================================== SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION HALF PARAMETER ( HALF = 0.5D0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D0 ) DOUBLE PRECISION FOUR PARAMETER ( FOUR = 4.0D0 ) * .. * .. Local Scalars .. LOGICAL GASMAL, SWAP INTEGER PMAX DOUBLE PRECISION A, CLT, CRT, D, FA, FT, GA, GT, HA, HT, L, M, $ MM, R, S, SLT, SRT, T, TEMP, TSIGN, TT * .. * .. Intrinsic Functions .. INTRINSIC ABS, SIGN, SQRT * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. Executable Statements .. * FT = F FA = ABS( FT ) HT = H HA = ABS( H ) * * PMAX points to the maximum absolute element of matrix * PMAX = 1 if F largest in absolute values * PMAX = 2 if G largest in absolute values * PMAX = 3 if H largest in absolute values * PMAX = 1 SWAP = ( HA.GT.FA ) IF( SWAP ) THEN PMAX = 3 TEMP = FT FT = HT HT = TEMP TEMP = FA FA = HA HA = TEMP * * Now FA .ge. HA * END IF GT = G GA = ABS( GT ) IF( GA.EQ.ZERO ) THEN * * Diagonal matrix * SSMIN = HA SSMAX = FA CLT = ONE CRT = ONE SLT = ZERO SRT = ZERO ELSE GASMAL = .TRUE. IF( GA.GT.FA ) THEN PMAX = 2 IF( ( FA / GA ).LT.DLAMCH( 'EPS' ) ) THEN * * Case of very large GA * GASMAL = .FALSE. SSMAX = GA IF( HA.GT.ONE ) THEN SSMIN = FA / ( GA / HA ) ELSE SSMIN = ( FA / GA )*HA END IF CLT = ONE SLT = HT / GT SRT = ONE CRT = FT / GT END IF END IF IF( GASMAL ) THEN * * Normal case * D = FA - HA IF( D.EQ.FA ) THEN * * Copes with infinite F or H * L = ONE ELSE L = D / FA END IF * * Note that 0 .le. L .le. 1 * M = GT / FT * * Note that abs(M) .le. 1/macheps * T = TWO - L * * Note that T .ge. 1 * MM = M*M TT = T*T S = SQRT( TT+MM ) * * Note that 1 .le. S .le. 1 + 1/macheps * IF( L.EQ.ZERO ) THEN R = ABS( M ) ELSE R = SQRT( L*L+MM ) END IF * * Note that 0 .le. R .le. 1 + 1/macheps * A = HALF*( S+R ) * * Note that 1 .le. A .le. 1 + abs(M) * SSMIN = HA / A SSMAX = FA*A IF( MM.EQ.ZERO ) THEN * * Note that M is very tiny * IF( L.EQ.ZERO ) THEN T = SIGN( TWO, FT )*SIGN( ONE, GT ) ELSE T = GT / SIGN( D, FT ) + M / T END IF ELSE T = ( M / ( S+T )+M / ( R+L ) )*( ONE+A ) END IF L = SQRT( T*T+FOUR ) CRT = TWO / L SRT = T / L CLT = ( CRT+SRT*M ) / A SLT = ( HT / FT )*SRT / A END IF END IF IF( SWAP ) THEN CSL = SRT SNL = CRT CSR = SLT SNR = CLT ELSE CSL = CLT SNL = SLT CSR = CRT SNR = SRT END IF * * Correct signs of SSMAX and SSMIN * IF( PMAX.EQ.1 ) $ TSIGN = SIGN( ONE, CSR )*SIGN( ONE, CSL )*SIGN( ONE, F ) IF( PMAX.EQ.2 ) $ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, CSL )*SIGN( ONE, G ) IF( PMAX.EQ.3 ) $ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, SNL )*SIGN( ONE, H ) SSMAX = SIGN( SSMAX, TSIGN ) SSMIN = SIGN( SSMIN, TSIGN*SIGN( ONE, F )*SIGN( ONE, H ) ) RETURN * * End of DLASV2 * END *> \brief \b DLASWP performs a series of row interchanges on a general rectangular matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASWP + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * * .. Scalar Arguments .. * INTEGER INCX, K1, K2, LDA, N * .. * .. Array Arguments .. * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLASWP performs a series of row interchanges on the matrix A. *> One row interchange is initiated for each of rows K1 through K2 of A. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the matrix of column dimension N to which the row *> interchanges will be applied. *> On exit, the permuted matrix. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. *> \endverbatim *> *> \param[in] K1 *> \verbatim *> K1 is INTEGER *> The first element of IPIV for which a row interchange will *> be done. *> \endverbatim *> *> \param[in] K2 *> \verbatim *> K2 is INTEGER *> (K2-K1+1) is the number of elements of IPIV for which a row *> interchange will be done. *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (K1+(K2-K1)*abs(INCX)) *> The vector of pivot indices. Only the elements in positions *> K1 through K1+(K2-K1)*abs(INCX) of IPIV are accessed. *> IPIV(K1+(K-K1)*abs(INCX)) = L implies rows K and L are to be *> interchanged. *> \endverbatim *> *> \param[in] INCX *> \verbatim *> INCX is INTEGER *> The increment between successive values of IPIV. If INCX *> is negative, the pivots are applied in reverse order. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup doubleOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> Modified by *> R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA *> \endverbatim *> * ===================================================================== SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * * -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. INTEGER INCX, K1, K2, LDA, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 DOUBLE PRECISION TEMP * .. * .. Executable Statements .. * * Interchange row I with row IPIV(K1+(I-K1)*abs(INCX)) for each of rows * K1 through K2. * IF( INCX.GT.0 ) THEN IX0 = K1 I1 = K1 I2 = K2 INC = 1 ELSE IF( INCX.LT.0 ) THEN IX0 = K1 + ( K1-K2 )*INCX I1 = K2 I2 = K1 INC = -1 ELSE RETURN END IF * N32 = ( N / 32 )*32 IF( N32.NE.0 ) THEN DO 30 J = 1, N32, 32 IX = IX0 DO 20 I = I1, I2, INC IP = IPIV( IX ) IF( IP.NE.I ) THEN DO 10 K = J, J + 31 TEMP = A( I, K ) A( I, K ) = A( IP, K ) A( IP, K ) = TEMP 10 CONTINUE END IF IX = IX + INCX 20 CONTINUE 30 CONTINUE END IF IF( N32.NE.N ) THEN N32 = N32 + 1 IX = IX0 DO 50 I = I1, I2, INC IP = IPIV( IX ) IF( IP.NE.I ) THEN DO 40 K = N32, N TEMP = A( I, K ) A( I, K ) = A( IP, K ) A( IP, K ) = TEMP 40 CONTINUE END IF IX = IX + INCX 50 CONTINUE END IF * RETURN * * End of DLASWP * END *> \brief \b DLASY2 solves the Sylvester matrix equation where the matrices are of order 1 or 2. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASY2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, * LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) * * .. Scalar Arguments .. * LOGICAL LTRANL, LTRANR * INTEGER INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2 * DOUBLE PRECISION SCALE, XNORM * .. * .. Array Arguments .. * DOUBLE PRECISION B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ), * $ X( LDX, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in *> *> op(TL)*X + ISGN*X*op(TR) = SCALE*B, *> *> where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or *> -1. op(T) = T or T**T, where T**T denotes the transpose of T. *> \endverbatim * * Arguments: * ========== * *> \param[in] LTRANL *> \verbatim *> LTRANL is LOGICAL *> On entry, LTRANL specifies the op(TL): *> = .FALSE., op(TL) = TL, *> = .TRUE., op(TL) = TL**T. *> \endverbatim *> *> \param[in] LTRANR *> \verbatim *> LTRANR is LOGICAL *> On entry, LTRANR specifies the op(TR): *> = .FALSE., op(TR) = TR, *> = .TRUE., op(TR) = TR**T. *> \endverbatim *> *> \param[in] ISGN *> \verbatim *> ISGN is INTEGER *> On entry, ISGN specifies the sign of the equation *> as described before. ISGN may only be 1 or -1. *> \endverbatim *> *> \param[in] N1 *> \verbatim *> N1 is INTEGER *> On entry, N1 specifies the order of matrix TL. *> N1 may only be 0, 1 or 2. *> \endverbatim *> *> \param[in] N2 *> \verbatim *> N2 is INTEGER *> On entry, N2 specifies the order of matrix TR. *> N2 may only be 0, 1 or 2. *> \endverbatim *> *> \param[in] TL *> \verbatim *> TL is DOUBLE PRECISION array, dimension (LDTL,2) *> On entry, TL contains an N1 by N1 matrix. *> \endverbatim *> *> \param[in] LDTL *> \verbatim *> LDTL is INTEGER *> The leading dimension of the matrix TL. LDTL >= max(1,N1). *> \endverbatim *> *> \param[in] TR *> \verbatim *> TR is DOUBLE PRECISION array, dimension (LDTR,2) *> On entry, TR contains an N2 by N2 matrix. *> \endverbatim *> *> \param[in] LDTR *> \verbatim *> LDTR is INTEGER *> The leading dimension of the matrix TR. LDTR >= max(1,N2). *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,2) *> On entry, the N1 by N2 matrix B contains the right-hand *> side of the equation. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the matrix B. LDB >= max(1,N1). *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is DOUBLE PRECISION *> On exit, SCALE contains the scale factor. SCALE is chosen *> less than or equal to 1 to prevent the solution overflowing. *> \endverbatim *> *> \param[out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,2) *> On exit, X contains the N1 by N2 solution. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the matrix X. LDX >= max(1,N1). *> \endverbatim *> *> \param[out] XNORM *> \verbatim *> XNORM is DOUBLE PRECISION *> On exit, XNORM is the infinity-norm of the solution. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> On exit, INFO is set to *> 0: successful exit. *> 1: TL and TR have too close eigenvalues, so TL or *> TR is perturbed to get a nonsingular equation. *> NOTE: In the interests of speed, this routine does not *> check the inputs for errors. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleSYauxiliary * * ===================================================================== SUBROUTINE DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, $ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. LOGICAL LTRANL, LTRANR INTEGER INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2 DOUBLE PRECISION SCALE, XNORM * .. * .. Array Arguments .. DOUBLE PRECISION B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ), $ X( LDX, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION TWO, HALF, EIGHT PARAMETER ( TWO = 2.0D+0, HALF = 0.5D+0, EIGHT = 8.0D+0 ) * .. * .. Local Scalars .. LOGICAL BSWAP, XSWAP INTEGER I, IP, IPIV, IPSV, J, JP, JPSV, K DOUBLE PRECISION BET, EPS, GAM, L21, SGN, SMIN, SMLNUM, TAU1, $ TEMP, U11, U12, U22, XMAX * .. * .. Local Arrays .. LOGICAL BSWPIV( 4 ), XSWPIV( 4 ) INTEGER JPIV( 4 ), LOCL21( 4 ), LOCU12( 4 ), $ LOCU22( 4 ) DOUBLE PRECISION BTMP( 4 ), T16( 4, 4 ), TMP( 4 ), X2( 2 ) * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH EXTERNAL IDAMAX, DLAMCH * .. * .. External Subroutines .. EXTERNAL DCOPY, DSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Data statements .. DATA LOCU12 / 3, 4, 1, 2 / , LOCL21 / 2, 1, 4, 3 / , $ LOCU22 / 4, 3, 2, 1 / DATA XSWPIV / .FALSE., .FALSE., .TRUE., .TRUE. / DATA BSWPIV / .FALSE., .TRUE., .FALSE., .TRUE. / * .. * .. Executable Statements .. * * Do not check the input parameters for errors * INFO = 0 * * Quick return if possible * IF( N1.EQ.0 .OR. N2.EQ.0 ) $ RETURN * * Set constants to control overflow * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) / EPS SGN = ISGN * K = N1 + N1 + N2 - 2 GO TO ( 10, 20, 30, 50 )K * * 1 by 1: TL11*X + SGN*X*TR11 = B11 * 10 CONTINUE TAU1 = TL( 1, 1 ) + SGN*TR( 1, 1 ) BET = ABS( TAU1 ) IF( BET.LE.SMLNUM ) THEN TAU1 = SMLNUM BET = SMLNUM INFO = 1 END IF * SCALE = ONE GAM = ABS( B( 1, 1 ) ) IF( SMLNUM*GAM.GT.BET ) $ SCALE = ONE / GAM * X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / TAU1 XNORM = ABS( X( 1, 1 ) ) RETURN * * 1 by 2: * TL11*[X11 X12] + ISGN*[X11 X12]*op[TR11 TR12] = [B11 B12] * [TR21 TR22] * 20 CONTINUE * SMIN = MAX( EPS*MAX( ABS( TL( 1, 1 ) ), ABS( TR( 1, 1 ) ), $ ABS( TR( 1, 2 ) ), ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ), $ SMLNUM ) TMP( 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 ) TMP( 4 ) = TL( 1, 1 ) + SGN*TR( 2, 2 ) IF( LTRANR ) THEN TMP( 2 ) = SGN*TR( 2, 1 ) TMP( 3 ) = SGN*TR( 1, 2 ) ELSE TMP( 2 ) = SGN*TR( 1, 2 ) TMP( 3 ) = SGN*TR( 2, 1 ) END IF BTMP( 1 ) = B( 1, 1 ) BTMP( 2 ) = B( 1, 2 ) GO TO 40 * * 2 by 1: * op[TL11 TL12]*[X11] + ISGN* [X11]*TR11 = [B11] * [TL21 TL22] [X21] [X21] [B21] * 30 CONTINUE SMIN = MAX( EPS*MAX( ABS( TR( 1, 1 ) ), ABS( TL( 1, 1 ) ), $ ABS( TL( 1, 2 ) ), ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ), $ SMLNUM ) TMP( 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 ) TMP( 4 ) = TL( 2, 2 ) + SGN*TR( 1, 1 ) IF( LTRANL ) THEN TMP( 2 ) = TL( 1, 2 ) TMP( 3 ) = TL( 2, 1 ) ELSE TMP( 2 ) = TL( 2, 1 ) TMP( 3 ) = TL( 1, 2 ) END IF BTMP( 1 ) = B( 1, 1 ) BTMP( 2 ) = B( 2, 1 ) 40 CONTINUE * * Solve 2 by 2 system using complete pivoting. * Set pivots less than SMIN to SMIN. * IPIV = IDAMAX( 4, TMP, 1 ) U11 = TMP( IPIV ) IF( ABS( U11 ).LE.SMIN ) THEN INFO = 1 U11 = SMIN END IF U12 = TMP( LOCU12( IPIV ) ) L21 = TMP( LOCL21( IPIV ) ) / U11 U22 = TMP( LOCU22( IPIV ) ) - U12*L21 XSWAP = XSWPIV( IPIV ) BSWAP = BSWPIV( IPIV ) IF( ABS( U22 ).LE.SMIN ) THEN INFO = 1 U22 = SMIN END IF IF( BSWAP ) THEN TEMP = BTMP( 2 ) BTMP( 2 ) = BTMP( 1 ) - L21*TEMP BTMP( 1 ) = TEMP ELSE BTMP( 2 ) = BTMP( 2 ) - L21*BTMP( 1 ) END IF SCALE = ONE IF( ( TWO*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( U22 ) .OR. $ ( TWO*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( U11 ) ) THEN SCALE = HALF / MAX( ABS( BTMP( 1 ) ), ABS( BTMP( 2 ) ) ) BTMP( 1 ) = BTMP( 1 )*SCALE BTMP( 2 ) = BTMP( 2 )*SCALE END IF X2( 2 ) = BTMP( 2 ) / U22 X2( 1 ) = BTMP( 1 ) / U11 - ( U12 / U11 )*X2( 2 ) IF( XSWAP ) THEN TEMP = X2( 2 ) X2( 2 ) = X2( 1 ) X2( 1 ) = TEMP END IF X( 1, 1 ) = X2( 1 ) IF( N1.EQ.1 ) THEN X( 1, 2 ) = X2( 2 ) XNORM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) ) ELSE X( 2, 1 ) = X2( 2 ) XNORM = MAX( ABS( X( 1, 1 ) ), ABS( X( 2, 1 ) ) ) END IF RETURN * * 2 by 2: * op[TL11 TL12]*[X11 X12] +ISGN* [X11 X12]*op[TR11 TR12] = [B11 B12] * [TL21 TL22] [X21 X22] [X21 X22] [TR21 TR22] [B21 B22] * * Solve equivalent 4 by 4 system using complete pivoting. * Set pivots less than SMIN to SMIN. * 50 CONTINUE SMIN = MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ), $ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ) SMIN = MAX( SMIN, ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ), $ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ) SMIN = MAX( EPS*SMIN, SMLNUM ) BTMP( 1 ) = ZERO CALL DCOPY( 16, BTMP, 0, T16, 1 ) T16( 1, 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 ) T16( 2, 2 ) = TL( 2, 2 ) + SGN*TR( 1, 1 ) T16( 3, 3 ) = TL( 1, 1 ) + SGN*TR( 2, 2 ) T16( 4, 4 ) = TL( 2, 2 ) + SGN*TR( 2, 2 ) IF( LTRANL ) THEN T16( 1, 2 ) = TL( 2, 1 ) T16( 2, 1 ) = TL( 1, 2 ) T16( 3, 4 ) = TL( 2, 1 ) T16( 4, 3 ) = TL( 1, 2 ) ELSE T16( 1, 2 ) = TL( 1, 2 ) T16( 2, 1 ) = TL( 2, 1 ) T16( 3, 4 ) = TL( 1, 2 ) T16( 4, 3 ) = TL( 2, 1 ) END IF IF( LTRANR ) THEN T16( 1, 3 ) = SGN*TR( 1, 2 ) T16( 2, 4 ) = SGN*TR( 1, 2 ) T16( 3, 1 ) = SGN*TR( 2, 1 ) T16( 4, 2 ) = SGN*TR( 2, 1 ) ELSE T16( 1, 3 ) = SGN*TR( 2, 1 ) T16( 2, 4 ) = SGN*TR( 2, 1 ) T16( 3, 1 ) = SGN*TR( 1, 2 ) T16( 4, 2 ) = SGN*TR( 1, 2 ) END IF BTMP( 1 ) = B( 1, 1 ) BTMP( 2 ) = B( 2, 1 ) BTMP( 3 ) = B( 1, 2 ) BTMP( 4 ) = B( 2, 2 ) * * Perform elimination * DO 100 I = 1, 3 XMAX = ZERO DO 70 IP = I, 4 DO 60 JP = I, 4 IF( ABS( T16( IP, JP ) ).GE.XMAX ) THEN XMAX = ABS( T16( IP, JP ) ) IPSV = IP JPSV = JP END IF 60 CONTINUE 70 CONTINUE IF( IPSV.NE.I ) THEN CALL DSWAP( 4, T16( IPSV, 1 ), 4, T16( I, 1 ), 4 ) TEMP = BTMP( I ) BTMP( I ) = BTMP( IPSV ) BTMP( IPSV ) = TEMP END IF IF( JPSV.NE.I ) $ CALL DSWAP( 4, T16( 1, JPSV ), 1, T16( 1, I ), 1 ) JPIV( I ) = JPSV IF( ABS( T16( I, I ) ).LT.SMIN ) THEN INFO = 1 T16( I, I ) = SMIN END IF DO 90 J = I + 1, 4 T16( J, I ) = T16( J, I ) / T16( I, I ) BTMP( J ) = BTMP( J ) - T16( J, I )*BTMP( I ) DO 80 K = I + 1, 4 T16( J, K ) = T16( J, K ) - T16( J, I )*T16( I, K ) 80 CONTINUE 90 CONTINUE 100 CONTINUE IF( ABS( T16( 4, 4 ) ).LT.SMIN ) THEN INFO = 1 T16( 4, 4 ) = SMIN END IF SCALE = ONE IF( ( EIGHT*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T16( 1, 1 ) ) .OR. $ ( EIGHT*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T16( 2, 2 ) ) .OR. $ ( EIGHT*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T16( 3, 3 ) ) .OR. $ ( EIGHT*SMLNUM )*ABS( BTMP( 4 ) ).GT.ABS( T16( 4, 4 ) ) ) THEN SCALE = ( ONE / EIGHT ) / MAX( ABS( BTMP( 1 ) ), $ ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ), ABS( BTMP( 4 ) ) ) BTMP( 1 ) = BTMP( 1 )*SCALE BTMP( 2 ) = BTMP( 2 )*SCALE BTMP( 3 ) = BTMP( 3 )*SCALE BTMP( 4 ) = BTMP( 4 )*SCALE END IF DO 120 I = 1, 4 K = 5 - I TEMP = ONE / T16( K, K ) TMP( K ) = BTMP( K )*TEMP DO 110 J = K + 1, 4 TMP( K ) = TMP( K ) - ( TEMP*T16( K, J ) )*TMP( J ) 110 CONTINUE 120 CONTINUE DO 130 I = 1, 3 IF( JPIV( 4-I ).NE.4-I ) THEN TEMP = TMP( 4-I ) TMP( 4-I ) = TMP( JPIV( 4-I ) ) TMP( JPIV( 4-I ) ) = TEMP END IF 130 CONTINUE X( 1, 1 ) = TMP( 1 ) X( 2, 1 ) = TMP( 2 ) X( 1, 2 ) = TMP( 3 ) X( 2, 2 ) = TMP( 4 ) XNORM = MAX( ABS( TMP( 1 ) )+ABS( TMP( 3 ) ), $ ABS( TMP( 2 ) )+ABS( TMP( 4 ) ) ) RETURN * * End of DLASY2 * END *> \brief \b DLASYF computes a partial factorization of a real symmetric matrix using the Bunch-Kaufman diagonal pivoting method. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLASYF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KB, LDA, LDW, N, NB * .. * .. Array Arguments .. * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), W( LDW, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLASYF computes a partial factorization of a real symmetric matrix A *> using the Bunch-Kaufman diagonal pivoting method. The partial *> factorization has the form: *> *> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: *> ( 0 U22 ) ( 0 D ) ( U12**T U22**T ) *> *> A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L' *> ( L21 I ) ( 0 A22 ) ( 0 I ) *> *> where the order of D is at most NB. The actual order is returned in *> the argument KB, and is either NB or NB-1, or N if N <= NB. *> *> DLASYF is an auxiliary routine called by DSYTRF. It uses blocked code *> (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or *> A22 (if UPLO = 'L'). *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the upper or lower triangular part of the *> symmetric matrix A is stored: *> = 'U': Upper triangular *> = 'L': Lower triangular *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] NB *> \verbatim *> NB is INTEGER *> The maximum number of columns of the matrix A that should be *> factored. NB should be at least 2 to allow for 2-by-2 pivot *> blocks. *> \endverbatim *> *> \param[out] KB *> \verbatim *> KB is INTEGER *> The number of columns of A that were actually factored. *> KB is either NB-1 or NB, or N if N <= NB. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the symmetric matrix A. If UPLO = 'U', the leading *> n-by-n upper triangular part of A contains the upper *> triangular part of the matrix A, and the strictly lower *> triangular part of A is not referenced. If UPLO = 'L', the *> leading n-by-n lower triangular part of A contains the lower *> triangular part of the matrix A, and the strictly upper *> triangular part of A is not referenced. *> On exit, A contains details of the partial factorization. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N) *> Details of the interchanges and the block structure of D. *> *> If UPLO = 'U': *> Only the last KB elements of IPIV are set. *> *> If IPIV(k) > 0, then rows and columns k and IPIV(k) were *> interchanged and D(k,k) is a 1-by-1 diagonal block. *> *> If IPIV(k) = IPIV(k-1) < 0, then rows and columns *> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) *> is a 2-by-2 diagonal block. *> *> If UPLO = 'L': *> Only the first KB elements of IPIV are set. *> *> If IPIV(k) > 0, then rows and columns k and IPIV(k) were *> interchanged and D(k,k) is a 1-by-1 diagonal block. *> *> If IPIV(k) = IPIV(k+1) < 0, then rows and columns *> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1) *> is a 2-by-2 diagonal block. *> \endverbatim *> *> \param[out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (LDW,NB) *> \endverbatim *> *> \param[in] LDW *> \verbatim *> LDW is INTEGER *> The leading dimension of the array W. LDW >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> > 0: if INFO = k, D(k,k) is exactly zero. The factorization *> has been completed, but the block diagonal matrix D is *> exactly singular. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date November 2013 * *> \ingroup doubleSYcomputational * *> \par Contributors: * ================== *> *> \verbatim *> *> November 2013, Igor Kozachenko, *> Computer Science Division, *> University of California, Berkeley *> \endverbatim * * ===================================================================== SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * * -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2013 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, KB, LDA, LDW, N, NB * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ), W( LDW, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION EIGHT, SEVTEN PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) * .. * .. Local Scalars .. INTEGER IMAX, J, JB, JJ, JMAX, JP, K, KK, KKW, KP, $ KSTEP, KW DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D21, D22, R1, $ ROWMAX, T * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX EXTERNAL LSAME, IDAMAX * .. * .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DGEMV, DSCAL, DSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Executable Statements .. * INFO = 0 * * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT * IF( LSAME( UPLO, 'U' ) ) THEN * * Factorize the trailing columns of A using the upper triangle * of A and working backwards, and compute the matrix W = U12*D * for use in updating A11 * * K is the main loop index, decreasing from N in steps of 1 or 2 * * KW is the column of W which corresponds to column K of A * K = N 10 CONTINUE KW = NB + K - N * * Exit from loop * IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 ) $ GO TO 30 * * Copy column K of A to column KW of W and update it * CALL DCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 ) IF( K.LT.N ) $ CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), LDA, $ W( K, KW+1 ), LDW, ONE, W( 1, KW ), 1 ) * KSTEP = 1 * * Determine rows and columns to be interchanged and whether * a 1-by-1 or 2-by-2 pivot block will be used * ABSAKK = ABS( W( K, KW ) ) * * IMAX is the row-index of the largest off-diagonal element in * column K, and COLMAX is its absolute value. * Determine both COLMAX and IMAX. * IF( K.GT.1 ) THEN IMAX = IDAMAX( K-1, W( 1, KW ), 1 ) COLMAX = ABS( W( IMAX, KW ) ) ELSE COLMAX = ZERO END IF * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN * * Column K is zero or underflow: set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K KP = K ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * * no interchange, use 1-by-1 pivot block * KP = K ELSE * * Copy column IMAX to column KW-1 of W and update it * CALL DCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 ) CALL DCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA, $ W( IMAX+1, KW-1 ), 1 ) IF( K.LT.N ) $ CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), $ LDA, W( IMAX, KW+1 ), LDW, ONE, $ W( 1, KW-1 ), 1 ) * * JMAX is the column-index of the largest off-diagonal * element in row IMAX, and ROWMAX is its absolute value * JMAX = IMAX + IDAMAX( K-IMAX, W( IMAX+1, KW-1 ), 1 ) ROWMAX = ABS( W( JMAX, KW-1 ) ) IF( IMAX.GT.1 ) THEN JMAX = IDAMAX( IMAX-1, W( 1, KW-1 ), 1 ) ROWMAX = MAX( ROWMAX, ABS( W( JMAX, KW-1 ) ) ) END IF * IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN * * no interchange, use 1-by-1 pivot block * KP = K ELSE IF( ABS( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX ) THEN * * interchange rows and columns K and IMAX, use 1-by-1 * pivot block * KP = IMAX * * copy column KW-1 of W to column KW of W * CALL DCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) ELSE * * interchange rows and columns K-1 and IMAX, use 2-by-2 * pivot block * KP = IMAX KSTEP = 2 END IF END IF * * ============================================================ * * KK is the column of A where pivoting step stopped * KK = K - KSTEP + 1 * * KKW is the column of W which corresponds to column KK of A * KKW = NB + KK - N * * Interchange rows and columns KP and KK. * Updated column KP is already stored in column KKW of W. * IF( KP.NE.KK ) THEN * * Copy non-updated column KK to column KP of submatrix A * at step K. No need to copy element into column K * (or K and K-1 for 2-by-2 pivot) of A, since these columns * will be later overwritten. * A( KP, KP ) = A( KK, KK ) CALL DCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), $ LDA ) IF( KP.GT.1 ) $ CALL DCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) * * Interchange rows KK and KP in last K+1 to N columns of A * (columns K (or K and K-1 for 2-by-2 pivot) of A will be * later overwritten). Interchange rows KK and KP * in last KKW to NB columns of W. * IF( K.LT.N ) $ CALL DSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ), $ LDA ) CALL DSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ), $ LDW ) END IF * IF( KSTEP.EQ.1 ) THEN * * 1-by-1 pivot block D(k): column kw of W now holds * * W(kw) = U(k)*D(k), * * where U(k) is the k-th column of U * * Store subdiag. elements of column U(k) * and 1-by-1 block D(k) in column k of A. * NOTE: Diagonal element U(k,k) is a UNIT element * and not stored. * A(k,k) := D(k,k) = W(k,kw) * A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k) * CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) R1 = ONE / A( K, K ) CALL DSCAL( K-1, R1, A( 1, K ), 1 ) * ELSE * * 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold * * ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k) * * where U(k) and U(k-1) are the k-th and (k-1)-th columns * of U * * Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2 * block D(k-1:k,k-1:k) in columns k-1 and k of A. * NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT * block and not stored. * A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw) * A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) = * = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) ) * IF( K.GT.2 ) THEN * * Compose the columns of the inverse of 2-by-2 pivot * block D in the following way to reduce the number * of FLOPS when we myltiply panel ( W(kw-1) W(kw) ) by * this inverse * * D**(-1) = ( d11 d21 )**(-1) = * ( d21 d22 ) * * = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) = * ( (-d21 ) ( d11 ) ) * * = 1/d21 * 1/((d11/d21)*(d22/d21)-1) * * * * ( ( d22/d21 ) ( -1 ) ) = * ( ( -1 ) ( d11/d21 ) ) * * = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) = * ( ( -1 ) ( D22 ) ) * * = 1/d21 * T * ( ( D11 ) ( -1 ) ) * ( ( -1 ) ( D22 ) ) * * = D21 * ( ( D11 ) ( -1 ) ) * ( ( -1 ) ( D22 ) ) * D21 = W( K-1, KW ) D11 = W( K, KW ) / D21 D22 = W( K-1, KW-1 ) / D21 T = ONE / ( D11*D22-ONE ) D21 = T / D21 * * Update elements in columns A(k-1) and A(k) as * dot products of rows of ( W(kw-1) W(kw) ) and columns * of D**(-1) * DO 20 J = 1, K - 2 A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) ) A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) ) 20 CONTINUE END IF * * Copy D(k) to A * A( K-1, K-1 ) = W( K-1, KW-1 ) A( K-1, K ) = W( K-1, KW ) A( K, K ) = W( K, KW ) * END IF * END IF * * Store details of the interchanges in IPIV * IF( KSTEP.EQ.1 ) THEN IPIV( K ) = KP ELSE IPIV( K ) = -KP IPIV( K-1 ) = -KP END IF * * Decrease K and return to the start of the main loop * K = K - KSTEP GO TO 10 * 30 CONTINUE * * Update the upper triangle of A11 (= A(1:k,1:k)) as * * A11 := A11 - U12*D*U12**T = A11 - U12*W**T * * computing blocks of NB columns at a time * DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB JB = MIN( NB, K-J+1 ) * * Update the upper triangle of the diagonal block * DO 40 JJ = J, J + JB - 1 CALL DGEMV( 'No transpose', JJ-J+1, N-K, -ONE, $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, ONE, $ A( J, JJ ), 1 ) 40 CONTINUE * * Update the rectangular superdiagonal block * CALL DGEMM( 'No transpose', 'Transpose', J-1, JB, N-K, -ONE, $ A( 1, K+1 ), LDA, W( J, KW+1 ), LDW, ONE, $ A( 1, J ), LDA ) 50 CONTINUE * * Put U12 in standard form by partially undoing the interchanges * in columns k+1:n looping backwards from k+1 to n * J = K + 1 60 CONTINUE * * Undo the interchanges (if any) of rows JJ and JP at each * step J * * (Here, J is a diagonal index) JJ = J JP = IPIV( J ) IF( JP.LT.0 ) THEN JP = -JP * (Here, J is a diagonal index) J = J + 1 END IF * (NOTE: Here, J is used to determine row length. Length N-J+1 * of the rows to swap back doesn't include diagonal element) J = J + 1 IF( JP.NE.JJ .AND. J.LE.N ) $ CALL DSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA ) IF( J.LT.N ) $ GO TO 60 * * Set KB to the number of columns factorized * KB = N - K * ELSE * * Factorize the leading columns of A using the lower triangle * of A and working forwards, and compute the matrix W = L21*D * for use in updating A22 * * K is the main loop index, increasing from 1 in steps of 1 or 2 * K = 1 70 CONTINUE * * Exit from loop * IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N ) $ GO TO 90 * * Copy column K of A to column K of W and update it * CALL DCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 ) CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), LDA, $ W( K, 1 ), LDW, ONE, W( K, K ), 1 ) * KSTEP = 1 * * Determine rows and columns to be interchanged and whether * a 1-by-1 or 2-by-2 pivot block will be used * ABSAKK = ABS( W( K, K ) ) * * IMAX is the row-index of the largest off-diagonal element in * column K, and COLMAX is its absolute value. * Determine both COLMAX and IMAX. * IF( K.LT.N ) THEN IMAX = K + IDAMAX( N-K, W( K+1, K ), 1 ) COLMAX = ABS( W( IMAX, K ) ) ELSE COLMAX = ZERO END IF * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN * * Column K is zero or underflow: set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K KP = K ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * * no interchange, use 1-by-1 pivot block * KP = K ELSE * * Copy column IMAX to column K+1 of W and update it * CALL DCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 ) CALL DCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, W( IMAX, K+1 ), $ 1 ) CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), $ LDA, W( IMAX, 1 ), LDW, ONE, W( K, K+1 ), 1 ) * * JMAX is the column-index of the largest off-diagonal * element in row IMAX, and ROWMAX is its absolute value * JMAX = K - 1 + IDAMAX( IMAX-K, W( K, K+1 ), 1 ) ROWMAX = ABS( W( JMAX, K+1 ) ) IF( IMAX.LT.N ) THEN JMAX = IMAX + IDAMAX( N-IMAX, W( IMAX+1, K+1 ), 1 ) ROWMAX = MAX( ROWMAX, ABS( W( JMAX, K+1 ) ) ) END IF * IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN * * no interchange, use 1-by-1 pivot block * KP = K ELSE IF( ABS( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX ) THEN * * interchange rows and columns K and IMAX, use 1-by-1 * pivot block * KP = IMAX * * copy column K+1 of W to column K of W * CALL DCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) ELSE * * interchange rows and columns K+1 and IMAX, use 2-by-2 * pivot block * KP = IMAX KSTEP = 2 END IF END IF * * ============================================================ * * KK is the column of A where pivoting step stopped * KK = K + KSTEP - 1 * * Interchange rows and columns KP and KK. * Updated column KP is already stored in column KK of W. * IF( KP.NE.KK ) THEN * * Copy non-updated column KK to column KP of submatrix A * at step K. No need to copy element into column K * (or K and K+1 for 2-by-2 pivot) of A, since these columns * will be later overwritten. * A( KP, KP ) = A( KK, KK ) CALL DCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), $ LDA ) IF( KP.LT.N ) $ CALL DCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) * * Interchange rows KK and KP in first K-1 columns of A * (columns K (or K and K+1 for 2-by-2 pivot) of A will be * later overwritten). Interchange rows KK and KP * in first KK columns of W. * IF( K.GT.1 ) $ CALL DSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) CALL DSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW ) END IF * IF( KSTEP.EQ.1 ) THEN * * 1-by-1 pivot block D(k): column k of W now holds * * W(k) = L(k)*D(k), * * where L(k) is the k-th column of L * * Store subdiag. elements of column L(k) * and 1-by-1 block D(k) in column k of A. * (NOTE: Diagonal element L(k,k) is a UNIT element * and not stored) * A(k,k) := D(k,k) = W(k,k) * A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k) * CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) IF( K.LT.N ) THEN R1 = ONE / A( K, K ) CALL DSCAL( N-K, R1, A( K+1, K ), 1 ) END IF * ELSE * * 2-by-2 pivot block D(k): columns k and k+1 of W now hold * * ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) * * where L(k) and L(k+1) are the k-th and (k+1)-th columns * of L * * Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2 * block D(k:k+1,k:k+1) in columns k and k+1 of A. * (NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT * block and not stored) * A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1) * A(k+2:N,k:k+1) := L(k+2:N,k:k+1) = * = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) ) * IF( K.LT.N-1 ) THEN * * Compose the columns of the inverse of 2-by-2 pivot * block D in the following way to reduce the number * of FLOPS when we myltiply panel ( W(k) W(k+1) ) by * this inverse * * D**(-1) = ( d11 d21 )**(-1) = * ( d21 d22 ) * * = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) = * ( (-d21 ) ( d11 ) ) * * = 1/d21 * 1/((d11/d21)*(d22/d21)-1) * * * * ( ( d22/d21 ) ( -1 ) ) = * ( ( -1 ) ( d11/d21 ) ) * * = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) = * ( ( -1 ) ( D22 ) ) * * = 1/d21 * T * ( ( D11 ) ( -1 ) ) * ( ( -1 ) ( D22 ) ) * * = D21 * ( ( D11 ) ( -1 ) ) * ( ( -1 ) ( D22 ) ) * D21 = W( K+1, K ) D11 = W( K+1, K+1 ) / D21 D22 = W( K, K ) / D21 T = ONE / ( D11*D22-ONE ) D21 = T / D21 * * Update elements in columns A(k) and A(k+1) as * dot products of rows of ( W(k) W(k+1) ) and columns * of D**(-1) * DO 80 J = K + 2, N A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) ) A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) ) 80 CONTINUE END IF * * Copy D(k) to A * A( K, K ) = W( K, K ) A( K+1, K ) = W( K+1, K ) A( K+1, K+1 ) = W( K+1, K+1 ) * END IF * END IF * * Store details of the interchanges in IPIV * IF( KSTEP.EQ.1 ) THEN IPIV( K ) = KP ELSE IPIV( K ) = -KP IPIV( K+1 ) = -KP END IF * * Increase K and return to the start of the main loop * K = K + KSTEP GO TO 70 * 90 CONTINUE * * Update the lower triangle of A22 (= A(k:n,k:n)) as * * A22 := A22 - L21*D*L21**T = A22 - L21*W**T * * computing blocks of NB columns at a time * DO 110 J = K, N, NB JB = MIN( NB, N-J+1 ) * * Update the lower triangle of the diagonal block * DO 100 JJ = J, J + JB - 1 CALL DGEMV( 'No transpose', J+JB-JJ, K-1, -ONE, $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, ONE, $ A( JJ, JJ ), 1 ) 100 CONTINUE * * Update the rectangular subdiagonal block * IF( J+JB.LE.N ) $ CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, $ K-1, -ONE, A( J+JB, 1 ), LDA, W( J, 1 ), LDW, $ ONE, A( J+JB, J ), LDA ) 110 CONTINUE * * Put L21 in standard form by partially undoing the interchanges * of rows in columns 1:k-1 looping backwards from k-1 to 1 * J = K - 1 120 CONTINUE * * Undo the interchanges (if any) of rows JJ and JP at each * step J * * (Here, J is a diagonal index) JJ = J JP = IPIV( J ) IF( JP.LT.0 ) THEN JP = -JP * (Here, J is a diagonal index) J = J - 1 END IF * (NOTE: Here, J is used to determine row length. Length J * of the rows to swap back doesn't include diagonal element) J = J - 1 IF( JP.NE.JJ .AND. J.GE.1 ) $ CALL DSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA ) IF( J.GT.1 ) $ GO TO 120 * * Set KB to the number of columns factorized * KB = K - 1 * END IF RETURN * * End of DLASYF * END *> \brief \b DLATBS solves a triangular banded system of equations. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLATBS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, * SCALE, CNORM, INFO ) * * .. Scalar Arguments .. * CHARACTER DIAG, NORMIN, TRANS, UPLO * INTEGER INFO, KD, LDAB, N * DOUBLE PRECISION SCALE * .. * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ), CNORM( * ), X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLATBS solves one of the triangular systems *> *> A *x = s*b or A**T*x = s*b *> *> with scaling to prevent overflow, where A is an upper or lower *> triangular band matrix. Here A**T denotes the transpose of A, x and b *> are n-element vectors, and s is a scaling factor, usually less than *> or equal to 1, chosen so that the components of x will be less than *> the overflow threshold. If the unscaled problem will not cause *> overflow, the Level 2 BLAS routine DTBSV is called. If the matrix A *> is singular (A(j,j) = 0 for some j), then s is set to 0 and a *> non-trivial solution to A*x = 0 is returned. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the matrix A is upper or lower triangular. *> = 'U': Upper triangular *> = 'L': Lower triangular *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> Specifies the operation applied to A. *> = 'N': Solve A * x = s*b (No transpose) *> = 'T': Solve A**T* x = s*b (Transpose) *> = 'C': Solve A**T* x = s*b (Conjugate transpose = Transpose) *> \endverbatim *> *> \param[in] DIAG *> \verbatim *> DIAG is CHARACTER*1 *> Specifies whether or not the matrix A is unit triangular. *> = 'N': Non-unit triangular *> = 'U': Unit triangular *> \endverbatim *> *> \param[in] NORMIN *> \verbatim *> NORMIN is CHARACTER*1 *> Specifies whether CNORM has been set or not. *> = 'Y': CNORM contains the column norms on entry *> = 'N': CNORM is not set on entry. On exit, the norms will *> be computed and stored in CNORM. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] KD *> \verbatim *> KD is INTEGER *> The number of subdiagonals or superdiagonals in the *> triangular matrix A. KD >= 0. *> \endverbatim *> *> \param[in] AB *> \verbatim *> AB is DOUBLE PRECISION array, dimension (LDAB,N) *> The upper or lower triangular band matrix A, stored in the *> first KD+1 rows of the array. The j-th column of A is stored *> in the j-th column of the array AB as follows: *> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; *> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array AB. LDAB >= KD+1. *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (N) *> On entry, the right hand side b of the triangular system. *> On exit, X is overwritten by the solution vector x. *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is DOUBLE PRECISION *> The scaling factor s for the triangular system *> A * x = s*b or A**T* x = s*b. *> If SCALE = 0, the matrix A is singular or badly scaled, and *> the vector x is an exact or approximate solution to A*x = 0. *> \endverbatim *> *> \param[in,out] CNORM *> \verbatim *> CNORM is DOUBLE PRECISION array, dimension (N) *> *> If NORMIN = 'Y', CNORM is an input argument and CNORM(j) *> contains the norm of the off-diagonal part of the j-th column *> of A. If TRANS = 'N', CNORM(j) must be greater than or equal *> to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) *> must be greater than or equal to the 1-norm. *> *> If NORMIN = 'N', CNORM is an output argument and CNORM(j) *> returns the 1-norm of the offdiagonal part of the j-th column *> of A. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -k, the k-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> A rough bound on x is computed; if that is less than overflow, DTBSV *> is called, otherwise, specific code is used which checks for possible *> overflow or divide-by-zero at every operation. *> *> A columnwise scheme is used for solving A*x = b. The basic algorithm *> if A is lower triangular is *> *> x[1:n] := b[1:n] *> for j = 1, ..., n *> x(j) := x(j) / A(j,j) *> x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] *> end *> *> Define bounds on the components of x after j iterations of the loop: *> M(j) = bound on x[1:j] *> G(j) = bound on x[j+1:n] *> Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. *> *> Then for iteration j+1 we have *> M(j+1) <= G(j) / | A(j+1,j+1) | *> G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | *> <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) *> *> where CNORM(j+1) is greater than or equal to the infinity-norm of *> column j+1 of A, not counting the diagonal. Hence *> *> G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) *> 1<=i<=j *> and *> *> |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) *> 1<=i< j *> *> Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTBSV if the *> reciprocal of the largest M(j), j=1,..,n, is larger than *> max(underflow, 1/overflow). *> *> The bound on x(j) is also used to determine when a step in the *> columnwise method can be performed without fear of overflow. If *> the computed bound is greater than a large constant, x is scaled to *> prevent overflow, but if the bound overflows, x is set to 0, x(j) to *> 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. *> *> Similarly, a row-wise scheme is used to solve A**T*x = b. The basic *> algorithm for A upper triangular is *> *> for j = 1, ..., n *> x(j) := ( b(j) - A[1:j-1,j]**T * x[1:j-1] ) / A(j,j) *> end *> *> We simultaneously compute two bounds *> G(j) = bound on ( b(i) - A[1:i-1,i]**T * x[1:i-1] ), 1<=i<=j *> M(j) = bound on x(i), 1<=i<=j *> *> The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we *> add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. *> Then the bound on x(j) is *> *> M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | *> *> <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) *> 1<=i<=j *> *> and we can safely call DTBSV if 1/M(n) and 1/G(n) are both greater *> than max(underflow, 1/overflow). *> \endverbatim *> * ===================================================================== SUBROUTINE DLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, $ SCALE, CNORM, INFO ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO INTEGER INFO, KD, LDAB, N DOUBLE PRECISION SCALE * .. * .. Array Arguments .. DOUBLE PRECISION AB( LDAB, * ), CNORM( * ), X( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOTRAN, NOUNIT, UPPER INTEGER I, IMAX, J, JFIRST, JINC, JLAST, JLEN, MAIND DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS, $ TMAX, TSCAL, USCAL, XBND, XJ, XMAX * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DASUM, DDOT, DLAMCH EXTERNAL LSAME, IDAMAX, DASUM, DDOT, DLAMCH * .. * .. External Subroutines .. EXTERNAL DAXPY, DSCAL, DTBSV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. Executable Statements .. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) NOTRAN = LSAME( TRANS, 'N' ) NOUNIT = LSAME( DIAG, 'N' ) * * Test the input parameters. * IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. $ LSAME( TRANS, 'C' ) ) THEN INFO = -2 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -3 ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT. $ LSAME( NORMIN, 'N' ) ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( KD.LT.0 ) THEN INFO = -6 ELSE IF( LDAB.LT.KD+1 ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLATBS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Determine machine dependent parameters to control overflow. * SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) BIGNUM = ONE / SMLNUM SCALE = ONE * IF( LSAME( NORMIN, 'N' ) ) THEN * * Compute the 1-norm of each column, not including the diagonal. * IF( UPPER ) THEN * * A is upper triangular. * DO 10 J = 1, N JLEN = MIN( KD, J-1 ) CNORM( J ) = DASUM( JLEN, AB( KD+1-JLEN, J ), 1 ) 10 CONTINUE ELSE * * A is lower triangular. * DO 20 J = 1, N JLEN = MIN( KD, N-J ) IF( JLEN.GT.0 ) THEN CNORM( J ) = DASUM( JLEN, AB( 2, J ), 1 ) ELSE CNORM( J ) = ZERO END IF 20 CONTINUE END IF END IF * * Scale the column norms by TSCAL if the maximum element in CNORM is * greater than BIGNUM. * IMAX = IDAMAX( N, CNORM, 1 ) TMAX = CNORM( IMAX ) IF( TMAX.LE.BIGNUM ) THEN TSCAL = ONE ELSE TSCAL = ONE / ( SMLNUM*TMAX ) CALL DSCAL( N, TSCAL, CNORM, 1 ) END IF * * Compute a bound on the computed solution vector to see if the * Level 2 BLAS routine DTBSV can be used. * J = IDAMAX( N, X, 1 ) XMAX = ABS( X( J ) ) XBND = XMAX IF( NOTRAN ) THEN * * Compute the growth in A * x = b. * IF( UPPER ) THEN JFIRST = N JLAST = 1 JINC = -1 MAIND = KD + 1 ELSE JFIRST = 1 JLAST = N JINC = 1 MAIND = 1 END IF * IF( TSCAL.NE.ONE ) THEN GROW = ZERO GO TO 50 END IF * IF( NOUNIT ) THEN * * A is non-unit triangular. * * Compute GROW = 1/G(j) and XBND = 1/M(j). * Initially, G(0) = max{x(i), i=1,...,n}. * GROW = ONE / MAX( XBND, SMLNUM ) XBND = GROW DO 30 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 50 * * M(j) = G(j-1) / abs(A(j,j)) * TJJ = ABS( AB( MAIND, J ) ) XBND = MIN( XBND, MIN( ONE, TJJ )*GROW ) IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN * * G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) * GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) ) ELSE * * G(j) could overflow, set GROW to 0. * GROW = ZERO END IF 30 CONTINUE GROW = XBND ELSE * * A is unit triangular. * * Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. * GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) ) DO 40 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 50 * * G(j) = G(j-1)*( 1 + CNORM(j) ) * GROW = GROW*( ONE / ( ONE+CNORM( J ) ) ) 40 CONTINUE END IF 50 CONTINUE * ELSE * * Compute the growth in A**T * x = b. * IF( UPPER ) THEN JFIRST = 1 JLAST = N JINC = 1 MAIND = KD + 1 ELSE JFIRST = N JLAST = 1 JINC = -1 MAIND = 1 END IF * IF( TSCAL.NE.ONE ) THEN GROW = ZERO GO TO 80 END IF * IF( NOUNIT ) THEN * * A is non-unit triangular. * * Compute GROW = 1/G(j) and XBND = 1/M(j). * Initially, M(0) = max{x(i), i=1,...,n}. * GROW = ONE / MAX( XBND, SMLNUM ) XBND = GROW DO 60 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 80 * * G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) * XJ = ONE + CNORM( J ) GROW = MIN( GROW, XBND / XJ ) * * M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) * TJJ = ABS( AB( MAIND, J ) ) IF( XJ.GT.TJJ ) $ XBND = XBND*( TJJ / XJ ) 60 CONTINUE GROW = MIN( GROW, XBND ) ELSE * * A is unit triangular. * * Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. * GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) ) DO 70 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 80 * * G(j) = ( 1 + CNORM(j) )*G(j-1) * XJ = ONE + CNORM( J ) GROW = GROW / XJ 70 CONTINUE END IF 80 CONTINUE END IF * IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN * * Use the Level 2 BLAS solve if the reciprocal of the bound on * elements of X is not too small. * CALL DTBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, X, 1 ) ELSE * * Use a Level 1 BLAS solve, scaling intermediate results. * IF( XMAX.GT.BIGNUM ) THEN * * Scale X so that its components are less than or equal to * BIGNUM in absolute value. * SCALE = BIGNUM / XMAX CALL DSCAL( N, SCALE, X, 1 ) XMAX = BIGNUM END IF * IF( NOTRAN ) THEN * * Solve A * x = b * DO 110 J = JFIRST, JLAST, JINC * * Compute x(j) = b(j) / A(j,j), scaling x if necessary. * XJ = ABS( X( J ) ) IF( NOUNIT ) THEN TJJS = AB( MAIND, J )*TSCAL ELSE TJJS = TSCAL IF( TSCAL.EQ.ONE ) $ GO TO 100 END IF TJJ = ABS( TJJS ) IF( TJJ.GT.SMLNUM ) THEN * * abs(A(j,j)) > SMLNUM: * IF( TJJ.LT.ONE ) THEN IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by 1/b(j). * REC = ONE / XJ CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF X( J ) = X( J ) / TJJS XJ = ABS( X( J ) ) ELSE IF( TJJ.GT.ZERO ) THEN * * 0 < abs(A(j,j)) <= SMLNUM: * IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM * to avoid overflow when dividing by A(j,j). * REC = ( TJJ*BIGNUM ) / XJ IF( CNORM( J ).GT.ONE ) THEN * * Scale by 1/CNORM(j) to avoid overflow when * multiplying x(j) times column j. * REC = REC / CNORM( J ) END IF CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF X( J ) = X( J ) / TJJS XJ = ABS( X( J ) ) ELSE * * A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and * scale = 0, and compute a solution to A*x = 0. * DO 90 I = 1, N X( I ) = ZERO 90 CONTINUE X( J ) = ONE XJ = ONE SCALE = ZERO XMAX = ZERO END IF 100 CONTINUE * * Scale x if necessary to avoid overflow when adding a * multiple of column j of A. * IF( XJ.GT.ONE ) THEN REC = ONE / XJ IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN * * Scale x by 1/(2*abs(x(j))). * REC = REC*HALF CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC END IF ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN * * Scale x by 1/2. * CALL DSCAL( N, HALF, X, 1 ) SCALE = SCALE*HALF END IF * IF( UPPER ) THEN IF( J.GT.1 ) THEN * * Compute the update * x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) - * x(j)* A(max(1,j-kd):j-1,j) * JLEN = MIN( KD, J-1 ) CALL DAXPY( JLEN, -X( J )*TSCAL, $ AB( KD+1-JLEN, J ), 1, X( J-JLEN ), 1 ) I = IDAMAX( J-1, X, 1 ) XMAX = ABS( X( I ) ) END IF ELSE IF( J.LT.N ) THEN * * Compute the update * x(j+1:min(j+kd,n)) := x(j+1:min(j+kd,n)) - * x(j) * A(j+1:min(j+kd,n),j) * JLEN = MIN( KD, N-J ) IF( JLEN.GT.0 ) $ CALL DAXPY( JLEN, -X( J )*TSCAL, AB( 2, J ), 1, $ X( J+1 ), 1 ) I = J + IDAMAX( N-J, X( J+1 ), 1 ) XMAX = ABS( X( I ) ) END IF 110 CONTINUE * ELSE * * Solve A**T * x = b * DO 160 J = JFIRST, JLAST, JINC * * Compute x(j) = b(j) - sum A(k,j)*x(k). * k<>j * XJ = ABS( X( J ) ) USCAL = TSCAL REC = ONE / MAX( XMAX, ONE ) IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN * * If x(j) could overflow, scale x by 1/(2*XMAX). * REC = REC*HALF IF( NOUNIT ) THEN TJJS = AB( MAIND, J )*TSCAL ELSE TJJS = TSCAL END IF TJJ = ABS( TJJS ) IF( TJJ.GT.ONE ) THEN * * Divide by A(j,j) when scaling x if A(j,j) > 1. * REC = MIN( ONE, REC*TJJ ) USCAL = USCAL / TJJS END IF IF( REC.LT.ONE ) THEN CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF * SUMJ = ZERO IF( USCAL.EQ.ONE ) THEN * * If the scaling needed for A in the dot product is 1, * call DDOT to perform the dot product. * IF( UPPER ) THEN JLEN = MIN( KD, J-1 ) SUMJ = DDOT( JLEN, AB( KD+1-JLEN, J ), 1, $ X( J-JLEN ), 1 ) ELSE JLEN = MIN( KD, N-J ) IF( JLEN.GT.0 ) $ SUMJ = DDOT( JLEN, AB( 2, J ), 1, X( J+1 ), 1 ) END IF ELSE * * Otherwise, use in-line code for the dot product. * IF( UPPER ) THEN JLEN = MIN( KD, J-1 ) DO 120 I = 1, JLEN SUMJ = SUMJ + ( AB( KD+I-JLEN, J )*USCAL )* $ X( J-JLEN-1+I ) 120 CONTINUE ELSE JLEN = MIN( KD, N-J ) DO 130 I = 1, JLEN SUMJ = SUMJ + ( AB( I+1, J )*USCAL )*X( J+I ) 130 CONTINUE END IF END IF * IF( USCAL.EQ.TSCAL ) THEN * * Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) * was not used to scale the dotproduct. * X( J ) = X( J ) - SUMJ XJ = ABS( X( J ) ) IF( NOUNIT ) THEN * * Compute x(j) = x(j) / A(j,j), scaling if necessary. * TJJS = AB( MAIND, J )*TSCAL ELSE TJJS = TSCAL IF( TSCAL.EQ.ONE ) $ GO TO 150 END IF TJJ = ABS( TJJS ) IF( TJJ.GT.SMLNUM ) THEN * * abs(A(j,j)) > SMLNUM: * IF( TJJ.LT.ONE ) THEN IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale X by 1/abs(x(j)). * REC = ONE / XJ CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF X( J ) = X( J ) / TJJS ELSE IF( TJJ.GT.ZERO ) THEN * * 0 < abs(A(j,j)) <= SMLNUM: * IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. * REC = ( TJJ*BIGNUM ) / XJ CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF X( J ) = X( J ) / TJJS ELSE * * A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and * scale = 0, and compute a solution to A**T*x = 0. * DO 140 I = 1, N X( I ) = ZERO 140 CONTINUE X( J ) = ONE SCALE = ZERO XMAX = ZERO END IF 150 CONTINUE ELSE * * Compute x(j) := x(j) / A(j,j) - sumj if the dot * product has already been divided by 1/A(j,j). * X( J ) = X( J ) / TJJS - SUMJ END IF XMAX = MAX( XMAX, ABS( X( J ) ) ) 160 CONTINUE END IF SCALE = SCALE / TSCAL END IF * * Scale the column norms by 1/TSCAL for return. * IF( TSCAL.NE.ONE ) THEN CALL DSCAL( N, ONE / TSCAL, CNORM, 1 ) END IF * RETURN * * End of DLATBS * END *> \brief \b DLATDF uses the LU factorization of the n-by-n matrix computed by sgetc2 and computes a contribution to the reciprocal Dif-estimate. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLATDF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, * JPIV ) * * .. Scalar Arguments .. * INTEGER IJOB, LDZ, N * DOUBLE PRECISION RDSCAL, RDSUM * .. * .. Array Arguments .. * INTEGER IPIV( * ), JPIV( * ) * DOUBLE PRECISION RHS( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLATDF uses the LU factorization of the n-by-n matrix Z computed by *> DGETC2 and computes a contribution to the reciprocal Dif-estimate *> by solving Z * x = b for x, and choosing the r.h.s. b such that *> the norm of x is as large as possible. On entry RHS = b holds the *> contribution from earlier solved sub-systems, and on return RHS = x. *> *> The factorization of Z returned by DGETC2 has the form Z = P*L*U*Q, *> where P and Q are permutation matrices. L is lower triangular with *> unit diagonal elements and U is upper triangular. *> \endverbatim * * Arguments: * ========== * *> \param[in] IJOB *> \verbatim *> IJOB is INTEGER *> IJOB = 2: First compute an approximative null-vector e *> of Z using DGECON, e is normalized and solve for *> Zx = +-e - f with the sign giving the greater value *> of 2-norm(x). About 5 times as expensive as Default. *> IJOB .ne. 2: Local look ahead strategy where all entries of *> the r.h.s. b is chosen as either +1 or -1 (Default). *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix Z. *> \endverbatim *> *> \param[in] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ, N) *> On entry, the LU part of the factorization of the n-by-n *> matrix Z computed by DGETC2: Z = P * L * U * Q *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDA >= max(1, N). *> \endverbatim *> *> \param[in,out] RHS *> \verbatim *> RHS is DOUBLE PRECISION array, dimension (N) *> On entry, RHS contains contributions from other subsystems. *> On exit, RHS contains the solution of the subsystem with *> entries acoording to the value of IJOB (see above). *> \endverbatim *> *> \param[in,out] RDSUM *> \verbatim *> RDSUM is DOUBLE PRECISION *> On entry, the sum of squares of computed contributions to *> the Dif-estimate under computation by DTGSYL, where the *> scaling factor RDSCAL (see below) has been factored out. *> On exit, the corresponding sum of squares updated with the *> contributions from the current sub-system. *> If TRANS = 'T' RDSUM is not touched. *> NOTE: RDSUM only makes sense when DTGSY2 is called by STGSYL. *> \endverbatim *> *> \param[in,out] RDSCAL *> \verbatim *> RDSCAL is DOUBLE PRECISION *> On entry, scaling factor used to prevent overflow in RDSUM. *> On exit, RDSCAL is updated w.r.t. the current contributions *> in RDSUM. *> If TRANS = 'T', RDSCAL is not touched. *> NOTE: RDSCAL only makes sense when DTGSY2 is called by *> DTGSYL. *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N). *> The pivot indices; for 1 <= i <= N, row i of the *> matrix has been interchanged with row IPIV(i). *> \endverbatim *> *> \param[in] JPIV *> \verbatim *> JPIV is INTEGER array, dimension (N). *> The pivot indices; for 1 <= j <= N, column j of the *> matrix has been interchanged with column JPIV(j). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Further Details: * ===================== *> *> This routine is a further developed implementation of algorithm *> BSOLVE in [1] using complete pivoting in the LU factorization. * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * *> \par References: * ================ *> *> \verbatim *> *> *> [1] Bo Kagstrom and Lars Westin, *> Generalized Schur Methods with Condition Estimators for *> Solving the Generalized Sylvester Equation, IEEE Transactions *> on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751. *> *> [2] Peter Poromaa, *> On Efficient and Robust Estimators for the Separation *> between two Regular Matrix Pairs with Applications in *> Condition Estimation. Report IMINF-95.05, Departement of *> Computing Science, Umea University, S-901 87 Umea, Sweden, 1995. *> \endverbatim *> * ===================================================================== SUBROUTINE DLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, $ JPIV ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. INTEGER IJOB, LDZ, N DOUBLE PRECISION RDSCAL, RDSUM * .. * .. Array Arguments .. INTEGER IPIV( * ), JPIV( * ) DOUBLE PRECISION RHS( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER MAXDIM PARAMETER ( MAXDIM = 8 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, INFO, J, K DOUBLE PRECISION BM, BP, PMONE, SMINU, SPLUS, TEMP * .. * .. Local Arrays .. INTEGER IWORK( MAXDIM ) DOUBLE PRECISION WORK( 4*MAXDIM ), XM( MAXDIM ), XP( MAXDIM ) * .. * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGECON, DGESC2, DLASSQ, DLASWP, $ DSCAL * .. * .. External Functions .. DOUBLE PRECISION DASUM, DDOT EXTERNAL DASUM, DDOT * .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT * .. * .. Executable Statements .. * IF( IJOB.NE.2 ) THEN * * Apply permutations IPIV to RHS * CALL DLASWP( 1, RHS, LDZ, 1, N-1, IPIV, 1 ) * * Solve for L-part choosing RHS either to +1 or -1. * PMONE = -ONE * DO 10 J = 1, N - 1 BP = RHS( J ) + ONE BM = RHS( J ) - ONE SPLUS = ONE * * Look-ahead for L-part RHS(1:N-1) = + or -1, SPLUS and * SMIN computed more efficiently than in BSOLVE [1]. * SPLUS = SPLUS + DDOT( N-J, Z( J+1, J ), 1, Z( J+1, J ), 1 ) SMINU = DDOT( N-J, Z( J+1, J ), 1, RHS( J+1 ), 1 ) SPLUS = SPLUS*RHS( J ) IF( SPLUS.GT.SMINU ) THEN RHS( J ) = BP ELSE IF( SMINU.GT.SPLUS ) THEN RHS( J ) = BM ELSE * * In this case the updating sums are equal and we can * choose RHS(J) +1 or -1. The first time this happens * we choose -1, thereafter +1. This is a simple way to * get good estimates of matrices like Byers well-known * example (see [1]). (Not done in BSOLVE.) * RHS( J ) = RHS( J ) + PMONE PMONE = ONE END IF * * Compute the remaining r.h.s. * TEMP = -RHS( J ) CALL DAXPY( N-J, TEMP, Z( J+1, J ), 1, RHS( J+1 ), 1 ) * 10 CONTINUE * * Solve for U-part, look-ahead for RHS(N) = +-1. This is not done * in BSOLVE and will hopefully give us a better estimate because * any ill-conditioning of the original matrix is transfered to U * and not to L. U(N, N) is an approximation to sigma_min(LU). * CALL DCOPY( N-1, RHS, 1, XP, 1 ) XP( N ) = RHS( N ) + ONE RHS( N ) = RHS( N ) - ONE SPLUS = ZERO SMINU = ZERO DO 30 I = N, 1, -1 TEMP = ONE / Z( I, I ) XP( I ) = XP( I )*TEMP RHS( I ) = RHS( I )*TEMP DO 20 K = I + 1, N XP( I ) = XP( I ) - XP( K )*( Z( I, K )*TEMP ) RHS( I ) = RHS( I ) - RHS( K )*( Z( I, K )*TEMP ) 20 CONTINUE SPLUS = SPLUS + ABS( XP( I ) ) SMINU = SMINU + ABS( RHS( I ) ) 30 CONTINUE IF( SPLUS.GT.SMINU ) $ CALL DCOPY( N, XP, 1, RHS, 1 ) * * Apply the permutations JPIV to the computed solution (RHS) * CALL DLASWP( 1, RHS, LDZ, 1, N-1, JPIV, -1 ) * * Compute the sum of squares * CALL DLASSQ( N, RHS, 1, RDSCAL, RDSUM ) * ELSE * * IJOB = 2, Compute approximate nullvector XM of Z * CALL DGECON( 'I', N, Z, LDZ, ONE, TEMP, WORK, IWORK, INFO ) CALL DCOPY( N, WORK( N+1 ), 1, XM, 1 ) * * Compute RHS * CALL DLASWP( 1, XM, LDZ, 1, N-1, IPIV, -1 ) TEMP = ONE / SQRT( DDOT( N, XM, 1, XM, 1 ) ) CALL DSCAL( N, TEMP, XM, 1 ) CALL DCOPY( N, XM, 1, XP, 1 ) CALL DAXPY( N, ONE, RHS, 1, XP, 1 ) CALL DAXPY( N, -ONE, XM, 1, RHS, 1 ) CALL DGESC2( N, Z, LDZ, RHS, IPIV, JPIV, TEMP ) CALL DGESC2( N, Z, LDZ, XP, IPIV, JPIV, TEMP ) IF( DASUM( N, XP, 1 ).GT.DASUM( N, RHS, 1 ) ) $ CALL DCOPY( N, XP, 1, RHS, 1 ) * * Compute the sum of squares * CALL DLASSQ( N, RHS, 1, RDSCAL, RDSUM ) * END IF * RETURN * * End of DLATDF * END *> \brief \b DLATPS solves a triangular system of equations with the matrix held in packed storage. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLATPS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, * CNORM, INFO ) * * .. Scalar Arguments .. * CHARACTER DIAG, NORMIN, TRANS, UPLO * INTEGER INFO, N * DOUBLE PRECISION SCALE * .. * .. Array Arguments .. * DOUBLE PRECISION AP( * ), CNORM( * ), X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLATPS solves one of the triangular systems *> *> A *x = s*b or A**T*x = s*b *> *> with scaling to prevent overflow, where A is an upper or lower *> triangular matrix stored in packed form. Here A**T denotes the *> transpose of A, x and b are n-element vectors, and s is a scaling *> factor, usually less than or equal to 1, chosen so that the *> components of x will be less than the overflow threshold. If the *> unscaled problem will not cause overflow, the Level 2 BLAS routine *> DTPSV is called. If the matrix A is singular (A(j,j) = 0 for some j), *> then s is set to 0 and a non-trivial solution to A*x = 0 is returned. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the matrix A is upper or lower triangular. *> = 'U': Upper triangular *> = 'L': Lower triangular *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> Specifies the operation applied to A. *> = 'N': Solve A * x = s*b (No transpose) *> = 'T': Solve A**T* x = s*b (Transpose) *> = 'C': Solve A**T* x = s*b (Conjugate transpose = Transpose) *> \endverbatim *> *> \param[in] DIAG *> \verbatim *> DIAG is CHARACTER*1 *> Specifies whether or not the matrix A is unit triangular. *> = 'N': Non-unit triangular *> = 'U': Unit triangular *> \endverbatim *> *> \param[in] NORMIN *> \verbatim *> NORMIN is CHARACTER*1 *> Specifies whether CNORM has been set or not. *> = 'Y': CNORM contains the column norms on entry *> = 'N': CNORM is not set on entry. On exit, the norms will *> be computed and stored in CNORM. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> The upper or lower triangular matrix A, packed columnwise in *> a linear array. The j-th column of A is stored in the array *> AP as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (N) *> On entry, the right hand side b of the triangular system. *> On exit, X is overwritten by the solution vector x. *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is DOUBLE PRECISION *> The scaling factor s for the triangular system *> A * x = s*b or A**T* x = s*b. *> If SCALE = 0, the matrix A is singular or badly scaled, and *> the vector x is an exact or approximate solution to A*x = 0. *> \endverbatim *> *> \param[in,out] CNORM *> \verbatim *> CNORM is DOUBLE PRECISION array, dimension (N) *> *> If NORMIN = 'Y', CNORM is an input argument and CNORM(j) *> contains the norm of the off-diagonal part of the j-th column *> of A. If TRANS = 'N', CNORM(j) must be greater than or equal *> to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) *> must be greater than or equal to the 1-norm. *> *> If NORMIN = 'N', CNORM is an output argument and CNORM(j) *> returns the 1-norm of the offdiagonal part of the j-th column *> of A. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -k, the k-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> A rough bound on x is computed; if that is less than overflow, DTPSV *> is called, otherwise, specific code is used which checks for possible *> overflow or divide-by-zero at every operation. *> *> A columnwise scheme is used for solving A*x = b. The basic algorithm *> if A is lower triangular is *> *> x[1:n] := b[1:n] *> for j = 1, ..., n *> x(j) := x(j) / A(j,j) *> x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] *> end *> *> Define bounds on the components of x after j iterations of the loop: *> M(j) = bound on x[1:j] *> G(j) = bound on x[j+1:n] *> Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. *> *> Then for iteration j+1 we have *> M(j+1) <= G(j) / | A(j+1,j+1) | *> G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | *> <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) *> *> where CNORM(j+1) is greater than or equal to the infinity-norm of *> column j+1 of A, not counting the diagonal. Hence *> *> G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) *> 1<=i<=j *> and *> *> |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) *> 1<=i< j *> *> Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTPSV if the *> reciprocal of the largest M(j), j=1,..,n, is larger than *> max(underflow, 1/overflow). *> *> The bound on x(j) is also used to determine when a step in the *> columnwise method can be performed without fear of overflow. If *> the computed bound is greater than a large constant, x is scaled to *> prevent overflow, but if the bound overflows, x is set to 0, x(j) to *> 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. *> *> Similarly, a row-wise scheme is used to solve A**T*x = b. The basic *> algorithm for A upper triangular is *> *> for j = 1, ..., n *> x(j) := ( b(j) - A[1:j-1,j]**T * x[1:j-1] ) / A(j,j) *> end *> *> We simultaneously compute two bounds *> G(j) = bound on ( b(i) - A[1:i-1,i]**T * x[1:i-1] ), 1<=i<=j *> M(j) = bound on x(i), 1<=i<=j *> *> The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we *> add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. *> Then the bound on x(j) is *> *> M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | *> *> <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) *> 1<=i<=j *> *> and we can safely call DTPSV if 1/M(n) and 1/G(n) are both greater *> than max(underflow, 1/overflow). *> \endverbatim *> * ===================================================================== SUBROUTINE DLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, $ CNORM, INFO ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO INTEGER INFO, N DOUBLE PRECISION SCALE * .. * .. Array Arguments .. DOUBLE PRECISION AP( * ), CNORM( * ), X( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOTRAN, NOUNIT, UPPER INTEGER I, IMAX, IP, J, JFIRST, JINC, JLAST, JLEN DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS, $ TMAX, TSCAL, USCAL, XBND, XJ, XMAX * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DASUM, DDOT, DLAMCH EXTERNAL LSAME, IDAMAX, DASUM, DDOT, DLAMCH * .. * .. External Subroutines .. EXTERNAL DAXPY, DSCAL, DTPSV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. Executable Statements .. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) NOTRAN = LSAME( TRANS, 'N' ) NOUNIT = LSAME( DIAG, 'N' ) * * Test the input parameters. * IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. $ LSAME( TRANS, 'C' ) ) THEN INFO = -2 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -3 ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT. $ LSAME( NORMIN, 'N' ) ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLATPS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Determine machine dependent parameters to control overflow. * SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) BIGNUM = ONE / SMLNUM SCALE = ONE * IF( LSAME( NORMIN, 'N' ) ) THEN * * Compute the 1-norm of each column, not including the diagonal. * IF( UPPER ) THEN * * A is upper triangular. * IP = 1 DO 10 J = 1, N CNORM( J ) = DASUM( J-1, AP( IP ), 1 ) IP = IP + J 10 CONTINUE ELSE * * A is lower triangular. * IP = 1 DO 20 J = 1, N - 1 CNORM( J ) = DASUM( N-J, AP( IP+1 ), 1 ) IP = IP + N - J + 1 20 CONTINUE CNORM( N ) = ZERO END IF END IF * * Scale the column norms by TSCAL if the maximum element in CNORM is * greater than BIGNUM. * IMAX = IDAMAX( N, CNORM, 1 ) TMAX = CNORM( IMAX ) IF( TMAX.LE.BIGNUM ) THEN TSCAL = ONE ELSE TSCAL = ONE / ( SMLNUM*TMAX ) CALL DSCAL( N, TSCAL, CNORM, 1 ) END IF * * Compute a bound on the computed solution vector to see if the * Level 2 BLAS routine DTPSV can be used. * J = IDAMAX( N, X, 1 ) XMAX = ABS( X( J ) ) XBND = XMAX IF( NOTRAN ) THEN * * Compute the growth in A * x = b. * IF( UPPER ) THEN JFIRST = N JLAST = 1 JINC = -1 ELSE JFIRST = 1 JLAST = N JINC = 1 END IF * IF( TSCAL.NE.ONE ) THEN GROW = ZERO GO TO 50 END IF * IF( NOUNIT ) THEN * * A is non-unit triangular. * * Compute GROW = 1/G(j) and XBND = 1/M(j). * Initially, G(0) = max{x(i), i=1,...,n}. * GROW = ONE / MAX( XBND, SMLNUM ) XBND = GROW IP = JFIRST*( JFIRST+1 ) / 2 JLEN = N DO 30 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 50 * * M(j) = G(j-1) / abs(A(j,j)) * TJJ = ABS( AP( IP ) ) XBND = MIN( XBND, MIN( ONE, TJJ )*GROW ) IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN * * G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) * GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) ) ELSE * * G(j) could overflow, set GROW to 0. * GROW = ZERO END IF IP = IP + JINC*JLEN JLEN = JLEN - 1 30 CONTINUE GROW = XBND ELSE * * A is unit triangular. * * Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. * GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) ) DO 40 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 50 * * G(j) = G(j-1)*( 1 + CNORM(j) ) * GROW = GROW*( ONE / ( ONE+CNORM( J ) ) ) 40 CONTINUE END IF 50 CONTINUE * ELSE * * Compute the growth in A**T * x = b. * IF( UPPER ) THEN JFIRST = 1 JLAST = N JINC = 1 ELSE JFIRST = N JLAST = 1 JINC = -1 END IF * IF( TSCAL.NE.ONE ) THEN GROW = ZERO GO TO 80 END IF * IF( NOUNIT ) THEN * * A is non-unit triangular. * * Compute GROW = 1/G(j) and XBND = 1/M(j). * Initially, M(0) = max{x(i), i=1,...,n}. * GROW = ONE / MAX( XBND, SMLNUM ) XBND = GROW IP = JFIRST*( JFIRST+1 ) / 2 JLEN = 1 DO 60 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 80 * * G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) * XJ = ONE + CNORM( J ) GROW = MIN( GROW, XBND / XJ ) * * M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) * TJJ = ABS( AP( IP ) ) IF( XJ.GT.TJJ ) $ XBND = XBND*( TJJ / XJ ) JLEN = JLEN + 1 IP = IP + JINC*JLEN 60 CONTINUE GROW = MIN( GROW, XBND ) ELSE * * A is unit triangular. * * Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. * GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) ) DO 70 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 80 * * G(j) = ( 1 + CNORM(j) )*G(j-1) * XJ = ONE + CNORM( J ) GROW = GROW / XJ 70 CONTINUE END IF 80 CONTINUE END IF * IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN * * Use the Level 2 BLAS solve if the reciprocal of the bound on * elements of X is not too small. * CALL DTPSV( UPLO, TRANS, DIAG, N, AP, X, 1 ) ELSE * * Use a Level 1 BLAS solve, scaling intermediate results. * IF( XMAX.GT.BIGNUM ) THEN * * Scale X so that its components are less than or equal to * BIGNUM in absolute value. * SCALE = BIGNUM / XMAX CALL DSCAL( N, SCALE, X, 1 ) XMAX = BIGNUM END IF * IF( NOTRAN ) THEN * * Solve A * x = b * IP = JFIRST*( JFIRST+1 ) / 2 DO 110 J = JFIRST, JLAST, JINC * * Compute x(j) = b(j) / A(j,j), scaling x if necessary. * XJ = ABS( X( J ) ) IF( NOUNIT ) THEN TJJS = AP( IP )*TSCAL ELSE TJJS = TSCAL IF( TSCAL.EQ.ONE ) $ GO TO 100 END IF TJJ = ABS( TJJS ) IF( TJJ.GT.SMLNUM ) THEN * * abs(A(j,j)) > SMLNUM: * IF( TJJ.LT.ONE ) THEN IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by 1/b(j). * REC = ONE / XJ CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF X( J ) = X( J ) / TJJS XJ = ABS( X( J ) ) ELSE IF( TJJ.GT.ZERO ) THEN * * 0 < abs(A(j,j)) <= SMLNUM: * IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM * to avoid overflow when dividing by A(j,j). * REC = ( TJJ*BIGNUM ) / XJ IF( CNORM( J ).GT.ONE ) THEN * * Scale by 1/CNORM(j) to avoid overflow when * multiplying x(j) times column j. * REC = REC / CNORM( J ) END IF CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF X( J ) = X( J ) / TJJS XJ = ABS( X( J ) ) ELSE * * A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and * scale = 0, and compute a solution to A*x = 0. * DO 90 I = 1, N X( I ) = ZERO 90 CONTINUE X( J ) = ONE XJ = ONE SCALE = ZERO XMAX = ZERO END IF 100 CONTINUE * * Scale x if necessary to avoid overflow when adding a * multiple of column j of A. * IF( XJ.GT.ONE ) THEN REC = ONE / XJ IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN * * Scale x by 1/(2*abs(x(j))). * REC = REC*HALF CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC END IF ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN * * Scale x by 1/2. * CALL DSCAL( N, HALF, X, 1 ) SCALE = SCALE*HALF END IF * IF( UPPER ) THEN IF( J.GT.1 ) THEN * * Compute the update * x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) * CALL DAXPY( J-1, -X( J )*TSCAL, AP( IP-J+1 ), 1, X, $ 1 ) I = IDAMAX( J-1, X, 1 ) XMAX = ABS( X( I ) ) END IF IP = IP - J ELSE IF( J.LT.N ) THEN * * Compute the update * x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) * CALL DAXPY( N-J, -X( J )*TSCAL, AP( IP+1 ), 1, $ X( J+1 ), 1 ) I = J + IDAMAX( N-J, X( J+1 ), 1 ) XMAX = ABS( X( I ) ) END IF IP = IP + N - J + 1 END IF 110 CONTINUE * ELSE * * Solve A**T * x = b * IP = JFIRST*( JFIRST+1 ) / 2 JLEN = 1 DO 160 J = JFIRST, JLAST, JINC * * Compute x(j) = b(j) - sum A(k,j)*x(k). * k<>j * XJ = ABS( X( J ) ) USCAL = TSCAL REC = ONE / MAX( XMAX, ONE ) IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN * * If x(j) could overflow, scale x by 1/(2*XMAX). * REC = REC*HALF IF( NOUNIT ) THEN TJJS = AP( IP )*TSCAL ELSE TJJS = TSCAL END IF TJJ = ABS( TJJS ) IF( TJJ.GT.ONE ) THEN * * Divide by A(j,j) when scaling x if A(j,j) > 1. * REC = MIN( ONE, REC*TJJ ) USCAL = USCAL / TJJS END IF IF( REC.LT.ONE ) THEN CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF * SUMJ = ZERO IF( USCAL.EQ.ONE ) THEN * * If the scaling needed for A in the dot product is 1, * call DDOT to perform the dot product. * IF( UPPER ) THEN SUMJ = DDOT( J-1, AP( IP-J+1 ), 1, X, 1 ) ELSE IF( J.LT.N ) THEN SUMJ = DDOT( N-J, AP( IP+1 ), 1, X( J+1 ), 1 ) END IF ELSE * * Otherwise, use in-line code for the dot product. * IF( UPPER ) THEN DO 120 I = 1, J - 1 SUMJ = SUMJ + ( AP( IP-J+I )*USCAL )*X( I ) 120 CONTINUE ELSE IF( J.LT.N ) THEN DO 130 I = 1, N - J SUMJ = SUMJ + ( AP( IP+I )*USCAL )*X( J+I ) 130 CONTINUE END IF END IF * IF( USCAL.EQ.TSCAL ) THEN * * Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) * was not used to scale the dotproduct. * X( J ) = X( J ) - SUMJ XJ = ABS( X( J ) ) IF( NOUNIT ) THEN * * Compute x(j) = x(j) / A(j,j), scaling if necessary. * TJJS = AP( IP )*TSCAL ELSE TJJS = TSCAL IF( TSCAL.EQ.ONE ) $ GO TO 150 END IF TJJ = ABS( TJJS ) IF( TJJ.GT.SMLNUM ) THEN * * abs(A(j,j)) > SMLNUM: * IF( TJJ.LT.ONE ) THEN IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale X by 1/abs(x(j)). * REC = ONE / XJ CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF X( J ) = X( J ) / TJJS ELSE IF( TJJ.GT.ZERO ) THEN * * 0 < abs(A(j,j)) <= SMLNUM: * IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. * REC = ( TJJ*BIGNUM ) / XJ CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF X( J ) = X( J ) / TJJS ELSE * * A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and * scale = 0, and compute a solution to A**T*x = 0. * DO 140 I = 1, N X( I ) = ZERO 140 CONTINUE X( J ) = ONE SCALE = ZERO XMAX = ZERO END IF 150 CONTINUE ELSE * * Compute x(j) := x(j) / A(j,j) - sumj if the dot * product has already been divided by 1/A(j,j). * X( J ) = X( J ) / TJJS - SUMJ END IF XMAX = MAX( XMAX, ABS( X( J ) ) ) JLEN = JLEN + 1 IP = IP + JINC*JLEN 160 CONTINUE END IF SCALE = SCALE / TSCAL END IF * * Scale the column norms by 1/TSCAL for return. * IF( TSCAL.NE.ONE ) THEN CALL DSCAL( N, ONE / TSCAL, CNORM, 1 ) END IF * RETURN * * End of DLATPS * END *> \brief \b DLATRD reduces the first nb rows and columns of a symmetric/Hermitian matrix A to real tridiagonal form by an orthogonal similarity transformation. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLATRD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDW, N, NB * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), E( * ), TAU( * ), W( LDW, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLATRD reduces NB rows and columns of a real symmetric matrix A to *> symmetric tridiagonal form by an orthogonal similarity *> transformation Q**T * A * Q, and returns the matrices V and W which are *> needed to apply the transformation to the unreduced part of A. *> *> If UPLO = 'U', DLATRD reduces the last NB rows and columns of a *> matrix, of which the upper triangle is supplied; *> if UPLO = 'L', DLATRD reduces the first NB rows and columns of a *> matrix, of which the lower triangle is supplied. *> *> This is an auxiliary routine called by DSYTRD. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the upper or lower triangular part of the *> symmetric matrix A is stored: *> = 'U': Upper triangular *> = 'L': Lower triangular *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. *> \endverbatim *> *> \param[in] NB *> \verbatim *> NB is INTEGER *> The number of rows and columns to be reduced. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the symmetric matrix A. If UPLO = 'U', the leading *> n-by-n upper triangular part of A contains the upper *> triangular part of the matrix A, and the strictly lower *> triangular part of A is not referenced. If UPLO = 'L', the *> leading n-by-n lower triangular part of A contains the lower *> triangular part of the matrix A, and the strictly upper *> triangular part of A is not referenced. *> On exit: *> if UPLO = 'U', the last NB columns have been reduced to *> tridiagonal form, with the diagonal elements overwriting *> the diagonal elements of A; the elements above the diagonal *> with the array TAU, represent the orthogonal matrix Q as a *> product of elementary reflectors; *> if UPLO = 'L', the first NB columns have been reduced to *> tridiagonal form, with the diagonal elements overwriting *> the diagonal elements of A; the elements below the diagonal *> with the array TAU, represent the orthogonal matrix Q as a *> product of elementary reflectors. *> See Further Details. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= (1,N). *> \endverbatim *> *> \param[out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N-1) *> If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal *> elements of the last NB columns of the reduced matrix; *> if UPLO = 'L', E(1:nb) contains the subdiagonal elements of *> the first NB columns of the reduced matrix. *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (N-1) *> The scalar factors of the elementary reflectors, stored in *> TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. *> See Further Details. *> \endverbatim *> *> \param[out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (LDW,NB) *> The n-by-nb matrix W required to update the unreduced part *> of A. *> \endverbatim *> *> \param[in] LDW *> \verbatim *> LDW is INTEGER *> The leading dimension of the array W. LDW >= max(1,N). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> If UPLO = 'U', the matrix Q is represented as a product of elementary *> reflectors *> *> Q = H(n) H(n-1) . . . H(n-nb+1). *> *> Each H(i) has the form *> *> H(i) = I - tau * v * v**T *> *> where tau is a real scalar, and v is a real vector with *> v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), *> and tau in TAU(i-1). *> *> If UPLO = 'L', the matrix Q is represented as a product of elementary *> reflectors *> *> Q = H(1) H(2) . . . H(nb). *> *> Each H(i) has the form *> *> H(i) = I - tau * v * v**T *> *> where tau is a real scalar, and v is a real vector with *> v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), *> and tau in TAU(i). *> *> The elements of the vectors v together form the n-by-nb matrix V *> which is needed, with W, to apply the transformation to the unreduced *> part of the matrix, using a symmetric rank-2k update of the form: *> A := A - V*W**T - W*V**T. *> *> The contents of A on exit are illustrated by the following examples *> with n = 5 and nb = 2: *> *> if UPLO = 'U': if UPLO = 'L': *> *> ( a a a v4 v5 ) ( d ) *> ( a a v4 v5 ) ( 1 d ) *> ( a 1 v5 ) ( v1 1 a ) *> ( d 1 ) ( v1 v2 a a ) *> ( d ) ( v1 v2 a a a ) *> *> where d denotes a diagonal element of the reduced matrix, a denotes *> an element of the original matrix that is unchanged, and vi denotes *> an element of the vector defining H(i). *> \endverbatim *> * ===================================================================== SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER LDA, LDW, N, NB * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), E( * ), TAU( * ), W( LDW, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, HALF PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) * .. * .. Local Scalars .. INTEGER I, IW DOUBLE PRECISION ALPHA * .. * .. External Subroutines .. EXTERNAL DAXPY, DGEMV, DLARFG, DSCAL, DSYMV * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT EXTERNAL LSAME, DDOT * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * * Quick return if possible * IF( N.LE.0 ) $ RETURN * IF( LSAME( UPLO, 'U' ) ) THEN * * Reduce last NB columns of upper triangle * DO 10 I = N, N - NB + 1, -1 IW = I - N + NB IF( I.LT.N ) THEN * * Update A(1:i,i) * CALL DGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ), $ LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 ) CALL DGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ), $ LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 ) END IF IF( I.GT.1 ) THEN * * Generate elementary reflector H(i) to annihilate * A(1:i-2,i) * CALL DLARFG( I-1, A( I-1, I ), A( 1, I ), 1, TAU( I-1 ) ) E( I-1 ) = A( I-1, I ) A( I-1, I ) = ONE * * Compute W(1:i-1,i) * CALL DSYMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1, $ ZERO, W( 1, IW ), 1 ) IF( I.LT.N ) THEN CALL DGEMV( 'Transpose', I-1, N-I, ONE, W( 1, IW+1 ), $ LDW, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 ) CALL DGEMV( 'No transpose', I-1, N-I, -ONE, $ A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE, $ W( 1, IW ), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, A( 1, I+1 ), $ LDA, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 ) CALL DGEMV( 'No transpose', I-1, N-I, -ONE, $ W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE, $ W( 1, IW ), 1 ) END IF CALL DSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 ) ALPHA = -HALF*TAU( I-1 )*DDOT( I-1, W( 1, IW ), 1, $ A( 1, I ), 1 ) CALL DAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 ) END IF * 10 CONTINUE ELSE * * Reduce first NB columns of lower triangle * DO 20 I = 1, NB * * Update A(i:n,i) * CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ), $ LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 ) CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ), $ LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 ) IF( I.LT.N ) THEN * * Generate elementary reflector H(i) to annihilate * A(i+2:n,i) * CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, $ TAU( I ) ) E( I ) = A( I+1, I ) A( I+1, I ) = ONE * * Compute W(i+1:n,i) * CALL DSYMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA, $ A( I+1, I ), 1, ZERO, W( I+1, I ), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, W( I+1, 1 ), LDW, $ A( I+1, I ), 1, ZERO, W( 1, I ), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ), $ LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA, $ A( I+1, I ), 1, ZERO, W( 1, I ), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ), $ LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) CALL DSCAL( N-I, TAU( I ), W( I+1, I ), 1 ) ALPHA = -HALF*TAU( I )*DDOT( N-I, W( I+1, I ), 1, $ A( I+1, I ), 1 ) CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 ) END IF * 20 CONTINUE END IF * RETURN * * End of DLATRD * END *> \brief \b DLATRS solves a triangular system of equations with the scale factor set to prevent overflow. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLATRS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, * CNORM, INFO ) * * .. Scalar Arguments .. * CHARACTER DIAG, NORMIN, TRANS, UPLO * INTEGER INFO, LDA, N * DOUBLE PRECISION SCALE * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), CNORM( * ), X( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLATRS solves one of the triangular systems *> *> A *x = s*b or A**T *x = s*b *> *> with scaling to prevent overflow. Here A is an upper or lower *> triangular matrix, A**T denotes the transpose of A, x and b are *> n-element vectors, and s is a scaling factor, usually less than *> or equal to 1, chosen so that the components of x will be less than *> the overflow threshold. If the unscaled problem will not cause *> overflow, the Level 2 BLAS routine DTRSV is called. If the matrix A *> is singular (A(j,j) = 0 for some j), then s is set to 0 and a *> non-trivial solution to A*x = 0 is returned. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the matrix A is upper or lower triangular. *> = 'U': Upper triangular *> = 'L': Lower triangular *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> Specifies the operation applied to A. *> = 'N': Solve A * x = s*b (No transpose) *> = 'T': Solve A**T* x = s*b (Transpose) *> = 'C': Solve A**T* x = s*b (Conjugate transpose = Transpose) *> \endverbatim *> *> \param[in] DIAG *> \verbatim *> DIAG is CHARACTER*1 *> Specifies whether or not the matrix A is unit triangular. *> = 'N': Non-unit triangular *> = 'U': Unit triangular *> \endverbatim *> *> \param[in] NORMIN *> \verbatim *> NORMIN is CHARACTER*1 *> Specifies whether CNORM has been set or not. *> = 'Y': CNORM contains the column norms on entry *> = 'N': CNORM is not set on entry. On exit, the norms will *> be computed and stored in CNORM. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The triangular matrix A. If UPLO = 'U', the leading n by n *> upper triangular part of the array A contains the upper *> triangular matrix, and the strictly lower triangular part of *> A is not referenced. If UPLO = 'L', the leading n by n lower *> triangular part of the array A contains the lower triangular *> matrix, and the strictly upper triangular part of A is not *> referenced. If DIAG = 'U', the diagonal elements of A are *> also not referenced and are assumed to be 1. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max (1,N). *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (N) *> On entry, the right hand side b of the triangular system. *> On exit, X is overwritten by the solution vector x. *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is DOUBLE PRECISION *> The scaling factor s for the triangular system *> A * x = s*b or A**T* x = s*b. *> If SCALE = 0, the matrix A is singular or badly scaled, and *> the vector x is an exact or approximate solution to A*x = 0. *> \endverbatim *> *> \param[in,out] CNORM *> \verbatim *> CNORM is DOUBLE PRECISION array, dimension (N) *> *> If NORMIN = 'Y', CNORM is an input argument and CNORM(j) *> contains the norm of the off-diagonal part of the j-th column *> of A. If TRANS = 'N', CNORM(j) must be greater than or equal *> to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) *> must be greater than or equal to the 1-norm. *> *> If NORMIN = 'N', CNORM is an output argument and CNORM(j) *> returns the 1-norm of the offdiagonal part of the j-th column *> of A. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -k, the k-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> A rough bound on x is computed; if that is less than overflow, DTRSV *> is called, otherwise, specific code is used which checks for possible *> overflow or divide-by-zero at every operation. *> *> A columnwise scheme is used for solving A*x = b. The basic algorithm *> if A is lower triangular is *> *> x[1:n] := b[1:n] *> for j = 1, ..., n *> x(j) := x(j) / A(j,j) *> x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] *> end *> *> Define bounds on the components of x after j iterations of the loop: *> M(j) = bound on x[1:j] *> G(j) = bound on x[j+1:n] *> Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. *> *> Then for iteration j+1 we have *> M(j+1) <= G(j) / | A(j+1,j+1) | *> G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | *> <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) *> *> where CNORM(j+1) is greater than or equal to the infinity-norm of *> column j+1 of A, not counting the diagonal. Hence *> *> G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) *> 1<=i<=j *> and *> *> |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) *> 1<=i< j *> *> Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTRSV if the *> reciprocal of the largest M(j), j=1,..,n, is larger than *> max(underflow, 1/overflow). *> *> The bound on x(j) is also used to determine when a step in the *> columnwise method can be performed without fear of overflow. If *> the computed bound is greater than a large constant, x is scaled to *> prevent overflow, but if the bound overflows, x is set to 0, x(j) to *> 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. *> *> Similarly, a row-wise scheme is used to solve A**T*x = b. The basic *> algorithm for A upper triangular is *> *> for j = 1, ..., n *> x(j) := ( b(j) - A[1:j-1,j]**T * x[1:j-1] ) / A(j,j) *> end *> *> We simultaneously compute two bounds *> G(j) = bound on ( b(i) - A[1:i-1,i]**T * x[1:i-1] ), 1<=i<=j *> M(j) = bound on x(i), 1<=i<=j *> *> The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we *> add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. *> Then the bound on x(j) is *> *> M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | *> *> <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) *> 1<=i<=j *> *> and we can safely call DTRSV if 1/M(n) and 1/G(n) are both greater *> than max(underflow, 1/overflow). *> \endverbatim *> * ===================================================================== SUBROUTINE DLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, $ CNORM, INFO ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO INTEGER INFO, LDA, N DOUBLE PRECISION SCALE * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), CNORM( * ), X( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOTRAN, NOUNIT, UPPER INTEGER I, IMAX, J, JFIRST, JINC, JLAST DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS, $ TMAX, TSCAL, USCAL, XBND, XJ, XMAX * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DASUM, DDOT, DLAMCH EXTERNAL LSAME, IDAMAX, DASUM, DDOT, DLAMCH * .. * .. External Subroutines .. EXTERNAL DAXPY, DSCAL, DTRSV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. Executable Statements .. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) NOTRAN = LSAME( TRANS, 'N' ) NOUNIT = LSAME( DIAG, 'N' ) * * Test the input parameters. * IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. $ LSAME( TRANS, 'C' ) ) THEN INFO = -2 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -3 ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT. $ LSAME( NORMIN, 'N' ) ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLATRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Determine machine dependent parameters to control overflow. * SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) BIGNUM = ONE / SMLNUM SCALE = ONE * IF( LSAME( NORMIN, 'N' ) ) THEN * * Compute the 1-norm of each column, not including the diagonal. * IF( UPPER ) THEN * * A is upper triangular. * DO 10 J = 1, N CNORM( J ) = DASUM( J-1, A( 1, J ), 1 ) 10 CONTINUE ELSE * * A is lower triangular. * DO 20 J = 1, N - 1 CNORM( J ) = DASUM( N-J, A( J+1, J ), 1 ) 20 CONTINUE CNORM( N ) = ZERO END IF END IF * * Scale the column norms by TSCAL if the maximum element in CNORM is * greater than BIGNUM. * IMAX = IDAMAX( N, CNORM, 1 ) TMAX = CNORM( IMAX ) IF( TMAX.LE.BIGNUM ) THEN TSCAL = ONE ELSE TSCAL = ONE / ( SMLNUM*TMAX ) CALL DSCAL( N, TSCAL, CNORM, 1 ) END IF * * Compute a bound on the computed solution vector to see if the * Level 2 BLAS routine DTRSV can be used. * J = IDAMAX( N, X, 1 ) XMAX = ABS( X( J ) ) XBND = XMAX IF( NOTRAN ) THEN * * Compute the growth in A * x = b. * IF( UPPER ) THEN JFIRST = N JLAST = 1 JINC = -1 ELSE JFIRST = 1 JLAST = N JINC = 1 END IF * IF( TSCAL.NE.ONE ) THEN GROW = ZERO GO TO 50 END IF * IF( NOUNIT ) THEN * * A is non-unit triangular. * * Compute GROW = 1/G(j) and XBND = 1/M(j). * Initially, G(0) = max{x(i), i=1,...,n}. * GROW = ONE / MAX( XBND, SMLNUM ) XBND = GROW DO 30 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 50 * * M(j) = G(j-1) / abs(A(j,j)) * TJJ = ABS( A( J, J ) ) XBND = MIN( XBND, MIN( ONE, TJJ )*GROW ) IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN * * G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) * GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) ) ELSE * * G(j) could overflow, set GROW to 0. * GROW = ZERO END IF 30 CONTINUE GROW = XBND ELSE * * A is unit triangular. * * Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. * GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) ) DO 40 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 50 * * G(j) = G(j-1)*( 1 + CNORM(j) ) * GROW = GROW*( ONE / ( ONE+CNORM( J ) ) ) 40 CONTINUE END IF 50 CONTINUE * ELSE * * Compute the growth in A**T * x = b. * IF( UPPER ) THEN JFIRST = 1 JLAST = N JINC = 1 ELSE JFIRST = N JLAST = 1 JINC = -1 END IF * IF( TSCAL.NE.ONE ) THEN GROW = ZERO GO TO 80 END IF * IF( NOUNIT ) THEN * * A is non-unit triangular. * * Compute GROW = 1/G(j) and XBND = 1/M(j). * Initially, M(0) = max{x(i), i=1,...,n}. * GROW = ONE / MAX( XBND, SMLNUM ) XBND = GROW DO 60 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 80 * * G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) * XJ = ONE + CNORM( J ) GROW = MIN( GROW, XBND / XJ ) * * M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) * TJJ = ABS( A( J, J ) ) IF( XJ.GT.TJJ ) $ XBND = XBND*( TJJ / XJ ) 60 CONTINUE GROW = MIN( GROW, XBND ) ELSE * * A is unit triangular. * * Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. * GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) ) DO 70 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 80 * * G(j) = ( 1 + CNORM(j) )*G(j-1) * XJ = ONE + CNORM( J ) GROW = GROW / XJ 70 CONTINUE END IF 80 CONTINUE END IF * IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN * * Use the Level 2 BLAS solve if the reciprocal of the bound on * elements of X is not too small. * CALL DTRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 ) ELSE * * Use a Level 1 BLAS solve, scaling intermediate results. * IF( XMAX.GT.BIGNUM ) THEN * * Scale X so that its components are less than or equal to * BIGNUM in absolute value. * SCALE = BIGNUM / XMAX CALL DSCAL( N, SCALE, X, 1 ) XMAX = BIGNUM END IF * IF( NOTRAN ) THEN * * Solve A * x = b * DO 110 J = JFIRST, JLAST, JINC * * Compute x(j) = b(j) / A(j,j), scaling x if necessary. * XJ = ABS( X( J ) ) IF( NOUNIT ) THEN TJJS = A( J, J )*TSCAL ELSE TJJS = TSCAL IF( TSCAL.EQ.ONE ) $ GO TO 100 END IF TJJ = ABS( TJJS ) IF( TJJ.GT.SMLNUM ) THEN * * abs(A(j,j)) > SMLNUM: * IF( TJJ.LT.ONE ) THEN IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by 1/b(j). * REC = ONE / XJ CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF X( J ) = X( J ) / TJJS XJ = ABS( X( J ) ) ELSE IF( TJJ.GT.ZERO ) THEN * * 0 < abs(A(j,j)) <= SMLNUM: * IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM * to avoid overflow when dividing by A(j,j). * REC = ( TJJ*BIGNUM ) / XJ IF( CNORM( J ).GT.ONE ) THEN * * Scale by 1/CNORM(j) to avoid overflow when * multiplying x(j) times column j. * REC = REC / CNORM( J ) END IF CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF X( J ) = X( J ) / TJJS XJ = ABS( X( J ) ) ELSE * * A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and * scale = 0, and compute a solution to A*x = 0. * DO 90 I = 1, N X( I ) = ZERO 90 CONTINUE X( J ) = ONE XJ = ONE SCALE = ZERO XMAX = ZERO END IF 100 CONTINUE * * Scale x if necessary to avoid overflow when adding a * multiple of column j of A. * IF( XJ.GT.ONE ) THEN REC = ONE / XJ IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN * * Scale x by 1/(2*abs(x(j))). * REC = REC*HALF CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC END IF ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN * * Scale x by 1/2. * CALL DSCAL( N, HALF, X, 1 ) SCALE = SCALE*HALF END IF * IF( UPPER ) THEN IF( J.GT.1 ) THEN * * Compute the update * x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) * CALL DAXPY( J-1, -X( J )*TSCAL, A( 1, J ), 1, X, $ 1 ) I = IDAMAX( J-1, X, 1 ) XMAX = ABS( X( I ) ) END IF ELSE IF( J.LT.N ) THEN * * Compute the update * x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) * CALL DAXPY( N-J, -X( J )*TSCAL, A( J+1, J ), 1, $ X( J+1 ), 1 ) I = J + IDAMAX( N-J, X( J+1 ), 1 ) XMAX = ABS( X( I ) ) END IF END IF 110 CONTINUE * ELSE * * Solve A**T * x = b * DO 160 J = JFIRST, JLAST, JINC * * Compute x(j) = b(j) - sum A(k,j)*x(k). * k<>j * XJ = ABS( X( J ) ) USCAL = TSCAL REC = ONE / MAX( XMAX, ONE ) IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN * * If x(j) could overflow, scale x by 1/(2*XMAX). * REC = REC*HALF IF( NOUNIT ) THEN TJJS = A( J, J )*TSCAL ELSE TJJS = TSCAL END IF TJJ = ABS( TJJS ) IF( TJJ.GT.ONE ) THEN * * Divide by A(j,j) when scaling x if A(j,j) > 1. * REC = MIN( ONE, REC*TJJ ) USCAL = USCAL / TJJS END IF IF( REC.LT.ONE ) THEN CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF * SUMJ = ZERO IF( USCAL.EQ.ONE ) THEN * * If the scaling needed for A in the dot product is 1, * call DDOT to perform the dot product. * IF( UPPER ) THEN SUMJ = DDOT( J-1, A( 1, J ), 1, X, 1 ) ELSE IF( J.LT.N ) THEN SUMJ = DDOT( N-J, A( J+1, J ), 1, X( J+1 ), 1 ) END IF ELSE * * Otherwise, use in-line code for the dot product. * IF( UPPER ) THEN DO 120 I = 1, J - 1 SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I ) 120 CONTINUE ELSE IF( J.LT.N ) THEN DO 130 I = J + 1, N SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I ) 130 CONTINUE END IF END IF * IF( USCAL.EQ.TSCAL ) THEN * * Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) * was not used to scale the dotproduct. * X( J ) = X( J ) - SUMJ XJ = ABS( X( J ) ) IF( NOUNIT ) THEN TJJS = A( J, J )*TSCAL ELSE TJJS = TSCAL IF( TSCAL.EQ.ONE ) $ GO TO 150 END IF * * Compute x(j) = x(j) / A(j,j), scaling if necessary. * TJJ = ABS( TJJS ) IF( TJJ.GT.SMLNUM ) THEN * * abs(A(j,j)) > SMLNUM: * IF( TJJ.LT.ONE ) THEN IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale X by 1/abs(x(j)). * REC = ONE / XJ CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF X( J ) = X( J ) / TJJS ELSE IF( TJJ.GT.ZERO ) THEN * * 0 < abs(A(j,j)) <= SMLNUM: * IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. * REC = ( TJJ*BIGNUM ) / XJ CALL DSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF X( J ) = X( J ) / TJJS ELSE * * A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and * scale = 0, and compute a solution to A**T*x = 0. * DO 140 I = 1, N X( I ) = ZERO 140 CONTINUE X( J ) = ONE SCALE = ZERO XMAX = ZERO END IF 150 CONTINUE ELSE * * Compute x(j) := x(j) / A(j,j) - sumj if the dot * product has already been divided by 1/A(j,j). * X( J ) = X( J ) / TJJS - SUMJ END IF XMAX = MAX( XMAX, ABS( X( J ) ) ) 160 CONTINUE END IF SCALE = SCALE / TSCAL END IF * * Scale the column norms by 1/TSCAL for return. * IF( TSCAL.NE.ONE ) THEN CALL DSCAL( N, ONE / TSCAL, CNORM, 1 ) END IF * RETURN * * End of DLATRS * END *> \brief \b DLATRZ factors an upper trapezoidal matrix by means of orthogonal transformations. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLATRZ + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLATRZ( M, N, L, A, LDA, TAU, WORK ) * * .. Scalar Arguments .. * INTEGER L, LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] L *> \verbatim *> L is INTEGER *> The number of columns of the matrix A containing the *> meaningful part of the Householder vectors. N-M >= L >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is 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. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (M) *> The scalar factors of the elementary reflectors. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (M) *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Contributors: * ================== *> *> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA * *> \par Further Details: * ===================== *> *> \verbatim *> *> 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 )**T, 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 ). *> \endverbatim *> * ===================================================================== SUBROUTINE DLATRZ( M, N, L, A, LDA, TAU, WORK ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER L, LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. 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 *> \brief \b DLATZM * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLATZM + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK ) * * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER INCV, LDC, M, N * DOUBLE PRECISION TAU * .. * .. Array Arguments .. * DOUBLE PRECISION C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> 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**T, 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': form P * C *> = 'R': form C * P *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is 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. *> \endverbatim *> *> \param[in] INCV *> \verbatim *> INCV is INTEGER *> The increment between elements of v. INCV <> 0 *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION *> The value tau in the representation of P. *> \endverbatim *> *> \param[in,out] C1 *> \verbatim *> C1 is 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'. *> \endverbatim *> *> \param[in,out] C2 *> \verbatim *> C2 is 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'. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the arrays C1 and C2. LDC >= (1,M). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension *> (N) if SIDE = 'L' *> (M) if SIDE = 'R' *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER SIDE INTEGER INCV, LDC, M, N DOUBLE PRECISION TAU * .. * .. Array Arguments .. DOUBLE PRECISION C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * ) * .. * * ===================================================================== * * .. 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**T * C2)**T * 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**T * [ 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**T] * 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 *> \brief \b DLAUU2 computes the product UUH or LHL, where U and L are upper or lower triangular matrices (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAUU2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAUU2( UPLO, N, A, LDA, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAUU2 computes the product U * U**T or L**T * L, where the triangular *> factor U or L is stored in the upper or lower triangular part of *> the array A. *> *> If UPLO = 'U' or 'u' then the upper triangle of the result is stored, *> overwriting the factor U in A. *> If UPLO = 'L' or 'l' then the lower triangle of the result is stored, *> overwriting the factor L in A. *> *> This is the unblocked form of the algorithm, calling Level 2 BLAS. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the triangular factor stored in the array A *> is upper or lower triangular: *> = 'U': Upper triangular *> = 'L': Lower triangular *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the triangular factor U or L. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the triangular factor U or L. *> On exit, if UPLO = 'U', the upper triangle of A is *> overwritten with the upper triangle of the product U * U**T; *> if UPLO = 'L', the lower triangle of A is overwritten with *> the lower triangle of the product L**T * L. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -k, the k-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLAUU2( UPLO, N, A, LDA, INFO ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER I DOUBLE PRECISION AII * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT EXTERNAL LSAME, DDOT * .. * .. External Subroutines .. EXTERNAL DGEMV, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLAUU2', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( UPPER ) THEN * * Compute the product U * U**T. * DO 10 I = 1, N AII = A( I, I ) IF( I.LT.N ) THEN A( I, I ) = DDOT( N-I+1, A( I, I ), LDA, A( I, I ), LDA ) CALL DGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), $ LDA, A( I, I+1 ), LDA, AII, A( 1, I ), 1 ) ELSE CALL DSCAL( I, AII, A( 1, I ), 1 ) END IF 10 CONTINUE * ELSE * * Compute the product L**T * L. * DO 20 I = 1, N AII = A( I, I ) IF( I.LT.N ) THEN A( I, I ) = DDOT( N-I+1, A( I, I ), 1, A( I, I ), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA, $ A( I+1, I ), 1, AII, A( I, 1 ), LDA ) ELSE CALL DSCAL( I, AII, A( I, 1 ), LDA ) END IF 20 CONTINUE END IF * RETURN * * End of DLAUU2 * END *> \brief \b DLAUUM computes the product UUH or LHL, where U and L are upper or lower triangular matrices (blocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLAUUM + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLAUUM( UPLO, N, A, LDA, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DLAUUM computes the product U * U**T or L**T * L, where the triangular *> factor U or L is stored in the upper or lower triangular part of *> the array A. *> *> If UPLO = 'U' or 'u' then the upper triangle of the result is stored, *> overwriting the factor U in A. *> If UPLO = 'L' or 'l' then the lower triangle of the result is stored, *> overwriting the factor L in A. *> *> This is the blocked form of the algorithm, calling Level 3 BLAS. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the triangular factor stored in the array A *> is upper or lower triangular: *> = 'U': Upper triangular *> = 'L': Lower triangular *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the triangular factor U or L. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the triangular factor U or L. *> On exit, if UPLO = 'U', the upper triangle of A is *> overwritten with the upper triangle of the product U * U**T; *> if UPLO = 'L', the lower triangle of A is overwritten with *> the lower triangle of the product L**T * L. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -k, the k-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DLAUUM( UPLO, N, A, LDA, INFO ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER I, IB, NB * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DGEMM, DLAUU2, DSYRK, DTRMM, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLAUUM', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Determine the block size for this environment. * NB = ILAENV( 1, 'DLAUUM', UPLO, N, -1, -1, -1 ) * IF( NB.LE.1 .OR. NB.GE.N ) THEN * * Use unblocked code * CALL DLAUU2( UPLO, N, A, LDA, INFO ) ELSE * * Use blocked code * IF( UPPER ) THEN * * Compute the product U * U**T. * DO 10 I = 1, N, NB IB = MIN( NB, N-I+1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-unit', $ I-1, IB, ONE, A( I, I ), LDA, A( 1, I ), $ LDA ) CALL DLAUU2( 'Upper', IB, A( I, I ), LDA, INFO ) IF( I+IB.LE.N ) THEN CALL DGEMM( 'No transpose', 'Transpose', I-1, IB, $ N-I-IB+1, ONE, A( 1, I+IB ), LDA, $ A( I, I+IB ), LDA, ONE, A( 1, I ), LDA ) CALL DSYRK( 'Upper', 'No transpose', IB, N-I-IB+1, $ ONE, A( I, I+IB ), LDA, ONE, A( I, I ), $ LDA ) END IF 10 CONTINUE ELSE * * Compute the product L**T * L. * DO 20 I = 1, N, NB IB = MIN( NB, N-I+1 ) CALL DTRMM( 'Left', 'Lower', 'Transpose', 'Non-unit', IB, $ I-1, ONE, A( I, I ), LDA, A( I, 1 ), LDA ) CALL DLAUU2( 'Lower', IB, A( I, I ), LDA, INFO ) IF( I+IB.LE.N ) THEN CALL DGEMM( 'Transpose', 'No transpose', IB, I-1, $ N-I-IB+1, ONE, A( I+IB, I ), LDA, $ A( I+IB, 1 ), LDA, ONE, A( I, 1 ), LDA ) CALL DSYRK( 'Lower', 'Transpose', IB, N-I-IB+1, ONE, $ A( I+IB, I ), LDA, ONE, A( I, I ), LDA ) END IF 20 CONTINUE END IF END IF * RETURN * * End of DLAUUM * END *> \brief \b DOPGTR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DOPGTR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDQ, N * .. * .. Array Arguments .. * DOUBLE PRECISION AP( * ), Q( LDQ, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DOPGTR generates a real orthogonal matrix Q which is defined as the *> product of n-1 elementary reflectors H(i) of order n, as returned by *> DSPTRD using packed storage: *> *> if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), *> *> if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangular packed storage used in previous *> call to DSPTRD; *> = 'L': Lower triangular packed storage used in previous *> call to DSPTRD. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix Q. N >= 0. *> \endverbatim *> *> \param[in] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> The vectors which define the elementary reflectors, as *> returned by DSPTRD. *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (N-1) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DSPTRD. *> \endverbatim *> *> \param[out] Q *> \verbatim *> Q is DOUBLE PRECISION array, dimension (LDQ,N) *> The N-by-N orthogonal matrix Q. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= max(1,N). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (N-1) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDQ, N * .. * .. Array Arguments .. DOUBLE PRECISION AP( * ), Q( LDQ, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER I, IINFO, IJ, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DORG2L, DORG2R, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DOPGTR', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( UPPER ) THEN * * Q was determined by a call to DSPTRD with UPLO = 'U' * * Unpack the vectors which define the elementary reflectors and * set the last row and column of Q equal to those of the unit * matrix * IJ = 2 DO 20 J = 1, N - 1 DO 10 I = 1, J - 1 Q( I, J ) = AP( IJ ) IJ = IJ + 1 10 CONTINUE IJ = IJ + 2 Q( N, J ) = ZERO 20 CONTINUE DO 30 I = 1, N - 1 Q( I, N ) = ZERO 30 CONTINUE Q( N, N ) = ONE * * Generate Q(1:n-1,1:n-1) * CALL DORG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO ) * ELSE * * Q was determined by a call to DSPTRD with UPLO = 'L'. * * Unpack the vectors which define the elementary reflectors and * set the first row and column of Q equal to those of the unit * matrix * Q( 1, 1 ) = ONE DO 40 I = 2, N Q( I, 1 ) = ZERO 40 CONTINUE IJ = 3 DO 60 J = 2, N Q( 1, J ) = ZERO DO 50 I = J + 1, N Q( I, J ) = AP( IJ ) IJ = IJ + 1 50 CONTINUE IJ = IJ + 2 60 CONTINUE IF( N.GT.1 ) THEN * * Generate Q(2:n,2:n) * CALL DORG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK, $ IINFO ) END IF END IF RETURN * * End of DOPGTR * END *> \brief \b DOPMTR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DOPMTR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, * INFO ) * * .. Scalar Arguments .. * CHARACTER SIDE, TRANS, UPLO * INTEGER INFO, LDC, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION AP( * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DOPMTR overwrites the general real M-by-N matrix C with *> *> SIDE = 'L' SIDE = 'R' *> TRANS = 'N': Q * C C * Q *> TRANS = 'T': Q**T * C C * Q**T *> *> where Q is a real orthogonal matrix of order nq, with nq = m if *> SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of *> nq-1 elementary reflectors, as returned by DSPTRD using packed *> storage: *> *> if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); *> *> if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply Q or Q**T from the Left; *> = 'R': apply Q or Q**T from the Right. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangular packed storage used in previous *> call to DSPTRD; *> = 'L': Lower triangular packed storage used in previous *> call to DSPTRD. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': No transpose, apply Q; *> = 'T': Transpose, apply Q**T. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. N >= 0. *> \endverbatim *> *> \param[in] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension *> (M*(M+1)/2) if SIDE = 'L' *> (N*(N+1)/2) if SIDE = 'R' *> The vectors which define the elementary reflectors, as *> returned by DSPTRD. AP is modified by the routine but *> restored on exit. *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (M-1) if SIDE = 'L' *> or (N-1) if SIDE = 'R' *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DSPTRD. *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (LDC,N) *> On entry, the M-by-N matrix C. *> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDC >= max(1,M). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension *> (N) if SIDE = 'L' *> (M) if SIDE = 'R' *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, $ INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS, UPLO INTEGER INFO, LDC, M, N * .. * .. Array Arguments .. DOUBLE PRECISION AP( * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL FORWRD, LEFT, NOTRAN, UPPER INTEGER I, I1, I2, I3, IC, II, JC, MI, NI, NQ DOUBLE PRECISION AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLARF, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) UPPER = LSAME( UPLO, 'U' ) * * NQ is the order of Q * IF( LEFT ) THEN NQ = M ELSE NQ = N END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -2 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DOPMTR', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * IF( UPPER ) THEN * * Q was determined by a call to DSPTRD with UPLO = 'U' * FORWRD = ( LEFT .AND. NOTRAN ) .OR. $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) * IF( FORWRD ) THEN I1 = 1 I2 = NQ - 1 I3 = 1 II = 2 ELSE I1 = NQ - 1 I2 = 1 I3 = -1 II = NQ*( NQ+1 ) / 2 - 1 END IF * IF( LEFT ) THEN NI = N ELSE MI = M END IF * DO 10 I = I1, I2, I3 IF( LEFT ) THEN * * H(i) is applied to C(1:i,1:n) * MI = I ELSE * * H(i) is applied to C(1:m,1:i) * NI = I END IF * * Apply H(i) * AII = AP( II ) AP( II ) = ONE CALL DLARF( SIDE, MI, NI, AP( II-I+1 ), 1, TAU( I ), C, LDC, $ WORK ) AP( II ) = AII * IF( FORWRD ) THEN II = II + I + 2 ELSE II = II - I - 1 END IF 10 CONTINUE ELSE * * Q was determined by a call to DSPTRD with UPLO = 'L'. * FORWRD = ( LEFT .AND. .NOT.NOTRAN ) .OR. $ ( .NOT.LEFT .AND. NOTRAN ) * IF( FORWRD ) THEN I1 = 1 I2 = NQ - 1 I3 = 1 II = 2 ELSE I1 = NQ - 1 I2 = 1 I3 = -1 II = NQ*( NQ+1 ) / 2 - 1 END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * DO 20 I = I1, I2, I3 AII = AP( II ) AP( II ) = ONE IF( LEFT ) THEN * * H(i) is applied to C(i+1:m,1:n) * MI = M - I IC = I + 1 ELSE * * H(i) is applied to C(1:m,i+1:n) * NI = N - I JC = I + 1 END IF * * Apply H(i) * CALL DLARF( SIDE, MI, NI, AP( II ), 1, TAU( I ), $ C( IC, JC ), LDC, WORK ) AP( II ) = AII * IF( FORWRD ) THEN II = II + NQ - I + 1 ELSE II = II - NQ + I - 2 END IF 20 CONTINUE END IF RETURN * * End of DOPMTR * END *> \brief \b DORBDB * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORBDB + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, * X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, * TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER SIGNS, TRANS * INTEGER INFO, LDX11, LDX12, LDX21, LDX22, LWORK, M, P, * $ Q * .. * .. Array Arguments .. * DOUBLE PRECISION PHI( * ), THETA( * ) * DOUBLE PRECISION TAUP1( * ), TAUP2( * ), TAUQ1( * ), TAUQ2( * ), * $ WORK( * ), X11( LDX11, * ), X12( LDX12, * ), * $ X21( LDX21, * ), X22( LDX22, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DORBDB simultaneously bidiagonalizes the blocks of an M-by-M *> partitioned orthogonal matrix X: *> *> [ B11 | B12 0 0 ] *> [ X11 | X12 ] [ P1 | ] [ 0 | 0 -I 0 ] [ Q1 | ]**T *> X = [-----------] = [---------] [----------------] [---------] . *> [ X21 | X22 ] [ | P2 ] [ B21 | B22 0 0 ] [ | Q2 ] *> [ 0 | 0 0 I ] *> *> X11 is P-by-Q. Q must be no larger than P, M-P, or M-Q. (If this is *> not the case, then X must be transposed and/or permuted. This can be *> done in constant time using the TRANS and SIGNS options. See DORCSD *> for details.) *> *> The orthogonal matrices P1, P2, Q1, and Q2 are P-by-P, (M-P)-by- *> (M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. They are *> represented implicitly by Householder vectors. *> *> B11, B12, B21, and B22 are Q-by-Q bidiagonal matrices represented *> implicitly by angles THETA, PHI. *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER *> = 'T': X, U1, U2, V1T, and V2T are stored in row-major *> order; *> otherwise: X, U1, U2, V1T, and V2T are stored in column- *> major order. *> \endverbatim *> *> \param[in] SIGNS *> \verbatim *> SIGNS is CHARACTER *> = 'O': The lower-left block is made nonpositive (the *> "other" convention); *> otherwise: The upper-right block is made nonpositive (the *> "default" convention). *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows and columns in X. *> \endverbatim *> *> \param[in] P *> \verbatim *> P is INTEGER *> The number of rows in X11 and X12. 0 <= P <= M. *> \endverbatim *> *> \param[in] Q *> \verbatim *> Q is INTEGER *> The number of columns in X11 and X21. 0 <= Q <= *> MIN(P,M-P,M-Q). *> \endverbatim *> *> \param[in,out] X11 *> \verbatim *> X11 is DOUBLE PRECISION array, dimension (LDX11,Q) *> On entry, the top-left block of the orthogonal matrix to be *> reduced. On exit, the form depends on TRANS: *> If TRANS = 'N', then *> the columns of tril(X11) specify reflectors for P1, *> the rows of triu(X11,1) specify reflectors for Q1; *> else TRANS = 'T', and *> the rows of triu(X11) specify reflectors for P1, *> the columns of tril(X11,-1) specify reflectors for Q1. *> \endverbatim *> *> \param[in] LDX11 *> \verbatim *> LDX11 is INTEGER *> The leading dimension of X11. If TRANS = 'N', then LDX11 >= *> P; else LDX11 >= Q. *> \endverbatim *> *> \param[in,out] X12 *> \verbatim *> X12 is DOUBLE PRECISION array, dimension (LDX12,M-Q) *> On entry, the top-right block of the orthogonal matrix to *> be reduced. On exit, the form depends on TRANS: *> If TRANS = 'N', then *> the rows of triu(X12) specify the first P reflectors for *> Q2; *> else TRANS = 'T', and *> the columns of tril(X12) specify the first P reflectors *> for Q2. *> \endverbatim *> *> \param[in] LDX12 *> \verbatim *> LDX12 is INTEGER *> The leading dimension of X12. If TRANS = 'N', then LDX12 >= *> P; else LDX11 >= M-Q. *> \endverbatim *> *> \param[in,out] X21 *> \verbatim *> X21 is DOUBLE PRECISION array, dimension (LDX21,Q) *> On entry, the bottom-left block of the orthogonal matrix to *> be reduced. On exit, the form depends on TRANS: *> If TRANS = 'N', then *> the columns of tril(X21) specify reflectors for P2; *> else TRANS = 'T', and *> the rows of triu(X21) specify reflectors for P2. *> \endverbatim *> *> \param[in] LDX21 *> \verbatim *> LDX21 is INTEGER *> The leading dimension of X21. If TRANS = 'N', then LDX21 >= *> M-P; else LDX21 >= Q. *> \endverbatim *> *> \param[in,out] X22 *> \verbatim *> X22 is DOUBLE PRECISION array, dimension (LDX22,M-Q) *> On entry, the bottom-right block of the orthogonal matrix to *> be reduced. On exit, the form depends on TRANS: *> If TRANS = 'N', then *> the rows of triu(X22(Q+1:M-P,P+1:M-Q)) specify the last *> M-P-Q reflectors for Q2, *> else TRANS = 'T', and *> the columns of tril(X22(P+1:M-Q,Q+1:M-P)) specify the last *> M-P-Q reflectors for P2. *> \endverbatim *> *> \param[in] LDX22 *> \verbatim *> LDX22 is INTEGER *> The leading dimension of X22. If TRANS = 'N', then LDX22 >= *> M-P; else LDX22 >= M-Q. *> \endverbatim *> *> \param[out] THETA *> \verbatim *> THETA is DOUBLE PRECISION array, dimension (Q) *> The entries of the bidiagonal blocks B11, B12, B21, B22 can *> be computed from the angles THETA and PHI. See Further *> Details. *> \endverbatim *> *> \param[out] PHI *> \verbatim *> PHI is DOUBLE PRECISION array, dimension (Q-1) *> The entries of the bidiagonal blocks B11, B12, B21, B22 can *> be computed from the angles THETA and PHI. See Further *> Details. *> \endverbatim *> *> \param[out] TAUP1 *> \verbatim *> TAUP1 is DOUBLE PRECISION array, dimension (P) *> The scalar factors of the elementary reflectors that define *> P1. *> \endverbatim *> *> \param[out] TAUP2 *> \verbatim *> TAUP2 is DOUBLE PRECISION array, dimension (M-P) *> The scalar factors of the elementary reflectors that define *> P2. *> \endverbatim *> *> \param[out] TAUQ1 *> \verbatim *> TAUQ1 is DOUBLE PRECISION array, dimension (Q) *> The scalar factors of the elementary reflectors that define *> Q1. *> \endverbatim *> *> \param[out] TAUQ2 *> \verbatim *> TAUQ2 is DOUBLE PRECISION array, dimension (M-Q) *> The scalar factors of the elementary reflectors that define *> Q2. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (LWORK) *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= M-Q. *> *> 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The bidiagonal blocks B11, B12, B21, and B22 are represented *> implicitly by angles THETA(1), ..., THETA(Q) and PHI(1), ..., *> PHI(Q-1). B11 and B21 are upper bidiagonal, while B21 and B22 are *> lower bidiagonal. Every entry in each bidiagonal band is a product *> of a sine or cosine of a THETA with a sine or cosine of a PHI. See *> [1] or DORCSD for details. *> *> P1, P2, Q1, and Q2 are represented as products of elementary *> reflectors. See DORCSD for details on generating P1, P2, Q1, and Q2 *> using DORGQR and DORGLQ. *> \endverbatim * *> \par References: * ================ *> *> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. *> Algorithms, 50(1):33-65, 2009. *> * ===================================================================== SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, $ X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, $ TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER SIGNS, TRANS INTEGER INFO, LDX11, LDX12, LDX21, LDX22, LWORK, M, P, $ Q * .. * .. Array Arguments .. DOUBLE PRECISION PHI( * ), THETA( * ) DOUBLE PRECISION TAUP1( * ), TAUP2( * ), TAUQ1( * ), TAUQ2( * ), $ WORK( * ), X11( LDX11, * ), X12( LDX12, * ), $ X21( LDX21, * ), X22( LDX22, * ) * .. * * ==================================================================== * * .. Parameters .. DOUBLE PRECISION REALONE PARAMETER ( REALONE = 1.0D0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL COLMAJOR, LQUERY INTEGER I, LWORKMIN, LWORKOPT DOUBLE PRECISION Z1, Z2, Z3, Z4 * .. * .. External Subroutines .. EXTERNAL DAXPY, DLARF, DLARFGP, DSCAL, XERBLA * .. * .. External Functions .. DOUBLE PRECISION DNRM2 LOGICAL LSAME EXTERNAL DNRM2, LSAME * .. * .. Intrinsic Functions INTRINSIC ATAN2, COS, MAX, SIN * .. * .. Executable Statements .. * * Test input arguments * INFO = 0 COLMAJOR = .NOT. LSAME( TRANS, 'T' ) IF( .NOT. LSAME( SIGNS, 'O' ) ) THEN Z1 = REALONE Z2 = REALONE Z3 = REALONE Z4 = REALONE ELSE Z1 = REALONE Z2 = -REALONE Z3 = REALONE Z4 = -REALONE END IF LQUERY = LWORK .EQ. -1 * IF( M .LT. 0 ) THEN INFO = -3 ELSE IF( P .LT. 0 .OR. P .GT. M ) THEN INFO = -4 ELSE IF( Q .LT. 0 .OR. Q .GT. P .OR. Q .GT. M-P .OR. $ Q .GT. M-Q ) THEN INFO = -5 ELSE IF( COLMAJOR .AND. LDX11 .LT. MAX( 1, P ) ) THEN INFO = -7 ELSE IF( .NOT.COLMAJOR .AND. LDX11 .LT. MAX( 1, Q ) ) THEN INFO = -7 ELSE IF( COLMAJOR .AND. LDX12 .LT. MAX( 1, P ) ) THEN INFO = -9 ELSE IF( .NOT.COLMAJOR .AND. LDX12 .LT. MAX( 1, M-Q ) ) THEN INFO = -9 ELSE IF( COLMAJOR .AND. LDX21 .LT. MAX( 1, M-P ) ) THEN INFO = -11 ELSE IF( .NOT.COLMAJOR .AND. LDX21 .LT. MAX( 1, Q ) ) THEN INFO = -11 ELSE IF( COLMAJOR .AND. LDX22 .LT. MAX( 1, M-P ) ) THEN INFO = -13 ELSE IF( .NOT.COLMAJOR .AND. LDX22 .LT. MAX( 1, M-Q ) ) THEN INFO = -13 END IF * * Compute workspace * IF( INFO .EQ. 0 ) THEN LWORKOPT = M - Q LWORKMIN = M - Q WORK(1) = LWORKOPT IF( LWORK .LT. LWORKMIN .AND. .NOT. LQUERY ) THEN INFO = -21 END IF END IF IF( INFO .NE. 0 ) THEN CALL XERBLA( 'xORBDB', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Handle column-major and row-major separately * IF( COLMAJOR ) THEN * * Reduce columns 1, ..., Q of X11, X12, X21, and X22 * DO I = 1, Q * IF( I .EQ. 1 ) THEN CALL DSCAL( P-I+1, Z1, X11(I,I), 1 ) ELSE CALL DSCAL( P-I+1, Z1*COS(PHI(I-1)), X11(I,I), 1 ) CALL DAXPY( P-I+1, -Z1*Z3*Z4*SIN(PHI(I-1)), X12(I,I-1), $ 1, X11(I,I), 1 ) END IF IF( I .EQ. 1 ) THEN CALL DSCAL( M-P-I+1, Z2, X21(I,I), 1 ) ELSE CALL DSCAL( M-P-I+1, Z2*COS(PHI(I-1)), X21(I,I), 1 ) CALL DAXPY( M-P-I+1, -Z2*Z3*Z4*SIN(PHI(I-1)), X22(I,I-1), $ 1, X21(I,I), 1 ) END IF * THETA(I) = ATAN2( DNRM2( M-P-I+1, X21(I,I), 1 ), $ DNRM2( P-I+1, X11(I,I), 1 ) ) * IF( P .GT. I ) THEN CALL DLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) ELSE IF( P .EQ. I ) THEN CALL DLARFGP( P-I+1, X11(I,I), X11(I,I), 1, TAUP1(I) ) END IF X11(I,I) = ONE IF ( M-P .GT. I ) THEN CALL DLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, $ TAUP2(I) ) ELSE IF ( M-P .EQ. I ) THEN CALL DLARFGP( M-P-I+1, X21(I,I), X21(I,I), 1, TAUP2(I) ) END IF X21(I,I) = ONE * IF ( Q .GT. I ) THEN CALL DLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), $ X11(I,I+1), LDX11, WORK ) END IF IF ( M-Q+1 .GT. I ) THEN CALL DLARF( 'L', P-I+1, M-Q-I+1, X11(I,I), 1, TAUP1(I), $ X12(I,I), LDX12, WORK ) END IF IF ( Q .GT. I ) THEN CALL DLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), $ X21(I,I+1), LDX21, WORK ) END IF IF ( M-Q+1 .GT. I ) THEN CALL DLARF( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1, TAUP2(I), $ X22(I,I), LDX22, WORK ) END IF * IF( I .LT. Q ) THEN CALL DSCAL( Q-I, -Z1*Z3*SIN(THETA(I)), X11(I,I+1), $ LDX11 ) CALL DAXPY( Q-I, Z2*Z3*COS(THETA(I)), X21(I,I+1), LDX21, $ X11(I,I+1), LDX11 ) END IF CALL DSCAL( M-Q-I+1, -Z1*Z4*SIN(THETA(I)), X12(I,I), LDX12 ) CALL DAXPY( M-Q-I+1, Z2*Z4*COS(THETA(I)), X22(I,I), LDX22, $ X12(I,I), LDX12 ) * IF( I .LT. Q ) $ PHI(I) = ATAN2( DNRM2( Q-I, X11(I,I+1), LDX11 ), $ DNRM2( M-Q-I+1, X12(I,I), LDX12 ) ) * IF( I .LT. Q ) THEN IF ( Q-I .EQ. 1 ) THEN CALL DLARFGP( Q-I, X11(I,I+1), X11(I,I+1), LDX11, $ TAUQ1(I) ) ELSE CALL DLARFGP( Q-I, X11(I,I+1), X11(I,I+2), LDX11, $ TAUQ1(I) ) END IF X11(I,I+1) = ONE END IF IF ( Q+I-1 .LT. M ) THEN IF ( M-Q .EQ. I ) THEN CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I), LDX12, $ TAUQ2(I) ) ELSE CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12, $ TAUQ2(I) ) END IF END IF X12(I,I) = ONE * IF( I .LT. Q ) THEN CALL DLARF( 'R', P-I, Q-I, X11(I,I+1), LDX11, TAUQ1(I), $ X11(I+1,I+1), LDX11, WORK ) CALL DLARF( 'R', M-P-I, Q-I, X11(I,I+1), LDX11, TAUQ1(I), $ X21(I+1,I+1), LDX21, WORK ) END IF IF ( P .GT. I ) THEN CALL DLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I), $ X12(I+1,I), LDX12, WORK ) END IF IF ( M-P .GT. I ) THEN CALL DLARF( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12, $ TAUQ2(I), X22(I+1,I), LDX22, WORK ) END IF * END DO * * Reduce columns Q + 1, ..., P of X12, X22 * DO I = Q + 1, P * CALL DSCAL( M-Q-I+1, -Z1*Z4, X12(I,I), LDX12 ) IF ( I .GE. M-Q ) THEN CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I), LDX12, $ TAUQ2(I) ) ELSE CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12, $ TAUQ2(I) ) END IF X12(I,I) = ONE * IF ( P .GT. I ) THEN CALL DLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I), $ X12(I+1,I), LDX12, WORK ) END IF IF( M-P-Q .GE. 1 ) $ CALL DLARF( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12, $ TAUQ2(I), X22(Q+1,I), LDX22, WORK ) * END DO * * Reduce columns P + 1, ..., M - Q of X12, X22 * DO I = 1, M - P - Q * CALL DSCAL( M-P-Q-I+1, Z2*Z4, X22(Q+I,P+I), LDX22 ) IF ( I .EQ. M-P-Q ) THEN CALL DLARFGP( M-P-Q-I+1, X22(Q+I,P+I), X22(Q+I,P+I), $ LDX22, TAUQ2(P+I) ) ELSE CALL DLARFGP( M-P-Q-I+1, X22(Q+I,P+I), X22(Q+I,P+I+1), $ LDX22, TAUQ2(P+I) ) END IF X22(Q+I,P+I) = ONE IF ( I .LT. M-P-Q ) THEN CALL DLARF( 'R', M-P-Q-I, M-P-Q-I+1, X22(Q+I,P+I), LDX22, $ TAUQ2(P+I), X22(Q+I+1,P+I), LDX22, WORK ) END IF * END DO * ELSE * * Reduce columns 1, ..., Q of X11, X12, X21, X22 * DO I = 1, Q * IF( I .EQ. 1 ) THEN CALL DSCAL( P-I+1, Z1, X11(I,I), LDX11 ) ELSE CALL DSCAL( P-I+1, Z1*COS(PHI(I-1)), X11(I,I), LDX11 ) CALL DAXPY( P-I+1, -Z1*Z3*Z4*SIN(PHI(I-1)), X12(I-1,I), $ LDX12, X11(I,I), LDX11 ) END IF IF( I .EQ. 1 ) THEN CALL DSCAL( M-P-I+1, Z2, X21(I,I), LDX21 ) ELSE CALL DSCAL( M-P-I+1, Z2*COS(PHI(I-1)), X21(I,I), LDX21 ) CALL DAXPY( M-P-I+1, -Z2*Z3*Z4*SIN(PHI(I-1)), X22(I-1,I), $ LDX22, X21(I,I), LDX21 ) END IF * THETA(I) = ATAN2( DNRM2( M-P-I+1, X21(I,I), LDX21 ), $ DNRM2( P-I+1, X11(I,I), LDX11 ) ) * CALL DLARFGP( P-I+1, X11(I,I), X11(I,I+1), LDX11, TAUP1(I) ) X11(I,I) = ONE IF ( I .EQ. M-P ) THEN CALL DLARFGP( M-P-I+1, X21(I,I), X21(I,I), LDX21, $ TAUP2(I) ) ELSE CALL DLARFGP( M-P-I+1, X21(I,I), X21(I,I+1), LDX21, $ TAUP2(I) ) END IF X21(I,I) = ONE * IF ( Q .GT. I ) THEN CALL DLARF( 'R', Q-I, P-I+1, X11(I,I), LDX11, TAUP1(I), $ X11(I+1,I), LDX11, WORK ) END IF IF ( M-Q+1 .GT. I ) THEN CALL DLARF( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11, $ TAUP1(I), X12(I,I), LDX12, WORK ) END IF IF ( Q .GT. I ) THEN CALL DLARF( 'R', Q-I, M-P-I+1, X21(I,I), LDX21, TAUP2(I), $ X21(I+1,I), LDX21, WORK ) END IF IF ( M-Q+1 .GT. I ) THEN CALL DLARF( 'R', M-Q-I+1, M-P-I+1, X21(I,I), LDX21, $ TAUP2(I), X22(I,I), LDX22, WORK ) END IF * IF( I .LT. Q ) THEN CALL DSCAL( Q-I, -Z1*Z3*SIN(THETA(I)), X11(I+1,I), 1 ) CALL DAXPY( Q-I, Z2*Z3*COS(THETA(I)), X21(I+1,I), 1, $ X11(I+1,I), 1 ) END IF CALL DSCAL( M-Q-I+1, -Z1*Z4*SIN(THETA(I)), X12(I,I), 1 ) CALL DAXPY( M-Q-I+1, Z2*Z4*COS(THETA(I)), X22(I,I), 1, $ X12(I,I), 1 ) * IF( I .LT. Q ) $ PHI(I) = ATAN2( DNRM2( Q-I, X11(I+1,I), 1 ), $ DNRM2( M-Q-I+1, X12(I,I), 1 ) ) * IF( I .LT. Q ) THEN IF ( Q-I .EQ. 1) THEN CALL DLARFGP( Q-I, X11(I+1,I), X11(I+1,I), 1, $ TAUQ1(I) ) ELSE CALL DLARFGP( Q-I, X11(I+1,I), X11(I+2,I), 1, $ TAUQ1(I) ) END IF X11(I+1,I) = ONE END IF IF ( M-Q .GT. I ) THEN CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, $ TAUQ2(I) ) ELSE CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I), 1, $ TAUQ2(I) ) END IF X12(I,I) = ONE * IF( I .LT. Q ) THEN CALL DLARF( 'L', Q-I, P-I, X11(I+1,I), 1, TAUQ1(I), $ X11(I+1,I+1), LDX11, WORK ) CALL DLARF( 'L', Q-I, M-P-I, X11(I+1,I), 1, TAUQ1(I), $ X21(I+1,I+1), LDX21, WORK ) END IF CALL DLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I), $ X12(I,I+1), LDX12, WORK ) IF ( M-P-I .GT. 0 ) THEN CALL DLARF( 'L', M-Q-I+1, M-P-I, X12(I,I), 1, TAUQ2(I), $ X22(I,I+1), LDX22, WORK ) END IF * END DO * * Reduce columns Q + 1, ..., P of X12, X22 * DO I = Q + 1, P * CALL DSCAL( M-Q-I+1, -Z1*Z4, X12(I,I), 1 ) CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, TAUQ2(I) ) X12(I,I) = ONE * IF ( P .GT. I ) THEN CALL DLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I), $ X12(I,I+1), LDX12, WORK ) END IF IF( M-P-Q .GE. 1 ) $ CALL DLARF( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1, TAUQ2(I), $ X22(I,Q+1), LDX22, WORK ) * END DO * * Reduce columns P + 1, ..., M - Q of X12, X22 * DO I = 1, M - P - Q * CALL DSCAL( M-P-Q-I+1, Z2*Z4, X22(P+I,Q+I), 1 ) IF ( M-P-Q .EQ. I ) THEN CALL DLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I,Q+I), 1, $ TAUQ2(P+I) ) ELSE CALL DLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I+1,Q+I), 1, $ TAUQ2(P+I) ) CALL DLARF( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), 1, $ TAUQ2(P+I), X22(P+I,Q+I+1), LDX22, WORK ) END IF X22(P+I,Q+I) = ONE * END DO * END IF * RETURN * * End of DORBDB * END *> \brief \b DORCSD * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORCSD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * RECURSIVE SUBROUTINE DORCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, * SIGNS, M, P, Q, X11, LDX11, X12, * LDX12, X21, LDX21, X22, LDX22, THETA, * U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, * LDV2T, WORK, LWORK, IWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, SIGNS, TRANS * INTEGER INFO, LDU1, LDU2, LDV1T, LDV2T, LDX11, LDX12, * $ LDX21, LDX22, LWORK, M, P, Q * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION THETA( * ) * DOUBLE PRECISION U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ), * $ V2T( LDV2T, * ), WORK( * ), X11( LDX11, * ), * $ X12( LDX12, * ), X21( LDX21, * ), X22( LDX22, * $ * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DORCSD computes the CS decomposition of an M-by-M partitioned *> orthogonal matrix X: *> *> [ I 0 0 | 0 0 0 ] *> [ 0 C 0 | 0 -S 0 ] *> [ X11 | X12 ] [ U1 | ] [ 0 0 0 | 0 0 -I ] [ V1 | ]**T *> X = [-----------] = [---------] [---------------------] [---------] . *> [ X21 | X22 ] [ | U2 ] [ 0 0 0 | I 0 0 ] [ | V2 ] *> [ 0 S 0 | 0 C 0 ] *> [ 0 0 I | 0 0 0 ] *> *> X11 is P-by-Q. The orthogonal matrices U1, U2, V1, and V2 are P-by-P, *> (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are *> R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in *> which R = MIN(P,M-P,Q,M-Q). *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBU1 *> \verbatim *> JOBU1 is CHARACTER *> = 'Y': U1 is computed; *> otherwise: U1 is not computed. *> \endverbatim *> *> \param[in] JOBU2 *> \verbatim *> JOBU2 is CHARACTER *> = 'Y': U2 is computed; *> otherwise: U2 is not computed. *> \endverbatim *> *> \param[in] JOBV1T *> \verbatim *> JOBV1T is CHARACTER *> = 'Y': V1T is computed; *> otherwise: V1T is not computed. *> \endverbatim *> *> \param[in] JOBV2T *> \verbatim *> JOBV2T is CHARACTER *> = 'Y': V2T is computed; *> otherwise: V2T is not computed. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER *> = 'T': X, U1, U2, V1T, and V2T are stored in row-major *> order; *> otherwise: X, U1, U2, V1T, and V2T are stored in column- *> major order. *> \endverbatim *> *> \param[in] SIGNS *> \verbatim *> SIGNS is CHARACTER *> = 'O': The lower-left block is made nonpositive (the *> "other" convention); *> otherwise: The upper-right block is made nonpositive (the *> "default" convention). *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows and columns in X. *> \endverbatim *> *> \param[in] P *> \verbatim *> P is INTEGER *> The number of rows in X11 and X12. 0 <= P <= M. *> \endverbatim *> *> \param[in] Q *> \verbatim *> Q is INTEGER *> The number of columns in X11 and X21. 0 <= Q <= M. *> \endverbatim *> *> \param[in,out] X11 *> \verbatim *> X11 is DOUBLE PRECISION array, dimension (LDX11,Q) *> On entry, part of the orthogonal matrix whose CSD is desired. *> \endverbatim *> *> \param[in] LDX11 *> \verbatim *> LDX11 is INTEGER *> The leading dimension of X11. LDX11 >= MAX(1,P). *> \endverbatim *> *> \param[in,out] X12 *> \verbatim *> X12 is DOUBLE PRECISION array, dimension (LDX12,M-Q) *> On entry, part of the orthogonal matrix whose CSD is desired. *> \endverbatim *> *> \param[in] LDX12 *> \verbatim *> LDX12 is INTEGER *> The leading dimension of X12. LDX12 >= MAX(1,P). *> \endverbatim *> *> \param[in,out] X21 *> \verbatim *> X21 is DOUBLE PRECISION array, dimension (LDX21,Q) *> On entry, part of the orthogonal matrix whose CSD is desired. *> \endverbatim *> *> \param[in] LDX21 *> \verbatim *> LDX21 is INTEGER *> The leading dimension of X11. LDX21 >= MAX(1,M-P). *> \endverbatim *> *> \param[in,out] X22 *> \verbatim *> X22 is DOUBLE PRECISION array, dimension (LDX22,M-Q) *> On entry, part of the orthogonal matrix whose CSD is desired. *> \endverbatim *> *> \param[in] LDX22 *> \verbatim *> LDX22 is INTEGER *> The leading dimension of X11. LDX22 >= MAX(1,M-P). *> \endverbatim *> *> \param[out] THETA *> \verbatim *> THETA is DOUBLE PRECISION array, dimension (R), in which R = *> MIN(P,M-P,Q,M-Q). *> C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and *> S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ). *> \endverbatim *> *> \param[out] U1 *> \verbatim *> U1 is DOUBLE PRECISION array, dimension (LDU1,P) *> If JOBU1 = 'Y', U1 contains the P-by-P orthogonal matrix U1. *> \endverbatim *> *> \param[in] LDU1 *> \verbatim *> LDU1 is INTEGER *> The leading dimension of U1. If JOBU1 = 'Y', LDU1 >= *> MAX(1,P). *> \endverbatim *> *> \param[out] U2 *> \verbatim *> U2 is DOUBLE PRECISION array, dimension (LDU2,M-P) *> If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) orthogonal *> matrix U2. *> \endverbatim *> *> \param[in] LDU2 *> \verbatim *> LDU2 is INTEGER *> The leading dimension of U2. If JOBU2 = 'Y', LDU2 >= *> MAX(1,M-P). *> \endverbatim *> *> \param[out] V1T *> \verbatim *> V1T is DOUBLE PRECISION array, dimension (LDV1T,Q) *> If JOBV1T = 'Y', V1T contains the Q-by-Q matrix orthogonal *> matrix V1**T. *> \endverbatim *> *> \param[in] LDV1T *> \verbatim *> LDV1T is INTEGER *> The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >= *> MAX(1,Q). *> \endverbatim *> *> \param[out] V2T *> \verbatim *> V2T is DOUBLE PRECISION array, dimension (LDV2T,M-Q) *> If JOBV2T = 'Y', V2T contains the (M-Q)-by-(M-Q) orthogonal *> matrix V2**T. *> \endverbatim *> *> \param[in] LDV2T *> \verbatim *> LDV2T is INTEGER *> The leading dimension of V2T. If JOBV2T = 'Y', LDV2T >= *> MAX(1,M-Q). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> If INFO > 0 on exit, WORK(2:R) contains the values PHI(1), *> ..., PHI(R-1) that, together with THETA(1), ..., THETA(R), *> define the matrix in intermediate bidiagonal-block form *> remaining after nonconvergence. INFO specifies the number *> of nonzero PHI's. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. *> *> 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. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (M-MIN(P, M-P, Q, M-Q)) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: DBBCSD did not converge. See the description of WORK *> above for details. *> \endverbatim * *> \par References: * ================ *> *> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. *> Algorithms, 50(1):33-65, 2009. * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup doubleOTHERcomputational * * ===================================================================== RECURSIVE SUBROUTINE DORCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, $ SIGNS, M, P, Q, X11, LDX11, X12, $ LDX12, X21, LDX21, X22, LDX22, THETA, $ U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, $ LDV2T, WORK, LWORK, IWORK, INFO ) * * -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, SIGNS, TRANS INTEGER INFO, LDU1, LDU2, LDV1T, LDV2T, LDX11, LDX12, $ LDX21, LDX22, LWORK, M, P, Q * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION THETA( * ) DOUBLE PRECISION U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ), $ V2T( LDV2T, * ), WORK( * ), X11( LDX11, * ), $ X12( LDX12, * ), X21( LDX21, * ), X22( LDX22, $ * ) * .. * * =================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, $ ZERO = 0.0D0 ) * .. * .. Local Scalars .. CHARACTER TRANST, SIGNST INTEGER CHILDINFO, I, IB11D, IB11E, IB12D, IB12E, $ IB21D, IB21E, IB22D, IB22E, IBBCSD, IORBDB, $ IORGLQ, IORGQR, IPHI, ITAUP1, ITAUP2, ITAUQ1, $ ITAUQ2, J, LBBCSDWORK, LBBCSDWORKMIN, $ LBBCSDWORKOPT, LORBDBWORK, LORBDBWORKMIN, $ LORBDBWORKOPT, LORGLQWORK, LORGLQWORKMIN, $ LORGLQWORKOPT, LORGQRWORK, LORGQRWORKMIN, $ LORGQRWORKOPT, LWORKMIN, LWORKOPT LOGICAL COLMAJOR, DEFAULTSIGNS, LQUERY, WANTU1, WANTU2, $ WANTV1T, WANTV2T * .. * .. External Subroutines .. EXTERNAL DBBCSD, DLACPY, DLAPMR, DLAPMT, $ DORBDB, DORGLQ, DORGQR, XERBLA * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions INTRINSIC INT, MAX, MIN * .. * .. Executable Statements .. * * Test input arguments * INFO = 0 WANTU1 = LSAME( JOBU1, 'Y' ) WANTU2 = LSAME( JOBU2, 'Y' ) WANTV1T = LSAME( JOBV1T, 'Y' ) WANTV2T = LSAME( JOBV2T, 'Y' ) COLMAJOR = .NOT. LSAME( TRANS, 'T' ) DEFAULTSIGNS = .NOT. LSAME( SIGNS, 'O' ) LQUERY = LWORK .EQ. -1 IF( M .LT. 0 ) THEN INFO = -7 ELSE IF( P .LT. 0 .OR. P .GT. M ) THEN INFO = -8 ELSE IF( Q .LT. 0 .OR. Q .GT. M ) THEN INFO = -9 ELSE IF ( COLMAJOR .AND. LDX11 .LT. MAX( 1, P ) ) THEN INFO = -11 ELSE IF (.NOT. COLMAJOR .AND. LDX11 .LT. MAX( 1, Q ) ) THEN INFO = -11 ELSE IF (COLMAJOR .AND. LDX12 .LT. MAX( 1, P ) ) THEN INFO = -13 ELSE IF (.NOT. COLMAJOR .AND. LDX12 .LT. MAX( 1, M-Q ) ) THEN INFO = -13 ELSE IF (COLMAJOR .AND. LDX21 .LT. MAX( 1, M-P ) ) THEN INFO = -15 ELSE IF (.NOT. COLMAJOR .AND. LDX21 .LT. MAX( 1, Q ) ) THEN INFO = -15 ELSE IF (COLMAJOR .AND. LDX22 .LT. MAX( 1, M-P ) ) THEN INFO = -17 ELSE IF (.NOT. COLMAJOR .AND. LDX22 .LT. MAX( 1, M-Q ) ) THEN INFO = -17 ELSE IF( WANTU1 .AND. LDU1 .LT. P ) THEN INFO = -20 ELSE IF( WANTU2 .AND. LDU2 .LT. M-P ) THEN INFO = -22 ELSE IF( WANTV1T .AND. LDV1T .LT. Q ) THEN INFO = -24 ELSE IF( WANTV2T .AND. LDV2T .LT. M-Q ) THEN INFO = -26 END IF * * Work with transpose if convenient * IF( INFO .EQ. 0 .AND. MIN( P, M-P ) .LT. MIN( Q, M-Q ) ) THEN IF( COLMAJOR ) THEN TRANST = 'T' ELSE TRANST = 'N' END IF IF( DEFAULTSIGNS ) THEN SIGNST = 'O' ELSE SIGNST = 'D' END IF CALL DORCSD( JOBV1T, JOBV2T, JOBU1, JOBU2, TRANST, SIGNST, M, $ Q, P, X11, LDX11, X21, LDX21, X12, LDX12, X22, $ LDX22, THETA, V1T, LDV1T, V2T, LDV2T, U1, LDU1, $ U2, LDU2, WORK, LWORK, IWORK, INFO ) RETURN END IF * * Work with permutation [ 0 I; I 0 ] * X * [ 0 I; I 0 ] if * convenient * IF( INFO .EQ. 0 .AND. M-Q .LT. Q ) THEN IF( DEFAULTSIGNS ) THEN SIGNST = 'O' ELSE SIGNST = 'D' END IF CALL DORCSD( JOBU2, JOBU1, JOBV2T, JOBV1T, TRANS, SIGNST, M, $ M-P, M-Q, X22, LDX22, X21, LDX21, X12, LDX12, X11, $ LDX11, THETA, U2, LDU2, U1, LDU1, V2T, LDV2T, V1T, $ LDV1T, WORK, LWORK, IWORK, INFO ) RETURN END IF * * Compute workspace * IF( INFO .EQ. 0 ) THEN * IPHI = 2 ITAUP1 = IPHI + MAX( 1, Q - 1 ) ITAUP2 = ITAUP1 + MAX( 1, P ) ITAUQ1 = ITAUP2 + MAX( 1, M - P ) ITAUQ2 = ITAUQ1 + MAX( 1, Q ) IORGQR = ITAUQ2 + MAX( 1, M - Q ) CALL DORGQR( M-Q, M-Q, M-Q, U1, MAX(1,M-Q), U1, WORK, -1, $ CHILDINFO ) LORGQRWORKOPT = INT( WORK(1) ) LORGQRWORKMIN = MAX( 1, M - Q ) IORGLQ = ITAUQ2 + MAX( 1, M - Q ) CALL DORGLQ( M-Q, M-Q, M-Q, U1, MAX(1,M-Q), U1, WORK, -1, $ CHILDINFO ) LORGLQWORKOPT = INT( WORK(1) ) LORGLQWORKMIN = MAX( 1, M - Q ) IORBDB = ITAUQ2 + MAX( 1, M - Q ) CALL DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, $ X21, LDX21, X22, LDX22, THETA, V1T, U1, U2, V1T, $ V2T, WORK, -1, CHILDINFO ) LORBDBWORKOPT = INT( WORK(1) ) LORBDBWORKMIN = LORBDBWORKOPT IB11D = ITAUQ2 + MAX( 1, M - Q ) IB11E = IB11D + MAX( 1, Q ) IB12D = IB11E + MAX( 1, Q - 1 ) IB12E = IB12D + MAX( 1, Q ) IB21D = IB12E + MAX( 1, Q - 1 ) IB21E = IB21D + MAX( 1, Q ) IB22D = IB21E + MAX( 1, Q - 1 ) IB22E = IB22D + MAX( 1, Q ) IBBCSD = IB22E + MAX( 1, Q - 1 ) CALL DBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, $ THETA, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, $ LDV2T, U1, U1, U1, U1, U1, U1, U1, U1, WORK, -1, $ CHILDINFO ) LBBCSDWORKOPT = INT( WORK(1) ) LBBCSDWORKMIN = LBBCSDWORKOPT LWORKOPT = MAX( IORGQR + LORGQRWORKOPT, IORGLQ + LORGLQWORKOPT, $ IORBDB + LORBDBWORKOPT, IBBCSD + LBBCSDWORKOPT ) - 1 LWORKMIN = MAX( IORGQR + LORGQRWORKMIN, IORGLQ + LORGLQWORKMIN, $ IORBDB + LORBDBWORKOPT, IBBCSD + LBBCSDWORKMIN ) - 1 WORK(1) = MAX(LWORKOPT,LWORKMIN) * IF( LWORK .LT. LWORKMIN .AND. .NOT. LQUERY ) THEN INFO = -22 ELSE LORGQRWORK = LWORK - IORGQR + 1 LORGLQWORK = LWORK - IORGLQ + 1 LORBDBWORK = LWORK - IORBDB + 1 LBBCSDWORK = LWORK - IBBCSD + 1 END IF END IF * * Abort if any illegal arguments * IF( INFO .NE. 0 ) THEN CALL XERBLA( 'DORCSD', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Transform to bidiagonal block form * CALL DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, $ LDX21, X22, LDX22, THETA, WORK(IPHI), WORK(ITAUP1), $ WORK(ITAUP2), WORK(ITAUQ1), WORK(ITAUQ2), $ WORK(IORBDB), LORBDBWORK, CHILDINFO ) * * Accumulate Householder reflectors * IF( COLMAJOR ) THEN IF( WANTU1 .AND. P .GT. 0 ) THEN CALL DLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 ) CALL DORGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR), $ LORGQRWORK, INFO) END IF IF( WANTU2 .AND. M-P .GT. 0 ) THEN CALL DLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 ) CALL DORGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2), $ WORK(IORGQR), LORGQRWORK, INFO ) END IF IF( WANTV1T .AND. Q .GT. 0 ) THEN CALL DLACPY( 'U', Q-1, Q-1, X11(1,2), LDX11, V1T(2,2), $ LDV1T ) V1T(1, 1) = ONE DO J = 2, Q V1T(1,J) = ZERO V1T(J,1) = ZERO END DO CALL DORGLQ( Q-1, Q-1, Q-1, V1T(2,2), LDV1T, WORK(ITAUQ1), $ WORK(IORGLQ), LORGLQWORK, INFO ) END IF IF( WANTV2T .AND. M-Q .GT. 0 ) THEN CALL DLACPY( 'U', P, M-Q, X12, LDX12, V2T, LDV2T ) IF (M-P .GT. Q) Then CALL DLACPY( 'U', M-P-Q, M-P-Q, X22(Q+1,P+1), LDX22, $ V2T(P+1,P+1), LDV2T ) END IF IF (M .GT. Q) THEN CALL DORGLQ( M-Q, M-Q, M-Q, V2T, LDV2T, WORK(ITAUQ2), $ WORK(IORGLQ), LORGLQWORK, INFO ) END IF END IF ELSE IF( WANTU1 .AND. P .GT. 0 ) THEN CALL DLACPY( 'U', Q, P, X11, LDX11, U1, LDU1 ) CALL DORGLQ( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGLQ), $ LORGLQWORK, INFO) END IF IF( WANTU2 .AND. M-P .GT. 0 ) THEN CALL DLACPY( 'U', Q, M-P, X21, LDX21, U2, LDU2 ) CALL DORGLQ( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2), $ WORK(IORGLQ), LORGLQWORK, INFO ) END IF IF( WANTV1T .AND. Q .GT. 0 ) THEN CALL DLACPY( 'L', Q-1, Q-1, X11(2,1), LDX11, V1T(2,2), $ LDV1T ) V1T(1, 1) = ONE DO J = 2, Q V1T(1,J) = ZERO V1T(J,1) = ZERO END DO CALL DORGQR( Q-1, Q-1, Q-1, V1T(2,2), LDV1T, WORK(ITAUQ1), $ WORK(IORGQR), LORGQRWORK, INFO ) END IF IF( WANTV2T .AND. M-Q .GT. 0 ) THEN CALL DLACPY( 'L', M-Q, P, X12, LDX12, V2T, LDV2T ) CALL DLACPY( 'L', M-P-Q, M-P-Q, X22(P+1,Q+1), LDX22, $ V2T(P+1,P+1), LDV2T ) CALL DORGQR( M-Q, M-Q, M-Q, V2T, LDV2T, WORK(ITAUQ2), $ WORK(IORGQR), LORGQRWORK, INFO ) END IF END IF * * Compute the CSD of the matrix in bidiagonal-block form * CALL DBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, THETA, $ WORK(IPHI), U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, $ LDV2T, WORK(IB11D), WORK(IB11E), WORK(IB12D), $ WORK(IB12E), WORK(IB21D), WORK(IB21E), WORK(IB22D), $ WORK(IB22E), WORK(IBBCSD), LBBCSDWORK, INFO ) * * Permute rows and columns to place identity submatrices in top- * left corner of (1,1)-block and/or bottom-right corner of (1,2)- * block and/or bottom-right corner of (2,1)-block and/or top-left * corner of (2,2)-block * IF( Q .GT. 0 .AND. WANTU2 ) THEN DO I = 1, Q IWORK(I) = M - P - Q + I END DO DO I = Q + 1, M - P IWORK(I) = I - Q END DO IF( COLMAJOR ) THEN CALL DLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK ) ELSE CALL DLAPMR( .FALSE., M-P, M-P, U2, LDU2, IWORK ) END IF END IF IF( M .GT. 0 .AND. WANTV2T ) THEN DO I = 1, P IWORK(I) = M - P - Q + I END DO DO I = P + 1, M - Q IWORK(I) = I - P END DO IF( .NOT. COLMAJOR ) THEN CALL DLAPMT( .FALSE., M-Q, M-Q, V2T, LDV2T, IWORK ) ELSE CALL DLAPMR( .FALSE., M-Q, M-Q, V2T, LDV2T, IWORK ) END IF END IF * RETURN * * End DORCSD * END *> \brief \b DORG2L generates all or part of the orthogonal matrix Q from a QL factorization determined by sgeqlf (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORG2L + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DORG2L generates an m by n real matrix Q with orthonormal columns, *> which is defined as the last n columns of a product of k elementary *> reflectors of order m *> *> Q = H(k) . . . H(2) H(1) *> *> as returned by DGEQLF. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix Q. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix Q. M >= N >= 0. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The number of elementary reflectors whose product defines the *> matrix Q. N >= K >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the (n-k+i)-th column must contain the vector which *> defines the elementary reflector H(i), for i = 1,2,...,k, as *> returned by DGEQLF in the last k columns of its array *> argument A. *> On exit, the m by n matrix Q. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The first dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DGEQLF. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument has an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, II, J, L * .. * .. External Subroutines .. EXTERNAL DLARF, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORG2L', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.0 ) $ RETURN * * Initialise columns 1:n-k to columns of the unit matrix * DO 20 J = 1, N - K DO 10 L = 1, M A( L, J ) = ZERO 10 CONTINUE A( M-N+J, J ) = ONE 20 CONTINUE * DO 40 I = 1, K II = N - K + I * * Apply H(i) to A(1:m-k+i,1:n-k+i) from the left * A( M-N+II, II ) = ONE CALL DLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A, $ LDA, WORK ) CALL DSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 ) A( M-N+II, II ) = ONE - TAU( I ) * * Set A(m-k+i+1:m,n-k+i) to zero * DO 30 L = M - N + II + 1, M A( L, II ) = ZERO 30 CONTINUE 40 CONTINUE RETURN * * End of DORG2L * END *> \brief \b DORG2R generates all or part of the orthogonal matrix Q from a QR factorization determined by sgeqrf (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORG2R + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DORG2R generates an m by n real matrix Q with orthonormal columns, *> which is defined as the first n columns of a product of k elementary *> reflectors of order m *> *> Q = H(1) H(2) . . . H(k) *> *> as returned by DGEQRF. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix Q. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix Q. M >= N >= 0. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The number of elementary reflectors whose product defines the *> matrix Q. N >= K >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the i-th column must contain the vector which *> defines the elementary reflector H(i), for i = 1,2,...,k, as *> returned by DGEQRF in the first k columns of its array *> argument A. *> On exit, the m-by-n matrix Q. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The first dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DGEQRF. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument has an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J, L * .. * .. External Subroutines .. EXTERNAL DLARF, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORG2R', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.0 ) $ RETURN * * Initialise columns k+1:n to columns of the unit matrix * DO 20 J = K + 1, N DO 10 L = 1, M A( L, J ) = ZERO 10 CONTINUE A( J, J ) = ONE 20 CONTINUE * DO 40 I = K, 1, -1 * * Apply H(i) to A(i:m,i:n) from the left * IF( I.LT.N ) THEN A( I, I ) = ONE CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), $ A( I, I+1 ), LDA, WORK ) END IF IF( I.LT.M ) $ CALL DSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) A( I, I ) = ONE - TAU( I ) * * Set A(1:i-1,i) to zero * DO 30 L = 1, I - 1 A( L, I ) = ZERO 30 CONTINUE 40 CONTINUE RETURN * * End of DORG2R * END *> \brief \b DORGBR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORGBR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER VECT * INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DORGBR generates one of the real orthogonal matrices Q or P**T *> determined by DGEBRD when reducing a real matrix A to bidiagonal *> form: A = Q * B * P**T. Q and P**T are defined as products of *> elementary reflectors H(i) or G(i) respectively. *> *> If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q *> is of order M: *> if m >= k, Q = H(1) H(2) . . . H(k) and DORGBR returns the first n *> columns of Q, where m >= n >= k; *> if m < k, Q = H(1) H(2) . . . H(m-1) and DORGBR returns Q as an *> M-by-M matrix. *> *> If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T *> is of order N: *> if k < n, P**T = G(k) . . . G(2) G(1) and DORGBR returns the first m *> rows of P**T, where n >= m >= k; *> if k >= n, P**T = G(n-1) . . . G(2) G(1) and DORGBR returns P**T as *> an N-by-N matrix. *> \endverbatim * * Arguments: * ========== * *> \param[in] VECT *> \verbatim *> VECT is CHARACTER*1 *> Specifies whether the matrix Q or the matrix P**T is *> required, as defined in the transformation applied by DGEBRD: *> = 'Q': generate Q; *> = 'P': generate P**T. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix Q or P**T to be returned. *> M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix Q or P**T to be returned. *> N >= 0. *> If VECT = 'Q', M >= N >= min(M,K); *> if VECT = 'P', N >= M >= min(N,K). *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> If VECT = 'Q', the number of columns in the original M-by-K *> matrix reduced by DGEBRD. *> If VECT = 'P', the number of rows in the original K-by-N *> matrix reduced by DGEBRD. *> K >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the vectors which define the elementary reflectors, *> as returned by DGEBRD. *> On exit, the M-by-N matrix Q or P**T. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension *> (min(M,K)) if VECT = 'Q' *> (min(N,K)) if VECT = 'P' *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i) or G(i), which determines Q or P**T, as *> returned by DGEBRD in its array argument TAUQ or TAUP. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= max(1,min(M,N)). *> For optimum performance LWORK >= min(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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date April 2012 * *> \ingroup doubleGBcomputational * * ===================================================================== SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * April 2012 * * .. Scalar Arguments .. CHARACTER VECT INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, WANTQ INTEGER I, IINFO, J, LWKOPT, MN * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DORGLQ, DORGQR, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 WANTQ = LSAME( VECT, 'Q' ) MN = MIN( M, N ) LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -2 ELSE IF( N.LT.0 .OR. ( WANTQ .AND. ( N.GT.M .OR. N.LT.MIN( M, $ K ) ) ) .OR. ( .NOT.WANTQ .AND. ( M.GT.N .OR. M.LT. $ MIN( N, K ) ) ) ) THEN INFO = -3 ELSE IF( K.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF( LWORK.LT.MAX( 1, MN ) .AND. .NOT.LQUERY ) THEN INFO = -9 END IF * IF( INFO.EQ.0 ) THEN WORK( 1 ) = 1 IF( WANTQ ) THEN IF( M.GE.K ) THEN CALL DORGQR( M, N, K, A, LDA, TAU, WORK, -1, IINFO ) ELSE IF( M.GT.1 ) THEN CALL DORGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK, $ -1, IINFO ) END IF END IF ELSE IF( K.LT.N ) THEN CALL DORGLQ( M, N, K, A, LDA, TAU, WORK, -1, IINFO ) ELSE IF( N.GT.1 ) THEN CALL DORGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, $ -1, IINFO ) END IF END IF END IF LWKOPT = WORK( 1 ) LWKOPT = MAX (LWKOPT, MN) END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORGBR', -INFO ) RETURN ELSE IF( LQUERY ) THEN WORK( 1 ) = LWKOPT RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * IF( WANTQ ) THEN * * Form Q, determined by a call to DGEBRD to reduce an m-by-k * matrix * IF( M.GE.K ) THEN * * If m >= k, assume m >= n >= k * CALL DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO ) * ELSE * * If m < k, assume m = n * * Shift the vectors which define the elementary reflectors one * column to the right, and set the first row and column of Q * to those of the unit matrix * DO 20 J = M, 2, -1 A( 1, J ) = ZERO DO 10 I = J + 1, M A( I, J ) = A( I, J-1 ) 10 CONTINUE 20 CONTINUE A( 1, 1 ) = ONE DO 30 I = 2, M A( I, 1 ) = ZERO 30 CONTINUE IF( M.GT.1 ) THEN * * Form Q(2:m,2:m) * CALL DORGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK, $ LWORK, IINFO ) END IF END IF ELSE * * Form P**T, determined by a call to DGEBRD to reduce a k-by-n * matrix * IF( K.LT.N ) THEN * * If k < n, assume k <= m <= n * CALL DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO ) * ELSE * * If k >= n, assume m = n * * Shift the vectors which define the elementary reflectors one * row downward, and set the first row and column of P**T to * those of the unit matrix * A( 1, 1 ) = ONE DO 40 I = 2, N A( I, 1 ) = ZERO 40 CONTINUE DO 60 J = 2, N DO 50 I = J - 1, 2, -1 A( I, J ) = A( I-1, J ) 50 CONTINUE A( 1, J ) = ZERO 60 CONTINUE IF( N.GT.1 ) THEN * * Form P**T(2:n,2:n) * CALL DORGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, $ LWORK, IINFO ) END IF END IF END IF WORK( 1 ) = LWKOPT RETURN * * End of DORGBR * END *> \brief \b DORGHR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORGHR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * INTEGER IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DORGHR generates a real orthogonal matrix Q which is defined as the *> product of IHI-ILO elementary reflectors of order N, as returned by *> DGEHRD: *> *> Q = H(ilo) H(ilo+1) . . . H(ihi-1). *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix Q. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> *> ILO and IHI must have the same values as in the previous call *> of DGEHRD. Q is equal to the unit matrix except in the *> submatrix Q(ilo+1:ihi,ilo+1:ihi). *> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the vectors which define the elementary reflectors, *> as returned by DGEHRD. *> On exit, the N-by-N orthogonal matrix Q. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (N-1) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DGEHRD. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= IHI-ILO. *> For optimum performance LWORK >= (IHI-ILO)*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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IINFO, J, LWKOPT, NB, NH * .. * .. External Subroutines .. EXTERNAL DORGQR, XERBLA * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NH = IHI - ILO 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, NH ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF * IF( INFO.EQ.0 ) THEN NB = ILAENV( 1, 'DORGQR', ' ', NH, NH, NH, -1 ) LWKOPT = MAX( 1, NH )*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORGHR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * * Shift the vectors which define the elementary reflectors one * column to the right, and set the first ilo and the last n-ihi * rows and columns to those of the unit matrix * DO 40 J = IHI, ILO + 1, -1 DO 10 I = 1, J - 1 A( I, J ) = ZERO 10 CONTINUE DO 20 I = J + 1, IHI A( I, J ) = A( I, J-1 ) 20 CONTINUE DO 30 I = IHI + 1, N A( I, J ) = ZERO 30 CONTINUE 40 CONTINUE DO 60 J = 1, ILO DO 50 I = 1, N A( I, J ) = ZERO 50 CONTINUE A( J, J ) = ONE 60 CONTINUE DO 80 J = IHI + 1, N DO 70 I = 1, N A( I, J ) = ZERO 70 CONTINUE A( J, J ) = ONE 80 CONTINUE * IF( NH.GT.0 ) THEN * * Generate Q(ilo+1:ihi,ilo+1:ihi) * CALL DORGQR( NH, NH, NH, A( ILO+1, ILO+1 ), LDA, TAU( ILO ), $ WORK, LWORK, IINFO ) END IF WORK( 1 ) = LWKOPT RETURN * * End of DORGHR * END *> \brief \b DORGL2 * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORGL2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DORGL2 generates an m by n real matrix Q with orthonormal rows, *> which is defined as the first m rows of a product of k elementary *> reflectors of order n *> *> Q = H(k) . . . H(2) H(1) *> *> as returned by DGELQF. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix Q. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix Q. N >= M. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The number of elementary reflectors whose product defines the *> matrix Q. M >= K >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the i-th row must contain the vector which defines *> the elementary reflector H(i), for i = 1,2,...,k, as returned *> by DGELQF in the first k rows of its array argument A. *> On exit, the m-by-n matrix Q. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The first dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DGELQF. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (M) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument has an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J, L * .. * .. External Subroutines .. EXTERNAL DLARF, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.M ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORGL2', -INFO ) RETURN END IF * * Quick return if possible * IF( M.LE.0 ) $ RETURN * IF( K.LT.M ) THEN * * Initialise rows k+1:m to rows of the unit matrix * DO 20 J = 1, N DO 10 L = K + 1, M A( L, J ) = ZERO 10 CONTINUE IF( J.GT.K .AND. J.LE.M ) $ A( J, J ) = ONE 20 CONTINUE END IF * DO 40 I = K, 1, -1 * * Apply H(i) to A(i:m,i:n) from the right * IF( I.LT.N ) THEN IF( I.LT.M ) THEN A( I, I ) = ONE CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, $ TAU( I ), A( I+1, I ), LDA, WORK ) END IF CALL DSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA ) END IF A( I, I ) = ONE - TAU( I ) * * Set A(i,1:i-1) to zero * DO 30 L = 1, I - 1 A( I, L ) = ZERO 30 CONTINUE 40 CONTINUE RETURN * * End of DORGL2 * END *> \brief \b DORGLQ * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORGLQ + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DORGLQ generates an M-by-N real matrix Q with orthonormal rows, *> which is defined as the first M rows of a product of K elementary *> reflectors of order N *> *> Q = H(k) . . . H(2) H(1) *> *> as returned by DGELQF. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix Q. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix Q. N >= M. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The number of elementary reflectors whose product defines the *> matrix Q. M >= K >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the i-th row must contain the vector which defines *> the elementary reflector H(i), for i = 1,2,...,k, as returned *> by DGELQF in the first k rows of its array argument A. *> On exit, the M-by-N matrix Q. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The first dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DGELQF. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument has an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, $ LWKOPT, NB, NBMIN, NX * .. * .. External Subroutines .. EXTERNAL DLARFB, DLARFT, DORGL2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NB = ILAENV( 1, 'DORGLQ', ' ', M, N, K, -1 ) LWKOPT = MAX( 1, M )*NB WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.M ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORGLQ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.LE.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, 'DORGLQ', ' ', M, N, K, -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, 'DORGLQ', ' ', M, N, K, -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code after the last block. * The first kk rows are handled by the block method. * KI = ( ( K-NX-1 ) / NB )*NB KK = MIN( K, KI+NB ) * * Set A(kk+1:m,1:kk) to zero. * DO 20 J = 1, KK DO 10 I = KK + 1, M A( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE KK = 0 END IF * * Use unblocked code for the last or only block. * IF( KK.LT.M ) $ CALL DORGL2( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, $ TAU( KK+1 ), WORK, IINFO ) * IF( KK.GT.0 ) THEN * * Use blocked code * DO 50 I = KI + 1, 1, -NB IB = MIN( NB, K-I+1 ) IF( I+IB.LE.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**T to A(i+ib:m,i:n) from the right * CALL DLARFB( 'Right', '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 * * Apply H**T to columns i:n of current block * CALL DORGL2( IB, N-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) * * Set columns 1:i-1 of current block to zero * DO 40 J = 1, I - 1 DO 30 L = I, I + IB - 1 A( L, J ) = ZERO 30 CONTINUE 40 CONTINUE 50 CONTINUE END IF * WORK( 1 ) = IWS RETURN * * End of DORGLQ * END *> \brief \b DORGQL * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORGQL + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DORGQL generates an M-by-N real matrix Q with orthonormal columns, *> which is defined as the last N columns of a product of K elementary *> reflectors of order M *> *> Q = H(k) . . . H(2) H(1) *> *> as returned by DGEQLF. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix Q. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix Q. M >= N >= 0. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The number of elementary reflectors whose product defines the *> matrix Q. N >= K >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the (n-k+i)-th column must contain the vector which *> defines the elementary reflector H(i), for i = 1,2,...,k, as *> returned by DGEQLF in the last k columns of its array *> argument A. *> On exit, the M-by-N matrix Q. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The first dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DGEQLF. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument has an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT, $ NB, NBMIN, NX * .. * .. External Subroutines .. EXTERNAL DLARFB, DLARFT, DORG2L, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 END IF * IF( INFO.EQ.0 ) THEN IF( N.EQ.0 ) THEN LWKOPT = 1 ELSE NB = ILAENV( 1, 'DORGQL', ' ', M, N, K, -1 ) LWKOPT = N*NB END IF WORK( 1 ) = LWKOPT * IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORGQL', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.LE.0 ) THEN 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, 'DORGQL', ' ', M, N, K, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = N IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'DORGQL', ' ', M, N, K, -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code after the first block. * The last kk columns are handled by the block method. * KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB ) * * Set A(m-kk+1:m,1:n-kk) to zero. * DO 20 J = 1, N - KK DO 10 I = M - KK + 1, M A( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE KK = 0 END IF * * Use unblocked code for the first or only block. * CALL DORG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO ) * IF( KK.GT.0 ) THEN * * Use blocked code * DO 50 I = K - KK + 1, K, NB IB = MIN( NB, K-I+1 ) IF( N-K+I.GT.1 ) THEN * * Form the triangular factor of the block reflector * H = H(i+ib-1) . . . H(i+1) H(i) * CALL DLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB, $ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK ) * * Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left * CALL DLARFB( 'Left', 'No transpose', 'Backward', $ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB, $ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA, $ WORK( IB+1 ), LDWORK ) END IF * * Apply H to rows 1:m-k+i+ib-1 of current block * CALL DORG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA, $ TAU( I ), WORK, IINFO ) * * Set rows m-k+i+ib:m of current block to zero * DO 40 J = N - K + I, N - K + I + IB - 1 DO 30 L = M - K + I + IB, M A( L, J ) = ZERO 30 CONTINUE 40 CONTINUE 50 CONTINUE END IF * WORK( 1 ) = IWS RETURN * * End of DORGQL * END *> \brief \b DORGQR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORGQR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DORGQR generates an M-by-N real matrix Q with orthonormal columns, *> which is defined as the first N columns of a product of K elementary *> reflectors of order M *> *> Q = H(1) H(2) . . . H(k) *> *> as returned by DGEQRF. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix Q. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix Q. M >= N >= 0. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The number of elementary reflectors whose product defines the *> matrix Q. N >= K >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the i-th column must contain the vector which *> defines the elementary reflector H(i), for i = 1,2,...,k, as *> returned by DGEQRF in the first k columns of its array *> argument A. *> On exit, the M-by-N matrix Q. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The first dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DGEQRF. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument has an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, $ LWKOPT, NB, NBMIN, NX * .. * .. External Subroutines .. EXTERNAL DLARFB, DLARFT, DORG2R, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 ) LWKOPT = MAX( 1, N )*NB WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORGQR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.LE.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, 'DORGQR', ' ', M, N, K, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = N IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'DORGQR', ' ', M, N, K, -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code after the last block. * The first kk columns are handled by the block method. * KI = ( ( K-NX-1 ) / NB )*NB KK = MIN( K, KI+NB ) * * Set A(1:kk,kk+1:n) to zero. * DO 20 J = KK + 1, N DO 10 I = 1, KK A( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE KK = 0 END IF * * Use unblocked code for the last or only block. * IF( KK.LT.N ) $ CALL DORG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, $ TAU( KK+1 ), WORK, IINFO ) * IF( KK.GT.0 ) THEN * * Use blocked code * DO 50 I = KI + 1, 1, -NB IB = MIN( NB, K-I+1 ) IF( I+IB.LE.N ) THEN * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) * * Apply H to A(i:m,i+ib:n) from the left * CALL DLARFB( 'Left', 'No transpose', 'Forward', $ 'Columnwise', M-I+1, N-I-IB+1, IB, $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), $ LDA, WORK( IB+1 ), LDWORK ) END IF * * Apply H to rows i:m of current block * CALL DORG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) * * Set rows 1:i-1 of current block to zero * DO 40 J = I, I + IB - 1 DO 30 L = 1, I - 1 A( L, J ) = ZERO 30 CONTINUE 40 CONTINUE 50 CONTINUE END IF * WORK( 1 ) = IWS RETURN * * End of DORGQR * END *> \brief \b DORGR2 generates all or part of the orthogonal matrix Q from an RQ factorization determined by sgerqf (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORGR2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORGR2( M, N, K, A, LDA, TAU, WORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DORGR2 generates an m by n real matrix Q with orthonormal rows, *> which is defined as the last m rows of a product of k elementary *> reflectors of order n *> *> Q = H(1) H(2) . . . H(k) *> *> as returned by DGERQF. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix Q. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix Q. N >= M. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The number of elementary reflectors whose product defines the *> matrix Q. M >= K >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the (m-k+i)-th row must contain the vector which *> defines the elementary reflector H(i), for i = 1,2,...,k, as *> returned by DGERQF in the last k rows of its array argument *> A. *> On exit, the m by n matrix Q. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The first dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DGERQF. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (M) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument has an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORGR2( M, N, K, A, LDA, TAU, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, II, J, L * .. * .. External Subroutines .. EXTERNAL DLARF, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.M ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORGR2', -INFO ) RETURN END IF * * Quick return if possible * IF( M.LE.0 ) $ RETURN * IF( K.LT.M ) THEN * * Initialise rows 1:m-k to rows of the unit matrix * DO 20 J = 1, N DO 10 L = 1, M - K A( L, J ) = ZERO 10 CONTINUE IF( J.GT.N-M .AND. J.LE.N-K ) $ A( M-N+J, J ) = ONE 20 CONTINUE END IF * DO 40 I = 1, K II = M - K + I * * Apply H(i) to A(1:m-k+i,1:n-k+i) from the right * A( II, N-M+II ) = ONE CALL DLARF( 'Right', II-1, N-M+II, A( II, 1 ), LDA, TAU( I ), $ A, LDA, WORK ) CALL DSCAL( N-M+II-1, -TAU( I ), A( II, 1 ), LDA ) A( II, N-M+II ) = ONE - TAU( I ) * * Set A(m-k+i,n-k+i+1:n) to zero * DO 30 L = N - M + II + 1, N A( II, L ) = ZERO 30 CONTINUE 40 CONTINUE RETURN * * End of DORGR2 * END *> \brief \b DORGRQ * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORGRQ + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DORGRQ generates an M-by-N real matrix Q with orthonormal rows, *> which is defined as the last M rows of a product of K elementary *> reflectors of order N *> *> Q = H(1) H(2) . . . H(k) *> *> as returned by DGERQF. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix Q. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix Q. N >= M. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The number of elementary reflectors whose product defines the *> matrix Q. M >= K >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the (m-k+i)-th row must contain the vector which *> defines the elementary reflector H(i), for i = 1,2,...,k, as *> returned by DGERQF in the last k rows of its array argument *> A. *> On exit, the M-by-N matrix Q. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The first dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DGERQF. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument has an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, II, IINFO, IWS, J, KK, L, LDWORK, $ LWKOPT, NB, NBMIN, NX * .. * .. External Subroutines .. EXTERNAL DLARFB, DLARFT, DORGR2, 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.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.M ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 END IF * IF( INFO.EQ.0 ) THEN IF( M.LE.0 ) THEN LWKOPT = 1 ELSE NB = ILAENV( 1, 'DORGRQ', ' ', M, N, K, -1 ) LWKOPT = M*NB END IF WORK( 1 ) = LWKOPT * IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORGRQ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.LE.0 ) THEN 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, 'DORGRQ', ' ', M, N, K, -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, 'DORGRQ', ' ', M, N, K, -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code after the first block. * The last kk rows are handled by the block method. * KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB ) * * Set A(1:m-kk,n-kk+1:n) to zero. * DO 20 J = N - KK + 1, N DO 10 I = 1, M - KK A( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE KK = 0 END IF * * Use unblocked code for the first or only block. * CALL DORGR2( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO ) * IF( KK.GT.0 ) THEN * * Use blocked code * DO 50 I = K - KK + 1, K, NB IB = MIN( NB, K-I+1 ) II = M - K + I IF( II.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( II, 1 ), LDA, TAU( I ), WORK, LDWORK ) * * Apply H**T to A(1:m-k+i-1,1:n-k+i+ib-1) from the right * CALL DLARFB( 'Right', 'Transpose', 'Backward', 'Rowwise', $ II-1, N-K+I+IB-1, IB, A( II, 1 ), LDA, WORK, $ LDWORK, A, LDA, WORK( IB+1 ), LDWORK ) END IF * * Apply H**T to columns 1:n-k+i+ib-1 of current block * CALL DORGR2( IB, N-K+I+IB-1, IB, A( II, 1 ), LDA, TAU( I ), $ WORK, IINFO ) * * Set columns n-k+i+ib:n of current block to zero * DO 40 L = N - K + I + IB, N DO 30 J = II, II + IB - 1 A( J, L ) = ZERO 30 CONTINUE 40 CONTINUE 50 CONTINUE END IF * WORK( 1 ) = IWS RETURN * * End of DORGRQ * END *> \brief \b DORGTR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORGTR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LWORK, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DORGTR generates a real orthogonal matrix Q which is defined as the *> product of n-1 elementary reflectors of order N, as returned by *> DSYTRD: *> *> if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), *> *> if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A contains elementary reflectors *> from DSYTRD; *> = 'L': Lower triangle of A contains elementary reflectors *> from DSYTRD. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix Q. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the vectors which define the elementary reflectors, *> as returned by DSYTRD. *> On exit, the N-by-N orthogonal matrix Q. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (N-1) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DSYTRD. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= max(1,N-1). *> For optimum performance LWORK >= (N-1)*NB, where NB is *> the optimal blocksize. *> *> 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, UPPER INTEGER I, IINFO, J, LWKOPT, NB * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DORGQL, DORGQR, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN INFO = -7 END IF * IF( INFO.EQ.0 ) THEN IF( UPPER ) THEN NB = ILAENV( 1, 'DORGQL', ' ', N-1, N-1, N-1, -1 ) ELSE NB = ILAENV( 1, 'DORGQR', ' ', N-1, N-1, N-1, -1 ) END IF LWKOPT = MAX( 1, N-1 )*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORGTR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * IF( UPPER ) THEN * * Q was determined by a call to DSYTRD with UPLO = 'U' * * Shift the vectors which define the elementary reflectors one * column to the left, and set the last row and column of Q to * those of the unit matrix * DO 20 J = 1, N - 1 DO 10 I = 1, J - 1 A( I, J ) = A( I, J+1 ) 10 CONTINUE A( N, J ) = ZERO 20 CONTINUE DO 30 I = 1, N - 1 A( I, N ) = ZERO 30 CONTINUE A( N, N ) = ONE * * Generate Q(1:n-1,1:n-1) * CALL DORGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO ) * ELSE * * Q was determined by a call to DSYTRD with UPLO = 'L'. * * Shift the vectors which define the elementary reflectors one * column to the right, and set the first row and column of Q to * those of the unit matrix * DO 50 J = N, 2, -1 A( 1, J ) = ZERO DO 40 I = J + 1, N A( I, J ) = A( I, J-1 ) 40 CONTINUE 50 CONTINUE A( 1, 1 ) = ONE DO 60 I = 2, N A( I, 1 ) = ZERO 60 CONTINUE IF( N.GT.1 ) THEN * * Generate Q(2:n,2:n) * CALL DORGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, $ LWORK, IINFO ) END IF END IF WORK( 1 ) = LWKOPT RETURN * * End of DORGTR * END *> \brief \b DORM2L multiplies a general matrix by the orthogonal matrix from a QL factorization determined by sgeqlf (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORM2L + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, INFO ) * * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DORM2L overwrites the general real m by n matrix C with *> *> Q * C if SIDE = 'L' and TRANS = 'N', or *> *> Q**T * C if SIDE = 'L' and TRANS = 'T', or *> *> C * Q if SIDE = 'R' and TRANS = 'N', or *> *> C * Q**T if SIDE = 'R' and TRANS = 'T', *> *> where Q is a real orthogonal matrix defined as the product of k *> elementary reflectors *> *> Q = H(k) . . . H(2) H(1) *> *> as returned by DGEQLF. Q is of order m if SIDE = 'L' and of order n *> if SIDE = 'R'. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply Q or Q**T from the Left *> = 'R': apply Q or Q**T from the Right *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': apply Q (No transpose) *> = 'T': apply Q**T (Transpose) *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. N >= 0. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The number of elementary reflectors whose product defines *> the matrix Q. *> If SIDE = 'L', M >= K >= 0; *> if SIDE = 'R', N >= K >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,K) *> The i-th column must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> DGEQLF in the last k columns of its array argument A. *> A is modified by the routine but restored on exit. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. *> If SIDE = 'L', LDA >= max(1,M); *> if SIDE = 'R', LDA >= max(1,N). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DGEQLF. *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (LDC,N) *> On entry, the m by n matrix C. *> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDC >= max(1,M). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension *> (N) if SIDE = 'L', *> (M) if SIDE = 'R' *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDA, LDC, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, MI, NI, NQ DOUBLE PRECISION AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLARF, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) * * NQ is the order of Q * IF( LEFT ) THEN NQ = M ELSE NQ = N END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORM2L', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) $ RETURN * IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) $ THEN I1 = 1 I2 = K I3 = 1 ELSE I1 = K I2 = 1 I3 = -1 END IF * IF( LEFT ) THEN NI = N ELSE MI = M END IF * DO 10 I = I1, I2, I3 IF( LEFT ) THEN * * H(i) is applied to C(1:m-k+i,1:n) * MI = M - K + I ELSE * * H(i) is applied to C(1:m,1:n-k+i) * NI = N - K + I END IF * * Apply H(i) * AII = A( NQ-K+I, I ) A( NQ-K+I, I ) = ONE CALL DLARF( SIDE, MI, NI, A( 1, I ), 1, TAU( I ), C, LDC, $ WORK ) A( NQ-K+I, I ) = AII 10 CONTINUE RETURN * * End of DORM2L * END *> \brief \b DORM2R multiplies a general matrix by the orthogonal matrix from a QR factorization determined by sgeqrf (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORM2R + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, INFO ) * * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DORM2R overwrites the general real m by n matrix C with *> *> Q * C if SIDE = 'L' and TRANS = 'N', or *> *> Q**T* C if SIDE = 'L' and TRANS = 'T', or *> *> C * Q if SIDE = 'R' and TRANS = 'N', or *> *> C * Q**T if SIDE = 'R' and TRANS = 'T', *> *> where Q is a real orthogonal matrix defined as the product of k *> elementary reflectors *> *> Q = H(1) H(2) . . . H(k) *> *> as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n *> if SIDE = 'R'. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply Q or Q**T from the Left *> = 'R': apply Q or Q**T from the Right *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': apply Q (No transpose) *> = 'T': apply Q**T (Transpose) *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. N >= 0. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The number of elementary reflectors whose product defines *> the matrix Q. *> If SIDE = 'L', M >= K >= 0; *> if SIDE = 'R', N >= K >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,K) *> The i-th column must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> DGEQRF in the first k columns of its array argument A. *> A is modified by the routine but restored on exit. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. *> If SIDE = 'L', LDA >= max(1,M); *> if SIDE = 'R', LDA >= max(1,N). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DGEQRF. *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (LDC,N) *> On entry, the m by n matrix C. *> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDC >= max(1,M). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension *> (N) if SIDE = 'L', *> (M) if SIDE = 'R' *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDA, LDC, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ DOUBLE PRECISION AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLARF, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) * * NQ is the order of Q * IF( LEFT ) THEN NQ = M ELSE NQ = N END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORM2R', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) $ RETURN * IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) $ THEN I1 = 1 I2 = K I3 = 1 ELSE I1 = K I2 = 1 I3 = -1 END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * DO 10 I = I1, I2, I3 IF( LEFT ) THEN * * H(i) is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H(i) is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H(i) * AII = A( I, I ) A( I, I ) = ONE CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ), $ LDC, WORK ) A( I, I ) = AII 10 CONTINUE RETURN * * End of DORM2R * END *> \brief \b DORMBR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORMBR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, * LDC, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER SIDE, TRANS, VECT * INTEGER INFO, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> If VECT = 'Q', DORMBR overwrites the general real M-by-N matrix C *> with *> SIDE = 'L' SIDE = 'R' *> TRANS = 'N': Q * C C * Q *> TRANS = 'T': Q**T * C C * Q**T *> *> If VECT = 'P', DORMBR overwrites the general real M-by-N matrix C *> with *> SIDE = 'L' SIDE = 'R' *> TRANS = 'N': P * C C * P *> TRANS = 'T': P**T * C C * P**T *> *> Here Q and P**T are the orthogonal matrices determined by DGEBRD when *> reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and *> P**T are defined as products of elementary reflectors H(i) and G(i) *> respectively. *> *> Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the *> order of the orthogonal matrix Q or P**T that is applied. *> *> If VECT = 'Q', A is assumed to have been an NQ-by-K matrix: *> if nq >= k, Q = H(1) H(2) . . . H(k); *> if nq < k, Q = H(1) H(2) . . . H(nq-1). *> *> If VECT = 'P', A is assumed to have been a K-by-NQ matrix: *> if k < nq, P = G(1) G(2) . . . G(k); *> if k >= nq, P = G(1) G(2) . . . G(nq-1). *> \endverbatim * * Arguments: * ========== * *> \param[in] VECT *> \verbatim *> VECT is CHARACTER*1 *> = 'Q': apply Q or Q**T; *> = 'P': apply P or P**T. *> \endverbatim *> *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply Q, Q**T, P or P**T from the Left; *> = 'R': apply Q, Q**T, P or P**T from the Right. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': No transpose, apply Q or P; *> = 'T': Transpose, apply Q**T or P**T. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. N >= 0. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> If VECT = 'Q', the number of columns in the original *> matrix reduced by DGEBRD. *> If VECT = 'P', the number of rows in the original *> matrix reduced by DGEBRD. *> K >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension *> (LDA,min(nq,K)) if VECT = 'Q' *> (LDA,nq) if VECT = 'P' *> The vectors which define the elementary reflectors H(i) and *> G(i), whose products determine the matrices Q and P, as *> returned by DGEBRD. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. *> If VECT = 'Q', LDA >= max(1,nq); *> if VECT = 'P', LDA >= max(1,min(nq,K)). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (min(nq,K)) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i) or G(i) which determines Q or P, as returned *> by DGEBRD in the array argument TAUQ or TAUP. *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (LDC,N) *> On entry, the M-by-N matrix C. *> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q *> or P*C or P**T*C or C*P or C*P**T. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDC >= max(1,M). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. *> If SIDE = 'L', LWORK >= max(1,N); *> if SIDE = 'R', LWORK >= max(1,M). *> For optimum performance LWORK >= N*NB if SIDE = 'L', and *> LWORK >= M*NB if SIDE = 'R', where NB is the optimal *> blocksize. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error *> message related to LWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, $ LDC, WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS, VECT INTEGER INFO, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN CHARACTER TRANST INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DORMLQ, DORMQR, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 APPLYQ = LSAME( VECT, 'Q' ) LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q or P and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( .NOT.APPLYQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN INFO = -1 ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -2 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( K.LT.0 ) THEN INFO = -6 ELSE IF( ( APPLYQ .AND. LDA.LT.MAX( 1, NQ ) ) .OR. $ ( .NOT.APPLYQ .AND. LDA.LT.MAX( 1, MIN( NQ, K ) ) ) ) $ THEN INFO = -8 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -11 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -13 END IF * IF( INFO.EQ.0 ) THEN IF( APPLYQ ) THEN IF( LEFT ) THEN NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M-1, N, M-1, $ -1 ) ELSE NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N-1, N-1, $ -1 ) END IF ELSE IF( LEFT ) THEN NB = ILAENV( 1, 'DORMLQ', SIDE // TRANS, M-1, N, M-1, $ -1 ) ELSE NB = ILAENV( 1, 'DORMLQ', SIDE // TRANS, M, N-1, N-1, $ -1 ) END IF END IF LWKOPT = MAX( 1, NW )*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORMBR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * WORK( 1 ) = 1 IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * IF( APPLYQ ) THEN * * Apply Q * IF( NQ.GE.K ) THEN * * Q was determined by a call to DGEBRD with nq >= k * CALL DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, IINFO ) ELSE IF( NQ.GT.1 ) THEN * * Q was determined by a call to DGEBRD with nq < k * IF( LEFT ) THEN MI = M - 1 NI = N I1 = 2 I2 = 1 ELSE MI = M NI = N - 1 I1 = 1 I2 = 2 END IF CALL DORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, $ C( I1, I2 ), LDC, WORK, LWORK, IINFO ) END IF ELSE * * Apply P * IF( NOTRAN ) THEN TRANST = 'T' ELSE TRANST = 'N' END IF IF( NQ.GT.K ) THEN * * P was determined by a call to DGEBRD with nq > k * CALL DORMLQ( SIDE, TRANST, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, IINFO ) ELSE IF( NQ.GT.1 ) THEN * * P was determined by a call to DGEBRD with nq <= k * IF( LEFT ) THEN MI = M - 1 NI = N I1 = 2 I2 = 1 ELSE MI = M NI = N - 1 I1 = 1 I2 = 2 END IF CALL DORMLQ( SIDE, TRANST, MI, NI, NQ-1, A( 1, 2 ), LDA, $ TAU, C( I1, I2 ), LDC, WORK, LWORK, IINFO ) END IF END IF WORK( 1 ) = LWKOPT RETURN * * End of DORMBR * END *> \brief \b DORMHR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORMHR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, * LDC, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DORMHR overwrites the general real M-by-N matrix C with *> *> SIDE = 'L' SIDE = 'R' *> TRANS = 'N': Q * C C * Q *> TRANS = 'T': Q**T * C C * Q**T *> *> where Q is a real orthogonal matrix of order nq, with nq = m if *> SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of *> IHI-ILO elementary reflectors, as returned by DGEHRD: *> *> Q = H(ilo) H(ilo+1) . . . H(ihi-1). *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply Q or Q**T from the Left; *> = 'R': apply Q or Q**T from the Right. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': No transpose, apply Q; *> = 'T': Transpose, apply Q**T. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. N >= 0. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> *> ILO and IHI must have the same values as in the previous call *> of DGEHRD. Q is equal to the unit matrix except in the *> submatrix Q(ilo+1:ihi,ilo+1:ihi). *> If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and *> ILO = 1 and IHI = 0, if M = 0; *> if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and *> ILO = 1 and IHI = 0, if N = 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension *> (LDA,M) if SIDE = 'L' *> (LDA,N) if SIDE = 'R' *> The vectors which define the elementary reflectors, as *> returned by DGEHRD. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. *> LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension *> (M-1) if SIDE = 'L' *> (N-1) if SIDE = 'R' *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DGEHRD. *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (LDC,N) *> On entry, the M-by-N matrix C. *> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDC >= max(1,M). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. *> If SIDE = 'L', LWORK >= max(1,N); *> if SIDE = 'R', LWORK >= max(1,M). *> For optimum performance LWORK >= N*NB if SIDE = 'L', and *> LWORK >= M*NB if SIDE = 'R', where NB is the optimal *> blocksize. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error *> message related to LWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, $ LDC, WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL LEFT, LQUERY INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DORMQR, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NH = IHI - ILO LEFT = LSAME( SIDE, 'L' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) ) $ THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, NQ ) ) THEN INFO = -5 ELSE IF( IHI.LT.MIN( ILO, NQ ) .OR. IHI.GT.NQ ) THEN INFO = -6 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -8 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -11 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -13 END IF * IF( INFO.EQ.0 ) THEN IF( LEFT ) THEN NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, NH, N, NH, -1 ) ELSE NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, NH, NH, -1 ) END IF LWKOPT = MAX( 1, NW )*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORMHR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. NH.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * IF( LEFT ) THEN MI = NH NI = N I1 = ILO + 1 I2 = 1 ELSE MI = M NI = NH I1 = 1 I2 = ILO + 1 END IF * CALL DORMQR( SIDE, TRANS, MI, NI, NH, A( ILO+1, ILO ), LDA, $ TAU( ILO ), C( I1, I2 ), LDC, WORK, LWORK, IINFO ) * WORK( 1 ) = LWKOPT RETURN * * End of DORMHR * END *> \brief \b DORML2 multiplies a general matrix by the orthogonal matrix from a LQ factorization determined by sgelqf (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORML2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, INFO ) * * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DORML2 overwrites the general real m by n matrix C with *> *> Q * C if SIDE = 'L' and TRANS = 'N', or *> *> Q**T* C if SIDE = 'L' and TRANS = 'T', or *> *> C * Q if SIDE = 'R' and TRANS = 'N', or *> *> C * Q**T if SIDE = 'R' and TRANS = 'T', *> *> where Q is a real orthogonal matrix defined as the product of k *> elementary reflectors *> *> Q = H(k) . . . H(2) H(1) *> *> as returned by DGELQF. Q is of order m if SIDE = 'L' and of order n *> if SIDE = 'R'. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply Q or Q**T from the Left *> = 'R': apply Q or Q**T from the Right *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': apply Q (No transpose) *> = 'T': apply Q**T (Transpose) *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. N >= 0. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The number of elementary reflectors whose product defines *> the matrix Q. *> If SIDE = 'L', M >= K >= 0; *> if SIDE = 'R', N >= K >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension *> (LDA,M) if SIDE = 'L', *> (LDA,N) if SIDE = 'R' *> The i-th row must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> DGELQF in the first k rows of its array argument A. *> A is modified by the routine but restored on exit. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,K). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DGELQF. *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (LDC,N) *> On entry, the m by n matrix C. *> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDC >= max(1,M). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension *> (N) if SIDE = 'L', *> (M) if SIDE = 'R' *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDA, LDC, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ DOUBLE PRECISION AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLARF, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) * * NQ is the order of Q * IF( LEFT ) THEN NQ = M ELSE NQ = N END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, K ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORML2', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) $ RETURN * IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) $ THEN I1 = 1 I2 = K I3 = 1 ELSE I1 = K I2 = 1 I3 = -1 END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * DO 10 I = I1, I2, I3 IF( LEFT ) THEN * * H(i) is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H(i) is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H(i) * AII = A( I, I ) A( I, I ) = ONE CALL DLARF( SIDE, MI, NI, A( I, I ), LDA, TAU( I ), $ C( IC, JC ), LDC, WORK ) A( I, I ) = AII 10 CONTINUE RETURN * * End of DORML2 * END *> \brief \b DORMLQ * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORMLQ + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DORMLQ overwrites the general real M-by-N matrix C with *> *> SIDE = 'L' SIDE = 'R' *> TRANS = 'N': Q * C C * Q *> TRANS = 'T': Q**T * C C * Q**T *> *> where Q is a real orthogonal matrix defined as the product of k *> elementary reflectors *> *> Q = H(k) . . . H(2) H(1) *> *> as returned by DGELQF. Q is of order M if SIDE = 'L' and of order N *> if SIDE = 'R'. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply Q or Q**T from the Left; *> = 'R': apply Q or Q**T from the Right. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': No transpose, apply Q; *> = 'T': Transpose, apply Q**T. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. N >= 0. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The number of elementary reflectors whose product defines *> the matrix Q. *> If SIDE = 'L', M >= K >= 0; *> if SIDE = 'R', N >= K >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension *> (LDA,M) if SIDE = 'L', *> (LDA,N) if SIDE = 'R' *> The i-th row must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> DGELQF in the first k rows of its array argument A. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,K). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DGELQF. *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (LDC,N) *> On entry, the M-by-N matrix C. *> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDC >= max(1,M). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. *> If SIDE = 'L', LWORK >= max(1,N); *> if SIDE = 'R', LWORK >= max(1,M). *> For good performance, LWORK should generally be larger. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error *> message related to LWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT, TSIZE PARAMETER ( NBMAX = 64, LDT = NBMAX+1, $ TSIZE = LDT*NBMAX ) * .. * .. Local Scalars .. LOGICAL LEFT, LQUERY, NOTRAN CHARACTER TRANST INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK, $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DLARFB, DLARFT, DORML2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, K ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -12 END IF * IF( INFO.EQ.0 ) THEN * * Compute the workspace requirements * NB = MIN( NBMAX, ILAENV( 1, 'DORMLQ', SIDE // TRANS, M, N, K, $ -1 ) ) LWKOPT = MAX( 1, NW )*NB + TSIZE WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORMLQ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 LDWORK = NW IF( NB.GT.1 .AND. NB.LT.K ) THEN IF( LWORK.LT.NW*NB+TSIZE ) THEN NB = (LWORK-TSIZE) / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'DORMLQ', SIDE // TRANS, M, N, K, $ -1 ) ) END IF END IF * IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN * * Use unblocked code * CALL DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, $ IINFO ) ELSE * * Use blocked code * IWT = 1 + NW*NB IF( ( LEFT .AND. NOTRAN ) .OR. $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN I1 = 1 I2 = K I3 = NB ELSE I1 = ( ( K-1 ) / NB )*NB + 1 I2 = 1 I3 = -NB END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * IF( NOTRAN ) THEN TRANST = 'T' ELSE TRANST = 'N' END IF * DO 10 I = I1, I2, I3 IB = MIN( NB, K-I+1 ) * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL DLARFT( 'Forward', 'Rowwise', NQ-I+1, IB, A( I, I ), $ LDA, TAU( I ), WORK( IWT ), LDT ) IF( LEFT ) THEN * * H or H**T is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H or H**T is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H or H**T * CALL DLARFB( SIDE, TRANST, 'Forward', 'Rowwise', MI, NI, IB, $ A( I, I ), LDA, WORK( IWT ), LDT, $ C( IC, JC ), LDC, WORK, LDWORK ) 10 CONTINUE END IF WORK( 1 ) = LWKOPT RETURN * * End of DORMLQ * END *> \brief \b DORMQL * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORMQL + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DORMQL overwrites the general real M-by-N matrix C with *> *> SIDE = 'L' SIDE = 'R' *> TRANS = 'N': Q * C C * Q *> TRANS = 'T': Q**T * C C * Q**T *> *> where Q is a real orthogonal matrix defined as the product of k *> elementary reflectors *> *> Q = H(k) . . . H(2) H(1) *> *> as returned by DGEQLF. Q is of order M if SIDE = 'L' and of order N *> if SIDE = 'R'. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply Q or Q**T from the Left; *> = 'R': apply Q or Q**T from the Right. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': No transpose, apply Q; *> = 'T': Transpose, apply Q**T. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. N >= 0. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The number of elementary reflectors whose product defines *> the matrix Q. *> If SIDE = 'L', M >= K >= 0; *> if SIDE = 'R', N >= K >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,K) *> The i-th column must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> DGEQLF in the last k columns of its array argument A. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. *> If SIDE = 'L', LDA >= max(1,M); *> if SIDE = 'R', LDA >= max(1,N). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DGEQLF. *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (LDC,N) *> On entry, the M-by-N matrix C. *> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDC >= max(1,M). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. *> If SIDE = 'L', LWORK >= max(1,N); *> if SIDE = 'R', LWORK >= max(1,M). *> For good performance, LWORK should generally be larger. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error *> message related to LWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT, TSIZE PARAMETER ( NBMAX = 64, LDT = NBMAX+1, $ TSIZE = LDT*NBMAX ) * .. * .. Local Scalars .. LOGICAL LEFT, LQUERY, NOTRAN INTEGER I, I1, I2, I3, IB, IINFO, IWT, LDWORK, LWKOPT, $ MI, NB, NBMIN, NI, NQ, NW * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DLARFB, DLARFT, DORM2L, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = MAX( 1, N ) ELSE NQ = N NW = MAX( 1, M ) END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN INFO = -12 END IF * IF( INFO.EQ.0 ) THEN * * Compute the workspace requirements * IF( M.EQ.0 .OR. N.EQ.0 ) THEN LWKOPT = 1 ELSE NB = MIN( NBMAX, ILAENV( 1, 'DORMQL', SIDE // TRANS, M, N, $ K, -1 ) ) LWKOPT = NW*NB + TSIZE END IF WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORMQL', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) THEN RETURN END IF * NBMIN = 2 LDWORK = NW IF( NB.GT.1 .AND. NB.LT.K ) THEN IF( LWORK.LT.NW*NB+TSIZE ) THEN NB = (LWORK-TSIZE) / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'DORMQL', SIDE // TRANS, M, N, K, $ -1 ) ) END IF END IF * IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN * * Use unblocked code * CALL DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, $ IINFO ) ELSE * * Use blocked code * IWT = 1 + NW*NB IF( ( LEFT .AND. NOTRAN ) .OR. $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN I1 = 1 I2 = K I3 = NB ELSE I1 = ( ( K-1 ) / NB )*NB + 1 I2 = 1 I3 = -NB END IF * IF( LEFT ) THEN NI = N ELSE MI = M END IF * DO 10 I = I1, I2, I3 IB = MIN( NB, K-I+1 ) * * Form the triangular factor of the block reflector * H = H(i+ib-1) . . . H(i+1) H(i) * CALL DLARFT( 'Backward', 'Columnwise', NQ-K+I+IB-1, IB, $ A( 1, I ), LDA, TAU( I ), WORK( IWT ), LDT ) IF( LEFT ) THEN * * H or H**T is applied to C(1:m-k+i+ib-1,1:n) * MI = M - K + I + IB - 1 ELSE * * H or H**T is applied to C(1:m,1:n-k+i+ib-1) * NI = N - K + I + IB - 1 END IF * * Apply H or H**T * CALL DLARFB( SIDE, TRANS, 'Backward', 'Columnwise', MI, NI, $ IB, A( 1, I ), LDA, WORK( IWT ), LDT, C, LDC, $ WORK, LDWORK ) 10 CONTINUE END IF WORK( 1 ) = LWKOPT RETURN * * End of DORMQL * END *> \brief \b DORMQR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORMQR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DORMQR overwrites the general real M-by-N matrix C with *> *> SIDE = 'L' SIDE = 'R' *> TRANS = 'N': Q * C C * Q *> TRANS = 'T': Q**T * C C * Q**T *> *> where Q is a real orthogonal matrix defined as the product of k *> elementary reflectors *> *> Q = H(1) H(2) . . . H(k) *> *> as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N *> if SIDE = 'R'. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply Q or Q**T from the Left; *> = 'R': apply Q or Q**T from the Right. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': No transpose, apply Q; *> = 'T': Transpose, apply Q**T. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. N >= 0. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The number of elementary reflectors whose product defines *> the matrix Q. *> If SIDE = 'L', M >= K >= 0; *> if SIDE = 'R', N >= K >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,K) *> The i-th column must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> DGEQRF in the first k columns of its array argument A. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. *> If SIDE = 'L', LDA >= max(1,M); *> if SIDE = 'R', LDA >= max(1,N). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DGEQRF. *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (LDC,N) *> On entry, the M-by-N matrix C. *> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDC >= max(1,M). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. *> If SIDE = 'L', LWORK >= max(1,N); *> if SIDE = 'R', LWORK >= max(1,M). *> For good performance, LWORK should generally be larger. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error *> message related to LWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT, TSIZE PARAMETER ( NBMAX = 64, LDT = NBMAX+1, $ TSIZE = LDT*NBMAX ) * .. * .. Local Scalars .. LOGICAL LEFT, LQUERY, NOTRAN INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK, $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DLARFB, DLARFT, DORM2R, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -12 END IF * IF( INFO.EQ.0 ) THEN * * Compute the workspace requirements * NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K, $ -1 ) ) LWKOPT = MAX( 1, NW )*NB + TSIZE WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORMQR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 LDWORK = NW IF( NB.GT.1 .AND. NB.LT.K ) THEN IF( LWORK.LT.NW*NB+TSIZE ) THEN NB = (LWORK-TSIZE) / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', SIDE // TRANS, M, N, K, $ -1 ) ) END IF END IF * IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN * * Use unblocked code * CALL DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, $ IINFO ) ELSE * * Use blocked code * IWT = 1 + NW*NB IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN I1 = 1 I2 = K I3 = NB ELSE I1 = ( ( K-1 ) / NB )*NB + 1 I2 = 1 I3 = -NB END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * DO 10 I = I1, I2, I3 IB = MIN( NB, K-I+1 ) * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL DLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), $ LDA, TAU( I ), WORK( IWT ), LDT ) IF( LEFT ) THEN * * H or H**T is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H or H**T is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H or H**T * CALL DLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, $ IB, A( I, I ), LDA, WORK( IWT ), LDT, $ C( IC, JC ), LDC, WORK, LDWORK ) 10 CONTINUE END IF WORK( 1 ) = LWKOPT RETURN * * End of DORMQR * END *> \brief \b DORMR2 multiplies a general matrix by the orthogonal matrix from a RQ factorization determined by sgerqf (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORMR2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, INFO ) * * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DORMR2 overwrites the general real m by n matrix C with *> *> Q * C if SIDE = 'L' and TRANS = 'N', or *> *> Q**T* C if SIDE = 'L' and TRANS = 'T', or *> *> C * Q if SIDE = 'R' and TRANS = 'N', or *> *> C * Q**T if SIDE = 'R' and TRANS = 'T', *> *> where Q is a real orthogonal matrix defined as the product of k *> elementary reflectors *> *> Q = H(1) H(2) . . . H(k) *> *> as returned by DGERQF. Q is of order m if SIDE = 'L' and of order n *> if SIDE = 'R'. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply Q or Q**T from the Left *> = 'R': apply Q or Q**T from the Right *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': apply Q (No transpose) *> = 'T': apply Q' (Transpose) *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. N >= 0. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The number of elementary reflectors whose product defines *> the matrix Q. *> If SIDE = 'L', M >= K >= 0; *> if SIDE = 'R', N >= K >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension *> (LDA,M) if SIDE = 'L', *> (LDA,N) if SIDE = 'R' *> The i-th row must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> DGERQF in the last k rows of its array argument A. *> A is modified by the routine but restored on exit. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,K). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DGERQF. *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (LDC,N) *> On entry, the m by n matrix C. *> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDC >= max(1,M). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension *> (N) if SIDE = 'L', *> (M) if SIDE = 'R' *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDA, LDC, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, MI, NI, NQ DOUBLE PRECISION AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLARF, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) * * NQ is the order of Q * IF( LEFT ) THEN NQ = M ELSE NQ = N END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, K ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORMR2', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) $ RETURN * IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) $ THEN I1 = 1 I2 = K I3 = 1 ELSE I1 = K I2 = 1 I3 = -1 END IF * IF( LEFT ) THEN NI = N ELSE MI = M END IF * DO 10 I = I1, I2, I3 IF( LEFT ) THEN * * H(i) is applied to C(1:m-k+i,1:n) * MI = M - K + I ELSE * * H(i) is applied to C(1:m,1:n-k+i) * NI = N - K + I END IF * * Apply H(i) * AII = A( I, NQ-K+I ) A( I, NQ-K+I ) = ONE CALL DLARF( SIDE, MI, NI, A( I, 1 ), LDA, TAU( I ), C, LDC, $ WORK ) A( I, NQ-K+I ) = AII 10 CONTINUE RETURN * * End of DORMR2 * END *> \brief \b DORMR3 multiplies a general matrix by the orthogonal matrix from a RZ factorization determined by stzrzf (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORMR3 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, * WORK, INFO ) * * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, L, LDA, LDC, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DORMR3 overwrites the general real m by n matrix C with *> *> Q * C if SIDE = 'L' and TRANS = 'N', or *> *> Q**T* C if SIDE = 'L' and TRANS = 'C', or *> *> C * Q if SIDE = 'R' and TRANS = 'N', or *> *> C * Q**T if SIDE = 'R' and TRANS = 'C', *> *> where Q is a real orthogonal matrix defined as the product of k *> elementary reflectors *> *> Q = H(1) H(2) . . . H(k) *> *> as returned by DTZRZF. Q is of order m if SIDE = 'L' and of order n *> if SIDE = 'R'. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply Q or Q**T from the Left *> = 'R': apply Q or Q**T from the Right *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': apply Q (No transpose) *> = 'T': apply Q**T (Transpose) *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. N >= 0. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The number of elementary reflectors whose product defines *> the matrix Q. *> If SIDE = 'L', M >= K >= 0; *> if SIDE = 'R', N >= K >= 0. *> \endverbatim *> *> \param[in] L *> \verbatim *> L is INTEGER *> The number of columns of the matrix A containing *> the meaningful part of the Householder reflectors. *> If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension *> (LDA,M) if SIDE = 'L', *> (LDA,N) if SIDE = 'R' *> The i-th row must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> DTZRZF in the last k rows of its array argument A. *> A is modified by the routine but restored on exit. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,K). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DTZRZF. *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (LDC,N) *> On entry, the m-by-n matrix C. *> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDC >= max(1,M). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension *> (N) if SIDE = 'L', *> (M) if SIDE = 'R' *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Contributors: * ================== *> *> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA * *> \par Further Details: * ===================== *> *> \verbatim *> \endverbatim *> * ===================================================================== SUBROUTINE DORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, $ WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, L, LDA, LDC, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JA, JC, MI, NI, NQ * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLARZ, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) * * NQ is the order of Q * IF( LEFT ) THEN NQ = M ELSE NQ = N END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN INFO = -5 ELSE IF( L.LT.0 .OR. ( LEFT .AND. ( L.GT.M ) ) .OR. $ ( .NOT.LEFT .AND. ( L.GT.N ) ) ) THEN INFO = -6 ELSE IF( LDA.LT.MAX( 1, K ) ) THEN INFO = -8 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -11 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORMR3', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) $ RETURN * IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN I1 = 1 I2 = K I3 = 1 ELSE I1 = K I2 = 1 I3 = -1 END IF * IF( LEFT ) THEN NI = N JA = M - L + 1 JC = 1 ELSE MI = M JA = N - L + 1 IC = 1 END IF * DO 10 I = I1, I2, I3 IF( LEFT ) THEN * * H(i) or H(i)**T is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H(i) or H(i)**T is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H(i) or H(i)**T * CALL DLARZ( SIDE, MI, NI, L, A( I, JA ), LDA, TAU( I ), $ C( IC, JC ), LDC, WORK ) * 10 CONTINUE * RETURN * * End of DORMR3 * END *> \brief \b DORMRQ * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORMRQ + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DORMRQ overwrites the general real M-by-N matrix C with *> *> SIDE = 'L' SIDE = 'R' *> TRANS = 'N': Q * C C * Q *> TRANS = 'T': Q**T * C C * Q**T *> *> where Q is a real orthogonal matrix defined as the product of k *> elementary reflectors *> *> Q = H(1) H(2) . . . H(k) *> *> as returned by DGERQF. Q is of order M if SIDE = 'L' and of order N *> if SIDE = 'R'. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply Q or Q**T from the Left; *> = 'R': apply Q or Q**T from the Right. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': No transpose, apply Q; *> = 'T': Transpose, apply Q**T. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. N >= 0. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The number of elementary reflectors whose product defines *> the matrix Q. *> If SIDE = 'L', M >= K >= 0; *> if SIDE = 'R', N >= K >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension *> (LDA,M) if SIDE = 'L', *> (LDA,N) if SIDE = 'R' *> The i-th row must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> DGERQF in the last k rows of its array argument A. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,K). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DGERQF. *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (LDC,N) *> On entry, the M-by-N matrix C. *> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDC >= max(1,M). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. *> If SIDE = 'L', LWORK >= max(1,N); *> if SIDE = 'R', LWORK >= max(1,M). *> For good performance, LWORK should generally be larger. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error *> message related to LWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT, TSIZE PARAMETER ( NBMAX = 64, LDT = NBMAX+1, $ TSIZE = LDT*NBMAX ) * .. * .. Local Scalars .. LOGICAL LEFT, LQUERY, NOTRAN CHARACTER TRANST INTEGER I, I1, I2, I3, IB, IINFO, IWT, LDWORK, LWKOPT, $ MI, NB, NBMIN, NI, NQ, NW * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DLARFB, DLARFT, DORMR2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = MAX( 1, N ) ELSE NQ = N NW = MAX( 1, M ) END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, K ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN INFO = -12 END IF * IF( INFO.EQ.0 ) THEN * * Compute the workspace requirements * IF( M.EQ.0 .OR. N.EQ.0 ) THEN LWKOPT = 1 ELSE NB = MIN( NBMAX, ILAENV( 1, 'DORMRQ', SIDE // TRANS, M, N, $ K, -1 ) ) LWKOPT = NW*NB + TSIZE END IF WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORMRQ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) THEN RETURN END IF * NBMIN = 2 LDWORK = NW IF( NB.GT.1 .AND. NB.LT.K ) THEN IF( LWORK.LT.NW*NB+TSIZE ) THEN NB = (LWORK-TSIZE) / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'DORMRQ', SIDE // TRANS, M, N, K, $ -1 ) ) END IF END IF * IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN * * Use unblocked code * CALL DORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, $ IINFO ) ELSE * * Use blocked code * IWT = 1 + NW*NB IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN I1 = 1 I2 = K I3 = NB ELSE I1 = ( ( K-1 ) / NB )*NB + 1 I2 = 1 I3 = -NB END IF * IF( LEFT ) THEN NI = N ELSE MI = M END IF * IF( NOTRAN ) THEN TRANST = 'T' ELSE TRANST = 'N' END IF * DO 10 I = I1, I2, I3 IB = MIN( NB, K-I+1 ) * * Form the triangular factor of the block reflector * H = H(i+ib-1) . . . H(i+1) H(i) * CALL DLARFT( 'Backward', 'Rowwise', NQ-K+I+IB-1, IB, $ A( I, 1 ), LDA, TAU( I ), WORK( IWT ), LDT ) IF( LEFT ) THEN * * H or H**T is applied to C(1:m-k+i+ib-1,1:n) * MI = M - K + I + IB - 1 ELSE * * H or H**T is applied to C(1:m,1:n-k+i+ib-1) * NI = N - K + I + IB - 1 END IF * * Apply H or H**T * CALL DLARFB( SIDE, TRANST, 'Backward', 'Rowwise', MI, NI, $ IB, A( I, 1 ), LDA, WORK( IWT ), LDT, C, LDC, $ WORK, LDWORK ) 10 CONTINUE END IF WORK( 1 ) = LWKOPT RETURN * * End of DORMRQ * END *> \brief \b DORMRZ * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORMRZ + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, L, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DORMRZ overwrites the general real M-by-N matrix C with *> *> SIDE = 'L' SIDE = 'R' *> TRANS = 'N': Q * C C * Q *> TRANS = 'T': Q**T * C C * Q**T *> *> where Q is a real orthogonal matrix defined as the product of k *> elementary reflectors *> *> Q = H(1) H(2) . . . H(k) *> *> as returned by DTZRZF. Q is of order M if SIDE = 'L' and of order N *> if SIDE = 'R'. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply Q or Q**T from the Left; *> = 'R': apply Q or Q**T from the Right. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': No transpose, apply Q; *> = 'T': Transpose, apply Q**T. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. N >= 0. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The number of elementary reflectors whose product defines *> the matrix Q. *> If SIDE = 'L', M >= K >= 0; *> if SIDE = 'R', N >= K >= 0. *> \endverbatim *> *> \param[in] L *> \verbatim *> L is INTEGER *> The number of columns of the matrix A containing *> the meaningful part of the Householder reflectors. *> If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension *> (LDA,M) if SIDE = 'L', *> (LDA,N) if SIDE = 'R' *> The i-th row must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> DTZRZF in the last k rows of its array argument A. *> A is modified by the routine but restored on exit. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,K). *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (K) *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DTZRZF. *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (LDC,N) *> On entry, the M-by-N matrix C. *> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDC >= max(1,M). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. *> If SIDE = 'L', LWORK >= max(1,N); *> if SIDE = 'R', LWORK >= max(1,M). *> For good performance, LWORK should generally be larger. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error *> message related to LWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Contributors: * ================== *> *> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA * *> \par Further Details: * ===================== *> *> \verbatim *> \endverbatim *> * ===================================================================== SUBROUTINE DORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, L, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT, TSIZE PARAMETER ( NBMAX = 64, LDT = NBMAX+1, $ TSIZE = LDT*NBMAX ) * .. * .. Local Scalars .. LOGICAL LEFT, LQUERY, NOTRAN CHARACTER TRANST INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JA, JC, $ LDWORK, LWKOPT, MI, NB, NBMIN, NI, NQ, NW * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DLARZB, DLARZT, DORMR3, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = MAX( 1, N ) ELSE NQ = N NW = MAX( 1, M ) END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN INFO = -5 ELSE IF( L.LT.0 .OR. ( LEFT .AND. ( L.GT.M ) ) .OR. $ ( .NOT.LEFT .AND. ( L.GT.N ) ) ) THEN INFO = -6 ELSE IF( LDA.LT.MAX( 1, K ) ) THEN INFO = -8 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -11 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -13 END IF * IF( INFO.EQ.0 ) THEN * * Compute the workspace requirements * IF( M.EQ.0 .OR. N.EQ.0 ) THEN LWKOPT = 1 ELSE NB = MIN( NBMAX, ILAENV( 1, 'DORMRQ', SIDE // TRANS, M, N, $ K, -1 ) ) LWKOPT = NW*NB + TSIZE END IF WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORMRZ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 LDWORK = NW IF( NB.GT.1 .AND. NB.LT.K ) THEN IF( LWORK.LT.NW*NB+TSIZE ) THEN NB = (LWORK-TSIZE) / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'DORMRQ', SIDE // TRANS, M, N, K, $ -1 ) ) END IF END IF * IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN * * Use unblocked code * CALL DORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, $ WORK, IINFO ) ELSE * * Use blocked code * IWT = 1 + NW*NB IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN I1 = 1 I2 = K I3 = NB ELSE I1 = ( ( K-1 ) / NB )*NB + 1 I2 = 1 I3 = -NB END IF * IF( LEFT ) THEN NI = N JC = 1 JA = M - L + 1 ELSE MI = M IC = 1 JA = N - L + 1 END IF * IF( NOTRAN ) THEN TRANST = 'T' ELSE TRANST = 'N' END IF * DO 10 I = I1, I2, I3 IB = MIN( NB, K-I+1 ) * * Form the triangular factor of the block reflector * H = H(i+ib-1) . . . H(i+1) H(i) * CALL DLARZT( 'Backward', 'Rowwise', L, IB, A( I, JA ), LDA, $ TAU( I ), WORK( IWT ), LDT ) * IF( LEFT ) THEN * * H or H**T is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H or H**T is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H or H**T * CALL DLARZB( SIDE, TRANST, 'Backward', 'Rowwise', MI, NI, $ IB, L, A( I, JA ), LDA, WORK( IWT ), LDT, $ C( IC, JC ), LDC, WORK, LDWORK ) 10 CONTINUE * END IF * WORK( 1 ) = LWKOPT * RETURN * * End of DORMRZ * END *> \brief \b DORMTR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DORMTR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, * WORK, LWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER SIDE, TRANS, UPLO * INTEGER INFO, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DORMTR overwrites the general real M-by-N matrix C with *> *> SIDE = 'L' SIDE = 'R' *> TRANS = 'N': Q * C C * Q *> TRANS = 'T': Q**T * C C * Q**T *> *> where Q is a real orthogonal matrix of order nq, with nq = m if *> SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of *> nq-1 elementary reflectors, as returned by DSYTRD: *> *> if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); *> *> if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply Q or Q**T from the Left; *> = 'R': apply Q or Q**T from the Right. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A contains elementary reflectors *> from DSYTRD; *> = 'L': Lower triangle of A contains elementary reflectors *> from DSYTRD. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': No transpose, apply Q; *> = 'T': Transpose, apply Q**T. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. N >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension *> (LDA,M) if SIDE = 'L' *> (LDA,N) if SIDE = 'R' *> The vectors which define the elementary reflectors, as *> returned by DSYTRD. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. *> LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension *> (M-1) if SIDE = 'L' *> (N-1) if SIDE = 'R' *> TAU(i) must contain the scalar factor of the elementary *> reflector H(i), as returned by DSYTRD. *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (LDC,N) *> On entry, the M-by-N matrix C. *> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDC >= max(1,M). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. *> If SIDE = 'L', LWORK >= max(1,N); *> if SIDE = 'R', LWORK >= max(1,M). *> For optimum performance LWORK >= N*NB if SIDE = 'L', and *> LWORK >= M*NB if SIDE = 'R', where NB is the optimal *> blocksize. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error *> message related to LWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS, UPLO INTEGER INFO, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL LEFT, LQUERY, UPPER INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DORMQL, DORMQR, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -2 ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) ) $ THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -12 END IF * IF( INFO.EQ.0 ) THEN IF( UPPER ) THEN IF( LEFT ) THEN NB = ILAENV( 1, 'DORMQL', SIDE // TRANS, M-1, N, M-1, $ -1 ) ELSE NB = ILAENV( 1, 'DORMQL', SIDE // TRANS, M, N-1, N-1, $ -1 ) END IF ELSE IF( LEFT ) THEN NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M-1, N, M-1, $ -1 ) ELSE NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N-1, N-1, $ -1 ) END IF END IF LWKOPT = MAX( 1, NW )*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORMTR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. NQ.EQ.1 ) THEN WORK( 1 ) = 1 RETURN END IF * IF( LEFT ) THEN MI = M - 1 NI = N ELSE MI = M NI = N - 1 END IF * IF( UPPER ) THEN * * Q was determined by a call to DSYTRD with UPLO = 'U' * CALL DORMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU, C, $ LDC, WORK, LWORK, IINFO ) ELSE * * Q was determined by a call to DSYTRD with UPLO = 'L' * IF( LEFT ) THEN I1 = 2 I2 = 1 ELSE I1 = 1 I2 = 2 END IF CALL DORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, $ C( I1, I2 ), LDC, WORK, LWORK, IINFO ) END IF WORK( 1 ) = LWKOPT RETURN * * End of DORMTR * END *> \brief \b DPBCON * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPBCON + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, * IWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, N * DOUBLE PRECISION ANORM, RCOND * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION AB( LDAB, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPBCON estimates the reciprocal of the condition number (in the *> 1-norm) of a real symmetric positive definite band matrix using the *> Cholesky factorization A = U**T*U or A = L*L**T computed by DPBTRF. *> *> An estimate is obtained for norm(inv(A)), and the reciprocal of the *> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangular factor stored in AB; *> = 'L': Lower triangular factor stored in AB. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] KD *> \verbatim *> KD is INTEGER *> The number of superdiagonals of the matrix A if UPLO = 'U', *> or the number of subdiagonals if UPLO = 'L'. KD >= 0. *> \endverbatim *> *> \param[in] AB *> \verbatim *> AB is DOUBLE PRECISION array, dimension (LDAB,N) *> The triangular factor U or L from the Cholesky factorization *> A = U**T*U or A = L*L**T of the band matrix A, stored in the *> first KD+1 rows of the array. The j-th column of U or L is *> stored in the j-th column of the array AB as follows: *> if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j; *> if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd). *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array AB. LDAB >= KD+1. *> \endverbatim *> *> \param[in] ANORM *> \verbatim *> ANORM is DOUBLE PRECISION *> The 1-norm (or infinity-norm) of the symmetric band matrix A. *> \endverbatim *> *> \param[out] RCOND *> \verbatim *> RCOND is 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. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, $ IWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, KD, LDAB, N DOUBLE PRECISION ANORM, RCOND * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION AB( LDAB, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER CHARACTER NORMIN INTEGER IX, KASE DOUBLE PRECISION AINVNM, SCALE, SCALEL, SCALEU, SMLNUM * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DLAMCH EXTERNAL LSAME, IDAMAX, DLAMCH * .. * .. External Subroutines .. EXTERNAL DLACN2, DLATBS, DRSCL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( KD.LT.0 ) THEN INFO = -3 ELSE IF( LDAB.LT.KD+1 ) THEN INFO = -5 ELSE IF( ANORM.LT.ZERO ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPBCON', -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 1-norm of the inverse. * KASE = 0 NORMIN = 'N' 10 CONTINUE CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( UPPER ) THEN * * Multiply by inv(U**T). * CALL DLATBS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, $ KD, AB, LDAB, WORK, SCALEL, WORK( 2*N+1 ), $ INFO ) NORMIN = 'Y' * * Multiply by inv(U). * CALL DLATBS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, $ KD, AB, LDAB, WORK, SCALEU, WORK( 2*N+1 ), $ INFO ) ELSE * * Multiply by inv(L). * CALL DLATBS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N, $ KD, AB, LDAB, WORK, SCALEL, WORK( 2*N+1 ), $ INFO ) NORMIN = 'Y' * * Multiply by inv(L**T). * CALL DLATBS( 'Lower', 'Transpose', 'Non-unit', NORMIN, N, $ KD, AB, LDAB, WORK, SCALEU, WORK( 2*N+1 ), $ INFO ) END IF * * Multiply by 1/SCALE if doing so will not cause overflow. * SCALE = SCALEL*SCALEU 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 DPBCON * END *> \brief \b DPBEQU * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPBEQU + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, N * DOUBLE PRECISION AMAX, SCOND * .. * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ), S( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPBEQU computes row and column scalings intended to equilibrate a *> symmetric positive definite band matrix A and reduce its condition *> number (with respect to the two-norm). S contains the scale factors, *> S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with *> elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This *> choice of S puts the condition number of B within a factor N of the *> smallest possible condition number over all possible diagonal *> scalings. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangular of A is stored; *> = 'L': Lower triangular of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] KD *> \verbatim *> KD is INTEGER *> The number of superdiagonals of the matrix A if UPLO = 'U', *> or the number of subdiagonals if UPLO = 'L'. KD >= 0. *> \endverbatim *> *> \param[in] AB *> \verbatim *> AB is DOUBLE PRECISION array, dimension (LDAB,N) *> The upper or lower triangle of the symmetric band matrix A, *> stored in the first KD+1 rows of the array. The j-th column *> of A is stored in the j-th column of the array AB as follows: *> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; *> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array A. LDAB >= KD+1. *> \endverbatim *> *> \param[out] S *> \verbatim *> S is DOUBLE PRECISION array, dimension (N) *> If INFO = 0, S contains the scale factors for A. *> \endverbatim *> *> \param[out] SCOND *> \verbatim *> SCOND is DOUBLE PRECISION *> If INFO = 0, S contains the ratio of the smallest S(i) to *> the largest S(i). If SCOND >= 0.1 and AMAX is neither too *> large nor too small, it is not worth scaling by S. *> \endverbatim *> *> \param[out] AMAX *> \verbatim *> AMAX is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: if INFO = i, the i-th diagonal element is nonpositive. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, KD, LDAB, N DOUBLE PRECISION AMAX, SCOND * .. * .. Array Arguments .. DOUBLE PRECISION AB( LDAB, * ), S( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER I, J DOUBLE PRECISION SMIN * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( KD.LT.0 ) THEN INFO = -3 ELSE IF( LDAB.LT.KD+1 ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPBEQU', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN SCOND = ONE AMAX = ZERO RETURN END IF * IF( UPPER ) THEN J = KD + 1 ELSE J = 1 END IF * * Initialize SMIN and AMAX. * S( 1 ) = AB( J, 1 ) SMIN = S( 1 ) AMAX = S( 1 ) * * Find the minimum and maximum diagonal elements. * DO 10 I = 2, N S( I ) = AB( J, I ) SMIN = MIN( SMIN, S( I ) ) AMAX = MAX( AMAX, S( I ) ) 10 CONTINUE * IF( SMIN.LE.ZERO ) THEN * * Find the first non-positive diagonal element and return. * DO 20 I = 1, N IF( S( I ).LE.ZERO ) THEN INFO = I RETURN END IF 20 CONTINUE ELSE * * Set the scale factors to the reciprocals * of the diagonal elements. * DO 30 I = 1, N S( I ) = ONE / SQRT( S( I ) ) 30 CONTINUE * * Compute SCOND = min(S(I)) / max(S(I)) * SCOND = SQRT( SMIN ) / SQRT( AMAX ) END IF RETURN * * End of DPBEQU * END *> \brief \b DPBRFS * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPBRFS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, * LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), * $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPBRFS improves the computed solution to a system of linear *> equations when the coefficient matrix is symmetric positive definite *> and banded, and provides error bounds and backward error estimates *> for the solution. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] KD *> \verbatim *> KD is INTEGER *> The number of superdiagonals of the matrix A if UPLO = 'U', *> or the number of subdiagonals if UPLO = 'L'. KD >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrices B and X. NRHS >= 0. *> \endverbatim *> *> \param[in] AB *> \verbatim *> AB is DOUBLE PRECISION array, dimension (LDAB,N) *> The upper or lower triangle of the symmetric band matrix A, *> stored in the first KD+1 rows of the array. The j-th column *> of A is stored in the j-th column of the array AB as follows: *> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; *> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array AB. LDAB >= KD+1. *> \endverbatim *> *> \param[in] AFB *> \verbatim *> AFB is DOUBLE PRECISION array, dimension (LDAFB,N) *> The triangular factor U or L from the Cholesky factorization *> A = U**T*U or A = L*L**T of the band matrix A as computed by *> DPBTRF, in the same storage format as A (see AB). *> \endverbatim *> *> \param[in] LDAFB *> \verbatim *> LDAFB is INTEGER *> The leading dimension of the array AFB. LDAFB >= KD+1. *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> The right hand side matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,NRHS) *> On entry, the solution matrix X, as computed by DPBTRS. *> On exit, the improved solution matrix X. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the array X. LDX >= max(1,N). *> \endverbatim *> *> \param[out] FERR *> \verbatim *> FERR is 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. *> \endverbatim *> *> \param[out] BERR *> \verbatim *> BERR is 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). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * *> \par Internal Parameters: * ========================= *> *> \verbatim *> ITMAX is the maximum number of steps of iterative refinement. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, $ LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) * .. * * ===================================================================== * * .. 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 UPPER INTEGER COUNT, I, J, K, KASE, L, NZ DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) * .. * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DLACN2, DPBTRS, DSBMV, 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 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( KD.LT.0 ) THEN INFO = -3 ELSE IF( NRHS.LT.0 ) THEN INFO = -4 ELSE IF( LDAB.LT.KD+1 ) THEN INFO = -6 ELSE IF( LDAFB.LT.KD+1 ) THEN INFO = -8 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( 'DPBRFS', -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 * * NZ = maximum number of nonzero elements in each row of A, plus 1 * NZ = MIN( N+1, 2*KD+2 ) 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 - A * X * CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 ) CALL DSBMV( UPLO, N, KD, -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(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(A)*abs(X) + abs(B). * IF( UPPER ) THEN DO 50 K = 1, N S = ZERO XK = ABS( X( K, J ) ) L = KD + 1 - K DO 40 I = MAX( 1, K-KD ), K - 1 WORK( I ) = WORK( I ) + ABS( AB( L+I, K ) )*XK S = S + ABS( AB( L+I, K ) )*ABS( X( I, J ) ) 40 CONTINUE WORK( K ) = WORK( K ) + ABS( AB( KD+1, K ) )*XK + S 50 CONTINUE ELSE DO 70 K = 1, N S = ZERO XK = ABS( X( K, J ) ) WORK( K ) = WORK( K ) + ABS( AB( 1, K ) )*XK L = 1 - K DO 60 I = K + 1, MIN( N, K+KD ) WORK( I ) = WORK( I ) + ABS( AB( L+I, K ) )*XK S = S + ABS( AB( L+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 DPBTRS( UPLO, N, KD, 1, AFB, LDAFB, 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(A))* * ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) * * where * norm(Z) is the magnitude of the largest component of Z * inv(A) is the inverse of 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(A)*abs(X)+abs(B)) * is incremented by SAFE1 if the i-th component of * abs(A)*abs(X) + abs(B) is less than SAFE2. * * Use DLACN2 to estimate the infinity-norm of the matrix * inv(A) * diag(W), * where W = abs(R) + NZ*EPS*( abs(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(A**T). * CALL DPBTRS( UPLO, N, KD, 1, AFB, LDAFB, WORK( N+1 ), N, $ INFO ) DO 110 I = 1, N WORK( N+I ) = WORK( N+I )*WORK( I ) 110 CONTINUE ELSE IF( KASE.EQ.2 ) THEN * * Multiply by inv(A)*diag(W). * DO 120 I = 1, N WORK( N+I ) = WORK( N+I )*WORK( I ) 120 CONTINUE CALL DPBTRS( UPLO, N, KD, 1, AFB, LDAFB, 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 DPBRFS * END *> \brief \b DPBSTF * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPBSTF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPBSTF( UPLO, N, KD, AB, LDAB, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, N * .. * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPBSTF computes a split Cholesky factorization of a real *> symmetric positive definite band matrix A. *> *> This routine is designed to be used in conjunction with DSBGST. *> *> The factorization has the form A = S**T*S where S is a band matrix *> of the same bandwidth as A and the following structure: *> *> S = ( U ) *> ( M L ) *> *> where U is upper triangular of order m = (n+kd)/2, and L is lower *> triangular of order n-m. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] KD *> \verbatim *> KD is INTEGER *> The number of superdiagonals of the matrix A if UPLO = 'U', *> or the number of subdiagonals if UPLO = 'L'. KD >= 0. *> \endverbatim *> *> \param[in,out] AB *> \verbatim *> AB is DOUBLE PRECISION array, dimension (LDAB,N) *> On entry, the upper or lower triangle of the symmetric band *> matrix A, stored in the first kd+1 rows of the array. The *> j-th column of A is stored in the j-th column of the array AB *> as follows: *> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; *> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). *> *> On exit, if INFO = 0, the factor S from the split Cholesky *> factorization A = S**T*S. See Further Details. *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array AB. LDAB >= KD+1. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, the factorization could not be completed, *> because the updated element a(i,i) was negative; the *> matrix A is not positive definite. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The band storage scheme is illustrated by the following example, when *> N = 7, KD = 2: *> *> S = ( s11 s12 s13 ) *> ( s22 s23 s24 ) *> ( s33 s34 ) *> ( s44 ) *> ( s53 s54 s55 ) *> ( s64 s65 s66 ) *> ( s75 s76 s77 ) *> *> If UPLO = 'U', the array AB holds: *> *> on entry: on exit: *> *> * * a13 a24 a35 a46 a57 * * s13 s24 s53 s64 s75 *> * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54 s65 s76 *> a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77 *> *> If UPLO = 'L', the array AB holds: *> *> on entry: on exit: *> *> a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77 *> a21 a32 a43 a54 a65 a76 * s12 s23 s34 s54 s65 s76 * *> a31 a42 a53 a64 a64 * * s13 s24 s53 s64 s75 * * *> *> Array elements marked * are not used by the routine. *> \endverbatim *> * ===================================================================== SUBROUTINE DPBSTF( UPLO, N, KD, AB, LDAB, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, KD, LDAB, N * .. * .. Array Arguments .. DOUBLE PRECISION AB( LDAB, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER J, KLD, KM, M DOUBLE PRECISION AJJ * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DSCAL, DSYR, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( KD.LT.0 ) THEN INFO = -3 ELSE IF( LDAB.LT.KD+1 ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPBSTF', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * KLD = MAX( 1, LDAB-1 ) * * Set the splitting point m. * M = ( N+KD ) / 2 * IF( UPPER ) THEN * * Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m). * DO 10 J = N, M + 1, -1 * * Compute s(j,j) and test for non-positive-definiteness. * AJJ = AB( KD+1, J ) IF( AJJ.LE.ZERO ) $ GO TO 50 AJJ = SQRT( AJJ ) AB( KD+1, J ) = AJJ KM = MIN( J-1, KD ) * * Compute elements j-km:j-1 of the j-th column and update the * the leading submatrix within the band. * CALL DSCAL( KM, ONE / AJJ, AB( KD+1-KM, J ), 1 ) CALL DSYR( 'Upper', KM, -ONE, AB( KD+1-KM, J ), 1, $ AB( KD+1, J-KM ), KLD ) 10 CONTINUE * * Factorize the updated submatrix A(1:m,1:m) as U**T*U. * DO 20 J = 1, M * * Compute s(j,j) and test for non-positive-definiteness. * AJJ = AB( KD+1, J ) IF( AJJ.LE.ZERO ) $ GO TO 50 AJJ = SQRT( AJJ ) AB( KD+1, J ) = AJJ KM = MIN( KD, M-J ) * * Compute elements j+1:j+km of the j-th row and update the * trailing submatrix within the band. * IF( KM.GT.0 ) THEN CALL DSCAL( KM, ONE / AJJ, AB( KD, J+1 ), KLD ) CALL DSYR( 'Upper', KM, -ONE, AB( KD, J+1 ), KLD, $ AB( KD+1, J+1 ), KLD ) END IF 20 CONTINUE ELSE * * Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m). * DO 30 J = N, M + 1, -1 * * Compute s(j,j) and test for non-positive-definiteness. * AJJ = AB( 1, J ) IF( AJJ.LE.ZERO ) $ GO TO 50 AJJ = SQRT( AJJ ) AB( 1, J ) = AJJ KM = MIN( J-1, KD ) * * Compute elements j-km:j-1 of the j-th row and update the * trailing submatrix within the band. * CALL DSCAL( KM, ONE / AJJ, AB( KM+1, J-KM ), KLD ) CALL DSYR( 'Lower', KM, -ONE, AB( KM+1, J-KM ), KLD, $ AB( 1, J-KM ), KLD ) 30 CONTINUE * * Factorize the updated submatrix A(1:m,1:m) as U**T*U. * DO 40 J = 1, M * * Compute s(j,j) and test for non-positive-definiteness. * AJJ = AB( 1, J ) IF( AJJ.LE.ZERO ) $ GO TO 50 AJJ = SQRT( AJJ ) AB( 1, J ) = AJJ KM = MIN( KD, M-J ) * * Compute elements j+1:j+km of the j-th column and update the * trailing submatrix within the band. * IF( KM.GT.0 ) THEN CALL DSCAL( KM, ONE / AJJ, AB( 2, J ), 1 ) CALL DSYR( 'Lower', KM, -ONE, AB( 2, J ), 1, $ AB( 1, J+1 ), KLD ) END IF 40 CONTINUE END IF RETURN * 50 CONTINUE INFO = J RETURN * * End of DPBSTF * END *> \brief DPBSV computes the solution to system of linear equations A * X = B for OTHER matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPBSV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, LDB, N, NRHS * .. * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPBSV computes the solution to a real system of linear equations *> A * X = B, *> where A is an N-by-N symmetric positive definite band matrix and X *> and B are N-by-NRHS matrices. *> *> The Cholesky decomposition is used to factor A as *> A = U**T * U, if UPLO = 'U', or *> A = L * L**T, if UPLO = 'L', *> where U is an upper triangular band matrix, and L is a lower *> triangular band matrix, with the same number of superdiagonals or *> subdiagonals as A. The factored form of A is then used to solve the *> system of equations A * X = B. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of linear equations, i.e., the order of the *> matrix A. N >= 0. *> \endverbatim *> *> \param[in] KD *> \verbatim *> KD is INTEGER *> The number of superdiagonals of the matrix A if UPLO = 'U', *> or the number of subdiagonals if UPLO = 'L'. KD >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrix B. NRHS >= 0. *> \endverbatim *> *> \param[in,out] AB *> \verbatim *> AB is DOUBLE PRECISION array, dimension (LDAB,N) *> On entry, the upper or lower triangle of the symmetric band *> matrix A, stored in the first KD+1 rows of the array. The *> j-th column of A is stored in the j-th column of the array AB *> as follows: *> if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j; *> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD). *> See below for further details. *> *> On exit, if INFO = 0, the triangular factor U or L from the *> Cholesky factorization A = U**T*U or A = L*L**T of the band *> matrix A, in the same storage format as A. *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array AB. LDAB >= KD+1. *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> On entry, the N-by-NRHS right hand side matrix B. *> On exit, if INFO = 0, the N-by-NRHS solution matrix X. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, the leading minor of order i of A is not *> positive definite, so the factorization could not be *> completed, and the solution has not been computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERsolve * *> \par Further Details: * ===================== *> *> \verbatim *> *> The band storage scheme is illustrated by the following example, when *> N = 6, KD = 2, and UPLO = 'U': *> *> On entry: On exit: *> *> * * a13 a24 a35 a46 * * 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 *> *> Similarly, if UPLO = 'L' the format of A is as follows: *> *> On entry: On exit: *> *> a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 *> a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * *> a31 a42 a53 a64 * * l31 l42 l53 l64 * * *> *> Array elements marked * are not used by the routine. *> \endverbatim *> * ===================================================================== SUBROUTINE DPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, KD, LDAB, LDB, N, NRHS * .. * .. Array Arguments .. DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) * .. * * ===================================================================== * * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DPBTRF, DPBTRS, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( KD.LT.0 ) THEN INFO = -3 ELSE IF( NRHS.LT.0 ) THEN INFO = -4 ELSE IF( LDAB.LT.KD+1 ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPBSV ', -INFO ) RETURN END IF * * Compute the Cholesky factorization A = U**T*U or A = L*L**T. * CALL DPBTRF( UPLO, N, KD, AB, LDAB, INFO ) IF( INFO.EQ.0 ) THEN * * Solve the system A*X = B, overwriting B with X. * CALL DPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) * END IF RETURN * * End of DPBSV * END *> \brief DPBSVX computes the solution to system of linear equations A * X = B for OTHER matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPBSVX + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, * EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, * WORK, IWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER EQUED, FACT, UPLO * INTEGER INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS * DOUBLE PRECISION RCOND * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), * $ BERR( * ), FERR( * ), S( * ), WORK( * ), * $ X( LDX, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPBSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to *> compute the solution to a real system of linear equations *> A * X = B, *> where A is an N-by-N symmetric positive definite band matrix and X *> and B are N-by-NRHS matrices. *> *> Error bounds on the solution and a condition estimate are also *> provided. *> \endverbatim * *> \par Description: * ================= *> *> \verbatim *> *> The following steps are performed: *> *> 1. If FACT = 'E', real scaling factors are computed to equilibrate *> the system: *> diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B *> Whether or not the system will be equilibrated depends on the *> scaling of the matrix A, but if equilibration is used, A is *> overwritten by diag(S)*A*diag(S) and B by diag(S)*B. *> *> 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to *> factor the matrix A (after equilibration if FACT = 'E') as *> A = U**T * U, if UPLO = 'U', or *> A = L * L**T, if UPLO = 'L', *> where U is an upper triangular band matrix, and L is a lower *> triangular band matrix. *> *> 3. If the leading i-by-i principal minor is not positive definite, *> 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. *> *> 4. The system of equations is solved for X using the factored form *> of A. *> *> 5. Iterative refinement is applied to improve the computed solution *> matrix and calculate error bounds and backward error estimates *> for it. *> *> 6. If equilibration was used, the matrix X is premultiplied by *> diag(S) so that it solves the original system before *> equilibration. *> \endverbatim * * Arguments: * ========== * *> \param[in] FACT *> \verbatim *> FACT is CHARACTER*1 *> Specifies whether or not the factored form of the matrix A is *> supplied on entry, and if not, whether the matrix A should be *> equilibrated before it is factored. *> = 'F': On entry, AFB contains the factored form of A. *> If EQUED = 'Y', the matrix A has been equilibrated *> with scaling factors given by S. AB and AFB will not *> be modified. *> = 'N': The matrix A will be copied to AFB and factored. *> = 'E': The matrix A will be equilibrated if necessary, then *> copied to AFB and factored. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of linear equations, i.e., the order of the *> matrix A. N >= 0. *> \endverbatim *> *> \param[in] KD *> \verbatim *> KD is INTEGER *> The number of superdiagonals of the matrix A if UPLO = 'U', *> or the number of subdiagonals if UPLO = 'L'. KD >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right-hand sides, i.e., the number of columns *> of the matrices B and X. NRHS >= 0. *> \endverbatim *> *> \param[in,out] AB *> \verbatim *> AB is DOUBLE PRECISION array, dimension (LDAB,N) *> On entry, the upper or lower triangle of the symmetric band *> matrix A, stored in the first KD+1 rows of the array, except *> if FACT = 'F' and EQUED = 'Y', then A must contain the *> equilibrated matrix diag(S)*A*diag(S). The j-th column of A *> is stored in the j-th column of the array AB as follows: *> if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j; *> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD). *> See below for further details. *> *> On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by *> diag(S)*A*diag(S). *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array A. LDAB >= KD+1. *> \endverbatim *> *> \param[in,out] AFB *> \verbatim *> AFB is DOUBLE PRECISION array, dimension (LDAFB,N) *> If FACT = 'F', then AFB is an input argument and on entry *> contains the triangular factor U or L from the Cholesky *> factorization A = U**T*U or A = L*L**T of the band matrix *> A, in the same storage format as A (see AB). If EQUED = 'Y', *> then AFB is the factored form of the equilibrated matrix A. *> *> If FACT = 'N', then AFB is an output argument and on exit *> returns the triangular factor U or L from the Cholesky *> factorization A = U**T*U or A = L*L**T. *> *> If FACT = 'E', then AFB is an output argument and on exit *> returns the triangular factor U or L from the Cholesky *> factorization A = U**T*U or A = L*L**T of the equilibrated *> matrix A (see the description of A for the form of the *> equilibrated matrix). *> \endverbatim *> *> \param[in] LDAFB *> \verbatim *> LDAFB is INTEGER *> The leading dimension of the array AFB. LDAFB >= KD+1. *> \endverbatim *> *> \param[in,out] EQUED *> \verbatim *> EQUED is CHARACTER*1 *> Specifies the form of equilibration that was done. *> = 'N': No equilibration (always true if FACT = 'N'). *> = 'Y': Equilibration was done, i.e., A has been replaced by *> diag(S) * A * diag(S). *> EQUED is an input argument if FACT = 'F'; otherwise, it is an *> output argument. *> \endverbatim *> *> \param[in,out] S *> \verbatim *> S is DOUBLE PRECISION array, dimension (N) *> The scale factors for A; not accessed if EQUED = 'N'. S is *> an input argument if FACT = 'F'; otherwise, S is an output *> argument. If FACT = 'F' and EQUED = 'Y', each element of S *> must be positive. *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> On entry, the N-by-NRHS right hand side matrix B. *> On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', *> B is overwritten by diag(S) * B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,NRHS) *> If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to *> the original system of equations. Note that if EQUED = 'Y', *> A and B are modified on exit, and the solution to the *> equilibrated system is inv(diag(S))*X. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the array X. LDX >= max(1,N). *> \endverbatim *> *> \param[out] RCOND *> \verbatim *> RCOND is DOUBLE PRECISION *> The estimate of the reciprocal condition number of the matrix *> A after equilibration (if done). 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. *> \endverbatim *> *> \param[out] FERR *> \verbatim *> FERR is 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. *> \endverbatim *> *> \param[out] BERR *> \verbatim *> BERR is 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). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, and i is *> <= N: the leading minor of order i of A is *> not positive definite, so the factorization *> could not be completed, and the solution has not *> been 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. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date April 2012 * *> \ingroup doubleOTHERsolve * *> \par Further Details: * ===================== *> *> \verbatim *> *> The band storage scheme is illustrated by the following example, when *> N = 6, KD = 2, and UPLO = 'U': *> *> Two-dimensional storage of the symmetric matrix A: *> *> a11 a12 a13 *> a22 a23 a24 *> a33 a34 a35 *> a44 a45 a46 *> a55 a56 *> (aij=conjg(aji)) a66 *> *> Band storage of the upper triangle of A: *> *> * * a13 a24 a35 a46 *> * a12 a23 a34 a45 a56 *> a11 a22 a33 a44 a55 a66 *> *> Similarly, if UPLO = 'L' the format of A is as follows: *> *> a11 a22 a33 a44 a55 a66 *> a21 a32 a43 a54 a65 * *> a31 a42 a53 a64 * * *> *> Array elements marked * are not used by the routine. *> \endverbatim *> * ===================================================================== SUBROUTINE DPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, $ EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, $ WORK, IWORK, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * April 2012 * * .. Scalar Arguments .. CHARACTER EQUED, FACT, UPLO INTEGER INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS DOUBLE PRECISION RCOND * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), $ BERR( * ), FERR( * ), S( * ), WORK( * ), $ X( LDX, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL EQUIL, NOFACT, RCEQU, UPPER INTEGER I, INFEQU, J, J1, J2 DOUBLE PRECISION AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANSB EXTERNAL LSAME, DLAMCH, DLANSB * .. * .. External Subroutines .. EXTERNAL DCOPY, DLACPY, DLAQSB, DPBCON, DPBEQU, DPBRFS, $ DPBTRF, DPBTRS, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * INFO = 0 NOFACT = LSAME( FACT, 'N' ) EQUIL = LSAME( FACT, 'E' ) UPPER = LSAME( UPLO, 'U' ) IF( NOFACT .OR. EQUIL ) THEN EQUED = 'N' RCEQU = .FALSE. ELSE RCEQU = LSAME( EQUED, 'Y' ) SMLNUM = DLAMCH( 'Safe minimum' ) BIGNUM = ONE / SMLNUM END IF * * Test the input parameters. * IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) ) $ THEN INFO = -1 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( KD.LT.0 ) THEN INFO = -4 ELSE IF( NRHS.LT.0 ) THEN INFO = -5 ELSE IF( LDAB.LT.KD+1 ) THEN INFO = -7 ELSE IF( LDAFB.LT.KD+1 ) THEN INFO = -9 ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. $ ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN INFO = -10 ELSE IF( RCEQU ) THEN SMIN = BIGNUM SMAX = ZERO DO 10 J = 1, N SMIN = MIN( SMIN, S( J ) ) SMAX = MAX( SMAX, S( J ) ) 10 CONTINUE IF( SMIN.LE.ZERO ) THEN INFO = -11 ELSE IF( N.GT.0 ) THEN SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM ) ELSE SCOND = ONE END IF END IF IF( INFO.EQ.0 ) THEN IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -13 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -15 END IF END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPBSVX', -INFO ) RETURN END IF * IF( EQUIL ) THEN * * Compute row and column scalings to equilibrate the matrix A. * CALL DPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFEQU ) IF( INFEQU.EQ.0 ) THEN * * Equilibrate the matrix. * CALL DLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED ) RCEQU = LSAME( EQUED, 'Y' ) END IF END IF * * Scale the right-hand side. * IF( RCEQU ) THEN DO 30 J = 1, NRHS DO 20 I = 1, N B( I, J ) = S( I )*B( I, J ) 20 CONTINUE 30 CONTINUE END IF * IF( NOFACT .OR. EQUIL ) THEN * * Compute the Cholesky factorization A = U**T *U or A = L*L**T. * IF( UPPER ) THEN DO 40 J = 1, N J1 = MAX( J-KD, 1 ) CALL DCOPY( J-J1+1, AB( KD+1-J+J1, J ), 1, $ AFB( KD+1-J+J1, J ), 1 ) 40 CONTINUE ELSE DO 50 J = 1, N J2 = MIN( J+KD, N ) CALL DCOPY( J2-J+1, AB( 1, J ), 1, AFB( 1, J ), 1 ) 50 CONTINUE END IF * CALL DPBTRF( UPLO, N, KD, AFB, LDAFB, 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. * ANORM = DLANSB( '1', UPLO, N, KD, AB, LDAB, WORK ) * * Compute the reciprocal of the condition number of A. * CALL DPBCON( UPLO, N, KD, AFB, LDAFB, ANORM, RCOND, WORK, IWORK, $ INFO ) * * Compute the solution matrix X. * CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) CALL DPBTRS( UPLO, N, KD, NRHS, AFB, LDAFB, X, LDX, INFO ) * * Use iterative refinement to improve the computed solution and * compute error bounds and backward error estimates for it. * CALL DPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, $ LDX, FERR, BERR, WORK, IWORK, INFO ) * * Transform the solution matrix X to a solution of the original * system. * IF( RCEQU ) THEN DO 70 J = 1, NRHS DO 60 I = 1, N X( I, J ) = S( I )*X( I, J ) 60 CONTINUE 70 CONTINUE DO 80 J = 1, NRHS FERR( J ) = FERR( J ) / SCOND 80 CONTINUE END IF * * Set INFO = N+1 if the matrix is singular to working precision. * IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) $ INFO = N + 1 * RETURN * * End of DPBSVX * END *> \brief \b DPBTF2 computes the Cholesky factorization of a symmetric/Hermitian positive definite band matrix (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPBTF2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPBTF2( UPLO, N, KD, AB, LDAB, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, N * .. * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPBTF2 computes the Cholesky factorization of a real symmetric *> positive definite band matrix A. *> *> The factorization has the form *> A = U**T * U , if UPLO = 'U', or *> A = L * L**T, if UPLO = 'L', *> where U is an upper triangular matrix, U**T is the transpose of U, and *> L is lower triangular. *> *> This is the unblocked version of the algorithm, calling Level 2 BLAS. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the upper or lower triangular part of the *> symmetric matrix A is stored: *> = 'U': Upper triangular *> = 'L': Lower triangular *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] KD *> \verbatim *> KD is INTEGER *> The number of super-diagonals of the matrix A if UPLO = 'U', *> or the number of sub-diagonals if UPLO = 'L'. KD >= 0. *> \endverbatim *> *> \param[in,out] AB *> \verbatim *> AB is DOUBLE PRECISION array, dimension (LDAB,N) *> On entry, the upper or lower triangle of the symmetric band *> matrix A, stored in the first KD+1 rows of the array. The *> j-th column of A is stored in the j-th column of the array AB *> as follows: *> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; *> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). *> *> On exit, if INFO = 0, the triangular factor U or L from the *> Cholesky factorization A = U**T*U or A = L*L**T of the band *> matrix A, in the same storage format as A. *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array AB. LDAB >= KD+1. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -k, the k-th argument had an illegal value *> > 0: if INFO = k, the leading minor of order k is not *> positive definite, and the factorization could not be *> completed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The band storage scheme is illustrated by the following example, when *> N = 6, KD = 2, and UPLO = 'U': *> *> On entry: On exit: *> *> * * a13 a24 a35 a46 * * 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 *> *> Similarly, if UPLO = 'L' the format of A is as follows: *> *> On entry: On exit: *> *> a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 *> a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * *> a31 a42 a53 a64 * * l31 l42 l53 l64 * * *> *> Array elements marked * are not used by the routine. *> \endverbatim *> * ===================================================================== SUBROUTINE DPBTF2( UPLO, N, KD, AB, LDAB, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, KD, LDAB, N * .. * .. Array Arguments .. DOUBLE PRECISION AB( LDAB, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER J, KLD, KN DOUBLE PRECISION AJJ * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DSCAL, DSYR, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( KD.LT.0 ) THEN INFO = -3 ELSE IF( LDAB.LT.KD+1 ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPBTF2', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * KLD = MAX( 1, LDAB-1 ) * IF( UPPER ) THEN * * Compute the Cholesky factorization A = U**T*U. * DO 10 J = 1, N * * Compute U(J,J) and test for non-positive-definiteness. * AJJ = AB( KD+1, J ) IF( AJJ.LE.ZERO ) $ GO TO 30 AJJ = SQRT( AJJ ) AB( KD+1, J ) = AJJ * * Compute elements J+1:J+KN of row J and update the * trailing submatrix within the band. * KN = MIN( KD, N-J ) IF( KN.GT.0 ) THEN CALL DSCAL( KN, ONE / AJJ, AB( KD, J+1 ), KLD ) CALL DSYR( 'Upper', KN, -ONE, AB( KD, J+1 ), KLD, $ AB( KD+1, J+1 ), KLD ) END IF 10 CONTINUE ELSE * * Compute the Cholesky factorization A = L*L**T. * DO 20 J = 1, N * * Compute L(J,J) and test for non-positive-definiteness. * AJJ = AB( 1, J ) IF( AJJ.LE.ZERO ) $ GO TO 30 AJJ = SQRT( AJJ ) AB( 1, J ) = AJJ * * Compute elements J+1:J+KN of column J and update the * trailing submatrix within the band. * KN = MIN( KD, N-J ) IF( KN.GT.0 ) THEN CALL DSCAL( KN, ONE / AJJ, AB( 2, J ), 1 ) CALL DSYR( 'Lower', KN, -ONE, AB( 2, J ), 1, $ AB( 1, J+1 ), KLD ) END IF 20 CONTINUE END IF RETURN * 30 CONTINUE INFO = J RETURN * * End of DPBTF2 * END *> \brief \b DPBTRF * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPBTRF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPBTRF( UPLO, N, KD, AB, LDAB, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, N * .. * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPBTRF computes the Cholesky factorization of a real symmetric *> positive definite band matrix A. *> *> The factorization has the form *> A = U**T * U, if UPLO = 'U', or *> A = L * L**T, if UPLO = 'L', *> where U is an upper triangular matrix and L is lower triangular. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] KD *> \verbatim *> KD is INTEGER *> The number of superdiagonals of the matrix A if UPLO = 'U', *> or the number of subdiagonals if UPLO = 'L'. KD >= 0. *> \endverbatim *> *> \param[in,out] AB *> \verbatim *> AB is DOUBLE PRECISION array, dimension (LDAB,N) *> On entry, the upper or lower triangle of the symmetric band *> matrix A, stored in the first KD+1 rows of the array. The *> j-th column of A is stored in the j-th column of the array AB *> as follows: *> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; *> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). *> *> On exit, if INFO = 0, the triangular factor U or L from the *> Cholesky factorization A = U**T*U or A = L*L**T of the band *> matrix A, in the same storage format as A. *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array AB. LDAB >= KD+1. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, the leading minor of order i is not *> positive definite, and the factorization could not be *> completed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The band storage scheme is illustrated by the following example, when *> N = 6, KD = 2, and UPLO = 'U': *> *> On entry: On exit: *> *> * * a13 a24 a35 a46 * * 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 *> *> Similarly, if UPLO = 'L' the format of A is as follows: *> *> On entry: On exit: *> *> a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 *> a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * *> a31 a42 a53 a64 * * l31 l42 l53 l64 * * *> *> Array elements marked * are not used by the routine. *> \endverbatim * *> \par Contributors: * ================== *> *> Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989 * * ===================================================================== SUBROUTINE DPBTRF( UPLO, N, KD, AB, LDAB, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, KD, LDAB, N * .. * .. Array Arguments .. DOUBLE PRECISION AB( LDAB, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) INTEGER NBMAX, LDWORK PARAMETER ( NBMAX = 32, LDWORK = NBMAX+1 ) * .. * .. Local Scalars .. INTEGER I, I2, I3, IB, II, J, JJ, NB * .. * .. Local Arrays .. DOUBLE PRECISION WORK( LDWORK, NBMAX ) * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DGEMM, DPBTF2, DPOTF2, DSYRK, DTRSM, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF( ( .NOT.LSAME( UPLO, 'U' ) ) .AND. $ ( .NOT.LSAME( UPLO, 'L' ) ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( KD.LT.0 ) THEN INFO = -3 ELSE IF( LDAB.LT.KD+1 ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPBTRF', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Determine the block size for this environment * NB = ILAENV( 1, 'DPBTRF', UPLO, N, KD, -1, -1 ) * * The block size must not exceed the semi-bandwidth KD, and must not * exceed the limit set by the size of the local array WORK. * NB = MIN( NB, NBMAX ) * IF( NB.LE.1 .OR. NB.GT.KD ) THEN * * Use unblocked code * CALL DPBTF2( UPLO, N, KD, AB, LDAB, INFO ) ELSE * * Use blocked code * IF( LSAME( UPLO, 'U' ) ) THEN * * Compute the Cholesky factorization of a symmetric band * matrix, given the upper triangle of the matrix in band * storage. * * Zero the upper triangle of the work array. * DO 20 J = 1, NB DO 10 I = 1, J - 1 WORK( I, J ) = ZERO 10 CONTINUE 20 CONTINUE * * Process the band matrix one diagonal block at a time. * DO 70 I = 1, N, NB IB = MIN( NB, N-I+1 ) * * Factorize the diagonal block * CALL DPOTF2( UPLO, IB, AB( KD+1, I ), LDAB-1, II ) IF( II.NE.0 ) THEN INFO = I + II - 1 GO TO 150 END IF IF( I+IB.LE.N ) THEN * * Update the relevant part of the trailing submatrix. * If A11 denotes the diagonal block which has just been * factorized, then we need to update the remaining * blocks in the diagram: * * A11 A12 A13 * A22 A23 * A33 * * The numbers of rows and columns in the partitioning * are IB, I2, I3 respectively. The blocks A12, A22 and * A23 are empty if IB = KD. The upper triangle of A13 * lies outside the band. * I2 = MIN( KD-IB, N-I-IB+1 ) I3 = MIN( IB, N-I-KD+1 ) * IF( I2.GT.0 ) THEN * * Update A12 * CALL DTRSM( 'Left', 'Upper', 'Transpose', $ 'Non-unit', IB, I2, ONE, AB( KD+1, I ), $ LDAB-1, AB( KD+1-IB, I+IB ), LDAB-1 ) * * Update A22 * CALL DSYRK( 'Upper', 'Transpose', I2, IB, -ONE, $ AB( KD+1-IB, I+IB ), LDAB-1, ONE, $ AB( KD+1, I+IB ), LDAB-1 ) END IF * IF( I3.GT.0 ) THEN * * Copy the lower triangle of A13 into the work array. * DO 40 JJ = 1, I3 DO 30 II = JJ, IB WORK( II, JJ ) = AB( II-JJ+1, JJ+I+KD-1 ) 30 CONTINUE 40 CONTINUE * * Update A13 (in the work array). * CALL DTRSM( 'Left', 'Upper', 'Transpose', $ 'Non-unit', IB, I3, ONE, AB( KD+1, I ), $ LDAB-1, WORK, LDWORK ) * * Update A23 * IF( I2.GT.0 ) $ CALL DGEMM( 'Transpose', 'No Transpose', I2, I3, $ IB, -ONE, AB( KD+1-IB, I+IB ), $ LDAB-1, WORK, LDWORK, ONE, $ AB( 1+IB, I+KD ), LDAB-1 ) * * Update A33 * CALL DSYRK( 'Upper', 'Transpose', I3, IB, -ONE, $ WORK, LDWORK, ONE, AB( KD+1, I+KD ), $ LDAB-1 ) * * Copy the lower triangle of A13 back into place. * DO 60 JJ = 1, I3 DO 50 II = JJ, IB AB( II-JJ+1, JJ+I+KD-1 ) = WORK( II, JJ ) 50 CONTINUE 60 CONTINUE END IF END IF 70 CONTINUE ELSE * * Compute the Cholesky factorization of a symmetric band * matrix, given the lower triangle of the matrix in band * storage. * * Zero the lower triangle of the work array. * DO 90 J = 1, NB DO 80 I = J + 1, NB WORK( I, J ) = ZERO 80 CONTINUE 90 CONTINUE * * Process the band matrix one diagonal block at a time. * DO 140 I = 1, N, NB IB = MIN( NB, N-I+1 ) * * Factorize the diagonal block * CALL DPOTF2( UPLO, IB, AB( 1, I ), LDAB-1, II ) IF( II.NE.0 ) THEN INFO = I + II - 1 GO TO 150 END IF IF( I+IB.LE.N ) THEN * * Update the relevant part of the trailing submatrix. * If A11 denotes the diagonal block which has just been * factorized, then we need to update the remaining * blocks in the diagram: * * A11 * A21 A22 * A31 A32 A33 * * The numbers of rows and columns in the partitioning * are IB, I2, I3 respectively. The blocks A21, A22 and * A32 are empty if IB = KD. The lower triangle of A31 * lies outside the band. * I2 = MIN( KD-IB, N-I-IB+1 ) I3 = MIN( IB, N-I-KD+1 ) * IF( I2.GT.0 ) THEN * * Update A21 * CALL DTRSM( 'Right', 'Lower', 'Transpose', $ 'Non-unit', I2, IB, ONE, AB( 1, I ), $ LDAB-1, AB( 1+IB, I ), LDAB-1 ) * * Update A22 * CALL DSYRK( 'Lower', 'No Transpose', I2, IB, -ONE, $ AB( 1+IB, I ), LDAB-1, ONE, $ AB( 1, I+IB ), LDAB-1 ) END IF * IF( I3.GT.0 ) THEN * * Copy the upper triangle of A31 into the work array. * DO 110 JJ = 1, IB DO 100 II = 1, MIN( JJ, I3 ) WORK( II, JJ ) = AB( KD+1-JJ+II, JJ+I-1 ) 100 CONTINUE 110 CONTINUE * * Update A31 (in the work array). * CALL DTRSM( 'Right', 'Lower', 'Transpose', $ 'Non-unit', I3, IB, ONE, AB( 1, I ), $ LDAB-1, WORK, LDWORK ) * * Update A32 * IF( I2.GT.0 ) $ CALL DGEMM( 'No transpose', 'Transpose', I3, I2, $ IB, -ONE, WORK, LDWORK, $ AB( 1+IB, I ), LDAB-1, ONE, $ AB( 1+KD-IB, I+IB ), LDAB-1 ) * * Update A33 * CALL DSYRK( 'Lower', 'No Transpose', I3, IB, -ONE, $ WORK, LDWORK, ONE, AB( 1, I+KD ), $ LDAB-1 ) * * Copy the upper triangle of A31 back into place. * DO 130 JJ = 1, IB DO 120 II = 1, MIN( JJ, I3 ) AB( KD+1-JJ+II, JJ+I-1 ) = WORK( II, JJ ) 120 CONTINUE 130 CONTINUE END IF END IF 140 CONTINUE END IF END IF RETURN * 150 CONTINUE RETURN * * End of DPBTRF * END *> \brief \b DPBTRS * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPBTRS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KD, LDAB, LDB, N, NRHS * .. * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPBTRS solves a system of linear equations A*X = B with a symmetric *> positive definite band matrix A using the Cholesky factorization *> A = U**T*U or A = L*L**T computed by DPBTRF. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangular factor stored in AB; *> = 'L': Lower triangular factor stored in AB. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] KD *> \verbatim *> KD is INTEGER *> The number of superdiagonals of the matrix A if UPLO = 'U', *> or the number of subdiagonals if UPLO = 'L'. KD >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrix B. NRHS >= 0. *> \endverbatim *> *> \param[in] AB *> \verbatim *> AB is DOUBLE PRECISION array, dimension (LDAB,N) *> The triangular factor U or L from the Cholesky factorization *> A = U**T*U or A = L*L**T of the band matrix A, stored in the *> first KD+1 rows of the array. The j-th column of U or L is *> stored in the j-th column of the array AB as follows: *> if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j; *> if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd). *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array AB. LDAB >= KD+1. *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> On entry, the right hand side matrix B. *> On exit, the solution matrix X. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, KD, LDAB, LDB, N, NRHS * .. * .. Array Arguments .. DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL UPPER INTEGER J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DTBSV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( KD.LT.0 ) THEN INFO = -3 ELSE IF( NRHS.LT.0 ) THEN INFO = -4 ELSE IF( LDAB.LT.KD+1 ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPBTRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * IF( UPPER ) THEN * * Solve A*X = B where A = U**T *U. * DO 10 J = 1, NRHS * * Solve U**T *X = B, overwriting B with X. * CALL DTBSV( 'Upper', 'Transpose', 'Non-unit', N, KD, AB, $ LDAB, B( 1, J ), 1 ) * * Solve U*X = B, overwriting B with X. * CALL DTBSV( 'Upper', 'No transpose', 'Non-unit', N, KD, AB, $ LDAB, B( 1, J ), 1 ) 10 CONTINUE ELSE * * Solve A*X = B where A = L*L**T. * DO 20 J = 1, NRHS * * Solve L*X = B, overwriting B with X. * CALL DTBSV( 'Lower', 'No transpose', 'Non-unit', N, KD, AB, $ LDAB, B( 1, J ), 1 ) * * Solve L**T *X = B, overwriting B with X. * CALL DTBSV( 'Lower', 'Transpose', 'Non-unit', N, KD, AB, $ LDAB, B( 1, J ), 1 ) 20 CONTINUE END IF * RETURN * * End of DPBTRS * END *> \brief \b DPFTRF * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPFTRF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPFTRF( TRANSR, UPLO, N, A, INFO ) * * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER N, INFO * .. * .. Array Arguments .. * DOUBLE PRECISION A( 0: * ) * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPFTRF computes the Cholesky factorization of a real symmetric *> positive definite matrix A. *> *> The factorization has the form *> A = U**T * U, if UPLO = 'U', or *> A = L * L**T, if UPLO = 'L', *> where U is an upper triangular matrix and L is lower triangular. *> *> This is the block version of the algorithm, calling Level 3 BLAS. *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANSR *> \verbatim *> TRANSR is CHARACTER*1 *> = 'N': The Normal TRANSR of RFP A is stored; *> = 'T': The Transpose TRANSR of RFP A is stored. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of RFP A is stored; *> = 'L': Lower triangle of RFP A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension ( N*(N+1)/2 ); *> On entry, the symmetric matrix A in RFP format. RFP format is *> described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' *> then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is *> (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is *> the transpose of RFP A as defined when *> TRANSR = 'N'. The contents of RFP A are defined by UPLO as *> follows: If UPLO = 'U' the RFP A contains the NT elements of *> upper packed A. If UPLO = 'L' the RFP A contains the elements *> of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR = *> 'T'. When TRANSR is 'N' the LDA is N+1 when N is even and N *> is odd. See the Note below for more details. *> *> On exit, if INFO = 0, the factor U or L from the Cholesky *> factorization RFP A = U**T*U or RFP A = L*L**T. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, the leading minor of order i is not *> positive definite, and the factorization could not be *> completed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> We first consider Rectangular Full Packed (RFP) Format when N is *> even. We give an example where N = 6. *> *> AP is Upper AP is Lower *> *> 00 01 02 03 04 05 00 *> 11 12 13 14 15 10 11 *> 22 23 24 25 20 21 22 *> 33 34 35 30 31 32 33 *> 44 45 40 41 42 43 44 *> 55 50 51 52 53 54 55 *> *> *> Let TRANSR = 'N'. RFP holds AP as follows: *> For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last *> three columns of AP upper. The lower triangle A(4:6,0:2) consists of *> the transpose of the first three columns of AP upper. *> For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first *> three columns of AP lower. The upper triangle A(0:2,0:2) consists of *> the transpose of the last three columns of AP lower. *> This covers the case N even and TRANSR = 'N'. *> *> RFP A RFP A *> *> 03 04 05 33 43 53 *> 13 14 15 00 44 54 *> 23 24 25 10 11 55 *> 33 34 35 20 21 22 *> 00 44 45 30 31 32 *> 01 11 55 40 41 42 *> 02 12 22 50 51 52 *> *> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the *> transpose of RFP A above. One therefore gets: *> *> *> RFP A RFP A *> *> 03 13 23 33 00 01 02 33 00 10 20 30 40 50 *> 04 14 24 34 44 11 12 43 44 11 21 31 41 51 *> 05 15 25 35 45 55 22 53 54 55 22 32 42 52 *> *> *> We then consider Rectangular Full Packed (RFP) Format when N is *> odd. We give an example where N = 5. *> *> AP is Upper AP is Lower *> *> 00 01 02 03 04 00 *> 11 12 13 14 10 11 *> 22 23 24 20 21 22 *> 33 34 30 31 32 33 *> 44 40 41 42 43 44 *> *> *> Let TRANSR = 'N'. RFP holds AP as follows: *> For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last *> three columns of AP upper. The lower triangle A(3:4,0:1) consists of *> the transpose of the first two columns of AP upper. *> For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first *> three columns of AP lower. The upper triangle A(0:1,1:2) consists of *> the transpose of the last two columns of AP lower. *> This covers the case N odd and TRANSR = 'N'. *> *> RFP A RFP A *> *> 02 03 04 00 33 43 *> 12 13 14 10 11 44 *> 22 23 24 20 21 22 *> 00 33 34 30 31 32 *> 01 11 44 40 41 42 *> *> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the *> transpose of RFP A above. One therefore gets: *> *> RFP A RFP A *> *> 02 12 22 00 01 00 10 20 30 40 50 *> 03 13 23 33 11 33 11 21 31 41 51 *> 04 14 24 34 44 43 44 22 32 42 52 *> \endverbatim *> * ===================================================================== SUBROUTINE DPFTRF( TRANSR, UPLO, N, A, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO INTEGER N, INFO * .. * .. Array Arguments .. DOUBLE PRECISION A( 0: * ) * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LOWER, NISODD, NORMALTRANSR INTEGER N1, N2, K * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, DSYRK, DPOTRF, DTRSM * .. * .. Intrinsic Functions .. INTRINSIC MOD * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 NORMALTRANSR = LSAME( TRANSR, 'N' ) LOWER = LSAME( UPLO, 'L' ) IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN INFO = -1 ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPFTRF', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * If N is odd, set NISODD = .TRUE. * If N is even, set K = N/2 and NISODD = .FALSE. * IF( MOD( N, 2 ).EQ.0 ) THEN K = N / 2 NISODD = .FALSE. ELSE NISODD = .TRUE. END IF * * Set N1 and N2 depending on LOWER * IF( LOWER ) THEN N2 = N / 2 N1 = N - N2 ELSE N1 = N / 2 N2 = N - N1 END IF * * start execution: there are eight cases * IF( NISODD ) THEN * * N is odd * IF( NORMALTRANSR ) THEN * * N is odd and TRANSR = 'N' * IF( LOWER ) THEN * * SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) * T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) * T1 -> a(0), T2 -> a(n), S -> a(n1) * CALL DPOTRF( 'L', N1, A( 0 ), N, INFO ) IF( INFO.GT.0 ) $ RETURN CALL DTRSM( 'R', 'L', 'T', 'N', N2, N1, ONE, A( 0 ), N, $ A( N1 ), N ) CALL DSYRK( 'U', 'N', N2, N1, -ONE, A( N1 ), N, ONE, $ A( N ), N ) CALL DPOTRF( 'U', N2, A( N ), N, INFO ) IF( INFO.GT.0 ) $ INFO = INFO + N1 * ELSE * * SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) * T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) * T1 -> a(n2), T2 -> a(n1), S -> a(0) * CALL DPOTRF( 'L', N1, A( N2 ), N, INFO ) IF( INFO.GT.0 ) $ RETURN CALL DTRSM( 'L', 'L', 'N', 'N', N1, N2, ONE, A( N2 ), N, $ A( 0 ), N ) CALL DSYRK( 'U', 'T', N2, N1, -ONE, A( 0 ), N, ONE, $ A( N1 ), N ) CALL DPOTRF( 'U', N2, A( N1 ), N, INFO ) IF( INFO.GT.0 ) $ INFO = INFO + N1 * END IF * ELSE * * N is odd and TRANSR = 'T' * IF( LOWER ) THEN * * SRPA for LOWER, TRANSPOSE and N is odd * T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) * T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 * CALL DPOTRF( 'U', N1, A( 0 ), N1, INFO ) IF( INFO.GT.0 ) $ RETURN CALL DTRSM( 'L', 'U', 'T', 'N', N1, N2, ONE, A( 0 ), N1, $ A( N1*N1 ), N1 ) CALL DSYRK( 'L', 'T', N2, N1, -ONE, A( N1*N1 ), N1, ONE, $ A( 1 ), N1 ) CALL DPOTRF( 'L', N2, A( 1 ), N1, INFO ) IF( INFO.GT.0 ) $ INFO = INFO + N1 * ELSE * * SRPA for UPPER, TRANSPOSE and N is odd * T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) * T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 * CALL DPOTRF( 'U', N1, A( N2*N2 ), N2, INFO ) IF( INFO.GT.0 ) $ RETURN CALL DTRSM( 'R', 'U', 'N', 'N', N2, N1, ONE, A( N2*N2 ), $ N2, A( 0 ), N2 ) CALL DSYRK( 'L', 'N', N2, N1, -ONE, A( 0 ), N2, ONE, $ A( N1*N2 ), N2 ) CALL DPOTRF( 'L', N2, A( N1*N2 ), N2, INFO ) IF( INFO.GT.0 ) $ INFO = INFO + N1 * END IF * END IF * ELSE * * N is even * IF( NORMALTRANSR ) THEN * * N is even and TRANSR = 'N' * IF( LOWER ) THEN * * SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) * T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) * T1 -> a(1), T2 -> a(0), S -> a(k+1) * CALL DPOTRF( 'L', K, A( 1 ), N+1, INFO ) IF( INFO.GT.0 ) $ RETURN CALL DTRSM( 'R', 'L', 'T', 'N', K, K, ONE, A( 1 ), N+1, $ A( K+1 ), N+1 ) CALL DSYRK( 'U', 'N', K, K, -ONE, A( K+1 ), N+1, ONE, $ A( 0 ), N+1 ) CALL DPOTRF( 'U', K, A( 0 ), N+1, INFO ) IF( INFO.GT.0 ) $ INFO = INFO + K * ELSE * * SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) * T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) * T1 -> a(k+1), T2 -> a(k), S -> a(0) * CALL DPOTRF( 'L', K, A( K+1 ), N+1, INFO ) IF( INFO.GT.0 ) $ RETURN CALL DTRSM( 'L', 'L', 'N', 'N', K, K, ONE, A( K+1 ), $ N+1, A( 0 ), N+1 ) CALL DSYRK( 'U', 'T', K, K, -ONE, A( 0 ), N+1, ONE, $ A( K ), N+1 ) CALL DPOTRF( 'U', K, A( K ), N+1, INFO ) IF( INFO.GT.0 ) $ INFO = INFO + K * END IF * ELSE * * N is even and TRANSR = 'T' * IF( LOWER ) THEN * * SRPA for LOWER, TRANSPOSE and N is even (see paper) * T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) * T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k * CALL DPOTRF( 'U', K, A( 0+K ), K, INFO ) IF( INFO.GT.0 ) $ RETURN CALL DTRSM( 'L', 'U', 'T', 'N', K, K, ONE, A( K ), N1, $ A( K*( K+1 ) ), K ) CALL DSYRK( 'L', 'T', K, K, -ONE, A( K*( K+1 ) ), K, ONE, $ A( 0 ), K ) CALL DPOTRF( 'L', K, A( 0 ), K, INFO ) IF( INFO.GT.0 ) $ INFO = INFO + K * ELSE * * SRPA for UPPER, TRANSPOSE and N is even (see paper) * T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) * T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k * CALL DPOTRF( 'U', K, A( K*( K+1 ) ), K, INFO ) IF( INFO.GT.0 ) $ RETURN CALL DTRSM( 'R', 'U', 'N', 'N', K, K, ONE, $ A( K*( K+1 ) ), K, A( 0 ), K ) CALL DSYRK( 'L', 'N', K, K, -ONE, A( 0 ), K, ONE, $ A( K*K ), K ) CALL DPOTRF( 'L', K, A( K*K ), K, INFO ) IF( INFO.GT.0 ) $ INFO = INFO + K * END IF * END IF * END IF * RETURN * * End of DPFTRF * END *> \brief \b DPFTRI * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPFTRI + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPFTRI( TRANSR, UPLO, N, A, INFO ) * * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER INFO, N * .. Array Arguments .. * DOUBLE PRECISION A( 0: * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPFTRI computes the inverse of a (real) symmetric positive definite *> matrix A using the Cholesky factorization A = U**T*U or A = L*L**T *> computed by DPFTRF. *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANSR *> \verbatim *> TRANSR is CHARACTER*1 *> = 'N': The Normal TRANSR of RFP A is stored; *> = 'T': The Transpose TRANSR of RFP A is stored. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension ( N*(N+1)/2 ) *> On entry, the symmetric matrix A in RFP format. RFP format is *> described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' *> then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is *> (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is *> the transpose of RFP A as defined when *> TRANSR = 'N'. The contents of RFP A are defined by UPLO as *> follows: If UPLO = 'U' the RFP A contains the nt elements of *> upper packed A. If UPLO = 'L' the RFP A contains the elements *> of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR = *> 'T'. When TRANSR is 'N' the LDA is N+1 when N is even and N *> is odd. See the Note below for more details. *> *> On exit, the symmetric inverse of the original matrix, in the *> same storage format. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, the (i,i) element of the factor U or L is *> zero, and the inverse could not be computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> We first consider Rectangular Full Packed (RFP) Format when N is *> even. We give an example where N = 6. *> *> AP is Upper AP is Lower *> *> 00 01 02 03 04 05 00 *> 11 12 13 14 15 10 11 *> 22 23 24 25 20 21 22 *> 33 34 35 30 31 32 33 *> 44 45 40 41 42 43 44 *> 55 50 51 52 53 54 55 *> *> *> Let TRANSR = 'N'. RFP holds AP as follows: *> For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last *> three columns of AP upper. The lower triangle A(4:6,0:2) consists of *> the transpose of the first three columns of AP upper. *> For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first *> three columns of AP lower. The upper triangle A(0:2,0:2) consists of *> the transpose of the last three columns of AP lower. *> This covers the case N even and TRANSR = 'N'. *> *> RFP A RFP A *> *> 03 04 05 33 43 53 *> 13 14 15 00 44 54 *> 23 24 25 10 11 55 *> 33 34 35 20 21 22 *> 00 44 45 30 31 32 *> 01 11 55 40 41 42 *> 02 12 22 50 51 52 *> *> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the *> transpose of RFP A above. One therefore gets: *> *> *> RFP A RFP A *> *> 03 13 23 33 00 01 02 33 00 10 20 30 40 50 *> 04 14 24 34 44 11 12 43 44 11 21 31 41 51 *> 05 15 25 35 45 55 22 53 54 55 22 32 42 52 *> *> *> We then consider Rectangular Full Packed (RFP) Format when N is *> odd. We give an example where N = 5. *> *> AP is Upper AP is Lower *> *> 00 01 02 03 04 00 *> 11 12 13 14 10 11 *> 22 23 24 20 21 22 *> 33 34 30 31 32 33 *> 44 40 41 42 43 44 *> *> *> Let TRANSR = 'N'. RFP holds AP as follows: *> For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last *> three columns of AP upper. The lower triangle A(3:4,0:1) consists of *> the transpose of the first two columns of AP upper. *> For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first *> three columns of AP lower. The upper triangle A(0:1,1:2) consists of *> the transpose of the last two columns of AP lower. *> This covers the case N odd and TRANSR = 'N'. *> *> RFP A RFP A *> *> 02 03 04 00 33 43 *> 12 13 14 10 11 44 *> 22 23 24 20 21 22 *> 00 33 34 30 31 32 *> 01 11 44 40 41 42 *> *> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the *> transpose of RFP A above. One therefore gets: *> *> RFP A RFP A *> *> 02 12 22 00 01 00 10 20 30 40 50 *> 03 13 23 33 11 33 11 21 31 41 51 *> 04 14 24 34 44 43 44 22 32 42 52 *> \endverbatim *> * ===================================================================== SUBROUTINE DPFTRI( TRANSR, UPLO, N, A, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO INTEGER INFO, N * .. Array Arguments .. DOUBLE PRECISION A( 0: * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LOWER, NISODD, NORMALTRANSR INTEGER N1, N2, K * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, DTFTRI, DLAUUM, DTRMM, DSYRK * .. * .. Intrinsic Functions .. INTRINSIC MOD * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 NORMALTRANSR = LSAME( TRANSR, 'N' ) LOWER = LSAME( UPLO, 'L' ) IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN INFO = -1 ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPFTRI', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Invert the triangular Cholesky factor U or L. * CALL DTFTRI( TRANSR, UPLO, 'N', N, A, INFO ) IF( INFO.GT.0 ) $ RETURN * * If N is odd, set NISODD = .TRUE. * If N is even, set K = N/2 and NISODD = .FALSE. * IF( MOD( N, 2 ).EQ.0 ) THEN K = N / 2 NISODD = .FALSE. ELSE NISODD = .TRUE. END IF * * Set N1 and N2 depending on LOWER * IF( LOWER ) THEN N2 = N / 2 N1 = N - N2 ELSE N1 = N / 2 N2 = N - N1 END IF * * Start execution of triangular matrix multiply: inv(U)*inv(U)^C or * inv(L)^C*inv(L). There are eight cases. * IF( NISODD ) THEN * * N is odd * IF( NORMALTRANSR ) THEN * * N is odd and TRANSR = 'N' * IF( LOWER ) THEN * * SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:N1-1) ) * T1 -> a(0,0), T2 -> a(0,1), S -> a(N1,0) * T1 -> a(0), T2 -> a(n), S -> a(N1) * CALL DLAUUM( 'L', N1, A( 0 ), N, INFO ) CALL DSYRK( 'L', 'T', N1, N2, ONE, A( N1 ), N, ONE, $ A( 0 ), N ) CALL DTRMM( 'L', 'U', 'N', 'N', N2, N1, ONE, A( N ), N, $ A( N1 ), N ) CALL DLAUUM( 'U', N2, A( N ), N, INFO ) * ELSE * * SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:N2-1) * T1 -> a(N1+1,0), T2 -> a(N1,0), S -> a(0,0) * T1 -> a(N2), T2 -> a(N1), S -> a(0) * CALL DLAUUM( 'L', N1, A( N2 ), N, INFO ) CALL DSYRK( 'L', 'N', N1, N2, ONE, A( 0 ), N, ONE, $ A( N2 ), N ) CALL DTRMM( 'R', 'U', 'T', 'N', N1, N2, ONE, A( N1 ), N, $ A( 0 ), N ) CALL DLAUUM( 'U', N2, A( N1 ), N, INFO ) * END IF * ELSE * * N is odd and TRANSR = 'T' * IF( LOWER ) THEN * * SRPA for LOWER, TRANSPOSE, and N is odd * T1 -> a(0), T2 -> a(1), S -> a(0+N1*N1) * CALL DLAUUM( 'U', N1, A( 0 ), N1, INFO ) CALL DSYRK( 'U', 'N', N1, N2, ONE, A( N1*N1 ), N1, ONE, $ A( 0 ), N1 ) CALL DTRMM( 'R', 'L', 'N', 'N', N1, N2, ONE, A( 1 ), N1, $ A( N1*N1 ), N1 ) CALL DLAUUM( 'L', N2, A( 1 ), N1, INFO ) * ELSE * * SRPA for UPPER, TRANSPOSE, and N is odd * T1 -> a(0+N2*N2), T2 -> a(0+N1*N2), S -> a(0) * CALL DLAUUM( 'U', N1, A( N2*N2 ), N2, INFO ) CALL DSYRK( 'U', 'T', N1, N2, ONE, A( 0 ), N2, ONE, $ A( N2*N2 ), N2 ) CALL DTRMM( 'L', 'L', 'T', 'N', N2, N1, ONE, A( N1*N2 ), $ N2, A( 0 ), N2 ) CALL DLAUUM( 'L', N2, A( N1*N2 ), N2, INFO ) * END IF * END IF * ELSE * * N is even * IF( NORMALTRANSR ) THEN * * N is even and TRANSR = 'N' * IF( LOWER ) THEN * * SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) * T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) * T1 -> a(1), T2 -> a(0), S -> a(k+1) * CALL DLAUUM( 'L', K, A( 1 ), N+1, INFO ) CALL DSYRK( 'L', 'T', K, K, ONE, A( K+1 ), N+1, ONE, $ A( 1 ), N+1 ) CALL DTRMM( 'L', 'U', 'N', 'N', K, K, ONE, A( 0 ), N+1, $ A( K+1 ), N+1 ) CALL DLAUUM( 'U', K, A( 0 ), N+1, INFO ) * ELSE * * SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) * T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) * T1 -> a(k+1), T2 -> a(k), S -> a(0) * CALL DLAUUM( 'L', K, A( K+1 ), N+1, INFO ) CALL DSYRK( 'L', 'N', K, K, ONE, A( 0 ), N+1, ONE, $ A( K+1 ), N+1 ) CALL DTRMM( 'R', 'U', 'T', 'N', K, K, ONE, A( K ), N+1, $ A( 0 ), N+1 ) CALL DLAUUM( 'U', K, A( K ), N+1, INFO ) * END IF * ELSE * * N is even and TRANSR = 'T' * IF( LOWER ) THEN * * SRPA for LOWER, TRANSPOSE, and N is even (see paper) * T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1), * T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k * CALL DLAUUM( 'U', K, A( K ), K, INFO ) CALL DSYRK( 'U', 'N', K, K, ONE, A( K*( K+1 ) ), K, ONE, $ A( K ), K ) CALL DTRMM( 'R', 'L', 'N', 'N', K, K, ONE, A( 0 ), K, $ A( K*( K+1 ) ), K ) CALL DLAUUM( 'L', K, A( 0 ), K, INFO ) * ELSE * * SRPA for UPPER, TRANSPOSE, and N is even (see paper) * T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0), * T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k * CALL DLAUUM( 'U', K, A( K*( K+1 ) ), K, INFO ) CALL DSYRK( 'U', 'T', K, K, ONE, A( 0 ), K, ONE, $ A( K*( K+1 ) ), K ) CALL DTRMM( 'L', 'L', 'T', 'N', K, K, ONE, A( K*K ), K, $ A( 0 ), K ) CALL DLAUUM( 'L', K, A( K*K ), K, INFO ) * END IF * END IF * END IF * RETURN * * End of DPFTRI * END *> \brief \b DPFTRS * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPFTRS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO ) * * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. * DOUBLE PRECISION A( 0: * ), B( LDB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPFTRS solves a system of linear equations A*X = B with a symmetric *> positive definite matrix A using the Cholesky factorization *> A = U**T*U or A = L*L**T computed by DPFTRF. *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANSR *> \verbatim *> TRANSR is CHARACTER*1 *> = 'N': The Normal TRANSR of RFP A is stored; *> = 'T': The Transpose TRANSR of RFP A is stored. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of RFP A is stored; *> = 'L': Lower triangle of RFP A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrix B. NRHS >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension ( N*(N+1)/2 ). *> The triangular factor U or L from the Cholesky factorization *> of RFP A = U**T*U or RFP A = L*L**T, as computed by DPFTRF. *> See note below for more details about RFP A. *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> On entry, the right hand side matrix B. *> On exit, the solution matrix X. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> We first consider Rectangular Full Packed (RFP) Format when N is *> even. We give an example where N = 6. *> *> AP is Upper AP is Lower *> *> 00 01 02 03 04 05 00 *> 11 12 13 14 15 10 11 *> 22 23 24 25 20 21 22 *> 33 34 35 30 31 32 33 *> 44 45 40 41 42 43 44 *> 55 50 51 52 53 54 55 *> *> *> Let TRANSR = 'N'. RFP holds AP as follows: *> For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last *> three columns of AP upper. The lower triangle A(4:6,0:2) consists of *> the transpose of the first three columns of AP upper. *> For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first *> three columns of AP lower. The upper triangle A(0:2,0:2) consists of *> the transpose of the last three columns of AP lower. *> This covers the case N even and TRANSR = 'N'. *> *> RFP A RFP A *> *> 03 04 05 33 43 53 *> 13 14 15 00 44 54 *> 23 24 25 10 11 55 *> 33 34 35 20 21 22 *> 00 44 45 30 31 32 *> 01 11 55 40 41 42 *> 02 12 22 50 51 52 *> *> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the *> transpose of RFP A above. One therefore gets: *> *> *> RFP A RFP A *> *> 03 13 23 33 00 01 02 33 00 10 20 30 40 50 *> 04 14 24 34 44 11 12 43 44 11 21 31 41 51 *> 05 15 25 35 45 55 22 53 54 55 22 32 42 52 *> *> *> We then consider Rectangular Full Packed (RFP) Format when N is *> odd. We give an example where N = 5. *> *> AP is Upper AP is Lower *> *> 00 01 02 03 04 00 *> 11 12 13 14 10 11 *> 22 23 24 20 21 22 *> 33 34 30 31 32 33 *> 44 40 41 42 43 44 *> *> *> Let TRANSR = 'N'. RFP holds AP as follows: *> For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last *> three columns of AP upper. The lower triangle A(3:4,0:1) consists of *> the transpose of the first two columns of AP upper. *> For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first *> three columns of AP lower. The upper triangle A(0:1,1:2) consists of *> the transpose of the last two columns of AP lower. *> This covers the case N odd and TRANSR = 'N'. *> *> RFP A RFP A *> *> 02 03 04 00 33 43 *> 12 13 14 10 11 44 *> 22 23 24 20 21 22 *> 00 33 34 30 31 32 *> 01 11 44 40 41 42 *> *> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the *> transpose of RFP A above. One therefore gets: *> *> RFP A RFP A *> *> 02 12 22 00 01 00 10 20 30 40 50 *> 03 13 23 33 11 33 11 21 31 41 51 *> 04 14 24 34 44 43 44 22 32 42 52 *> \endverbatim *> * ===================================================================== SUBROUTINE DPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. DOUBLE PRECISION A( 0: * ), B( LDB, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LOWER, NORMALTRANSR * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, DTFSM * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 NORMALTRANSR = LSAME( TRANSR, 'N' ) LOWER = LSAME( UPLO, 'L' ) IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN INFO = -1 ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) 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 = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPFTRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * * start execution: there are two triangular solves * IF( LOWER ) THEN CALL DTFSM( TRANSR, 'L', UPLO, 'N', 'N', N, NRHS, ONE, A, B, $ LDB ) CALL DTFSM( TRANSR, 'L', UPLO, 'T', 'N', N, NRHS, ONE, A, B, $ LDB ) ELSE CALL DTFSM( TRANSR, 'L', UPLO, 'T', 'N', N, NRHS, ONE, A, B, $ LDB ) CALL DTFSM( TRANSR, 'L', UPLO, 'N', 'N', N, NRHS, ONE, A, B, $ LDB ) END IF * RETURN * * End of DPFTRS * END *> \brief \b DPOCON * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPOCON + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK, * INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N * DOUBLE PRECISION ANORM, RCOND * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPOCON estimates the reciprocal of the condition number (in the *> 1-norm) of a real symmetric positive definite matrix using the *> Cholesky factorization A = U**T*U or A = L*L**T computed by DPOTRF. *> *> An estimate is obtained for norm(inv(A)), and the reciprocal of the *> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The triangular factor U or L from the Cholesky factorization *> A = U**T*U or A = L*L**T, as computed by DPOTRF. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in] ANORM *> \verbatim *> ANORM is DOUBLE PRECISION *> The 1-norm (or infinity-norm) of the symmetric matrix A. *> \endverbatim *> *> \param[out] RCOND *> \verbatim *> RCOND is 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. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doublePOcomputational * * ===================================================================== SUBROUTINE DPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK, $ INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, N DOUBLE PRECISION ANORM, RCOND * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER CHARACTER NORMIN INTEGER IX, KASE DOUBLE PRECISION AINVNM, SCALE, SCALEL, SCALEU, SMLNUM * .. * .. 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 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( ANORM.LT.ZERO ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPOCON', -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 1-norm of inv(A). * KASE = 0 NORMIN = 'N' 10 CONTINUE CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( UPPER ) THEN * * Multiply by inv(U**T). * CALL DLATRS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, A, $ LDA, WORK, SCALEL, WORK( 2*N+1 ), INFO ) NORMIN = 'Y' * * Multiply by inv(U). * CALL DLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, $ A, LDA, WORK, SCALEU, WORK( 2*N+1 ), INFO ) ELSE * * Multiply by inv(L). * CALL DLATRS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N, $ A, LDA, WORK, SCALEL, WORK( 2*N+1 ), INFO ) NORMIN = 'Y' * * Multiply by inv(L**T). * CALL DLATRS( 'Lower', 'Transpose', 'Non-unit', NORMIN, N, A, $ LDA, WORK, SCALEU, WORK( 2*N+1 ), INFO ) END IF * * Multiply by 1/SCALE if doing so will not cause overflow. * SCALE = SCALEL*SCALEU 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 DPOCON * END *> \brief \b DPOEQU * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPOEQU + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPOEQU( N, A, LDA, S, SCOND, AMAX, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, N * DOUBLE PRECISION AMAX, SCOND * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), S( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPOEQU computes row and column scalings intended to equilibrate a *> symmetric positive definite matrix A and reduce its condition number *> (with respect to the two-norm). S contains the scale factors, *> S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with *> elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This *> choice of S puts the condition number of B within a factor N of the *> smallest possible condition number over all possible diagonal *> scalings. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The N-by-N symmetric positive definite matrix whose scaling *> factors are to be computed. Only the diagonal elements of A *> are referenced. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] S *> \verbatim *> S is DOUBLE PRECISION array, dimension (N) *> If INFO = 0, S contains the scale factors for A. *> \endverbatim *> *> \param[out] SCOND *> \verbatim *> SCOND is DOUBLE PRECISION *> If INFO = 0, S contains the ratio of the smallest S(i) to *> the largest S(i). If SCOND >= 0.1 and AMAX is neither too *> large nor too small, it is not worth scaling by S. *> \endverbatim *> *> \param[out] AMAX *> \verbatim *> AMAX is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, the i-th diagonal element is nonpositive. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doublePOcomputational * * ===================================================================== SUBROUTINE DPOEQU( N, A, LDA, S, SCOND, AMAX, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, N DOUBLE PRECISION AMAX, SCOND * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), S( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I DOUBLE PRECISION SMIN * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -3 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPOEQU', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN SCOND = ONE AMAX = ZERO RETURN END IF * * Find the minimum and maximum diagonal elements. * S( 1 ) = A( 1, 1 ) SMIN = S( 1 ) AMAX = S( 1 ) DO 10 I = 2, N S( I ) = A( I, I ) SMIN = MIN( SMIN, S( I ) ) AMAX = MAX( AMAX, S( I ) ) 10 CONTINUE * IF( SMIN.LE.ZERO ) THEN * * Find the first non-positive diagonal element and return. * DO 20 I = 1, N IF( S( I ).LE.ZERO ) THEN INFO = I RETURN END IF 20 CONTINUE ELSE * * Set the scale factors to the reciprocals * of the diagonal elements. * DO 30 I = 1, N S( I ) = ONE / SQRT( S( I ) ) 30 CONTINUE * * Compute SCOND = min(S(I)) / max(S(I)) * SCOND = SQRT( SMIN ) / SQRT( AMAX ) END IF RETURN * * End of DPOEQU * END *> \brief \b DPOEQUB * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPOEQUB + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, N * DOUBLE PRECISION AMAX, SCOND * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), S( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPOEQUB computes row and column scalings intended to equilibrate a *> symmetric positive definite matrix A and reduce its condition number *> (with respect to the two-norm). S contains the scale factors, *> S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with *> elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This *> choice of S puts the condition number of B within a factor N of the *> smallest possible condition number over all possible diagonal *> scalings. *> *> This routine differs from DPOEQU by restricting the scaling factors *> to a power of the radix. Barring over- and underflow, scaling by *> these factors introduces no additional rounding errors. However, the *> scaled diagonal entries are no longer approximately 1 but lie *> between sqrt(radix) and 1/sqrt(radix). *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The N-by-N symmetric positive definite matrix whose scaling *> factors are to be computed. Only the diagonal elements of A *> are referenced. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] S *> \verbatim *> S is DOUBLE PRECISION array, dimension (N) *> If INFO = 0, S contains the scale factors for A. *> \endverbatim *> *> \param[out] SCOND *> \verbatim *> SCOND is DOUBLE PRECISION *> If INFO = 0, S contains the ratio of the smallest S(i) to *> the largest S(i). If SCOND >= 0.1 and AMAX is neither too *> large nor too small, it is not worth scaling by S. *> \endverbatim *> *> \param[out] AMAX *> \verbatim *> AMAX is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, the i-th diagonal element is nonpositive. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doublePOcomputational * * ===================================================================== SUBROUTINE DPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, N DOUBLE PRECISION AMAX, SCOND * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), S( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I DOUBLE PRECISION SMIN, BASE, TMP * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT, LOG, INT * .. * .. Executable Statements .. * * Test the input parameters. * * Positive definite only performs 1 pass of equilibration. * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -3 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPOEQUB', -INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) THEN SCOND = ONE AMAX = ZERO RETURN END IF BASE = DLAMCH( 'B' ) TMP = -0.5D+0 / LOG ( BASE ) * * Find the minimum and maximum diagonal elements. * S( 1 ) = A( 1, 1 ) SMIN = S( 1 ) AMAX = S( 1 ) DO 10 I = 2, N S( I ) = A( I, I ) SMIN = MIN( SMIN, S( I ) ) AMAX = MAX( AMAX, S( I ) ) 10 CONTINUE * IF( SMIN.LE.ZERO ) THEN * * Find the first non-positive diagonal element and return. * DO 20 I = 1, N IF( S( I ).LE.ZERO ) THEN INFO = I RETURN END IF 20 CONTINUE ELSE * * Set the scale factors to the reciprocals * of the diagonal elements. * DO 30 I = 1, N S( I ) = BASE ** INT( TMP * LOG( S( I ) ) ) 30 CONTINUE * * Compute SCOND = min(S(I)) / max(S(I)). * SCOND = SQRT( SMIN ) / SQRT( AMAX ) END IF * RETURN * * End of DPOEQUB * END *> \brief \b DPORFS * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPORFS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, * LDX, FERR, BERR, WORK, IWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), * $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPORFS improves the computed solution to a system of linear *> equations when the coefficient matrix is symmetric positive definite, *> and provides error bounds and backward error estimates for the *> solution. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrices B and X. NRHS >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The symmetric matrix A. If UPLO = 'U', the leading N-by-N *> upper triangular part of A contains the upper triangular part *> of the matrix A, and the strictly lower triangular part of A *> is not referenced. If UPLO = 'L', the leading N-by-N lower *> triangular part of A contains the lower triangular part of *> the matrix A, and the strictly upper triangular part of A is *> not referenced. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in] AF *> \verbatim *> AF is DOUBLE PRECISION array, dimension (LDAF,N) *> The triangular factor U or L from the Cholesky factorization *> A = U**T*U or A = L*L**T, as computed by DPOTRF. *> \endverbatim *> *> \param[in] LDAF *> \verbatim *> LDAF is INTEGER *> The leading dimension of the array AF. LDAF >= max(1,N). *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> The right hand side matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,NRHS) *> On entry, the solution matrix X, as computed by DPOTRS. *> On exit, the improved solution matrix X. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the array X. LDX >= max(1,N). *> \endverbatim *> *> \param[out] FERR *> \verbatim *> FERR is 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. *> \endverbatim *> *> \param[out] BERR *> \verbatim *> BERR is 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). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * *> \par Internal Parameters: * ========================= *> *> \verbatim *> ITMAX is the maximum number of steps of iterative refinement. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doublePOcomputational * * ===================================================================== SUBROUTINE DPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, $ LDX, FERR, BERR, WORK, IWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) * .. * * ===================================================================== * * .. 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 UPPER 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, DLACN2, DPOTRS, DSYMV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL LSAME, DLAMCH * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( 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 = -9 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -11 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPORFS', -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 * * 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 - A * X * CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 ) CALL DSYMV( UPLO, 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(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(A)*abs(X) + abs(B). * IF( UPPER ) THEN DO 50 K = 1, N S = ZERO XK = ABS( X( K, J ) ) DO 40 I = 1, K - 1 WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK S = S + ABS( A( I, K ) )*ABS( X( I, J ) ) 40 CONTINUE WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK + S 50 CONTINUE ELSE DO 70 K = 1, N S = ZERO XK = ABS( X( K, J ) ) WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK DO 60 I = K + 1, N WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK 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 DPOTRS( UPLO, N, 1, AF, LDAF, 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(A))* * ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) * * where * norm(Z) is the magnitude of the largest component of Z * inv(A) is the inverse of 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(A)*abs(X)+abs(B)) * is incremented by SAFE1 if the i-th component of * abs(A)*abs(X) + abs(B) is less than SAFE2. * * Use DLACN2 to estimate the infinity-norm of the matrix * inv(A) * diag(W), * where W = abs(R) + NZ*EPS*( abs(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(A**T). * CALL DPOTRS( UPLO, N, 1, AF, LDAF, WORK( N+1 ), N, INFO ) DO 110 I = 1, N WORK( N+I ) = WORK( I )*WORK( N+I ) 110 CONTINUE ELSE IF( KASE.EQ.2 ) THEN * * Multiply by inv(A)*diag(W). * DO 120 I = 1, N WORK( N+I ) = WORK( I )*WORK( N+I ) 120 CONTINUE CALL DPOTRS( UPLO, N, 1, AF, LDAF, 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 DPORFS * END *> \brief DPOSV computes the solution to system of linear equations A * X = B for PO matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPOSV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, N, NRHS * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPOSV computes the solution to a real system of linear equations *> A * X = B, *> where A is an N-by-N symmetric positive definite matrix and X and B *> are N-by-NRHS matrices. *> *> The Cholesky decomposition is used to factor A as *> A = U**T* U, if UPLO = 'U', or *> A = L * L**T, if UPLO = 'L', *> where U is an upper triangular matrix and L is a lower triangular *> matrix. The factored form of A is then used to solve the system of *> equations A * X = B. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of linear equations, i.e., the order of the *> matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrix B. NRHS >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the symmetric matrix A. If UPLO = 'U', the leading *> N-by-N upper triangular part of A contains the upper *> triangular part of the matrix A, and the strictly lower *> triangular part of A is not referenced. If UPLO = 'L', the *> leading N-by-N lower triangular part of A contains the lower *> triangular part of the matrix A, and the strictly upper *> triangular part of A is not referenced. *> *> On exit, if INFO = 0, the factor U or L from the Cholesky *> factorization A = U**T*U or A = L*L**T. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> On entry, the N-by-NRHS right hand side matrix B. *> On exit, if INFO = 0, the N-by-NRHS solution matrix X. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, the leading minor of order i of A is not *> positive definite, so the factorization could not be *> completed, and the solution has not been computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doublePOsolve * * ===================================================================== SUBROUTINE DPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, LDB, N, NRHS * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * ===================================================================== * * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DPOTRF, DPOTRS, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) 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 = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPOSV ', -INFO ) RETURN END IF * * Compute the Cholesky factorization A = U**T*U or A = L*L**T. * CALL DPOTRF( UPLO, N, A, LDA, INFO ) IF( INFO.EQ.0 ) THEN * * Solve the system A*X = B, overwriting B with X. * CALL DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) * END IF RETURN * * End of DPOSV * END *> \brief DPOSVX computes the solution to system of linear equations A * X = B for PO matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPOSVX + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, * S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, * IWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER EQUED, FACT, UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS * DOUBLE PRECISION RCOND * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), * $ BERR( * ), FERR( * ), S( * ), WORK( * ), * $ X( LDX, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPOSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to *> compute the solution to a real system of linear equations *> A * X = B, *> where A is an N-by-N symmetric positive definite matrix and X and B *> are N-by-NRHS matrices. *> *> Error bounds on the solution and a condition estimate are also *> provided. *> \endverbatim * *> \par Description: * ================= *> *> \verbatim *> *> The following steps are performed: *> *> 1. If FACT = 'E', real scaling factors are computed to equilibrate *> the system: *> diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B *> Whether or not the system will be equilibrated depends on the *> scaling of the matrix A, but if equilibration is used, A is *> overwritten by diag(S)*A*diag(S) and B by diag(S)*B. *> *> 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to *> factor the matrix A (after equilibration if FACT = 'E') as *> A = U**T* U, if UPLO = 'U', or *> A = L * L**T, if UPLO = 'L', *> where U is an upper triangular matrix and L is a lower triangular *> matrix. *> *> 3. If the leading i-by-i principal minor is not positive definite, *> 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. *> *> 4. The system of equations is solved for X using the factored form *> of A. *> *> 5. Iterative refinement is applied to improve the computed solution *> matrix and calculate error bounds and backward error estimates *> for it. *> *> 6. If equilibration was used, the matrix X is premultiplied by *> diag(S) so that it solves the original system before *> equilibration. *> \endverbatim * * Arguments: * ========== * *> \param[in] FACT *> \verbatim *> FACT is CHARACTER*1 *> Specifies whether or not the factored form of the matrix A is *> supplied on entry, and if not, whether the matrix A should be *> equilibrated before it is factored. *> = 'F': On entry, AF contains the factored form of A. *> If EQUED = 'Y', the matrix A has been equilibrated *> with scaling factors given by S. A and AF will not *> be modified. *> = 'N': The matrix A will be copied to AF and factored. *> = 'E': The matrix A will be equilibrated if necessary, then *> copied to AF and factored. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of linear equations, i.e., the order of the *> matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrices B and X. NRHS >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the symmetric matrix A, except if FACT = 'F' and *> EQUED = 'Y', then A must contain the equilibrated matrix *> diag(S)*A*diag(S). If UPLO = 'U', the leading *> N-by-N upper triangular part of A contains the upper *> triangular part of the matrix A, and the strictly lower *> triangular part of A is not referenced. If UPLO = 'L', the *> leading N-by-N lower triangular part of A contains the lower *> triangular part of the matrix A, and the strictly upper *> triangular part of A is not referenced. A is not modified if *> FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit. *> *> On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by *> diag(S)*A*diag(S). *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] AF *> \verbatim *> AF is DOUBLE PRECISION array, dimension (LDAF,N) *> If FACT = 'F', then AF is an input argument and on entry *> contains the triangular factor U or L from the Cholesky *> factorization A = U**T*U or A = L*L**T, in the same storage *> format as A. If EQUED .ne. 'N', then AF is the factored form *> of the equilibrated matrix diag(S)*A*diag(S). *> *> If FACT = 'N', then AF is an output argument and on exit *> returns the triangular factor U or L from the Cholesky *> factorization A = U**T*U or A = L*L**T of the original *> matrix A. *> *> If FACT = 'E', then AF is an output argument and on exit *> returns the triangular factor U or L from the Cholesky *> factorization A = U**T*U or A = L*L**T of the equilibrated *> matrix A (see the description of A for the form of the *> equilibrated matrix). *> \endverbatim *> *> \param[in] LDAF *> \verbatim *> LDAF is INTEGER *> The leading dimension of the array AF. LDAF >= max(1,N). *> \endverbatim *> *> \param[in,out] EQUED *> \verbatim *> EQUED is CHARACTER*1 *> Specifies the form of equilibration that was done. *> = 'N': No equilibration (always true if FACT = 'N'). *> = 'Y': Equilibration was done, i.e., A has been replaced by *> diag(S) * A * diag(S). *> EQUED is an input argument if FACT = 'F'; otherwise, it is an *> output argument. *> \endverbatim *> *> \param[in,out] S *> \verbatim *> S is DOUBLE PRECISION array, dimension (N) *> The scale factors for A; not accessed if EQUED = 'N'. S is *> an input argument if FACT = 'F'; otherwise, S is an output *> argument. If FACT = 'F' and EQUED = 'Y', each element of S *> must be positive. *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> On entry, the N-by-NRHS right hand side matrix B. *> On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', *> B is overwritten by diag(S) * B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,NRHS) *> If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to *> the original system of equations. Note that if EQUED = 'Y', *> A and B are modified on exit, and the solution to the *> equilibrated system is inv(diag(S))*X. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the array X. LDX >= max(1,N). *> \endverbatim *> *> \param[out] RCOND *> \verbatim *> RCOND is DOUBLE PRECISION *> The estimate of the reciprocal condition number of the matrix *> A after equilibration (if done). 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. *> \endverbatim *> *> \param[out] FERR *> \verbatim *> FERR is 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. *> \endverbatim *> *> \param[out] BERR *> \verbatim *> BERR is 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). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, and i is *> <= N: the leading minor of order i of A is *> not positive definite, so the factorization *> could not be completed, and the solution has not *> been 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. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date April 2012 * *> \ingroup doublePOsolve * * ===================================================================== SUBROUTINE DPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, $ S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, $ IWORK, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * April 2012 * * .. Scalar Arguments .. CHARACTER EQUED, FACT, UPLO INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS DOUBLE PRECISION RCOND * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), $ BERR( * ), FERR( * ), S( * ), WORK( * ), $ X( LDX, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL EQUIL, NOFACT, RCEQU INTEGER I, INFEQU, J DOUBLE PRECISION AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANSY EXTERNAL LSAME, DLAMCH, DLANSY * .. * .. External Subroutines .. EXTERNAL DLACPY, DLAQSY, DPOCON, DPOEQU, DPORFS, DPOTRF, $ DPOTRS, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * INFO = 0 NOFACT = LSAME( FACT, 'N' ) EQUIL = LSAME( FACT, 'E' ) IF( NOFACT .OR. EQUIL ) THEN EQUED = 'N' RCEQU = .FALSE. ELSE RCEQU = LSAME( EQUED, 'Y' ) SMLNUM = DLAMCH( 'Safe minimum' ) BIGNUM = ONE / SMLNUM END IF * * Test the input parameters. * IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) ) $ THEN INFO = -1 ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) $ THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( NRHS.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. $ ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN INFO = -9 ELSE IF( RCEQU ) THEN SMIN = BIGNUM SMAX = ZERO DO 10 J = 1, N SMIN = MIN( SMIN, S( J ) ) SMAX = MAX( SMAX, S( J ) ) 10 CONTINUE IF( SMIN.LE.ZERO ) THEN INFO = -10 ELSE IF( N.GT.0 ) THEN SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM ) ELSE SCOND = ONE END IF END IF IF( INFO.EQ.0 ) THEN IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -12 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -14 END IF END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPOSVX', -INFO ) RETURN END IF * IF( EQUIL ) THEN * * Compute row and column scalings to equilibrate the matrix A. * CALL DPOEQU( N, A, LDA, S, SCOND, AMAX, INFEQU ) IF( INFEQU.EQ.0 ) THEN * * Equilibrate the matrix. * CALL DLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) RCEQU = LSAME( EQUED, 'Y' ) END IF END IF * * Scale the right hand side. * IF( RCEQU ) THEN DO 30 J = 1, NRHS DO 20 I = 1, N B( I, J ) = S( I )*B( I, J ) 20 CONTINUE 30 CONTINUE END IF * IF( NOFACT .OR. EQUIL ) THEN * * Compute the Cholesky factorization A = U**T *U or A = L*L**T. * CALL DLACPY( UPLO, N, N, A, LDA, AF, LDAF ) CALL DPOTRF( UPLO, N, AF, LDAF, 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. * ANORM = DLANSY( '1', UPLO, N, A, LDA, WORK ) * * Compute the reciprocal of the condition number of A. * CALL DPOCON( UPLO, N, AF, LDAF, ANORM, RCOND, WORK, IWORK, INFO ) * * Compute the solution matrix X. * CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) CALL DPOTRS( UPLO, N, NRHS, AF, LDAF, X, LDX, INFO ) * * Use iterative refinement to improve the computed solution and * compute error bounds and backward error estimates for it. * CALL DPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX, $ FERR, BERR, WORK, IWORK, INFO ) * * Transform the solution matrix X to a solution of the original * system. * IF( RCEQU ) THEN DO 50 J = 1, NRHS DO 40 I = 1, N X( I, J ) = S( I )*X( I, J ) 40 CONTINUE 50 CONTINUE DO 60 J = 1, NRHS FERR( J ) = FERR( J ) / SCOND 60 CONTINUE END IF * * Set INFO = N+1 if the matrix is singular to working precision. * IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) $ INFO = N + 1 * RETURN * * End of DPOSVX * END *> \brief \b DPOTF2 computes the Cholesky factorization of a symmetric/Hermitian positive definite matrix (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPOTF2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPOTF2 computes the Cholesky factorization of a real symmetric *> positive definite matrix A. *> *> The factorization has the form *> A = U**T * U , if UPLO = 'U', or *> A = L * L**T, if UPLO = 'L', *> where U is an upper triangular matrix and L is lower triangular. *> *> This is the unblocked version of the algorithm, calling Level 2 BLAS. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the upper or lower triangular part of the *> symmetric matrix A is stored. *> = 'U': Upper triangular *> = 'L': Lower triangular *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the symmetric matrix A. If UPLO = 'U', the leading *> n by n upper triangular part of A contains the upper *> triangular part of the matrix A, and the strictly lower *> triangular part of A is not referenced. If UPLO = 'L', the *> leading n by n lower triangular part of A contains the lower *> triangular part of the matrix A, and the strictly upper *> triangular part of A is not referenced. *> *> On exit, if INFO = 0, the factor U or L from the Cholesky *> factorization A = U**T *U or A = L*L**T. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -k, the k-th argument had an illegal value *> > 0: if INFO = k, the leading minor of order k is not *> positive definite, and the factorization could not be *> completed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doublePOcomputational * * ===================================================================== SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER J DOUBLE PRECISION AJJ * .. * .. External Functions .. LOGICAL LSAME, DISNAN DOUBLE PRECISION DDOT EXTERNAL LSAME, DDOT, DISNAN * .. * .. External Subroutines .. EXTERNAL DGEMV, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPOTF2', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( UPPER ) THEN * * Compute the Cholesky factorization A = U**T *U. * DO 10 J = 1, N * * Compute U(J,J) and test for non-positive-definiteness. * AJJ = A( J, J ) - DDOT( J-1, A( 1, J ), 1, A( 1, J ), 1 ) IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) THEN A( J, J ) = AJJ GO TO 30 END IF AJJ = SQRT( AJJ ) A( J, J ) = AJJ * * Compute elements J+1:N of row J. * IF( J.LT.N ) THEN CALL DGEMV( 'Transpose', J-1, N-J, -ONE, A( 1, J+1 ), $ LDA, A( 1, J ), 1, ONE, A( J, J+1 ), LDA ) CALL DSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA ) END IF 10 CONTINUE ELSE * * Compute the Cholesky factorization A = L*L**T. * DO 20 J = 1, N * * Compute L(J,J) and test for non-positive-definiteness. * AJJ = A( J, J ) - DDOT( J-1, A( J, 1 ), LDA, A( J, 1 ), $ LDA ) IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) THEN A( J, J ) = AJJ GO TO 30 END IF AJJ = SQRT( AJJ ) A( J, J ) = AJJ * * Compute elements J+1:N of column J. * IF( J.LT.N ) THEN CALL DGEMV( 'No transpose', N-J, J-1, -ONE, A( J+1, 1 ), $ LDA, A( J, 1 ), LDA, ONE, A( J+1, J ), 1 ) CALL DSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 ) END IF 20 CONTINUE END IF GO TO 40 * 30 CONTINUE INFO = J * 40 CONTINUE RETURN * * End of DPOTF2 * END *> \brief \b DPOTRF * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPOTRF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPOTRF computes the Cholesky factorization of a real symmetric *> positive definite matrix A. *> *> The factorization has the form *> A = U**T * U, if UPLO = 'U', or *> A = L * L**T, if UPLO = 'L', *> where U is an upper triangular matrix and L is lower triangular. *> *> This is the block version of the algorithm, calling Level 3 BLAS. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the symmetric matrix A. If UPLO = 'U', the leading *> N-by-N upper triangular part of A contains the upper *> triangular part of the matrix A, and the strictly lower *> triangular part of A is not referenced. If UPLO = 'L', the *> leading N-by-N lower triangular part of A contains the lower *> triangular part of the matrix A, and the strictly upper *> triangular part of A is not referenced. *> *> On exit, if INFO = 0, the factor U or L from the Cholesky *> factorization A = U**T*U or A = L*L**T. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, the leading minor of order i is not *> positive definite, and the factorization could not be *> completed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doublePOcomputational * * ===================================================================== SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER J, JB, NB * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DGEMM, DPOTRF2, DSYRK, DTRSM, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPOTRF', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Determine the block size for this environment. * NB = ILAENV( 1, 'DPOTRF', UPLO, N, -1, -1, -1 ) IF( NB.LE.1 .OR. NB.GE.N ) THEN * * Use unblocked code. * CALL DPOTRF2( UPLO, N, A, LDA, INFO ) ELSE * * Use blocked code. * IF( UPPER ) THEN * * Compute the Cholesky factorization A = U**T*U. * DO 10 J = 1, N, NB * * Update and factorize the current diagonal block and test * for non-positive-definiteness. * JB = MIN( NB, N-J+1 ) CALL DSYRK( 'Upper', 'Transpose', JB, J-1, -ONE, $ A( 1, J ), LDA, ONE, A( J, J ), LDA ) CALL DPOTRF2( 'Upper', JB, A( J, J ), LDA, INFO ) IF( INFO.NE.0 ) $ GO TO 30 IF( J+JB.LE.N ) THEN * * Compute the current block row. * CALL DGEMM( 'Transpose', 'No transpose', JB, N-J-JB+1, $ J-1, -ONE, A( 1, J ), LDA, A( 1, J+JB ), $ LDA, ONE, A( J, J+JB ), LDA ) CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', $ JB, N-J-JB+1, ONE, A( J, J ), LDA, $ A( J, J+JB ), LDA ) END IF 10 CONTINUE * ELSE * * Compute the Cholesky factorization A = L*L**T. * DO 20 J = 1, N, NB * * Update and factorize the current diagonal block and test * for non-positive-definiteness. * JB = MIN( NB, N-J+1 ) CALL DSYRK( 'Lower', 'No transpose', JB, J-1, -ONE, $ A( J, 1 ), LDA, ONE, A( J, J ), LDA ) CALL DPOTRF2( 'Lower', JB, A( J, J ), LDA, INFO ) IF( INFO.NE.0 ) $ GO TO 30 IF( J+JB.LE.N ) THEN * * Compute the current block column. * CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, $ J-1, -ONE, A( J+JB, 1 ), LDA, A( J, 1 ), $ LDA, ONE, A( J+JB, J ), LDA ) CALL DTRSM( 'Right', 'Lower', 'Transpose', 'Non-unit', $ N-J-JB+1, JB, ONE, A( J, J ), LDA, $ A( J+JB, J ), LDA ) END IF 20 CONTINUE END IF END IF GO TO 40 * 30 CONTINUE INFO = INFO + J - 1 * 40 CONTINUE RETURN * * End of DPOTRF * END *> \brief \b DPOTRF2 * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * RECURSIVE SUBROUTINE DPOTRF2( UPLO, N, A, LDA, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N * .. * .. Array Arguments .. * REAL A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPOTRF2 computes the Cholesky factorization of a real symmetric *> positive definite matrix A using the recursive algorithm. *> *> The factorization has the form *> A = U**T * U, if UPLO = 'U', or *> A = L * L**T, if UPLO = 'L', *> where U is an upper triangular matrix and L is lower triangular. *> *> This is the recursive version of the algorithm. It divides *> the matrix into four submatrices: *> *> [ A11 | A12 ] where A11 is n1 by n1 and A22 is n2 by n2 *> A = [ -----|----- ] with n1 = n/2 *> [ A21 | A22 ] n2 = n-n1 *> *> The subroutine calls itself to factor A11. Update and scale A21 *> or A12, update A22 then calls itself to factor A22. *> *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the symmetric matrix A. If UPLO = 'U', the leading *> N-by-N upper triangular part of A contains the upper *> triangular part of the matrix A, and the strictly lower *> triangular part of A is not referenced. If UPLO = 'L', the *> leading N-by-N lower triangular part of A contains the lower *> triangular part of the matrix A, and the strictly upper *> triangular part of A is not referenced. *> *> On exit, if INFO = 0, the factor U or L from the Cholesky *> factorization A = U**T*U or A = L*L**T. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, the leading minor of order i is not *> positive definite, and the factorization could not be *> completed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doublePOcomputational * * ===================================================================== RECURSIVE SUBROUTINE DPOTRF2( UPLO, N, A, LDA, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER N1, N2, IINFO * .. * .. External Functions .. LOGICAL LSAME, DISNAN EXTERNAL LSAME, DISNAN * .. * .. External Subroutines .. EXTERNAL DSYRK, DTRSM, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, SQRT * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPOTRF2', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * N=1 case * IF( N.EQ.1 ) THEN * * Test for non-positive-definiteness * IF( A( 1, 1 ).LE.ZERO.OR.DISNAN( A( 1, 1 ) ) ) THEN INFO = 1 RETURN END IF * * Factor * A( 1, 1 ) = SQRT( A( 1, 1 ) ) * * Use recursive code * ELSE N1 = N/2 N2 = N-N1 * * Factor A11 * CALL DPOTRF2( UPLO, N1, A( 1, 1 ), LDA, IINFO ) IF ( IINFO.NE.0 ) THEN INFO = IINFO RETURN END IF * * Compute the Cholesky factorization A = U**T*U * IF( UPPER ) THEN * * Update and scale A12 * CALL DTRSM( 'L', 'U', 'T', 'N', N1, N2, ONE, $ A( 1, 1 ), LDA, A( 1, N1+1 ), LDA ) * * Update and factor A22 * CALL DSYRK( UPLO, 'T', N2, N1, -ONE, A( 1, N1+1 ), LDA, $ ONE, A( N1+1, N1+1 ), LDA ) CALL DPOTRF2( UPLO, N2, A( N1+1, N1+1 ), LDA, IINFO ) IF ( IINFO.NE.0 ) THEN INFO = IINFO + N1 RETURN END IF * * Compute the Cholesky factorization A = L*L**T * ELSE * * Update and scale A21 * CALL DTRSM( 'R', 'L', 'T', 'N', N2, N1, ONE, $ A( 1, 1 ), LDA, A( N1+1, 1 ), LDA ) * * Update and factor A22 * CALL DSYRK( UPLO, 'N', N2, N1, -ONE, A( N1+1, 1 ), LDA, $ ONE, A( N1+1, N1+1 ), LDA ) CALL DPOTRF2( UPLO, N2, A( N1+1, N1+1 ), LDA, IINFO ) IF ( IINFO.NE.0 ) THEN INFO = IINFO + N1 RETURN END IF END IF END IF RETURN * * End of DPOTRF2 * END *> \brief \b DPOTRI * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPOTRI + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPOTRI( UPLO, N, A, LDA, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPOTRI computes the inverse of a real symmetric positive definite *> matrix A using the Cholesky factorization A = U**T*U or A = L*L**T *> computed by DPOTRF. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the triangular factor U or L from the Cholesky *> factorization A = U**T*U or A = L*L**T, as computed by *> DPOTRF. *> On exit, the upper or lower triangle of the (symmetric) *> inverse of A, overwriting the input factor U or L. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, the (i,i) element of the factor U or L is *> zero, and the inverse could not be computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doublePOcomputational * * ===================================================================== SUBROUTINE DPOTRI( UPLO, N, A, LDA, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) * .. * * ===================================================================== * * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLAUUM, DTRTRI, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPOTRI', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Invert the triangular Cholesky factor U or L. * CALL DTRTRI( UPLO, 'Non-unit', N, A, LDA, INFO ) IF( INFO.GT.0 ) $ RETURN * * Form inv(U) * inv(U)**T or inv(L)**T * inv(L). * CALL DLAUUM( UPLO, N, A, LDA, INFO ) * RETURN * * End of DPOTRI * END *> \brief \b DPOTRS * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPOTRS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, N, NRHS * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPOTRS solves a system of linear equations A*X = B with a symmetric *> positive definite matrix A using the Cholesky factorization *> A = U**T*U or A = L*L**T computed by DPOTRF. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrix B. NRHS >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The triangular factor U or L from the Cholesky factorization *> A = U**T*U or A = L*L**T, as computed by DPOTRF. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> On entry, the right hand side matrix B. *> On exit, the solution matrix X. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doublePOcomputational * * ===================================================================== SUBROUTINE DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, LDB, N, NRHS * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DTRSM, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( 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 = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPOTRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * IF( UPPER ) THEN * * Solve A*X = B where A = U**T *U. * * Solve U**T *X = B, overwriting B with X. * CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-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 where A = L*L**T. * * Solve L*X = B, overwriting B with X. * CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', N, $ NRHS, ONE, A, LDA, B, LDB ) * * Solve L**T *X = B, overwriting B with X. * CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Non-unit', N, NRHS, $ ONE, A, LDA, B, LDB ) END IF * RETURN * * End of DPOTRS * END *> \brief \b DPPCON * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPPCON + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPPCON( UPLO, N, AP, ANORM, RCOND, WORK, IWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N * DOUBLE PRECISION ANORM, RCOND * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION AP( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPPCON estimates the reciprocal of the condition number (in the *> 1-norm) of a real symmetric positive definite packed matrix using *> the Cholesky factorization A = U**T*U or A = L*L**T computed by *> DPPTRF. *> *> An estimate is obtained for norm(inv(A)), and the reciprocal of the *> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> The triangular factor U or L from the Cholesky factorization *> A = U**T*U or A = L*L**T, packed columnwise in a linear *> array. The j-th column of U or L is stored in the array AP *> as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. *> \endverbatim *> *> \param[in] ANORM *> \verbatim *> ANORM is DOUBLE PRECISION *> The 1-norm (or infinity-norm) of the symmetric matrix A. *> \endverbatim *> *> \param[out] RCOND *> \verbatim *> RCOND is 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. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DPPCON( UPLO, N, AP, ANORM, RCOND, WORK, IWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, N DOUBLE PRECISION ANORM, RCOND * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION AP( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER CHARACTER NORMIN INTEGER IX, KASE DOUBLE PRECISION AINVNM, SCALE, SCALEL, SCALEU, SMLNUM * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DLAMCH EXTERNAL LSAME, IDAMAX, DLAMCH * .. * .. External Subroutines .. EXTERNAL DLACN2, DLATPS, DRSCL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( ANORM.LT.ZERO ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPPCON', -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 1-norm of the inverse. * KASE = 0 NORMIN = 'N' 10 CONTINUE CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( UPPER ) THEN * * Multiply by inv(U**T). * CALL DLATPS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, $ AP, WORK, SCALEL, WORK( 2*N+1 ), INFO ) NORMIN = 'Y' * * Multiply by inv(U). * CALL DLATPS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, $ AP, WORK, SCALEU, WORK( 2*N+1 ), INFO ) ELSE * * Multiply by inv(L). * CALL DLATPS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N, $ AP, WORK, SCALEL, WORK( 2*N+1 ), INFO ) NORMIN = 'Y' * * Multiply by inv(L**T). * CALL DLATPS( 'Lower', 'Transpose', 'Non-unit', NORMIN, N, $ AP, WORK, SCALEU, WORK( 2*N+1 ), INFO ) END IF * * Multiply by 1/SCALE if doing so will not cause overflow. * SCALE = SCALEL*SCALEU 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 DPPCON * END *> \brief \b DPPEQU * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPPEQU + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N * DOUBLE PRECISION AMAX, SCOND * .. * .. Array Arguments .. * DOUBLE PRECISION AP( * ), S( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPPEQU computes row and column scalings intended to equilibrate a *> symmetric positive definite matrix A in packed storage and reduce *> its condition number (with respect to the two-norm). S contains the *> scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix *> B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal. *> This choice of S puts the condition number of B within a factor N of *> the smallest possible condition number over all possible diagonal *> scalings. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> The upper or lower triangle of the symmetric matrix A, packed *> columnwise in a linear array. The j-th column of A is stored *> in the array AP as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. *> \endverbatim *> *> \param[out] S *> \verbatim *> S is DOUBLE PRECISION array, dimension (N) *> If INFO = 0, S contains the scale factors for A. *> \endverbatim *> *> \param[out] SCOND *> \verbatim *> SCOND is DOUBLE PRECISION *> If INFO = 0, S contains the ratio of the smallest S(i) to *> the largest S(i). If SCOND >= 0.1 and AMAX is neither too *> large nor too small, it is not worth scaling by S. *> \endverbatim *> *> \param[out] AMAX *> \verbatim *> AMAX is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, the i-th diagonal element is nonpositive. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, N DOUBLE PRECISION AMAX, SCOND * .. * .. Array Arguments .. DOUBLE PRECISION AP( * ), S( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER I, JJ DOUBLE PRECISION SMIN * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPPEQU', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN SCOND = ONE AMAX = ZERO RETURN END IF * * Initialize SMIN and AMAX. * S( 1 ) = AP( 1 ) SMIN = S( 1 ) AMAX = S( 1 ) * IF( UPPER ) THEN * * UPLO = 'U': Upper triangle of A is stored. * Find the minimum and maximum diagonal elements. * JJ = 1 DO 10 I = 2, N JJ = JJ + I S( I ) = AP( JJ ) SMIN = MIN( SMIN, S( I ) ) AMAX = MAX( AMAX, S( I ) ) 10 CONTINUE * ELSE * * UPLO = 'L': Lower triangle of A is stored. * Find the minimum and maximum diagonal elements. * JJ = 1 DO 20 I = 2, N JJ = JJ + N - I + 2 S( I ) = AP( JJ ) SMIN = MIN( SMIN, S( I ) ) AMAX = MAX( AMAX, S( I ) ) 20 CONTINUE END IF * IF( SMIN.LE.ZERO ) THEN * * Find the first non-positive diagonal element and return. * DO 30 I = 1, N IF( S( I ).LE.ZERO ) THEN INFO = I RETURN END IF 30 CONTINUE ELSE * * Set the scale factors to the reciprocals * of the diagonal elements. * DO 40 I = 1, N S( I ) = ONE / SQRT( S( I ) ) 40 CONTINUE * * Compute SCOND = min(S(I)) / max(S(I)) * SCOND = SQRT( SMIN ) / SQRT( AMAX ) END IF RETURN * * End of DPPEQU * END *> \brief \b DPPRFS * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPPRFS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, * BERR, WORK, IWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, LDX, N, NRHS * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ), * $ FERR( * ), WORK( * ), X( LDX, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPPRFS improves the computed solution to a system of linear *> equations when the coefficient matrix is symmetric positive definite *> and packed, and provides error bounds and backward error estimates *> for the solution. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrices B and X. NRHS >= 0. *> \endverbatim *> *> \param[in] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> The upper or lower triangle of the symmetric matrix A, packed *> columnwise in a linear array. The j-th column of A is stored *> in the array AP as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. *> \endverbatim *> *> \param[in] AFP *> \verbatim *> AFP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> The triangular factor U or L from the Cholesky factorization *> A = U**T*U or A = L*L**T, as computed by DPPTRF/ZPPTRF, *> packed columnwise in a linear array in the same format as A *> (see AP). *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> The right hand side matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,NRHS) *> On entry, the solution matrix X, as computed by DPPTRS. *> On exit, the improved solution matrix X. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the array X. LDX >= max(1,N). *> \endverbatim *> *> \param[out] FERR *> \verbatim *> FERR is 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. *> \endverbatim *> *> \param[out] BERR *> \verbatim *> BERR is 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). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * *> \par Internal Parameters: * ========================= *> *> \verbatim *> ITMAX is the maximum number of steps of iterative refinement. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, $ BERR, WORK, IWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDB, LDX, N, NRHS * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ), $ FERR( * ), WORK( * ), X( LDX, * ) * .. * * ===================================================================== * * .. 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 UPPER INTEGER COUNT, I, IK, J, K, KASE, KK, NZ DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) * .. * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DLACN2, DPPTRS, DSPMV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL LSAME, DLAMCH * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( NRHS.LT.0 ) THEN INFO = -3 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPPRFS', -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 * * 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 - A * X * CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 ) CALL DSPMV( UPLO, N, -ONE, AP, X( 1, J ), 1, ONE, WORK( N+1 ), $ 1 ) * * Compute componentwise relative backward error from formula * * max(i) ( abs(R(i)) / ( abs(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(A)*abs(X) + abs(B). * KK = 1 IF( UPPER ) THEN DO 50 K = 1, N S = ZERO XK = ABS( X( K, J ) ) IK = KK DO 40 I = 1, K - 1 WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK S = S + ABS( AP( IK ) )*ABS( X( I, J ) ) IK = IK + 1 40 CONTINUE WORK( K ) = WORK( K ) + ABS( AP( KK+K-1 ) )*XK + S KK = KK + K 50 CONTINUE ELSE DO 70 K = 1, N S = ZERO XK = ABS( X( K, J ) ) WORK( K ) = WORK( K ) + ABS( AP( KK ) )*XK IK = KK + 1 DO 60 I = K + 1, N WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK S = S + ABS( AP( IK ) )*ABS( X( I, J ) ) IK = IK + 1 60 CONTINUE WORK( K ) = WORK( K ) + S KK = KK + ( N-K+1 ) 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 DPPTRS( UPLO, N, 1, AFP, 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(A))* * ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) * * where * norm(Z) is the magnitude of the largest component of Z * inv(A) is the inverse of 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(A)*abs(X)+abs(B)) * is incremented by SAFE1 if the i-th component of * abs(A)*abs(X) + abs(B) is less than SAFE2. * * Use DLACN2 to estimate the infinity-norm of the matrix * inv(A) * diag(W), * where W = abs(R) + NZ*EPS*( abs(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(A**T). * CALL DPPTRS( UPLO, N, 1, AFP, WORK( N+1 ), N, INFO ) DO 110 I = 1, N WORK( N+I ) = WORK( I )*WORK( N+I ) 110 CONTINUE ELSE IF( KASE.EQ.2 ) THEN * * Multiply by inv(A)*diag(W). * DO 120 I = 1, N WORK( N+I ) = WORK( I )*WORK( N+I ) 120 CONTINUE CALL DPPTRS( UPLO, N, 1, AFP, 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 DPPRFS * END *> \brief DPPSV computes the solution to system of linear equations A * X = B for OTHER matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPPSV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPPSV( UPLO, N, NRHS, AP, B, LDB, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. * DOUBLE PRECISION AP( * ), B( LDB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPPSV computes the solution to a real system of linear equations *> A * X = B, *> where A is an N-by-N symmetric positive definite matrix stored in *> packed format and X and B are N-by-NRHS matrices. *> *> The Cholesky decomposition is used to factor A as *> A = U**T* U, if UPLO = 'U', or *> A = L * L**T, if UPLO = 'L', *> where U is an upper triangular matrix and L is a lower triangular *> matrix. The factored form of A is then used to solve the system of *> equations A * X = B. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of linear equations, i.e., the order of the *> matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrix B. NRHS >= 0. *> \endverbatim *> *> \param[in,out] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> On entry, the upper or lower triangle of the symmetric matrix *> A, packed columnwise in a linear array. The j-th column of A *> is stored in the array AP as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. *> See below for further details. *> *> On exit, if INFO = 0, the factor U or L from the Cholesky *> factorization A = U**T*U or A = L*L**T, in the same storage *> format as A. *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> On entry, the N-by-NRHS right hand side matrix B. *> On exit, if INFO = 0, the N-by-NRHS solution matrix X. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, the leading minor of order i of A is not *> positive definite, so the factorization could not be *> completed, and the solution has not been computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERsolve * *> \par Further Details: * ===================== *> *> \verbatim *> *> The packed storage scheme is illustrated by the following example *> when N = 4, UPLO = 'U': *> *> Two-dimensional storage of the symmetric matrix A: *> *> a11 a12 a13 a14 *> a22 a23 a24 *> a33 a34 (aij = conjg(aji)) *> a44 *> *> Packed storage of the upper triangle of A: *> *> AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] *> \endverbatim *> * ===================================================================== SUBROUTINE DPPSV( UPLO, N, NRHS, AP, B, LDB, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. DOUBLE PRECISION AP( * ), B( LDB, * ) * .. * * ===================================================================== * * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DPPTRF, DPPTRS, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) 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 = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPPSV ', -INFO ) RETURN END IF * * Compute the Cholesky factorization A = U**T*U or A = L*L**T. * CALL DPPTRF( UPLO, N, AP, INFO ) IF( INFO.EQ.0 ) THEN * * Solve the system A*X = B, overwriting B with X. * CALL DPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO ) * END IF RETURN * * End of DPPSV * END *> \brief DPPSVX computes the solution to system of linear equations A * X = B for OTHER matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPPSVX + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, * X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER EQUED, FACT, UPLO * INTEGER INFO, LDB, LDX, N, NRHS * DOUBLE PRECISION RCOND * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ), * $ FERR( * ), S( * ), WORK( * ), X( LDX, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPPSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to *> compute the solution to a real system of linear equations *> A * X = B, *> where A is an N-by-N symmetric positive definite matrix stored in *> packed format and X and B are N-by-NRHS matrices. *> *> Error bounds on the solution and a condition estimate are also *> provided. *> \endverbatim * *> \par Description: * ================= *> *> \verbatim *> *> The following steps are performed: *> *> 1. If FACT = 'E', real scaling factors are computed to equilibrate *> the system: *> diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B *> Whether or not the system will be equilibrated depends on the *> scaling of the matrix A, but if equilibration is used, A is *> overwritten by diag(S)*A*diag(S) and B by diag(S)*B. *> *> 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to *> factor the matrix A (after equilibration if FACT = 'E') as *> A = U**T* U, if UPLO = 'U', or *> A = L * L**T, if UPLO = 'L', *> where U is an upper triangular matrix and L is a lower triangular *> matrix. *> *> 3. If the leading i-by-i principal minor is not positive definite, *> 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. *> *> 4. The system of equations is solved for X using the factored form *> of A. *> *> 5. Iterative refinement is applied to improve the computed solution *> matrix and calculate error bounds and backward error estimates *> for it. *> *> 6. If equilibration was used, the matrix X is premultiplied by *> diag(S) so that it solves the original system before *> equilibration. *> \endverbatim * * Arguments: * ========== * *> \param[in] FACT *> \verbatim *> FACT is CHARACTER*1 *> Specifies whether or not the factored form of the matrix A is *> supplied on entry, and if not, whether the matrix A should be *> equilibrated before it is factored. *> = 'F': On entry, AFP contains the factored form of A. *> If EQUED = 'Y', the matrix A has been equilibrated *> with scaling factors given by S. AP and AFP will not *> be modified. *> = 'N': The matrix A will be copied to AFP and factored. *> = 'E': The matrix A will be equilibrated if necessary, then *> copied to AFP and factored. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of linear equations, i.e., the order of the *> matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrices B and X. NRHS >= 0. *> \endverbatim *> *> \param[in,out] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> On entry, the upper or lower triangle of the symmetric matrix *> A, packed columnwise in a linear array, except if FACT = 'F' *> and EQUED = 'Y', then A must contain the equilibrated matrix *> diag(S)*A*diag(S). The j-th column of A is stored in the *> array AP as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. *> See below for further details. A is not modified if *> FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit. *> *> On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by *> diag(S)*A*diag(S). *> \endverbatim *> *> \param[in,out] AFP *> \verbatim *> AFP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> If FACT = 'F', then AFP is an input argument and on entry *> contains the triangular factor U or L from the Cholesky *> factorization A = U**T*U or A = L*L**T, in the same storage *> format as A. If EQUED .ne. 'N', then AFP is the factored *> form of the equilibrated matrix A. *> *> If FACT = 'N', then AFP is an output argument and on exit *> returns the triangular factor U or L from the Cholesky *> factorization A = U**T * U or A = L * L**T of the original *> matrix A. *> *> If FACT = 'E', then AFP is an output argument and on exit *> returns the triangular factor U or L from the Cholesky *> factorization A = U**T * U or A = L * L**T of the equilibrated *> matrix A (see the description of AP for the form of the *> equilibrated matrix). *> \endverbatim *> *> \param[in,out] EQUED *> \verbatim *> EQUED is CHARACTER*1 *> Specifies the form of equilibration that was done. *> = 'N': No equilibration (always true if FACT = 'N'). *> = 'Y': Equilibration was done, i.e., A has been replaced by *> diag(S) * A * diag(S). *> EQUED is an input argument if FACT = 'F'; otherwise, it is an *> output argument. *> \endverbatim *> *> \param[in,out] S *> \verbatim *> S is DOUBLE PRECISION array, dimension (N) *> The scale factors for A; not accessed if EQUED = 'N'. S is *> an input argument if FACT = 'F'; otherwise, S is an output *> argument. If FACT = 'F' and EQUED = 'Y', each element of S *> must be positive. *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> On entry, the N-by-NRHS right hand side matrix B. *> On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', *> B is overwritten by diag(S) * B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,NRHS) *> If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to *> the original system of equations. Note that if EQUED = 'Y', *> A and B are modified on exit, and the solution to the *> equilibrated system is inv(diag(S))*X. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the array X. LDX >= max(1,N). *> \endverbatim *> *> \param[out] RCOND *> \verbatim *> RCOND is DOUBLE PRECISION *> The estimate of the reciprocal condition number of the matrix *> A after equilibration (if done). 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. *> \endverbatim *> *> \param[out] FERR *> \verbatim *> FERR is 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. *> \endverbatim *> *> \param[out] BERR *> \verbatim *> BERR is 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). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, and i is *> <= N: the leading minor of order i of A is *> not positive definite, so the factorization *> could not be completed, and the solution has not *> been 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. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date April 2012 * *> \ingroup doubleOTHERsolve * *> \par Further Details: * ===================== *> *> \verbatim *> *> The packed storage scheme is illustrated by the following example *> when N = 4, UPLO = 'U': *> *> Two-dimensional storage of the symmetric matrix A: *> *> a11 a12 a13 a14 *> a22 a23 a24 *> a33 a34 (aij = conjg(aji)) *> a44 *> *> Packed storage of the upper triangle of A: *> *> AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] *> \endverbatim *> * ===================================================================== SUBROUTINE DPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, $ X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO ) * * -- LAPACK driver routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * April 2012 * * .. Scalar Arguments .. CHARACTER EQUED, FACT, UPLO INTEGER INFO, LDB, LDX, N, NRHS DOUBLE PRECISION RCOND * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ), $ FERR( * ), S( * ), WORK( * ), X( LDX, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL EQUIL, NOFACT, RCEQU INTEGER I, INFEQU, J DOUBLE PRECISION AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANSP EXTERNAL LSAME, DLAMCH, DLANSP * .. * .. External Subroutines .. EXTERNAL DCOPY, DLACPY, DLAQSP, DPPCON, DPPEQU, DPPRFS, $ DPPTRF, DPPTRS, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * INFO = 0 NOFACT = LSAME( FACT, 'N' ) EQUIL = LSAME( FACT, 'E' ) IF( NOFACT .OR. EQUIL ) THEN EQUED = 'N' RCEQU = .FALSE. ELSE RCEQU = LSAME( EQUED, 'Y' ) SMLNUM = DLAMCH( 'Safe minimum' ) BIGNUM = ONE / SMLNUM END IF * * Test the input parameters. * IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) ) $ THEN INFO = -1 ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) $ THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( NRHS.LT.0 ) THEN INFO = -4 ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. $ ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN INFO = -7 ELSE IF( RCEQU ) THEN SMIN = BIGNUM SMAX = ZERO DO 10 J = 1, N SMIN = MIN( SMIN, S( J ) ) SMAX = MAX( SMAX, S( J ) ) 10 CONTINUE IF( SMIN.LE.ZERO ) THEN INFO = -8 ELSE IF( N.GT.0 ) THEN SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM ) ELSE SCOND = ONE END IF END IF IF( INFO.EQ.0 ) THEN IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -10 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -12 END IF END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPPSVX', -INFO ) RETURN END IF * IF( EQUIL ) THEN * * Compute row and column scalings to equilibrate the matrix A. * CALL DPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFEQU ) IF( INFEQU.EQ.0 ) THEN * * Equilibrate the matrix. * CALL DLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED ) RCEQU = LSAME( EQUED, 'Y' ) END IF END IF * * Scale the right-hand side. * IF( RCEQU ) THEN DO 30 J = 1, NRHS DO 20 I = 1, N B( I, J ) = S( I )*B( I, J ) 20 CONTINUE 30 CONTINUE END IF * IF( NOFACT .OR. EQUIL ) THEN * * Compute the Cholesky factorization A = U**T * U or A = L * L**T. * CALL DCOPY( N*( N+1 ) / 2, AP, 1, AFP, 1 ) CALL DPPTRF( UPLO, N, AFP, 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. * ANORM = DLANSP( 'I', UPLO, N, AP, WORK ) * * Compute the reciprocal of the condition number of A. * CALL DPPCON( UPLO, N, AFP, ANORM, RCOND, WORK, IWORK, INFO ) * * Compute the solution matrix X. * CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) CALL DPPTRS( UPLO, N, NRHS, AFP, X, LDX, INFO ) * * Use iterative refinement to improve the computed solution and * compute error bounds and backward error estimates for it. * CALL DPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, $ WORK, IWORK, INFO ) * * Transform the solution matrix X to a solution of the original * system. * IF( RCEQU ) THEN DO 50 J = 1, NRHS DO 40 I = 1, N X( I, J ) = S( I )*X( I, J ) 40 CONTINUE 50 CONTINUE DO 60 J = 1, NRHS FERR( J ) = FERR( J ) / SCOND 60 CONTINUE END IF * * Set INFO = N+1 if the matrix is singular to working precision. * IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) $ INFO = N + 1 * RETURN * * End of DPPSVX * END *> \brief \b DPPTRF * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPPTRF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPPTRF( UPLO, N, AP, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N * .. * .. Array Arguments .. * DOUBLE PRECISION AP( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPPTRF computes the Cholesky factorization of a real symmetric *> positive definite matrix A stored in packed format. *> *> The factorization has the form *> A = U**T * U, if UPLO = 'U', or *> A = L * L**T, if UPLO = 'L', *> where U is an upper triangular matrix and L is lower triangular. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> On entry, the upper or lower triangle of the symmetric matrix *> A, packed columnwise in a linear array. The j-th column of A *> is stored in the array AP as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. *> See below for further details. *> *> On exit, if INFO = 0, the triangular factor U or L from the *> Cholesky factorization A = U**T*U or A = L*L**T, in the same *> storage format as A. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, the leading minor of order i is not *> positive definite, and the factorization could not be *> completed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The packed storage scheme is illustrated by the following example *> when N = 4, UPLO = 'U': *> *> Two-dimensional storage of the symmetric matrix A: *> *> a11 a12 a13 a14 *> a22 a23 a24 *> a33 a34 (aij = aji) *> a44 *> *> Packed storage of the upper triangle of A: *> *> AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] *> \endverbatim *> * ===================================================================== SUBROUTINE DPPTRF( UPLO, N, AP, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, N * .. * .. Array Arguments .. DOUBLE PRECISION AP( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER J, JC, JJ DOUBLE PRECISION AJJ * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT EXTERNAL LSAME, DDOT * .. * .. External Subroutines .. EXTERNAL DSCAL, DSPR, DTPSV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPPTRF', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( UPPER ) THEN * * Compute the Cholesky factorization A = U**T*U. * JJ = 0 DO 10 J = 1, N JC = JJ + 1 JJ = JJ + J * * Compute elements 1:J-1 of column J. * IF( J.GT.1 ) $ CALL DTPSV( 'Upper', 'Transpose', 'Non-unit', J-1, AP, $ AP( JC ), 1 ) * * Compute U(J,J) and test for non-positive-definiteness. * AJJ = AP( JJ ) - DDOT( J-1, AP( JC ), 1, AP( JC ), 1 ) IF( AJJ.LE.ZERO ) THEN AP( JJ ) = AJJ GO TO 30 END IF AP( JJ ) = SQRT( AJJ ) 10 CONTINUE ELSE * * Compute the Cholesky factorization A = L*L**T. * JJ = 1 DO 20 J = 1, N * * Compute L(J,J) and test for non-positive-definiteness. * AJJ = AP( JJ ) IF( AJJ.LE.ZERO ) THEN AP( JJ ) = AJJ GO TO 30 END IF AJJ = SQRT( AJJ ) AP( JJ ) = AJJ * * Compute elements J+1:N of column J and update the trailing * submatrix. * IF( J.LT.N ) THEN CALL DSCAL( N-J, ONE / AJJ, AP( JJ+1 ), 1 ) CALL DSPR( 'Lower', N-J, -ONE, AP( JJ+1 ), 1, $ AP( JJ+N-J+1 ) ) JJ = JJ + N - J + 1 END IF 20 CONTINUE END IF GO TO 40 * 30 CONTINUE INFO = J * 40 CONTINUE RETURN * * End of DPPTRF * END *> \brief \b DPPTRI * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPPTRI + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPPTRI( UPLO, N, AP, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N * .. * .. Array Arguments .. * DOUBLE PRECISION AP( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPPTRI computes the inverse of a real symmetric positive definite *> matrix A using the Cholesky factorization A = U**T*U or A = L*L**T *> computed by DPPTRF. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangular factor is stored in AP; *> = 'L': Lower triangular factor is stored in AP. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> On entry, the triangular factor U or L from the Cholesky *> factorization A = U**T*U or A = L*L**T, packed columnwise as *> a linear array. The j-th column of U or L is stored in the *> array AP as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. *> *> On exit, the upper or lower triangle of the (symmetric) *> inverse of A, overwriting the input factor U or L. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, the (i,i) element of the factor U or L is *> zero, and the inverse could not be computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DPPTRI( UPLO, N, AP, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, N * .. * .. Array Arguments .. DOUBLE PRECISION AP( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER J, JC, JJ, JJN DOUBLE PRECISION AJJ * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT EXTERNAL LSAME, DDOT * .. * .. External Subroutines .. EXTERNAL DSCAL, DSPR, DTPMV, DTPTRI, XERBLA * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPPTRI', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Invert the triangular Cholesky factor U or L. * CALL DTPTRI( UPLO, 'Non-unit', N, AP, INFO ) IF( INFO.GT.0 ) $ RETURN * IF( UPPER ) THEN * * Compute the product inv(U) * inv(U)**T. * JJ = 0 DO 10 J = 1, N JC = JJ + 1 JJ = JJ + J IF( J.GT.1 ) $ CALL DSPR( 'Upper', J-1, ONE, AP( JC ), 1, AP ) AJJ = AP( JJ ) CALL DSCAL( J, AJJ, AP( JC ), 1 ) 10 CONTINUE * ELSE * * Compute the product inv(L)**T * inv(L). * JJ = 1 DO 20 J = 1, N JJN = JJ + N - J + 1 AP( JJ ) = DDOT( N-J+1, AP( JJ ), 1, AP( JJ ), 1 ) IF( J.LT.N ) $ CALL DTPMV( 'Lower', 'Transpose', 'Non-unit', N-J, $ AP( JJN ), AP( JJ+1 ), 1 ) JJ = JJN 20 CONTINUE END IF * RETURN * * End of DPPTRI * END *> \brief \b DPPTRS * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPPTRS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. * DOUBLE PRECISION AP( * ), B( LDB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPPTRS solves a system of linear equations A*X = B with a symmetric *> positive definite matrix A in packed storage using the Cholesky *> factorization A = U**T*U or A = L*L**T computed by DPPTRF. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrix B. NRHS >= 0. *> \endverbatim *> *> \param[in] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> The triangular factor U or L from the Cholesky factorization *> A = U**T*U or A = L*L**T, packed columnwise in a linear *> array. The j-th column of U or L is stored in the array AP *> as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> On entry, the right hand side matrix B. *> On exit, the solution matrix X. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. DOUBLE PRECISION AP( * ), B( LDB, * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL UPPER INTEGER I * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DTPSV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( NRHS.LT.0 ) THEN INFO = -3 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPPTRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * IF( UPPER ) THEN * * Solve A*X = B where A = U**T * U. * DO 10 I = 1, NRHS * * Solve U**T *X = B, overwriting B with X. * CALL DTPSV( 'Upper', 'Transpose', 'Non-unit', N, AP, $ B( 1, I ), 1 ) * * Solve U*X = B, overwriting B with X. * CALL DTPSV( 'Upper', 'No transpose', 'Non-unit', N, AP, $ B( 1, I ), 1 ) 10 CONTINUE ELSE * * Solve A*X = B where A = L * L**T. * DO 20 I = 1, NRHS * * Solve L*Y = B, overwriting B with X. * CALL DTPSV( 'Lower', 'No transpose', 'Non-unit', N, AP, $ B( 1, I ), 1 ) * * Solve L**T *X = Y, overwriting B with X. * CALL DTPSV( 'Lower', 'Transpose', 'Non-unit', N, AP, $ B( 1, I ), 1 ) 20 CONTINUE END IF * RETURN * * End of DPPTRS * END *> \brief \b DPSTF2 computes the Cholesky factorization with complete pivoting of a real symmetric positive semidefinite matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPSTF2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) * * .. Scalar Arguments .. * DOUBLE PRECISION TOL * INTEGER INFO, LDA, N, RANK * CHARACTER UPLO * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), WORK( 2*N ) * INTEGER PIV( N ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPSTF2 computes the Cholesky factorization with complete *> pivoting of a real symmetric positive semidefinite matrix A. *> *> The factorization has the form *> P**T * A * P = U**T * U , if UPLO = 'U', *> P**T * A * P = L * L**T, if UPLO = 'L', *> where U is an upper triangular matrix and L is lower triangular, and *> P is stored as vector PIV. *> *> This algorithm does not attempt to check that A is positive *> semidefinite. This version of the algorithm calls level 2 BLAS. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the upper or lower triangular part of the *> symmetric matrix A is stored. *> = 'U': Upper triangular *> = 'L': Lower triangular *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the symmetric matrix A. If UPLO = 'U', the leading *> n by n upper triangular part of A contains the upper *> triangular part of the matrix A, and the strictly lower *> triangular part of A is not referenced. If UPLO = 'L', the *> leading n by n lower triangular part of A contains the lower *> triangular part of the matrix A, and the strictly upper *> triangular part of A is not referenced. *> *> On exit, if INFO = 0, the factor U or L from the Cholesky *> factorization as above. *> \endverbatim *> *> \param[out] PIV *> \verbatim *> PIV is INTEGER array, dimension (N) *> PIV is such that the nonzero entries are P( PIV(K), K ) = 1. *> \endverbatim *> *> \param[out] RANK *> \verbatim *> RANK is INTEGER *> The rank of A given by the number of steps the algorithm *> completed. *> \endverbatim *> *> \param[in] TOL *> \verbatim *> TOL is DOUBLE PRECISION *> User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) ) *> will be used. The algorithm terminates at the (K-1)st step *> if the pivot <= TOL. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (2*N) *> Work space. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> < 0: If INFO = -K, the K-th argument had an illegal value, *> = 0: algorithm completed successfully, and *> > 0: the matrix A is either rank deficient with computed rank *> as returned in RANK, or is not positive semidefinite. See *> Section 7 of LAPACK Working Note #161 for further *> information. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION TOL INTEGER INFO, LDA, N, RANK CHARACTER UPLO * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), WORK( 2*N ) INTEGER PIV( N ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. DOUBLE PRECISION AJJ, DSTOP, DTEMP INTEGER I, ITEMP, J, PVT LOGICAL UPPER * .. * .. External Functions .. DOUBLE PRECISION DLAMCH LOGICAL LSAME, DISNAN EXTERNAL DLAMCH, LSAME, DISNAN * .. * .. External Subroutines .. EXTERNAL DGEMV, DSCAL, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, SQRT, MAXLOC * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPSTF2', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Initialize PIV * DO 100 I = 1, N PIV( I ) = I 100 CONTINUE * * Compute stopping value * PVT = 1 AJJ = A( PVT, PVT ) DO I = 2, N IF( A( I, I ).GT.AJJ ) THEN PVT = I AJJ = A( PVT, PVT ) END IF END DO IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) THEN RANK = 0 INFO = 1 GO TO 170 END IF * * Compute stopping value if not supplied * IF( TOL.LT.ZERO ) THEN DSTOP = N * DLAMCH( 'Epsilon' ) * AJJ ELSE DSTOP = TOL END IF * * Set first half of WORK to zero, holds dot products * DO 110 I = 1, N WORK( I ) = 0 110 CONTINUE * IF( UPPER ) THEN * * Compute the Cholesky factorization P**T * A * P = U**T * U * DO 130 J = 1, N * * Find pivot, test for exit, else swap rows and columns * Update dot products, compute possible pivots which are * stored in the second half of WORK * DO 120 I = J, N * IF( J.GT.1 ) THEN WORK( I ) = WORK( I ) + A( J-1, I )**2 END IF WORK( N+I ) = A( I, I ) - WORK( I ) * 120 CONTINUE * IF( J.GT.1 ) THEN ITEMP = MAXLOC( WORK( (N+J):(2*N) ), 1 ) PVT = ITEMP + J - 1 AJJ = WORK( N+PVT ) IF( AJJ.LE.DSTOP.OR.DISNAN( AJJ ) ) THEN A( J, J ) = AJJ GO TO 160 END IF END IF * IF( J.NE.PVT ) THEN * * Pivot OK, so can now swap pivot rows and columns * A( PVT, PVT ) = A( J, J ) CALL DSWAP( J-1, A( 1, J ), 1, A( 1, PVT ), 1 ) IF( PVT.LT.N ) $ CALL DSWAP( N-PVT, A( J, PVT+1 ), LDA, $ A( PVT, PVT+1 ), LDA ) CALL DSWAP( PVT-J-1, A( J, J+1 ), LDA, A( J+1, PVT ), 1 ) * * Swap dot products and PIV * DTEMP = WORK( J ) WORK( J ) = WORK( PVT ) WORK( PVT ) = DTEMP ITEMP = PIV( PVT ) PIV( PVT ) = PIV( J ) PIV( J ) = ITEMP END IF * AJJ = SQRT( AJJ ) A( J, J ) = AJJ * * Compute elements J+1:N of row J * IF( J.LT.N ) THEN CALL DGEMV( 'Trans', J-1, N-J, -ONE, A( 1, J+1 ), LDA, $ A( 1, J ), 1, ONE, A( J, J+1 ), LDA ) CALL DSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA ) END IF * 130 CONTINUE * ELSE * * Compute the Cholesky factorization P**T * A * P = L * L**T * DO 150 J = 1, N * * Find pivot, test for exit, else swap rows and columns * Update dot products, compute possible pivots which are * stored in the second half of WORK * DO 140 I = J, N * IF( J.GT.1 ) THEN WORK( I ) = WORK( I ) + A( I, J-1 )**2 END IF WORK( N+I ) = A( I, I ) - WORK( I ) * 140 CONTINUE * IF( J.GT.1 ) THEN ITEMP = MAXLOC( WORK( (N+J):(2*N) ), 1 ) PVT = ITEMP + J - 1 AJJ = WORK( N+PVT ) IF( AJJ.LE.DSTOP.OR.DISNAN( AJJ ) ) THEN A( J, J ) = AJJ GO TO 160 END IF END IF * IF( J.NE.PVT ) THEN * * Pivot OK, so can now swap pivot rows and columns * A( PVT, PVT ) = A( J, J ) CALL DSWAP( J-1, A( J, 1 ), LDA, A( PVT, 1 ), LDA ) IF( PVT.LT.N ) $ CALL DSWAP( N-PVT, A( PVT+1, J ), 1, A( PVT+1, PVT ), $ 1 ) CALL DSWAP( PVT-J-1, A( J+1, J ), 1, A( PVT, J+1 ), LDA ) * * Swap dot products and PIV * DTEMP = WORK( J ) WORK( J ) = WORK( PVT ) WORK( PVT ) = DTEMP ITEMP = PIV( PVT ) PIV( PVT ) = PIV( J ) PIV( J ) = ITEMP END IF * AJJ = SQRT( AJJ ) A( J, J ) = AJJ * * Compute elements J+1:N of column J * IF( J.LT.N ) THEN CALL DGEMV( 'No Trans', N-J, J-1, -ONE, A( J+1, 1 ), LDA, $ A( J, 1 ), LDA, ONE, A( J+1, J ), 1 ) CALL DSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 ) END IF * 150 CONTINUE * END IF * * Ran to completion, A has full rank * RANK = N * GO TO 170 160 CONTINUE * * Rank is number of steps completed. Set INFO = 1 to signal * that the factorization cannot be used to solve a system. * RANK = J - 1 INFO = 1 * 170 CONTINUE RETURN * * End of DPSTF2 * END *> \brief \b DPSTRF computes the Cholesky factorization with complete pivoting of a real symmetric positive semidefinite matrix. * * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPSTRF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) * * .. Scalar Arguments .. * DOUBLE PRECISION TOL * INTEGER INFO, LDA, N, RANK * CHARACTER UPLO * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), WORK( 2*N ) * INTEGER PIV( N ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPSTRF computes the Cholesky factorization with complete *> pivoting of a real symmetric positive semidefinite matrix A. *> *> The factorization has the form *> P**T * A * P = U**T * U , if UPLO = 'U', *> P**T * A * P = L * L**T, if UPLO = 'L', *> where U is an upper triangular matrix and L is lower triangular, and *> P is stored as vector PIV. *> *> This algorithm does not attempt to check that A is positive *> semidefinite. This version of the algorithm calls level 3 BLAS. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the upper or lower triangular part of the *> symmetric matrix A is stored. *> = 'U': Upper triangular *> = 'L': Lower triangular *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the symmetric matrix A. If UPLO = 'U', the leading *> n by n upper triangular part of A contains the upper *> triangular part of the matrix A, and the strictly lower *> triangular part of A is not referenced. If UPLO = 'L', the *> leading n by n lower triangular part of A contains the lower *> triangular part of the matrix A, and the strictly upper *> triangular part of A is not referenced. *> *> On exit, if INFO = 0, the factor U or L from the Cholesky *> factorization as above. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] PIV *> \verbatim *> PIV is INTEGER array, dimension (N) *> PIV is such that the nonzero entries are P( PIV(K), K ) = 1. *> \endverbatim *> *> \param[out] RANK *> \verbatim *> RANK is INTEGER *> The rank of A given by the number of steps the algorithm *> completed. *> \endverbatim *> *> \param[in] TOL *> \verbatim *> TOL is DOUBLE PRECISION *> User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) ) *> will be used. The algorithm terminates at the (K-1)st step *> if the pivot <= TOL. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (2*N) *> Work space. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> < 0: If INFO = -K, the K-th argument had an illegal value, *> = 0: algorithm completed successfully, and *> > 0: the matrix A is either rank deficient with computed rank *> as returned in RANK, or is not positive semidefinite. See *> Section 7 of LAPACK Working Note #161 for further *> information. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION TOL INTEGER INFO, LDA, N, RANK CHARACTER UPLO * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), WORK( 2*N ) INTEGER PIV( N ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. DOUBLE PRECISION AJJ, DSTOP, DTEMP INTEGER I, ITEMP, J, JB, K, NB, PVT LOGICAL UPPER * .. * .. External Functions .. DOUBLE PRECISION DLAMCH INTEGER ILAENV LOGICAL LSAME, DISNAN EXTERNAL DLAMCH, ILAENV, LSAME, DISNAN * .. * .. External Subroutines .. EXTERNAL DGEMV, DPSTF2, DSCAL, DSWAP, DSYRK, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT, MAXLOC * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPSTRF', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Get block size * NB = ILAENV( 1, 'DPOTRF', UPLO, N, -1, -1, -1 ) IF( NB.LE.1 .OR. NB.GE.N ) THEN * * Use unblocked code * CALL DPSTF2( UPLO, N, A( 1, 1 ), LDA, PIV, RANK, TOL, WORK, $ INFO ) GO TO 200 * ELSE * * Initialize PIV * DO 100 I = 1, N PIV( I ) = I 100 CONTINUE * * Compute stopping value * PVT = 1 AJJ = A( PVT, PVT ) DO I = 2, N IF( A( I, I ).GT.AJJ ) THEN PVT = I AJJ = A( PVT, PVT ) END IF END DO IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) THEN RANK = 0 INFO = 1 GO TO 200 END IF * * Compute stopping value if not supplied * IF( TOL.LT.ZERO ) THEN DSTOP = N * DLAMCH( 'Epsilon' ) * AJJ ELSE DSTOP = TOL END IF * * IF( UPPER ) THEN * * Compute the Cholesky factorization P**T * A * P = U**T * U * DO 140 K = 1, N, NB * * Account for last block not being NB wide * JB = MIN( NB, N-K+1 ) * * Set relevant part of first half of WORK to zero, * holds dot products * DO 110 I = K, N WORK( I ) = 0 110 CONTINUE * DO 130 J = K, K + JB - 1 * * Find pivot, test for exit, else swap rows and columns * Update dot products, compute possible pivots which are * stored in the second half of WORK * DO 120 I = J, N * IF( J.GT.K ) THEN WORK( I ) = WORK( I ) + A( J-1, I )**2 END IF WORK( N+I ) = A( I, I ) - WORK( I ) * 120 CONTINUE * IF( J.GT.1 ) THEN ITEMP = MAXLOC( WORK( (N+J):(2*N) ), 1 ) PVT = ITEMP + J - 1 AJJ = WORK( N+PVT ) IF( AJJ.LE.DSTOP.OR.DISNAN( AJJ ) ) THEN A( J, J ) = AJJ GO TO 190 END IF END IF * IF( J.NE.PVT ) THEN * * Pivot OK, so can now swap pivot rows and columns * A( PVT, PVT ) = A( J, J ) CALL DSWAP( J-1, A( 1, J ), 1, A( 1, PVT ), 1 ) IF( PVT.LT.N ) $ CALL DSWAP( N-PVT, A( J, PVT+1 ), LDA, $ A( PVT, PVT+1 ), LDA ) CALL DSWAP( PVT-J-1, A( J, J+1 ), LDA, $ A( J+1, PVT ), 1 ) * * Swap dot products and PIV * DTEMP = WORK( J ) WORK( J ) = WORK( PVT ) WORK( PVT ) = DTEMP ITEMP = PIV( PVT ) PIV( PVT ) = PIV( J ) PIV( J ) = ITEMP END IF * AJJ = SQRT( AJJ ) A( J, J ) = AJJ * * Compute elements J+1:N of row J. * IF( J.LT.N ) THEN CALL DGEMV( 'Trans', J-K, N-J, -ONE, A( K, J+1 ), $ LDA, A( K, J ), 1, ONE, A( J, J+1 ), $ LDA ) CALL DSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA ) END IF * 130 CONTINUE * * Update trailing matrix, J already incremented * IF( K+JB.LE.N ) THEN CALL DSYRK( 'Upper', 'Trans', N-J+1, JB, -ONE, $ A( K, J ), LDA, ONE, A( J, J ), LDA ) END IF * 140 CONTINUE * ELSE * * Compute the Cholesky factorization P**T * A * P = L * L**T * DO 180 K = 1, N, NB * * Account for last block not being NB wide * JB = MIN( NB, N-K+1 ) * * Set relevant part of first half of WORK to zero, * holds dot products * DO 150 I = K, N WORK( I ) = 0 150 CONTINUE * DO 170 J = K, K + JB - 1 * * Find pivot, test for exit, else swap rows and columns * Update dot products, compute possible pivots which are * stored in the second half of WORK * DO 160 I = J, N * IF( J.GT.K ) THEN WORK( I ) = WORK( I ) + A( I, J-1 )**2 END IF WORK( N+I ) = A( I, I ) - WORK( I ) * 160 CONTINUE * IF( J.GT.1 ) THEN ITEMP = MAXLOC( WORK( (N+J):(2*N) ), 1 ) PVT = ITEMP + J - 1 AJJ = WORK( N+PVT ) IF( AJJ.LE.DSTOP.OR.DISNAN( AJJ ) ) THEN A( J, J ) = AJJ GO TO 190 END IF END IF * IF( J.NE.PVT ) THEN * * Pivot OK, so can now swap pivot rows and columns * A( PVT, PVT ) = A( J, J ) CALL DSWAP( J-1, A( J, 1 ), LDA, A( PVT, 1 ), LDA ) IF( PVT.LT.N ) $ CALL DSWAP( N-PVT, A( PVT+1, J ), 1, $ A( PVT+1, PVT ), 1 ) CALL DSWAP( PVT-J-1, A( J+1, J ), 1, A( PVT, J+1 ), $ LDA ) * * Swap dot products and PIV * DTEMP = WORK( J ) WORK( J ) = WORK( PVT ) WORK( PVT ) = DTEMP ITEMP = PIV( PVT ) PIV( PVT ) = PIV( J ) PIV( J ) = ITEMP END IF * AJJ = SQRT( AJJ ) A( J, J ) = AJJ * * Compute elements J+1:N of column J. * IF( J.LT.N ) THEN CALL DGEMV( 'No Trans', N-J, J-K, -ONE, $ A( J+1, K ), LDA, A( J, K ), LDA, ONE, $ A( J+1, J ), 1 ) CALL DSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 ) END IF * 170 CONTINUE * * Update trailing matrix, J already incremented * IF( K+JB.LE.N ) THEN CALL DSYRK( 'Lower', 'No Trans', N-J+1, JB, -ONE, $ A( J, K ), LDA, ONE, A( J, J ), LDA ) END IF * 180 CONTINUE * END IF END IF * * Ran to completion, A has full rank * RANK = N * GO TO 200 190 CONTINUE * * Rank is the number of steps completed. Set INFO = 1 to signal * that the factorization cannot be used to solve a system. * RANK = J - 1 INFO = 1 * 200 CONTINUE RETURN * * End of DPSTRF * END *> \brief \b DPTCON * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPTCON + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPTCON( N, D, E, ANORM, RCOND, WORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, N * DOUBLE PRECISION ANORM, RCOND * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), E( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPTCON computes the reciprocal of the condition number (in the *> 1-norm) of a real symmetric positive definite tridiagonal matrix *> using the factorization A = L*D*L**T or A = U**T*D*U computed by *> DPTTRF. *> *> Norm(inv(A)) is computed by a direct method, and the reciprocal of *> the condition number is computed as *> RCOND = 1 / (ANORM * norm(inv(A))). *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The n diagonal elements of the diagonal matrix D from the *> factorization of A, as computed by DPTTRF. *> \endverbatim *> *> \param[in] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N-1) *> The (n-1) off-diagonal elements of the unit bidiagonal factor *> U or L from the factorization of A, as computed by DPTTRF. *> \endverbatim *> *> \param[in] ANORM *> \verbatim *> ANORM is DOUBLE PRECISION *> The 1-norm of the original matrix A. *> \endverbatim *> *> \param[out] RCOND *> \verbatim *> RCOND is DOUBLE PRECISION *> The reciprocal of the condition number of the matrix A, *> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the *> 1-norm of inv(A) computed in this routine. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doublePTcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The method used is described in Nicholas J. Higham, "Efficient *> Algorithms for Computing the Condition Number of a Tridiagonal *> Matrix", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986. *> \endverbatim *> * ===================================================================== SUBROUTINE DPTCON( N, D, E, ANORM, RCOND, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, N DOUBLE PRECISION ANORM, RCOND * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, IX DOUBLE PRECISION AINVNM * .. * .. External Functions .. INTEGER IDAMAX EXTERNAL IDAMAX * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * * Test the input arguments. * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( ANORM.LT.ZERO ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPTCON', -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 positive. * DO 10 I = 1, N IF( D( I ).LE.ZERO ) $ RETURN 10 CONTINUE * * Solve M(A) * x = e, where M(A) = (m(i,j)) is given by * * m(i,j) = abs(A(i,j)), i = j, * m(i,j) = -abs(A(i,j)), i .ne. j, * * and e = [ 1, 1, ..., 1 ]**T. Note M(A) = M(L)*D*M(L)**T. * * Solve M(L) * x = e. * WORK( 1 ) = ONE DO 20 I = 2, N WORK( I ) = ONE + WORK( I-1 )*ABS( E( I-1 ) ) 20 CONTINUE * * Solve D * M(L)**T * x = b. * WORK( N ) = WORK( N ) / D( N ) DO 30 I = N - 1, 1, -1 WORK( I ) = WORK( I ) / D( I ) + WORK( I+1 )*ABS( E( I ) ) 30 CONTINUE * * Compute AINVNM = max(x(i)), 1<=i<=n. * IX = IDAMAX( N, WORK, 1 ) AINVNM = ABS( WORK( IX ) ) * * Compute the reciprocal condition number. * IF( AINVNM.NE.ZERO ) $ RCOND = ( ONE / AINVNM ) / ANORM * RETURN * * End of DPTCON * END *> \brief \b DPTEQR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPTEQR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * * .. Scalar Arguments .. * CHARACTER COMPZ * INTEGER INFO, LDZ, N * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPTEQR computes all eigenvalues and, optionally, eigenvectors of a *> symmetric positive definite tridiagonal matrix by first factoring the *> matrix using DPTTRF, and then calling DBDSQR to compute the singular *> values of the bidiagonal factor. *> *> This routine computes the eigenvalues of the positive definite *> tridiagonal matrix to high relative accuracy. This means that if the *> eigenvalues range over many orders of magnitude in size, then the *> small eigenvalues and corresponding eigenvectors will be computed *> more accurately than, for example, with the standard QR method. *> *> The eigenvectors of a full or band symmetric positive definite matrix *> can also be found if DSYTRD, DSPTRD, or DSBTRD has been used to *> reduce this matrix to tridiagonal form. (The reduction to tridiagonal *> form, however, may preclude the possibility of obtaining high *> relative accuracy in the small eigenvalues of the original matrix, if *> these eigenvalues range over many orders of magnitude.) *> \endverbatim * * Arguments: * ========== * *> \param[in] COMPZ *> \verbatim *> COMPZ is CHARACTER*1 *> = 'N': Compute eigenvalues only. *> = 'V': Compute eigenvectors of original symmetric *> matrix also. Array Z contains the orthogonal *> matrix used to reduce the original matrix to *> tridiagonal form. *> = 'I': Compute eigenvectors of tridiagonal matrix also. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix. N >= 0. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> On entry, the n diagonal elements of the tridiagonal *> matrix. *> On normal exit, D contains the eigenvalues, in descending *> order. *> \endverbatim *> *> \param[in,out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N-1) *> On entry, the (n-1) subdiagonal elements of the tridiagonal *> matrix. *> On exit, E has been destroyed. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ, N) *> On entry, if COMPZ = 'V', the orthogonal matrix used in the *> reduction to tridiagonal form. *> On exit, if COMPZ = 'V', the orthonormal eigenvectors of the *> original symmetric matrix; *> if COMPZ = 'I', the orthonormal eigenvectors of the *> tridiagonal matrix. *> If INFO > 0 on exit, Z contains the eigenvectors associated *> with only the stored eigenvalues. *> If COMPZ = 'N', then Z is not referenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1, and if *> COMPZ = 'V' or 'I', LDZ >= max(1,N). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (4*N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: if INFO = i, and i is: *> <= N the Cholesky factorization of the matrix could *> not be performed because the i-th principal minor *> was not positive definite. *> > N the SVD algorithm failed to converge; *> if INFO = N+i, i off-diagonal elements of the *> bidiagonal factor did not converge to zero. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doublePTcomputational * * ===================================================================== SUBROUTINE DPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER COMPZ INTEGER INFO, LDZ, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DBDSQR, DLASET, DPTTRF, XERBLA * .. * .. Local Arrays .. DOUBLE PRECISION C( 1, 1 ), VT( 1, 1 ) * .. * .. Local Scalars .. INTEGER I, ICOMPZ, NRU * .. * .. Intrinsic Functions .. INTRINSIC MAX, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 * IF( LSAME( COMPZ, 'N' ) ) THEN ICOMPZ = 0 ELSE IF( LSAME( COMPZ, 'V' ) ) THEN ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ICOMPZ = 2 ELSE ICOMPZ = -1 END IF IF( ICOMPZ.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, $ N ) ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPTEQR', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( N.EQ.1 ) THEN IF( ICOMPZ.GT.0 ) $ Z( 1, 1 ) = ONE RETURN END IF IF( ICOMPZ.EQ.2 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) * * Call DPTTRF to factor the matrix. * CALL DPTTRF( N, D, E, INFO ) IF( INFO.NE.0 ) $ RETURN DO 10 I = 1, N D( I ) = SQRT( D( I ) ) 10 CONTINUE DO 20 I = 1, N - 1 E( I ) = E( I )*D( I ) 20 CONTINUE * * Call DBDSQR to compute the singular values/vectors of the * bidiagonal factor. * IF( ICOMPZ.GT.0 ) THEN NRU = N ELSE NRU = 0 END IF CALL DBDSQR( 'Lower', N, 0, NRU, 0, D, E, VT, 1, Z, LDZ, C, 1, $ WORK, INFO ) * * Square the singular values. * IF( INFO.EQ.0 ) THEN DO 30 I = 1, N D( I ) = D( I )*D( I ) 30 CONTINUE ELSE INFO = N + INFO END IF * RETURN * * End of DPTEQR * END *> \brief \b DPTRFS * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPTRFS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, * BERR, WORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDB, LDX, N, NRHS * .. * .. Array Arguments .. * DOUBLE PRECISION B( LDB, * ), BERR( * ), D( * ), DF( * ), * $ E( * ), EF( * ), FERR( * ), WORK( * ), * $ X( LDX, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPTRFS improves the computed solution to a system of linear *> equations when the coefficient matrix is symmetric positive definite *> and tridiagonal, and provides error bounds and backward error *> estimates for the solution. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrix B. NRHS >= 0. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The n diagonal elements of the tridiagonal matrix A. *> \endverbatim *> *> \param[in] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N-1) *> The (n-1) subdiagonal elements of the tridiagonal matrix A. *> \endverbatim *> *> \param[in] DF *> \verbatim *> DF is DOUBLE PRECISION array, dimension (N) *> The n diagonal elements of the diagonal matrix D from the *> factorization computed by DPTTRF. *> \endverbatim *> *> \param[in] EF *> \verbatim *> EF is DOUBLE PRECISION array, dimension (N-1) *> The (n-1) subdiagonal elements of the unit bidiagonal factor *> L from the factorization computed by DPTTRF. *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> The right hand side matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,NRHS) *> On entry, the solution matrix X, as computed by DPTTRS. *> On exit, the improved solution matrix X. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the array X. LDX >= max(1,N). *> \endverbatim *> *> \param[out] FERR *> \verbatim *> FERR is DOUBLE PRECISION array, dimension (NRHS) *> The 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). *> \endverbatim *> *> \param[out] BERR *> \verbatim *> BERR is 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). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (2*N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * *> \par Internal Parameters: * ========================= *> *> \verbatim *> ITMAX is the maximum number of steps of iterative refinement. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doublePTcomputational * * ===================================================================== SUBROUTINE DPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, $ BERR, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDB, LDX, N, NRHS * .. * .. Array Arguments .. DOUBLE PRECISION B( LDB, * ), BERR( * ), D( * ), DF( * ), $ E( * ), EF( * ), FERR( * ), WORK( * ), $ X( LDX, * ) * .. * * ===================================================================== * * .. 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 .. INTEGER COUNT, I, IX, J, NZ DOUBLE PRECISION BI, CX, DX, EPS, EX, LSTRES, S, SAFE1, SAFE2, $ SAFMIN * .. * .. External Subroutines .. EXTERNAL DAXPY, DPTTRS, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH EXTERNAL IDAMAX, DLAMCH * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( NRHS.LT.0 ) THEN INFO = -2 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPTRFS', -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 * * 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 90 J = 1, NRHS * COUNT = 1 LSTRES = THREE 20 CONTINUE * * Loop until stopping criterion is satisfied. * * Compute residual R = B - A * X. Also compute * abs(A)*abs(x) + abs(b) for use in the backward error bound. * IF( N.EQ.1 ) THEN BI = B( 1, J ) DX = D( 1 )*X( 1, J ) WORK( N+1 ) = BI - DX WORK( 1 ) = ABS( BI ) + ABS( DX ) ELSE BI = B( 1, J ) DX = D( 1 )*X( 1, J ) EX = E( 1 )*X( 2, J ) WORK( N+1 ) = BI - DX - EX WORK( 1 ) = ABS( BI ) + ABS( DX ) + ABS( EX ) DO 30 I = 2, N - 1 BI = B( I, J ) CX = E( I-1 )*X( I-1, J ) DX = D( I )*X( I, J ) EX = E( I )*X( I+1, J ) WORK( N+I ) = BI - CX - DX - EX WORK( I ) = ABS( BI ) + ABS( CX ) + ABS( DX ) + ABS( EX ) 30 CONTINUE BI = B( N, J ) CX = E( N-1 )*X( N-1, J ) DX = D( N )*X( N, J ) WORK( N+N ) = BI - CX - DX WORK( N ) = ABS( BI ) + ABS( CX ) + ABS( DX ) END IF * * Compute componentwise relative backward error from formula * * max(i) ( abs(R(i)) / ( abs(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 40 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 40 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 DPTTRS( N, 1, DF, EF, 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(A))* * ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) * * where * norm(Z) is the magnitude of the largest component of Z * inv(A) is the inverse of 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(A)*abs(X)+abs(B)) * is incremented by SAFE1 if the i-th component of * abs(A)*abs(X) + abs(B) is less than SAFE2. * DO 50 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 50 CONTINUE IX = IDAMAX( N, WORK, 1 ) FERR( J ) = WORK( IX ) * * Estimate the norm of inv(A). * * Solve M(A) * x = e, where M(A) = (m(i,j)) is given by * * m(i,j) = abs(A(i,j)), i = j, * m(i,j) = -abs(A(i,j)), i .ne. j, * * and e = [ 1, 1, ..., 1 ]**T. Note M(A) = M(L)*D*M(L)**T. * * Solve M(L) * x = e. * WORK( 1 ) = ONE DO 60 I = 2, N WORK( I ) = ONE + WORK( I-1 )*ABS( EF( I-1 ) ) 60 CONTINUE * * Solve D * M(L)**T * x = b. * WORK( N ) = WORK( N ) / DF( N ) DO 70 I = N - 1, 1, -1 WORK( I ) = WORK( I ) / DF( I ) + WORK( I+1 )*ABS( EF( I ) ) 70 CONTINUE * * Compute norm(inv(A)) = max(x(i)), 1<=i<=n. * IX = IDAMAX( N, WORK, 1 ) FERR( J ) = FERR( J )*ABS( WORK( IX ) ) * * Normalize error. * LSTRES = ZERO DO 80 I = 1, N LSTRES = MAX( LSTRES, ABS( X( I, J ) ) ) 80 CONTINUE IF( LSTRES.NE.ZERO ) $ FERR( J ) = FERR( J ) / LSTRES * 90 CONTINUE * RETURN * * End of DPTRFS * END *> \brief DPTSV computes the solution to system of linear equations A * X = B for PT matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPTSV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPTSV( N, NRHS, D, E, B, LDB, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. * DOUBLE PRECISION B( LDB, * ), D( * ), E( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPTSV computes the solution to a real system of linear equations *> A*X = B, where A is an N-by-N symmetric positive definite tridiagonal *> matrix, and X and B are N-by-NRHS matrices. *> *> A is factored as A = L*D*L**T, and the factored form of A is then *> used to solve the system of equations. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrix B. NRHS >= 0. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> On entry, the n diagonal elements of the tridiagonal matrix *> A. On exit, the n diagonal elements of the diagonal matrix *> D from the factorization A = L*D*L**T. *> \endverbatim *> *> \param[in,out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N-1) *> On entry, the (n-1) subdiagonal elements of the tridiagonal *> matrix A. On exit, the (n-1) subdiagonal elements of the *> unit bidiagonal factor L from the L*D*L**T factorization of *> A. (E can also be regarded as the superdiagonal of the unit *> bidiagonal factor U from the U**T*D*U factorization of A.) *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> On entry, the N-by-NRHS right hand side matrix B. *> On exit, if INFO = 0, the N-by-NRHS solution matrix X. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, the leading minor of order i is not *> positive definite, and the solution has not been *> computed. The factorization has not been completed *> unless i = N. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doublePTsolve * * ===================================================================== SUBROUTINE DPTSV( N, NRHS, D, E, B, LDB, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. DOUBLE PRECISION B( LDB, * ), D( * ), E( * ) * .. * * ===================================================================== * * .. External Subroutines .. EXTERNAL DPTTRF, DPTTRS, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( NRHS.LT.0 ) THEN INFO = -2 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPTSV ', -INFO ) RETURN END IF * * Compute the L*D*L**T (or U**T*D*U) factorization of A. * CALL DPTTRF( N, D, E, INFO ) IF( INFO.EQ.0 ) THEN * * Solve the system A*X = B, overwriting B with X. * CALL DPTTRS( N, NRHS, D, E, B, LDB, INFO ) END IF RETURN * * End of DPTSV * END *> \brief DPTSVX computes the solution to system of linear equations A * X = B for PT matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPTSVX + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, * RCOND, FERR, BERR, WORK, INFO ) * * .. Scalar Arguments .. * CHARACTER FACT * INTEGER INFO, LDB, LDX, N, NRHS * DOUBLE PRECISION RCOND * .. * .. Array Arguments .. * DOUBLE PRECISION B( LDB, * ), BERR( * ), D( * ), DF( * ), * $ E( * ), EF( * ), FERR( * ), WORK( * ), * $ X( LDX, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPTSVX uses the factorization A = L*D*L**T to compute the solution *> to a real system of linear equations A*X = B, where A is an N-by-N *> symmetric positive definite tridiagonal matrix and X and B are *> N-by-NRHS matrices. *> *> Error bounds on the solution and a condition estimate are also *> provided. *> \endverbatim * *> \par Description: * ================= *> *> \verbatim *> *> The following steps are performed: *> *> 1. If FACT = 'N', the matrix A is factored as A = L*D*L**T, where L *> is a unit lower bidiagonal matrix and D is diagonal. The *> factorization can also be regarded as having the form *> A = U**T*D*U. *> *> 2. If the leading i-by-i principal minor is not positive definite, *> 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] FACT *> \verbatim *> FACT is CHARACTER*1 *> Specifies whether or not the factored form of A has been *> supplied on entry. *> = 'F': On entry, DF and EF contain the factored form of A. *> D, E, DF, and EF will not be modified. *> = 'N': The matrix A will be copied to DF and EF and *> factored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrices B and X. NRHS >= 0. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The n diagonal elements of the tridiagonal matrix A. *> \endverbatim *> *> \param[in] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N-1) *> The (n-1) subdiagonal elements of the tridiagonal matrix A. *> \endverbatim *> *> \param[in,out] DF *> \verbatim *> DF is DOUBLE PRECISION array, dimension (N) *> If FACT = 'F', then DF is an input argument and on entry *> contains the n diagonal elements of the diagonal matrix D *> from the L*D*L**T factorization of A. *> If FACT = 'N', then DF is an output argument and on exit *> contains the n diagonal elements of the diagonal matrix D *> from the L*D*L**T factorization of A. *> \endverbatim *> *> \param[in,out] EF *> \verbatim *> EF is DOUBLE PRECISION array, dimension (N-1) *> If FACT = 'F', then EF is an input argument and on entry *> contains the (n-1) subdiagonal elements of the unit *> bidiagonal factor L from the L*D*L**T factorization of A. *> If FACT = 'N', then EF is an output argument and on exit *> contains the (n-1) subdiagonal elements of the unit *> bidiagonal factor L from the L*D*L**T factorization of A. *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> The N-by-NRHS right hand side matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,NRHS) *> If INFO = 0 of INFO = N+1, the N-by-NRHS solution matrix X. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the array X. LDX >= max(1,N). *> \endverbatim *> *> \param[out] RCOND *> \verbatim *> RCOND is DOUBLE PRECISION *> 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. *> \endverbatim *> *> \param[out] FERR *> \verbatim *> FERR is DOUBLE PRECISION array, dimension (NRHS) *> The 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). *> \endverbatim *> *> \param[out] BERR *> \verbatim *> BERR is 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). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (2*N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, and i is *> <= N: the leading minor of order i of A is *> not positive definite, so the factorization *> could not be completed, and the solution has not *> been 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. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doublePTsolve * * ===================================================================== SUBROUTINE DPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, $ RCOND, FERR, BERR, WORK, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER FACT INTEGER INFO, LDB, LDX, N, NRHS DOUBLE PRECISION RCOND * .. * .. Array Arguments .. DOUBLE PRECISION B( LDB, * ), BERR( * ), D( * ), DF( * ), $ E( * ), EF( * ), FERR( * ), WORK( * ), $ X( LDX, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOFACT DOUBLE PRECISION ANORM * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANST EXTERNAL LSAME, DLAMCH, DLANST * .. * .. External Subroutines .. EXTERNAL DCOPY, DLACPY, DPTCON, DPTRFS, DPTTRF, DPTTRS, $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 NOFACT = LSAME( FACT, 'N' ) IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) 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 = -9 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -11 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPTSVX', -INFO ) RETURN END IF * IF( NOFACT ) THEN * * Compute the L*D*L**T (or U**T*D*U) factorization of A. * CALL DCOPY( N, D, 1, DF, 1 ) IF( N.GT.1 ) $ CALL DCOPY( N-1, E, 1, EF, 1 ) CALL DPTTRF( N, DF, EF, 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. * ANORM = DLANST( '1', N, D, E ) * * Compute the reciprocal of the condition number of A. * CALL DPTCON( N, DF, EF, ANORM, RCOND, WORK, INFO ) * * Compute the solution vectors X. * CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) CALL DPTTRS( N, NRHS, DF, EF, X, LDX, INFO ) * * Use iterative refinement to improve the computed solutions and * compute error bounds and backward error estimates for them. * CALL DPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR, $ WORK, INFO ) * * Set INFO = N+1 if the matrix is singular to working precision. * IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) $ INFO = N + 1 * RETURN * * End of DPTSVX * END *> \brief \b DPTTRF * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPTTRF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPTTRF( N, D, E, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, N * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), E( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPTTRF computes the L*D*L**T factorization of a real symmetric *> positive definite tridiagonal matrix A. The factorization may also *> be regarded as having the form A = U**T*D*U. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> On entry, the n diagonal elements of the tridiagonal matrix *> A. On exit, the n diagonal elements of the diagonal matrix *> D from the L*D*L**T factorization of A. *> \endverbatim *> *> \param[in,out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N-1) *> On entry, the (n-1) subdiagonal elements of the tridiagonal *> matrix A. On exit, the (n-1) subdiagonal elements of the *> unit bidiagonal factor L from the L*D*L**T factorization of A. *> E can also be regarded as the superdiagonal of the unit *> bidiagonal factor U from the U**T*D*U factorization of A. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -k, the k-th argument had an illegal value *> > 0: if INFO = k, the leading minor of order k is not *> positive definite; if k < N, the factorization could not *> be completed, while if k = N, the factorization was *> completed, but D(N) <= 0. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doublePTcomputational * * ===================================================================== SUBROUTINE DPTTRF( N, D, E, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, I4 DOUBLE PRECISION EI * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MOD * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 CALL XERBLA( 'DPTTRF', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Compute the L*D*L**T (or U**T*D*U) factorization of A. * I4 = MOD( N-1, 4 ) DO 10 I = 1, I4 IF( D( I ).LE.ZERO ) THEN INFO = I GO TO 30 END IF EI = E( I ) E( I ) = EI / D( I ) D( I+1 ) = D( I+1 ) - E( I )*EI 10 CONTINUE * DO 20 I = I4 + 1, N - 4, 4 * * Drop out of the loop if d(i) <= 0: the matrix is not positive * definite. * IF( D( I ).LE.ZERO ) THEN INFO = I GO TO 30 END IF * * Solve for e(i) and d(i+1). * EI = E( I ) E( I ) = EI / D( I ) D( I+1 ) = D( I+1 ) - E( I )*EI * IF( D( I+1 ).LE.ZERO ) THEN INFO = I + 1 GO TO 30 END IF * * Solve for e(i+1) and d(i+2). * EI = E( I+1 ) E( I+1 ) = EI / D( I+1 ) D( I+2 ) = D( I+2 ) - E( I+1 )*EI * IF( D( I+2 ).LE.ZERO ) THEN INFO = I + 2 GO TO 30 END IF * * Solve for e(i+2) and d(i+3). * EI = E( I+2 ) E( I+2 ) = EI / D( I+2 ) D( I+3 ) = D( I+3 ) - E( I+2 )*EI * IF( D( I+3 ).LE.ZERO ) THEN INFO = I + 3 GO TO 30 END IF * * Solve for e(i+3) and d(i+4). * EI = E( I+3 ) E( I+3 ) = EI / D( I+3 ) D( I+4 ) = D( I+4 ) - E( I+3 )*EI 20 CONTINUE * * Check d(n) for positive definiteness. * IF( D( N ).LE.ZERO ) $ INFO = N * 30 CONTINUE RETURN * * End of DPTTRF * END *> \brief \b DPTTRS * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPTTRS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPTTRS( N, NRHS, D, E, B, LDB, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. * DOUBLE PRECISION B( LDB, * ), D( * ), E( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPTTRS solves a tridiagonal system of the form *> A * X = B *> using the L*D*L**T factorization of A computed by DPTTRF. D is a *> diagonal matrix specified in the vector D, L is a unit bidiagonal *> matrix whose subdiagonal is specified in the vector E, and X and B *> are N by NRHS matrices. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the tridiagonal matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrix B. NRHS >= 0. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The n diagonal elements of the diagonal matrix D from the *> L*D*L**T factorization of A. *> \endverbatim *> *> \param[in] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N-1) *> The (n-1) subdiagonal elements of the unit bidiagonal factor *> L from the L*D*L**T factorization of A. E can also be regarded *> as the superdiagonal of the unit bidiagonal factor U from the *> factorization A = U**T*D*U. *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> On entry, the right hand side vectors B for the system of *> linear equations. *> On exit, the solution vectors, X. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -k, the k-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doublePTcomputational * * ===================================================================== SUBROUTINE DPTTRS( N, NRHS, D, E, B, LDB, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. DOUBLE PRECISION B( LDB, * ), D( * ), E( * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER J, JB, NB * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. External Subroutines .. EXTERNAL DPTTS2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments. * 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 = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPTTRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * * 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, 'DPTTRS', ' ', N, NRHS, -1, -1 ) ) END IF * IF( NB.GE.NRHS ) THEN CALL DPTTS2( N, NRHS, D, E, B, LDB ) ELSE DO 10 J = 1, NRHS, NB JB = MIN( NRHS-J+1, NB ) CALL DPTTS2( N, JB, D, E, B( 1, J ), LDB ) 10 CONTINUE END IF * RETURN * * End of DPTTRS * END *> \brief \b DPTTS2 solves a tridiagonal system of the form AX=B using the L D LH factorization computed by spttrf. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DPTTS2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DPTTS2( N, NRHS, D, E, B, LDB ) * * .. Scalar Arguments .. * INTEGER LDB, N, NRHS * .. * .. Array Arguments .. * DOUBLE PRECISION B( LDB, * ), D( * ), E( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DPTTS2 solves a tridiagonal system of the form *> A * X = B *> using the L*D*L**T factorization of A computed by DPTTRF. D is a *> diagonal matrix specified in the vector D, L is a unit bidiagonal *> matrix whose subdiagonal is specified in the vector E, and X and B *> are N by NRHS matrices. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the tridiagonal matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrix B. NRHS >= 0. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The n diagonal elements of the diagonal matrix D from the *> L*D*L**T factorization of A. *> \endverbatim *> *> \param[in] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N-1) *> The (n-1) subdiagonal elements of the unit bidiagonal factor *> L from the L*D*L**T factorization of A. E can also be regarded *> as the superdiagonal of the unit bidiagonal factor U from the *> factorization A = U**T*D*U. *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> On entry, the right hand side vectors B for the system of *> linear equations. *> On exit, the solution vectors, X. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doublePTcomputational * * ===================================================================== SUBROUTINE DPTTS2( N, NRHS, D, E, B, LDB ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER LDB, N, NRHS * .. * .. Array Arguments .. DOUBLE PRECISION B( LDB, * ), D( * ), E( * ) * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I, J * .. * .. External Subroutines .. EXTERNAL DSCAL * .. * .. Executable Statements .. * * Quick return if possible * IF( N.LE.1 ) THEN IF( N.EQ.1 ) $ CALL DSCAL( NRHS, 1.D0 / D( 1 ), B, LDB ) RETURN END IF * * Solve A * X = B using the factorization A = L*D*L**T, * overwriting each right hand side vector with its solution. * DO 30 J = 1, NRHS * * Solve L * x = b. * DO 10 I = 2, N B( I, J ) = B( I, J ) - B( I-1, J )*E( I-1 ) 10 CONTINUE * * Solve D * L**T * x = b. * B( N, J ) = B( N, J ) / D( N ) DO 20 I = N - 1, 1, -1 B( I, J ) = B( I, J ) / D( I ) - B( I+1, J )*E( I ) 20 CONTINUE 30 CONTINUE * RETURN * * End of DPTTS2 * END *> \brief \b DRSCL multiplies a vector by the reciprocal of a real scalar. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DRSCL + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DRSCL( N, SA, SX, INCX ) * * .. Scalar Arguments .. * INTEGER INCX, N * DOUBLE PRECISION SA * .. * .. Array Arguments .. * DOUBLE PRECISION SX( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DRSCL multiplies an n-element real vector x by the real scalar 1/a. *> This is done without overflow or underflow as long as *> the final result x/a does not overflow or underflow. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The number of components of the vector x. *> \endverbatim *> *> \param[in] SA *> \verbatim *> SA is DOUBLE PRECISION *> The scalar a which is used to divide each component of x. *> SA must be >= 0, or the subroutine will divide by zero. *> \endverbatim *> *> \param[in,out] SX *> \verbatim *> SX is DOUBLE PRECISION array, dimension *> (1+(N-1)*abs(INCX)) *> The n-element vector x. *> \endverbatim *> *> \param[in] INCX *> \verbatim *> INCX is INTEGER *> The increment between successive values of the vector SX. *> > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date November 2017 * *> \ingroup doubleOTHERauxiliary * * ===================================================================== SUBROUTINE DRSCL( N, SA, SX, INCX ) * * -- LAPACK auxiliary routine (version 3.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. Scalar Arguments .. INTEGER INCX, N DOUBLE PRECISION SA * .. * .. Array Arguments .. DOUBLE PRECISION SX( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL DONE DOUBLE PRECISION BIGNUM, CDEN, CDEN1, CNUM, CNUM1, MUL, SMLNUM * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. External Subroutines .. EXTERNAL DSCAL, DLABAD * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * * Quick return if possible * IF( N.LE.0 ) $ RETURN * * Get machine parameters * SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) * * Initialize the denominator to SA and the numerator to 1. * CDEN = SA CNUM = ONE * 10 CONTINUE CDEN1 = CDEN*SMLNUM CNUM1 = CNUM / BIGNUM IF( ABS( CDEN1 ).GT.ABS( CNUM ) .AND. CNUM.NE.ZERO ) THEN * * Pre-multiply X by SMLNUM if CDEN is large compared to CNUM. * MUL = SMLNUM DONE = .FALSE. CDEN = CDEN1 ELSE IF( ABS( CNUM1 ).GT.ABS( CDEN ) ) THEN * * Pre-multiply X by BIGNUM if CDEN is small compared to CNUM. * MUL = BIGNUM DONE = .FALSE. CNUM = CNUM1 ELSE * * Multiply X by CNUM / CDEN and return. * MUL = CNUM / CDEN DONE = .TRUE. END IF * * Scale the vector X by MUL * CALL DSCAL( N, MUL, SX, INCX ) * IF( .NOT.DONE ) $ GO TO 10 * RETURN * * End of DRSCL * END *> \brief DSBEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSBEV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, * INFO ) * * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, KD, LDAB, LDZ, N * .. * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSBEV computes all the eigenvalues and, optionally, eigenvectors of *> a real symmetric band matrix A. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBZ *> \verbatim *> JOBZ is CHARACTER*1 *> = 'N': Compute eigenvalues only; *> = 'V': Compute eigenvalues and eigenvectors. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] KD *> \verbatim *> KD is INTEGER *> The number of superdiagonals of the matrix A if UPLO = 'U', *> or the number of subdiagonals if UPLO = 'L'. KD >= 0. *> \endverbatim *> *> \param[in,out] AB *> \verbatim *> AB is DOUBLE PRECISION array, dimension (LDAB, N) *> On entry, the upper or lower triangle of the symmetric band *> matrix A, stored in the first KD+1 rows of the array. The *> j-th column of A is stored in the j-th column of the array AB *> as follows: *> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; *> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). *> *> On exit, AB is overwritten by values generated during the *> reduction to tridiagonal form. If UPLO = 'U', the first *> superdiagonal and the diagonal of the tridiagonal matrix T *> are returned in rows KD and KD+1 of AB, and if UPLO = 'L', *> the diagonal and first subdiagonal of T are returned in the *> first two rows of AB. *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array AB. LDAB >= KD + 1. *> \endverbatim *> *> \param[out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> If INFO = 0, the eigenvalues in ascending order. *> \endverbatim *> *> \param[out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ, N) *> If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal *> eigenvectors of the matrix A, with the i-th column of Z *> holding the eigenvector associated with W(i). *> If JOBZ = 'N', then Z is not referenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1, and if *> JOBZ = 'V', LDZ >= max(1,N). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (max(1,3*N-2)) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, the algorithm failed to converge; i *> off-diagonal elements of an intermediate tridiagonal *> form did not converge to zero. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHEReigen * * ===================================================================== SUBROUTINE DSBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, $ INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO INTEGER INFO, KD, LDAB, LDZ, N * .. * .. Array Arguments .. DOUBLE PRECISION AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL LOWER, WANTZ INTEGER IINFO, IMAX, INDE, INDWRK, ISCALE DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, $ SMLNUM * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANSB EXTERNAL LSAME, DLAMCH, DLANSB * .. * .. External Subroutines .. EXTERNAL DLASCL, DSBTRD, DSCAL, DSTEQR, DSTERF, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC SQRT * .. * .. Executable Statements .. * * Test the input parameters. * WANTZ = LSAME( JOBZ, 'V' ) LOWER = LSAME( UPLO, 'L' ) * INFO = 0 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( KD.LT.0 ) THEN INFO = -4 ELSE IF( LDAB.LT.KD+1 ) THEN INFO = -6 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN INFO = -9 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSBEV ', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( N.EQ.1 ) THEN IF( LOWER ) THEN W( 1 ) = AB( 1, 1 ) ELSE W( 1 ) = AB( KD+1, 1 ) END IF IF( WANTZ ) $ Z( 1, 1 ) = ONE RETURN END IF * * Get machine constants. * SAFMIN = DLAMCH( 'Safe minimum' ) EPS = DLAMCH( 'Precision' ) SMLNUM = SAFMIN / EPS BIGNUM = ONE / SMLNUM RMIN = SQRT( SMLNUM ) RMAX = SQRT( BIGNUM ) * * Scale matrix to allowable range, if necessary. * ANRM = DLANSB( 'M', UPLO, N, KD, AB, LDAB, WORK ) ISCALE = 0 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN ISCALE = 1 SIGMA = RMAX / ANRM END IF IF( ISCALE.EQ.1 ) THEN IF( LOWER ) THEN CALL DLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) ELSE CALL DLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) END IF END IF * * Call DSBTRD to reduce symmetric band matrix to tridiagonal form. * INDE = 1 INDWRK = INDE + N CALL DSBTRD( JOBZ, UPLO, N, KD, AB, LDAB, W, WORK( INDE ), Z, LDZ, $ WORK( INDWRK ), IINFO ) * * For eigenvalues only, call DSTERF. For eigenvectors, call SSTEQR. * IF( .NOT.WANTZ ) THEN CALL DSTERF( N, W, WORK( INDE ), INFO ) ELSE CALL DSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDWRK ), $ INFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * IF( ISCALE.EQ.1 ) THEN IF( INFO.EQ.0 ) THEN IMAX = N ELSE IMAX = INFO - 1 END IF CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) END IF * RETURN * * End of DSBEV * END *> \brief DSBEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSBEVD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, * LWORK, IWORK, LIWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, KD, LDAB, LDZ, LIWORK, LWORK, N * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSBEVD computes all the eigenvalues and, optionally, eigenvectors of *> a real symmetric band matrix A. If eigenvectors are desired, it uses *> a divide and conquer algorithm. *> *> The divide and conquer algorithm makes very mild assumptions about *> floating point arithmetic. It will work on machines with a guard *> digit in add/subtract, or on those binary machines without guard *> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or *> Cray-2. It could conceivably fail on hexadecimal or decimal machines *> without guard digits, but we know of none. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBZ *> \verbatim *> JOBZ is CHARACTER*1 *> = 'N': Compute eigenvalues only; *> = 'V': Compute eigenvalues and eigenvectors. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] KD *> \verbatim *> KD is INTEGER *> The number of superdiagonals of the matrix A if UPLO = 'U', *> or the number of subdiagonals if UPLO = 'L'. KD >= 0. *> \endverbatim *> *> \param[in,out] AB *> \verbatim *> AB is DOUBLE PRECISION array, dimension (LDAB, N) *> On entry, the upper or lower triangle of the symmetric band *> matrix A, stored in the first KD+1 rows of the array. The *> j-th column of A is stored in the j-th column of the array AB *> as follows: *> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; *> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). *> *> On exit, AB is overwritten by values generated during the *> reduction to tridiagonal form. If UPLO = 'U', the first *> superdiagonal and the diagonal of the tridiagonal matrix T *> are returned in rows KD and KD+1 of AB, and if UPLO = 'L', *> the diagonal and first subdiagonal of T are returned in the *> first two rows of AB. *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array AB. LDAB >= KD + 1. *> \endverbatim *> *> \param[out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> If INFO = 0, the eigenvalues in ascending order. *> \endverbatim *> *> \param[out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ, N) *> If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal *> eigenvectors of the matrix A, with the i-th column of Z *> holding the eigenvector associated with W(i). *> If JOBZ = 'N', then Z is not referenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1, and if *> JOBZ = 'V', LDZ >= max(1,N). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, *> dimension (LWORK) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. *> IF N <= 1, LWORK must be at least 1. *> If JOBZ = 'N' and N > 2, LWORK must be at least 2*N. *> If JOBZ = 'V' and N > 2, LWORK must be at least *> ( 1 + 5*N + 2*N**2 ). *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal sizes of the WORK and IWORK *> arrays, returns these values as the first entries of the WORK *> and IWORK arrays, and no error message related to LWORK or *> LIWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) *> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. *> \endverbatim *> *> \param[in] LIWORK *> \verbatim *> LIWORK is INTEGER *> The dimension of the array IWORK. *> If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. *> If JOBZ = 'V' and N > 2, LIWORK must be at least 3 + 5*N. *> *> If LIWORK = -1, then a workspace query is assumed; the *> routine only calculates the optimal sizes of the WORK and *> IWORK arrays, returns these values as the first entries of *> the WORK and IWORK arrays, and no error message related to *> LWORK or LIWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, the algorithm failed to converge; i *> off-diagonal elements of an intermediate tridiagonal *> form did not converge to zero. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHEReigen * * ===================================================================== SUBROUTINE DSBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, $ LWORK, IWORK, LIWORK, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO INTEGER INFO, KD, LDAB, LDZ, LIWORK, LWORK, N * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LOWER, LQUERY, WANTZ INTEGER IINFO, INDE, INDWK2, INDWRK, ISCALE, LIWMIN, $ LLWRK2, LWMIN DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, $ SMLNUM * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANSB EXTERNAL LSAME, DLAMCH, DLANSB * .. * .. External Subroutines .. EXTERNAL DGEMM, DLACPY, DLASCL, DSBTRD, DSCAL, DSTEDC, $ DSTERF, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC SQRT * .. * .. Executable Statements .. * * Test the input parameters. * WANTZ = LSAME( JOBZ, 'V' ) LOWER = LSAME( UPLO, 'L' ) LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) * INFO = 0 IF( N.LE.1 ) THEN LIWMIN = 1 LWMIN = 1 ELSE IF( WANTZ ) THEN LIWMIN = 3 + 5*N LWMIN = 1 + 5*N + 2*N**2 ELSE LIWMIN = 1 LWMIN = 2*N END IF END IF IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( KD.LT.0 ) THEN INFO = -4 ELSE IF( LDAB.LT.KD+1 ) THEN INFO = -6 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN INFO = -9 END IF * IF( INFO.EQ.0 ) THEN WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN * IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN INFO = -11 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN INFO = -13 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSBEVD', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( N.EQ.1 ) THEN W( 1 ) = AB( 1, 1 ) IF( WANTZ ) $ Z( 1, 1 ) = ONE RETURN END IF * * Get machine constants. * SAFMIN = DLAMCH( 'Safe minimum' ) EPS = DLAMCH( 'Precision' ) SMLNUM = SAFMIN / EPS BIGNUM = ONE / SMLNUM RMIN = SQRT( SMLNUM ) RMAX = SQRT( BIGNUM ) * * Scale matrix to allowable range, if necessary. * ANRM = DLANSB( 'M', UPLO, N, KD, AB, LDAB, WORK ) ISCALE = 0 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN ISCALE = 1 SIGMA = RMAX / ANRM END IF IF( ISCALE.EQ.1 ) THEN IF( LOWER ) THEN CALL DLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) ELSE CALL DLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) END IF END IF * * Call DSBTRD to reduce symmetric band matrix to tridiagonal form. * INDE = 1 INDWRK = INDE + N INDWK2 = INDWRK + N*N LLWRK2 = LWORK - INDWK2 + 1 CALL DSBTRD( JOBZ, UPLO, N, KD, AB, LDAB, W, WORK( INDE ), Z, LDZ, $ WORK( INDWRK ), IINFO ) * * For eigenvalues only, call DSTERF. For eigenvectors, call SSTEDC. * IF( .NOT.WANTZ ) THEN CALL DSTERF( N, W, WORK( INDE ), INFO ) ELSE CALL DSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N, $ WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO ) CALL DGEMM( 'N', 'N', N, N, N, ONE, Z, LDZ, WORK( INDWRK ), N, $ ZERO, WORK( INDWK2 ), N ) CALL DLACPY( 'A', N, N, WORK( INDWK2 ), N, Z, LDZ ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * IF( ISCALE.EQ.1 ) $ CALL DSCAL( N, ONE / SIGMA, W, 1 ) * WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN RETURN * * End of DSBEVD * END *> \brief DSBEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSBEVX + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, * VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, * IFAIL, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N * DOUBLE PRECISION ABSTOL, VL, VU * .. * .. Array Arguments .. * INTEGER IFAIL( * ), IWORK( * ) * DOUBLE PRECISION AB( LDAB, * ), Q( LDQ, * ), W( * ), WORK( * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSBEVX computes selected eigenvalues and, optionally, eigenvectors *> of a real symmetric band matrix A. Eigenvalues and eigenvectors can *> be selected by specifying either a range of values or a range of *> indices for the desired eigenvalues. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBZ *> \verbatim *> JOBZ is CHARACTER*1 *> = 'N': Compute eigenvalues only; *> = 'V': Compute eigenvalues and eigenvectors. *> \endverbatim *> *> \param[in] RANGE *> \verbatim *> RANGE is CHARACTER*1 *> = 'A': all eigenvalues will be found; *> = 'V': all eigenvalues in the half-open interval (VL,VU] *> will be found; *> = 'I': the IL-th through IU-th eigenvalues will be found. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] KD *> \verbatim *> KD is INTEGER *> The number of superdiagonals of the matrix A if UPLO = 'U', *> or the number of subdiagonals if UPLO = 'L'. KD >= 0. *> \endverbatim *> *> \param[in,out] AB *> \verbatim *> AB is DOUBLE PRECISION array, dimension (LDAB, N) *> On entry, the upper or lower triangle of the symmetric band *> matrix A, stored in the first KD+1 rows of the array. The *> j-th column of A is stored in the j-th column of the array AB *> as follows: *> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; *> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). *> *> On exit, AB is overwritten by values generated during the *> reduction to tridiagonal form. If UPLO = 'U', the first *> superdiagonal and the diagonal of the tridiagonal matrix T *> are returned in rows KD and KD+1 of AB, and if UPLO = 'L', *> the diagonal and first subdiagonal of T are returned in the *> first two rows of AB. *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array AB. LDAB >= KD + 1. *> \endverbatim *> *> \param[out] Q *> \verbatim *> Q is DOUBLE PRECISION array, dimension (LDQ, N) *> If JOBZ = 'V', the N-by-N orthogonal matrix used in the *> reduction to tridiagonal form. *> If JOBZ = 'N', the array Q is not referenced. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. If JOBZ = 'V', then *> LDQ >= max(1,N). *> \endverbatim *> *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION *> If RANGE='V', the lower bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION *> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] IL *> \verbatim *> IL is INTEGER *> If RANGE='I', the index of the *> smallest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> If RANGE='I', the index of the *> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] ABSTOL *> \verbatim *> ABSTOL is DOUBLE PRECISION *> The absolute error tolerance for the eigenvalues. *> An approximate eigenvalue is accepted as converged *> when it is determined to lie in an interval [a,b] *> of width less than or equal to *> *> ABSTOL + EPS * max( |a|,|b| ) , *> *> where EPS is the machine precision. If ABSTOL is less than *> or equal to zero, then EPS*|T| will be used in its place, *> where |T| is the 1-norm of the tridiagonal matrix obtained *> by reducing AB to tridiagonal form. *> *> Eigenvalues will be computed most accurately when ABSTOL is *> set to twice the underflow threshold 2*DLAMCH('S'), not zero. *> If this routine returns with INFO>0, indicating that some *> eigenvectors did not converge, try setting ABSTOL to *> 2*DLAMCH('S'). *> *> See "Computing Small Singular Values of Bidiagonal Matrices *> with Guaranteed High Relative Accuracy," by Demmel and *> Kahan, LAPACK Working Note #3. *> \endverbatim *> *> \param[out] M *> \verbatim *> M is INTEGER *> The total number of eigenvalues found. 0 <= M <= N. *> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. *> \endverbatim *> *> \param[out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> The first M elements contain the selected eigenvalues in *> ascending order. *> \endverbatim *> *> \param[out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M)) *> If JOBZ = 'V', then if INFO = 0, the first M columns of Z *> contain the orthonormal eigenvectors of the matrix A *> corresponding to the selected eigenvalues, with the i-th *> column of Z holding the eigenvector associated with W(i). *> If an eigenvector fails to converge, then that column of Z *> contains the latest approximation to the eigenvector, and the *> index of the eigenvector is returned in IFAIL. *> If JOBZ = 'N', then Z is not referenced. *> Note: the user must ensure that at least max(1,M) columns are *> supplied in the array Z; if RANGE = 'V', the exact value of M *> is not known in advance and an upper bound must be used. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1, and if *> JOBZ = 'V', LDZ >= max(1,N). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (7*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (5*N) *> \endverbatim *> *> \param[out] IFAIL *> \verbatim *> IFAIL is INTEGER array, dimension (N) *> If JOBZ = 'V', then if INFO = 0, the first M elements of *> IFAIL are zero. If INFO > 0, then IFAIL contains the *> indices of the eigenvectors that failed to converge. *> If JOBZ = 'N', then IFAIL is not referenced. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: if INFO = i, then i eigenvectors failed to converge. *> Their indices are stored in array IFAIL. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleOTHEReigen * * ===================================================================== SUBROUTINE DSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, $ VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, $ IFAIL, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO INTEGER IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N DOUBLE PRECISION ABSTOL, VL, VU * .. * .. Array Arguments .. INTEGER IFAIL( * ), IWORK( * ) DOUBLE PRECISION AB( LDAB, * ), Q( LDQ, * ), W( * ), WORK( * ), $ Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL ALLEIG, INDEIG, LOWER, TEST, VALEIG, WANTZ CHARACTER ORDER INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, $ INDISP, INDIWO, INDWRK, ISCALE, ITMP1, J, JJ, $ NSPLIT DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, $ SIGMA, SMLNUM, TMP1, VLL, VUU * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANSB EXTERNAL LSAME, DLAMCH, DLANSB * .. * .. External Subroutines .. EXTERNAL DCOPY, DGEMV, DLACPY, DLASCL, DSBTRD, DSCAL, $ DSTEBZ, DSTEIN, DSTEQR, DSTERF, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * WANTZ = LSAME( JOBZ, 'V' ) ALLEIG = LSAME( RANGE, 'A' ) VALEIG = LSAME( RANGE, 'V' ) INDEIG = LSAME( RANGE, 'I' ) LOWER = LSAME( UPLO, 'L' ) * INFO = 0 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN INFO = -2 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( KD.LT.0 ) THEN INFO = -5 ELSE IF( LDAB.LT.KD+1 ) THEN INFO = -7 ELSE IF( WANTZ .AND. LDQ.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( VALEIG ) THEN IF( N.GT.0 .AND. VU.LE.VL ) $ INFO = -11 ELSE IF( INDEIG ) THEN IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN INFO = -12 ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN INFO = -13 END IF END IF END IF IF( INFO.EQ.0 ) THEN IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) $ INFO = -18 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSBEVX', -INFO ) RETURN END IF * * Quick return if possible * M = 0 IF( N.EQ.0 ) $ RETURN * IF( N.EQ.1 ) THEN M = 1 IF( LOWER ) THEN TMP1 = AB( 1, 1 ) ELSE TMP1 = AB( KD+1, 1 ) END IF IF( VALEIG ) THEN IF( .NOT.( VL.LT.TMP1 .AND. VU.GE.TMP1 ) ) $ M = 0 END IF IF( M.EQ.1 ) THEN W( 1 ) = TMP1 IF( WANTZ ) $ Z( 1, 1 ) = ONE END IF RETURN END IF * * Get machine constants. * SAFMIN = DLAMCH( 'Safe minimum' ) EPS = DLAMCH( 'Precision' ) SMLNUM = SAFMIN / EPS BIGNUM = ONE / SMLNUM RMIN = SQRT( SMLNUM ) RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) * * Scale matrix to allowable range, if necessary. * ISCALE = 0 ABSTLL = ABSTOL IF( VALEIG ) THEN VLL = VL VUU = VU ELSE VLL = ZERO VUU = ZERO END IF ANRM = DLANSB( 'M', UPLO, N, KD, AB, LDAB, WORK ) IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN ISCALE = 1 SIGMA = RMAX / ANRM END IF IF( ISCALE.EQ.1 ) THEN IF( LOWER ) THEN CALL DLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) ELSE CALL DLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) END IF IF( ABSTOL.GT.0 ) $ ABSTLL = ABSTOL*SIGMA IF( VALEIG ) THEN VLL = VL*SIGMA VUU = VU*SIGMA END IF END IF * * Call DSBTRD to reduce symmetric band matrix to tridiagonal form. * INDD = 1 INDE = INDD + N INDWRK = INDE + N CALL DSBTRD( JOBZ, UPLO, N, KD, AB, LDAB, WORK( INDD ), $ WORK( INDE ), Q, LDQ, WORK( INDWRK ), IINFO ) * * If all eigenvalues are desired and ABSTOL is less than or equal * to zero, then call DSTERF or SSTEQR. If this fails for some * eigenvalue, then try DSTEBZ. * TEST = .FALSE. IF (INDEIG) THEN IF (IL.EQ.1 .AND. IU.EQ.N) THEN TEST = .TRUE. END IF END IF IF ((ALLEIG .OR. TEST) .AND. (ABSTOL.LE.ZERO)) THEN CALL DCOPY( N, WORK( INDD ), 1, W, 1 ) INDEE = INDWRK + 2*N IF( .NOT.WANTZ ) THEN CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) CALL DSTERF( N, W, WORK( INDEE ), INFO ) ELSE CALL DLACPY( 'A', N, N, Q, LDQ, Z, LDZ ) CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ, $ WORK( INDWRK ), INFO ) IF( INFO.EQ.0 ) THEN DO 10 I = 1, N IFAIL( I ) = 0 10 CONTINUE END IF END IF IF( INFO.EQ.0 ) THEN M = N GO TO 30 END IF INFO = 0 END IF * * Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. * IF( WANTZ ) THEN ORDER = 'B' ELSE ORDER = 'E' END IF INDIBL = 1 INDISP = INDIBL + N INDIWO = INDISP + N CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W, $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ), $ IWORK( INDIWO ), INFO ) * IF( WANTZ ) THEN CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, $ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO ) * * Apply orthogonal matrix used in reduction to tridiagonal * form to eigenvectors returned by DSTEIN. * DO 20 J = 1, M CALL DCOPY( N, Z( 1, J ), 1, WORK( 1 ), 1 ) CALL DGEMV( 'N', N, N, ONE, Q, LDQ, WORK, 1, ZERO, $ Z( 1, J ), 1 ) 20 CONTINUE END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * 30 CONTINUE IF( ISCALE.EQ.1 ) THEN IF( INFO.EQ.0 ) THEN IMAX = M ELSE IMAX = INFO - 1 END IF CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) END IF * * If eigenvalues are not in order, then sort them, along with * eigenvectors. * IF( WANTZ ) THEN DO 50 J = 1, M - 1 I = 0 TMP1 = W( J ) DO 40 JJ = J + 1, M IF( W( JJ ).LT.TMP1 ) THEN I = JJ TMP1 = W( JJ ) END IF 40 CONTINUE * IF( I.NE.0 ) THEN ITMP1 = IWORK( INDIBL+I-1 ) W( I ) = W( J ) IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) W( J ) = TMP1 IWORK( INDIBL+J-1 ) = ITMP1 CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) IF( INFO.NE.0 ) THEN ITMP1 = IFAIL( I ) IFAIL( I ) = IFAIL( J ) IFAIL( J ) = ITMP1 END IF END IF 50 CONTINUE END IF * RETURN * * End of DSBEVX * END *> \brief \b DSBGST * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSBGST + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, * LDX, WORK, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO, VECT * INTEGER INFO, KA, KB, LDAB, LDBB, LDX, N * .. * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), WORK( * ), * $ X( LDX, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSBGST reduces a real symmetric-definite banded generalized *> eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y, *> such that C has the same bandwidth as A. *> *> B must have been previously factorized as S**T*S by DPBSTF, using a *> split Cholesky factorization. A is overwritten by C = X**T*A*X, where *> X = S**(-1)*Q and Q is an orthogonal matrix chosen to preserve the *> bandwidth of A. *> \endverbatim * * Arguments: * ========== * *> \param[in] VECT *> \verbatim *> VECT is CHARACTER*1 *> = 'N': do not form the transformation matrix X; *> = 'V': form X. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A and B. N >= 0. *> \endverbatim *> *> \param[in] KA *> \verbatim *> KA is INTEGER *> The number of superdiagonals of the matrix A if UPLO = 'U', *> or the number of subdiagonals if UPLO = 'L'. KA >= 0. *> \endverbatim *> *> \param[in] KB *> \verbatim *> KB is INTEGER *> The number of superdiagonals of the matrix B if UPLO = 'U', *> or the number of subdiagonals if UPLO = 'L'. KA >= KB >= 0. *> \endverbatim *> *> \param[in,out] AB *> \verbatim *> AB is DOUBLE PRECISION array, dimension (LDAB,N) *> On entry, the upper or lower triangle of the symmetric band *> matrix A, stored in the first ka+1 rows of the array. The *> j-th column of A is stored in the j-th column of the array AB *> as follows: *> if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; *> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). *> *> On exit, the transformed matrix X**T*A*X, stored in the same *> format as A. *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array AB. LDAB >= KA+1. *> \endverbatim *> *> \param[in] BB *> \verbatim *> BB is DOUBLE PRECISION array, dimension (LDBB,N) *> The banded factor S from the split Cholesky factorization of *> B, as returned by DPBSTF, stored in the first KB+1 rows of *> the array. *> \endverbatim *> *> \param[in] LDBB *> \verbatim *> LDBB is INTEGER *> The leading dimension of the array BB. LDBB >= KB+1. *> \endverbatim *> *> \param[out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,N) *> If VECT = 'V', the n-by-n matrix X. *> If VECT = 'N', the array X is not referenced. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the array X. *> LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (2*N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DSBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, $ LDX, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO, VECT INTEGER INFO, KA, KB, LDAB, LDBB, LDX, N * .. * .. Array Arguments .. DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), WORK( * ), $ X( LDX, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPDATE, UPPER, WANTX INTEGER I, I0, I1, I2, INCA, J, J1, J1T, J2, J2T, K, $ KA1, KB1, KBT, L, M, NR, NRT, NX DOUBLE PRECISION BII, RA, RA1, T * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DGER, DLAR2V, DLARGV, DLARTG, DLARTV, DLASET, $ DROT, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters * WANTX = LSAME( VECT, 'V' ) UPPER = LSAME( UPLO, 'U' ) KA1 = KA + 1 KB1 = KB + 1 INFO = 0 IF( .NOT.WANTX .AND. .NOT.LSAME( VECT, 'N' ) ) THEN INFO = -1 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( KA.LT.0 ) THEN INFO = -4 ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN INFO = -5 ELSE IF( LDAB.LT.KA+1 ) THEN INFO = -7 ELSE IF( LDBB.LT.KB+1 ) THEN INFO = -9 ELSE IF( LDX.LT.1 .OR. WANTX .AND. LDX.LT.MAX( 1, N ) ) THEN INFO = -11 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSBGST', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * INCA = LDAB*KA1 * * Initialize X to the unit matrix, if needed * IF( WANTX ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, X, LDX ) * * Set M to the splitting point m. It must be the same value as is * used in DPBSTF. The chosen value allows the arrays WORK and RWORK * to be of dimension (N). * M = ( N+KB ) / 2 * * The routine works in two phases, corresponding to the two halves * of the split Cholesky factorization of B as S**T*S where * * S = ( U ) * ( M L ) * * with U upper triangular of order m, and L lower triangular of * order n-m. S has the same bandwidth as B. * * S is treated as a product of elementary matrices: * * S = S(m)*S(m-1)*...*S(2)*S(1)*S(m+1)*S(m+2)*...*S(n-1)*S(n) * * where S(i) is determined by the i-th row of S. * * In phase 1, the index i takes the values n, n-1, ... , m+1; * in phase 2, it takes the values 1, 2, ... , m. * * For each value of i, the current matrix A is updated by forming * inv(S(i))**T*A*inv(S(i)). This creates a triangular bulge outside * the band of A. The bulge is then pushed down toward the bottom of * A in phase 1, and up toward the top of A in phase 2, by applying * plane rotations. * * There are kb*(kb+1)/2 elements in the bulge, but at most 2*kb-1 * of them are linearly independent, so annihilating a bulge requires * only 2*kb-1 plane rotations. The rotations are divided into a 1st * set of kb-1 rotations, and a 2nd set of kb rotations. * * Wherever possible, rotations are generated and applied in vector * operations of length NR between the indices J1 and J2 (sometimes * replaced by modified values NRT, J1T or J2T). * * The cosines and sines of the rotations are stored in the array * WORK. The cosines of the 1st set of rotations are stored in * elements n+2:n+m-kb-1 and the sines of the 1st set in elements * 2:m-kb-1; the cosines of the 2nd set are stored in elements * n+m-kb+1:2*n and the sines of the second set in elements m-kb+1:n. * * The bulges are not formed explicitly; nonzero elements outside the * band are created only when they are required for generating new * rotations; they are stored in the array WORK, in positions where * they are later overwritten by the sines of the rotations which * annihilate them. * * **************************** Phase 1 ***************************** * * The logical structure of this phase is: * * UPDATE = .TRUE. * DO I = N, M + 1, -1 * use S(i) to update A and create a new bulge * apply rotations to push all bulges KA positions downward * END DO * UPDATE = .FALSE. * DO I = M + KA + 1, N - 1 * apply rotations to push all bulges KA positions downward * END DO * * To avoid duplicating code, the two loops are merged. * UPDATE = .TRUE. I = N + 1 10 CONTINUE IF( UPDATE ) THEN I = I - 1 KBT = MIN( KB, I-1 ) I0 = I - 1 I1 = MIN( N, I+KA ) I2 = I - KBT + KA1 IF( I.LT.M+1 ) THEN UPDATE = .FALSE. I = I + 1 I0 = M IF( KA.EQ.0 ) $ GO TO 480 GO TO 10 END IF ELSE I = I + KA IF( I.GT.N-1 ) $ GO TO 480 END IF * IF( UPPER ) THEN * * Transform A, working with the upper triangle * IF( UPDATE ) THEN * * Form inv(S(i))**T * A * inv(S(i)) * BII = BB( KB1, I ) DO 20 J = I, I1 AB( I-J+KA1, J ) = AB( I-J+KA1, J ) / BII 20 CONTINUE DO 30 J = MAX( 1, I-KA ), I AB( J-I+KA1, I ) = AB( J-I+KA1, I ) / BII 30 CONTINUE DO 60 K = I - KBT, I - 1 DO 40 J = I - KBT, K AB( J-K+KA1, K ) = AB( J-K+KA1, K ) - $ BB( J-I+KB1, I )*AB( K-I+KA1, I ) - $ BB( K-I+KB1, I )*AB( J-I+KA1, I ) + $ AB( KA1, I )*BB( J-I+KB1, I )* $ BB( K-I+KB1, I ) 40 CONTINUE DO 50 J = MAX( 1, I-KA ), I - KBT - 1 AB( J-K+KA1, K ) = AB( J-K+KA1, K ) - $ BB( K-I+KB1, I )*AB( J-I+KA1, I ) 50 CONTINUE 60 CONTINUE DO 80 J = I, I1 DO 70 K = MAX( J-KA, I-KBT ), I - 1 AB( K-J+KA1, J ) = AB( K-J+KA1, J ) - $ BB( K-I+KB1, I )*AB( I-J+KA1, J ) 70 CONTINUE 80 CONTINUE * IF( WANTX ) THEN * * post-multiply X by inv(S(i)) * CALL DSCAL( N-M, ONE / BII, X( M+1, I ), 1 ) IF( KBT.GT.0 ) $ CALL DGER( N-M, KBT, -ONE, X( M+1, I ), 1, $ BB( KB1-KBT, I ), 1, X( M+1, I-KBT ), LDX ) END IF * * store a(i,i1) in RA1 for use in next loop over K * RA1 = AB( I-I1+KA1, I1 ) END IF * * Generate and apply vectors of rotations to chase all the * existing bulges KA positions down toward the bottom of the * band * DO 130 K = 1, KB - 1 IF( UPDATE ) THEN * * Determine the rotations which would annihilate the bulge * which has in theory just been created * IF( I-K+KA.LT.N .AND. I-K.GT.1 ) THEN * * generate rotation to annihilate a(i,i-k+ka+1) * CALL DLARTG( AB( K+1, I-K+KA ), RA1, $ WORK( N+I-K+KA-M ), WORK( I-K+KA-M ), $ RA ) * * create nonzero element a(i-k,i-k+ka+1) outside the * band and store it in WORK(i-k) * T = -BB( KB1-K, I )*RA1 WORK( I-K ) = WORK( N+I-K+KA-M )*T - $ WORK( I-K+KA-M )*AB( 1, I-K+KA ) AB( 1, I-K+KA ) = WORK( I-K+KA-M )*T + $ WORK( N+I-K+KA-M )*AB( 1, I-K+KA ) RA1 = RA END IF END IF J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1 NR = ( N-J2+KA ) / KA1 J1 = J2 + ( NR-1 )*KA1 IF( UPDATE ) THEN J2T = MAX( J2, I+2*KA-K+1 ) ELSE J2T = J2 END IF NRT = ( N-J2T+KA ) / KA1 DO 90 J = J2T, J1, KA1 * * create nonzero element a(j-ka,j+1) outside the band * and store it in WORK(j-m) * WORK( J-M ) = WORK( J-M )*AB( 1, J+1 ) AB( 1, J+1 ) = WORK( N+J-M )*AB( 1, J+1 ) 90 CONTINUE * * generate rotations in 1st set to annihilate elements which * have been created outside the band * IF( NRT.GT.0 ) $ CALL DLARGV( NRT, AB( 1, J2T ), INCA, WORK( J2T-M ), KA1, $ WORK( N+J2T-M ), KA1 ) IF( NR.GT.0 ) THEN * * apply rotations in 1st set from the right * DO 100 L = 1, KA - 1 CALL DLARTV( NR, AB( KA1-L, J2 ), INCA, $ AB( KA-L, J2+1 ), INCA, WORK( N+J2-M ), $ WORK( J2-M ), KA1 ) 100 CONTINUE * * apply rotations in 1st set from both sides to diagonal * blocks * CALL DLAR2V( NR, AB( KA1, J2 ), AB( KA1, J2+1 ), $ AB( KA, J2+1 ), INCA, WORK( N+J2-M ), $ WORK( J2-M ), KA1 ) * END IF * * start applying rotations in 1st set from the left * DO 110 L = KA - 1, KB - K + 1, -1 NRT = ( N-J2+L ) / KA1 IF( NRT.GT.0 ) $ CALL DLARTV( NRT, AB( L, J2+KA1-L ), INCA, $ AB( L+1, J2+KA1-L ), INCA, $ WORK( N+J2-M ), WORK( J2-M ), KA1 ) 110 CONTINUE * IF( WANTX ) THEN * * post-multiply X by product of rotations in 1st set * DO 120 J = J2, J1, KA1 CALL DROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1, $ WORK( N+J-M ), WORK( J-M ) ) 120 CONTINUE END IF 130 CONTINUE * IF( UPDATE ) THEN IF( I2.LE.N .AND. KBT.GT.0 ) THEN * * create nonzero element a(i-kbt,i-kbt+ka+1) outside the * band and store it in WORK(i-kbt) * WORK( I-KBT ) = -BB( KB1-KBT, I )*RA1 END IF END IF * DO 170 K = KB, 1, -1 IF( UPDATE ) THEN J2 = I - K - 1 + MAX( 2, K-I0+1 )*KA1 ELSE J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1 END IF * * finish applying rotations in 2nd set from the left * DO 140 L = KB - K, 1, -1 NRT = ( N-J2+KA+L ) / KA1 IF( NRT.GT.0 ) $ CALL DLARTV( NRT, AB( L, J2-L+1 ), INCA, $ AB( L+1, J2-L+1 ), INCA, WORK( N+J2-KA ), $ WORK( J2-KA ), KA1 ) 140 CONTINUE NR = ( N-J2+KA ) / KA1 J1 = J2 + ( NR-1 )*KA1 DO 150 J = J1, J2, -KA1 WORK( J ) = WORK( J-KA ) WORK( N+J ) = WORK( N+J-KA ) 150 CONTINUE DO 160 J = J2, J1, KA1 * * create nonzero element a(j-ka,j+1) outside the band * and store it in WORK(j) * WORK( J ) = WORK( J )*AB( 1, J+1 ) AB( 1, J+1 ) = WORK( N+J )*AB( 1, J+1 ) 160 CONTINUE IF( UPDATE ) THEN IF( I-K.LT.N-KA .AND. K.LE.KBT ) $ WORK( I-K+KA ) = WORK( I-K ) END IF 170 CONTINUE * DO 210 K = KB, 1, -1 J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1 NR = ( N-J2+KA ) / KA1 J1 = J2 + ( NR-1 )*KA1 IF( NR.GT.0 ) THEN * * generate rotations in 2nd set to annihilate elements * which have been created outside the band * CALL DLARGV( NR, AB( 1, J2 ), INCA, WORK( J2 ), KA1, $ WORK( N+J2 ), KA1 ) * * apply rotations in 2nd set from the right * DO 180 L = 1, KA - 1 CALL DLARTV( NR, AB( KA1-L, J2 ), INCA, $ AB( KA-L, J2+1 ), INCA, WORK( N+J2 ), $ WORK( J2 ), KA1 ) 180 CONTINUE * * apply rotations in 2nd set from both sides to diagonal * blocks * CALL DLAR2V( NR, AB( KA1, J2 ), AB( KA1, J2+1 ), $ AB( KA, J2+1 ), INCA, WORK( N+J2 ), $ WORK( J2 ), KA1 ) * END IF * * start applying rotations in 2nd set from the left * DO 190 L = KA - 1, KB - K + 1, -1 NRT = ( N-J2+L ) / KA1 IF( NRT.GT.0 ) $ CALL DLARTV( NRT, AB( L, J2+KA1-L ), INCA, $ AB( L+1, J2+KA1-L ), INCA, WORK( N+J2 ), $ WORK( J2 ), KA1 ) 190 CONTINUE * IF( WANTX ) THEN * * post-multiply X by product of rotations in 2nd set * DO 200 J = J2, J1, KA1 CALL DROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1, $ WORK( N+J ), WORK( J ) ) 200 CONTINUE END IF 210 CONTINUE * DO 230 K = 1, KB - 1 J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1 * * finish applying rotations in 1st set from the left * DO 220 L = KB - K, 1, -1 NRT = ( N-J2+L ) / KA1 IF( NRT.GT.0 ) $ CALL DLARTV( NRT, AB( L, J2+KA1-L ), INCA, $ AB( L+1, J2+KA1-L ), INCA, $ WORK( N+J2-M ), WORK( J2-M ), KA1 ) 220 CONTINUE 230 CONTINUE * IF( KB.GT.1 ) THEN DO 240 J = N - 1, I - KB + 2*KA + 1, -1 WORK( N+J-M ) = WORK( N+J-KA-M ) WORK( J-M ) = WORK( J-KA-M ) 240 CONTINUE END IF * ELSE * * Transform A, working with the lower triangle * IF( UPDATE ) THEN * * Form inv(S(i))**T * A * inv(S(i)) * BII = BB( 1, I ) DO 250 J = I, I1 AB( J-I+1, I ) = AB( J-I+1, I ) / BII 250 CONTINUE DO 260 J = MAX( 1, I-KA ), I AB( I-J+1, J ) = AB( I-J+1, J ) / BII 260 CONTINUE DO 290 K = I - KBT, I - 1 DO 270 J = I - KBT, K AB( K-J+1, J ) = AB( K-J+1, J ) - $ BB( I-J+1, J )*AB( I-K+1, K ) - $ BB( I-K+1, K )*AB( I-J+1, J ) + $ AB( 1, I )*BB( I-J+1, J )* $ BB( I-K+1, K ) 270 CONTINUE DO 280 J = MAX( 1, I-KA ), I - KBT - 1 AB( K-J+1, J ) = AB( K-J+1, J ) - $ BB( I-K+1, K )*AB( I-J+1, J ) 280 CONTINUE 290 CONTINUE DO 310 J = I, I1 DO 300 K = MAX( J-KA, I-KBT ), I - 1 AB( J-K+1, K ) = AB( J-K+1, K ) - $ BB( I-K+1, K )*AB( J-I+1, I ) 300 CONTINUE 310 CONTINUE * IF( WANTX ) THEN * * post-multiply X by inv(S(i)) * CALL DSCAL( N-M, ONE / BII, X( M+1, I ), 1 ) IF( KBT.GT.0 ) $ CALL DGER( N-M, KBT, -ONE, X( M+1, I ), 1, $ BB( KBT+1, I-KBT ), LDBB-1, $ X( M+1, I-KBT ), LDX ) END IF * * store a(i1,i) in RA1 for use in next loop over K * RA1 = AB( I1-I+1, I ) END IF * * Generate and apply vectors of rotations to chase all the * existing bulges KA positions down toward the bottom of the * band * DO 360 K = 1, KB - 1 IF( UPDATE ) THEN * * Determine the rotations which would annihilate the bulge * which has in theory just been created * IF( I-K+KA.LT.N .AND. I-K.GT.1 ) THEN * * generate rotation to annihilate a(i-k+ka+1,i) * CALL DLARTG( AB( KA1-K, I ), RA1, WORK( N+I-K+KA-M ), $ WORK( I-K+KA-M ), RA ) * * create nonzero element a(i-k+ka+1,i-k) outside the * band and store it in WORK(i-k) * T = -BB( K+1, I-K )*RA1 WORK( I-K ) = WORK( N+I-K+KA-M )*T - $ WORK( I-K+KA-M )*AB( KA1, I-K ) AB( KA1, I-K ) = WORK( I-K+KA-M )*T + $ WORK( N+I-K+KA-M )*AB( KA1, I-K ) RA1 = RA END IF END IF J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1 NR = ( N-J2+KA ) / KA1 J1 = J2 + ( NR-1 )*KA1 IF( UPDATE ) THEN J2T = MAX( J2, I+2*KA-K+1 ) ELSE J2T = J2 END IF NRT = ( N-J2T+KA ) / KA1 DO 320 J = J2T, J1, KA1 * * create nonzero element a(j+1,j-ka) outside the band * and store it in WORK(j-m) * WORK( J-M ) = WORK( J-M )*AB( KA1, J-KA+1 ) AB( KA1, J-KA+1 ) = WORK( N+J-M )*AB( KA1, J-KA+1 ) 320 CONTINUE * * generate rotations in 1st set to annihilate elements which * have been created outside the band * IF( NRT.GT.0 ) $ CALL DLARGV( NRT, AB( KA1, J2T-KA ), INCA, WORK( J2T-M ), $ KA1, WORK( N+J2T-M ), KA1 ) IF( NR.GT.0 ) THEN * * apply rotations in 1st set from the left * DO 330 L = 1, KA - 1 CALL DLARTV( NR, AB( L+1, J2-L ), INCA, $ AB( L+2, J2-L ), INCA, WORK( N+J2-M ), $ WORK( J2-M ), KA1 ) 330 CONTINUE * * apply rotations in 1st set from both sides to diagonal * blocks * CALL DLAR2V( NR, AB( 1, J2 ), AB( 1, J2+1 ), AB( 2, J2 ), $ INCA, WORK( N+J2-M ), WORK( J2-M ), KA1 ) * END IF * * start applying rotations in 1st set from the right * DO 340 L = KA - 1, KB - K + 1, -1 NRT = ( N-J2+L ) / KA1 IF( NRT.GT.0 ) $ CALL DLARTV( NRT, AB( KA1-L+1, J2 ), INCA, $ AB( KA1-L, J2+1 ), INCA, WORK( N+J2-M ), $ WORK( J2-M ), KA1 ) 340 CONTINUE * IF( WANTX ) THEN * * post-multiply X by product of rotations in 1st set * DO 350 J = J2, J1, KA1 CALL DROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1, $ WORK( N+J-M ), WORK( J-M ) ) 350 CONTINUE END IF 360 CONTINUE * IF( UPDATE ) THEN IF( I2.LE.N .AND. KBT.GT.0 ) THEN * * create nonzero element a(i-kbt+ka+1,i-kbt) outside the * band and store it in WORK(i-kbt) * WORK( I-KBT ) = -BB( KBT+1, I-KBT )*RA1 END IF END IF * DO 400 K = KB, 1, -1 IF( UPDATE ) THEN J2 = I - K - 1 + MAX( 2, K-I0+1 )*KA1 ELSE J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1 END IF * * finish applying rotations in 2nd set from the right * DO 370 L = KB - K, 1, -1 NRT = ( N-J2+KA+L ) / KA1 IF( NRT.GT.0 ) $ CALL DLARTV( NRT, AB( KA1-L+1, J2-KA ), INCA, $ AB( KA1-L, J2-KA+1 ), INCA, $ WORK( N+J2-KA ), WORK( J2-KA ), KA1 ) 370 CONTINUE NR = ( N-J2+KA ) / KA1 J1 = J2 + ( NR-1 )*KA1 DO 380 J = J1, J2, -KA1 WORK( J ) = WORK( J-KA ) WORK( N+J ) = WORK( N+J-KA ) 380 CONTINUE DO 390 J = J2, J1, KA1 * * create nonzero element a(j+1,j-ka) outside the band * and store it in WORK(j) * WORK( J ) = WORK( J )*AB( KA1, J-KA+1 ) AB( KA1, J-KA+1 ) = WORK( N+J )*AB( KA1, J-KA+1 ) 390 CONTINUE IF( UPDATE ) THEN IF( I-K.LT.N-KA .AND. K.LE.KBT ) $ WORK( I-K+KA ) = WORK( I-K ) END IF 400 CONTINUE * DO 440 K = KB, 1, -1 J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1 NR = ( N-J2+KA ) / KA1 J1 = J2 + ( NR-1 )*KA1 IF( NR.GT.0 ) THEN * * generate rotations in 2nd set to annihilate elements * which have been created outside the band * CALL DLARGV( NR, AB( KA1, J2-KA ), INCA, WORK( J2 ), KA1, $ WORK( N+J2 ), KA1 ) * * apply rotations in 2nd set from the left * DO 410 L = 1, KA - 1 CALL DLARTV( NR, AB( L+1, J2-L ), INCA, $ AB( L+2, J2-L ), INCA, WORK( N+J2 ), $ WORK( J2 ), KA1 ) 410 CONTINUE * * apply rotations in 2nd set from both sides to diagonal * blocks * CALL DLAR2V( NR, AB( 1, J2 ), AB( 1, J2+1 ), AB( 2, J2 ), $ INCA, WORK( N+J2 ), WORK( J2 ), KA1 ) * END IF * * start applying rotations in 2nd set from the right * DO 420 L = KA - 1, KB - K + 1, -1 NRT = ( N-J2+L ) / KA1 IF( NRT.GT.0 ) $ CALL DLARTV( NRT, AB( KA1-L+1, J2 ), INCA, $ AB( KA1-L, J2+1 ), INCA, WORK( N+J2 ), $ WORK( J2 ), KA1 ) 420 CONTINUE * IF( WANTX ) THEN * * post-multiply X by product of rotations in 2nd set * DO 430 J = J2, J1, KA1 CALL DROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1, $ WORK( N+J ), WORK( J ) ) 430 CONTINUE END IF 440 CONTINUE * DO 460 K = 1, KB - 1 J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1 * * finish applying rotations in 1st set from the right * DO 450 L = KB - K, 1, -1 NRT = ( N-J2+L ) / KA1 IF( NRT.GT.0 ) $ CALL DLARTV( NRT, AB( KA1-L+1, J2 ), INCA, $ AB( KA1-L, J2+1 ), INCA, WORK( N+J2-M ), $ WORK( J2-M ), KA1 ) 450 CONTINUE 460 CONTINUE * IF( KB.GT.1 ) THEN DO 470 J = N - 1, I - KB + 2*KA + 1, -1 WORK( N+J-M ) = WORK( N+J-KA-M ) WORK( J-M ) = WORK( J-KA-M ) 470 CONTINUE END IF * END IF * GO TO 10 * 480 CONTINUE * * **************************** Phase 2 ***************************** * * The logical structure of this phase is: * * UPDATE = .TRUE. * DO I = 1, M * use S(i) to update A and create a new bulge * apply rotations to push all bulges KA positions upward * END DO * UPDATE = .FALSE. * DO I = M - KA - 1, 2, -1 * apply rotations to push all bulges KA positions upward * END DO * * To avoid duplicating code, the two loops are merged. * UPDATE = .TRUE. I = 0 490 CONTINUE IF( UPDATE ) THEN I = I + 1 KBT = MIN( KB, M-I ) I0 = I + 1 I1 = MAX( 1, I-KA ) I2 = I + KBT - KA1 IF( I.GT.M ) THEN UPDATE = .FALSE. I = I - 1 I0 = M + 1 IF( KA.EQ.0 ) $ RETURN GO TO 490 END IF ELSE I = I - KA IF( I.LT.2 ) $ RETURN END IF * IF( I.LT.M-KBT ) THEN NX = M ELSE NX = N END IF * IF( UPPER ) THEN * * Transform A, working with the upper triangle * IF( UPDATE ) THEN * * Form inv(S(i))**T * A * inv(S(i)) * BII = BB( KB1, I ) DO 500 J = I1, I AB( J-I+KA1, I ) = AB( J-I+KA1, I ) / BII 500 CONTINUE DO 510 J = I, MIN( N, I+KA ) AB( I-J+KA1, J ) = AB( I-J+KA1, J ) / BII 510 CONTINUE DO 540 K = I + 1, I + KBT DO 520 J = K, I + KBT AB( K-J+KA1, J ) = AB( K-J+KA1, J ) - $ BB( I-J+KB1, J )*AB( I-K+KA1, K ) - $ BB( I-K+KB1, K )*AB( I-J+KA1, J ) + $ AB( KA1, I )*BB( I-J+KB1, J )* $ BB( I-K+KB1, K ) 520 CONTINUE DO 530 J = I + KBT + 1, MIN( N, I+KA ) AB( K-J+KA1, J ) = AB( K-J+KA1, J ) - $ BB( I-K+KB1, K )*AB( I-J+KA1, J ) 530 CONTINUE 540 CONTINUE DO 560 J = I1, I DO 550 K = I + 1, MIN( J+KA, I+KBT ) AB( J-K+KA1, K ) = AB( J-K+KA1, K ) - $ BB( I-K+KB1, K )*AB( J-I+KA1, I ) 550 CONTINUE 560 CONTINUE * IF( WANTX ) THEN * * post-multiply X by inv(S(i)) * CALL DSCAL( NX, ONE / BII, X( 1, I ), 1 ) IF( KBT.GT.0 ) $ CALL DGER( NX, KBT, -ONE, X( 1, I ), 1, BB( KB, I+1 ), $ LDBB-1, X( 1, I+1 ), LDX ) END IF * * store a(i1,i) in RA1 for use in next loop over K * RA1 = AB( I1-I+KA1, I ) END IF * * Generate and apply vectors of rotations to chase all the * existing bulges KA positions up toward the top of the band * DO 610 K = 1, KB - 1 IF( UPDATE ) THEN * * Determine the rotations which would annihilate the bulge * which has in theory just been created * IF( I+K-KA1.GT.0 .AND. I+K.LT.M ) THEN * * generate rotation to annihilate a(i+k-ka-1,i) * CALL DLARTG( AB( K+1, I ), RA1, WORK( N+I+K-KA ), $ WORK( I+K-KA ), RA ) * * create nonzero element a(i+k-ka-1,i+k) outside the * band and store it in WORK(m-kb+i+k) * T = -BB( KB1-K, I+K )*RA1 WORK( M-KB+I+K ) = WORK( N+I+K-KA )*T - $ WORK( I+K-KA )*AB( 1, I+K ) AB( 1, I+K ) = WORK( I+K-KA )*T + $ WORK( N+I+K-KA )*AB( 1, I+K ) RA1 = RA END IF END IF J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1 NR = ( J2+KA-1 ) / KA1 J1 = J2 - ( NR-1 )*KA1 IF( UPDATE ) THEN J2T = MIN( J2, I-2*KA+K-1 ) ELSE J2T = J2 END IF NRT = ( J2T+KA-1 ) / KA1 DO 570 J = J1, J2T, KA1 * * create nonzero element a(j-1,j+ka) outside the band * and store it in WORK(j) * WORK( J ) = WORK( J )*AB( 1, J+KA-1 ) AB( 1, J+KA-1 ) = WORK( N+J )*AB( 1, J+KA-1 ) 570 CONTINUE * * generate rotations in 1st set to annihilate elements which * have been created outside the band * IF( NRT.GT.0 ) $ CALL DLARGV( NRT, AB( 1, J1+KA ), INCA, WORK( J1 ), KA1, $ WORK( N+J1 ), KA1 ) IF( NR.GT.0 ) THEN * * apply rotations in 1st set from the left * DO 580 L = 1, KA - 1 CALL DLARTV( NR, AB( KA1-L, J1+L ), INCA, $ AB( KA-L, J1+L ), INCA, WORK( N+J1 ), $ WORK( J1 ), KA1 ) 580 CONTINUE * * apply rotations in 1st set from both sides to diagonal * blocks * CALL DLAR2V( NR, AB( KA1, J1 ), AB( KA1, J1-1 ), $ AB( KA, J1 ), INCA, WORK( N+J1 ), $ WORK( J1 ), KA1 ) * END IF * * start applying rotations in 1st set from the right * DO 590 L = KA - 1, KB - K + 1, -1 NRT = ( J2+L-1 ) / KA1 J1T = J2 - ( NRT-1 )*KA1 IF( NRT.GT.0 ) $ CALL DLARTV( NRT, AB( L, J1T ), INCA, $ AB( L+1, J1T-1 ), INCA, WORK( N+J1T ), $ WORK( J1T ), KA1 ) 590 CONTINUE * IF( WANTX ) THEN * * post-multiply X by product of rotations in 1st set * DO 600 J = J1, J2, KA1 CALL DROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1, $ WORK( N+J ), WORK( J ) ) 600 CONTINUE END IF 610 CONTINUE * IF( UPDATE ) THEN IF( I2.GT.0 .AND. KBT.GT.0 ) THEN * * create nonzero element a(i+kbt-ka-1,i+kbt) outside the * band and store it in WORK(m-kb+i+kbt) * WORK( M-KB+I+KBT ) = -BB( KB1-KBT, I+KBT )*RA1 END IF END IF * DO 650 K = KB, 1, -1 IF( UPDATE ) THEN J2 = I + K + 1 - MAX( 2, K+I0-M )*KA1 ELSE J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1 END IF * * finish applying rotations in 2nd set from the right * DO 620 L = KB - K, 1, -1 NRT = ( J2+KA+L-1 ) / KA1 J1T = J2 - ( NRT-1 )*KA1 IF( NRT.GT.0 ) $ CALL DLARTV( NRT, AB( L, J1T+KA ), INCA, $ AB( L+1, J1T+KA-1 ), INCA, $ WORK( N+M-KB+J1T+KA ), $ WORK( M-KB+J1T+KA ), KA1 ) 620 CONTINUE NR = ( J2+KA-1 ) / KA1 J1 = J2 - ( NR-1 )*KA1 DO 630 J = J1, J2, KA1 WORK( M-KB+J ) = WORK( M-KB+J+KA ) WORK( N+M-KB+J ) = WORK( N+M-KB+J+KA ) 630 CONTINUE DO 640 J = J1, J2, KA1 * * create nonzero element a(j-1,j+ka) outside the band * and store it in WORK(m-kb+j) * WORK( M-KB+J ) = WORK( M-KB+J )*AB( 1, J+KA-1 ) AB( 1, J+KA-1 ) = WORK( N+M-KB+J )*AB( 1, J+KA-1 ) 640 CONTINUE IF( UPDATE ) THEN IF( I+K.GT.KA1 .AND. K.LE.KBT ) $ WORK( M-KB+I+K-KA ) = WORK( M-KB+I+K ) END IF 650 CONTINUE * DO 690 K = KB, 1, -1 J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1 NR = ( J2+KA-1 ) / KA1 J1 = J2 - ( NR-1 )*KA1 IF( NR.GT.0 ) THEN * * generate rotations in 2nd set to annihilate elements * which have been created outside the band * CALL DLARGV( NR, AB( 1, J1+KA ), INCA, WORK( M-KB+J1 ), $ KA1, WORK( N+M-KB+J1 ), KA1 ) * * apply rotations in 2nd set from the left * DO 660 L = 1, KA - 1 CALL DLARTV( NR, AB( KA1-L, J1+L ), INCA, $ AB( KA-L, J1+L ), INCA, $ WORK( N+M-KB+J1 ), WORK( M-KB+J1 ), KA1 ) 660 CONTINUE * * apply rotations in 2nd set from both sides to diagonal * blocks * CALL DLAR2V( NR, AB( KA1, J1 ), AB( KA1, J1-1 ), $ AB( KA, J1 ), INCA, WORK( N+M-KB+J1 ), $ WORK( M-KB+J1 ), KA1 ) * END IF * * start applying rotations in 2nd set from the right * DO 670 L = KA - 1, KB - K + 1, -1 NRT = ( J2+L-1 ) / KA1 J1T = J2 - ( NRT-1 )*KA1 IF( NRT.GT.0 ) $ CALL DLARTV( NRT, AB( L, J1T ), INCA, $ AB( L+1, J1T-1 ), INCA, $ WORK( N+M-KB+J1T ), WORK( M-KB+J1T ), $ KA1 ) 670 CONTINUE * IF( WANTX ) THEN * * post-multiply X by product of rotations in 2nd set * DO 680 J = J1, J2, KA1 CALL DROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1, $ WORK( N+M-KB+J ), WORK( M-KB+J ) ) 680 CONTINUE END IF 690 CONTINUE * DO 710 K = 1, KB - 1 J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1 * * finish applying rotations in 1st set from the right * DO 700 L = KB - K, 1, -1 NRT = ( J2+L-1 ) / KA1 J1T = J2 - ( NRT-1 )*KA1 IF( NRT.GT.0 ) $ CALL DLARTV( NRT, AB( L, J1T ), INCA, $ AB( L+1, J1T-1 ), INCA, WORK( N+J1T ), $ WORK( J1T ), KA1 ) 700 CONTINUE 710 CONTINUE * IF( KB.GT.1 ) THEN DO 720 J = 2, MIN( I+KB, M ) - 2*KA - 1 WORK( N+J ) = WORK( N+J+KA ) WORK( J ) = WORK( J+KA ) 720 CONTINUE END IF * ELSE * * Transform A, working with the lower triangle * IF( UPDATE ) THEN * * Form inv(S(i))**T * A * inv(S(i)) * BII = BB( 1, I ) DO 730 J = I1, I AB( I-J+1, J ) = AB( I-J+1, J ) / BII 730 CONTINUE DO 740 J = I, MIN( N, I+KA ) AB( J-I+1, I ) = AB( J-I+1, I ) / BII 740 CONTINUE DO 770 K = I + 1, I + KBT DO 750 J = K, I + KBT AB( J-K+1, K ) = AB( J-K+1, K ) - $ BB( J-I+1, I )*AB( K-I+1, I ) - $ BB( K-I+1, I )*AB( J-I+1, I ) + $ AB( 1, I )*BB( J-I+1, I )* $ BB( K-I+1, I ) 750 CONTINUE DO 760 J = I + KBT + 1, MIN( N, I+KA ) AB( J-K+1, K ) = AB( J-K+1, K ) - $ BB( K-I+1, I )*AB( J-I+1, I ) 760 CONTINUE 770 CONTINUE DO 790 J = I1, I DO 780 K = I + 1, MIN( J+KA, I+KBT ) AB( K-J+1, J ) = AB( K-J+1, J ) - $ BB( K-I+1, I )*AB( I-J+1, J ) 780 CONTINUE 790 CONTINUE * IF( WANTX ) THEN * * post-multiply X by inv(S(i)) * CALL DSCAL( NX, ONE / BII, X( 1, I ), 1 ) IF( KBT.GT.0 ) $ CALL DGER( NX, KBT, -ONE, X( 1, I ), 1, BB( 2, I ), 1, $ X( 1, I+1 ), LDX ) END IF * * store a(i,i1) in RA1 for use in next loop over K * RA1 = AB( I-I1+1, I1 ) END IF * * Generate and apply vectors of rotations to chase all the * existing bulges KA positions up toward the top of the band * DO 840 K = 1, KB - 1 IF( UPDATE ) THEN * * Determine the rotations which would annihilate the bulge * which has in theory just been created * IF( I+K-KA1.GT.0 .AND. I+K.LT.M ) THEN * * generate rotation to annihilate a(i,i+k-ka-1) * CALL DLARTG( AB( KA1-K, I+K-KA ), RA1, $ WORK( N+I+K-KA ), WORK( I+K-KA ), RA ) * * create nonzero element a(i+k,i+k-ka-1) outside the * band and store it in WORK(m-kb+i+k) * T = -BB( K+1, I )*RA1 WORK( M-KB+I+K ) = WORK( N+I+K-KA )*T - $ WORK( I+K-KA )*AB( KA1, I+K-KA ) AB( KA1, I+K-KA ) = WORK( I+K-KA )*T + $ WORK( N+I+K-KA )*AB( KA1, I+K-KA ) RA1 = RA END IF END IF J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1 NR = ( J2+KA-1 ) / KA1 J1 = J2 - ( NR-1 )*KA1 IF( UPDATE ) THEN J2T = MIN( J2, I-2*KA+K-1 ) ELSE J2T = J2 END IF NRT = ( J2T+KA-1 ) / KA1 DO 800 J = J1, J2T, KA1 * * create nonzero element a(j+ka,j-1) outside the band * and store it in WORK(j) * WORK( J ) = WORK( J )*AB( KA1, J-1 ) AB( KA1, J-1 ) = WORK( N+J )*AB( KA1, J-1 ) 800 CONTINUE * * generate rotations in 1st set to annihilate elements which * have been created outside the band * IF( NRT.GT.0 ) $ CALL DLARGV( NRT, AB( KA1, J1 ), INCA, WORK( J1 ), KA1, $ WORK( N+J1 ), KA1 ) IF( NR.GT.0 ) THEN * * apply rotations in 1st set from the right * DO 810 L = 1, KA - 1 CALL DLARTV( NR, AB( L+1, J1 ), INCA, AB( L+2, J1-1 ), $ INCA, WORK( N+J1 ), WORK( J1 ), KA1 ) 810 CONTINUE * * apply rotations in 1st set from both sides to diagonal * blocks * CALL DLAR2V( NR, AB( 1, J1 ), AB( 1, J1-1 ), $ AB( 2, J1-1 ), INCA, WORK( N+J1 ), $ WORK( J1 ), KA1 ) * END IF * * start applying rotations in 1st set from the left * DO 820 L = KA - 1, KB - K + 1, -1 NRT = ( J2+L-1 ) / KA1 J1T = J2 - ( NRT-1 )*KA1 IF( NRT.GT.0 ) $ CALL DLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA, $ AB( KA1-L, J1T-KA1+L ), INCA, $ WORK( N+J1T ), WORK( J1T ), KA1 ) 820 CONTINUE * IF( WANTX ) THEN * * post-multiply X by product of rotations in 1st set * DO 830 J = J1, J2, KA1 CALL DROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1, $ WORK( N+J ), WORK( J ) ) 830 CONTINUE END IF 840 CONTINUE * IF( UPDATE ) THEN IF( I2.GT.0 .AND. KBT.GT.0 ) THEN * * create nonzero element a(i+kbt,i+kbt-ka-1) outside the * band and store it in WORK(m-kb+i+kbt) * WORK( M-KB+I+KBT ) = -BB( KBT+1, I )*RA1 END IF END IF * DO 880 K = KB, 1, -1 IF( UPDATE ) THEN J2 = I + K + 1 - MAX( 2, K+I0-M )*KA1 ELSE J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1 END IF * * finish applying rotations in 2nd set from the left * DO 850 L = KB - K, 1, -1 NRT = ( J2+KA+L-1 ) / KA1 J1T = J2 - ( NRT-1 )*KA1 IF( NRT.GT.0 ) $ CALL DLARTV( NRT, AB( KA1-L+1, J1T+L-1 ), INCA, $ AB( KA1-L, J1T+L-1 ), INCA, $ WORK( N+M-KB+J1T+KA ), $ WORK( M-KB+J1T+KA ), KA1 ) 850 CONTINUE NR = ( J2+KA-1 ) / KA1 J1 = J2 - ( NR-1 )*KA1 DO 860 J = J1, J2, KA1 WORK( M-KB+J ) = WORK( M-KB+J+KA ) WORK( N+M-KB+J ) = WORK( N+M-KB+J+KA ) 860 CONTINUE DO 870 J = J1, J2, KA1 * * create nonzero element a(j+ka,j-1) outside the band * and store it in WORK(m-kb+j) * WORK( M-KB+J ) = WORK( M-KB+J )*AB( KA1, J-1 ) AB( KA1, J-1 ) = WORK( N+M-KB+J )*AB( KA1, J-1 ) 870 CONTINUE IF( UPDATE ) THEN IF( I+K.GT.KA1 .AND. K.LE.KBT ) $ WORK( M-KB+I+K-KA ) = WORK( M-KB+I+K ) END IF 880 CONTINUE * DO 920 K = KB, 1, -1 J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1 NR = ( J2+KA-1 ) / KA1 J1 = J2 - ( NR-1 )*KA1 IF( NR.GT.0 ) THEN * * generate rotations in 2nd set to annihilate elements * which have been created outside the band * CALL DLARGV( NR, AB( KA1, J1 ), INCA, WORK( M-KB+J1 ), $ KA1, WORK( N+M-KB+J1 ), KA1 ) * * apply rotations in 2nd set from the right * DO 890 L = 1, KA - 1 CALL DLARTV( NR, AB( L+1, J1 ), INCA, AB( L+2, J1-1 ), $ INCA, WORK( N+M-KB+J1 ), WORK( M-KB+J1 ), $ KA1 ) 890 CONTINUE * * apply rotations in 2nd set from both sides to diagonal * blocks * CALL DLAR2V( NR, AB( 1, J1 ), AB( 1, J1-1 ), $ AB( 2, J1-1 ), INCA, WORK( N+M-KB+J1 ), $ WORK( M-KB+J1 ), KA1 ) * END IF * * start applying rotations in 2nd set from the left * DO 900 L = KA - 1, KB - K + 1, -1 NRT = ( J2+L-1 ) / KA1 J1T = J2 - ( NRT-1 )*KA1 IF( NRT.GT.0 ) $ CALL DLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA, $ AB( KA1-L, J1T-KA1+L ), INCA, $ WORK( N+M-KB+J1T ), WORK( M-KB+J1T ), $ KA1 ) 900 CONTINUE * IF( WANTX ) THEN * * post-multiply X by product of rotations in 2nd set * DO 910 J = J1, J2, KA1 CALL DROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1, $ WORK( N+M-KB+J ), WORK( M-KB+J ) ) 910 CONTINUE END IF 920 CONTINUE * DO 940 K = 1, KB - 1 J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1 * * finish applying rotations in 1st set from the left * DO 930 L = KB - K, 1, -1 NRT = ( J2+L-1 ) / KA1 J1T = J2 - ( NRT-1 )*KA1 IF( NRT.GT.0 ) $ CALL DLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA, $ AB( KA1-L, J1T-KA1+L ), INCA, $ WORK( N+J1T ), WORK( J1T ), KA1 ) 930 CONTINUE 940 CONTINUE * IF( KB.GT.1 ) THEN DO 950 J = 2, MIN( I+KB, M ) - 2*KA - 1 WORK( N+J ) = WORK( N+J+KA ) WORK( J ) = WORK( J+KA ) 950 CONTINUE END IF * END IF * GO TO 490 * * End of DSBGST * END *> \brief \b DSBGV * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSBGV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, * LDZ, WORK, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, KA, KB, LDAB, LDBB, LDZ, N * .. * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), W( * ), * $ WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSBGV computes all the eigenvalues, and optionally, the eigenvectors *> of a real generalized symmetric-definite banded eigenproblem, of *> the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric *> and banded, and B is also positive definite. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBZ *> \verbatim *> JOBZ is CHARACTER*1 *> = 'N': Compute eigenvalues only; *> = 'V': Compute eigenvalues and eigenvectors. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangles of A and B are stored; *> = 'L': Lower triangles of A and B are stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A and B. N >= 0. *> \endverbatim *> *> \param[in] KA *> \verbatim *> KA is INTEGER *> The number of superdiagonals of the matrix A if UPLO = 'U', *> or the number of subdiagonals if UPLO = 'L'. KA >= 0. *> \endverbatim *> *> \param[in] KB *> \verbatim *> KB is INTEGER *> The number of superdiagonals of the matrix B if UPLO = 'U', *> or the number of subdiagonals if UPLO = 'L'. KB >= 0. *> \endverbatim *> *> \param[in,out] AB *> \verbatim *> AB is DOUBLE PRECISION array, dimension (LDAB, N) *> On entry, the upper or lower triangle of the symmetric band *> matrix A, stored in the first ka+1 rows of the array. The *> j-th column of A is stored in the j-th column of the array AB *> as follows: *> if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; *> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). *> *> On exit, the contents of AB are destroyed. *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array AB. LDAB >= KA+1. *> \endverbatim *> *> \param[in,out] BB *> \verbatim *> BB is DOUBLE PRECISION array, dimension (LDBB, N) *> On entry, the upper or lower triangle of the symmetric band *> matrix B, stored in the first kb+1 rows of the array. The *> j-th column of B is stored in the j-th column of the array BB *> as follows: *> if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; *> if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb). *> *> On exit, the factor S from the split Cholesky factorization *> B = S**T*S, as returned by DPBSTF. *> \endverbatim *> *> \param[in] LDBB *> \verbatim *> LDBB is INTEGER *> The leading dimension of the array BB. LDBB >= KB+1. *> \endverbatim *> *> \param[out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> If INFO = 0, the eigenvalues in ascending order. *> \endverbatim *> *> \param[out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ, N) *> If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of *> eigenvectors, with the i-th column of Z holding the *> eigenvector associated with W(i). The eigenvectors are *> normalized so that Z**T*B*Z = I. *> If JOBZ = 'N', then Z is not referenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1, and if *> JOBZ = 'V', LDZ >= N. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, and i is: *> <= N: the algorithm failed to converge: *> i off-diagonal elements of an intermediate *> tridiagonal form did not converge to zero; *> > N: if INFO = N + i, for 1 <= i <= N, then DPBSTF *> returned INFO = i: B is not positive definite. *> The factorization of B could not be completed and *> no eigenvalues or eigenvectors were computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHEReigen * * ===================================================================== SUBROUTINE DSBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, $ LDZ, WORK, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO INTEGER INFO, KA, KB, LDAB, LDBB, LDZ, N * .. * .. Array Arguments .. DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), W( * ), $ WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL UPPER, WANTZ CHARACTER VECT INTEGER IINFO, INDE, INDWRK * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DPBSTF, DSBGST, DSBTRD, DSTEQR, DSTERF, XERBLA * .. * .. Executable Statements .. * * Test the input parameters. * WANTZ = LSAME( JOBZ, 'V' ) UPPER = LSAME( UPLO, 'U' ) * INFO = 0 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( KA.LT.0 ) THEN INFO = -4 ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN INFO = -5 ELSE IF( LDAB.LT.KA+1 ) THEN INFO = -7 ELSE IF( LDBB.LT.KB+1 ) THEN INFO = -9 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN INFO = -12 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSBGV ', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Form a split Cholesky factorization of B. * CALL DPBSTF( UPLO, N, KB, BB, LDBB, INFO ) IF( INFO.NE.0 ) THEN INFO = N + INFO RETURN END IF * * Transform problem to standard eigenvalue problem. * INDE = 1 INDWRK = INDE + N CALL DSBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Z, LDZ, $ WORK( INDWRK ), IINFO ) * * Reduce to tridiagonal form. * IF( WANTZ ) THEN VECT = 'U' ELSE VECT = 'N' END IF CALL DSBTRD( VECT, UPLO, N, KA, AB, LDAB, W, WORK( INDE ), Z, LDZ, $ WORK( INDWRK ), IINFO ) * * For eigenvalues only, call DSTERF. For eigenvectors, call SSTEQR. * IF( .NOT.WANTZ ) THEN CALL DSTERF( N, W, WORK( INDE ), INFO ) ELSE CALL DSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDWRK ), $ INFO ) END IF RETURN * * End of DSBGV * END *> \brief \b DSBGVD * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSBGVD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, * Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, KA, KB, LDAB, LDBB, LDZ, LIWORK, LWORK, N * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), W( * ), * $ WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSBGVD computes all the eigenvalues, and optionally, the eigenvectors *> of a real generalized symmetric-definite banded eigenproblem, of the *> form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric and *> banded, and B is also positive definite. If eigenvectors are *> desired, it uses a divide and conquer algorithm. *> *> The divide and conquer algorithm makes very mild assumptions about *> floating point arithmetic. It will work on machines with a guard *> digit in add/subtract, or on those binary machines without guard *> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or *> Cray-2. It could conceivably fail on hexadecimal or decimal machines *> without guard digits, but we know of none. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBZ *> \verbatim *> JOBZ is CHARACTER*1 *> = 'N': Compute eigenvalues only; *> = 'V': Compute eigenvalues and eigenvectors. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangles of A and B are stored; *> = 'L': Lower triangles of A and B are stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A and B. N >= 0. *> \endverbatim *> *> \param[in] KA *> \verbatim *> KA is INTEGER *> The number of superdiagonals of the matrix A if UPLO = 'U', *> or the number of subdiagonals if UPLO = 'L'. KA >= 0. *> \endverbatim *> *> \param[in] KB *> \verbatim *> KB is INTEGER *> The number of superdiagonals of the matrix B if UPLO = 'U', *> or the number of subdiagonals if UPLO = 'L'. KB >= 0. *> \endverbatim *> *> \param[in,out] AB *> \verbatim *> AB is DOUBLE PRECISION array, dimension (LDAB, N) *> On entry, the upper or lower triangle of the symmetric band *> matrix A, stored in the first ka+1 rows of the array. The *> j-th column of A is stored in the j-th column of the array AB *> as follows: *> if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; *> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). *> *> On exit, the contents of AB are destroyed. *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array AB. LDAB >= KA+1. *> \endverbatim *> *> \param[in,out] BB *> \verbatim *> BB is DOUBLE PRECISION array, dimension (LDBB, N) *> On entry, the upper or lower triangle of the symmetric band *> matrix B, stored in the first kb+1 rows of the array. The *> j-th column of B is stored in the j-th column of the array BB *> as follows: *> if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; *> if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb). *> *> On exit, the factor S from the split Cholesky factorization *> B = S**T*S, as returned by DPBSTF. *> \endverbatim *> *> \param[in] LDBB *> \verbatim *> LDBB is INTEGER *> The leading dimension of the array BB. LDBB >= KB+1. *> \endverbatim *> *> \param[out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> If INFO = 0, the eigenvalues in ascending order. *> \endverbatim *> *> \param[out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ, N) *> If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of *> eigenvectors, with the i-th column of Z holding the *> eigenvector associated with W(i). The eigenvectors are *> normalized so Z**T*B*Z = I. *> If JOBZ = 'N', then Z is not referenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1, and if *> JOBZ = 'V', LDZ >= max(1,N). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. *> If N <= 1, LWORK >= 1. *> If JOBZ = 'N' and N > 1, LWORK >= 2*N. *> If JOBZ = 'V' and N > 1, LWORK >= 1 + 5*N + 2*N**2. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal sizes of the WORK and IWORK *> arrays, returns these values as the first entries of the WORK *> and IWORK arrays, and no error message related to LWORK or *> LIWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) *> On exit, if LIWORK > 0, IWORK(1) returns the optimal LIWORK. *> \endverbatim *> *> \param[in] LIWORK *> \verbatim *> LIWORK is INTEGER *> The dimension of the array IWORK. *> If JOBZ = 'N' or N <= 1, LIWORK >= 1. *> If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. *> *> If LIWORK = -1, then a workspace query is assumed; the *> routine only calculates the optimal sizes of the WORK and *> IWORK arrays, returns these values as the first entries of *> the WORK and IWORK arrays, and no error message related to *> LWORK or LIWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, and i is: *> <= N: the algorithm failed to converge: *> i off-diagonal elements of an intermediate *> tridiagonal form did not converge to zero; *> > N: if INFO = N + i, for 1 <= i <= N, then DPBSTF *> returned INFO = i: B is not positive definite. *> The factorization of B could not be completed and *> no eigenvalues or eigenvectors were computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleOTHEReigen * *> \par Contributors: * ================== *> *> Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA * * ===================================================================== SUBROUTINE DSBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, $ Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO INTEGER INFO, KA, KB, LDAB, LDBB, LDZ, LIWORK, LWORK, N * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), W( * ), $ WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, UPPER, WANTZ CHARACTER VECT INTEGER IINFO, INDE, INDWK2, INDWRK, LIWMIN, LLWRK2, $ LWMIN * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DGEMM, DLACPY, DPBSTF, DSBGST, DSBTRD, DSTEDC, $ DSTERF, XERBLA * .. * .. Executable Statements .. * * Test the input parameters. * WANTZ = LSAME( JOBZ, 'V' ) UPPER = LSAME( UPLO, 'U' ) LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) * INFO = 0 IF( N.LE.1 ) THEN LIWMIN = 1 LWMIN = 1 ELSE IF( WANTZ ) THEN LIWMIN = 3 + 5*N LWMIN = 1 + 5*N + 2*N**2 ELSE LIWMIN = 1 LWMIN = 2*N END IF * IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( KA.LT.0 ) THEN INFO = -4 ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN INFO = -5 ELSE IF( LDAB.LT.KA+1 ) THEN INFO = -7 ELSE IF( LDBB.LT.KB+1 ) THEN INFO = -9 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN INFO = -12 END IF * IF( INFO.EQ.0 ) THEN WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN * IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN INFO = -14 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN INFO = -16 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSBGVD', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Form a split Cholesky factorization of B. * CALL DPBSTF( UPLO, N, KB, BB, LDBB, INFO ) IF( INFO.NE.0 ) THEN INFO = N + INFO RETURN END IF * * Transform problem to standard eigenvalue problem. * INDE = 1 INDWRK = INDE + N INDWK2 = INDWRK + N*N LLWRK2 = LWORK - INDWK2 + 1 CALL DSBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Z, LDZ, $ WORK, IINFO ) * * Reduce to tridiagonal form. * IF( WANTZ ) THEN VECT = 'U' ELSE VECT = 'N' END IF CALL DSBTRD( VECT, UPLO, N, KA, AB, LDAB, W, WORK( INDE ), Z, LDZ, $ WORK( INDWRK ), IINFO ) * * For eigenvalues only, call DSTERF. For eigenvectors, call SSTEDC. * IF( .NOT.WANTZ ) THEN CALL DSTERF( N, W, WORK( INDE ), INFO ) ELSE CALL DSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N, $ WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO ) CALL DGEMM( 'N', 'N', N, N, N, ONE, Z, LDZ, WORK( INDWRK ), N, $ ZERO, WORK( INDWK2 ), N ) CALL DLACPY( 'A', N, N, WORK( INDWK2 ), N, Z, LDZ ) END IF * WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN * RETURN * * End of DSBGVD * END *> \brief \b DSBGVX * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSBGVX + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, * LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, * LDZ, WORK, IWORK, IFAIL, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, IU, KA, KB, LDAB, LDBB, LDQ, LDZ, M, * $ N * DOUBLE PRECISION ABSTOL, VL, VU * .. * .. Array Arguments .. * INTEGER IFAIL( * ), IWORK( * ) * DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), Q( LDQ, * ), * $ W( * ), WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSBGVX computes selected eigenvalues, and optionally, eigenvectors *> of a real generalized symmetric-definite banded eigenproblem, of *> the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric *> and banded, and B is also positive definite. Eigenvalues and *> eigenvectors can be selected by specifying either all eigenvalues, *> a range of values or a range of indices for the desired eigenvalues. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBZ *> \verbatim *> JOBZ is CHARACTER*1 *> = 'N': Compute eigenvalues only; *> = 'V': Compute eigenvalues and eigenvectors. *> \endverbatim *> *> \param[in] RANGE *> \verbatim *> RANGE is CHARACTER*1 *> = 'A': all eigenvalues will be found. *> = 'V': all eigenvalues in the half-open interval (VL,VU] *> will be found. *> = 'I': the IL-th through IU-th eigenvalues will be found. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangles of A and B are stored; *> = 'L': Lower triangles of A and B are stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A and B. N >= 0. *> \endverbatim *> *> \param[in] KA *> \verbatim *> KA is INTEGER *> The number of superdiagonals of the matrix A if UPLO = 'U', *> or the number of subdiagonals if UPLO = 'L'. KA >= 0. *> \endverbatim *> *> \param[in] KB *> \verbatim *> KB is INTEGER *> The number of superdiagonals of the matrix B if UPLO = 'U', *> or the number of subdiagonals if UPLO = 'L'. KB >= 0. *> \endverbatim *> *> \param[in,out] AB *> \verbatim *> AB is DOUBLE PRECISION array, dimension (LDAB, N) *> On entry, the upper or lower triangle of the symmetric band *> matrix A, stored in the first ka+1 rows of the array. The *> j-th column of A is stored in the j-th column of the array AB *> as follows: *> if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; *> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). *> *> On exit, the contents of AB are destroyed. *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array AB. LDAB >= KA+1. *> \endverbatim *> *> \param[in,out] BB *> \verbatim *> BB is DOUBLE PRECISION array, dimension (LDBB, N) *> On entry, the upper or lower triangle of the symmetric band *> matrix B, stored in the first kb+1 rows of the array. The *> j-th column of B is stored in the j-th column of the array BB *> as follows: *> if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; *> if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb). *> *> On exit, the factor S from the split Cholesky factorization *> B = S**T*S, as returned by DPBSTF. *> \endverbatim *> *> \param[in] LDBB *> \verbatim *> LDBB is INTEGER *> The leading dimension of the array BB. LDBB >= KB+1. *> \endverbatim *> *> \param[out] Q *> \verbatim *> Q is DOUBLE PRECISION array, dimension (LDQ, N) *> If JOBZ = 'V', the n-by-n matrix used in the reduction of *> A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x, *> and consequently C to tridiagonal form. *> If JOBZ = 'N', the array Q is not referenced. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. If JOBZ = 'N', *> LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N). *> \endverbatim *> *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION *> *> If RANGE='V', the lower bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION *> *> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] IL *> \verbatim *> IL is INTEGER *> *> If RANGE='I', the index of the *> smallest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> *> If RANGE='I', the index of the *> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] ABSTOL *> \verbatim *> ABSTOL is DOUBLE PRECISION *> The absolute error tolerance for the eigenvalues. *> An approximate eigenvalue is accepted as converged *> when it is determined to lie in an interval [a,b] *> of width less than or equal to *> *> ABSTOL + EPS * max( |a|,|b| ) , *> *> where EPS is the machine precision. If ABSTOL is less than *> or equal to zero, then EPS*|T| will be used in its place, *> where |T| is the 1-norm of the tridiagonal matrix obtained *> by reducing A to tridiagonal form. *> *> Eigenvalues will be computed most accurately when ABSTOL is *> set to twice the underflow threshold 2*DLAMCH('S'), not zero. *> If this routine returns with INFO>0, indicating that some *> eigenvectors did not converge, try setting ABSTOL to *> 2*DLAMCH('S'). *> \endverbatim *> *> \param[out] M *> \verbatim *> M is INTEGER *> The total number of eigenvalues found. 0 <= M <= N. *> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. *> \endverbatim *> *> \param[out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> If INFO = 0, the eigenvalues in ascending order. *> \endverbatim *> *> \param[out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ, N) *> If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of *> eigenvectors, with the i-th column of Z holding the *> eigenvector associated with W(i). The eigenvectors are *> normalized so Z**T*B*Z = I. *> If JOBZ = 'N', then Z is not referenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1, and if *> JOBZ = 'V', LDZ >= max(1,N). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (7*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (5*N) *> \endverbatim *> *> \param[out] IFAIL *> \verbatim *> IFAIL is INTEGER array, dimension (M) *> If JOBZ = 'V', then if INFO = 0, the first M elements of *> IFAIL are zero. If INFO > 0, then IFAIL contains the *> indices of the eigenvalues that failed to converge. *> If JOBZ = 'N', then IFAIL is not referenced. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0 : successful exit *> < 0 : if INFO = -i, the i-th argument had an illegal value *> <= N: if INFO = i, then i eigenvectors failed to converge. *> Their indices are stored in IFAIL. *> > N : DPBSTF returned an error code; i.e., *> if INFO = N + i, for 1 <= i <= N, then the leading *> minor of order i of B is not positive definite. *> The factorization of B could not be completed and *> no eigenvalues or eigenvectors were computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleOTHEReigen * *> \par Contributors: * ================== *> *> Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA * * ===================================================================== SUBROUTINE DSBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, $ LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, $ LDZ, WORK, IWORK, IFAIL, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO INTEGER IL, INFO, IU, KA, KB, LDAB, LDBB, LDQ, LDZ, M, $ N DOUBLE PRECISION ABSTOL, VL, VU * .. * .. Array Arguments .. INTEGER IFAIL( * ), IWORK( * ) DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), Q( LDQ, * ), $ W( * ), WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL ALLEIG, INDEIG, TEST, UPPER, VALEIG, WANTZ CHARACTER ORDER, VECT INTEGER I, IINFO, INDD, INDE, INDEE, INDIBL, INDISP, $ INDIWO, INDWRK, ITMP1, J, JJ, NSPLIT DOUBLE PRECISION TMP1 * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DCOPY, DGEMV, DLACPY, DPBSTF, DSBGST, DSBTRD, $ DSTEBZ, DSTEIN, DSTEQR, DSTERF, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * * Test the input parameters. * WANTZ = LSAME( JOBZ, 'V' ) UPPER = LSAME( UPLO, 'U' ) ALLEIG = LSAME( RANGE, 'A' ) VALEIG = LSAME( RANGE, 'V' ) INDEIG = LSAME( RANGE, 'I' ) * INFO = 0 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN INFO = -2 ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( KA.LT.0 ) THEN INFO = -5 ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN INFO = -6 ELSE IF( LDAB.LT.KA+1 ) THEN INFO = -8 ELSE IF( LDBB.LT.KB+1 ) THEN INFO = -10 ELSE IF( LDQ.LT.1 .OR. ( WANTZ .AND. LDQ.LT.N ) ) THEN INFO = -12 ELSE IF( VALEIG ) THEN IF( N.GT.0 .AND. VU.LE.VL ) $ INFO = -14 ELSE IF( INDEIG ) THEN IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN INFO = -15 ELSE IF ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN INFO = -16 END IF END IF END IF IF( INFO.EQ.0) THEN IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN INFO = -21 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSBGVX', -INFO ) RETURN END IF * * Quick return if possible * M = 0 IF( N.EQ.0 ) $ RETURN * * Form a split Cholesky factorization of B. * CALL DPBSTF( UPLO, N, KB, BB, LDBB, INFO ) IF( INFO.NE.0 ) THEN INFO = N + INFO RETURN END IF * * Transform problem to standard eigenvalue problem. * CALL DSBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, $ WORK, IINFO ) * * Reduce symmetric band matrix to tridiagonal form. * INDD = 1 INDE = INDD + N INDWRK = INDE + N IF( WANTZ ) THEN VECT = 'U' ELSE VECT = 'N' END IF CALL DSBTRD( VECT, UPLO, N, KA, AB, LDAB, WORK( INDD ), $ WORK( INDE ), Q, LDQ, WORK( INDWRK ), IINFO ) * * If all eigenvalues are desired and ABSTOL is less than or equal * to zero, then call DSTERF or SSTEQR. If this fails for some * eigenvalue, then try DSTEBZ. * TEST = .FALSE. IF( INDEIG ) THEN IF( IL.EQ.1 .AND. IU.EQ.N ) THEN TEST = .TRUE. END IF END IF IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN CALL DCOPY( N, WORK( INDD ), 1, W, 1 ) INDEE = INDWRK + 2*N CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) IF( .NOT.WANTZ ) THEN CALL DSTERF( N, W, WORK( INDEE ), INFO ) ELSE CALL DLACPY( 'A', N, N, Q, LDQ, Z, LDZ ) CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ, $ WORK( INDWRK ), INFO ) IF( INFO.EQ.0 ) THEN DO 10 I = 1, N IFAIL( I ) = 0 10 CONTINUE END IF END IF IF( INFO.EQ.0 ) THEN M = N GO TO 30 END IF INFO = 0 END IF * * Otherwise, call DSTEBZ and, if eigenvectors are desired, * call DSTEIN. * IF( WANTZ ) THEN ORDER = 'B' ELSE ORDER = 'E' END IF INDIBL = 1 INDISP = INDIBL + N INDIWO = INDISP + N CALL DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W, $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ), $ IWORK( INDIWO ), INFO ) * IF( WANTZ ) THEN CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, $ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO ) * * Apply transformation matrix used in reduction to tridiagonal * form to eigenvectors returned by DSTEIN. * DO 20 J = 1, M CALL DCOPY( N, Z( 1, J ), 1, WORK( 1 ), 1 ) CALL DGEMV( 'N', N, N, ONE, Q, LDQ, WORK, 1, ZERO, $ Z( 1, J ), 1 ) 20 CONTINUE END IF * 30 CONTINUE * * If eigenvalues are not in order, then sort them, along with * eigenvectors. * IF( WANTZ ) THEN DO 50 J = 1, M - 1 I = 0 TMP1 = W( J ) DO 40 JJ = J + 1, M IF( W( JJ ).LT.TMP1 ) THEN I = JJ TMP1 = W( JJ ) END IF 40 CONTINUE * IF( I.NE.0 ) THEN ITMP1 = IWORK( INDIBL+I-1 ) W( I ) = W( J ) IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) W( J ) = TMP1 IWORK( INDIBL+J-1 ) = ITMP1 CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) IF( INFO.NE.0 ) THEN ITMP1 = IFAIL( I ) IFAIL( I ) = IFAIL( J ) IFAIL( J ) = ITMP1 END IF END IF 50 CONTINUE END IF * RETURN * * End of DSBGVX * END *> \brief \b DSBTRD * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSBTRD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, * WORK, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO, VECT * INTEGER INFO, KD, LDAB, LDQ, N * .. * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ), D( * ), E( * ), Q( LDQ, * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSBTRD reduces a real symmetric band matrix A to symmetric *> tridiagonal form T by an orthogonal similarity transformation: *> Q**T * A * Q = T. *> \endverbatim * * Arguments: * ========== * *> \param[in] VECT *> \verbatim *> VECT is CHARACTER*1 *> = 'N': do not form Q; *> = 'V': form Q; *> = 'U': update a matrix X, by forming X*Q. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] KD *> \verbatim *> KD is INTEGER *> The number of superdiagonals of the matrix A if UPLO = 'U', *> or the number of subdiagonals if UPLO = 'L'. KD >= 0. *> \endverbatim *> *> \param[in,out] AB *> \verbatim *> AB is DOUBLE PRECISION array, dimension (LDAB,N) *> On entry, the upper or lower triangle of the symmetric band *> matrix A, stored in the first KD+1 rows of the array. The *> j-th column of A is stored in the j-th column of the array AB *> as follows: *> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; *> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). *> On exit, the diagonal elements of AB are overwritten by the *> diagonal elements of the tridiagonal matrix T; if KD > 0, the *> elements on the first superdiagonal (if UPLO = 'U') or the *> first subdiagonal (if UPLO = 'L') are overwritten by the *> off-diagonal elements of T; the rest of AB is overwritten by *> values generated during the reduction. *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array AB. LDAB >= KD+1. *> \endverbatim *> *> \param[out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The diagonal elements of the tridiagonal matrix T. *> \endverbatim *> *> \param[out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N-1) *> The off-diagonal elements of the tridiagonal matrix T: *> E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'. *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is DOUBLE PRECISION array, dimension (LDQ,N) *> On entry, if VECT = 'U', then Q must contain an N-by-N *> matrix X; if VECT = 'N' or 'V', then Q need not be set. *> *> On exit: *> if VECT = 'V', Q contains the N-by-N orthogonal matrix Q; *> if VECT = 'U', Q contains the product X*Q; *> if VECT = 'N', the array Q is not referenced. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. *> LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> Modified by Linda Kaufman, Bell Labs. *> \endverbatim *> * ===================================================================== SUBROUTINE DSBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, $ WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO, VECT INTEGER INFO, KD, LDAB, LDQ, N * .. * .. Array Arguments .. DOUBLE PRECISION AB( LDAB, * ), D( * ), E( * ), Q( LDQ, * ), $ WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL INITQ, UPPER, WANTQ INTEGER I, I2, IBL, INCA, INCX, IQAEND, IQB, IQEND, J, $ J1, J1END, J1INC, J2, JEND, JIN, JINC, K, KD1, $ KDM1, KDN, L, LAST, LEND, NQ, NR, NRT DOUBLE PRECISION TEMP * .. * .. External Subroutines .. EXTERNAL DLAR2V, DLARGV, DLARTG, DLARTV, DLASET, DROT, $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Executable Statements .. * * Test the input parameters * INITQ = LSAME( VECT, 'V' ) WANTQ = INITQ .OR. LSAME( VECT, 'U' ) UPPER = LSAME( UPLO, 'U' ) KD1 = KD + 1 KDM1 = KD - 1 INCX = LDAB - 1 IQEND = 1 * INFO = 0 IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'N' ) ) THEN INFO = -1 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( KD.LT.0 ) THEN INFO = -4 ELSE IF( LDAB.LT.KD1 ) THEN INFO = -6 ELSE IF( LDQ.LT.MAX( 1, N ) .AND. WANTQ ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSBTRD', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Initialize Q to the unit matrix, if needed * IF( INITQ ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) * * Wherever possible, plane rotations are generated and applied in * vector operations of length NR over the index set J1:J2:KD1. * * The cosines and sines of the plane rotations are stored in the * arrays D and WORK. * INCA = KD1*LDAB KDN = MIN( N-1, KD ) IF( UPPER ) THEN * IF( KD.GT.1 ) THEN * * Reduce to tridiagonal form, working with upper triangle * NR = 0 J1 = KDN + 2 J2 = 1 * DO 90 I = 1, N - 2 * * Reduce i-th row of matrix to tridiagonal form * DO 80 K = KDN + 1, 2, -1 J1 = J1 + KDN J2 = J2 + KDN * IF( NR.GT.0 ) THEN * * generate plane rotations to annihilate nonzero * elements which have been created outside the band * CALL DLARGV( NR, AB( 1, J1-1 ), INCA, WORK( J1 ), $ KD1, D( J1 ), KD1 ) * * apply rotations from the right * * * Dependent on the the number of diagonals either * DLARTV or DROT is used * IF( NR.GE.2*KD-1 ) THEN DO 10 L = 1, KD - 1 CALL DLARTV( NR, AB( L+1, J1-1 ), INCA, $ AB( L, J1 ), INCA, D( J1 ), $ WORK( J1 ), KD1 ) 10 CONTINUE * ELSE JEND = J1 + ( NR-1 )*KD1 DO 20 JINC = J1, JEND, KD1 CALL DROT( KDM1, AB( 2, JINC-1 ), 1, $ AB( 1, JINC ), 1, D( JINC ), $ WORK( JINC ) ) 20 CONTINUE END IF END IF * * IF( K.GT.2 ) THEN IF( K.LE.N-I+1 ) THEN * * generate plane rotation to annihilate a(i,i+k-1) * within the band * CALL DLARTG( AB( KD-K+3, I+K-2 ), $ AB( KD-K+2, I+K-1 ), D( I+K-1 ), $ WORK( I+K-1 ), TEMP ) AB( KD-K+3, I+K-2 ) = TEMP * * apply rotation from the right * CALL DROT( K-3, AB( KD-K+4, I+K-2 ), 1, $ AB( KD-K+3, I+K-1 ), 1, D( I+K-1 ), $ WORK( I+K-1 ) ) END IF NR = NR + 1 J1 = J1 - KDN - 1 END IF * * apply plane rotations from both sides to diagonal * blocks * IF( NR.GT.0 ) $ CALL DLAR2V( NR, AB( KD1, J1-1 ), AB( KD1, J1 ), $ AB( KD, J1 ), INCA, D( J1 ), $ WORK( J1 ), KD1 ) * * apply plane rotations from the left * IF( NR.GT.0 ) THEN IF( 2*KD-1.LT.NR ) THEN * * Dependent on the the number of diagonals either * DLARTV or DROT is used * DO 30 L = 1, KD - 1 IF( J2+L.GT.N ) THEN NRT = NR - 1 ELSE NRT = NR END IF IF( NRT.GT.0 ) $ CALL DLARTV( NRT, AB( KD-L, J1+L ), INCA, $ AB( KD-L+1, J1+L ), INCA, $ D( J1 ), WORK( J1 ), KD1 ) 30 CONTINUE ELSE J1END = J1 + KD1*( NR-2 ) IF( J1END.GE.J1 ) THEN DO 40 JIN = J1, J1END, KD1 CALL DROT( KD-1, AB( KD-1, JIN+1 ), INCX, $ AB( KD, JIN+1 ), INCX, $ D( JIN ), WORK( JIN ) ) 40 CONTINUE END IF LEND = MIN( KDM1, N-J2 ) LAST = J1END + KD1 IF( LEND.GT.0 ) $ CALL DROT( LEND, AB( KD-1, LAST+1 ), INCX, $ AB( KD, LAST+1 ), INCX, D( LAST ), $ WORK( LAST ) ) END IF END IF * IF( WANTQ ) THEN * * accumulate product of plane rotations in Q * IF( INITQ ) THEN * * take advantage of the fact that Q was * initially the Identity matrix * IQEND = MAX( IQEND, J2 ) I2 = MAX( 0, K-3 ) IQAEND = 1 + I*KD IF( K.EQ.2 ) $ IQAEND = IQAEND + KD IQAEND = MIN( IQAEND, IQEND ) DO 50 J = J1, J2, KD1 IBL = I - I2 / KDM1 I2 = I2 + 1 IQB = MAX( 1, J-IBL ) NQ = 1 + IQAEND - IQB IQAEND = MIN( IQAEND+KD, IQEND ) CALL DROT( NQ, Q( IQB, J-1 ), 1, Q( IQB, J ), $ 1, D( J ), WORK( J ) ) 50 CONTINUE ELSE * DO 60 J = J1, J2, KD1 CALL DROT( N, Q( 1, J-1 ), 1, Q( 1, J ), 1, $ D( J ), WORK( J ) ) 60 CONTINUE END IF * END IF * IF( J2+KDN.GT.N ) THEN * * adjust J2 to keep within the bounds of the matrix * NR = NR - 1 J2 = J2 - KDN - 1 END IF * DO 70 J = J1, J2, KD1 * * create nonzero element a(j-1,j+kd) outside the band * and store it in WORK * WORK( J+KD ) = WORK( J )*AB( 1, J+KD ) AB( 1, J+KD ) = D( J )*AB( 1, J+KD ) 70 CONTINUE 80 CONTINUE 90 CONTINUE END IF * IF( KD.GT.0 ) THEN * * copy off-diagonal elements to E * DO 100 I = 1, N - 1 E( I ) = AB( KD, I+1 ) 100 CONTINUE ELSE * * set E to zero if original matrix was diagonal * DO 110 I = 1, N - 1 E( I ) = ZERO 110 CONTINUE END IF * * copy diagonal elements to D * DO 120 I = 1, N D( I ) = AB( KD1, I ) 120 CONTINUE * ELSE * IF( KD.GT.1 ) THEN * * Reduce to tridiagonal form, working with lower triangle * NR = 0 J1 = KDN + 2 J2 = 1 * DO 210 I = 1, N - 2 * * Reduce i-th column of matrix to tridiagonal form * DO 200 K = KDN + 1, 2, -1 J1 = J1 + KDN J2 = J2 + KDN * IF( NR.GT.0 ) THEN * * generate plane rotations to annihilate nonzero * elements which have been created outside the band * CALL DLARGV( NR, AB( KD1, J1-KD1 ), INCA, $ WORK( J1 ), KD1, D( J1 ), KD1 ) * * apply plane rotations from one side * * * Dependent on the the number of diagonals either * DLARTV or DROT is used * IF( NR.GT.2*KD-1 ) THEN DO 130 L = 1, KD - 1 CALL DLARTV( NR, AB( KD1-L, J1-KD1+L ), INCA, $ AB( KD1-L+1, J1-KD1+L ), INCA, $ D( J1 ), WORK( J1 ), KD1 ) 130 CONTINUE ELSE JEND = J1 + KD1*( NR-1 ) DO 140 JINC = J1, JEND, KD1 CALL DROT( KDM1, AB( KD, JINC-KD ), INCX, $ AB( KD1, JINC-KD ), INCX, $ D( JINC ), WORK( JINC ) ) 140 CONTINUE END IF * END IF * IF( K.GT.2 ) THEN IF( K.LE.N-I+1 ) THEN * * generate plane rotation to annihilate a(i+k-1,i) * within the band * CALL DLARTG( AB( K-1, I ), AB( K, I ), $ D( I+K-1 ), WORK( I+K-1 ), TEMP ) AB( K-1, I ) = TEMP * * apply rotation from the left * CALL DROT( K-3, AB( K-2, I+1 ), LDAB-1, $ AB( K-1, I+1 ), LDAB-1, D( I+K-1 ), $ WORK( I+K-1 ) ) END IF NR = NR + 1 J1 = J1 - KDN - 1 END IF * * apply plane rotations from both sides to diagonal * blocks * IF( NR.GT.0 ) $ CALL DLAR2V( NR, AB( 1, J1-1 ), AB( 1, J1 ), $ AB( 2, J1-1 ), INCA, D( J1 ), $ WORK( J1 ), KD1 ) * * apply plane rotations from the right * * * Dependent on the the number of diagonals either * DLARTV or DROT is used * IF( NR.GT.0 ) THEN IF( NR.GT.2*KD-1 ) THEN DO 150 L = 1, KD - 1 IF( J2+L.GT.N ) THEN NRT = NR - 1 ELSE NRT = NR END IF IF( NRT.GT.0 ) $ CALL DLARTV( NRT, AB( L+2, J1-1 ), INCA, $ AB( L+1, J1 ), INCA, D( J1 ), $ WORK( J1 ), KD1 ) 150 CONTINUE ELSE J1END = J1 + KD1*( NR-2 ) IF( J1END.GE.J1 ) THEN DO 160 J1INC = J1, J1END, KD1 CALL DROT( KDM1, AB( 3, J1INC-1 ), 1, $ AB( 2, J1INC ), 1, D( J1INC ), $ WORK( J1INC ) ) 160 CONTINUE END IF LEND = MIN( KDM1, N-J2 ) LAST = J1END + KD1 IF( LEND.GT.0 ) $ CALL DROT( LEND, AB( 3, LAST-1 ), 1, $ AB( 2, LAST ), 1, D( LAST ), $ WORK( LAST ) ) END IF END IF * * * IF( WANTQ ) THEN * * accumulate product of plane rotations in Q * IF( INITQ ) THEN * * take advantage of the fact that Q was * initially the Identity matrix * IQEND = MAX( IQEND, J2 ) I2 = MAX( 0, K-3 ) IQAEND = 1 + I*KD IF( K.EQ.2 ) $ IQAEND = IQAEND + KD IQAEND = MIN( IQAEND, IQEND ) DO 170 J = J1, J2, KD1 IBL = I - I2 / KDM1 I2 = I2 + 1 IQB = MAX( 1, J-IBL ) NQ = 1 + IQAEND - IQB IQAEND = MIN( IQAEND+KD, IQEND ) CALL DROT( NQ, Q( IQB, J-1 ), 1, Q( IQB, J ), $ 1, D( J ), WORK( J ) ) 170 CONTINUE ELSE * DO 180 J = J1, J2, KD1 CALL DROT( N, Q( 1, J-1 ), 1, Q( 1, J ), 1, $ D( J ), WORK( J ) ) 180 CONTINUE END IF END IF * IF( J2+KDN.GT.N ) THEN * * adjust J2 to keep within the bounds of the matrix * NR = NR - 1 J2 = J2 - KDN - 1 END IF * DO 190 J = J1, J2, KD1 * * create nonzero element a(j+kd,j-1) outside the * band and store it in WORK * WORK( J+KD ) = WORK( J )*AB( KD1, J ) AB( KD1, J ) = D( J )*AB( KD1, J ) 190 CONTINUE 200 CONTINUE 210 CONTINUE END IF * IF( KD.GT.0 ) THEN * * copy off-diagonal elements to E * DO 220 I = 1, N - 1 E( I ) = AB( 2, I ) 220 CONTINUE ELSE * * set E to zero if original matrix was diagonal * DO 230 I = 1, N - 1 E( I ) = ZERO 230 CONTINUE END IF * * copy diagonal elements to D * DO 240 I = 1, N D( I ) = AB( 1, I ) 240 CONTINUE END IF * RETURN * * End of DSBTRD * END *> \brief \b DSFRK performs a symmetric rank-k operation for matrix in RFP format. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSFRK + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, * C ) * * .. Scalar Arguments .. * DOUBLE PRECISION ALPHA, BETA * INTEGER K, LDA, N * CHARACTER TRANS, TRANSR, UPLO * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), C( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> Level 3 BLAS like routine for C in RFP Format. *> *> DSFRK performs one of the symmetric rank--k operations *> *> C := alpha*A*A**T + beta*C, *> *> or *> *> C := alpha*A**T*A + beta*C, *> *> where alpha and beta are real scalars, C is an n--by--n symmetric *> matrix and A is an n--by--k matrix in the first case and a k--by--n *> matrix in the second case. *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANSR *> \verbatim *> TRANSR is CHARACTER*1 *> = 'N': The Normal Form of RFP A is stored; *> = 'T': The Transpose Form of RFP A is stored. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> On entry, UPLO specifies whether the upper or lower *> triangular part of the array C is to be referenced as *> follows: *> *> UPLO = 'U' or 'u' Only the upper triangular part of C *> is to be referenced. *> *> UPLO = 'L' or 'l' Only the lower triangular part of C *> is to be referenced. *> *> Unchanged on exit. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> On entry, TRANS specifies the operation to be performed as *> follows: *> *> TRANS = 'N' or 'n' C := alpha*A*A**T + beta*C. *> *> TRANS = 'T' or 't' C := alpha*A**T*A + beta*C. *> *> Unchanged on exit. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> On entry, N specifies the order of the matrix C. N must be *> at least zero. *> Unchanged on exit. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> On entry with TRANS = 'N' or 'n', K specifies the number *> of columns of the matrix A, and on entry with TRANS = 'T' *> or 't', K specifies the number of rows of the matrix A. K *> must be at least zero. *> Unchanged on exit. *> \endverbatim *> *> \param[in] ALPHA *> \verbatim *> ALPHA is DOUBLE PRECISION *> On entry, ALPHA specifies the scalar alpha. *> Unchanged on exit. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,ka) *> where KA *> is K when TRANS = 'N' or 'n', and is N otherwise. Before *> entry with TRANS = 'N' or 'n', the leading N--by--K part of *> the array A must contain the matrix A, otherwise the leading *> K--by--N part of the array A must contain the matrix A. *> Unchanged on exit. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> On entry, LDA specifies the first dimension of A as declared *> in the calling (sub) program. When TRANS = 'N' or 'n' *> then LDA must be at least max( 1, n ), otherwise LDA must *> be at least max( 1, k ). *> Unchanged on exit. *> \endverbatim *> *> \param[in] BETA *> \verbatim *> BETA is DOUBLE PRECISION *> On entry, BETA specifies the scalar beta. *> Unchanged on exit. *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (NT) *> NT = N*(N+1)/2. On entry, the symmetric matrix C in RFP *> Format. RFP Format is described by TRANSR, UPLO and N. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DSFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, $ C ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION ALPHA, BETA INTEGER K, LDA, N CHARACTER TRANS, TRANSR, UPLO * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( * ) * .. * * ===================================================================== * * .. * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL LOWER, NORMALTRANSR, NISODD, NOTRANS INTEGER INFO, NROWA, J, NK, N1, N2 * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, DGEMM, DSYRK * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 NORMALTRANSR = LSAME( TRANSR, 'N' ) LOWER = LSAME( UPLO, 'L' ) NOTRANS = LSAME( TRANS, 'N' ) * IF( NOTRANS ) THEN NROWA = N ELSE NROWA = K END IF * IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN INFO = -1 ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN INFO = -2 ELSE IF( .NOT.NOTRANS .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( K.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSFRK ', -INFO ) RETURN END IF * * Quick return if possible. * * The quick return case: ((ALPHA.EQ.0).AND.(BETA.NE.ZERO)) is not * done (it is in DSYRK for example) and left in the general case. * IF( ( N.EQ.0 ) .OR. ( ( ( ALPHA.EQ.ZERO ) .OR. ( K.EQ.0 ) ) .AND. $ ( BETA.EQ.ONE ) ) )RETURN * IF( ( ALPHA.EQ.ZERO ) .AND. ( BETA.EQ.ZERO ) ) THEN DO J = 1, ( ( N*( N+1 ) ) / 2 ) C( J ) = ZERO END DO RETURN END IF * * C is N-by-N. * If N is odd, set NISODD = .TRUE., and N1 and N2. * If N is even, NISODD = .FALSE., and NK. * IF( MOD( N, 2 ).EQ.0 ) THEN NISODD = .FALSE. NK = N / 2 ELSE NISODD = .TRUE. IF( LOWER ) THEN N2 = N / 2 N1 = N - N2 ELSE N1 = N / 2 N2 = N - N1 END IF END IF * IF( NISODD ) THEN * * N is odd * IF( NORMALTRANSR ) THEN * * N is odd and TRANSR = 'N' * IF( LOWER ) THEN * * N is odd, TRANSR = 'N', and UPLO = 'L' * IF( NOTRANS ) THEN * * N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' * CALL DSYRK( 'L', 'N', N1, K, ALPHA, A( 1, 1 ), LDA, $ BETA, C( 1 ), N ) CALL DSYRK( 'U', 'N', N2, K, ALPHA, A( N1+1, 1 ), LDA, $ BETA, C( N+1 ), N ) CALL DGEMM( 'N', 'T', N2, N1, K, ALPHA, A( N1+1, 1 ), $ LDA, A( 1, 1 ), LDA, BETA, C( N1+1 ), N ) * ELSE * * N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'T' * CALL DSYRK( 'L', 'T', N1, K, ALPHA, A( 1, 1 ), LDA, $ BETA, C( 1 ), N ) CALL DSYRK( 'U', 'T', N2, K, ALPHA, A( 1, N1+1 ), LDA, $ BETA, C( N+1 ), N ) CALL DGEMM( 'T', 'N', N2, N1, K, ALPHA, A( 1, N1+1 ), $ LDA, A( 1, 1 ), LDA, BETA, C( N1+1 ), N ) * END IF * ELSE * * N is odd, TRANSR = 'N', and UPLO = 'U' * IF( NOTRANS ) THEN * * N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' * CALL DSYRK( 'L', 'N', N1, K, ALPHA, A( 1, 1 ), LDA, $ BETA, C( N2+1 ), N ) CALL DSYRK( 'U', 'N', N2, K, ALPHA, A( N2, 1 ), LDA, $ BETA, C( N1+1 ), N ) CALL DGEMM( 'N', 'T', N1, N2, K, ALPHA, A( 1, 1 ), $ LDA, A( N2, 1 ), LDA, BETA, C( 1 ), N ) * ELSE * * N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'T' * CALL DSYRK( 'L', 'T', N1, K, ALPHA, A( 1, 1 ), LDA, $ BETA, C( N2+1 ), N ) CALL DSYRK( 'U', 'T', N2, K, ALPHA, A( 1, N2 ), LDA, $ BETA, C( N1+1 ), N ) CALL DGEMM( 'T', 'N', N1, N2, K, ALPHA, A( 1, 1 ), $ LDA, A( 1, N2 ), LDA, BETA, C( 1 ), N ) * END IF * END IF * ELSE * * N is odd, and TRANSR = 'T' * IF( LOWER ) THEN * * N is odd, TRANSR = 'T', and UPLO = 'L' * IF( NOTRANS ) THEN * * N is odd, TRANSR = 'T', UPLO = 'L', and TRANS = 'N' * CALL DSYRK( 'U', 'N', N1, K, ALPHA, A( 1, 1 ), LDA, $ BETA, C( 1 ), N1 ) CALL DSYRK( 'L', 'N', N2, K, ALPHA, A( N1+1, 1 ), LDA, $ BETA, C( 2 ), N1 ) CALL DGEMM( 'N', 'T', N1, N2, K, ALPHA, A( 1, 1 ), $ LDA, A( N1+1, 1 ), LDA, BETA, $ C( N1*N1+1 ), N1 ) * ELSE * * N is odd, TRANSR = 'T', UPLO = 'L', and TRANS = 'T' * CALL DSYRK( 'U', 'T', N1, K, ALPHA, A( 1, 1 ), LDA, $ BETA, C( 1 ), N1 ) CALL DSYRK( 'L', 'T', N2, K, ALPHA, A( 1, N1+1 ), LDA, $ BETA, C( 2 ), N1 ) CALL DGEMM( 'T', 'N', N1, N2, K, ALPHA, A( 1, 1 ), $ LDA, A( 1, N1+1 ), LDA, BETA, $ C( N1*N1+1 ), N1 ) * END IF * ELSE * * N is odd, TRANSR = 'T', and UPLO = 'U' * IF( NOTRANS ) THEN * * N is odd, TRANSR = 'T', UPLO = 'U', and TRANS = 'N' * CALL DSYRK( 'U', 'N', N1, K, ALPHA, A( 1, 1 ), LDA, $ BETA, C( N2*N2+1 ), N2 ) CALL DSYRK( 'L', 'N', N2, K, ALPHA, A( N1+1, 1 ), LDA, $ BETA, C( N1*N2+1 ), N2 ) CALL DGEMM( 'N', 'T', N2, N1, K, ALPHA, A( N1+1, 1 ), $ LDA, A( 1, 1 ), LDA, BETA, C( 1 ), N2 ) * ELSE * * N is odd, TRANSR = 'T', UPLO = 'U', and TRANS = 'T' * CALL DSYRK( 'U', 'T', N1, K, ALPHA, A( 1, 1 ), LDA, $ BETA, C( N2*N2+1 ), N2 ) CALL DSYRK( 'L', 'T', N2, K, ALPHA, A( 1, N1+1 ), LDA, $ BETA, C( N1*N2+1 ), N2 ) CALL DGEMM( 'T', 'N', N2, N1, K, ALPHA, A( 1, N1+1 ), $ LDA, A( 1, 1 ), LDA, BETA, C( 1 ), N2 ) * END IF * END IF * END IF * ELSE * * N is even * IF( NORMALTRANSR ) THEN * * N is even and TRANSR = 'N' * IF( LOWER ) THEN * * N is even, TRANSR = 'N', and UPLO = 'L' * IF( NOTRANS ) THEN * * N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' * CALL DSYRK( 'L', 'N', NK, K, ALPHA, A( 1, 1 ), LDA, $ BETA, C( 2 ), N+1 ) CALL DSYRK( 'U', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA, $ BETA, C( 1 ), N+1 ) CALL DGEMM( 'N', 'T', NK, NK, K, ALPHA, A( NK+1, 1 ), $ LDA, A( 1, 1 ), LDA, BETA, C( NK+2 ), $ N+1 ) * ELSE * * N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'T' * CALL DSYRK( 'L', 'T', NK, K, ALPHA, A( 1, 1 ), LDA, $ BETA, C( 2 ), N+1 ) CALL DSYRK( 'U', 'T', NK, K, ALPHA, A( 1, NK+1 ), LDA, $ BETA, C( 1 ), N+1 ) CALL DGEMM( 'T', 'N', NK, NK, K, ALPHA, A( 1, NK+1 ), $ LDA, A( 1, 1 ), LDA, BETA, C( NK+2 ), $ N+1 ) * END IF * ELSE * * N is even, TRANSR = 'N', and UPLO = 'U' * IF( NOTRANS ) THEN * * N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' * CALL DSYRK( 'L', 'N', NK, K, ALPHA, A( 1, 1 ), LDA, $ BETA, C( NK+2 ), N+1 ) CALL DSYRK( 'U', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA, $ BETA, C( NK+1 ), N+1 ) CALL DGEMM( 'N', 'T', NK, NK, K, ALPHA, A( 1, 1 ), $ LDA, A( NK+1, 1 ), LDA, BETA, C( 1 ), $ N+1 ) * ELSE * * N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'T' * CALL DSYRK( 'L', 'T', NK, K, ALPHA, A( 1, 1 ), LDA, $ BETA, C( NK+2 ), N+1 ) CALL DSYRK( 'U', 'T', NK, K, ALPHA, A( 1, NK+1 ), LDA, $ BETA, C( NK+1 ), N+1 ) CALL DGEMM( 'T', 'N', NK, NK, K, ALPHA, A( 1, 1 ), $ LDA, A( 1, NK+1 ), LDA, BETA, C( 1 ), $ N+1 ) * END IF * END IF * ELSE * * N is even, and TRANSR = 'T' * IF( LOWER ) THEN * * N is even, TRANSR = 'T', and UPLO = 'L' * IF( NOTRANS ) THEN * * N is even, TRANSR = 'T', UPLO = 'L', and TRANS = 'N' * CALL DSYRK( 'U', 'N', NK, K, ALPHA, A( 1, 1 ), LDA, $ BETA, C( NK+1 ), NK ) CALL DSYRK( 'L', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA, $ BETA, C( 1 ), NK ) CALL DGEMM( 'N', 'T', NK, NK, K, ALPHA, A( 1, 1 ), $ LDA, A( NK+1, 1 ), LDA, BETA, $ C( ( ( NK+1 )*NK )+1 ), NK ) * ELSE * * N is even, TRANSR = 'T', UPLO = 'L', and TRANS = 'T' * CALL DSYRK( 'U', 'T', NK, K, ALPHA, A( 1, 1 ), LDA, $ BETA, C( NK+1 ), NK ) CALL DSYRK( 'L', 'T', NK, K, ALPHA, A( 1, NK+1 ), LDA, $ BETA, C( 1 ), NK ) CALL DGEMM( 'T', 'N', NK, NK, K, ALPHA, A( 1, 1 ), $ LDA, A( 1, NK+1 ), LDA, BETA, $ C( ( ( NK+1 )*NK )+1 ), NK ) * END IF * ELSE * * N is even, TRANSR = 'T', and UPLO = 'U' * IF( NOTRANS ) THEN * * N is even, TRANSR = 'T', UPLO = 'U', and TRANS = 'N' * CALL DSYRK( 'U', 'N', NK, K, ALPHA, A( 1, 1 ), LDA, $ BETA, C( NK*( NK+1 )+1 ), NK ) CALL DSYRK( 'L', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA, $ BETA, C( NK*NK+1 ), NK ) CALL DGEMM( 'N', 'T', NK, NK, K, ALPHA, A( NK+1, 1 ), $ LDA, A( 1, 1 ), LDA, BETA, C( 1 ), NK ) * ELSE * * N is even, TRANSR = 'T', UPLO = 'U', and TRANS = 'T' * CALL DSYRK( 'U', 'T', NK, K, ALPHA, A( 1, 1 ), LDA, $ BETA, C( NK*( NK+1 )+1 ), NK ) CALL DSYRK( 'L', 'T', NK, K, ALPHA, A( 1, NK+1 ), LDA, $ BETA, C( NK*NK+1 ), NK ) CALL DGEMM( 'T', 'N', NK, NK, K, ALPHA, A( 1, NK+1 ), $ LDA, A( 1, 1 ), LDA, BETA, C( 1 ), NK ) * END IF * END IF * END IF * END IF * RETURN * * End of DSFRK * END *> \brief \b DSPCON * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSPCON + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, IWORK, * INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N * DOUBLE PRECISION ANORM, RCOND * .. * .. Array Arguments .. * INTEGER IPIV( * ), IWORK( * ) * DOUBLE PRECISION AP( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSPCON estimates the reciprocal of the condition number (in the *> 1-norm) of a real symmetric packed matrix A using the factorization *> A = U*D*U**T or A = L*D*L**T computed by DSPTRF. *> *> An estimate is obtained for norm(inv(A)), and the reciprocal of the *> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the details of the factorization are stored *> as an upper or lower triangular matrix. *> = 'U': Upper triangular, form is A = U*D*U**T; *> = 'L': Lower triangular, form is A = L*D*L**T. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> The block diagonal matrix D and the multipliers used to *> obtain the factor U or L as computed by DSPTRF, stored as a *> packed triangular matrix. *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N) *> Details of the interchanges and the block structure of D *> as determined by DSPTRF. *> \endverbatim *> *> \param[in] ANORM *> \verbatim *> ANORM is DOUBLE PRECISION *> The 1-norm of the original matrix A. *> \endverbatim *> *> \param[out] RCOND *> \verbatim *> RCOND is 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. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (2*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, IWORK, $ INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, N DOUBLE PRECISION ANORM, RCOND * .. * .. Array Arguments .. INTEGER IPIV( * ), IWORK( * ) DOUBLE PRECISION AP( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER I, IP, KASE DOUBLE PRECISION AINVNM * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLACN2, DSPTRS, XERBLA * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( ANORM.LT.ZERO ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSPCON', -INFO ) RETURN END IF * * Quick return if possible * RCOND = ZERO IF( N.EQ.0 ) THEN RCOND = ONE RETURN ELSE IF( ANORM.LE.ZERO ) THEN RETURN END IF * * Check that the diagonal matrix D is nonsingular. * IF( UPPER ) THEN * * Upper triangular storage: examine D from bottom to top * IP = N*( N+1 ) / 2 DO 10 I = N, 1, -1 IF( IPIV( I ).GT.0 .AND. AP( IP ).EQ.ZERO ) $ RETURN IP = IP - I 10 CONTINUE ELSE * * Lower triangular storage: examine D from top to bottom. * IP = 1 DO 20 I = 1, N IF( IPIV( I ).GT.0 .AND. AP( IP ).EQ.ZERO ) $ RETURN IP = IP + N - I + 1 20 CONTINUE END IF * * Estimate the 1-norm of the inverse. * KASE = 0 30 CONTINUE CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) IF( KASE.NE.0 ) THEN * * Multiply by inv(L*D*L**T) or inv(U*D*U**T). * CALL DSPTRS( UPLO, N, 1, AP, IPIV, WORK, N, INFO ) GO TO 30 END IF * * Compute the estimate of the reciprocal condition number. * IF( AINVNM.NE.ZERO ) $ RCOND = ( ONE / AINVNM ) / ANORM * RETURN * * End of DSPCON * END *> \brief DSPEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSPEV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, LDZ, N * .. * .. Array Arguments .. * DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSPEV computes all the eigenvalues and, optionally, eigenvectors of a *> real symmetric matrix A in packed storage. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBZ *> \verbatim *> JOBZ is CHARACTER*1 *> = 'N': Compute eigenvalues only; *> = 'V': Compute eigenvalues and eigenvectors. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> On entry, the upper or lower triangle of the symmetric matrix *> A, packed columnwise in a linear array. The j-th column of A *> is stored in the array AP as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. *> *> On exit, AP is overwritten by values generated during the *> reduction to tridiagonal form. If UPLO = 'U', the diagonal *> and first superdiagonal of the tridiagonal matrix T overwrite *> the corresponding elements of A, and if UPLO = 'L', the *> diagonal and first subdiagonal of T overwrite the *> corresponding elements of A. *> \endverbatim *> *> \param[out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> If INFO = 0, the eigenvalues in ascending order. *> \endverbatim *> *> \param[out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ, N) *> If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal *> eigenvectors of the matrix A, with the i-th column of Z *> holding the eigenvector associated with W(i). *> If JOBZ = 'N', then Z is not referenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1, and if *> JOBZ = 'V', LDZ >= max(1,N). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: if INFO = i, the algorithm failed to converge; i *> off-diagonal elements of an intermediate tridiagonal *> form did not converge to zero. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHEReigen * * ===================================================================== SUBROUTINE DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO INTEGER INFO, LDZ, N * .. * .. Array Arguments .. DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL WANTZ INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, $ SMLNUM * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANSP EXTERNAL LSAME, DLAMCH, DLANSP * .. * .. External Subroutines .. EXTERNAL DOPGTR, DSCAL, DSPTRD, DSTEQR, DSTERF, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC SQRT * .. * .. Executable Statements .. * * Test the input parameters. * WANTZ = LSAME( JOBZ, 'V' ) * INFO = 0 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) ) $ THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN INFO = -7 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSPEV ', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( N.EQ.1 ) THEN W( 1 ) = AP( 1 ) IF( WANTZ ) $ Z( 1, 1 ) = ONE RETURN END IF * * Get machine constants. * SAFMIN = DLAMCH( 'Safe minimum' ) EPS = DLAMCH( 'Precision' ) SMLNUM = SAFMIN / EPS BIGNUM = ONE / SMLNUM RMIN = SQRT( SMLNUM ) RMAX = SQRT( BIGNUM ) * * Scale matrix to allowable range, if necessary. * ANRM = DLANSP( 'M', UPLO, N, AP, WORK ) ISCALE = 0 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN ISCALE = 1 SIGMA = RMAX / ANRM END IF IF( ISCALE.EQ.1 ) THEN CALL DSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 ) END IF * * Call DSPTRD to reduce symmetric packed matrix to tridiagonal form. * INDE = 1 INDTAU = INDE + N CALL DSPTRD( UPLO, N, AP, W, WORK( INDE ), WORK( INDTAU ), IINFO ) * * For eigenvalues only, call DSTERF. For eigenvectors, first call * DOPGTR to generate the orthogonal matrix, then call DSTEQR. * IF( .NOT.WANTZ ) THEN CALL DSTERF( N, W, WORK( INDE ), INFO ) ELSE INDWRK = INDTAU + N CALL DOPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ, $ WORK( INDWRK ), IINFO ) CALL DSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDTAU ), $ INFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * IF( ISCALE.EQ.1 ) THEN IF( INFO.EQ.0 ) THEN IMAX = N ELSE IMAX = INFO - 1 END IF CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) END IF * RETURN * * End of DSPEV * END *> \brief DSPEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSPEVD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, * IWORK, LIWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, LDZ, LIWORK, LWORK, N * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSPEVD computes all the eigenvalues and, optionally, eigenvectors *> of a real symmetric matrix A in packed storage. If eigenvectors are *> desired, it uses a divide and conquer algorithm. *> *> The divide and conquer algorithm makes very mild assumptions about *> floating point arithmetic. It will work on machines with a guard *> digit in add/subtract, or on those binary machines without guard *> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or *> Cray-2. It could conceivably fail on hexadecimal or decimal machines *> without guard digits, but we know of none. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBZ *> \verbatim *> JOBZ is CHARACTER*1 *> = 'N': Compute eigenvalues only; *> = 'V': Compute eigenvalues and eigenvectors. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> On entry, the upper or lower triangle of the symmetric matrix *> A, packed columnwise in a linear array. The j-th column of A *> is stored in the array AP as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. *> *> On exit, AP is overwritten by values generated during the *> reduction to tridiagonal form. If UPLO = 'U', the diagonal *> and first superdiagonal of the tridiagonal matrix T overwrite *> the corresponding elements of A, and if UPLO = 'L', the *> diagonal and first subdiagonal of T overwrite the *> corresponding elements of A. *> \endverbatim *> *> \param[out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> If INFO = 0, the eigenvalues in ascending order. *> \endverbatim *> *> \param[out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ, N) *> If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal *> eigenvectors of the matrix A, with the i-th column of Z *> holding the eigenvector associated with W(i). *> If JOBZ = 'N', then Z is not referenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1, and if *> JOBZ = 'V', LDZ >= max(1,N). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the required LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. *> If N <= 1, LWORK must be at least 1. *> If JOBZ = 'N' and N > 1, LWORK must be at least 2*N. *> If JOBZ = 'V' and N > 1, LWORK must be at least *> 1 + 6*N + N**2. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the required sizes of the WORK and IWORK *> arrays, returns these values as the first entries of the WORK *> and IWORK arrays, and no error message related to LWORK or *> LIWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) *> On exit, if INFO = 0, IWORK(1) returns the required LIWORK. *> \endverbatim *> *> \param[in] LIWORK *> \verbatim *> LIWORK is INTEGER *> The dimension of the array IWORK. *> If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. *> If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. *> *> If LIWORK = -1, then a workspace query is assumed; the *> routine only calculates the required sizes of the WORK and *> IWORK arrays, returns these values as the first entries of *> the WORK and IWORK arrays, and no error message related to *> LWORK or LIWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: if INFO = i, the algorithm failed to converge; i *> off-diagonal elements of an intermediate tridiagonal *> form did not converge to zero. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup doubleOTHEReigen * * ===================================================================== SUBROUTINE DSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, $ IWORK, LIWORK, INFO ) * * -- LAPACK driver routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO INTEGER INFO, LDZ, LIWORK, LWORK, N * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, WANTZ INTEGER IINFO, INDE, INDTAU, INDWRK, ISCALE, LIWMIN, $ LLWORK, LWMIN DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, $ SMLNUM * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANSP EXTERNAL LSAME, DLAMCH, DLANSP * .. * .. External Subroutines .. EXTERNAL DOPMTR, DSCAL, DSPTRD, DSTEDC, DSTERF, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC SQRT * .. * .. Executable Statements .. * * Test the input parameters. * WANTZ = LSAME( JOBZ, 'V' ) LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) * INFO = 0 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) ) $ THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN INFO = -7 END IF * IF( INFO.EQ.0 ) THEN IF( N.LE.1 ) THEN LIWMIN = 1 LWMIN = 1 ELSE IF( WANTZ ) THEN LIWMIN = 3 + 5*N LWMIN = 1 + 6*N + N**2 ELSE LIWMIN = 1 LWMIN = 2*N END IF END IF IWORK( 1 ) = LIWMIN WORK( 1 ) = LWMIN * IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN INFO = -9 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN INFO = -11 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSPEVD', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( N.EQ.1 ) THEN W( 1 ) = AP( 1 ) IF( WANTZ ) $ Z( 1, 1 ) = ONE RETURN END IF * * Get machine constants. * SAFMIN = DLAMCH( 'Safe minimum' ) EPS = DLAMCH( 'Precision' ) SMLNUM = SAFMIN / EPS BIGNUM = ONE / SMLNUM RMIN = SQRT( SMLNUM ) RMAX = SQRT( BIGNUM ) * * Scale matrix to allowable range, if necessary. * ANRM = DLANSP( 'M', UPLO, N, AP, WORK ) ISCALE = 0 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN ISCALE = 1 SIGMA = RMAX / ANRM END IF IF( ISCALE.EQ.1 ) THEN CALL DSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 ) END IF * * Call DSPTRD to reduce symmetric packed matrix to tridiagonal form. * INDE = 1 INDTAU = INDE + N CALL DSPTRD( UPLO, N, AP, W, WORK( INDE ), WORK( INDTAU ), IINFO ) * * For eigenvalues only, call DSTERF. For eigenvectors, first call * DSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the * tridiagonal matrix, then call DOPMTR to multiply it by the * Householder transformations represented in AP. * IF( .NOT.WANTZ ) THEN CALL DSTERF( N, W, WORK( INDE ), INFO ) ELSE INDWRK = INDTAU + N LLWORK = LWORK - INDWRK + 1 CALL DSTEDC( 'I', N, W, WORK( INDE ), Z, LDZ, WORK( INDWRK ), $ LLWORK, IWORK, LIWORK, INFO ) CALL DOPMTR( 'L', UPLO, 'N', N, N, AP, WORK( INDTAU ), Z, LDZ, $ WORK( INDWRK ), IINFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * IF( ISCALE.EQ.1 ) $ CALL DSCAL( N, ONE / SIGMA, W, 1 ) * WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN RETURN * * End of DSPEVD * END *> \brief DSPEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSPEVX + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, * ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, * INFO ) * * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, IU, LDZ, M, N * DOUBLE PRECISION ABSTOL, VL, VU * .. * .. Array Arguments .. * INTEGER IFAIL( * ), IWORK( * ) * DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSPEVX computes selected eigenvalues and, optionally, eigenvectors *> of a real symmetric matrix A in packed storage. Eigenvalues/vectors *> can be selected by specifying either a range of values or a range of *> indices for the desired eigenvalues. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBZ *> \verbatim *> JOBZ is CHARACTER*1 *> = 'N': Compute eigenvalues only; *> = 'V': Compute eigenvalues and eigenvectors. *> \endverbatim *> *> \param[in] RANGE *> \verbatim *> RANGE is CHARACTER*1 *> = 'A': all eigenvalues will be found; *> = 'V': all eigenvalues in the half-open interval (VL,VU] *> will be found; *> = 'I': the IL-th through IU-th eigenvalues will be found. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> On entry, the upper or lower triangle of the symmetric matrix *> A, packed columnwise in a linear array. The j-th column of A *> is stored in the array AP as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. *> *> On exit, AP is overwritten by values generated during the *> reduction to tridiagonal form. If UPLO = 'U', the diagonal *> and first superdiagonal of the tridiagonal matrix T overwrite *> the corresponding elements of A, and if UPLO = 'L', the *> diagonal and first subdiagonal of T overwrite the *> corresponding elements of A. *> \endverbatim *> *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION *> If RANGE='V', the lower bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION *> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] IL *> \verbatim *> IL is INTEGER *> If RANGE='I', the index of the *> smallest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> If RANGE='I', the index of the *> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] ABSTOL *> \verbatim *> ABSTOL is DOUBLE PRECISION *> The absolute error tolerance for the eigenvalues. *> An approximate eigenvalue is accepted as converged *> when it is determined to lie in an interval [a,b] *> of width less than or equal to *> *> ABSTOL + EPS * max( |a|,|b| ) , *> *> where EPS is the machine precision. If ABSTOL is less than *> or equal to zero, then EPS*|T| will be used in its place, *> where |T| is the 1-norm of the tridiagonal matrix obtained *> by reducing AP to tridiagonal form. *> *> Eigenvalues will be computed most accurately when ABSTOL is *> set to twice the underflow threshold 2*DLAMCH('S'), not zero. *> If this routine returns with INFO>0, indicating that some *> eigenvectors did not converge, try setting ABSTOL to *> 2*DLAMCH('S'). *> *> See "Computing Small Singular Values of Bidiagonal Matrices *> with Guaranteed High Relative Accuracy," by Demmel and *> Kahan, LAPACK Working Note #3. *> \endverbatim *> *> \param[out] M *> \verbatim *> M is INTEGER *> The total number of eigenvalues found. 0 <= M <= N. *> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. *> \endverbatim *> *> \param[out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> If INFO = 0, the selected eigenvalues in ascending order. *> \endverbatim *> *> \param[out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M)) *> If JOBZ = 'V', then if INFO = 0, the first M columns of Z *> contain the orthonormal eigenvectors of the matrix A *> corresponding to the selected eigenvalues, with the i-th *> column of Z holding the eigenvector associated with W(i). *> If an eigenvector fails to converge, then that column of Z *> contains the latest approximation to the eigenvector, and the *> index of the eigenvector is returned in IFAIL. *> If JOBZ = 'N', then Z is not referenced. *> Note: the user must ensure that at least max(1,M) columns are *> supplied in the array Z; if RANGE = 'V', the exact value of M *> is not known in advance and an upper bound must be used. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1, and if *> JOBZ = 'V', LDZ >= max(1,N). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (8*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (5*N) *> \endverbatim *> *> \param[out] IFAIL *> \verbatim *> IFAIL is INTEGER array, dimension (N) *> If JOBZ = 'V', then if INFO = 0, the first M elements of *> IFAIL are zero. If INFO > 0, then IFAIL contains the *> indices of the eigenvectors that failed to converge. *> If JOBZ = 'N', then IFAIL is not referenced. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, then i eigenvectors failed to converge. *> Their indices are stored in array IFAIL. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleOTHEReigen * * ===================================================================== SUBROUTINE DSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, $ ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, $ INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO INTEGER IL, INFO, IU, LDZ, M, N DOUBLE PRECISION ABSTOL, VL, VU * .. * .. Array Arguments .. INTEGER IFAIL( * ), IWORK( * ) DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL ALLEIG, INDEIG, TEST, VALEIG, WANTZ CHARACTER ORDER INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, $ INDISP, INDIWO, INDTAU, INDWRK, ISCALE, ITMP1, $ J, JJ, NSPLIT DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, $ SIGMA, SMLNUM, TMP1, VLL, VUU * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANSP EXTERNAL LSAME, DLAMCH, DLANSP * .. * .. External Subroutines .. EXTERNAL DCOPY, DOPGTR, DOPMTR, DSCAL, DSPTRD, DSTEBZ, $ DSTEIN, DSTEQR, DSTERF, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * WANTZ = LSAME( JOBZ, 'V' ) ALLEIG = LSAME( RANGE, 'A' ) VALEIG = LSAME( RANGE, 'V' ) INDEIG = LSAME( RANGE, 'I' ) * INFO = 0 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN INFO = -2 ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) ) $ THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( VALEIG ) THEN IF( N.GT.0 .AND. VU.LE.VL ) $ INFO = -7 ELSE IF( INDEIG ) THEN IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN INFO = -9 END IF END IF END IF IF( INFO.EQ.0 ) THEN IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) $ INFO = -14 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSPEVX', -INFO ) RETURN END IF * * Quick return if possible * M = 0 IF( N.EQ.0 ) $ RETURN * IF( N.EQ.1 ) THEN IF( ALLEIG .OR. INDEIG ) THEN M = 1 W( 1 ) = AP( 1 ) ELSE IF( VL.LT.AP( 1 ) .AND. VU.GE.AP( 1 ) ) THEN M = 1 W( 1 ) = AP( 1 ) END IF END IF IF( WANTZ ) $ Z( 1, 1 ) = ONE RETURN END IF * * Get machine constants. * SAFMIN = DLAMCH( 'Safe minimum' ) EPS = DLAMCH( 'Precision' ) SMLNUM = SAFMIN / EPS BIGNUM = ONE / SMLNUM RMIN = SQRT( SMLNUM ) RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) * * Scale matrix to allowable range, if necessary. * ISCALE = 0 ABSTLL = ABSTOL IF( VALEIG ) THEN VLL = VL VUU = VU ELSE VLL = ZERO VUU = ZERO END IF ANRM = DLANSP( 'M', UPLO, N, AP, WORK ) IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN ISCALE = 1 SIGMA = RMAX / ANRM END IF IF( ISCALE.EQ.1 ) THEN CALL DSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 ) IF( ABSTOL.GT.0 ) $ ABSTLL = ABSTOL*SIGMA IF( VALEIG ) THEN VLL = VL*SIGMA VUU = VU*SIGMA END IF END IF * * Call DSPTRD to reduce symmetric packed matrix to tridiagonal form. * INDTAU = 1 INDE = INDTAU + N INDD = INDE + N INDWRK = INDD + N CALL DSPTRD( UPLO, N, AP, WORK( INDD ), WORK( INDE ), $ WORK( INDTAU ), IINFO ) * * If all eigenvalues are desired and ABSTOL is less than or equal * to zero, then call DSTERF or DOPGTR and SSTEQR. If this fails * for some eigenvalue, then try DSTEBZ. * TEST = .FALSE. IF (INDEIG) THEN IF (IL.EQ.1 .AND. IU.EQ.N) THEN TEST = .TRUE. END IF END IF IF ((ALLEIG .OR. TEST) .AND. (ABSTOL.LE.ZERO)) THEN CALL DCOPY( N, WORK( INDD ), 1, W, 1 ) INDEE = INDWRK + 2*N IF( .NOT.WANTZ ) THEN CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) CALL DSTERF( N, W, WORK( INDEE ), INFO ) ELSE CALL DOPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ, $ WORK( INDWRK ), IINFO ) CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ, $ WORK( INDWRK ), INFO ) IF( INFO.EQ.0 ) THEN DO 10 I = 1, N IFAIL( I ) = 0 10 CONTINUE END IF END IF IF( INFO.EQ.0 ) THEN M = N GO TO 20 END IF INFO = 0 END IF * * Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. * IF( WANTZ ) THEN ORDER = 'B' ELSE ORDER = 'E' END IF INDIBL = 1 INDISP = INDIBL + N INDIWO = INDISP + N CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W, $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ), $ IWORK( INDIWO ), INFO ) * IF( WANTZ ) THEN CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, $ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO ) * * Apply orthogonal matrix used in reduction to tridiagonal * form to eigenvectors returned by DSTEIN. * CALL DOPMTR( 'L', UPLO, 'N', N, M, AP, WORK( INDTAU ), Z, LDZ, $ WORK( INDWRK ), IINFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * 20 CONTINUE IF( ISCALE.EQ.1 ) THEN IF( INFO.EQ.0 ) THEN IMAX = M ELSE IMAX = INFO - 1 END IF CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) END IF * * If eigenvalues are not in order, then sort them, along with * eigenvectors. * IF( WANTZ ) THEN DO 40 J = 1, M - 1 I = 0 TMP1 = W( J ) DO 30 JJ = J + 1, M IF( W( JJ ).LT.TMP1 ) THEN I = JJ TMP1 = W( JJ ) END IF 30 CONTINUE * IF( I.NE.0 ) THEN ITMP1 = IWORK( INDIBL+I-1 ) W( I ) = W( J ) IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) W( J ) = TMP1 IWORK( INDIBL+J-1 ) = ITMP1 CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) IF( INFO.NE.0 ) THEN ITMP1 = IFAIL( I ) IFAIL( I ) = IFAIL( J ) IFAIL( J ) = ITMP1 END IF END IF 40 CONTINUE END IF * RETURN * * End of DSPEVX * END *> \brief \b DSPGST * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSPGST + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSPGST( ITYPE, UPLO, N, AP, BP, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, ITYPE, N * .. * .. Array Arguments .. * DOUBLE PRECISION AP( * ), BP( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSPGST reduces a real symmetric-definite generalized eigenproblem *> to standard form, using packed storage. *> *> If ITYPE = 1, the problem is A*x = lambda*B*x, *> and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T) *> *> If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or *> B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L. *> *> B must have been previously factorized as U**T*U or L*L**T by DPPTRF. *> \endverbatim * * Arguments: * ========== * *> \param[in] ITYPE *> \verbatim *> ITYPE is INTEGER *> = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T); *> = 2 or 3: compute U*A*U**T or L**T*A*L. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored and B is factored as *> U**T*U; *> = 'L': Lower triangle of A is stored and B is factored as *> L*L**T. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A and B. N >= 0. *> \endverbatim *> *> \param[in,out] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> On entry, the upper or lower triangle of the symmetric matrix *> A, packed columnwise in a linear array. The j-th column of A *> is stored in the array AP as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. *> *> On exit, if INFO = 0, the transformed matrix, stored in the *> same format as A. *> \endverbatim *> *> \param[in] BP *> \verbatim *> BP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> The triangular factor from the Cholesky factorization of B, *> stored in the same format as A, as returned by DPPTRF. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DSPGST( ITYPE, UPLO, N, AP, BP, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, ITYPE, N * .. * .. Array Arguments .. DOUBLE PRECISION AP( * ), BP( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, HALF PARAMETER ( ONE = 1.0D0, HALF = 0.5D0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER J, J1, J1J1, JJ, K, K1, K1K1, KK DOUBLE PRECISION AJJ, AKK, BJJ, BKK, CT * .. * .. External Subroutines .. EXTERNAL DAXPY, DSCAL, DSPMV, DSPR2, DTPMV, DTPSV, $ XERBLA * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT EXTERNAL LSAME, DDOT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN INFO = -1 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSPGST', -INFO ) RETURN END IF * IF( ITYPE.EQ.1 ) THEN IF( UPPER ) THEN * * Compute inv(U**T)*A*inv(U) * * J1 and JJ are the indices of A(1,j) and A(j,j) * JJ = 0 DO 10 J = 1, N J1 = JJ + 1 JJ = JJ + J * * Compute the j-th column of the upper triangle of A * BJJ = BP( JJ ) CALL DTPSV( UPLO, 'Transpose', 'Nonunit', J, BP, $ AP( J1 ), 1 ) CALL DSPMV( UPLO, J-1, -ONE, AP, BP( J1 ), 1, ONE, $ AP( J1 ), 1 ) CALL DSCAL( J-1, ONE / BJJ, AP( J1 ), 1 ) AP( JJ ) = ( AP( JJ )-DDOT( J-1, AP( J1 ), 1, BP( J1 ), $ 1 ) ) / BJJ 10 CONTINUE ELSE * * Compute inv(L)*A*inv(L**T) * * KK and K1K1 are the indices of A(k,k) and A(k+1,k+1) * KK = 1 DO 20 K = 1, N K1K1 = KK + N - K + 1 * * Update the lower triangle of A(k:n,k:n) * AKK = AP( KK ) BKK = BP( KK ) AKK = AKK / BKK**2 AP( KK ) = AKK IF( K.LT.N ) THEN CALL DSCAL( N-K, ONE / BKK, AP( KK+1 ), 1 ) CT = -HALF*AKK CALL DAXPY( N-K, CT, BP( KK+1 ), 1, AP( KK+1 ), 1 ) CALL DSPR2( UPLO, N-K, -ONE, AP( KK+1 ), 1, $ BP( KK+1 ), 1, AP( K1K1 ) ) CALL DAXPY( N-K, CT, BP( KK+1 ), 1, AP( KK+1 ), 1 ) CALL DTPSV( UPLO, 'No transpose', 'Non-unit', N-K, $ BP( K1K1 ), AP( KK+1 ), 1 ) END IF KK = K1K1 20 CONTINUE END IF ELSE IF( UPPER ) THEN * * Compute U*A*U**T * * K1 and KK are the indices of A(1,k) and A(k,k) * KK = 0 DO 30 K = 1, N K1 = KK + 1 KK = KK + K * * Update the upper triangle of A(1:k,1:k) * AKK = AP( KK ) BKK = BP( KK ) CALL DTPMV( UPLO, 'No transpose', 'Non-unit', K-1, BP, $ AP( K1 ), 1 ) CT = HALF*AKK CALL DAXPY( K-1, CT, BP( K1 ), 1, AP( K1 ), 1 ) CALL DSPR2( UPLO, K-1, ONE, AP( K1 ), 1, BP( K1 ), 1, $ AP ) CALL DAXPY( K-1, CT, BP( K1 ), 1, AP( K1 ), 1 ) CALL DSCAL( K-1, BKK, AP( K1 ), 1 ) AP( KK ) = AKK*BKK**2 30 CONTINUE ELSE * * Compute L**T *A*L * * JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1) * JJ = 1 DO 40 J = 1, N J1J1 = JJ + N - J + 1 * * Compute the j-th column of the lower triangle of A * AJJ = AP( JJ ) BJJ = BP( JJ ) AP( JJ ) = AJJ*BJJ + DDOT( N-J, AP( JJ+1 ), 1, $ BP( JJ+1 ), 1 ) CALL DSCAL( N-J, BJJ, AP( JJ+1 ), 1 ) CALL DSPMV( UPLO, N-J, ONE, AP( J1J1 ), BP( JJ+1 ), 1, $ ONE, AP( JJ+1 ), 1 ) CALL DTPMV( UPLO, 'Transpose', 'Non-unit', N-J+1, $ BP( JJ ), AP( JJ ), 1 ) JJ = J1J1 40 CONTINUE END IF END IF RETURN * * End of DSPGST * END *> \brief \b DSPGV * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSPGV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, * INFO ) * * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, ITYPE, LDZ, N * .. * .. Array Arguments .. * DOUBLE PRECISION AP( * ), BP( * ), W( * ), WORK( * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSPGV computes all the eigenvalues and, optionally, the eigenvectors *> of a real generalized symmetric-definite eigenproblem, of the form *> A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. *> Here A and B are assumed to be symmetric, stored in packed format, *> and B is also positive definite. *> \endverbatim * * Arguments: * ========== * *> \param[in] ITYPE *> \verbatim *> ITYPE is INTEGER *> Specifies the problem type to be solved: *> = 1: A*x = (lambda)*B*x *> = 2: A*B*x = (lambda)*x *> = 3: B*A*x = (lambda)*x *> \endverbatim *> *> \param[in] JOBZ *> \verbatim *> JOBZ is CHARACTER*1 *> = 'N': Compute eigenvalues only; *> = 'V': Compute eigenvalues and eigenvectors. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangles of A and B are stored; *> = 'L': Lower triangles of A and B are stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A and B. N >= 0. *> \endverbatim *> *> \param[in,out] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> On entry, the upper or lower triangle of the symmetric matrix *> A, packed columnwise in a linear array. The j-th column of A *> is stored in the array AP as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. *> *> On exit, the contents of AP are destroyed. *> \endverbatim *> *> \param[in,out] BP *> \verbatim *> BP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> On entry, the upper or lower triangle of the symmetric matrix *> B, packed columnwise in a linear array. The j-th column of B *> is stored in the array BP as follows: *> if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; *> if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. *> *> On exit, the triangular factor U or L from the Cholesky *> factorization B = U**T*U or B = L*L**T, in the same storage *> format as B. *> \endverbatim *> *> \param[out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> If INFO = 0, the eigenvalues in ascending order. *> \endverbatim *> *> \param[out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ, N) *> If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of *> eigenvectors. The eigenvectors are normalized as follows: *> if ITYPE = 1 or 2, Z**T*B*Z = I; *> if ITYPE = 3, Z**T*inv(B)*Z = I. *> If JOBZ = 'N', then Z is not referenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1, and if *> JOBZ = 'V', LDZ >= max(1,N). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: DPPTRF or DSPEV returned an error code: *> <= N: if INFO = i, DSPEV failed to converge; *> i off-diagonal elements of an intermediate *> tridiagonal form did not converge to zero. *> > N: if INFO = n + i, for 1 <= i <= n, then the leading *> minor of order i of B is not positive definite. *> The factorization of B could not be completed and *> no eigenvalues or eigenvectors were computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup doubleOTHEReigen * * ===================================================================== SUBROUTINE DSPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, $ INFO ) * * -- LAPACK driver routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO INTEGER INFO, ITYPE, LDZ, N * .. * .. Array Arguments .. DOUBLE PRECISION AP( * ), BP( * ), W( * ), WORK( * ), $ Z( LDZ, * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL UPPER, WANTZ CHARACTER TRANS INTEGER J, NEIG * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DPPTRF, DSPEV, DSPGST, DTPMV, DTPSV, XERBLA * .. * .. Executable Statements .. * * Test the input parameters. * WANTZ = LSAME( JOBZ, 'V' ) UPPER = LSAME( UPLO, 'U' ) * INFO = 0 IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN INFO = -1 ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -2 ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN INFO = -9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSPGV ', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Form a Cholesky factorization of B. * CALL DPPTRF( UPLO, N, BP, INFO ) IF( INFO.NE.0 ) THEN INFO = N + INFO RETURN END IF * * Transform problem to standard eigenvalue problem and solve. * CALL DSPGST( ITYPE, UPLO, N, AP, BP, INFO ) CALL DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO ) * IF( WANTZ ) THEN * * Backtransform eigenvectors to the original problem. * NEIG = N IF( INFO.GT.0 ) $ NEIG = INFO - 1 IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN * * For A*x=(lambda)*B*x and A*B*x=(lambda)*x; * backtransform eigenvectors: x = inv(L)**T*y or inv(U)*y * IF( UPPER ) THEN TRANS = 'N' ELSE TRANS = 'T' END IF * DO 10 J = 1, NEIG CALL DTPSV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ), $ 1 ) 10 CONTINUE * ELSE IF( ITYPE.EQ.3 ) THEN * * For B*A*x=(lambda)*x; * backtransform eigenvectors: x = L*y or U**T*y * IF( UPPER ) THEN TRANS = 'T' ELSE TRANS = 'N' END IF * DO 20 J = 1, NEIG CALL DTPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ), $ 1 ) 20 CONTINUE END IF END IF RETURN * * End of DSPGV * END *> \brief \b DSPGVD * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSPGVD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, * LWORK, IWORK, LIWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, ITYPE, LDZ, LIWORK, LWORK, N * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION AP( * ), BP( * ), W( * ), WORK( * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSPGVD computes all the eigenvalues, and optionally, the eigenvectors *> of a real generalized symmetric-definite eigenproblem, of the form *> A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and *> B are assumed to be symmetric, stored in packed format, and B is also *> positive definite. *> If eigenvectors are desired, it uses a divide and conquer algorithm. *> *> The divide and conquer algorithm makes very mild assumptions about *> floating point arithmetic. It will work on machines with a guard *> digit in add/subtract, or on those binary machines without guard *> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or *> Cray-2. It could conceivably fail on hexadecimal or decimal machines *> without guard digits, but we know of none. *> \endverbatim * * Arguments: * ========== * *> \param[in] ITYPE *> \verbatim *> ITYPE is INTEGER *> Specifies the problem type to be solved: *> = 1: A*x = (lambda)*B*x *> = 2: A*B*x = (lambda)*x *> = 3: B*A*x = (lambda)*x *> \endverbatim *> *> \param[in] JOBZ *> \verbatim *> JOBZ is CHARACTER*1 *> = 'N': Compute eigenvalues only; *> = 'V': Compute eigenvalues and eigenvectors. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangles of A and B are stored; *> = 'L': Lower triangles of A and B are stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A and B. N >= 0. *> \endverbatim *> *> \param[in,out] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> On entry, the upper or lower triangle of the symmetric matrix *> A, packed columnwise in a linear array. The j-th column of A *> is stored in the array AP as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. *> *> On exit, the contents of AP are destroyed. *> \endverbatim *> *> \param[in,out] BP *> \verbatim *> BP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> On entry, the upper or lower triangle of the symmetric matrix *> B, packed columnwise in a linear array. The j-th column of B *> is stored in the array BP as follows: *> if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; *> if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. *> *> On exit, the triangular factor U or L from the Cholesky *> factorization B = U**T*U or B = L*L**T, in the same storage *> format as B. *> \endverbatim *> *> \param[out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> If INFO = 0, the eigenvalues in ascending order. *> \endverbatim *> *> \param[out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ, N) *> If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of *> eigenvectors. The eigenvectors are normalized as follows: *> if ITYPE = 1 or 2, Z**T*B*Z = I; *> if ITYPE = 3, Z**T*inv(B)*Z = I. *> If JOBZ = 'N', then Z is not referenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1, and if *> JOBZ = 'V', LDZ >= max(1,N). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the required LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. *> If N <= 1, LWORK >= 1. *> If JOBZ = 'N' and N > 1, LWORK >= 2*N. *> If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the required sizes of the WORK and IWORK *> arrays, returns these values as the first entries of the WORK *> and IWORK arrays, and no error message related to LWORK or *> LIWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) *> On exit, if INFO = 0, IWORK(1) returns the required LIWORK. *> \endverbatim *> *> \param[in] LIWORK *> \verbatim *> LIWORK is INTEGER *> The dimension of the array IWORK. *> If JOBZ = 'N' or N <= 1, LIWORK >= 1. *> If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. *> *> If LIWORK = -1, then a workspace query is assumed; the *> routine only calculates the required sizes of the WORK and *> IWORK arrays, returns these values as the first entries of *> the WORK and IWORK arrays, and no error message related to *> LWORK or LIWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: DPPTRF or DSPEVD returned an error code: *> <= N: if INFO = i, DSPEVD failed to converge; *> i off-diagonal elements of an intermediate *> tridiagonal form did not converge to zero; *> > N: if INFO = N + i, for 1 <= i <= N, then the leading *> minor of order i of B is not positive definite. *> The factorization of B could not be completed and *> no eigenvalues or eigenvectors were computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHEReigen * *> \par Contributors: * ================== *> *> Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA * * ===================================================================== SUBROUTINE DSPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, $ LWORK, IWORK, LIWORK, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO INTEGER INFO, ITYPE, LDZ, LIWORK, LWORK, N * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION AP( * ), BP( * ), W( * ), WORK( * ), $ Z( LDZ, * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL LQUERY, UPPER, WANTZ CHARACTER TRANS INTEGER J, LIWMIN, LWMIN, NEIG * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DPPTRF, DSPEVD, DSPGST, DTPMV, DTPSV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MAX * .. * .. Executable Statements .. * * Test the input parameters. * WANTZ = LSAME( JOBZ, 'V' ) UPPER = LSAME( UPLO, 'U' ) LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) * INFO = 0 IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN INFO = -1 ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -2 ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN INFO = -9 END IF * IF( INFO.EQ.0 ) THEN IF( N.LE.1 ) THEN LIWMIN = 1 LWMIN = 1 ELSE IF( WANTZ ) THEN LIWMIN = 3 + 5*N LWMIN = 1 + 6*N + 2*N**2 ELSE LIWMIN = 1 LWMIN = 2*N END IF END IF WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN INFO = -11 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN INFO = -13 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSPGVD', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Form a Cholesky factorization of BP. * CALL DPPTRF( UPLO, N, BP, INFO ) IF( INFO.NE.0 ) THEN INFO = N + INFO RETURN END IF * * Transform problem to standard eigenvalue problem and solve. * CALL DSPGST( ITYPE, UPLO, N, AP, BP, INFO ) CALL DSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, IWORK, $ LIWORK, INFO ) LWMIN = MAX( DBLE( LWMIN ), DBLE( WORK( 1 ) ) ) LIWMIN = MAX( DBLE( LIWMIN ), DBLE( IWORK( 1 ) ) ) * IF( WANTZ ) THEN * * Backtransform eigenvectors to the original problem. * NEIG = N IF( INFO.GT.0 ) $ NEIG = INFO - 1 IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN * * For A*x=(lambda)*B*x and A*B*x=(lambda)*x; * backtransform eigenvectors: x = inv(L)**T *y or inv(U)*y * IF( UPPER ) THEN TRANS = 'N' ELSE TRANS = 'T' END IF * DO 10 J = 1, NEIG CALL DTPSV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ), $ 1 ) 10 CONTINUE * ELSE IF( ITYPE.EQ.3 ) THEN * * For B*A*x=(lambda)*x; * backtransform eigenvectors: x = L*y or U**T *y * IF( UPPER ) THEN TRANS = 'T' ELSE TRANS = 'N' END IF * DO 20 J = 1, NEIG CALL DTPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ), $ 1 ) 20 CONTINUE END IF END IF * WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN * RETURN * * End of DSPGVD * END *> \brief \b DSPGVX * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSPGVX + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, * IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, * IFAIL, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, ITYPE, IU, LDZ, M, N * DOUBLE PRECISION ABSTOL, VL, VU * .. * .. Array Arguments .. * INTEGER IFAIL( * ), IWORK( * ) * DOUBLE PRECISION AP( * ), BP( * ), W( * ), WORK( * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSPGVX computes selected eigenvalues, and optionally, eigenvectors *> of a real generalized symmetric-definite eigenproblem, of the form *> A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A *> and B are assumed to be symmetric, stored in packed storage, and B *> is also positive definite. Eigenvalues and eigenvectors can be *> selected by specifying either a range of values or a range of indices *> for the desired eigenvalues. *> \endverbatim * * Arguments: * ========== * *> \param[in] ITYPE *> \verbatim *> ITYPE is INTEGER *> Specifies the problem type to be solved: *> = 1: A*x = (lambda)*B*x *> = 2: A*B*x = (lambda)*x *> = 3: B*A*x = (lambda)*x *> \endverbatim *> *> \param[in] JOBZ *> \verbatim *> JOBZ is CHARACTER*1 *> = 'N': Compute eigenvalues only; *> = 'V': Compute eigenvalues and eigenvectors. *> \endverbatim *> *> \param[in] RANGE *> \verbatim *> RANGE is CHARACTER*1 *> = 'A': all eigenvalues will be found. *> = 'V': all eigenvalues in the half-open interval (VL,VU] *> will be found. *> = 'I': the IL-th through IU-th eigenvalues will be found. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A and B are stored; *> = 'L': Lower triangle of A and B are stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix pencil (A,B). N >= 0. *> \endverbatim *> *> \param[in,out] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> On entry, the upper or lower triangle of the symmetric matrix *> A, packed columnwise in a linear array. The j-th column of A *> is stored in the array AP as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. *> *> On exit, the contents of AP are destroyed. *> \endverbatim *> *> \param[in,out] BP *> \verbatim *> BP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> On entry, the upper or lower triangle of the symmetric matrix *> B, packed columnwise in a linear array. The j-th column of B *> is stored in the array BP as follows: *> if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; *> if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. *> *> On exit, the triangular factor U or L from the Cholesky *> factorization B = U**T*U or B = L*L**T, in the same storage *> format as B. *> \endverbatim *> *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION *> *> If RANGE='V', the lower bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION *> *> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] IL *> \verbatim *> IL is INTEGER *> *> If RANGE='I', the index of the *> smallest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> *> If RANGE='I', the index of the *> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] ABSTOL *> \verbatim *> ABSTOL is DOUBLE PRECISION *> The absolute error tolerance for the eigenvalues. *> An approximate eigenvalue is accepted as converged *> when it is determined to lie in an interval [a,b] *> of width less than or equal to *> *> ABSTOL + EPS * max( |a|,|b| ) , *> *> where EPS is the machine precision. If ABSTOL is less than *> or equal to zero, then EPS*|T| will be used in its place, *> where |T| is the 1-norm of the tridiagonal matrix obtained *> by reducing A to tridiagonal form. *> *> Eigenvalues will be computed most accurately when ABSTOL is *> set to twice the underflow threshold 2*DLAMCH('S'), not zero. *> If this routine returns with INFO>0, indicating that some *> eigenvectors did not converge, try setting ABSTOL to *> 2*DLAMCH('S'). *> \endverbatim *> *> \param[out] M *> \verbatim *> M is INTEGER *> The total number of eigenvalues found. 0 <= M <= N. *> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. *> \endverbatim *> *> \param[out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> On normal exit, the first M elements contain the selected *> eigenvalues in ascending order. *> \endverbatim *> *> \param[out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M)) *> If JOBZ = 'N', then Z is not referenced. *> If JOBZ = 'V', then if INFO = 0, the first M columns of Z *> contain the orthonormal eigenvectors of the matrix A *> corresponding to the selected eigenvalues, with the i-th *> column of Z holding the eigenvector associated with W(i). *> The eigenvectors are normalized as follows: *> if ITYPE = 1 or 2, Z**T*B*Z = I; *> if ITYPE = 3, Z**T*inv(B)*Z = I. *> *> If an eigenvector fails to converge, then that column of Z *> contains the latest approximation to the eigenvector, and the *> index of the eigenvector is returned in IFAIL. *> Note: the user must ensure that at least max(1,M) columns are *> supplied in the array Z; if RANGE = 'V', the exact value of M *> is not known in advance and an upper bound must be used. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1, and if *> JOBZ = 'V', LDZ >= max(1,N). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (8*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (5*N) *> \endverbatim *> *> \param[out] IFAIL *> \verbatim *> IFAIL is INTEGER array, dimension (N) *> If JOBZ = 'V', then if INFO = 0, the first M elements of *> IFAIL are zero. If INFO > 0, then IFAIL contains the *> indices of the eigenvectors that failed to converge. *> If JOBZ = 'N', then IFAIL is not referenced. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: DPPTRF or DSPEVX returned an error code: *> <= N: if INFO = i, DSPEVX failed to converge; *> i eigenvectors failed to converge. Their indices *> are stored in array IFAIL. *> > N: if INFO = N + i, for 1 <= i <= N, then the leading *> minor of order i of B is not positive definite. *> The factorization of B could not be completed and *> no eigenvalues or eigenvectors were computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleOTHEReigen * *> \par Contributors: * ================== *> *> Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA * * ===================================================================== SUBROUTINE DSPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, $ IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, $ IFAIL, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO INTEGER IL, INFO, ITYPE, IU, LDZ, M, N DOUBLE PRECISION ABSTOL, VL, VU * .. * .. Array Arguments .. INTEGER IFAIL( * ), IWORK( * ) DOUBLE PRECISION AP( * ), BP( * ), W( * ), WORK( * ), $ Z( LDZ, * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL ALLEIG, INDEIG, UPPER, VALEIG, WANTZ CHARACTER TRANS INTEGER J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DPPTRF, DSPEVX, DSPGST, DTPMV, DTPSV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * * Test the input parameters. * UPPER = LSAME( UPLO, 'U' ) WANTZ = LSAME( JOBZ, 'V' ) ALLEIG = LSAME( RANGE, 'A' ) VALEIG = LSAME( RANGE, 'V' ) INDEIG = LSAME( RANGE, 'I' ) * INFO = 0 IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN INFO = -1 ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -2 ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN INFO = -3 ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( VALEIG ) THEN IF( N.GT.0 .AND. VU.LE.VL ) THEN INFO = -9 END IF ELSE IF( INDEIG ) THEN IF( IL.LT.1 ) THEN INFO = -10 ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN INFO = -11 END IF END IF END IF IF( INFO.EQ.0 ) THEN IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN INFO = -16 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSPGVX', -INFO ) RETURN END IF * * Quick return if possible * M = 0 IF( N.EQ.0 ) $ RETURN * * Form a Cholesky factorization of B. * CALL DPPTRF( UPLO, N, BP, INFO ) IF( INFO.NE.0 ) THEN INFO = N + INFO RETURN END IF * * Transform problem to standard eigenvalue problem and solve. * CALL DSPGST( ITYPE, UPLO, N, AP, BP, INFO ) CALL DSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M, $ W, Z, LDZ, WORK, IWORK, IFAIL, INFO ) * IF( WANTZ ) THEN * * Backtransform eigenvectors to the original problem. * IF( INFO.GT.0 ) $ M = INFO - 1 IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN * * For A*x=(lambda)*B*x and A*B*x=(lambda)*x; * backtransform eigenvectors: x = inv(L)**T*y or inv(U)*y * IF( UPPER ) THEN TRANS = 'N' ELSE TRANS = 'T' END IF * DO 10 J = 1, M CALL DTPSV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ), $ 1 ) 10 CONTINUE * ELSE IF( ITYPE.EQ.3 ) THEN * * For B*A*x=(lambda)*x; * backtransform eigenvectors: x = L*y or U**T*y * IF( UPPER ) THEN TRANS = 'T' ELSE TRANS = 'N' END IF * DO 20 J = 1, M CALL DTPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ), $ 1 ) 20 CONTINUE END IF END IF * RETURN * * End of DSPGVX * END *> \brief \b DSPRFS * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSPRFS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, * FERR, BERR, WORK, IWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, LDX, N, NRHS * .. * .. Array Arguments .. * INTEGER IPIV( * ), IWORK( * ) * DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ), * $ FERR( * ), WORK( * ), X( LDX, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSPRFS improves the computed solution to a system of linear *> equations when the coefficient matrix is symmetric indefinite *> and packed, and provides error bounds and backward error estimates *> for the solution. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrices B and X. NRHS >= 0. *> \endverbatim *> *> \param[in] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> The upper or lower triangle of the symmetric matrix A, packed *> columnwise in a linear array. The j-th column of A is stored *> in the array AP as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. *> \endverbatim *> *> \param[in] AFP *> \verbatim *> AFP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> The factored form of the matrix A. AFP contains the block *> diagonal matrix D and the multipliers used to obtain the *> factor U or L from the factorization A = U*D*U**T or *> A = L*D*L**T as computed by DSPTRF, stored as a packed *> triangular matrix. *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N) *> Details of the interchanges and the block structure of D *> as determined by DSPTRF. *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> The right hand side matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,NRHS) *> On entry, the solution matrix X, as computed by DSPTRS. *> On exit, the improved solution matrix X. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the array X. LDX >= max(1,N). *> \endverbatim *> *> \param[out] FERR *> \verbatim *> FERR is 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. *> \endverbatim *> *> \param[out] BERR *> \verbatim *> BERR is 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). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * *> \par Internal Parameters: * ========================= *> *> \verbatim *> ITMAX is the maximum number of steps of iterative refinement. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, $ FERR, BERR, WORK, IWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDB, LDX, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ), IWORK( * ) DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ), $ FERR( * ), WORK( * ), X( LDX, * ) * .. * * ===================================================================== * * .. 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 UPPER INTEGER COUNT, I, IK, J, K, KASE, KK, NZ DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) * .. * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DLACN2, DSPMV, DSPTRS, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL LSAME, DLAMCH * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( NRHS.LT.0 ) THEN INFO = -3 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSPRFS', -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 * * 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 - A * X * CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 ) CALL DSPMV( UPLO, N, -ONE, AP, X( 1, J ), 1, ONE, WORK( N+1 ), $ 1 ) * * Compute componentwise relative backward error from formula * * max(i) ( abs(R(i)) / ( abs(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(A)*abs(X) + abs(B). * KK = 1 IF( UPPER ) THEN DO 50 K = 1, N S = ZERO XK = ABS( X( K, J ) ) IK = KK DO 40 I = 1, K - 1 WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK S = S + ABS( AP( IK ) )*ABS( X( I, J ) ) IK = IK + 1 40 CONTINUE WORK( K ) = WORK( K ) + ABS( AP( KK+K-1 ) )*XK + S KK = KK + K 50 CONTINUE ELSE DO 70 K = 1, N S = ZERO XK = ABS( X( K, J ) ) WORK( K ) = WORK( K ) + ABS( AP( KK ) )*XK IK = KK + 1 DO 60 I = K + 1, N WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK S = S + ABS( AP( IK ) )*ABS( X( I, J ) ) IK = IK + 1 60 CONTINUE WORK( K ) = WORK( K ) + S KK = KK + ( N-K+1 ) 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 DSPTRS( UPLO, N, 1, AFP, 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(A))* * ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) * * where * norm(Z) is the magnitude of the largest component of Z * inv(A) is the inverse of 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(A)*abs(X)+abs(B)) * is incremented by SAFE1 if the i-th component of * abs(A)*abs(X) + abs(B) is less than SAFE2. * * Use DLACN2 to estimate the infinity-norm of the matrix * inv(A) * diag(W), * where W = abs(R) + NZ*EPS*( abs(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(A**T). * CALL DSPTRS( UPLO, N, 1, AFP, IPIV, WORK( N+1 ), N, $ INFO ) DO 110 I = 1, N WORK( N+I ) = WORK( I )*WORK( N+I ) 110 CONTINUE ELSE IF( KASE.EQ.2 ) THEN * * Multiply by inv(A)*diag(W). * DO 120 I = 1, N WORK( N+I ) = WORK( I )*WORK( N+I ) 120 CONTINUE CALL DSPTRS( UPLO, N, 1, AFP, 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 DSPRFS * END *> \brief DSPSV computes the solution to system of linear equations A * X = B for OTHER matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSPSV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. * INTEGER IPIV( * ) * DOUBLE PRECISION AP( * ), B( LDB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSPSV computes the solution to a real system of linear equations *> A * X = B, *> where A is an N-by-N symmetric matrix stored in packed format and X *> and B are N-by-NRHS matrices. *> *> The diagonal pivoting method is used to factor A as *> A = U * D * U**T, if UPLO = 'U', or *> A = L * D * L**T, if UPLO = 'L', *> where U (or L) is a product of permutation and unit upper (lower) *> triangular matrices, D is symmetric and block diagonal with 1-by-1 *> and 2-by-2 diagonal blocks. The factored form of A is then used to *> solve the system of equations A * X = B. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of linear equations, i.e., the order of the *> matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrix B. NRHS >= 0. *> \endverbatim *> *> \param[in,out] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> On entry, the upper or lower triangle of the symmetric matrix *> A, packed columnwise in a linear array. The j-th column of A *> is stored in the array AP as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. *> See below for further details. *> *> On exit, the block diagonal matrix D and the multipliers used *> to obtain the factor U or L from the factorization *> A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as *> a packed triangular matrix in the same storage format as A. *> \endverbatim *> *> \param[out] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N) *> Details of the interchanges and the block structure of D, as *> determined by DSPTRF. If IPIV(k) > 0, then rows and columns *> k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1 *> diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, *> then rows and columns k-1 and -IPIV(k) were interchanged and *> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and *> IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and *> -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 *> diagonal block. *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> On entry, the N-by-NRHS right hand side matrix B. *> On exit, if INFO = 0, the N-by-NRHS solution matrix X. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, D(i,i) is exactly zero. The factorization *> has been completed, but the block diagonal matrix D is *> exactly singular, so the solution could not be *> computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERsolve * *> \par Further Details: * ===================== *> *> \verbatim *> *> The packed storage scheme is illustrated by the following example *> when N = 4, UPLO = 'U': *> *> Two-dimensional storage of the symmetric matrix A: *> *> a11 a12 a13 a14 *> a22 a23 a24 *> a33 a34 (aij = aji) *> a44 *> *> Packed storage of the upper triangle of A: *> *> AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] *> \endverbatim *> * ===================================================================== SUBROUTINE DSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION AP( * ), B( LDB, * ) * .. * * ===================================================================== * * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DSPTRF, DSPTRS, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) 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 = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSPSV ', -INFO ) RETURN END IF * * Compute the factorization A = U*D*U**T or A = L*D*L**T. * CALL DSPTRF( UPLO, N, AP, IPIV, INFO ) IF( INFO.EQ.0 ) THEN * * Solve the system A*X = B, overwriting B with X. * CALL DSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) * END IF RETURN * * End of DSPSV * END *> \brief DSPSVX computes the solution to system of linear equations A * X = B for OTHER matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSPSVX + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, * LDX, RCOND, FERR, BERR, WORK, IWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER FACT, UPLO * INTEGER INFO, LDB, LDX, N, NRHS * DOUBLE PRECISION RCOND * .. * .. Array Arguments .. * INTEGER IPIV( * ), IWORK( * ) * DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ), * $ FERR( * ), WORK( * ), X( LDX, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSPSVX uses the diagonal pivoting factorization A = U*D*U**T or *> A = L*D*L**T to compute the solution to a real system of linear *> equations A * X = B, where A is an N-by-N symmetric matrix stored *> in packed format and X and B are N-by-NRHS matrices. *> *> Error bounds on the solution and a condition estimate are also *> provided. *> \endverbatim * *> \par Description: * ================= *> *> \verbatim *> *> The following steps are performed: *> *> 1. If FACT = 'N', the diagonal pivoting method is used to factor A as *> A = U * D * U**T, if UPLO = 'U', or *> A = L * D * L**T, if UPLO = 'L', *> where U (or L) is a product of permutation and unit upper (lower) *> triangular matrices and D is symmetric and block diagonal with *> 1-by-1 and 2-by-2 diagonal blocks. *> *> 2. If some D(i,i)=0, so that D 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] FACT *> \verbatim *> FACT is CHARACTER*1 *> Specifies whether or not the factored form of A has been *> supplied on entry. *> = 'F': On entry, AFP and IPIV contain the factored form of *> A. AP, AFP and IPIV will not be modified. *> = 'N': The matrix A will be copied to AFP and factored. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of linear equations, i.e., the order of the *> matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrices B and X. NRHS >= 0. *> \endverbatim *> *> \param[in] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> The upper or lower triangle of the symmetric matrix A, packed *> columnwise in a linear array. The j-th column of A is stored *> in the array AP as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. *> See below for further details. *> \endverbatim *> *> \param[in,out] AFP *> \verbatim *> AFP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> If FACT = 'F', then AFP is an input argument and on entry *> contains the block diagonal matrix D and the multipliers used *> to obtain the factor U or L from the factorization *> A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as *> a packed triangular matrix in the same storage format as A. *> *> If FACT = 'N', then AFP is an output argument and on exit *> contains the block diagonal matrix D and the multipliers used *> to obtain the factor U or L from the factorization *> A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as *> a packed triangular matrix in the same storage format as A. *> \endverbatim *> *> \param[in,out] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N) *> If FACT = 'F', then IPIV is an input argument and on entry *> contains details of the interchanges and the block structure *> of D, as determined by DSPTRF. *> If IPIV(k) > 0, then rows and columns k and IPIV(k) were *> interchanged and D(k,k) is a 1-by-1 diagonal block. *> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and *> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) *> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = *> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were *> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. *> *> If FACT = 'N', then IPIV is an output argument and on exit *> contains details of the interchanges and the block structure *> of D, as determined by DSPTRF. *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> The N-by-NRHS right hand side matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,NRHS) *> If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the array X. LDX >= max(1,N). *> \endverbatim *> *> \param[out] RCOND *> \verbatim *> RCOND is 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. *> \endverbatim *> *> \param[out] FERR *> \verbatim *> FERR is 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. *> \endverbatim *> *> \param[out] BERR *> \verbatim *> BERR is 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). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, and i is *> <= N: D(i,i) is exactly zero. The factorization *> has been completed but the factor D is exactly *> singular, so the solution and error bounds could *> not be computed. RCOND = 0 is returned. *> = N+1: D 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. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date April 2012 * *> \ingroup doubleOTHERsolve * *> \par Further Details: * ===================== *> *> \verbatim *> *> The packed storage scheme is illustrated by the following example *> when N = 4, UPLO = 'U': *> *> Two-dimensional storage of the symmetric matrix A: *> *> a11 a12 a13 a14 *> a22 a23 a24 *> a33 a34 (aij = aji) *> a44 *> *> Packed storage of the upper triangle of A: *> *> AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] *> \endverbatim *> * ===================================================================== SUBROUTINE DSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, $ LDX, RCOND, FERR, BERR, WORK, IWORK, INFO ) * * -- LAPACK driver routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * April 2012 * * .. Scalar Arguments .. CHARACTER FACT, UPLO INTEGER INFO, LDB, LDX, N, NRHS DOUBLE PRECISION RCOND * .. * .. Array Arguments .. INTEGER IPIV( * ), IWORK( * ) DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ), $ FERR( * ), WORK( * ), X( LDX, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOFACT DOUBLE PRECISION ANORM * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANSP EXTERNAL LSAME, DLAMCH, DLANSP * .. * .. External Subroutines .. EXTERNAL DCOPY, DLACPY, DSPCON, DSPRFS, DSPTRF, DSPTRS, $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 NOFACT = LSAME( FACT, 'N' ) IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN INFO = -1 ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) $ 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 = -9 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -11 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSPSVX', -INFO ) RETURN END IF * IF( NOFACT ) THEN * * Compute the factorization A = U*D*U**T or A = L*D*L**T. * CALL DCOPY( N*( N+1 ) / 2, AP, 1, AFP, 1 ) CALL DSPTRF( UPLO, N, AFP, 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. * ANORM = DLANSP( 'I', UPLO, N, AP, WORK ) * * Compute the reciprocal of the condition number of A. * CALL DSPCON( UPLO, N, AFP, IPIV, ANORM, RCOND, WORK, IWORK, INFO ) * * Compute the solution vectors X. * CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) CALL DSPTRS( UPLO, N, NRHS, AFP, IPIV, X, LDX, INFO ) * * Use iterative refinement to improve the computed solutions and * compute error bounds and backward error estimates for them. * CALL DSPRFS( UPLO, N, NRHS, AP, AFP, 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 DSPSVX * END *> \brief \b DSPTRD * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSPTRD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSPTRD( UPLO, N, AP, D, E, TAU, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N * .. * .. Array Arguments .. * DOUBLE PRECISION AP( * ), D( * ), E( * ), TAU( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSPTRD reduces a real symmetric matrix A stored in packed form to *> symmetric tridiagonal form T by an orthogonal similarity *> transformation: Q**T * A * Q = T. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> On entry, the upper or lower triangle of the symmetric matrix *> A, packed columnwise in a linear array. The j-th column of A *> is stored in the array AP as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. *> On exit, if UPLO = 'U', the diagonal and first superdiagonal *> of A are overwritten by the corresponding elements of the *> tridiagonal matrix T, and the elements above the first *> superdiagonal, with the array TAU, represent the orthogonal *> matrix Q as a product of elementary reflectors; if UPLO *> = 'L', the diagonal and first subdiagonal of A are over- *> written by the corresponding elements of the tridiagonal *> matrix T, and the elements below the first subdiagonal, with *> the array TAU, represent the orthogonal matrix Q as a product *> of elementary reflectors. See Further Details. *> \endverbatim *> *> \param[out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The diagonal elements of the tridiagonal matrix T: *> D(i) = A(i,i). *> \endverbatim *> *> \param[out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N-1) *> The off-diagonal elements of the tridiagonal matrix T: *> E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (N-1) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> If UPLO = 'U', the matrix Q is represented as a product of elementary *> reflectors *> *> Q = H(n-1) . . . H(2) H(1). *> *> Each H(i) has the form *> *> H(i) = I - tau * v * v**T *> *> where tau is a real scalar, and v is a real vector with *> v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP, *> overwriting A(1:i-1,i+1), and tau is stored in TAU(i). *> *> If UPLO = 'L', the matrix Q is represented as a product of elementary *> reflectors *> *> Q = H(1) H(2) . . . H(n-1). *> *> Each H(i) has the form *> *> H(i) = I - tau * v * v**T *> *> where tau is a real scalar, and v is a real vector with *> v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP, *> overwriting A(i+2:n,i), and tau is stored in TAU(i). *> \endverbatim *> * ===================================================================== SUBROUTINE DSPTRD( UPLO, N, AP, D, E, TAU, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, N * .. * .. Array Arguments .. DOUBLE PRECISION AP( * ), D( * ), E( * ), TAU( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO, HALF PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0, $ HALF = 1.0D0 / 2.0D0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER I, I1, I1I1, II DOUBLE PRECISION ALPHA, TAUI * .. * .. External Subroutines .. EXTERNAL DAXPY, DLARFG, DSPMV, DSPR2, XERBLA * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT EXTERNAL LSAME, DDOT * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSPTRD', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.0 ) $ RETURN * IF( UPPER ) THEN * * Reduce the upper triangle of A. * I1 is the index in AP of A(1,I+1). * I1 = N*( N-1 ) / 2 + 1 DO 10 I = N - 1, 1, -1 * * Generate elementary reflector H(i) = I - tau * v * v**T * to annihilate A(1:i-1,i+1) * CALL DLARFG( I, AP( I1+I-1 ), AP( I1 ), 1, TAUI ) E( I ) = AP( I1+I-1 ) * IF( TAUI.NE.ZERO ) THEN * * Apply H(i) from both sides to A(1:i,1:i) * AP( I1+I-1 ) = ONE * * Compute y := tau * A * v storing y in TAU(1:i) * CALL DSPMV( UPLO, I, TAUI, AP, AP( I1 ), 1, ZERO, TAU, $ 1 ) * * Compute w := y - 1/2 * tau * (y**T *v) * v * ALPHA = -HALF*TAUI*DDOT( I, TAU, 1, AP( I1 ), 1 ) CALL DAXPY( I, ALPHA, AP( I1 ), 1, TAU, 1 ) * * Apply the transformation as a rank-2 update: * A := A - v * w**T - w * v**T * CALL DSPR2( UPLO, I, -ONE, AP( I1 ), 1, TAU, 1, AP ) * AP( I1+I-1 ) = E( I ) END IF D( I+1 ) = AP( I1+I ) TAU( I ) = TAUI I1 = I1 - I 10 CONTINUE D( 1 ) = AP( 1 ) ELSE * * Reduce the lower triangle of A. II is the index in AP of * A(i,i) and I1I1 is the index of A(i+1,i+1). * II = 1 DO 20 I = 1, N - 1 I1I1 = II + N - I + 1 * * Generate elementary reflector H(i) = I - tau * v * v**T * to annihilate A(i+2:n,i) * CALL DLARFG( N-I, AP( II+1 ), AP( II+2 ), 1, TAUI ) E( I ) = AP( II+1 ) * IF( TAUI.NE.ZERO ) THEN * * Apply H(i) from both sides to A(i+1:n,i+1:n) * AP( II+1 ) = ONE * * Compute y := tau * A * v storing y in TAU(i:n-1) * CALL DSPMV( UPLO, N-I, TAUI, AP( I1I1 ), AP( II+1 ), 1, $ ZERO, TAU( I ), 1 ) * * Compute w := y - 1/2 * tau * (y**T *v) * v * ALPHA = -HALF*TAUI*DDOT( N-I, TAU( I ), 1, AP( II+1 ), $ 1 ) CALL DAXPY( N-I, ALPHA, AP( II+1 ), 1, TAU( I ), 1 ) * * Apply the transformation as a rank-2 update: * A := A - v * w**T - w * v**T * CALL DSPR2( UPLO, N-I, -ONE, AP( II+1 ), 1, TAU( I ), 1, $ AP( I1I1 ) ) * AP( II+1 ) = E( I ) END IF D( I ) = AP( II ) TAU( I ) = TAUI II = I1I1 20 CONTINUE D( N ) = AP( II ) END IF * RETURN * * End of DSPTRD * END *> \brief \b DSPTRF * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSPTRF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSPTRF( UPLO, N, AP, IPIV, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N * .. * .. Array Arguments .. * INTEGER IPIV( * ) * DOUBLE PRECISION AP( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSPTRF computes the factorization of a real symmetric matrix A stored *> in packed format using the Bunch-Kaufman diagonal pivoting method: *> *> A = U*D*U**T or A = L*D*L**T *> *> where U (or L) is a product of permutation and unit upper (lower) *> triangular matrices, and D is symmetric and block diagonal with *> 1-by-1 and 2-by-2 diagonal blocks. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> On entry, the upper or lower triangle of the symmetric matrix *> A, packed columnwise in a linear array. The j-th column of A *> is stored in the array AP as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. *> *> On exit, the block diagonal matrix D and the multipliers used *> to obtain the factor U or L, stored as a packed triangular *> matrix overwriting A (see below for further details). *> \endverbatim *> *> \param[out] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N) *> Details of the interchanges and the block structure of D. *> If IPIV(k) > 0, then rows and columns k and IPIV(k) were *> interchanged and D(k,k) is a 1-by-1 diagonal block. *> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and *> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) *> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = *> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were *> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, D(i,i) is exactly zero. The factorization *> has been completed, but the block diagonal matrix D is *> exactly singular, and division by zero will occur if it *> is used to solve a system of equations. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> If UPLO = 'U', then A = U*D*U**T, where *> U = P(n)*U(n)* ... *P(k)U(k)* ..., *> i.e., U is a product of terms P(k)*U(k), where k decreases from n to *> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 *> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as *> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such *> that if the diagonal block D(k) is of order s (s = 1 or 2), then *> *> ( I v 0 ) k-s *> U(k) = ( 0 I 0 ) s *> ( 0 0 I ) n-k *> k-s s n-k *> *> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). *> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), *> and A(k,k), and v overwrites A(1:k-2,k-1:k). *> *> If UPLO = 'L', then A = L*D*L**T, where *> L = P(1)*L(1)* ... *P(k)*L(k)* ..., *> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to *> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 *> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as *> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such *> that if the diagonal block D(k) is of order s (s = 1 or 2), then *> *> ( I 0 0 ) k-1 *> L(k) = ( 0 I 0 ) s *> ( 0 v I ) n-k-s+1 *> k-1 s n-k-s+1 *> *> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). *> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), *> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). *> \endverbatim * *> \par Contributors: * ================== *> *> J. Lewis, Boeing Computer Services Company *> * ===================================================================== SUBROUTINE DSPTRF( UPLO, N, AP, IPIV, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION AP( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION EIGHT, SEVTEN PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER I, IMAX, J, JMAX, K, KC, KK, KNC, KP, KPC, $ KSTEP, KX, NPP DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, R1, $ ROWMAX, T, WK, WKM1, WKP1 * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX EXTERNAL LSAME, IDAMAX * .. * .. External Subroutines .. EXTERNAL DSCAL, DSPR, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSPTRF', -INFO ) RETURN END IF * * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT * IF( UPPER ) THEN * * Factorize A as U*D*U**T using the upper triangle of A * * K is the main loop index, decreasing from N to 1 in steps of * 1 or 2 * K = N KC = ( N-1 )*N / 2 + 1 10 CONTINUE KNC = KC * * If K < 1, exit from loop * IF( K.LT.1 ) $ GO TO 110 KSTEP = 1 * * Determine rows and columns to be interchanged and whether * a 1-by-1 or 2-by-2 pivot block will be used * ABSAKK = ABS( AP( KC+K-1 ) ) * * IMAX is the row-index of the largest off-diagonal element in * column K, and COLMAX is its absolute value * IF( K.GT.1 ) THEN IMAX = IDAMAX( K-1, AP( KC ), 1 ) COLMAX = ABS( AP( KC+IMAX-1 ) ) ELSE COLMAX = ZERO END IF * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN * * Column K is zero: set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K KP = K ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * * no interchange, use 1-by-1 pivot block * KP = K ELSE * ROWMAX = ZERO JMAX = IMAX KX = IMAX*( IMAX+1 ) / 2 + IMAX DO 20 J = IMAX + 1, K IF( ABS( AP( KX ) ).GT.ROWMAX ) THEN ROWMAX = ABS( AP( KX ) ) JMAX = J END IF KX = KX + J 20 CONTINUE KPC = ( IMAX-1 )*IMAX / 2 + 1 IF( IMAX.GT.1 ) THEN JMAX = IDAMAX( IMAX-1, AP( KPC ), 1 ) ROWMAX = MAX( ROWMAX, ABS( AP( KPC+JMAX-1 ) ) ) END IF * IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN * * no interchange, use 1-by-1 pivot block * KP = K ELSE IF( ABS( AP( KPC+IMAX-1 ) ).GE.ALPHA*ROWMAX ) THEN * * interchange rows and columns K and IMAX, use 1-by-1 * pivot block * KP = IMAX ELSE * * interchange rows and columns K-1 and IMAX, use 2-by-2 * pivot block * KP = IMAX KSTEP = 2 END IF END IF * KK = K - KSTEP + 1 IF( KSTEP.EQ.2 ) $ KNC = KNC - K + 1 IF( KP.NE.KK ) THEN * * Interchange rows and columns KK and KP in the leading * submatrix A(1:k,1:k) * CALL DSWAP( KP-1, AP( KNC ), 1, AP( KPC ), 1 ) KX = KPC + KP - 1 DO 30 J = KP + 1, KK - 1 KX = KX + J - 1 T = AP( KNC+J-1 ) AP( KNC+J-1 ) = AP( KX ) AP( KX ) = T 30 CONTINUE T = AP( KNC+KK-1 ) AP( KNC+KK-1 ) = AP( KPC+KP-1 ) AP( KPC+KP-1 ) = T IF( KSTEP.EQ.2 ) THEN T = AP( KC+K-2 ) AP( KC+K-2 ) = AP( KC+KP-1 ) AP( KC+KP-1 ) = T END IF END IF * * Update the leading submatrix * IF( KSTEP.EQ.1 ) THEN * * 1-by-1 pivot block D(k): column k now holds * * W(k) = U(k)*D(k) * * where U(k) is the k-th column of U * * Perform a rank-1 update of A(1:k-1,1:k-1) as * * A := A - U(k)*D(k)*U(k)**T = A - W(k)*1/D(k)*W(k)**T * R1 = ONE / AP( KC+K-1 ) CALL DSPR( UPLO, K-1, -R1, AP( KC ), 1, AP ) * * Store U(k) in column k * CALL DSCAL( K-1, R1, AP( KC ), 1 ) ELSE * * 2-by-2 pivot block D(k): columns k and k-1 now hold * * ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) * * where U(k) and U(k-1) are the k-th and (k-1)-th columns * of U * * Perform a rank-2 update of A(1:k-2,1:k-2) as * * A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T * = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )**T * IF( K.GT.2 ) THEN * D12 = AP( K-1+( K-1 )*K / 2 ) D22 = AP( K-1+( K-2 )*( K-1 ) / 2 ) / D12 D11 = AP( K+( K-1 )*K / 2 ) / D12 T = ONE / ( D11*D22-ONE ) D12 = T / D12 * DO 50 J = K - 2, 1, -1 WKM1 = D12*( D11*AP( J+( K-2 )*( K-1 ) / 2 )- $ AP( J+( K-1 )*K / 2 ) ) WK = D12*( D22*AP( J+( K-1 )*K / 2 )- $ AP( J+( K-2 )*( K-1 ) / 2 ) ) DO 40 I = J, 1, -1 AP( I+( J-1 )*J / 2 ) = AP( I+( J-1 )*J / 2 ) - $ AP( I+( K-1 )*K / 2 )*WK - $ AP( I+( K-2 )*( K-1 ) / 2 )*WKM1 40 CONTINUE AP( J+( K-1 )*K / 2 ) = WK AP( J+( K-2 )*( K-1 ) / 2 ) = WKM1 50 CONTINUE * END IF * END IF END IF * * Store details of the interchanges in IPIV * IF( KSTEP.EQ.1 ) THEN IPIV( K ) = KP ELSE IPIV( K ) = -KP IPIV( K-1 ) = -KP END IF * * Decrease K and return to the start of the main loop * K = K - KSTEP KC = KNC - K GO TO 10 * ELSE * * Factorize A as L*D*L**T using the lower triangle of A * * K is the main loop index, increasing from 1 to N in steps of * 1 or 2 * K = 1 KC = 1 NPP = N*( N+1 ) / 2 60 CONTINUE KNC = KC * * If K > N, exit from loop * IF( K.GT.N ) $ GO TO 110 KSTEP = 1 * * Determine rows and columns to be interchanged and whether * a 1-by-1 or 2-by-2 pivot block will be used * ABSAKK = ABS( AP( KC ) ) * * IMAX is the row-index of the largest off-diagonal element in * column K, and COLMAX is its absolute value * IF( K.LT.N ) THEN IMAX = K + IDAMAX( N-K, AP( KC+1 ), 1 ) COLMAX = ABS( AP( KC+IMAX-K ) ) ELSE COLMAX = ZERO END IF * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN * * Column K is zero: set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K KP = K ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * * no interchange, use 1-by-1 pivot block * KP = K ELSE * * JMAX is the column-index of the largest off-diagonal * element in row IMAX, and ROWMAX is its absolute value * ROWMAX = ZERO KX = KC + IMAX - K DO 70 J = K, IMAX - 1 IF( ABS( AP( KX ) ).GT.ROWMAX ) THEN ROWMAX = ABS( AP( KX ) ) JMAX = J END IF KX = KX + N - J 70 CONTINUE KPC = NPP - ( N-IMAX+1 )*( N-IMAX+2 ) / 2 + 1 IF( IMAX.LT.N ) THEN JMAX = IMAX + IDAMAX( N-IMAX, AP( KPC+1 ), 1 ) ROWMAX = MAX( ROWMAX, ABS( AP( KPC+JMAX-IMAX ) ) ) END IF * IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN * * no interchange, use 1-by-1 pivot block * KP = K ELSE IF( ABS( AP( KPC ) ).GE.ALPHA*ROWMAX ) THEN * * interchange rows and columns K and IMAX, use 1-by-1 * pivot block * KP = IMAX ELSE * * interchange rows and columns K+1 and IMAX, use 2-by-2 * pivot block * KP = IMAX KSTEP = 2 END IF END IF * KK = K + KSTEP - 1 IF( KSTEP.EQ.2 ) $ KNC = KNC + N - K + 1 IF( KP.NE.KK ) THEN * * Interchange rows and columns KK and KP in the trailing * submatrix A(k:n,k:n) * IF( KP.LT.N ) $ CALL DSWAP( N-KP, AP( KNC+KP-KK+1 ), 1, AP( KPC+1 ), $ 1 ) KX = KNC + KP - KK DO 80 J = KK + 1, KP - 1 KX = KX + N - J + 1 T = AP( KNC+J-KK ) AP( KNC+J-KK ) = AP( KX ) AP( KX ) = T 80 CONTINUE T = AP( KNC ) AP( KNC ) = AP( KPC ) AP( KPC ) = T IF( KSTEP.EQ.2 ) THEN T = AP( KC+1 ) AP( KC+1 ) = AP( KC+KP-K ) AP( KC+KP-K ) = T END IF END IF * * Update the trailing submatrix * IF( KSTEP.EQ.1 ) THEN * * 1-by-1 pivot block D(k): column k now holds * * W(k) = L(k)*D(k) * * where L(k) is the k-th column of L * IF( K.LT.N ) THEN * * Perform a rank-1 update of A(k+1:n,k+1:n) as * * A := A - L(k)*D(k)*L(k)**T = A - W(k)*(1/D(k))*W(k)**T * R1 = ONE / AP( KC ) CALL DSPR( UPLO, N-K, -R1, AP( KC+1 ), 1, $ AP( KC+N-K+1 ) ) * * Store L(k) in column K * CALL DSCAL( N-K, R1, AP( KC+1 ), 1 ) END IF ELSE * * 2-by-2 pivot block D(k): columns K and K+1 now hold * * ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) * * where L(k) and L(k+1) are the k-th and (k+1)-th columns * of L * IF( K.LT.N-1 ) THEN * * Perform a rank-2 update of A(k+2:n,k+2:n) as * * A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )**T * = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )**T * * where L(k) and L(k+1) are the k-th and (k+1)-th * columns of L * D21 = AP( K+1+( K-1 )*( 2*N-K ) / 2 ) D11 = AP( K+1+K*( 2*N-K-1 ) / 2 ) / D21 D22 = AP( K+( K-1 )*( 2*N-K ) / 2 ) / D21 T = ONE / ( D11*D22-ONE ) D21 = T / D21 * DO 100 J = K + 2, N WK = D21*( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )- $ AP( J+K*( 2*N-K-1 ) / 2 ) ) WKP1 = D21*( D22*AP( J+K*( 2*N-K-1 ) / 2 )- $ AP( J+( K-1 )*( 2*N-K ) / 2 ) ) * DO 90 I = J, N AP( I+( J-1 )*( 2*N-J ) / 2 ) = AP( I+( J-1 )* $ ( 2*N-J ) / 2 ) - AP( I+( K-1 )*( 2*N-K ) / $ 2 )*WK - AP( I+K*( 2*N-K-1 ) / 2 )*WKP1 90 CONTINUE * AP( J+( K-1 )*( 2*N-K ) / 2 ) = WK AP( J+K*( 2*N-K-1 ) / 2 ) = WKP1 * 100 CONTINUE END IF END IF END IF * * Store details of the interchanges in IPIV * IF( KSTEP.EQ.1 ) THEN IPIV( K ) = KP ELSE IPIV( K ) = -KP IPIV( K+1 ) = -KP END IF * * Increase K and return to the start of the main loop * K = K + KSTEP KC = KNC + N - K + 2 GO TO 60 * END IF * 110 CONTINUE RETURN * * End of DSPTRF * END *> \brief \b DSPTRI * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSPTRI + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSPTRI( UPLO, N, AP, IPIV, WORK, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N * .. * .. Array Arguments .. * INTEGER IPIV( * ) * DOUBLE PRECISION AP( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSPTRI computes the inverse of a real symmetric indefinite matrix *> A in packed storage using the factorization A = U*D*U**T or *> A = L*D*L**T computed by DSPTRF. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the details of the factorization are stored *> as an upper or lower triangular matrix. *> = 'U': Upper triangular, form is A = U*D*U**T; *> = 'L': Lower triangular, form is A = L*D*L**T. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> On entry, the block diagonal matrix D and the multipliers *> used to obtain the factor U or L as computed by DSPTRF, *> stored as a packed triangular matrix. *> *> On exit, if INFO = 0, the (symmetric) inverse of the original *> matrix, stored as a packed triangular matrix. The j-th column *> of inv(A) is stored in the array AP as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j; *> if UPLO = 'L', *> AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n. *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N) *> Details of the interchanges and the block structure of D *> as determined by DSPTRF. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its *> inverse could not be computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DSPTRI( UPLO, N, AP, IPIV, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION AP( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER J, K, KC, KCNEXT, KP, KPC, KSTEP, KX, NPP DOUBLE PRECISION AK, AKKP1, AKP1, D, T, TEMP * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT EXTERNAL LSAME, DDOT * .. * .. External Subroutines .. EXTERNAL DCOPY, DSPMV, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSPTRI', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Check that the diagonal matrix D is nonsingular. * IF( UPPER ) THEN * * Upper triangular storage: examine D from bottom to top * KP = N*( N+1 ) / 2 DO 10 INFO = N, 1, -1 IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO ) $ RETURN KP = KP - INFO 10 CONTINUE ELSE * * Lower triangular storage: examine D from top to bottom. * KP = 1 DO 20 INFO = 1, N IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO ) $ RETURN KP = KP + N - INFO + 1 20 CONTINUE END IF INFO = 0 * IF( UPPER ) THEN * * Compute inv(A) from the factorization A = U*D*U**T. * * K is the main loop index, increasing from 1 to N in steps of * 1 or 2, depending on the size of the diagonal blocks. * K = 1 KC = 1 30 CONTINUE * * If K > N, exit from loop. * IF( K.GT.N ) $ GO TO 50 * KCNEXT = KC + K IF( IPIV( K ).GT.0 ) THEN * * 1 x 1 diagonal block * * Invert the diagonal block. * AP( KC+K-1 ) = ONE / AP( KC+K-1 ) * * Compute column K of the inverse. * IF( K.GT.1 ) THEN CALL DCOPY( K-1, AP( KC ), 1, WORK, 1 ) CALL DSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO, AP( KC ), $ 1 ) AP( KC+K-1 ) = AP( KC+K-1 ) - $ DDOT( K-1, WORK, 1, AP( KC ), 1 ) END IF KSTEP = 1 ELSE * * 2 x 2 diagonal block * * Invert the diagonal block. * T = ABS( AP( KCNEXT+K-1 ) ) AK = AP( KC+K-1 ) / T AKP1 = AP( KCNEXT+K ) / T AKKP1 = AP( KCNEXT+K-1 ) / T D = T*( AK*AKP1-ONE ) AP( KC+K-1 ) = AKP1 / D AP( KCNEXT+K ) = AK / D AP( KCNEXT+K-1 ) = -AKKP1 / D * * Compute columns K and K+1 of the inverse. * IF( K.GT.1 ) THEN CALL DCOPY( K-1, AP( KC ), 1, WORK, 1 ) CALL DSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO, AP( KC ), $ 1 ) AP( KC+K-1 ) = AP( KC+K-1 ) - $ DDOT( K-1, WORK, 1, AP( KC ), 1 ) AP( KCNEXT+K-1 ) = AP( KCNEXT+K-1 ) - $ DDOT( K-1, AP( KC ), 1, AP( KCNEXT ), $ 1 ) CALL DCOPY( K-1, AP( KCNEXT ), 1, WORK, 1 ) CALL DSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO, $ AP( KCNEXT ), 1 ) AP( KCNEXT+K ) = AP( KCNEXT+K ) - $ DDOT( K-1, WORK, 1, AP( KCNEXT ), 1 ) END IF KSTEP = 2 KCNEXT = KCNEXT + K + 1 END IF * KP = ABS( IPIV( K ) ) IF( KP.NE.K ) THEN * * Interchange rows and columns K and KP in the leading * submatrix A(1:k+1,1:k+1) * KPC = ( KP-1 )*KP / 2 + 1 CALL DSWAP( KP-1, AP( KC ), 1, AP( KPC ), 1 ) KX = KPC + KP - 1 DO 40 J = KP + 1, K - 1 KX = KX + J - 1 TEMP = AP( KC+J-1 ) AP( KC+J-1 ) = AP( KX ) AP( KX ) = TEMP 40 CONTINUE TEMP = AP( KC+K-1 ) AP( KC+K-1 ) = AP( KPC+KP-1 ) AP( KPC+KP-1 ) = TEMP IF( KSTEP.EQ.2 ) THEN TEMP = AP( KC+K+K-1 ) AP( KC+K+K-1 ) = AP( KC+K+KP-1 ) AP( KC+K+KP-1 ) = TEMP END IF END IF * K = K + KSTEP KC = KCNEXT GO TO 30 50 CONTINUE * ELSE * * Compute inv(A) from the factorization A = L*D*L**T. * * K is the main loop index, increasing from 1 to N in steps of * 1 or 2, depending on the size of the diagonal blocks. * NPP = N*( N+1 ) / 2 K = N KC = NPP 60 CONTINUE * * If K < 1, exit from loop. * IF( K.LT.1 ) $ GO TO 80 * KCNEXT = KC - ( N-K+2 ) IF( IPIV( K ).GT.0 ) THEN * * 1 x 1 diagonal block * * Invert the diagonal block. * AP( KC ) = ONE / AP( KC ) * * Compute column K of the inverse. * IF( K.LT.N ) THEN CALL DCOPY( N-K, AP( KC+1 ), 1, WORK, 1 ) CALL DSPMV( UPLO, N-K, -ONE, AP( KC+N-K+1 ), WORK, 1, $ ZERO, AP( KC+1 ), 1 ) AP( KC ) = AP( KC ) - DDOT( N-K, WORK, 1, AP( KC+1 ), 1 ) END IF KSTEP = 1 ELSE * * 2 x 2 diagonal block * * Invert the diagonal block. * T = ABS( AP( KCNEXT+1 ) ) AK = AP( KCNEXT ) / T AKP1 = AP( KC ) / T AKKP1 = AP( KCNEXT+1 ) / T D = T*( AK*AKP1-ONE ) AP( KCNEXT ) = AKP1 / D AP( KC ) = AK / D AP( KCNEXT+1 ) = -AKKP1 / D * * Compute columns K-1 and K of the inverse. * IF( K.LT.N ) THEN CALL DCOPY( N-K, AP( KC+1 ), 1, WORK, 1 ) CALL DSPMV( UPLO, N-K, -ONE, AP( KC+( N-K+1 ) ), WORK, 1, $ ZERO, AP( KC+1 ), 1 ) AP( KC ) = AP( KC ) - DDOT( N-K, WORK, 1, AP( KC+1 ), 1 ) AP( KCNEXT+1 ) = AP( KCNEXT+1 ) - $ DDOT( N-K, AP( KC+1 ), 1, $ AP( KCNEXT+2 ), 1 ) CALL DCOPY( N-K, AP( KCNEXT+2 ), 1, WORK, 1 ) CALL DSPMV( UPLO, N-K, -ONE, AP( KC+( N-K+1 ) ), WORK, 1, $ ZERO, AP( KCNEXT+2 ), 1 ) AP( KCNEXT ) = AP( KCNEXT ) - $ DDOT( N-K, WORK, 1, AP( KCNEXT+2 ), 1 ) END IF KSTEP = 2 KCNEXT = KCNEXT - ( N-K+3 ) END IF * KP = ABS( IPIV( K ) ) IF( KP.NE.K ) THEN * * Interchange rows and columns K and KP in the trailing * submatrix A(k-1:n,k-1:n) * KPC = NPP - ( N-KP+1 )*( N-KP+2 ) / 2 + 1 IF( KP.LT.N ) $ CALL DSWAP( N-KP, AP( KC+KP-K+1 ), 1, AP( KPC+1 ), 1 ) KX = KC + KP - K DO 70 J = K + 1, KP - 1 KX = KX + N - J + 1 TEMP = AP( KC+J-K ) AP( KC+J-K ) = AP( KX ) AP( KX ) = TEMP 70 CONTINUE TEMP = AP( KC ) AP( KC ) = AP( KPC ) AP( KPC ) = TEMP IF( KSTEP.EQ.2 ) THEN TEMP = AP( KC-N+K-1 ) AP( KC-N+K-1 ) = AP( KC-N+KP-1 ) AP( KC-N+KP-1 ) = TEMP END IF END IF * K = K - KSTEP KC = KCNEXT GO TO 60 80 CONTINUE END IF * RETURN * * End of DSPTRI * END *> \brief \b DSPTRS * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSPTRS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. * INTEGER IPIV( * ) * DOUBLE PRECISION AP( * ), B( LDB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSPTRS solves a system of linear equations A*X = B with a real *> symmetric matrix A stored in packed format using the factorization *> A = U*D*U**T or A = L*D*L**T computed by DSPTRF. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the details of the factorization are stored *> as an upper or lower triangular matrix. *> = 'U': Upper triangular, form is A = U*D*U**T; *> = 'L': Lower triangular, form is A = L*D*L**T. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrix B. NRHS >= 0. *> \endverbatim *> *> \param[in] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> The block diagonal matrix D and the multipliers used to *> obtain the factor U or L as computed by DSPTRF, stored as a *> packed triangular matrix. *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N) *> Details of the interchanges and the block structure of D *> as determined by DSPTRF. *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> On entry, the right hand side matrix B. *> On exit, the solution matrix X. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION AP( * ), B( LDB, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER J, K, KC, KP DOUBLE PRECISION AK, AKM1, AKM1K, BK, BKM1, DENOM * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DGEMV, DGER, DSCAL, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( NRHS.LT.0 ) THEN INFO = -3 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSPTRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * IF( UPPER ) THEN * * Solve A*X = B, where A = U*D*U**T. * * First solve U*D*X = B, overwriting B with X. * * K is the main loop index, decreasing from N to 1 in steps of * 1 or 2, depending on the size of the diagonal blocks. * K = N KC = N*( N+1 ) / 2 + 1 10 CONTINUE * * If K < 1, exit from loop. * IF( K.LT.1 ) $ GO TO 30 * KC = KC - K IF( IPIV( K ).GT.0 ) THEN * * 1 x 1 diagonal block * * Interchange rows K and IPIV(K). * KP = IPIV( K ) IF( KP.NE.K ) $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) * * Multiply by inv(U(K)), where U(K) is the transformation * stored in column K of A. * CALL DGER( K-1, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB, $ B( 1, 1 ), LDB ) * * Multiply by the inverse of the diagonal block. * CALL DSCAL( NRHS, ONE / AP( KC+K-1 ), B( K, 1 ), LDB ) K = K - 1 ELSE * * 2 x 2 diagonal block * * Interchange rows K-1 and -IPIV(K). * KP = -IPIV( K ) IF( KP.NE.K-1 ) $ CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) * * Multiply by inv(U(K)), where U(K) is the transformation * stored in columns K-1 and K of A. * CALL DGER( K-2, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB, $ B( 1, 1 ), LDB ) CALL DGER( K-2, NRHS, -ONE, AP( KC-( K-1 ) ), 1, $ B( K-1, 1 ), LDB, B( 1, 1 ), LDB ) * * Multiply by the inverse of the diagonal block. * AKM1K = AP( KC+K-2 ) AKM1 = AP( KC-1 ) / AKM1K AK = AP( KC+K-1 ) / AKM1K DENOM = AKM1*AK - ONE DO 20 J = 1, NRHS BKM1 = B( K-1, J ) / AKM1K BK = B( K, J ) / AKM1K B( K-1, J ) = ( AK*BKM1-BK ) / DENOM B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM 20 CONTINUE KC = KC - K + 1 K = K - 2 END IF * GO TO 10 30 CONTINUE * * Next solve U**T*X = B, overwriting B with X. * * K is the main loop index, increasing from 1 to N in steps of * 1 or 2, depending on the size of the diagonal blocks. * K = 1 KC = 1 40 CONTINUE * * If K > N, exit from loop. * IF( K.GT.N ) $ GO TO 50 * IF( IPIV( K ).GT.0 ) THEN * * 1 x 1 diagonal block * * Multiply by inv(U**T(K)), where U(K) is the transformation * stored in column K of A. * CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, AP( KC ), $ 1, ONE, B( K, 1 ), LDB ) * * Interchange rows K and IPIV(K). * KP = IPIV( K ) IF( KP.NE.K ) $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) KC = KC + K K = K + 1 ELSE * * 2 x 2 diagonal block * * Multiply by inv(U**T(K+1)), where U(K+1) is the transformation * stored in columns K and K+1 of A. * CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, AP( KC ), $ 1, ONE, B( K, 1 ), LDB ) CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, $ AP( KC+K ), 1, ONE, B( K+1, 1 ), LDB ) * * Interchange rows K and -IPIV(K). * KP = -IPIV( K ) IF( KP.NE.K ) $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) KC = KC + 2*K + 1 K = K + 2 END IF * GO TO 40 50 CONTINUE * ELSE * * Solve A*X = B, where A = L*D*L**T. * * First solve L*D*X = B, overwriting B with X. * * K is the main loop index, increasing from 1 to N in steps of * 1 or 2, depending on the size of the diagonal blocks. * K = 1 KC = 1 60 CONTINUE * * If K > N, exit from loop. * IF( K.GT.N ) $ GO TO 80 * IF( IPIV( K ).GT.0 ) THEN * * 1 x 1 diagonal block * * Interchange rows K and IPIV(K). * KP = IPIV( K ) IF( KP.NE.K ) $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) * * Multiply by inv(L(K)), where L(K) is the transformation * stored in column K of A. * IF( K.LT.N ) $ CALL DGER( N-K, NRHS, -ONE, AP( KC+1 ), 1, B( K, 1 ), $ LDB, B( K+1, 1 ), LDB ) * * Multiply by the inverse of the diagonal block. * CALL DSCAL( NRHS, ONE / AP( KC ), B( K, 1 ), LDB ) KC = KC + N - K + 1 K = K + 1 ELSE * * 2 x 2 diagonal block * * Interchange rows K+1 and -IPIV(K). * KP = -IPIV( K ) IF( KP.NE.K+1 ) $ CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) * * Multiply by inv(L(K)), where L(K) is the transformation * stored in columns K and K+1 of A. * IF( K.LT.N-1 ) THEN CALL DGER( N-K-1, NRHS, -ONE, AP( KC+2 ), 1, B( K, 1 ), $ LDB, B( K+2, 1 ), LDB ) CALL DGER( N-K-1, NRHS, -ONE, AP( KC+N-K+2 ), 1, $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB ) END IF * * Multiply by the inverse of the diagonal block. * AKM1K = AP( KC+1 ) AKM1 = AP( KC ) / AKM1K AK = AP( KC+N-K+1 ) / AKM1K DENOM = AKM1*AK - ONE DO 70 J = 1, NRHS BKM1 = B( K, J ) / AKM1K BK = B( K+1, J ) / AKM1K B( K, J ) = ( AK*BKM1-BK ) / DENOM B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM 70 CONTINUE KC = KC + 2*( N-K ) + 1 K = K + 2 END IF * GO TO 60 80 CONTINUE * * Next solve L**T*X = B, overwriting B with X. * * K is the main loop index, decreasing from N to 1 in steps of * 1 or 2, depending on the size of the diagonal blocks. * K = N KC = N*( N+1 ) / 2 + 1 90 CONTINUE * * If K < 1, exit from loop. * IF( K.LT.1 ) $ GO TO 100 * KC = KC - ( N-K+1 ) IF( IPIV( K ).GT.0 ) THEN * * 1 x 1 diagonal block * * Multiply by inv(L**T(K)), where L(K) is the transformation * stored in column K of A. * IF( K.LT.N ) $ CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), $ LDB, AP( KC+1 ), 1, ONE, B( K, 1 ), LDB ) * * Interchange rows K and IPIV(K). * KP = IPIV( K ) IF( KP.NE.K ) $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) K = K - 1 ELSE * * 2 x 2 diagonal block * * Multiply by inv(L**T(K-1)), where L(K-1) is the transformation * stored in columns K-1 and K of A. * IF( K.LT.N ) THEN CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), $ LDB, AP( KC+1 ), 1, ONE, B( K, 1 ), LDB ) CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), $ LDB, AP( KC-( N-K ) ), 1, ONE, B( K-1, 1 ), $ LDB ) END IF * * Interchange rows K and -IPIV(K). * KP = -IPIV( K ) IF( KP.NE.K ) $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) KC = KC - ( N-K+2 ) K = K - 2 END IF * GO TO 90 100 CONTINUE END IF * RETURN * * End of DSPTRS * END *> \brief \b DSTEBZ * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSTEBZ + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, * M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, * INFO ) * * .. Scalar Arguments .. * CHARACTER ORDER, RANGE * INTEGER IL, INFO, IU, M, N, NSPLIT * DOUBLE PRECISION ABSTOL, VL, VU * .. * .. Array Arguments .. * INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * ) * DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSTEBZ computes the eigenvalues of a symmetric tridiagonal *> matrix T. The user may ask for all eigenvalues, all eigenvalues *> in the half-open interval (VL, VU], or the IL-th through IU-th *> eigenvalues. *> *> To avoid overflow, the matrix must be scaled so that its *> largest element is no greater than overflow**(1/2) * underflow**(1/4) in absolute value, and for greatest *> accuracy, it should not be much smaller than that. *> *> See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal *> Matrix", Report CS41, Computer Science Dept., Stanford *> University, July 21, 1966. *> \endverbatim * * Arguments: * ========== * *> \param[in] RANGE *> \verbatim *> RANGE is CHARACTER*1 *> = 'A': ("All") all eigenvalues will be found. *> = 'V': ("Value") all eigenvalues in the half-open interval *> (VL, VU] will be found. *> = 'I': ("Index") the IL-th through IU-th eigenvalues (of the *> entire matrix) will be found. *> \endverbatim *> *> \param[in] ORDER *> \verbatim *> ORDER is CHARACTER*1 *> = 'B': ("By Block") the eigenvalues will be grouped by *> split-off block (see IBLOCK, ISPLIT) and *> ordered from smallest to largest within *> the block. *> = 'E': ("Entire matrix") *> the eigenvalues for the entire matrix *> will be ordered from smallest to *> largest. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the tridiagonal matrix T. N >= 0. *> \endverbatim *> *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION *> *> If RANGE='V', the lower bound of the interval to *> be searched for eigenvalues. Eigenvalues less than or equal *> to VL, or greater than VU, will not be returned. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION *> *> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. Eigenvalues less than or equal *> to VL, or greater than VU, will not be returned. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] IL *> \verbatim *> IL is INTEGER *> *> If RANGE='I', the index of the *> smallest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> *> If RANGE='I', the index of the *> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] ABSTOL *> \verbatim *> ABSTOL is DOUBLE PRECISION *> The absolute tolerance for the eigenvalues. An eigenvalue *> (or cluster) is considered to be located if it has been *> determined to lie in an interval whose width is ABSTOL or *> less. If ABSTOL is less than or equal to zero, then ULP*|T| *> will be used, where |T| means the 1-norm of T. *> *> Eigenvalues will be computed most accurately when ABSTOL is *> set to twice the underflow threshold 2*DLAMCH('S'), not zero. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The n diagonal elements of the tridiagonal matrix T. *> \endverbatim *> *> \param[in] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N-1) *> The (n-1) off-diagonal elements of the tridiagonal matrix T. *> \endverbatim *> *> \param[out] M *> \verbatim *> M is INTEGER *> The actual number of eigenvalues found. 0 <= M <= N. *> (See also the description of INFO=2,3.) *> \endverbatim *> *> \param[out] NSPLIT *> \verbatim *> NSPLIT is INTEGER *> The number of diagonal blocks in the matrix T. *> 1 <= NSPLIT <= N. *> \endverbatim *> *> \param[out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> On exit, the first M elements of W will contain the *> eigenvalues. (DSTEBZ may use the remaining N-M elements as *> workspace.) *> \endverbatim *> *> \param[out] IBLOCK *> \verbatim *> IBLOCK is INTEGER array, dimension (N) *> At each row/column j where E(j) is zero or small, the *> matrix T is considered to split into a block diagonal *> matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which *> block (from 1 to the number of blocks) the eigenvalue W(i) *> belongs. (DSTEBZ may use the remaining N-M elements as *> workspace.) *> \endverbatim *> *> \param[out] ISPLIT *> \verbatim *> ISPLIT is INTEGER array, dimension (N) *> The splitting points, at which T breaks up into submatrices. *> The first submatrix consists of rows/columns 1 to ISPLIT(1), *> the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), *> etc., and the NSPLIT-th consists of rows/columns *> ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. *> (Only the first NSPLIT elements will actually be used, but *> since the user cannot know a priori what value NSPLIT will *> have, N words must be reserved for ISPLIT.) *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (4*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (3*N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: some or all of the eigenvalues failed to converge or *> were not computed: *> =1 or 3: Bisection failed to converge for some *> eigenvalues; these eigenvalues are flagged by a *> negative block number. The effect is that the *> eigenvalues may not be as accurate as the *> absolute and relative tolerances. This is *> generally caused by unexpectedly inaccurate *> arithmetic. *> =2 or 3: RANGE='I' only: Not all of the eigenvalues *> IL:IU were found. *> Effect: M < IU+1-IL *> Cause: non-monotonic arithmetic, causing the *> Sturm sequence to be non-monotonic. *> Cure: recalculate, using RANGE='A', and pick *> out eigenvalues IL:IU. In some cases, *> increasing the PARAMETER "FUDGE" may *> make things work. *> = 4: RANGE='I', and the Gershgorin interval *> initially used was too small. No eigenvalues *> were computed. *> Probable cause: your machine has sloppy *> floating-point arithmetic. *> Cure: Increase the PARAMETER "FUDGE", *> recompile, and try again. *> \endverbatim * *> \par Internal Parameters: * ========================= *> *> \verbatim *> RELFAC DOUBLE PRECISION, default = 2.0e0 *> The relative tolerance. An interval (a,b] lies within *> "relative tolerance" if b-a < RELFAC*ulp*max(|a|,|b|), *> where "ulp" is the machine precision (distance from 1 to *> the next larger floating point number.) *> *> FUDGE DOUBLE PRECISION, default = 2 *> A "fudge factor" to widen the Gershgorin intervals. Ideally, *> a value of 1 should work, but on machines with sloppy *> arithmetic, this needs to be larger. The default for *> publicly released versions should be large enough to handle *> the worst machine around. Note that this has no effect *> on accuracy of the solution. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, $ M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, $ INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. CHARACTER ORDER, RANGE INTEGER IL, INFO, IU, M, N, NSPLIT DOUBLE PRECISION ABSTOL, VL, VU * .. * .. Array Arguments .. INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * ) DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, HALF PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, $ HALF = 1.0D0 / TWO ) DOUBLE PRECISION FUDGE, RELFAC PARAMETER ( FUDGE = 2.1D0, RELFAC = 2.0D0 ) * .. * .. Local Scalars .. LOGICAL NCNVRG, TOOFEW INTEGER IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO, $ IM, IN, IOFF, IORDER, IOUT, IRANGE, ITMAX, $ ITMP1, IW, IWOFF, J, JB, JDISC, JE, NB, NWL, $ NWU DOUBLE PRECISION ATOLI, BNORM, GL, GU, PIVMIN, RTOLI, SAFEMN, $ TMP1, TMP2, TNORM, ULP, WKILL, WL, WLU, WU, WUL * .. * .. Local Arrays .. INTEGER IDUMMA( 1 ) * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH EXTERNAL LSAME, ILAENV, DLAMCH * .. * .. External Subroutines .. EXTERNAL DLAEBZ, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT * .. * .. Executable Statements .. * INFO = 0 * * Decode RANGE * IF( LSAME( RANGE, 'A' ) ) THEN IRANGE = 1 ELSE IF( LSAME( RANGE, 'V' ) ) THEN IRANGE = 2 ELSE IF( LSAME( RANGE, 'I' ) ) THEN IRANGE = 3 ELSE IRANGE = 0 END IF * * Decode ORDER * IF( LSAME( ORDER, 'B' ) ) THEN IORDER = 2 ELSE IF( LSAME( ORDER, 'E' ) ) THEN IORDER = 1 ELSE IORDER = 0 END IF * * Check for Errors * IF( IRANGE.LE.0 ) THEN INFO = -1 ELSE IF( IORDER.LE.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( IRANGE.EQ.2 ) THEN IF( VL.GE.VU ) $ INFO = -5 ELSE IF( IRANGE.EQ.3 .AND. ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) ) $ THEN INFO = -6 ELSE IF( IRANGE.EQ.3 .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) $ THEN INFO = -7 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSTEBZ', -INFO ) RETURN END IF * * Initialize error flags * INFO = 0 NCNVRG = .FALSE. TOOFEW = .FALSE. * * Quick return if possible * M = 0 IF( N.EQ.0 ) $ RETURN * * Simplifications: * IF( IRANGE.EQ.3 .AND. IL.EQ.1 .AND. IU.EQ.N ) $ IRANGE = 1 * * Get machine constants * NB is the minimum vector length for vector bisection, or 0 * if only scalar is to be done. * SAFEMN = DLAMCH( 'S' ) ULP = DLAMCH( 'P' ) RTOLI = ULP*RELFAC NB = ILAENV( 1, 'DSTEBZ', ' ', N, -1, -1, -1 ) IF( NB.LE.1 ) $ NB = 0 * * Special Case when N=1 * IF( N.EQ.1 ) THEN NSPLIT = 1 ISPLIT( 1 ) = 1 IF( IRANGE.EQ.2 .AND. ( VL.GE.D( 1 ) .OR. VU.LT.D( 1 ) ) ) THEN M = 0 ELSE W( 1 ) = D( 1 ) IBLOCK( 1 ) = 1 M = 1 END IF RETURN END IF * * Compute Splitting Points * NSPLIT = 1 WORK( N ) = ZERO PIVMIN = ONE * DO 10 J = 2, N TMP1 = E( J-1 )**2 IF( ABS( D( J )*D( J-1 ) )*ULP**2+SAFEMN.GT.TMP1 ) THEN ISPLIT( NSPLIT ) = J - 1 NSPLIT = NSPLIT + 1 WORK( J-1 ) = ZERO ELSE WORK( J-1 ) = TMP1 PIVMIN = MAX( PIVMIN, TMP1 ) END IF 10 CONTINUE ISPLIT( NSPLIT ) = N PIVMIN = PIVMIN*SAFEMN * * Compute Interval and ATOLI * IF( IRANGE.EQ.3 ) THEN * * RANGE='I': Compute the interval containing eigenvalues * IL through IU. * * Compute Gershgorin interval for entire (split) matrix * and use it as the initial interval * GU = D( 1 ) GL = D( 1 ) TMP1 = ZERO * DO 20 J = 1, N - 1 TMP2 = SQRT( WORK( J ) ) GU = MAX( GU, D( J )+TMP1+TMP2 ) GL = MIN( GL, D( J )-TMP1-TMP2 ) TMP1 = TMP2 20 CONTINUE * GU = MAX( GU, D( N )+TMP1 ) GL = MIN( GL, D( N )-TMP1 ) TNORM = MAX( ABS( GL ), ABS( GU ) ) GL = GL - FUDGE*TNORM*ULP*N - FUDGE*TWO*PIVMIN GU = GU + FUDGE*TNORM*ULP*N + FUDGE*PIVMIN * * Compute Iteration parameters * ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) / $ LOG( TWO ) ) + 2 IF( ABSTOL.LE.ZERO ) THEN ATOLI = ULP*TNORM ELSE ATOLI = ABSTOL END IF * WORK( N+1 ) = GL WORK( N+2 ) = GL WORK( N+3 ) = GU WORK( N+4 ) = GU WORK( N+5 ) = GL WORK( N+6 ) = GU IWORK( 1 ) = -1 IWORK( 2 ) = -1 IWORK( 3 ) = N + 1 IWORK( 4 ) = N + 1 IWORK( 5 ) = IL - 1 IWORK( 6 ) = IU * CALL DLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN, D, E, $ WORK, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT, $ IWORK, W, IBLOCK, IINFO ) * IF( IWORK( 6 ).EQ.IU ) THEN WL = WORK( N+1 ) WLU = WORK( N+3 ) NWL = IWORK( 1 ) WU = WORK( N+4 ) WUL = WORK( N+2 ) NWU = IWORK( 4 ) ELSE WL = WORK( N+2 ) WLU = WORK( N+4 ) NWL = IWORK( 2 ) WU = WORK( N+3 ) WUL = WORK( N+1 ) NWU = IWORK( 3 ) END IF * IF( NWL.LT.0 .OR. NWL.GE.N .OR. NWU.LT.1 .OR. NWU.GT.N ) THEN INFO = 4 RETURN END IF ELSE * * RANGE='A' or 'V' -- Set ATOLI * TNORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ), $ ABS( D( N ) )+ABS( E( N-1 ) ) ) * DO 30 J = 2, N - 1 TNORM = MAX( TNORM, ABS( D( J ) )+ABS( E( J-1 ) )+ $ ABS( E( J ) ) ) 30 CONTINUE * IF( ABSTOL.LE.ZERO ) THEN ATOLI = ULP*TNORM ELSE ATOLI = ABSTOL END IF * IF( IRANGE.EQ.2 ) THEN WL = VL WU = VU ELSE WL = ZERO WU = ZERO END IF END IF * * Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU. * NWL accumulates the number of eigenvalues .le. WL, * NWU accumulates the number of eigenvalues .le. WU * M = 0 IEND = 0 INFO = 0 NWL = 0 NWU = 0 * DO 70 JB = 1, NSPLIT IOFF = IEND IBEGIN = IOFF + 1 IEND = ISPLIT( JB ) IN = IEND - IOFF * IF( IN.EQ.1 ) THEN * * Special Case -- IN=1 * IF( IRANGE.EQ.1 .OR. WL.GE.D( IBEGIN )-PIVMIN ) $ NWL = NWL + 1 IF( IRANGE.EQ.1 .OR. WU.GE.D( IBEGIN )-PIVMIN ) $ NWU = NWU + 1 IF( IRANGE.EQ.1 .OR. ( WL.LT.D( IBEGIN )-PIVMIN .AND. WU.GE. $ D( IBEGIN )-PIVMIN ) ) THEN M = M + 1 W( M ) = D( IBEGIN ) IBLOCK( M ) = JB END IF ELSE * * General Case -- IN > 1 * * Compute Gershgorin Interval * and use it as the initial interval * GU = D( IBEGIN ) GL = D( IBEGIN ) TMP1 = ZERO * DO 40 J = IBEGIN, IEND - 1 TMP2 = ABS( E( J ) ) GU = MAX( GU, D( J )+TMP1+TMP2 ) GL = MIN( GL, D( J )-TMP1-TMP2 ) TMP1 = TMP2 40 CONTINUE * GU = MAX( GU, D( IEND )+TMP1 ) GL = MIN( GL, D( IEND )-TMP1 ) BNORM = MAX( ABS( GL ), ABS( GU ) ) GL = GL - FUDGE*BNORM*ULP*IN - FUDGE*PIVMIN GU = GU + FUDGE*BNORM*ULP*IN + FUDGE*PIVMIN * * Compute ATOLI for the current submatrix * IF( ABSTOL.LE.ZERO ) THEN ATOLI = ULP*MAX( ABS( GL ), ABS( GU ) ) ELSE ATOLI = ABSTOL END IF * IF( IRANGE.GT.1 ) THEN IF( GU.LT.WL ) THEN NWL = NWL + IN NWU = NWU + IN GO TO 70 END IF GL = MAX( GL, WL ) GU = MIN( GU, WU ) IF( GL.GE.GU ) $ GO TO 70 END IF * * Set Up Initial Interval * WORK( N+1 ) = GL WORK( N+IN+1 ) = GU CALL DLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN, $ D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ), $ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM, $ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO ) * NWL = NWL + IWORK( 1 ) NWU = NWU + IWORK( IN+1 ) IWOFF = M - IWORK( 1 ) * * Compute Eigenvalues * ITMAX = INT( ( LOG( GU-GL+PIVMIN )-LOG( PIVMIN ) ) / $ LOG( TWO ) ) + 2 CALL DLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN, $ D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ), $ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT, $ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO ) * * Copy Eigenvalues Into W and IBLOCK * Use -JB for block number for unconverged eigenvalues. * DO 60 J = 1, IOUT TMP1 = HALF*( WORK( J+N )+WORK( J+IN+N ) ) * * Flag non-convergence. * IF( J.GT.IOUT-IINFO ) THEN NCNVRG = .TRUE. IB = -JB ELSE IB = JB END IF DO 50 JE = IWORK( J ) + 1 + IWOFF, $ IWORK( J+IN ) + IWOFF W( JE ) = TMP1 IBLOCK( JE ) = IB 50 CONTINUE 60 CONTINUE * M = M + IM END IF 70 CONTINUE * * If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU * If NWL+1 < IL or NWU > IU, discard extra eigenvalues. * IF( IRANGE.EQ.3 ) THEN IM = 0 IDISCL = IL - 1 - NWL IDISCU = NWU - IU * IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN DO 80 JE = 1, M IF( W( JE ).LE.WLU .AND. IDISCL.GT.0 ) THEN IDISCL = IDISCL - 1 ELSE IF( W( JE ).GE.WUL .AND. IDISCU.GT.0 ) THEN IDISCU = IDISCU - 1 ELSE IM = IM + 1 W( IM ) = W( JE ) IBLOCK( IM ) = IBLOCK( JE ) END IF 80 CONTINUE M = IM END IF IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN * * Code to deal with effects of bad arithmetic: * Some low eigenvalues to be discarded are not in (WL,WLU], * or high eigenvalues to be discarded are not in (WUL,WU] * so just kill off the smallest IDISCL/largest IDISCU * eigenvalues, by simply finding the smallest/largest * eigenvalue(s). * * (If N(w) is monotone non-decreasing, this should never * happen.) * IF( IDISCL.GT.0 ) THEN WKILL = WU DO 100 JDISC = 1, IDISCL IW = 0 DO 90 JE = 1, M IF( IBLOCK( JE ).NE.0 .AND. $ ( W( JE ).LT.WKILL .OR. IW.EQ.0 ) ) THEN IW = JE WKILL = W( JE ) END IF 90 CONTINUE IBLOCK( IW ) = 0 100 CONTINUE END IF IF( IDISCU.GT.0 ) THEN * WKILL = WL DO 120 JDISC = 1, IDISCU IW = 0 DO 110 JE = 1, M IF( IBLOCK( JE ).NE.0 .AND. $ ( W( JE ).GT.WKILL .OR. IW.EQ.0 ) ) THEN IW = JE WKILL = W( JE ) END IF 110 CONTINUE IBLOCK( IW ) = 0 120 CONTINUE END IF IM = 0 DO 130 JE = 1, M IF( IBLOCK( JE ).NE.0 ) THEN IM = IM + 1 W( IM ) = W( JE ) IBLOCK( IM ) = IBLOCK( JE ) END IF 130 CONTINUE M = IM END IF IF( IDISCL.LT.0 .OR. IDISCU.LT.0 ) THEN TOOFEW = .TRUE. END IF END IF * * If ORDER='B', do nothing -- the eigenvalues are already sorted * by block. * If ORDER='E', sort the eigenvalues from smallest to largest * IF( IORDER.EQ.1 .AND. NSPLIT.GT.1 ) THEN DO 150 JE = 1, M - 1 IE = 0 TMP1 = W( JE ) DO 140 J = JE + 1, M IF( W( J ).LT.TMP1 ) THEN IE = J TMP1 = W( J ) END IF 140 CONTINUE * IF( IE.NE.0 ) THEN ITMP1 = IBLOCK( IE ) W( IE ) = W( JE ) IBLOCK( IE ) = IBLOCK( JE ) W( JE ) = TMP1 IBLOCK( JE ) = ITMP1 END IF 150 CONTINUE END IF * INFO = 0 IF( NCNVRG ) $ INFO = INFO + 1 IF( TOOFEW ) $ INFO = INFO + 2 RETURN * * End of DSTEBZ * END *> \brief \b DSTEDC * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSTEDC + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, * LIWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER COMPZ * INTEGER INFO, LDZ, LIWORK, LWORK, N * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSTEDC computes all eigenvalues and, optionally, eigenvectors of a *> symmetric tridiagonal matrix using the divide and conquer method. *> The eigenvectors of a full or band real symmetric matrix can also be *> found if DSYTRD or DSPTRD or DSBTRD has been used to reduce this *> matrix to tridiagonal form. *> *> This code makes very mild assumptions about floating point *> arithmetic. It will work on machines with a guard digit in *> add/subtract, or on those binary machines without guard digits *> which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. *> It could conceivably fail on hexadecimal or decimal machines *> without guard digits, but we know of none. See DLAED3 for details. *> \endverbatim * * Arguments: * ========== * *> \param[in] COMPZ *> \verbatim *> COMPZ is CHARACTER*1 *> = 'N': Compute eigenvalues only. *> = 'I': Compute eigenvectors of tridiagonal matrix also. *> = 'V': Compute eigenvectors of original dense symmetric *> matrix also. On entry, Z contains the orthogonal *> matrix used to reduce the original matrix to *> tridiagonal form. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The dimension of the symmetric tridiagonal matrix. N >= 0. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> On entry, the diagonal elements of the tridiagonal matrix. *> On exit, if INFO = 0, the eigenvalues in ascending order. *> \endverbatim *> *> \param[in,out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N-1) *> On entry, the subdiagonal elements of the tridiagonal matrix. *> On exit, E has been destroyed. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ,N) *> On entry, if COMPZ = 'V', then Z contains the orthogonal *> matrix used in the reduction to tridiagonal form. *> On exit, if INFO = 0, then if COMPZ = 'V', Z contains the *> orthonormal eigenvectors of the original symmetric matrix, *> and if COMPZ = 'I', Z contains the orthonormal eigenvectors *> of the symmetric tridiagonal matrix. *> If COMPZ = 'N', then Z is not referenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1. *> If eigenvectors are desired, then LDZ >= max(1,N). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. *> If COMPZ = 'N' or N <= 1 then LWORK must be at least 1. *> If COMPZ = 'V' and N > 1 then LWORK must be at least *> ( 1 + 3*N + 2*N*lg N + 4*N**2 ), *> where lg( N ) = smallest integer k such *> that 2**k >= N. *> If COMPZ = 'I' and N > 1 then LWORK must be at least *> ( 1 + 4*N + N**2 ). *> Note that for COMPZ = 'I' or 'V', then if N is less than or *> equal to the minimum divide size, usually 25, then LWORK need *> only be max(1,2*(N-1)). *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error *> message related to LWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) *> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. *> \endverbatim *> *> \param[in] LIWORK *> \verbatim *> LIWORK is INTEGER *> The dimension of the array IWORK. *> If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1. *> If COMPZ = 'V' and N > 1 then LIWORK must be at least *> ( 6 + 6*N + 5*N*lg N ). *> If COMPZ = 'I' and N > 1 then LIWORK must be at least *> ( 3 + 5*N ). *> Note that for COMPZ = 'I' or 'V', then if N is less than or *> equal to the minimum divide size, usually 25, then LIWORK *> need only be 1. *> *> If LIWORK = -1, then a workspace query is assumed; the *> routine only calculates the optimal size of the IWORK array, *> returns this value as the first entry of the IWORK array, and *> no error message related to LIWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is 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). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup auxOTHERcomputational * *> \par Contributors: * ================== *> *> Jeff Rutter, Computer Science Division, University of California *> at Berkeley, USA \n *> Modified by Francoise Tisseur, University of Tennessee *> * ===================================================================== SUBROUTINE DSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, $ LIWORK, INFO ) * * -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. CHARACTER COMPZ INTEGER INFO, LDZ, LIWORK, LWORK, N * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER FINISH, I, ICOMPZ, II, J, K, LGN, LIWMIN, $ LWMIN, M, SMLSIZ, START, STOREZ, STRTRW DOUBLE PRECISION EPS, ORGNRM, P, TINY * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANST EXTERNAL LSAME, ILAENV, DLAMCH, DLANST * .. * .. External Subroutines .. EXTERNAL DGEMM, DLACPY, DLAED0, DLASCL, DLASET, DLASRT, $ DSTEQR, DSTERF, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, LOG, MAX, MOD, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) * IF( LSAME( COMPZ, 'N' ) ) THEN ICOMPZ = 0 ELSE IF( LSAME( COMPZ, 'V' ) ) THEN ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ICOMPZ = 2 ELSE ICOMPZ = -1 END IF IF( ICOMPZ.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( ( LDZ.LT.1 ) .OR. $ ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, N ) ) ) THEN INFO = -6 END IF * IF( INFO.EQ.0 ) THEN * * Compute the workspace requirements * SMLSIZ = ILAENV( 9, 'DSTEDC', ' ', 0, 0, 0, 0 ) IF( N.LE.1 .OR. ICOMPZ.EQ.0 ) THEN LIWMIN = 1 LWMIN = 1 ELSE IF( N.LE.SMLSIZ ) THEN LIWMIN = 1 LWMIN = 2*( N - 1 ) ELSE LGN = INT( LOG( DBLE( N ) )/LOG( TWO ) ) IF( 2**LGN.LT.N ) $ LGN = LGN + 1 IF( 2**LGN.LT.N ) $ LGN = LGN + 1 IF( ICOMPZ.EQ.1 ) THEN LWMIN = 1 + 3*N + 2*N*LGN + 4*N**2 LIWMIN = 6 + 6*N + 5*N*LGN ELSE IF( ICOMPZ.EQ.2 ) THEN LWMIN = 1 + 4*N + N**2 LIWMIN = 3 + 5*N END IF END IF WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN * IF( LWORK.LT.LWMIN .AND. .NOT. LQUERY ) THEN INFO = -8 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT. LQUERY ) THEN INFO = -10 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSTEDC', -INFO ) RETURN ELSE IF (LQUERY) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN IF( N.EQ.1 ) THEN IF( ICOMPZ.NE.0 ) $ Z( 1, 1 ) = ONE RETURN END IF * * If the following conditional clause is removed, then the routine * will use the Divide and Conquer routine to compute only the * eigenvalues, which requires (3N + 3N**2) real workspace and * (2 + 5N + 2N lg(N)) integer workspace. * Since on many architectures DSTERF is much faster than any other * algorithm for finding eigenvalues only, it is used here * as the default. If the conditional clause is removed, then * information on the size of workspace needs to be changed. * * If COMPZ = 'N', use DSTERF to compute the eigenvalues. * IF( ICOMPZ.EQ.0 ) THEN CALL DSTERF( N, D, E, INFO ) GO TO 50 END IF * * If N is smaller than the minimum divide size (SMLSIZ+1), then * solve the problem with another solver. * IF( N.LE.SMLSIZ ) THEN * CALL DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * ELSE * * If COMPZ = 'V', the Z matrix must be stored elsewhere for later * use. * IF( ICOMPZ.EQ.1 ) THEN STOREZ = 1 + N*N ELSE STOREZ = 1 END IF * IF( ICOMPZ.EQ.2 ) THEN CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) END IF * * Scale. * ORGNRM = DLANST( 'M', N, D, E ) IF( ORGNRM.EQ.ZERO ) $ GO TO 50 * EPS = DLAMCH( 'Epsilon' ) * START = 1 * * while ( START <= N ) * 10 CONTINUE IF( START.LE.N ) THEN * * Let FINISH be the position of the next subdiagonal entry * such that E( FINISH ) <= TINY or FINISH = N if no such * subdiagonal exists. The matrix identified by the elements * between START and FINISH constitutes an independent * sub-problem. * FINISH = START 20 CONTINUE IF( FINISH.LT.N ) THEN TINY = EPS*SQRT( ABS( D( FINISH ) ) )* $ SQRT( ABS( D( FINISH+1 ) ) ) IF( ABS( E( FINISH ) ).GT.TINY ) THEN FINISH = FINISH + 1 GO TO 20 END IF END IF * * (Sub) Problem determined. Compute its size and solve it. * M = FINISH - START + 1 IF( M.EQ.1 ) THEN START = FINISH + 1 GO TO 10 END IF IF( M.GT.SMLSIZ ) THEN * * Scale. * ORGNRM = DLANST( 'M', M, D( START ), E( START ) ) CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M, 1, D( START ), M, $ INFO ) CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M-1, 1, E( START ), $ M-1, INFO ) * IF( ICOMPZ.EQ.1 ) THEN STRTRW = 1 ELSE STRTRW = START END IF CALL DLAED0( ICOMPZ, N, M, D( START ), E( START ), $ Z( STRTRW, START ), LDZ, WORK( 1 ), N, $ WORK( STOREZ ), IWORK, INFO ) IF( INFO.NE.0 ) THEN INFO = ( INFO / ( M+1 )+START-1 )*( N+1 ) + $ MOD( INFO, ( M+1 ) ) + START - 1 GO TO 50 END IF * * Scale back. * CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, M, 1, D( START ), M, $ INFO ) * ELSE IF( ICOMPZ.EQ.1 ) THEN * * Since QR won't update a Z matrix which is larger than * the length of D, we must solve the sub-problem in a * workspace and then multiply back into Z. * CALL DSTEQR( 'I', M, D( START ), E( START ), WORK, M, $ WORK( M*M+1 ), INFO ) CALL DLACPY( 'A', N, M, Z( 1, START ), LDZ, $ WORK( STOREZ ), N ) CALL DGEMM( 'N', 'N', N, M, M, ONE, $ WORK( STOREZ ), N, WORK, M, ZERO, $ Z( 1, START ), LDZ ) ELSE IF( ICOMPZ.EQ.2 ) THEN CALL DSTEQR( 'I', M, D( START ), E( START ), $ Z( START, START ), LDZ, WORK, INFO ) ELSE CALL DSTERF( M, D( START ), E( START ), INFO ) END IF IF( INFO.NE.0 ) THEN INFO = START*( N+1 ) + FINISH GO TO 50 END IF END IF * START = FINISH + 1 GO TO 10 END IF * * endwhile * IF( ICOMPZ.EQ.0 ) THEN * * Use Quick Sort * CALL DLASRT( 'I', N, D, INFO ) * ELSE * * Use Selection Sort to minimize swaps of eigenvectors * DO 40 II = 2, N I = II - 1 K = I P = D( I ) DO 30 J = II, N IF( D( J ).LT.P ) THEN K = J P = D( J ) END IF 30 CONTINUE IF( K.NE.I ) THEN D( K ) = D( I ) D( I ) = P CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) END IF 40 CONTINUE END IF END IF * 50 CONTINUE WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN * RETURN * * End of DSTEDC * END *> \brief \b DSTEGR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSTEGR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, * ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, * LIWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE * INTEGER IL, INFO, IU, LDZ, LIWORK, LWORK, M, N * DOUBLE PRECISION ABSTOL, VL, VU * .. * .. Array Arguments .. * INTEGER ISUPPZ( * ), IWORK( * ) * DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ) * DOUBLE PRECISION Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSTEGR computes selected eigenvalues and, optionally, eigenvectors *> of a real symmetric tridiagonal matrix T. Any such unreduced matrix has *> a well defined set of pairwise different real eigenvalues, the corresponding *> real eigenvectors are pairwise orthogonal. *> *> The spectrum may be computed either completely or partially by specifying *> either an interval (VL,VU] or a range of indices IL:IU for the desired *> eigenvalues. *> *> DSTEGR is a compatibility wrapper around the improved DSTEMR routine. *> See DSTEMR for further details. *> *> One important change is that the ABSTOL parameter no longer provides any *> benefit and hence is no longer used. *> *> Note : DSTEGR and DSTEMR work only on machines which follow *> IEEE-754 floating-point standard in their handling of infinities and *> NaNs. Normal execution may create these exceptiona values and hence *> may abort due to a floating point exception in environments which *> do not conform to the IEEE-754 standard. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBZ *> \verbatim *> JOBZ is CHARACTER*1 *> = 'N': Compute eigenvalues only; *> = 'V': Compute eigenvalues and eigenvectors. *> \endverbatim *> *> \param[in] RANGE *> \verbatim *> RANGE is CHARACTER*1 *> = 'A': all eigenvalues will be found. *> = 'V': all eigenvalues in the half-open interval (VL,VU] *> will be found. *> = 'I': the IL-th through IU-th eigenvalues will be found. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix. N >= 0. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> On entry, the N diagonal elements of the tridiagonal matrix *> T. On exit, D is overwritten. *> \endverbatim *> *> \param[in,out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N) *> On entry, the (N-1) subdiagonal elements of the tridiagonal *> matrix T in elements 1 to N-1 of E. E(N) need not be set on *> input, but is used internally as workspace. *> On exit, E is overwritten. *> \endverbatim *> *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION *> *> If RANGE='V', the lower bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION *> *> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] IL *> \verbatim *> IL is INTEGER *> *> If RANGE='I', the index of the *> smallest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> *> If RANGE='I', the index of the *> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] ABSTOL *> \verbatim *> ABSTOL is DOUBLE PRECISION *> Unused. Was the absolute error tolerance for the *> eigenvalues/eigenvectors in previous versions. *> \endverbatim *> *> \param[out] M *> \verbatim *> M is INTEGER *> The total number of eigenvalues found. 0 <= M <= N. *> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. *> \endverbatim *> *> \param[out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> The first M elements contain the selected eigenvalues in *> ascending order. *> \endverbatim *> *> \param[out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M) ) *> If JOBZ = 'V', and if INFO = 0, then the first M columns of Z *> contain the orthonormal eigenvectors of the matrix T *> corresponding to the selected eigenvalues, with the i-th *> column of Z holding the eigenvector associated with W(i). *> If JOBZ = 'N', then Z is not referenced. *> Note: the user must ensure that at least max(1,M) columns are *> supplied in the array Z; if RANGE = 'V', the exact value of M *> is not known in advance and an upper bound must be used. *> Supplying N columns is always safe. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1, and if *> JOBZ = 'V', then LDZ >= max(1,N). *> \endverbatim *> *> \param[out] ISUPPZ *> \verbatim *> ISUPPZ is INTEGER array, dimension ( 2*max(1,M) ) *> The support of the eigenvectors in Z, i.e., the indices *> indicating the nonzero elements in Z. The i-th computed eigenvector *> is nonzero only in elements ISUPPZ( 2*i-1 ) through *> ISUPPZ( 2*i ). This is relevant in the case when the matrix *> is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (LWORK) *> On exit, if INFO = 0, WORK(1) returns the optimal *> (and minimal) LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= max(1,18*N) *> if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'. *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error *> message related to LWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (LIWORK) *> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. *> \endverbatim *> *> \param[in] LIWORK *> \verbatim *> LIWORK is INTEGER *> The dimension of the array IWORK. LIWORK >= max(1,10*N) *> if the eigenvectors are desired, and LIWORK >= max(1,8*N) *> if only the eigenvalues are to be computed. *> If LIWORK = -1, then a workspace query is assumed; the *> routine only calculates the optimal size of the IWORK array, *> returns this value as the first entry of the IWORK array, and *> no error message related to LIWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> On exit, INFO *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = 1X, internal error in DLARRE, *> if INFO = 2X, internal error in DLARRV. *> Here, the digit X = ABS( IINFO ) < 10, where IINFO is *> the nonzero error code returned by DLARRE or *> DLARRV, respectively. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleOTHERcomputational * *> \par Contributors: * ================== *> *> Inderjit Dhillon, IBM Almaden, USA \n *> Osni Marques, LBNL/NERSC, USA \n *> Christof Voemel, LBNL/NERSC, USA \n * * ===================================================================== SUBROUTINE DSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, $ ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, $ LIWORK, INFO ) * * -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE INTEGER IL, INFO, IU, LDZ, LIWORK, LWORK, M, N DOUBLE PRECISION ABSTOL, VL, VU * .. * .. Array Arguments .. INTEGER ISUPPZ( * ), IWORK( * ) DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ) DOUBLE PRECISION Z( LDZ, * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL TRYRAC * .. * .. External Subroutines .. EXTERNAL DSTEMR * .. * .. Executable Statements .. INFO = 0 TRYRAC = .FALSE. CALL DSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, $ M, W, Z, LDZ, N, ISUPPZ, TRYRAC, WORK, LWORK, $ IWORK, LIWORK, INFO ) * * End of DSTEGR * END *> \brief \b DSTEIN * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSTEIN + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, * IWORK, IFAIL, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDZ, M, N * .. * .. Array Arguments .. * INTEGER IBLOCK( * ), IFAIL( * ), ISPLIT( * ), * $ IWORK( * ) * DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSTEIN computes the eigenvectors of a real symmetric tridiagonal *> matrix T corresponding to specified eigenvalues, using inverse *> iteration. *> *> The maximum number of iterations allowed for each eigenvector is *> specified by an internal parameter MAXITS (currently set to 5). *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix. N >= 0. *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The n diagonal elements of the tridiagonal matrix T. *> \endverbatim *> *> \param[in] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N-1) *> The (n-1) subdiagonal elements of the tridiagonal matrix *> T, in elements 1 to N-1. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of eigenvectors to be found. 0 <= M <= N. *> \endverbatim *> *> \param[in] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> The first M elements of W contain the eigenvalues for *> which eigenvectors are to be computed. The eigenvalues *> should be grouped by split-off block and ordered from *> smallest to largest within the block. ( The output array *> W from DSTEBZ with ORDER = 'B' is expected here. ) *> \endverbatim *> *> \param[in] IBLOCK *> \verbatim *> IBLOCK is INTEGER array, dimension (N) *> The submatrix indices associated with the corresponding *> eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to *> the first submatrix from the top, =2 if W(i) belongs to *> the second submatrix, etc. ( The output array IBLOCK *> from DSTEBZ is expected here. ) *> \endverbatim *> *> \param[in] ISPLIT *> \verbatim *> ISPLIT is INTEGER array, dimension (N) *> The splitting points, at which T breaks up into submatrices. *> The first submatrix consists of rows/columns 1 to *> ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 *> through ISPLIT( 2 ), etc. *> ( The output array ISPLIT from DSTEBZ is expected here. ) *> \endverbatim *> *> \param[out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ, M) *> The computed eigenvectors. The eigenvector associated *> with the eigenvalue W(i) is stored in the i-th column of *> Z. Any vector which fails to converge is set to its current *> iterate after MAXITS iterations. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= max(1,N). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (5*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> \endverbatim *> *> \param[out] IFAIL *> \verbatim *> IFAIL is INTEGER array, dimension (M) *> On normal exit, all elements of IFAIL are zero. *> If one or more eigenvectors fail to converge after *> MAXITS iterations, then their indices are stored in *> array IFAIL. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, then i eigenvectors failed to converge *> in MAXITS iterations. Their indices are stored in *> array IFAIL. *> \endverbatim * *> \par Internal Parameters: * ========================= *> *> \verbatim *> MAXITS INTEGER, default = 5 *> The maximum number of iterations performed. *> *> EXTRA INTEGER, default = 2 *> The number of iterations performed after norm growth *> criterion is satisfied, should be at least 1. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, $ IWORK, IFAIL, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDZ, M, N * .. * .. Array Arguments .. INTEGER IBLOCK( * ), IFAIL( * ), ISPLIT( * ), $ IWORK( * ) DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TEN, ODM3, ODM1 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1, $ ODM3 = 1.0D-3, ODM1 = 1.0D-1 ) INTEGER MAXITS, EXTRA PARAMETER ( MAXITS = 5, EXTRA = 2 ) * .. * .. Local Scalars .. INTEGER B1, BLKSIZ, BN, GPIND, I, IINFO, INDRV1, $ INDRV2, INDRV3, INDRV4, INDRV5, ITS, J, J1, $ JBLK, JMAX, NBLK, NRMCHK DOUBLE PRECISION DTPCRT, EPS, EPS1, NRM, ONENRM, ORTOL, PERTOL, $ SCL, SEP, TOL, XJ, XJM, ZTR * .. * .. Local Arrays .. INTEGER ISEED( 4 ) * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DDOT, DLAMCH, DNRM2 EXTERNAL IDAMAX, DDOT, DLAMCH, DNRM2 * .. * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DLAGTF, DLAGTS, DLARNV, DSCAL, $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 DO 10 I = 1, M IFAIL( I ) = 0 10 CONTINUE * IF( N.LT.0 ) THEN INFO = -1 ELSE IF( M.LT.0 .OR. M.GT.N ) THEN INFO = -4 ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE DO 20 J = 2, M IF( IBLOCK( J ).LT.IBLOCK( J-1 ) ) THEN INFO = -6 GO TO 30 END IF IF( IBLOCK( J ).EQ.IBLOCK( J-1 ) .AND. W( J ).LT.W( J-1 ) ) $ THEN INFO = -5 GO TO 30 END IF 20 CONTINUE 30 CONTINUE END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSTEIN', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. M.EQ.0 ) THEN RETURN ELSE IF( N.EQ.1 ) THEN Z( 1, 1 ) = ONE RETURN END IF * * Get machine constants. * EPS = DLAMCH( 'Precision' ) * * Initialize seed for random number generator DLARNV. * DO 40 I = 1, 4 ISEED( I ) = 1 40 CONTINUE * * Initialize pointers. * INDRV1 = 0 INDRV2 = INDRV1 + N INDRV3 = INDRV2 + N INDRV4 = INDRV3 + N INDRV5 = INDRV4 + N * * Compute eigenvectors of matrix blocks. * J1 = 1 DO 160 NBLK = 1, IBLOCK( M ) * * Find starting and ending indices of block nblk. * IF( NBLK.EQ.1 ) THEN B1 = 1 ELSE B1 = ISPLIT( NBLK-1 ) + 1 END IF BN = ISPLIT( NBLK ) BLKSIZ = BN - B1 + 1 IF( BLKSIZ.EQ.1 ) $ GO TO 60 GPIND = J1 * * Compute reorthogonalization criterion and stopping criterion. * ONENRM = ABS( D( B1 ) ) + ABS( E( B1 ) ) ONENRM = MAX( ONENRM, ABS( D( BN ) )+ABS( E( BN-1 ) ) ) DO 50 I = B1 + 1, BN - 1 ONENRM = MAX( ONENRM, ABS( D( I ) )+ABS( E( I-1 ) )+ $ ABS( E( I ) ) ) 50 CONTINUE ORTOL = ODM3*ONENRM * DTPCRT = SQRT( ODM1 / BLKSIZ ) * * Loop through eigenvalues of block nblk. * 60 CONTINUE JBLK = 0 DO 150 J = J1, M IF( IBLOCK( J ).NE.NBLK ) THEN J1 = J GO TO 160 END IF JBLK = JBLK + 1 XJ = W( J ) * * Skip all the work if the block size is one. * IF( BLKSIZ.EQ.1 ) THEN WORK( INDRV1+1 ) = ONE GO TO 120 END IF * * If eigenvalues j and j-1 are too close, add a relatively * small perturbation. * IF( JBLK.GT.1 ) THEN EPS1 = ABS( EPS*XJ ) PERTOL = TEN*EPS1 SEP = XJ - XJM IF( SEP.LT.PERTOL ) $ XJ = XJM + PERTOL END IF * ITS = 0 NRMCHK = 0 * * Get random starting vector. * CALL DLARNV( 2, ISEED, BLKSIZ, WORK( INDRV1+1 ) ) * * Copy the matrix T so it won't be destroyed in factorization. * CALL DCOPY( BLKSIZ, D( B1 ), 1, WORK( INDRV4+1 ), 1 ) CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV2+2 ), 1 ) CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV3+1 ), 1 ) * * Compute LU factors with partial pivoting ( PT = LU ) * TOL = ZERO CALL DLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, WORK( INDRV2+2 ), $ WORK( INDRV3+1 ), TOL, WORK( INDRV5+1 ), IWORK, $ IINFO ) * * Update iteration count. * 70 CONTINUE ITS = ITS + 1 IF( ITS.GT.MAXITS ) $ GO TO 100 * * Normalize and scale the righthand side vector Pb. * JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 ) SCL = BLKSIZ*ONENRM*MAX( EPS, $ ABS( WORK( INDRV4+BLKSIZ ) ) ) / $ ABS( WORK( INDRV1+JMAX ) ) CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 ) * * Solve the system LU = Pb. * CALL DLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), WORK( INDRV2+2 ), $ WORK( INDRV3+1 ), WORK( INDRV5+1 ), IWORK, $ WORK( INDRV1+1 ), TOL, IINFO ) * * Reorthogonalize by modified Gram-Schmidt if eigenvalues are * close enough. * IF( JBLK.EQ.1 ) $ GO TO 90 IF( ABS( XJ-XJM ).GT.ORTOL ) $ GPIND = J IF( GPIND.NE.J ) THEN DO 80 I = GPIND, J - 1 ZTR = -DDOT( BLKSIZ, WORK( INDRV1+1 ), 1, Z( B1, I ), $ 1 ) CALL DAXPY( BLKSIZ, ZTR, Z( B1, I ), 1, $ WORK( INDRV1+1 ), 1 ) 80 CONTINUE END IF * * Check the infinity norm of the iterate. * 90 CONTINUE JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 ) NRM = ABS( WORK( INDRV1+JMAX ) ) * * Continue for additional iterations after norm reaches * stopping criterion. * IF( NRM.LT.DTPCRT ) $ GO TO 70 NRMCHK = NRMCHK + 1 IF( NRMCHK.LT.EXTRA+1 ) $ GO TO 70 * GO TO 110 * * If stopping criterion was not satisfied, update info and * store eigenvector number in array ifail. * 100 CONTINUE INFO = INFO + 1 IFAIL( INFO ) = J * * Accept iterate as jth eigenvector. * 110 CONTINUE SCL = ONE / DNRM2( BLKSIZ, WORK( INDRV1+1 ), 1 ) JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 ) IF( WORK( INDRV1+JMAX ).LT.ZERO ) $ SCL = -SCL CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 ) 120 CONTINUE DO 130 I = 1, N Z( I, J ) = ZERO 130 CONTINUE DO 140 I = 1, BLKSIZ Z( B1+I-1, J ) = WORK( INDRV1+I ) 140 CONTINUE * * Save the shift to check eigenvalue spacing at next * iteration. * XJM = XJ * 150 CONTINUE 160 CONTINUE * RETURN * * End of DSTEIN * END *> \brief \b DSTEMR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSTEMR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, * M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, * IWORK, LIWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE * LOGICAL TRYRAC * INTEGER IL, INFO, IU, LDZ, NZC, LIWORK, LWORK, M, N * DOUBLE PRECISION VL, VU * .. * .. Array Arguments .. * INTEGER ISUPPZ( * ), IWORK( * ) * DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ) * DOUBLE PRECISION Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSTEMR computes selected eigenvalues and, optionally, eigenvectors *> of a real symmetric tridiagonal matrix T. Any such unreduced matrix has *> a well defined set of pairwise different real eigenvalues, the corresponding *> real eigenvectors are pairwise orthogonal. *> *> The spectrum may be computed either completely or partially by specifying *> either an interval (VL,VU] or a range of indices IL:IU for the desired *> eigenvalues. *> *> Depending on the number of desired eigenvalues, these are computed either *> by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are *> computed by the use of various suitable L D L^T factorizations near clusters *> of close eigenvalues (referred to as RRRs, Relatively Robust *> Representations). An informal sketch of the algorithm follows. *> *> For each unreduced block (submatrix) of T, *> (a) Compute T - sigma I = L D L^T, so that L and D *> define all the wanted eigenvalues to high relative accuracy. *> This means that small relative changes in the entries of D and L *> cause only small relative changes in the eigenvalues and *> eigenvectors. The standard (unfactored) representation of the *> tridiagonal matrix T does not have this property in general. *> (b) Compute the eigenvalues to suitable accuracy. *> If the eigenvectors are desired, the algorithm attains full *> accuracy of the computed eigenvalues only right before *> the corresponding vectors have to be computed, see steps c) and d). *> (c) For each cluster of close eigenvalues, select a new *> shift close to the cluster, find a new factorization, and refine *> the shifted eigenvalues to suitable accuracy. *> (d) For each eigenvalue with a large enough relative separation compute *> the corresponding eigenvector by forming a rank revealing twisted *> factorization. Go back to (c) for any clusters that remain. *> *> For more details, see: *> - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations *> to compute orthogonal eigenvectors of symmetric tridiagonal matrices," *> Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. *> - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and *> Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, *> 2004. Also LAPACK Working Note 154. *> - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric *> tridiagonal eigenvalue/eigenvector problem", *> Computer Science Division Technical Report No. UCB/CSD-97-971, *> UC Berkeley, May 1997. *> *> Further Details *> 1.DSTEMR works only on machines which follow IEEE-754 *> floating-point standard in their handling of infinities and NaNs. *> This permits the use of efficient inner loops avoiding a check for *> zero divisors. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBZ *> \verbatim *> JOBZ is CHARACTER*1 *> = 'N': Compute eigenvalues only; *> = 'V': Compute eigenvalues and eigenvectors. *> \endverbatim *> *> \param[in] RANGE *> \verbatim *> RANGE is CHARACTER*1 *> = 'A': all eigenvalues will be found. *> = 'V': all eigenvalues in the half-open interval (VL,VU] *> will be found. *> = 'I': the IL-th through IU-th eigenvalues will be found. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix. N >= 0. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> On entry, the N diagonal elements of the tridiagonal matrix *> T. On exit, D is overwritten. *> \endverbatim *> *> \param[in,out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N) *> On entry, the (N-1) subdiagonal elements of the tridiagonal *> matrix T in elements 1 to N-1 of E. E(N) need not be set on *> input, but is used internally as workspace. *> On exit, E is overwritten. *> \endverbatim *> *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION *> *> If RANGE='V', the lower bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION *> *> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] IL *> \verbatim *> IL is INTEGER *> *> If RANGE='I', the index of the *> smallest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> *> If RANGE='I', the index of the *> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[out] M *> \verbatim *> M is INTEGER *> The total number of eigenvalues found. 0 <= M <= N. *> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. *> \endverbatim *> *> \param[out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> The first M elements contain the selected eigenvalues in *> ascending order. *> \endverbatim *> *> \param[out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M) ) *> If JOBZ = 'V', and if INFO = 0, then the first M columns of Z *> contain the orthonormal eigenvectors of the matrix T *> corresponding to the selected eigenvalues, with the i-th *> column of Z holding the eigenvector associated with W(i). *> If JOBZ = 'N', then Z is not referenced. *> Note: the user must ensure that at least max(1,M) columns are *> supplied in the array Z; if RANGE = 'V', the exact value of M *> is not known in advance and can be computed with a workspace *> query by setting NZC = -1, see below. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1, and if *> JOBZ = 'V', then LDZ >= max(1,N). *> \endverbatim *> *> \param[in] NZC *> \verbatim *> NZC is INTEGER *> The number of eigenvectors to be held in the array Z. *> If RANGE = 'A', then NZC >= max(1,N). *> If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU]. *> If RANGE = 'I', then NZC >= IU-IL+1. *> If NZC = -1, then a workspace query is assumed; the *> routine calculates the number of columns of the array Z that *> are needed to hold the eigenvectors. *> This value is returned as the first entry of the Z array, and *> no error message related to NZC is issued by XERBLA. *> \endverbatim *> *> \param[out] ISUPPZ *> \verbatim *> ISUPPZ is INTEGER array, dimension ( 2*max(1,M) ) *> The support of the eigenvectors in Z, i.e., the indices *> indicating the nonzero elements in Z. The i-th computed eigenvector *> is nonzero only in elements ISUPPZ( 2*i-1 ) through *> ISUPPZ( 2*i ). This is relevant in the case when the matrix *> is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0. *> \endverbatim *> *> \param[in,out] TRYRAC *> \verbatim *> TRYRAC is LOGICAL *> If TRYRAC.EQ..TRUE., indicates that the code should check whether *> the tridiagonal matrix defines its eigenvalues to high relative *> accuracy. If so, the code uses relative-accuracy preserving *> algorithms that might be (a bit) slower depending on the matrix. *> If the matrix does not define its eigenvalues to high relative *> accuracy, the code can uses possibly faster algorithms. *> If TRYRAC.EQ..FALSE., the code is not required to guarantee *> relatively accurate eigenvalues and can use the fastest possible *> techniques. *> On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix *> does not define its eigenvalues to high relative accuracy. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (LWORK) *> On exit, if INFO = 0, WORK(1) returns the optimal *> (and minimal) LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= max(1,18*N) *> if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'. *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error *> message related to LWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (LIWORK) *> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. *> \endverbatim *> *> \param[in] LIWORK *> \verbatim *> LIWORK is INTEGER *> The dimension of the array IWORK. LIWORK >= max(1,10*N) *> if the eigenvectors are desired, and LIWORK >= max(1,8*N) *> if only the eigenvalues are to be computed. *> If LIWORK = -1, then a workspace query is assumed; the *> routine only calculates the optimal size of the IWORK array, *> returns this value as the first entry of the IWORK array, and *> no error message related to LIWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> On exit, INFO *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = 1X, internal error in DLARRE, *> if INFO = 2X, internal error in DLARRV. *> Here, the digit X = ABS( IINFO ) < 10, where IINFO is *> the nonzero error code returned by DLARRE or *> DLARRV, respectively. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleOTHERcomputational * *> \par Contributors: * ================== *> *> Beresford Parlett, University of California, Berkeley, USA \n *> Jim Demmel, University of California, Berkeley, USA \n *> Inderjit Dhillon, University of Texas, Austin, USA \n *> Osni Marques, LBNL/NERSC, USA \n *> Christof Voemel, University of California, Berkeley, USA * * ===================================================================== SUBROUTINE DSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, $ M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, $ IWORK, LIWORK, INFO ) * * -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE LOGICAL TRYRAC INTEGER IL, INFO, IU, LDZ, NZC, LIWORK, LWORK, M, N DOUBLE PRECISION VL, VU * .. * .. Array Arguments .. INTEGER ISUPPZ( * ), IWORK( * ) DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ) DOUBLE PRECISION Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, FOUR, MINRGP PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, $ FOUR = 4.0D0, $ MINRGP = 1.0D-3 ) * .. * .. Local Scalars .. LOGICAL ALLEIG, INDEIG, LQUERY, VALEIG, WANTZ, ZQUERY INTEGER I, IBEGIN, IEND, IFIRST, IIL, IINDBL, IINDW, $ IINDWK, IINFO, IINSPL, IIU, ILAST, IN, INDD, $ INDE2, INDERR, INDGP, INDGRS, INDWRK, ITMP, $ ITMP2, J, JBLK, JJ, LIWMIN, LWMIN, NSPLIT, $ NZCMIN, OFFSET, WBEGIN, WEND DOUBLE PRECISION BIGNUM, CS, EPS, PIVMIN, R1, R2, RMAX, RMIN, $ RTOL1, RTOL2, SAFMIN, SCALE, SMLNUM, SN, $ THRESH, TMP, TNRM, WL, WU * .. * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANST EXTERNAL LSAME, DLAMCH, DLANST * .. * .. External Subroutines .. EXTERNAL DCOPY, DLAE2, DLAEV2, DLARRC, DLARRE, DLARRJ, $ DLARRR, DLARRV, DLASRT, DSCAL, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * WANTZ = LSAME( JOBZ, 'V' ) ALLEIG = LSAME( RANGE, 'A' ) VALEIG = LSAME( RANGE, 'V' ) INDEIG = LSAME( RANGE, 'I' ) * LQUERY = ( ( LWORK.EQ.-1 ).OR.( LIWORK.EQ.-1 ) ) ZQUERY = ( NZC.EQ.-1 ) * DSTEMR needs WORK of size 6*N, IWORK of size 3*N. * In addition, DLARRE needs WORK of size 6*N, IWORK of size 5*N. * Furthermore, DLARRV needs WORK of size 12*N, IWORK of size 7*N. IF( WANTZ ) THEN LWMIN = 18*N LIWMIN = 10*N ELSE * need less workspace if only the eigenvalues are wanted LWMIN = 12*N LIWMIN = 8*N ENDIF WL = ZERO WU = ZERO IIL = 0 IIU = 0 NSPLIT = 0 IF( VALEIG ) THEN * We do not reference VL, VU in the cases RANGE = 'I','A' * The interval (WL, WU] contains all the wanted eigenvalues. * It is either given by the user or computed in DLARRE. WL = VL WU = VU ELSEIF( INDEIG ) THEN * We do not reference IL, IU in the cases RANGE = 'V','A' IIL = IL IIU = IU ENDIF * INFO = 0 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( VALEIG .AND. N.GT.0 .AND. WU.LE.WL ) THEN INFO = -7 ELSE IF( INDEIG .AND. ( IIL.LT.1 .OR. IIL.GT.N ) ) THEN INFO = -8 ELSE IF( INDEIG .AND. ( IIU.LT.IIL .OR. IIU.GT.N ) ) THEN INFO = -9 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN INFO = -13 ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN INFO = -17 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN INFO = -19 END IF * * Get machine constants. * SAFMIN = DLAMCH( 'Safe minimum' ) EPS = DLAMCH( 'Precision' ) SMLNUM = SAFMIN / EPS BIGNUM = ONE / SMLNUM RMIN = SQRT( SMLNUM ) RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) * IF( INFO.EQ.0 ) THEN WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN * IF( WANTZ .AND. ALLEIG ) THEN NZCMIN = N ELSE IF( WANTZ .AND. VALEIG ) THEN CALL DLARRC( 'T', N, VL, VU, D, E, SAFMIN, $ NZCMIN, ITMP, ITMP2, INFO ) ELSE IF( WANTZ .AND. INDEIG ) THEN NZCMIN = IIU-IIL+1 ELSE * WANTZ .EQ. FALSE. NZCMIN = 0 ENDIF IF( ZQUERY .AND. INFO.EQ.0 ) THEN Z( 1,1 ) = NZCMIN ELSE IF( NZC.LT.NZCMIN .AND. .NOT.ZQUERY ) THEN INFO = -14 END IF END IF IF( INFO.NE.0 ) THEN * CALL XERBLA( 'DSTEMR', -INFO ) * RETURN ELSE IF( LQUERY .OR. ZQUERY ) THEN RETURN END IF * * Handle N = 0, 1, and 2 cases immediately * M = 0 IF( N.EQ.0 ) $ RETURN * IF( N.EQ.1 ) THEN IF( ALLEIG .OR. INDEIG ) THEN M = 1 W( 1 ) = D( 1 ) ELSE IF( WL.LT.D( 1 ) .AND. WU.GE.D( 1 ) ) THEN M = 1 W( 1 ) = D( 1 ) END IF END IF IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN Z( 1, 1 ) = ONE ISUPPZ(1) = 1 ISUPPZ(2) = 1 END IF RETURN END IF * IF( N.EQ.2 ) THEN IF( .NOT.WANTZ ) THEN CALL DLAE2( D(1), E(1), D(2), R1, R2 ) ELSE IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN CALL DLAEV2( D(1), E(1), D(2), R1, R2, CS, SN ) END IF IF( ALLEIG.OR. $ (VALEIG.AND.(R2.GT.WL).AND. $ (R2.LE.WU)).OR. $ (INDEIG.AND.(IIL.EQ.1)) ) THEN M = M+1 W( M ) = R2 IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN Z( 1, M ) = -SN Z( 2, M ) = CS * Note: At most one of SN and CS can be zero. IF (SN.NE.ZERO) THEN IF (CS.NE.ZERO) THEN ISUPPZ(2*M-1) = 1 ISUPPZ(2*M) = 2 ELSE ISUPPZ(2*M-1) = 1 ISUPPZ(2*M) = 1 END IF ELSE ISUPPZ(2*M-1) = 2 ISUPPZ(2*M) = 2 END IF ENDIF ENDIF IF( ALLEIG.OR. $ (VALEIG.AND.(R1.GT.WL).AND. $ (R1.LE.WU)).OR. $ (INDEIG.AND.(IIU.EQ.2)) ) THEN M = M+1 W( M ) = R1 IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN Z( 1, M ) = CS Z( 2, M ) = SN * Note: At most one of SN and CS can be zero. IF (SN.NE.ZERO) THEN IF (CS.NE.ZERO) THEN ISUPPZ(2*M-1) = 1 ISUPPZ(2*M) = 2 ELSE ISUPPZ(2*M-1) = 1 ISUPPZ(2*M) = 1 END IF ELSE ISUPPZ(2*M-1) = 2 ISUPPZ(2*M) = 2 END IF ENDIF ENDIF ELSE * Continue with general N INDGRS = 1 INDERR = 2*N + 1 INDGP = 3*N + 1 INDD = 4*N + 1 INDE2 = 5*N + 1 INDWRK = 6*N + 1 * IINSPL = 1 IINDBL = N + 1 IINDW = 2*N + 1 IINDWK = 3*N + 1 * * Scale matrix to allowable range, if necessary. * The allowable range is related to the PIVMIN parameter; see the * comments in DLARRD. The preference for scaling small values * up is heuristic; we expect users' matrices not to be close to the * RMAX threshold. * SCALE = ONE TNRM = DLANST( 'M', N, D, E ) IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN SCALE = RMIN / TNRM ELSE IF( TNRM.GT.RMAX ) THEN SCALE = RMAX / TNRM END IF IF( SCALE.NE.ONE ) THEN CALL DSCAL( N, SCALE, D, 1 ) CALL DSCAL( N-1, SCALE, E, 1 ) TNRM = TNRM*SCALE IF( VALEIG ) THEN * If eigenvalues in interval have to be found, * scale (WL, WU] accordingly WL = WL*SCALE WU = WU*SCALE ENDIF END IF * * Compute the desired eigenvalues of the tridiagonal after splitting * into smaller subblocks if the corresponding off-diagonal elements * are small * THRESH is the splitting parameter for DLARRE * A negative THRESH forces the old splitting criterion based on the * size of the off-diagonal. A positive THRESH switches to splitting * which preserves relative accuracy. * IF( TRYRAC ) THEN * Test whether the matrix warrants the more expensive relative approach. CALL DLARRR( N, D, E, IINFO ) ELSE * The user does not care about relative accurately eigenvalues IINFO = -1 ENDIF * Set the splitting criterion IF (IINFO.EQ.0) THEN THRESH = EPS ELSE THRESH = -EPS * relative accuracy is desired but T does not guarantee it TRYRAC = .FALSE. ENDIF * IF( TRYRAC ) THEN * Copy original diagonal, needed to guarantee relative accuracy CALL DCOPY(N,D,1,WORK(INDD),1) ENDIF * Store the squares of the offdiagonal values of T DO 5 J = 1, N-1 WORK( INDE2+J-1 ) = E(J)**2 5 CONTINUE * Set the tolerance parameters for bisection IF( .NOT.WANTZ ) THEN * DLARRE computes the eigenvalues to full precision. RTOL1 = FOUR * EPS RTOL2 = FOUR * EPS ELSE * DLARRE computes the eigenvalues to less than full precision. * DLARRV will refine the eigenvalue approximations, and we can * need less accurate initial bisection in DLARRE. * Note: these settings do only affect the subset case and DLARRE RTOL1 = SQRT(EPS) RTOL2 = MAX( SQRT(EPS)*5.0D-3, FOUR * EPS ) ENDIF CALL DLARRE( RANGE, N, WL, WU, IIL, IIU, D, E, $ WORK(INDE2), RTOL1, RTOL2, THRESH, NSPLIT, $ IWORK( IINSPL ), M, W, WORK( INDERR ), $ WORK( INDGP ), IWORK( IINDBL ), $ IWORK( IINDW ), WORK( INDGRS ), PIVMIN, $ WORK( INDWRK ), IWORK( IINDWK ), IINFO ) IF( IINFO.NE.0 ) THEN INFO = 10 + ABS( IINFO ) RETURN END IF * Note that if RANGE .NE. 'V', DLARRE computes bounds on the desired * part of the spectrum. All desired eigenvalues are contained in * (WL,WU] IF( WANTZ ) THEN * * Compute the desired eigenvectors corresponding to the computed * eigenvalues * CALL DLARRV( N, WL, WU, D, E, $ PIVMIN, IWORK( IINSPL ), M, $ 1, M, MINRGP, RTOL1, RTOL2, $ W, WORK( INDERR ), WORK( INDGP ), IWORK( IINDBL ), $ IWORK( IINDW ), WORK( INDGRS ), Z, LDZ, $ ISUPPZ, WORK( INDWRK ), IWORK( IINDWK ), IINFO ) IF( IINFO.NE.0 ) THEN INFO = 20 + ABS( IINFO ) RETURN END IF ELSE * DLARRE computes eigenvalues of the (shifted) root representation * DLARRV returns the eigenvalues of the unshifted matrix. * However, if the eigenvectors are not desired by the user, we need * to apply the corresponding shifts from DLARRE to obtain the * eigenvalues of the original matrix. DO 20 J = 1, M ITMP = IWORK( IINDBL+J-1 ) W( J ) = W( J ) + E( IWORK( IINSPL+ITMP-1 ) ) 20 CONTINUE END IF * IF ( TRYRAC ) THEN * Refine computed eigenvalues so that they are relatively accurate * with respect to the original matrix T. IBEGIN = 1 WBEGIN = 1 DO 39 JBLK = 1, IWORK( IINDBL+M-1 ) IEND = IWORK( IINSPL+JBLK-1 ) IN = IEND - IBEGIN + 1 WEND = WBEGIN - 1 * check if any eigenvalues have to be refined in this block 36 CONTINUE IF( WEND.LT.M ) THEN IF( IWORK( IINDBL+WEND ).EQ.JBLK ) THEN WEND = WEND + 1 GO TO 36 END IF END IF IF( WEND.LT.WBEGIN ) THEN IBEGIN = IEND + 1 GO TO 39 END IF OFFSET = IWORK(IINDW+WBEGIN-1)-1 IFIRST = IWORK(IINDW+WBEGIN-1) ILAST = IWORK(IINDW+WEND-1) RTOL2 = FOUR * EPS CALL DLARRJ( IN, $ WORK(INDD+IBEGIN-1), WORK(INDE2+IBEGIN-1), $ IFIRST, ILAST, RTOL2, OFFSET, W(WBEGIN), $ WORK( INDERR+WBEGIN-1 ), $ WORK( INDWRK ), IWORK( IINDWK ), PIVMIN, $ TNRM, IINFO ) IBEGIN = IEND + 1 WBEGIN = WEND + 1 39 CONTINUE ENDIF * * If matrix was scaled, then rescale eigenvalues appropriately. * IF( SCALE.NE.ONE ) THEN CALL DSCAL( M, ONE / SCALE, W, 1 ) END IF END IF * * If eigenvalues are not in increasing order, then sort them, * possibly along with eigenvectors. * IF( NSPLIT.GT.1 .OR. N.EQ.2 ) THEN IF( .NOT. WANTZ ) THEN CALL DLASRT( 'I', M, W, IINFO ) IF( IINFO.NE.0 ) THEN INFO = 3 RETURN END IF ELSE DO 60 J = 1, M - 1 I = 0 TMP = W( J ) DO 50 JJ = J + 1, M IF( W( JJ ).LT.TMP ) THEN I = JJ TMP = W( JJ ) END IF 50 CONTINUE IF( I.NE.0 ) THEN W( I ) = W( J ) W( J ) = TMP IF( WANTZ ) THEN CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) ITMP = ISUPPZ( 2*I-1 ) ISUPPZ( 2*I-1 ) = ISUPPZ( 2*J-1 ) ISUPPZ( 2*J-1 ) = ITMP ITMP = ISUPPZ( 2*I ) ISUPPZ( 2*I ) = ISUPPZ( 2*J ) ISUPPZ( 2*J ) = ITMP END IF END IF 60 CONTINUE END IF ENDIF * * WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN RETURN * * End of DSTEMR * END *> \brief \b DSTEQR * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSTEQR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * * .. Scalar Arguments .. * CHARACTER COMPZ * INTEGER INFO, LDZ, N * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSTEQR computes all eigenvalues and, optionally, eigenvectors of a *> symmetric tridiagonal matrix using the implicit QL or QR method. *> The eigenvectors of a full or band symmetric matrix can also be found *> if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to *> tridiagonal form. *> \endverbatim * * Arguments: * ========== * *> \param[in] COMPZ *> \verbatim *> COMPZ is CHARACTER*1 *> = 'N': Compute eigenvalues only. *> = 'V': Compute eigenvalues and eigenvectors of the original *> symmetric matrix. On entry, Z must contain the *> orthogonal matrix used to reduce the original matrix *> to tridiagonal form. *> = 'I': Compute eigenvalues and eigenvectors of the *> tridiagonal matrix. Z is initialized to the identity *> matrix. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix. N >= 0. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> On entry, the diagonal elements of the tridiagonal matrix. *> On exit, if INFO = 0, the eigenvalues in ascending order. *> \endverbatim *> *> \param[in,out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N-1) *> On entry, the (n-1) subdiagonal elements of the tridiagonal *> matrix. *> On exit, E has been destroyed. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ, N) *> On entry, if COMPZ = 'V', then Z contains the orthogonal *> matrix used in the reduction to tridiagonal form. *> On exit, if INFO = 0, then if COMPZ = 'V', Z contains the *> orthonormal eigenvectors of the original symmetric matrix, *> and if COMPZ = 'I', Z contains the orthonormal eigenvectors *> of the symmetric tridiagonal matrix. *> If COMPZ = 'N', then Z is not referenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1, and if *> eigenvectors are desired, then LDZ >= max(1,N). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (max(1,2*N-2)) *> If COMPZ = 'N', then WORK is not referenced. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: the algorithm has failed to find all the eigenvalues in *> a total of 30*N iterations; if INFO = i, then i *> elements of E have not converged to zero; on exit, D *> and E contain the elements of a symmetric tridiagonal *> matrix which is orthogonally similar to the original *> matrix. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER COMPZ INTEGER INFO, LDZ, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, $ THREE = 3.0D0 ) INTEGER MAXIT PARAMETER ( MAXIT = 30 ) * .. * .. Local Scalars .. INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND, $ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1, $ NM1, NMAXIT DOUBLE PRECISION ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2, $ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANST, DLAPY2 EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2 * .. * .. External Subroutines .. EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASET, DLASR, $ DLASRT, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SIGN, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 * IF( LSAME( COMPZ, 'N' ) ) THEN ICOMPZ = 0 ELSE IF( LSAME( COMPZ, 'V' ) ) THEN ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ICOMPZ = 2 ELSE ICOMPZ = -1 END IF IF( ICOMPZ.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, $ N ) ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSTEQR', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( N.EQ.1 ) THEN IF( ICOMPZ.EQ.2 ) $ Z( 1, 1 ) = ONE RETURN END IF * * Determine the unit roundoff and over/underflow thresholds. * EPS = DLAMCH( 'E' ) EPS2 = EPS**2 SAFMIN = DLAMCH( 'S' ) SAFMAX = ONE / SAFMIN SSFMAX = SQRT( SAFMAX ) / THREE SSFMIN = SQRT( SAFMIN ) / EPS2 * * Compute the eigenvalues and eigenvectors of the tridiagonal * matrix. * IF( ICOMPZ.EQ.2 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) * NMAXIT = N*MAXIT JTOT = 0 * * Determine where the matrix splits and choose QL or QR iteration * for each block, according to whether top or bottom diagonal * element is smaller. * L1 = 1 NM1 = N - 1 * 10 CONTINUE IF( L1.GT.N ) $ GO TO 160 IF( L1.GT.1 ) $ E( L1-1 ) = ZERO IF( L1.LE.NM1 ) THEN DO 20 M = L1, NM1 TST = ABS( E( M ) ) IF( TST.EQ.ZERO ) $ GO TO 30 IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ $ 1 ) ) ) )*EPS ) THEN E( M ) = ZERO GO TO 30 END IF 20 CONTINUE END IF M = N * 30 CONTINUE L = L1 LSV = L LEND = M LENDSV = LEND L1 = M + 1 IF( LEND.EQ.L ) $ GO TO 10 * * Scale submatrix in rows and columns L to LEND * ANORM = DLANST( 'M', LEND-L+1, D( L ), E( L ) ) ISCALE = 0 IF( ANORM.EQ.ZERO ) $ GO TO 10 IF( ANORM.GT.SSFMAX ) THEN ISCALE = 1 CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, $ INFO ) CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, $ INFO ) ELSE IF( ANORM.LT.SSFMIN ) THEN ISCALE = 2 CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, $ INFO ) CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, $ INFO ) END IF * * Choose between QL and QR iteration * IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN LEND = LSV L = LENDSV END IF * IF( LEND.GT.L ) THEN * * QL Iteration * * Look for small subdiagonal element. * 40 CONTINUE IF( L.NE.LEND ) THEN LENDM1 = LEND - 1 DO 50 M = L, LENDM1 TST = ABS( E( M ) )**2 IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+ $ SAFMIN )GO TO 60 50 CONTINUE END IF * M = LEND * 60 CONTINUE IF( M.LT.LEND ) $ E( M ) = ZERO P = D( L ) IF( M.EQ.L ) $ GO TO 80 * * If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 * to compute its eigensystem. * IF( M.EQ.L+1 ) THEN IF( ICOMPZ.GT.0 ) THEN CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S ) WORK( L ) = C WORK( N-1+L ) = S CALL DLASR( 'R', 'V', 'B', N, 2, WORK( L ), $ WORK( N-1+L ), Z( 1, L ), LDZ ) ELSE CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 ) END IF D( L ) = RT1 D( L+1 ) = RT2 E( L ) = ZERO L = L + 2 IF( L.LE.LEND ) $ GO TO 40 GO TO 140 END IF * IF( JTOT.EQ.NMAXIT ) $ GO TO 140 JTOT = JTOT + 1 * * Form shift. * G = ( D( L+1 )-P ) / ( TWO*E( L ) ) R = DLAPY2( G, ONE ) G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) ) * S = ONE C = ONE P = ZERO * * Inner loop * MM1 = M - 1 DO 70 I = MM1, L, -1 F = S*E( I ) B = C*E( I ) CALL DLARTG( G, F, C, S, R ) IF( I.NE.M-1 ) $ E( I+1 ) = R G = D( I+1 ) - P R = ( D( I )-G )*S + TWO*C*B P = S*R D( I+1 ) = G + P G = C*R - B * * If eigenvectors are desired, then save rotations. * IF( ICOMPZ.GT.0 ) THEN WORK( I ) = C WORK( N-1+I ) = -S END IF * 70 CONTINUE * * If eigenvectors are desired, then apply saved rotations. * IF( ICOMPZ.GT.0 ) THEN MM = M - L + 1 CALL DLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ), $ Z( 1, L ), LDZ ) END IF * D( L ) = D( L ) - P E( L ) = G GO TO 40 * * Eigenvalue found. * 80 CONTINUE D( L ) = P * L = L + 1 IF( L.LE.LEND ) $ GO TO 40 GO TO 140 * ELSE * * QR Iteration * * Look for small superdiagonal element. * 90 CONTINUE IF( L.NE.LEND ) THEN LENDP1 = LEND + 1 DO 100 M = L, LENDP1, -1 TST = ABS( E( M-1 ) )**2 IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+ $ SAFMIN )GO TO 110 100 CONTINUE END IF * M = LEND * 110 CONTINUE IF( M.GT.LEND ) $ E( M-1 ) = ZERO P = D( L ) IF( M.EQ.L ) $ GO TO 130 * * If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 * to compute its eigensystem. * IF( M.EQ.L-1 ) THEN IF( ICOMPZ.GT.0 ) THEN CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S ) WORK( M ) = C WORK( N-1+M ) = S CALL DLASR( 'R', 'V', 'F', N, 2, WORK( M ), $ WORK( N-1+M ), Z( 1, L-1 ), LDZ ) ELSE CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 ) END IF D( L-1 ) = RT1 D( L ) = RT2 E( L-1 ) = ZERO L = L - 2 IF( L.GE.LEND ) $ GO TO 90 GO TO 140 END IF * IF( JTOT.EQ.NMAXIT ) $ GO TO 140 JTOT = JTOT + 1 * * Form shift. * G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) ) R = DLAPY2( G, ONE ) G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) ) * S = ONE C = ONE P = ZERO * * Inner loop * LM1 = L - 1 DO 120 I = M, LM1 F = S*E( I ) B = C*E( I ) CALL DLARTG( G, F, C, S, R ) IF( I.NE.M ) $ E( I-1 ) = R G = D( I ) - P R = ( D( I+1 )-G )*S + TWO*C*B P = S*R D( I ) = G + P G = C*R - B * * If eigenvectors are desired, then save rotations. * IF( ICOMPZ.GT.0 ) THEN WORK( I ) = C WORK( N-1+I ) = S END IF * 120 CONTINUE * * If eigenvectors are desired, then apply saved rotations. * IF( ICOMPZ.GT.0 ) THEN MM = L - M + 1 CALL DLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ), $ Z( 1, M ), LDZ ) END IF * D( L ) = D( L ) - P E( LM1 ) = G GO TO 90 * * Eigenvalue found. * 130 CONTINUE D( L ) = P * L = L - 1 IF( L.GE.LEND ) $ GO TO 90 GO TO 140 * END IF * * Undo scaling if necessary * 140 CONTINUE IF( ISCALE.EQ.1 ) THEN CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, $ D( LSV ), N, INFO ) CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ), $ N, INFO ) ELSE IF( ISCALE.EQ.2 ) THEN CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, $ D( LSV ), N, INFO ) CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ), $ N, INFO ) END IF * * Check for no convergence to an eigenvalue after a total * of N*MAXIT iterations. * IF( JTOT.LT.NMAXIT ) $ GO TO 10 DO 150 I = 1, N - 1 IF( E( I ).NE.ZERO ) $ INFO = INFO + 1 150 CONTINUE GO TO 190 * * Order eigenvalues and eigenvectors. * 160 CONTINUE IF( ICOMPZ.EQ.0 ) THEN * * Use Quick Sort * CALL DLASRT( 'I', N, D, INFO ) * ELSE * * Use Selection Sort to minimize swaps of eigenvectors * DO 180 II = 2, N I = II - 1 K = I P = D( I ) DO 170 J = II, N IF( D( J ).LT.P ) THEN K = J P = D( J ) END IF 170 CONTINUE IF( K.NE.I ) THEN D( K ) = D( I ) D( I ) = P CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) END IF 180 CONTINUE END IF * 190 CONTINUE RETURN * * End of DSTEQR * END *> \brief \b DSTERF * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSTERF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSTERF( N, D, E, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, N * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), E( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSTERF computes all eigenvalues of a symmetric tridiagonal matrix *> using the Pal-Walker-Kahan variant of the QL or QR algorithm. *> \endverbatim * * Arguments: * ========== * *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix. N >= 0. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> On entry, the n diagonal elements of the tridiagonal matrix. *> On exit, if INFO = 0, the eigenvalues in ascending order. *> \endverbatim *> *> \param[in,out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N-1) *> On entry, the (n-1) subdiagonal elements of the tridiagonal *> matrix. *> On exit, E has been destroyed. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: the algorithm failed to find all of the eigenvalues in *> a total of 30*N iterations; if INFO = i, then i *> elements of E have not converged to zero. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== SUBROUTINE DSTERF( N, D, E, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, $ THREE = 3.0D0 ) INTEGER MAXIT PARAMETER ( MAXIT = 30 ) * .. * .. Local Scalars .. INTEGER I, ISCALE, JTOT, L, L1, LEND, LENDSV, LSV, M, $ NMAXIT DOUBLE PRECISION ALPHA, ANORM, BB, C, EPS, EPS2, GAMMA, OLDC, $ OLDGAM, P, R, RT1, RT2, RTE, S, SAFMAX, SAFMIN, $ SIGMA, SSFMAX, SSFMIN, RMAX * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLANST, DLAPY2 EXTERNAL DLAMCH, DLANST, DLAPY2 * .. * .. External Subroutines .. EXTERNAL DLAE2, DLASCL, DLASRT, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, SIGN, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 * * Quick return if possible * IF( N.LT.0 ) THEN INFO = -1 CALL XERBLA( 'DSTERF', -INFO ) RETURN END IF IF( N.LE.1 ) $ RETURN * * Determine the unit roundoff for this environment. * EPS = DLAMCH( 'E' ) EPS2 = EPS**2 SAFMIN = DLAMCH( 'S' ) SAFMAX = ONE / SAFMIN SSFMAX = SQRT( SAFMAX ) / THREE SSFMIN = SQRT( SAFMIN ) / EPS2 RMAX = DLAMCH( 'O' ) * * Compute the eigenvalues of the tridiagonal matrix. * NMAXIT = N*MAXIT SIGMA = ZERO JTOT = 0 * * Determine where the matrix splits and choose QL or QR iteration * for each block, according to whether top or bottom diagonal * element is smaller. * L1 = 1 * 10 CONTINUE IF( L1.GT.N ) $ GO TO 170 IF( L1.GT.1 ) $ E( L1-1 ) = ZERO DO 20 M = L1, N - 1 IF( ABS( E( M ) ).LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ $ 1 ) ) ) )*EPS ) THEN E( M ) = ZERO GO TO 30 END IF 20 CONTINUE M = N * 30 CONTINUE L = L1 LSV = L LEND = M LENDSV = LEND L1 = M + 1 IF( LEND.EQ.L ) $ GO TO 10 * * Scale submatrix in rows and columns L to LEND * ANORM = DLANST( 'M', LEND-L+1, D( L ), E( L ) ) ISCALE = 0 IF( ANORM.EQ.ZERO ) $ GO TO 10 IF( (ANORM.GT.SSFMAX) ) THEN ISCALE = 1 CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, $ INFO ) CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, $ INFO ) ELSE IF( ANORM.LT.SSFMIN ) THEN ISCALE = 2 CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, $ INFO ) CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, $ INFO ) END IF * DO 40 I = L, LEND - 1 E( I ) = E( I )**2 40 CONTINUE * * Choose between QL and QR iteration * IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN LEND = LSV L = LENDSV END IF * IF( LEND.GE.L ) THEN * * QL Iteration * * Look for small subdiagonal element. * 50 CONTINUE IF( L.NE.LEND ) THEN DO 60 M = L, LEND - 1 IF( ABS( E( M ) ).LE.EPS2*ABS( D( M )*D( M+1 ) ) ) $ GO TO 70 60 CONTINUE END IF M = LEND * 70 CONTINUE IF( M.LT.LEND ) $ E( M ) = ZERO P = D( L ) IF( M.EQ.L ) $ GO TO 90 * * If remaining matrix is 2 by 2, use DLAE2 to compute its * eigenvalues. * IF( M.EQ.L+1 ) THEN RTE = SQRT( E( L ) ) CALL DLAE2( D( L ), RTE, D( L+1 ), RT1, RT2 ) D( L ) = RT1 D( L+1 ) = RT2 E( L ) = ZERO L = L + 2 IF( L.LE.LEND ) $ GO TO 50 GO TO 150 END IF * IF( JTOT.EQ.NMAXIT ) $ GO TO 150 JTOT = JTOT + 1 * * Form shift. * RTE = SQRT( E( L ) ) SIGMA = ( D( L+1 )-P ) / ( TWO*RTE ) R = DLAPY2( SIGMA, ONE ) SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) ) * C = ONE S = ZERO GAMMA = D( M ) - SIGMA P = GAMMA*GAMMA * * Inner loop * DO 80 I = M - 1, L, -1 BB = E( I ) R = P + BB IF( I.NE.M-1 ) $ E( I+1 ) = S*R OLDC = C C = P / R S = BB / R OLDGAM = GAMMA ALPHA = D( I ) GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM D( I+1 ) = OLDGAM + ( ALPHA-GAMMA ) IF( C.NE.ZERO ) THEN P = ( GAMMA*GAMMA ) / C ELSE P = OLDC*BB END IF 80 CONTINUE * E( L ) = S*P D( L ) = SIGMA + GAMMA GO TO 50 * * Eigenvalue found. * 90 CONTINUE D( L ) = P * L = L + 1 IF( L.LE.LEND ) $ GO TO 50 GO TO 150 * ELSE * * QR Iteration * * Look for small superdiagonal element. * 100 CONTINUE DO 110 M = L, LEND + 1, -1 IF( ABS( E( M-1 ) ).LE.EPS2*ABS( D( M )*D( M-1 ) ) ) $ GO TO 120 110 CONTINUE M = LEND * 120 CONTINUE IF( M.GT.LEND ) $ E( M-1 ) = ZERO P = D( L ) IF( M.EQ.L ) $ GO TO 140 * * If remaining matrix is 2 by 2, use DLAE2 to compute its * eigenvalues. * IF( M.EQ.L-1 ) THEN RTE = SQRT( E( L-1 ) ) CALL DLAE2( D( L ), RTE, D( L-1 ), RT1, RT2 ) D( L ) = RT1 D( L-1 ) = RT2 E( L-1 ) = ZERO L = L - 2 IF( L.GE.LEND ) $ GO TO 100 GO TO 150 END IF * IF( JTOT.EQ.NMAXIT ) $ GO TO 150 JTOT = JTOT + 1 * * Form shift. * RTE = SQRT( E( L-1 ) ) SIGMA = ( D( L-1 )-P ) / ( TWO*RTE ) R = DLAPY2( SIGMA, ONE ) SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) ) * C = ONE S = ZERO GAMMA = D( M ) - SIGMA P = GAMMA*GAMMA * * Inner loop * DO 130 I = M, L - 1 BB = E( I ) R = P + BB IF( I.NE.M ) $ E( I-1 ) = S*R OLDC = C C = P / R S = BB / R OLDGAM = GAMMA ALPHA = D( I+1 ) GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM D( I ) = OLDGAM + ( ALPHA-GAMMA ) IF( C.NE.ZERO ) THEN P = ( GAMMA*GAMMA ) / C ELSE P = OLDC*BB END IF 130 CONTINUE * E( L-1 ) = S*P D( L ) = SIGMA + GAMMA GO TO 100 * * Eigenvalue found. * 140 CONTINUE D( L ) = P * L = L - 1 IF( L.GE.LEND ) $ GO TO 100 GO TO 150 * END IF * * Undo scaling if necessary * 150 CONTINUE IF( ISCALE.EQ.1 ) $ CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, $ D( LSV ), N, INFO ) IF( ISCALE.EQ.2 ) $ CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, $ D( LSV ), N, INFO ) * * Check for no convergence to an eigenvalue after a total * of N*MAXIT iterations. * IF( JTOT.LT.NMAXIT ) $ GO TO 10 DO 160 I = 1, N - 1 IF( E( I ).NE.ZERO ) $ INFO = INFO + 1 160 CONTINUE GO TO 180 * * Sort eigenvalues in increasing order. * 170 CONTINUE CALL DLASRT( 'I', N, D, INFO ) * 180 CONTINUE RETURN * * End of DSTERF * END *> \brief DSTEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSTEV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSTEV( JOBZ, N, D, E, Z, LDZ, WORK, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBZ * INTEGER INFO, LDZ, N * .. * .. Array Arguments .. * DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSTEV computes all eigenvalues and, optionally, eigenvectors of a *> real symmetric tridiagonal matrix A. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBZ *> \verbatim *> JOBZ is CHARACTER*1 *> = 'N': Compute eigenvalues only; *> = 'V': Compute eigenvalues and eigenvectors. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix. N >= 0. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> On entry, the n diagonal elements of the tridiagonal matrix *> A. *> On exit, if INFO = 0, the eigenvalues in ascending order. *> \endverbatim *> *> \param[in,out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N-1) *> On entry, the (n-1) subdiagonal elements of the tridiagonal *> matrix A, stored in elements 1 to N-1 of E. *> On exit, the contents of E are destroyed. *> \endverbatim *> *> \param[out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ, N) *> If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal *> eigenvectors of the matrix A, with the i-th column of Z *> holding the eigenvector associated with D(i). *> If JOBZ = 'N', then Z is not referenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1, and if *> JOBZ = 'V', LDZ >= max(1,N). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (max(1,2*N-2)) *> If JOBZ = 'N', WORK is not referenced. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, the algorithm failed to converge; i *> off-diagonal elements of E did not converge to zero. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHEReigen * * ===================================================================== SUBROUTINE DSTEV( JOBZ, N, D, E, Z, LDZ, WORK, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ INTEGER INFO, LDZ, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL WANTZ INTEGER IMAX, ISCALE DOUBLE PRECISION BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM, $ TNRM * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANST EXTERNAL LSAME, DLAMCH, DLANST * .. * .. External Subroutines .. EXTERNAL DSCAL, DSTEQR, DSTERF, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC SQRT * .. * .. Executable Statements .. * * Test the input parameters. * WANTZ = LSAME( JOBZ, 'V' ) * INFO = 0 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN INFO = -6 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSTEV ', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( N.EQ.1 ) THEN IF( WANTZ ) $ Z( 1, 1 ) = ONE RETURN END IF * * Get machine constants. * SAFMIN = DLAMCH( 'Safe minimum' ) EPS = DLAMCH( 'Precision' ) SMLNUM = SAFMIN / EPS BIGNUM = ONE / SMLNUM RMIN = SQRT( SMLNUM ) RMAX = SQRT( BIGNUM ) * * Scale matrix to allowable range, if necessary. * ISCALE = 0 TNRM = DLANST( 'M', N, D, E ) IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN ISCALE = 1 SIGMA = RMIN / TNRM ELSE IF( TNRM.GT.RMAX ) THEN ISCALE = 1 SIGMA = RMAX / TNRM END IF IF( ISCALE.EQ.1 ) THEN CALL DSCAL( N, SIGMA, D, 1 ) CALL DSCAL( N-1, SIGMA, E( 1 ), 1 ) END IF * * For eigenvalues only, call DSTERF. For eigenvalues and * eigenvectors, call DSTEQR. * IF( .NOT.WANTZ ) THEN CALL DSTERF( N, D, E, INFO ) ELSE CALL DSTEQR( 'I', N, D, E, Z, LDZ, WORK, INFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * IF( ISCALE.EQ.1 ) THEN IF( INFO.EQ.0 ) THEN IMAX = N ELSE IMAX = INFO - 1 END IF CALL DSCAL( IMAX, ONE / SIGMA, D, 1 ) END IF * RETURN * * End of DSTEV * END *> \brief DSTEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSTEVD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSTEVD( JOBZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, * LIWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBZ * INTEGER INFO, LDZ, LIWORK, LWORK, N * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSTEVD computes all eigenvalues and, optionally, eigenvectors of a *> real symmetric tridiagonal matrix. If eigenvectors are desired, it *> uses a divide and conquer algorithm. *> *> The divide and conquer algorithm makes very mild assumptions about *> floating point arithmetic. It will work on machines with a guard *> digit in add/subtract, or on those binary machines without guard *> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or *> Cray-2. It could conceivably fail on hexadecimal or decimal machines *> without guard digits, but we know of none. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBZ *> \verbatim *> JOBZ is CHARACTER*1 *> = 'N': Compute eigenvalues only; *> = 'V': Compute eigenvalues and eigenvectors. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix. N >= 0. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> On entry, the n diagonal elements of the tridiagonal matrix *> A. *> On exit, if INFO = 0, the eigenvalues in ascending order. *> \endverbatim *> *> \param[in,out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N-1) *> On entry, the (n-1) subdiagonal elements of the tridiagonal *> matrix A, stored in elements 1 to N-1 of E. *> On exit, the contents of E are destroyed. *> \endverbatim *> *> \param[out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ, N) *> If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal *> eigenvectors of the matrix A, with the i-th column of Z *> holding the eigenvector associated with D(i). *> If JOBZ = 'N', then Z is not referenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1, and if *> JOBZ = 'V', LDZ >= max(1,N). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, *> dimension (LWORK) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. *> If JOBZ = 'N' or N <= 1 then LWORK must be at least 1. *> If JOBZ = 'V' and N > 1 then LWORK must be at least *> ( 1 + 4*N + N**2 ). *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal sizes of the WORK and IWORK *> arrays, returns these values as the first entries of the WORK *> and IWORK arrays, and no error message related to LWORK or *> LIWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) *> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. *> \endverbatim *> *> \param[in] LIWORK *> \verbatim *> LIWORK is INTEGER *> The dimension of the array IWORK. *> If JOBZ = 'N' or N <= 1 then LIWORK must be at least 1. *> If JOBZ = 'V' and N > 1 then LIWORK must be at least 3+5*N. *> *> If LIWORK = -1, then a workspace query is assumed; the *> routine only calculates the optimal sizes of the WORK and *> IWORK arrays, returns these values as the first entries of *> the WORK and IWORK arrays, and no error message related to *> LWORK or LIWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, the algorithm failed to converge; i *> off-diagonal elements of E did not converge to zero. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHEReigen * * ===================================================================== SUBROUTINE DSTEVD( JOBZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, $ LIWORK, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ INTEGER INFO, LDZ, LIWORK, LWORK, N * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, WANTZ INTEGER ISCALE, LIWMIN, LWMIN DOUBLE PRECISION BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM, $ TNRM * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANST EXTERNAL LSAME, DLAMCH, DLANST * .. * .. External Subroutines .. EXTERNAL DSCAL, DSTEDC, DSTERF, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC SQRT * .. * .. Executable Statements .. * * Test the input parameters. * WANTZ = LSAME( JOBZ, 'V' ) LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) * INFO = 0 LIWMIN = 1 LWMIN = 1 IF( N.GT.1 .AND. WANTZ ) THEN LWMIN = 1 + 4*N + N**2 LIWMIN = 3 + 5*N END IF * IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN INFO = -6 END IF * IF( INFO.EQ.0 ) THEN WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN * IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN INFO = -8 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN INFO = -10 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSTEVD', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( N.EQ.1 ) THEN IF( WANTZ ) $ Z( 1, 1 ) = ONE RETURN END IF * * Get machine constants. * SAFMIN = DLAMCH( 'Safe minimum' ) EPS = DLAMCH( 'Precision' ) SMLNUM = SAFMIN / EPS BIGNUM = ONE / SMLNUM RMIN = SQRT( SMLNUM ) RMAX = SQRT( BIGNUM ) * * Scale matrix to allowable range, if necessary. * ISCALE = 0 TNRM = DLANST( 'M', N, D, E ) IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN ISCALE = 1 SIGMA = RMIN / TNRM ELSE IF( TNRM.GT.RMAX ) THEN ISCALE = 1 SIGMA = RMAX / TNRM END IF IF( ISCALE.EQ.1 ) THEN CALL DSCAL( N, SIGMA, D, 1 ) CALL DSCAL( N-1, SIGMA, E( 1 ), 1 ) END IF * * For eigenvalues only, call DSTERF. For eigenvalues and * eigenvectors, call DSTEDC. * IF( .NOT.WANTZ ) THEN CALL DSTERF( N, D, E, INFO ) ELSE CALL DSTEDC( 'I', N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK, $ INFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * IF( ISCALE.EQ.1 ) $ CALL DSCAL( N, ONE / SIGMA, D, 1 ) * WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN * RETURN * * End of DSTEVD * END *> \brief DSTEVR computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSTEVR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, * M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, * LIWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE * INTEGER IL, INFO, IU, LDZ, LIWORK, LWORK, M, N * DOUBLE PRECISION ABSTOL, VL, VU * .. * .. Array Arguments .. * INTEGER ISUPPZ( * ), IWORK( * ) * DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSTEVR computes selected eigenvalues and, optionally, eigenvectors *> of a real symmetric tridiagonal matrix T. Eigenvalues and *> eigenvectors can be selected by specifying either a range of values *> or a range of indices for the desired eigenvalues. *> *> Whenever possible, DSTEVR calls DSTEMR to compute the *> eigenspectrum using Relatively Robust Representations. DSTEMR *> computes eigenvalues by the dqds algorithm, while orthogonal *> eigenvectors are computed from various "good" L D L^T representations *> (also known as Relatively Robust Representations). Gram-Schmidt *> orthogonalization is avoided as far as possible. More specifically, *> the various steps of the algorithm are as follows. For the i-th *> unreduced block of T, *> (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T *> is a relatively robust representation, *> (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high *> relative accuracy by the dqds algorithm, *> (c) If there is a cluster of close eigenvalues, "choose" sigma_i *> close to the cluster, and go to step (a), *> (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T, *> compute the corresponding eigenvector by forming a *> rank-revealing twisted factorization. *> The desired accuracy of the output can be specified by the input *> parameter ABSTOL. *> *> For more details, see "A new O(n^2) algorithm for the symmetric *> tridiagonal eigenvalue/eigenvector problem", by Inderjit Dhillon, *> Computer Science Division Technical Report No. UCB//CSD-97-971, *> UC Berkeley, May 1997. *> *> *> Note 1 : DSTEVR calls DSTEMR when the full spectrum is requested *> on machines which conform to the ieee-754 floating point standard. *> DSTEVR calls DSTEBZ and DSTEIN on non-ieee machines and *> when partial spectrum requests are made. *> *> Normal execution of DSTEMR may create NaNs and infinities and *> hence may abort due to a floating point exception in environments *> which do not handle NaNs and infinities in the ieee standard default *> manner. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBZ *> \verbatim *> JOBZ is CHARACTER*1 *> = 'N': Compute eigenvalues only; *> = 'V': Compute eigenvalues and eigenvectors. *> \endverbatim *> *> \param[in] RANGE *> \verbatim *> RANGE is CHARACTER*1 *> = 'A': all eigenvalues will be found. *> = 'V': all eigenvalues in the half-open interval (VL,VU] *> will be found. *> = 'I': the IL-th through IU-th eigenvalues will be found. *> For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and *> DSTEIN are called *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix. N >= 0. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> On entry, the n diagonal elements of the tridiagonal matrix *> A. *> On exit, D may be multiplied by a constant factor chosen *> to avoid over/underflow in computing the eigenvalues. *> \endverbatim *> *> \param[in,out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (max(1,N-1)) *> On entry, the (n-1) subdiagonal elements of the tridiagonal *> matrix A in elements 1 to N-1 of E. *> On exit, E may be multiplied by a constant factor chosen *> to avoid over/underflow in computing the eigenvalues. *> \endverbatim *> *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION *> If RANGE='V', the lower bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION *> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] IL *> \verbatim *> IL is INTEGER *> If RANGE='I', the index of the *> smallest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> If RANGE='I', the index of the *> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] ABSTOL *> \verbatim *> ABSTOL is DOUBLE PRECISION *> The absolute error tolerance for the eigenvalues. *> An approximate eigenvalue is accepted as converged *> when it is determined to lie in an interval [a,b] *> of width less than or equal to *> *> ABSTOL + EPS * max( |a|,|b| ) , *> *> where EPS is the machine precision. If ABSTOL is less than *> or equal to zero, then EPS*|T| will be used in its place, *> where |T| is the 1-norm of the tridiagonal matrix obtained *> by reducing A to tridiagonal form. *> *> See "Computing Small Singular Values of Bidiagonal Matrices *> with Guaranteed High Relative Accuracy," by Demmel and *> Kahan, LAPACK Working Note #3. *> *> If high relative accuracy is important, set ABSTOL to *> DLAMCH( 'Safe minimum' ). Doing so will guarantee that *> eigenvalues are computed to high relative accuracy when *> possible in future releases. The current code does not *> make any guarantees about high relative accuracy, but *> future releases will. See J. Barlow and J. Demmel, *> "Computing Accurate Eigensystems of Scaled Diagonally *> Dominant Matrices", LAPACK Working Note #7, for a discussion *> of which matrices define their eigenvalues to high relative *> accuracy. *> \endverbatim *> *> \param[out] M *> \verbatim *> M is INTEGER *> The total number of eigenvalues found. 0 <= M <= N. *> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. *> \endverbatim *> *> \param[out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> The first M elements contain the selected eigenvalues in *> ascending order. *> \endverbatim *> *> \param[out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M) ) *> If JOBZ = 'V', then if INFO = 0, the first M columns of Z *> contain the orthonormal eigenvectors of the matrix A *> corresponding to the selected eigenvalues, with the i-th *> column of Z holding the eigenvector associated with W(i). *> Note: the user must ensure that at least max(1,M) columns are *> supplied in the array Z; if RANGE = 'V', the exact value of M *> is not known in advance and an upper bound must be used. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1, and if *> JOBZ = 'V', LDZ >= max(1,N). *> \endverbatim *> *> \param[out] ISUPPZ *> \verbatim *> ISUPPZ is INTEGER array, dimension ( 2*max(1,M) ) *> The support of the eigenvectors in Z, i.e., the indices *> indicating the nonzero elements in Z. The i-th eigenvector *> is nonzero only in elements ISUPPZ( 2*i-1 ) through *> ISUPPZ( 2*i ). *> Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal (and *> minimal) LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= max(1,20*N). *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal sizes of the WORK and IWORK *> arrays, returns these values as the first entries of the WORK *> and IWORK arrays, and no error message related to LWORK or *> LIWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) *> On exit, if INFO = 0, IWORK(1) returns the optimal (and *> minimal) LIWORK. *> \endverbatim *> *> \param[in] LIWORK *> \verbatim *> LIWORK is INTEGER *> The dimension of the array IWORK. LIWORK >= max(1,10*N). *> *> If LIWORK = -1, then a workspace query is assumed; the *> routine only calculates the optimal sizes of the WORK and *> IWORK arrays, returns these values as the first entries of *> the WORK and IWORK arrays, and no error message related to *> LWORK or LIWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: Internal error *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleOTHEReigen * *> \par Contributors: * ================== *> *> Inderjit Dhillon, IBM Almaden, USA \n *> Osni Marques, LBNL/NERSC, USA \n *> Ken Stanley, Computer Science Division, University of *> California at Berkeley, USA \n *> * ===================================================================== SUBROUTINE DSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, $ M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, $ LIWORK, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE INTEGER IL, INFO, IU, LDZ, LIWORK, LWORK, M, N DOUBLE PRECISION ABSTOL, VL, VU * .. * .. Array Arguments .. INTEGER ISUPPZ( * ), IWORK( * ) DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) * .. * .. Local Scalars .. LOGICAL ALLEIG, INDEIG, TEST, LQUERY, VALEIG, WANTZ, $ TRYRAC CHARACTER ORDER INTEGER I, IEEEOK, IMAX, INDIBL, INDIFL, INDISP, $ INDIWO, ISCALE, ITMP1, J, JJ, LIWMIN, LWMIN, $ NSPLIT DOUBLE PRECISION BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM, $ TMP1, TNRM, VLL, VUU * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANST EXTERNAL LSAME, ILAENV, DLAMCH, DLANST * .. * .. External Subroutines .. EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTEMR, DSTEIN, DSTERF, $ DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT * .. * .. Executable Statements .. * * * Test the input parameters. * IEEEOK = ILAENV( 10, 'DSTEVR', 'N', 1, 2, 3, 4 ) * WANTZ = LSAME( JOBZ, 'V' ) ALLEIG = LSAME( RANGE, 'A' ) VALEIG = LSAME( RANGE, 'V' ) INDEIG = LSAME( RANGE, 'I' ) * LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LIWORK.EQ.-1 ) ) LWMIN = MAX( 1, 20*N ) LIWMIN = MAX( 1, 10*N ) * * INFO = 0 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( VALEIG ) THEN IF( N.GT.0 .AND. VU.LE.VL ) $ INFO = -7 ELSE IF( INDEIG ) THEN IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN INFO = -9 END IF END IF END IF IF( INFO.EQ.0 ) THEN IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN INFO = -14 END IF END IF * IF( INFO.EQ.0 ) THEN WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN * IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN INFO = -17 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN INFO = -19 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSTEVR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * M = 0 IF( N.EQ.0 ) $ RETURN * IF( N.EQ.1 ) THEN IF( ALLEIG .OR. INDEIG ) THEN M = 1 W( 1 ) = D( 1 ) ELSE IF( VL.LT.D( 1 ) .AND. VU.GE.D( 1 ) ) THEN M = 1 W( 1 ) = D( 1 ) END IF END IF IF( WANTZ ) $ Z( 1, 1 ) = ONE RETURN END IF * * Get machine constants. * SAFMIN = DLAMCH( 'Safe minimum' ) EPS = DLAMCH( 'Precision' ) SMLNUM = SAFMIN / EPS BIGNUM = ONE / SMLNUM RMIN = SQRT( SMLNUM ) RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) * * * Scale matrix to allowable range, if necessary. * ISCALE = 0 IF( VALEIG ) THEN VLL = VL VUU = VU END IF * TNRM = DLANST( 'M', N, D, E ) IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN ISCALE = 1 SIGMA = RMIN / TNRM ELSE IF( TNRM.GT.RMAX ) THEN ISCALE = 1 SIGMA = RMAX / TNRM END IF IF( ISCALE.EQ.1 ) THEN CALL DSCAL( N, SIGMA, D, 1 ) CALL DSCAL( N-1, SIGMA, E( 1 ), 1 ) IF( VALEIG ) THEN VLL = VL*SIGMA VUU = VU*SIGMA END IF END IF * Initialize indices into workspaces. Note: These indices are used only * if DSTERF or DSTEMR fail. * IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in DSTEBZ and * stores the block indices of each of the M<=N eigenvalues. INDIBL = 1 * IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in DSTEBZ and * stores the starting and finishing indices of each block. INDISP = INDIBL + N * IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors * that corresponding to eigenvectors that fail to converge in * DSTEIN. This information is discarded; if any fail, the driver * returns INFO > 0. INDIFL = INDISP + N * INDIWO is the offset of the remaining integer workspace. INDIWO = INDISP + N * * If all eigenvalues are desired, then * call DSTERF or DSTEMR. If this fails for some eigenvalue, then * try DSTEBZ. * * TEST = .FALSE. IF( INDEIG ) THEN IF( IL.EQ.1 .AND. IU.EQ.N ) THEN TEST = .TRUE. END IF END IF IF( ( ALLEIG .OR. TEST ) .AND. IEEEOK.EQ.1 ) THEN CALL DCOPY( N-1, E( 1 ), 1, WORK( 1 ), 1 ) IF( .NOT.WANTZ ) THEN CALL DCOPY( N, D, 1, W, 1 ) CALL DSTERF( N, W, WORK, INFO ) ELSE CALL DCOPY( N, D, 1, WORK( N+1 ), 1 ) IF (ABSTOL .LE. TWO*N*EPS) THEN TRYRAC = .TRUE. ELSE TRYRAC = .FALSE. END IF CALL DSTEMR( JOBZ, 'A', N, WORK( N+1 ), WORK, VL, VU, IL, $ IU, M, W, Z, LDZ, N, ISUPPZ, TRYRAC, $ WORK( 2*N+1 ), LWORK-2*N, IWORK, LIWORK, INFO ) * END IF IF( INFO.EQ.0 ) THEN M = N GO TO 10 END IF INFO = 0 END IF * * Otherwise, call DSTEBZ and, if eigenvectors are desired, DSTEIN. * IF( WANTZ ) THEN ORDER = 'B' ELSE ORDER = 'E' END IF CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTOL, D, E, M, $ NSPLIT, W, IWORK( INDIBL ), IWORK( INDISP ), WORK, $ IWORK( INDIWO ), INFO ) * IF( WANTZ ) THEN CALL DSTEIN( N, D, E, M, W, IWORK( INDIBL ), IWORK( INDISP ), $ Z, LDZ, WORK, IWORK( INDIWO ), IWORK( INDIFL ), $ INFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * 10 CONTINUE IF( ISCALE.EQ.1 ) THEN IF( INFO.EQ.0 ) THEN IMAX = M ELSE IMAX = INFO - 1 END IF CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) END IF * * If eigenvalues are not in order, then sort them, along with * eigenvectors. * IF( WANTZ ) THEN DO 30 J = 1, M - 1 I = 0 TMP1 = W( J ) DO 20 JJ = J + 1, M IF( W( JJ ).LT.TMP1 ) THEN I = JJ TMP1 = W( JJ ) END IF 20 CONTINUE * IF( I.NE.0 ) THEN ITMP1 = IWORK( I ) W( I ) = W( J ) IWORK( I ) = IWORK( J ) W( J ) = TMP1 IWORK( J ) = ITMP1 CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) END IF 30 CONTINUE END IF * * Causes problems with tests 19 & 20: * IF (wantz .and. INDEIG ) Z( 1,1) = Z(1,1) / 1.002 + .002 * * WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN RETURN * * End of DSTEVR * END *> \brief DSTEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSTEVX + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, * M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE * INTEGER IL, INFO, IU, LDZ, M, N * DOUBLE PRECISION ABSTOL, VL, VU * .. * .. Array Arguments .. * INTEGER IFAIL( * ), IWORK( * ) * DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSTEVX computes selected eigenvalues and, optionally, eigenvectors *> of a real symmetric tridiagonal matrix A. Eigenvalues and *> eigenvectors can be selected by specifying either a range of values *> or a range of indices for the desired eigenvalues. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBZ *> \verbatim *> JOBZ is CHARACTER*1 *> = 'N': Compute eigenvalues only; *> = 'V': Compute eigenvalues and eigenvectors. *> \endverbatim *> *> \param[in] RANGE *> \verbatim *> RANGE is CHARACTER*1 *> = 'A': all eigenvalues will be found. *> = 'V': all eigenvalues in the half-open interval (VL,VU] *> will be found. *> = 'I': the IL-th through IU-th eigenvalues will be found. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix. N >= 0. *> \endverbatim *> *> \param[in,out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> On entry, the n diagonal elements of the tridiagonal matrix *> A. *> On exit, D may be multiplied by a constant factor chosen *> to avoid over/underflow in computing the eigenvalues. *> \endverbatim *> *> \param[in,out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (max(1,N-1)) *> On entry, the (n-1) subdiagonal elements of the tridiagonal *> matrix A in elements 1 to N-1 of E. *> On exit, E may be multiplied by a constant factor chosen *> to avoid over/underflow in computing the eigenvalues. *> \endverbatim *> *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION *> If RANGE='V', the lower bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION *> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] IL *> \verbatim *> IL is INTEGER *> If RANGE='I', the index of the *> smallest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> If RANGE='I', the index of the *> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] ABSTOL *> \verbatim *> ABSTOL is DOUBLE PRECISION *> The absolute error tolerance for the eigenvalues. *> An approximate eigenvalue is accepted as converged *> when it is determined to lie in an interval [a,b] *> of width less than or equal to *> *> ABSTOL + EPS * max( |a|,|b| ) , *> *> where EPS is the machine precision. If ABSTOL is less *> than or equal to zero, then EPS*|T| will be used in *> its place, where |T| is the 1-norm of the tridiagonal *> matrix. *> *> Eigenvalues will be computed most accurately when ABSTOL is *> set to twice the underflow threshold 2*DLAMCH('S'), not zero. *> If this routine returns with INFO>0, indicating that some *> eigenvectors did not converge, try setting ABSTOL to *> 2*DLAMCH('S'). *> *> See "Computing Small Singular Values of Bidiagonal Matrices *> with Guaranteed High Relative Accuracy," by Demmel and *> Kahan, LAPACK Working Note #3. *> \endverbatim *> *> \param[out] M *> \verbatim *> M is INTEGER *> The total number of eigenvalues found. 0 <= M <= N. *> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. *> \endverbatim *> *> \param[out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> The first M elements contain the selected eigenvalues in *> ascending order. *> \endverbatim *> *> \param[out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M) ) *> If JOBZ = 'V', then if INFO = 0, the first M columns of Z *> contain the orthonormal eigenvectors of the matrix A *> corresponding to the selected eigenvalues, with the i-th *> column of Z holding the eigenvector associated with W(i). *> If an eigenvector fails to converge (INFO > 0), then that *> column of Z contains the latest approximation to the *> eigenvector, and the index of the eigenvector is returned *> in IFAIL. If JOBZ = 'N', then Z is not referenced. *> Note: the user must ensure that at least max(1,M) columns are *> supplied in the array Z; if RANGE = 'V', the exact value of M *> is not known in advance and an upper bound must be used. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1, and if *> JOBZ = 'V', LDZ >= max(1,N). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (5*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (5*N) *> \endverbatim *> *> \param[out] IFAIL *> \verbatim *> IFAIL is INTEGER array, dimension (N) *> If JOBZ = 'V', then if INFO = 0, the first M elements of *> IFAIL are zero. If INFO > 0, then IFAIL contains the *> indices of the eigenvectors that failed to converge. *> If JOBZ = 'N', then IFAIL is not referenced. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, then i eigenvectors failed to converge. *> Their indices are stored in array IFAIL. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleOTHEReigen * * ===================================================================== SUBROUTINE DSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, $ M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE INTEGER IL, INFO, IU, LDZ, M, N DOUBLE PRECISION ABSTOL, VL, VU * .. * .. Array Arguments .. INTEGER IFAIL( * ), IWORK( * ) DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL ALLEIG, INDEIG, TEST, VALEIG, WANTZ CHARACTER ORDER INTEGER I, IMAX, INDIBL, INDISP, INDIWO, INDWRK, $ ISCALE, ITMP1, J, JJ, NSPLIT DOUBLE PRECISION BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM, $ TMP1, TNRM, VLL, VUU * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANST EXTERNAL LSAME, DLAMCH, DLANST * .. * .. External Subroutines .. EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTEIN, DSTEQR, DSTERF, $ DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * WANTZ = LSAME( JOBZ, 'V' ) ALLEIG = LSAME( RANGE, 'A' ) VALEIG = LSAME( RANGE, 'V' ) INDEIG = LSAME( RANGE, 'I' ) * INFO = 0 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( VALEIG ) THEN IF( N.GT.0 .AND. VU.LE.VL ) $ INFO = -7 ELSE IF( INDEIG ) THEN IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN INFO = -9 END IF END IF END IF IF( INFO.EQ.0 ) THEN IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) $ INFO = -14 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSTEVX', -INFO ) RETURN END IF * * Quick return if possible * M = 0 IF( N.EQ.0 ) $ RETURN * IF( N.EQ.1 ) THEN IF( ALLEIG .OR. INDEIG ) THEN M = 1 W( 1 ) = D( 1 ) ELSE IF( VL.LT.D( 1 ) .AND. VU.GE.D( 1 ) ) THEN M = 1 W( 1 ) = D( 1 ) END IF END IF IF( WANTZ ) $ Z( 1, 1 ) = ONE RETURN END IF * * Get machine constants. * SAFMIN = DLAMCH( 'Safe minimum' ) EPS = DLAMCH( 'Precision' ) SMLNUM = SAFMIN / EPS BIGNUM = ONE / SMLNUM RMIN = SQRT( SMLNUM ) RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) * * Scale matrix to allowable range, if necessary. * ISCALE = 0 IF( VALEIG ) THEN VLL = VL VUU = VU ELSE VLL = ZERO VUU = ZERO END IF TNRM = DLANST( 'M', N, D, E ) IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN ISCALE = 1 SIGMA = RMIN / TNRM ELSE IF( TNRM.GT.RMAX ) THEN ISCALE = 1 SIGMA = RMAX / TNRM END IF IF( ISCALE.EQ.1 ) THEN CALL DSCAL( N, SIGMA, D, 1 ) CALL DSCAL( N-1, SIGMA, E( 1 ), 1 ) IF( VALEIG ) THEN VLL = VL*SIGMA VUU = VU*SIGMA END IF END IF * * If all eigenvalues are desired and ABSTOL is less than zero, then * call DSTERF or SSTEQR. If this fails for some eigenvalue, then * try DSTEBZ. * TEST = .FALSE. IF( INDEIG ) THEN IF( IL.EQ.1 .AND. IU.EQ.N ) THEN TEST = .TRUE. END IF END IF IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN CALL DCOPY( N, D, 1, W, 1 ) CALL DCOPY( N-1, E( 1 ), 1, WORK( 1 ), 1 ) INDWRK = N + 1 IF( .NOT.WANTZ ) THEN CALL DSTERF( N, W, WORK, INFO ) ELSE CALL DSTEQR( 'I', N, W, WORK, Z, LDZ, WORK( INDWRK ), INFO ) IF( INFO.EQ.0 ) THEN DO 10 I = 1, N IFAIL( I ) = 0 10 CONTINUE END IF END IF IF( INFO.EQ.0 ) THEN M = N GO TO 20 END IF INFO = 0 END IF * * Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. * IF( WANTZ ) THEN ORDER = 'B' ELSE ORDER = 'E' END IF INDWRK = 1 INDIBL = 1 INDISP = INDIBL + N INDIWO = INDISP + N CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTOL, D, E, M, $ NSPLIT, W, IWORK( INDIBL ), IWORK( INDISP ), $ WORK( INDWRK ), IWORK( INDIWO ), INFO ) * IF( WANTZ ) THEN CALL DSTEIN( N, D, E, M, W, IWORK( INDIBL ), IWORK( INDISP ), $ Z, LDZ, WORK( INDWRK ), IWORK( INDIWO ), IFAIL, $ INFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * 20 CONTINUE IF( ISCALE.EQ.1 ) THEN IF( INFO.EQ.0 ) THEN IMAX = M ELSE IMAX = INFO - 1 END IF CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) END IF * * If eigenvalues are not in order, then sort them, along with * eigenvectors. * IF( WANTZ ) THEN DO 40 J = 1, M - 1 I = 0 TMP1 = W( J ) DO 30 JJ = J + 1, M IF( W( JJ ).LT.TMP1 ) THEN I = JJ TMP1 = W( JJ ) END IF 30 CONTINUE * IF( I.NE.0 ) THEN ITMP1 = IWORK( INDIBL+I-1 ) W( I ) = W( J ) IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) W( J ) = TMP1 IWORK( INDIBL+J-1 ) = ITMP1 CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) IF( INFO.NE.0 ) THEN ITMP1 = IFAIL( I ) IFAIL( I ) = IFAIL( J ) IFAIL( J ) = ITMP1 END IF END IF 40 CONTINUE END IF * RETURN * * End of DSTEVX * END *> \brief \b DSYCON * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSYCON + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, * IWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N * DOUBLE PRECISION ANORM, RCOND * .. * .. Array Arguments .. * INTEGER IPIV( * ), IWORK( * ) * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSYCON estimates the reciprocal of the condition number (in the *> 1-norm) of a real symmetric matrix A using the factorization *> A = U*D*U**T or A = L*D*L**T computed by DSYTRF. *> *> An estimate is obtained for norm(inv(A)), and the reciprocal of the *> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the details of the factorization are stored *> as an upper or lower triangular matrix. *> = 'U': Upper triangular, form is A = U*D*U**T; *> = 'L': Lower triangular, form is A = L*D*L**T. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The block diagonal matrix D and the multipliers used to *> obtain the factor U or L as computed by DSYTRF. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N) *> Details of the interchanges and the block structure of D *> as determined by DSYTRF. *> \endverbatim *> *> \param[in] ANORM *> \verbatim *> ANORM is DOUBLE PRECISION *> The 1-norm of the original matrix A. *> \endverbatim *> *> \param[out] RCOND *> \verbatim *> RCOND is 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. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (2*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleSYcomputational * * ===================================================================== SUBROUTINE DSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, $ IWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, N DOUBLE PRECISION ANORM, RCOND * .. * .. Array Arguments .. INTEGER IPIV( * ), IWORK( * ) DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER I, KASE DOUBLE PRECISION AINVNM * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLACN2, DSYTRS, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( ANORM.LT.ZERO ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYCON', -INFO ) RETURN END IF * * Quick return if possible * RCOND = ZERO IF( N.EQ.0 ) THEN RCOND = ONE RETURN ELSE IF( ANORM.LE.ZERO ) THEN RETURN END IF * * Check that the diagonal matrix D is nonsingular. * IF( UPPER ) THEN * * Upper triangular storage: examine D from bottom to top * DO 10 I = N, 1, -1 IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO ) $ RETURN 10 CONTINUE ELSE * * Lower triangular storage: examine D from top to bottom. * DO 20 I = 1, N IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO ) $ RETURN 20 CONTINUE END IF * * Estimate the 1-norm of the inverse. * KASE = 0 30 CONTINUE CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) IF( KASE.NE.0 ) THEN * * Multiply by inv(L*D*L**T) or inv(U*D*U**T). * CALL DSYTRS( UPLO, N, 1, A, LDA, IPIV, WORK, N, INFO ) GO TO 30 END IF * * Compute the estimate of the reciprocal condition number. * IF( AINVNM.NE.ZERO ) $ RCOND = ( ONE / AINVNM ) / ANORM * RETURN * * End of DSYCON * END *> \brief \b DSYCONV * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSYCONV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYCONV( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO, WAY * INTEGER INFO, LDA, N * .. * .. Array Arguments .. * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), E( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSYCONV convert A given by TRF into L and D and vice-versa. *> Get Non-diag elements of D (returned in workspace) and *> apply or reverse permutation done in TRF. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the details of the factorization are stored *> as an upper or lower triangular matrix. *> = 'U': Upper triangular, form is A = U*D*U**T; *> = 'L': Lower triangular, form is A = L*D*L**T. *> \endverbatim *> *> \param[in] WAY *> \verbatim *> WAY is CHARACTER*1 *> = 'C': Convert *> = 'R': Revert *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The block diagonal matrix D and the multipliers used to *> obtain the factor U or L as computed by DSYTRF. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N) *> Details of the interchanges and the block structure of D *> as determined by DSYTRF. *> \endverbatim *> *> \param[out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N) *> E stores the supdiagonal/subdiagonal of the symmetric 1-by-1 *> or 2-by-2 block diagonal matrix D in LDLT. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleSYcomputational * * ===================================================================== SUBROUTINE DSYCONV( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO, WAY INTEGER INFO, LDA, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ), E( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * * .. External Subroutines .. EXTERNAL XERBLA * .. Local Scalars .. LOGICAL UPPER, CONVERT INTEGER I, IP, J DOUBLE PRECISION TEMP * .. * .. Executable Statements .. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) CONVERT = LSAME( WAY, 'C' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.CONVERT .AND. .NOT.LSAME( WAY, 'R' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYCONV', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( UPPER ) THEN * * A is UPPER * * Convert A (A is upper) * * Convert VALUE * IF ( CONVERT ) THEN I=N E(1)=ZERO DO WHILE ( I .GT. 1 ) IF( IPIV(I) .LT. 0 ) THEN E(I)=A(I-1,I) E(I-1)=ZERO A(I-1,I)=ZERO I=I-1 ELSE E(I)=ZERO ENDIF I=I-1 END DO * * Convert PERMUTATIONS * I=N DO WHILE ( I .GE. 1 ) IF( IPIV(I) .GT. 0) THEN IP=IPIV(I) IF( I .LT. N) THEN DO 12 J= I+1,N TEMP=A(IP,J) A(IP,J)=A(I,J) A(I,J)=TEMP 12 CONTINUE ENDIF ELSE IP=-IPIV(I) IF( I .LT. N) THEN DO 13 J= I+1,N TEMP=A(IP,J) A(IP,J)=A(I-1,J) A(I-1,J)=TEMP 13 CONTINUE ENDIF I=I-1 ENDIF I=I-1 END DO ELSE * * Revert A (A is upper) * * * Revert PERMUTATIONS * I=1 DO WHILE ( I .LE. N ) IF( IPIV(I) .GT. 0 ) THEN IP=IPIV(I) IF( I .LT. N) THEN DO J= I+1,N TEMP=A(IP,J) A(IP,J)=A(I,J) A(I,J)=TEMP END DO ENDIF ELSE IP=-IPIV(I) I=I+1 IF( I .LT. N) THEN DO J= I+1,N TEMP=A(IP,J) A(IP,J)=A(I-1,J) A(I-1,J)=TEMP END DO ENDIF ENDIF I=I+1 END DO * * Revert VALUE * I=N DO WHILE ( I .GT. 1 ) IF( IPIV(I) .LT. 0 ) THEN A(I-1,I)=E(I) I=I-1 ENDIF I=I-1 END DO END IF ELSE * * A is LOWER * IF ( CONVERT ) THEN * * Convert A (A is lower) * * * Convert VALUE * I=1 E(N)=ZERO DO WHILE ( I .LE. N ) IF( I.LT.N .AND. IPIV(I) .LT. 0 ) THEN E(I)=A(I+1,I) E(I+1)=ZERO A(I+1,I)=ZERO I=I+1 ELSE E(I)=ZERO ENDIF I=I+1 END DO * * Convert PERMUTATIONS * I=1 DO WHILE ( I .LE. N ) IF( IPIV(I) .GT. 0 ) THEN IP=IPIV(I) IF (I .GT. 1) THEN DO 22 J= 1,I-1 TEMP=A(IP,J) A(IP,J)=A(I,J) A(I,J)=TEMP 22 CONTINUE ENDIF ELSE IP=-IPIV(I) IF (I .GT. 1) THEN DO 23 J= 1,I-1 TEMP=A(IP,J) A(IP,J)=A(I+1,J) A(I+1,J)=TEMP 23 CONTINUE ENDIF I=I+1 ENDIF I=I+1 END DO ELSE * * Revert A (A is lower) * * * Revert PERMUTATIONS * I=N DO WHILE ( I .GE. 1 ) IF( IPIV(I) .GT. 0 ) THEN IP=IPIV(I) IF (I .GT. 1) THEN DO J= 1,I-1 TEMP=A(I,J) A(I,J)=A(IP,J) A(IP,J)=TEMP END DO ENDIF ELSE IP=-IPIV(I) I=I-1 IF (I .GT. 1) THEN DO J= 1,I-1 TEMP=A(I+1,J) A(I+1,J)=A(IP,J) A(IP,J)=TEMP END DO ENDIF ENDIF I=I-1 END DO * * Revert VALUE * I=1 DO WHILE ( I .LE. N-1 ) IF( IPIV(I) .LT. 0 ) THEN A(I+1,I)=E(I) I=I+1 ENDIF I=I+1 END DO END IF END IF RETURN * * End of DSYCONV * END *> \brief \b DSYEQUB * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSYEQUB + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, N * DOUBLE PRECISION AMAX, SCOND * CHARACTER UPLO * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), S( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSYEQUB computes row and column scalings intended to equilibrate a *> symmetric matrix A (with respect to the Euclidean norm) and reduce *> its condition number. The scale factors S are computed by the BIN *> algorithm (see references) so that the scaled matrix B with elements *> B(i,j) = S(i)*A(i,j)*S(j) has a condition number within a factor N of *> the smallest possible condition number over all possible diagonal *> scalings. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The N-by-N symmetric matrix whose scaling factors are to be *> computed. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] S *> \verbatim *> S is DOUBLE PRECISION array, dimension (N) *> If INFO = 0, S contains the scale factors for A. *> \endverbatim *> *> \param[out] SCOND *> \verbatim *> SCOND is DOUBLE PRECISION *> If INFO = 0, S contains the ratio of the smallest S(i) to *> the largest S(i). If SCOND >= 0.1 and AMAX is neither too *> large nor too small, it is not worth scaling by S. *> \endverbatim *> *> \param[out] AMAX *> \verbatim *> AMAX is DOUBLE PRECISION *> Largest absolute value of any matrix element. If AMAX is *> very close to overflow or very close to underflow, the *> matrix should be scaled. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (2*N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, the i-th diagonal element is nonpositive. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date November 2017 * *> \ingroup doubleSYcomputational * *> \par References: * ================ *> *> Livne, O.E. and Golub, G.H., "Scaling by Binormalization", \n *> Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004. \n *> DOI 10.1023/B:NUMA.0000016606.32820.69 \n *> Tech report version: http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.3.1679 *> * ===================================================================== SUBROUTINE DSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) * * -- LAPACK computational routine (version 3.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. Scalar Arguments .. INTEGER INFO, LDA, N DOUBLE PRECISION AMAX, SCOND CHARACTER UPLO * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), S( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) INTEGER MAX_ITER PARAMETER ( MAX_ITER = 100 ) * .. * .. Local Scalars .. INTEGER I, J, ITER DOUBLE PRECISION AVG, STD, TOL, C0, C1, C2, T, U, SI, D, BASE, $ SMIN, SMAX, SMLNUM, BIGNUM, SCALE, SUMSQ LOGICAL UP * .. * .. External Functions .. DOUBLE PRECISION DLAMCH LOGICAL LSAME EXTERNAL DLAMCH, LSAME * .. * .. External Subroutines .. EXTERNAL DLASSQ, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( .NOT. ( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) ) THEN INFO = -1 ELSE IF ( N .LT. 0 ) THEN INFO = -2 ELSE IF ( LDA .LT. MAX( 1, N ) ) THEN INFO = -4 END IF IF ( INFO .NE. 0 ) THEN CALL XERBLA( 'DSYEQUB', -INFO ) RETURN END IF UP = LSAME( UPLO, 'U' ) AMAX = ZERO * * Quick return if possible. * IF ( N .EQ. 0 ) THEN SCOND = ONE RETURN END IF DO I = 1, N S( I ) = ZERO END DO AMAX = ZERO IF ( UP ) THEN DO J = 1, N DO I = 1, J-1 S( I ) = MAX( S( I ), ABS( A( I, J ) ) ) S( J ) = MAX( S( J ), ABS( A( I, J ) ) ) AMAX = MAX( AMAX, ABS( A( I, J ) ) ) END DO S( J ) = MAX( S( J ), ABS( A( J, J ) ) ) AMAX = MAX( AMAX, ABS( A( J, J ) ) ) END DO ELSE DO J = 1, N S( J ) = MAX( S( J ), ABS( A( J, J ) ) ) AMAX = MAX( AMAX, ABS( A( J, J ) ) ) DO I = J+1, N S( I ) = MAX( S( I ), ABS( A( I, J ) ) ) S( J ) = MAX( S( J ), ABS( A( I, J ) ) ) AMAX = MAX( AMAX, ABS( A( I, J ) ) ) END DO END DO END IF DO J = 1, N S( J ) = 1.0D0 / S( J ) END DO TOL = ONE / SQRT( 2.0D0 * N ) DO ITER = 1, MAX_ITER SCALE = 0.0D0 SUMSQ = 0.0D0 * beta = |A|s DO I = 1, N WORK( I ) = ZERO END DO IF ( UP ) THEN DO J = 1, N DO I = 1, J-1 WORK( I ) = WORK( I ) + ABS( A( I, J ) ) * S( J ) WORK( J ) = WORK( J ) + ABS( A( I, J ) ) * S( I ) END DO WORK( J ) = WORK( J ) + ABS( A( J, J ) ) * S( J ) END DO ELSE DO J = 1, N WORK( J ) = WORK( J ) + ABS( A( J, J ) ) * S( J ) DO I = J+1, N WORK( I ) = WORK( I ) + ABS( A( I, J ) ) * S( J ) WORK( J ) = WORK( J ) + ABS( A( I, J ) ) * S( I ) END DO END DO END IF * avg = s^T beta / n AVG = 0.0D0 DO I = 1, N AVG = AVG + S( I )*WORK( I ) END DO AVG = AVG / N STD = 0.0D0 DO I = N+1, 2*N WORK( I ) = S( I-N ) * WORK( I-N ) - AVG END DO CALL DLASSQ( N, WORK( N+1 ), 1, SCALE, SUMSQ ) STD = SCALE * SQRT( SUMSQ / N ) IF ( STD .LT. TOL * AVG ) GOTO 999 DO I = 1, N T = ABS( A( I, I ) ) SI = S( I ) C2 = ( N-1 ) * T C1 = ( N-2 ) * ( WORK( I ) - T*SI ) C0 = -(T*SI)*SI + 2*WORK( I )*SI - N*AVG D = C1*C1 - 4*C0*C2 IF ( D .LE. 0 ) THEN INFO = -1 RETURN END IF SI = -2*C0 / ( C1 + SQRT( D ) ) D = SI - S( I ) U = ZERO IF ( UP ) THEN DO J = 1, I T = ABS( A( J, I ) ) U = U + S( J )*T WORK( J ) = WORK( J ) + D*T END DO DO J = I+1,N T = ABS( A( I, J ) ) U = U + S( J )*T WORK( J ) = WORK( J ) + D*T END DO ELSE DO J = 1, I T = ABS( A( I, J ) ) U = U + S( J )*T WORK( J ) = WORK( J ) + D*T END DO DO J = I+1,N T = ABS( A( J, I ) ) U = U + S( J )*T WORK( J ) = WORK( J ) + D*T END DO END IF AVG = AVG + ( U + WORK( I ) ) * D / N S( I ) = SI END DO END DO 999 CONTINUE SMLNUM = DLAMCH( 'SAFEMIN' ) BIGNUM = ONE / SMLNUM SMIN = BIGNUM SMAX = ZERO T = ONE / SQRT( AVG ) BASE = DLAMCH( 'B' ) U = ONE / LOG( BASE ) DO I = 1, N S( I ) = BASE ** INT( U * LOG( S( I ) * T ) ) SMIN = MIN( SMIN, S( I ) ) SMAX = MAX( SMAX, S( I ) ) END DO SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM ) * END *> \brief DSYEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSYEV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, LDA, LWORK, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSYEV computes all eigenvalues and, optionally, eigenvectors of a *> real symmetric matrix A. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBZ *> \verbatim *> JOBZ is CHARACTER*1 *> = 'N': Compute eigenvalues only; *> = 'V': Compute eigenvalues and eigenvectors. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA, N) *> On entry, the symmetric matrix A. If UPLO = 'U', the *> leading N-by-N upper triangular part of A contains the *> upper triangular part of the matrix A. If UPLO = 'L', *> the leading N-by-N lower triangular part of A contains *> the lower triangular part of the matrix A. *> On exit, if JOBZ = 'V', then if INFO = 0, A contains the *> orthonormal eigenvectors of the matrix A. *> If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') *> or the upper triangle (if UPLO='U') of A, including the *> diagonal, is destroyed. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> If INFO = 0, the eigenvalues in ascending order. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The length of the array WORK. LWORK >= max(1,3*N-1). *> For optimal efficiency, LWORK >= (NB+2)*N, *> where NB is the blocksize for DSYTRD 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, the algorithm failed to converge; i *> off-diagonal elements of an intermediate tridiagonal *> form did not converge to zero. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleSYeigen * * ===================================================================== SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO INTEGER INFO, LDA, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL LOWER, LQUERY, WANTZ INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, $ LLWORK, LWKOPT, NB DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, $ SMLNUM * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANSY EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY * .. * .. External Subroutines .. EXTERNAL DLASCL, DORGTR, DSCAL, DSTEQR, DSTERF, DSYTRD, $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * WANTZ = LSAME( JOBZ, 'V' ) LOWER = LSAME( UPLO, 'L' ) LQUERY = ( LWORK.EQ.-1 ) * INFO = 0 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 END IF * IF( INFO.EQ.0 ) THEN NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) LWKOPT = MAX( 1, ( NB+2 )*N ) WORK( 1 ) = LWKOPT * IF( LWORK.LT.MAX( 1, 3*N-1 ) .AND. .NOT.LQUERY ) $ INFO = -8 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYEV ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN RETURN END IF * IF( N.EQ.1 ) THEN W( 1 ) = A( 1, 1 ) WORK( 1 ) = 2 IF( WANTZ ) $ A( 1, 1 ) = ONE RETURN END IF * * Get machine constants. * SAFMIN = DLAMCH( 'Safe minimum' ) EPS = DLAMCH( 'Precision' ) SMLNUM = SAFMIN / EPS BIGNUM = ONE / SMLNUM RMIN = SQRT( SMLNUM ) RMAX = SQRT( BIGNUM ) * * Scale matrix to allowable range, if necessary. * ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) ISCALE = 0 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN ISCALE = 1 SIGMA = RMAX / ANRM END IF IF( ISCALE.EQ.1 ) $ CALL DLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) * * Call DSYTRD to reduce symmetric matrix to tridiagonal form. * INDE = 1 INDTAU = INDE + N INDWRK = INDTAU + N LLWORK = LWORK - INDWRK + 1 CALL DSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ), $ WORK( INDWRK ), LLWORK, IINFO ) * * For eigenvalues only, call DSTERF. For eigenvectors, first call * DORGTR to generate the orthogonal matrix, then call DSTEQR. * IF( .NOT.WANTZ ) THEN CALL DSTERF( N, W, WORK( INDE ), INFO ) ELSE CALL DORGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ), $ LLWORK, IINFO ) CALL DSTEQR( JOBZ, N, W, WORK( INDE ), A, LDA, WORK( INDTAU ), $ INFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * IF( ISCALE.EQ.1 ) THEN IF( INFO.EQ.0 ) THEN IMAX = N ELSE IMAX = INFO - 1 END IF CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) END IF * * Set WORK(1) to optimal workspace size. * WORK( 1 ) = LWKOPT * RETURN * * End of DSYEV * END *> \brief DSYEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSYEVD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, * LIWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, LDA, LIWORK, LWORK, N * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSYEVD computes all eigenvalues and, optionally, eigenvectors of a *> real symmetric matrix A. If eigenvectors are desired, it uses a *> divide and conquer algorithm. *> *> The divide and conquer algorithm makes very mild assumptions about *> floating point arithmetic. It will work on machines with a guard *> digit in add/subtract, or on those binary machines without guard *> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or *> Cray-2. It could conceivably fail on hexadecimal or decimal machines *> without guard digits, but we know of none. *> *> Because of large use of BLAS of level 3, DSYEVD needs N**2 more *> workspace than DSYEVX. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBZ *> \verbatim *> JOBZ is CHARACTER*1 *> = 'N': Compute eigenvalues only; *> = 'V': Compute eigenvalues and eigenvectors. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA, N) *> On entry, the symmetric matrix A. If UPLO = 'U', the *> leading N-by-N upper triangular part of A contains the *> upper triangular part of the matrix A. If UPLO = 'L', *> the leading N-by-N lower triangular part of A contains *> the lower triangular part of the matrix A. *> On exit, if JOBZ = 'V', then if INFO = 0, A contains the *> orthonormal eigenvectors of the matrix A. *> If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') *> or the upper triangle (if UPLO='U') of A, including the *> diagonal, is destroyed. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> If INFO = 0, the eigenvalues in ascending order. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, *> dimension (LWORK) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. *> If N <= 1, LWORK must be at least 1. *> If JOBZ = 'N' and N > 1, LWORK must be at least 2*N+1. *> If JOBZ = 'V' and N > 1, LWORK must be at least *> 1 + 6*N + 2*N**2. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal sizes of the WORK and IWORK *> arrays, returns these values as the first entries of the WORK *> and IWORK arrays, and no error message related to LWORK or *> LIWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) *> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. *> \endverbatim *> *> \param[in] LIWORK *> \verbatim *> LIWORK is INTEGER *> The dimension of the array IWORK. *> If N <= 1, LIWORK must be at least 1. *> If JOBZ = 'N' and N > 1, LIWORK must be at least 1. *> If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. *> *> If LIWORK = -1, then a workspace query is assumed; the *> routine only calculates the optimal sizes of the WORK and *> IWORK arrays, returns these values as the first entries of *> the WORK and IWORK arrays, and no error message related to *> LWORK or LIWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i and JOBZ = 'N', then the algorithm failed *> to converge; i off-diagonal elements of an intermediate *> tridiagonal form did not converge to zero; *> if INFO = i and JOBZ = 'V', then the algorithm failed *> to compute an eigenvalue while working on the submatrix *> lying in rows and columns INFO/(N+1) through *> mod(INFO,N+1). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleSYeigen * *> \par Contributors: * ================== *> *> Jeff Rutter, Computer Science Division, University of California *> at Berkeley, USA \n *> Modified by Francoise Tisseur, University of Tennessee \n *> Modified description of INFO. Sven, 16 Feb 05. \n *> * ===================================================================== SUBROUTINE DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, $ LIWORK, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO INTEGER INFO, LDA, LIWORK, LWORK, N * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. * LOGICAL LOWER, LQUERY, WANTZ INTEGER IINFO, INDE, INDTAU, INDWK2, INDWRK, ISCALE, $ LIOPT, LIWMIN, LLWORK, LLWRK2, LOPT, LWMIN DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, $ SMLNUM * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANSY EXTERNAL LSAME, DLAMCH, DLANSY, ILAENV * .. * .. External Subroutines .. EXTERNAL DLACPY, DLASCL, DORMTR, DSCAL, DSTEDC, DSTERF, $ DSYTRD, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * WANTZ = LSAME( JOBZ, 'V' ) LOWER = LSAME( UPLO, 'L' ) LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) * INFO = 0 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 END IF * IF( INFO.EQ.0 ) THEN IF( N.LE.1 ) THEN LIWMIN = 1 LWMIN = 1 LOPT = LWMIN LIOPT = LIWMIN ELSE IF( WANTZ ) THEN LIWMIN = 3 + 5*N LWMIN = 1 + 6*N + 2*N**2 ELSE LIWMIN = 1 LWMIN = 2*N + 1 END IF LOPT = MAX( LWMIN, 2*N + $ ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) ) LIOPT = LIWMIN END IF WORK( 1 ) = LOPT IWORK( 1 ) = LIOPT * IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN INFO = -8 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN INFO = -10 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYEVD', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( N.EQ.1 ) THEN W( 1 ) = A( 1, 1 ) IF( WANTZ ) $ A( 1, 1 ) = ONE RETURN END IF * * Get machine constants. * SAFMIN = DLAMCH( 'Safe minimum' ) EPS = DLAMCH( 'Precision' ) SMLNUM = SAFMIN / EPS BIGNUM = ONE / SMLNUM RMIN = SQRT( SMLNUM ) RMAX = SQRT( BIGNUM ) * * Scale matrix to allowable range, if necessary. * ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) ISCALE = 0 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN ISCALE = 1 SIGMA = RMAX / ANRM END IF IF( ISCALE.EQ.1 ) $ CALL DLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) * * Call DSYTRD to reduce symmetric matrix to tridiagonal form. * INDE = 1 INDTAU = INDE + N INDWRK = INDTAU + N LLWORK = LWORK - INDWRK + 1 INDWK2 = INDWRK + N*N LLWRK2 = LWORK - INDWK2 + 1 * CALL DSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ), $ WORK( INDWRK ), LLWORK, IINFO ) * * For eigenvalues only, call DSTERF. For eigenvectors, first call * DSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the * tridiagonal matrix, then call DORMTR to multiply it by the * Householder transformations stored in A. * IF( .NOT.WANTZ ) THEN CALL DSTERF( N, W, WORK( INDE ), INFO ) ELSE CALL DSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N, $ WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO ) CALL DORMTR( 'L', UPLO, 'N', N, N, A, LDA, WORK( INDTAU ), $ WORK( INDWRK ), N, WORK( INDWK2 ), LLWRK2, IINFO ) CALL DLACPY( 'A', N, N, WORK( INDWRK ), N, A, LDA ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * IF( ISCALE.EQ.1 ) $ CALL DSCAL( N, ONE / SIGMA, W, 1 ) * WORK( 1 ) = LOPT IWORK( 1 ) = LIOPT * RETURN * * End of DSYEVD * END *> \brief DSYEVR computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSYEVR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, * ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, * IWORK, LIWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LWORK, M, N * DOUBLE PRECISION ABSTOL, VL, VU * .. * .. Array Arguments .. * INTEGER ISUPPZ( * ), IWORK( * ) * DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSYEVR computes selected eigenvalues and, optionally, eigenvectors *> of a real symmetric matrix A. Eigenvalues and eigenvectors can be *> selected by specifying either a range of values or a range of *> indices for the desired eigenvalues. *> *> DSYEVR first reduces the matrix A to tridiagonal form T with a call *> to DSYTRD. Then, whenever possible, DSYEVR calls DSTEMR to compute *> the eigenspectrum using Relatively Robust Representations. DSTEMR *> computes eigenvalues by the dqds algorithm, while orthogonal *> eigenvectors are computed from various "good" L D L^T representations *> (also known as Relatively Robust Representations). Gram-Schmidt *> orthogonalization is avoided as far as possible. More specifically, *> the various steps of the algorithm are as follows. *> *> For each unreduced block (submatrix) of T, *> (a) Compute T - sigma I = L D L^T, so that L and D *> define all the wanted eigenvalues to high relative accuracy. *> This means that small relative changes in the entries of D and L *> cause only small relative changes in the eigenvalues and *> eigenvectors. The standard (unfactored) representation of the *> tridiagonal matrix T does not have this property in general. *> (b) Compute the eigenvalues to suitable accuracy. *> If the eigenvectors are desired, the algorithm attains full *> accuracy of the computed eigenvalues only right before *> the corresponding vectors have to be computed, see steps c) and d). *> (c) For each cluster of close eigenvalues, select a new *> shift close to the cluster, find a new factorization, and refine *> the shifted eigenvalues to suitable accuracy. *> (d) For each eigenvalue with a large enough relative separation compute *> the corresponding eigenvector by forming a rank revealing twisted *> factorization. Go back to (c) for any clusters that remain. *> *> The desired accuracy of the output can be specified by the input *> parameter ABSTOL. *> *> For more details, see DSTEMR's documentation and: *> - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations *> to compute orthogonal eigenvectors of symmetric tridiagonal matrices," *> Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. *> - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and *> Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, *> 2004. Also LAPACK Working Note 154. *> - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric *> tridiagonal eigenvalue/eigenvector problem", *> Computer Science Division Technical Report No. UCB/CSD-97-971, *> UC Berkeley, May 1997. *> *> *> Note 1 : DSYEVR calls DSTEMR when the full spectrum is requested *> on machines which conform to the ieee-754 floating point standard. *> DSYEVR calls DSTEBZ and DSTEIN on non-ieee machines and *> when partial spectrum requests are made. *> *> Normal execution of DSTEMR may create NaNs and infinities and *> hence may abort due to a floating point exception in environments *> which do not handle NaNs and infinities in the ieee standard default *> manner. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBZ *> \verbatim *> JOBZ is CHARACTER*1 *> = 'N': Compute eigenvalues only; *> = 'V': Compute eigenvalues and eigenvectors. *> \endverbatim *> *> \param[in] RANGE *> \verbatim *> RANGE is CHARACTER*1 *> = 'A': all eigenvalues will be found. *> = 'V': all eigenvalues in the half-open interval (VL,VU] *> will be found. *> = 'I': the IL-th through IU-th eigenvalues will be found. *> For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and *> DSTEIN are called *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA, N) *> On entry, the symmetric matrix A. If UPLO = 'U', the *> leading N-by-N upper triangular part of A contains the *> upper triangular part of the matrix A. If UPLO = 'L', *> the leading N-by-N lower triangular part of A contains *> the lower triangular part of the matrix A. *> On exit, the lower triangle (if UPLO='L') or the upper *> triangle (if UPLO='U') of A, including the diagonal, is *> destroyed. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION *> If RANGE='V', the lower bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION *> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] IL *> \verbatim *> IL is INTEGER *> If RANGE='I', the index of the *> smallest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> If RANGE='I', the index of the *> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] ABSTOL *> \verbatim *> ABSTOL is DOUBLE PRECISION *> The absolute error tolerance for the eigenvalues. *> An approximate eigenvalue is accepted as converged *> when it is determined to lie in an interval [a,b] *> of width less than or equal to *> *> ABSTOL + EPS * max( |a|,|b| ) , *> *> where EPS is the machine precision. If ABSTOL is less than *> or equal to zero, then EPS*|T| will be used in its place, *> where |T| is the 1-norm of the tridiagonal matrix obtained *> by reducing A to tridiagonal form. *> *> See "Computing Small Singular Values of Bidiagonal Matrices *> with Guaranteed High Relative Accuracy," by Demmel and *> Kahan, LAPACK Working Note #3. *> *> If high relative accuracy is important, set ABSTOL to *> DLAMCH( 'Safe minimum' ). Doing so will guarantee that *> eigenvalues are computed to high relative accuracy when *> possible in future releases. The current code does not *> make any guarantees about high relative accuracy, but *> future releases will. See J. Barlow and J. Demmel, *> "Computing Accurate Eigensystems of Scaled Diagonally *> Dominant Matrices", LAPACK Working Note #7, for a discussion *> of which matrices define their eigenvalues to high relative *> accuracy. *> \endverbatim *> *> \param[out] M *> \verbatim *> M is INTEGER *> The total number of eigenvalues found. 0 <= M <= N. *> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. *> \endverbatim *> *> \param[out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> The first M elements contain the selected eigenvalues in *> ascending order. *> \endverbatim *> *> \param[out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M)) *> If JOBZ = 'V', then if INFO = 0, the first M columns of Z *> contain the orthonormal eigenvectors of the matrix A *> corresponding to the selected eigenvalues, with the i-th *> column of Z holding the eigenvector associated with W(i). *> If JOBZ = 'N', then Z is not referenced. *> Note: the user must ensure that at least max(1,M) columns are *> supplied in the array Z; if RANGE = 'V', the exact value of M *> is not known in advance and an upper bound must be used. *> Supplying N columns is always safe. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1, and if *> JOBZ = 'V', LDZ >= max(1,N). *> \endverbatim *> *> \param[out] ISUPPZ *> \verbatim *> ISUPPZ is INTEGER array, dimension ( 2*max(1,M) ) *> The support of the eigenvectors in Z, i.e., the indices *> indicating the nonzero elements in Z. The i-th eigenvector *> is nonzero only in elements ISUPPZ( 2*i-1 ) through *> ISUPPZ( 2*i ). This is an output of DSTEMR (tridiagonal *> matrix). The support of the eigenvectors of A is typically *> 1:N because of the orthogonal transformations applied by DORMTR. *> Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= max(1,26*N). *> For optimal efficiency, LWORK >= (NB+6)*N, *> where NB is the max of the blocksize for DSYTRD and DORMTR *> 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. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) *> On exit, if INFO = 0, IWORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LIWORK *> \verbatim *> LIWORK is INTEGER *> The dimension of the array IWORK. LIWORK >= max(1,10*N). *> *> If LIWORK = -1, then a workspace query is assumed; the *> routine only calculates the optimal size of the IWORK array, *> returns this value as the first entry of the IWORK array, and *> no error message related to LIWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: Internal error *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleSYeigen * *> \par Contributors: * ================== *> *> Inderjit Dhillon, IBM Almaden, USA \n *> Osni Marques, LBNL/NERSC, USA \n *> Ken Stanley, Computer Science Division, University of *> California at Berkeley, USA \n *> Jason Riedy, Computer Science Division, University of *> California at Berkeley, USA \n *> * ===================================================================== SUBROUTINE DSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, $ ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, $ IWORK, LIWORK, INFO ) * * -- LAPACK driver routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LWORK, M, N DOUBLE PRECISION ABSTOL, VL, VU * .. * .. Array Arguments .. INTEGER ISUPPZ( * ), IWORK( * ) DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) * .. * .. Local Scalars .. LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, VALEIG, WANTZ, $ TRYRAC CHARACTER ORDER INTEGER I, IEEEOK, IINFO, IMAX, INDD, INDDD, INDE, $ INDEE, INDIBL, INDIFL, INDISP, INDIWO, INDTAU, $ INDWK, INDWKN, ISCALE, J, JJ, LIWMIN, $ LLWORK, LLWRKN, LWKOPT, LWMIN, NB, NSPLIT DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, $ SIGMA, SMLNUM, TMP1, VLL, VUU * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANSY EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY * .. * .. External Subroutines .. EXTERNAL DCOPY, DORMTR, DSCAL, DSTEBZ, DSTEMR, DSTEIN, $ DSTERF, DSWAP, DSYTRD, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * IEEEOK = ILAENV( 10, 'DSYEVR', 'N', 1, 2, 3, 4 ) * LOWER = LSAME( UPLO, 'L' ) WANTZ = LSAME( JOBZ, 'V' ) ALLEIG = LSAME( RANGE, 'A' ) VALEIG = LSAME( RANGE, 'V' ) INDEIG = LSAME( RANGE, 'I' ) * LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LIWORK.EQ.-1 ) ) * LWMIN = MAX( 1, 26*N ) LIWMIN = MAX( 1, 10*N ) * INFO = 0 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN INFO = -2 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( VALEIG ) THEN IF( N.GT.0 .AND. VU.LE.VL ) $ INFO = -8 ELSE IF( INDEIG ) THEN IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN INFO = -10 END IF END IF END IF IF( INFO.EQ.0 ) THEN IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN INFO = -15 ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN INFO = -18 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN INFO = -20 END IF END IF * IF( INFO.EQ.0 ) THEN NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) NB = MAX( NB, ILAENV( 1, 'DORMTR', UPLO, N, -1, -1, -1 ) ) LWKOPT = MAX( ( NB+1 )*N, LWMIN ) WORK( 1 ) = LWKOPT IWORK( 1 ) = LIWMIN END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYEVR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * M = 0 IF( N.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * IF( N.EQ.1 ) THEN WORK( 1 ) = 7 IF( ALLEIG .OR. INDEIG ) THEN M = 1 W( 1 ) = A( 1, 1 ) ELSE IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN M = 1 W( 1 ) = A( 1, 1 ) END IF END IF IF( WANTZ ) THEN Z( 1, 1 ) = ONE ISUPPZ( 1 ) = 1 ISUPPZ( 2 ) = 1 END IF RETURN END IF * * Get machine constants. * SAFMIN = DLAMCH( 'Safe minimum' ) EPS = DLAMCH( 'Precision' ) SMLNUM = SAFMIN / EPS BIGNUM = ONE / SMLNUM RMIN = SQRT( SMLNUM ) RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) * * Scale matrix to allowable range, if necessary. * ISCALE = 0 ABSTLL = ABSTOL IF (VALEIG) THEN VLL = VL VUU = VU END IF ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN ISCALE = 1 SIGMA = RMAX / ANRM END IF IF( ISCALE.EQ.1 ) THEN IF( LOWER ) THEN DO 10 J = 1, N CALL DSCAL( N-J+1, SIGMA, A( J, J ), 1 ) 10 CONTINUE ELSE DO 20 J = 1, N CALL DSCAL( J, SIGMA, A( 1, J ), 1 ) 20 CONTINUE END IF IF( ABSTOL.GT.0 ) $ ABSTLL = ABSTOL*SIGMA IF( VALEIG ) THEN VLL = VL*SIGMA VUU = VU*SIGMA END IF END IF * Initialize indices into workspaces. Note: The IWORK indices are * used only if DSTERF or DSTEMR fail. * WORK(INDTAU:INDTAU+N-1) stores the scalar factors of the * elementary reflectors used in DSYTRD. INDTAU = 1 * WORK(INDD:INDD+N-1) stores the tridiagonal's diagonal entries. INDD = INDTAU + N * WORK(INDE:INDE+N-1) stores the off-diagonal entries of the * tridiagonal matrix from DSYTRD. INDE = INDD + N * WORK(INDDD:INDDD+N-1) is a copy of the diagonal entries over * -written by DSTEMR (the DSTERF path copies the diagonal to W). INDDD = INDE + N * WORK(INDEE:INDEE+N-1) is a copy of the off-diagonal entries over * -written while computing the eigenvalues in DSTERF and DSTEMR. INDEE = INDDD + N * INDWK is the starting offset of the left-over workspace, and * LLWORK is the remaining workspace size. INDWK = INDEE + N LLWORK = LWORK - INDWK + 1 * IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in DSTEBZ and * stores the block indices of each of the M<=N eigenvalues. INDIBL = 1 * IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in DSTEBZ and * stores the starting and finishing indices of each block. INDISP = INDIBL + N * IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors * that corresponding to eigenvectors that fail to converge in * DSTEIN. This information is discarded; if any fail, the driver * returns INFO > 0. INDIFL = INDISP + N * INDIWO is the offset of the remaining integer workspace. INDIWO = INDIFL + N * * Call DSYTRD to reduce symmetric matrix to tridiagonal form. * CALL DSYTRD( UPLO, N, A, LDA, WORK( INDD ), WORK( INDE ), $ WORK( INDTAU ), WORK( INDWK ), LLWORK, IINFO ) * * If all eigenvalues are desired * then call DSTERF or DSTEMR and DORMTR. * IF( ( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) .AND. $ IEEEOK.EQ.1 ) THEN IF( .NOT.WANTZ ) THEN CALL DCOPY( N, WORK( INDD ), 1, W, 1 ) CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) CALL DSTERF( N, W, WORK( INDEE ), INFO ) ELSE CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) CALL DCOPY( N, WORK( INDD ), 1, WORK( INDDD ), 1 ) * IF (ABSTOL .LE. TWO*N*EPS) THEN TRYRAC = .TRUE. ELSE TRYRAC = .FALSE. END IF CALL DSTEMR( JOBZ, 'A', N, WORK( INDDD ), WORK( INDEE ), $ VL, VU, IL, IU, M, W, Z, LDZ, N, ISUPPZ, $ TRYRAC, WORK( INDWK ), LWORK, IWORK, LIWORK, $ INFO ) * * * * Apply orthogonal matrix used in reduction to tridiagonal * form to eigenvectors returned by DSTEMR. * IF( WANTZ .AND. INFO.EQ.0 ) THEN INDWKN = INDE LLWRKN = LWORK - INDWKN + 1 CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, $ WORK( INDTAU ), Z, LDZ, WORK( INDWKN ), $ LLWRKN, IINFO ) END IF END IF * * IF( INFO.EQ.0 ) THEN * Everything worked. Skip DSTEBZ/DSTEIN. IWORK(:) are * undefined. M = N GO TO 30 END IF INFO = 0 END IF * * Otherwise, call DSTEBZ and, if eigenvectors are desired, DSTEIN. * Also call DSTEBZ and DSTEIN if DSTEMR fails. * IF( WANTZ ) THEN ORDER = 'B' ELSE ORDER = 'E' END IF CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W, $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWK ), $ IWORK( INDIWO ), INFO ) * IF( WANTZ ) THEN CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, $ WORK( INDWK ), IWORK( INDIWO ), IWORK( INDIFL ), $ INFO ) * * Apply orthogonal matrix used in reduction to tridiagonal * form to eigenvectors returned by DSTEIN. * INDWKN = INDE LLWRKN = LWORK - INDWKN + 1 CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, $ LDZ, WORK( INDWKN ), LLWRKN, IINFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * * Jump here if DSTEMR/DSTEIN succeeded. 30 CONTINUE IF( ISCALE.EQ.1 ) THEN IF( INFO.EQ.0 ) THEN IMAX = M ELSE IMAX = INFO - 1 END IF CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) END IF * * If eigenvalues are not in order, then sort them, along with * eigenvectors. Note: We do not sort the IFAIL portion of IWORK. * It may not be initialized (if DSTEMR/DSTEIN succeeded), and we do * not return this detailed information to the user. * IF( WANTZ ) THEN DO 50 J = 1, M - 1 I = 0 TMP1 = W( J ) DO 40 JJ = J + 1, M IF( W( JJ ).LT.TMP1 ) THEN I = JJ TMP1 = W( JJ ) END IF 40 CONTINUE * IF( I.NE.0 ) THEN W( I ) = W( J ) W( J ) = TMP1 CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) END IF 50 CONTINUE END IF * * Set WORK(1) to optimal workspace size. * WORK( 1 ) = LWKOPT IWORK( 1 ) = LIWMIN * RETURN * * End of DSYEVR * END *> \brief DSYEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSYEVX + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, * ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, * IFAIL, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N * DOUBLE PRECISION ABSTOL, VL, VU * .. * .. Array Arguments .. * INTEGER IFAIL( * ), IWORK( * ) * DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSYEVX computes selected eigenvalues and, optionally, eigenvectors *> of a real symmetric matrix A. Eigenvalues and eigenvectors can be *> selected by specifying either a range of values or a range of indices *> for the desired eigenvalues. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBZ *> \verbatim *> JOBZ is CHARACTER*1 *> = 'N': Compute eigenvalues only; *> = 'V': Compute eigenvalues and eigenvectors. *> \endverbatim *> *> \param[in] RANGE *> \verbatim *> RANGE is CHARACTER*1 *> = 'A': all eigenvalues will be found. *> = 'V': all eigenvalues in the half-open interval (VL,VU] *> will be found. *> = 'I': the IL-th through IU-th eigenvalues will be found. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA, N) *> On entry, the symmetric matrix A. If UPLO = 'U', the *> leading N-by-N upper triangular part of A contains the *> upper triangular part of the matrix A. If UPLO = 'L', *> the leading N-by-N lower triangular part of A contains *> the lower triangular part of the matrix A. *> On exit, the lower triangle (if UPLO='L') or the upper *> triangle (if UPLO='U') of A, including the diagonal, is *> destroyed. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION *> If RANGE='V', the lower bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION *> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] IL *> \verbatim *> IL is INTEGER *> If RANGE='I', the index of the *> smallest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> If RANGE='I', the index of the *> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] ABSTOL *> \verbatim *> ABSTOL is DOUBLE PRECISION *> The absolute error tolerance for the eigenvalues. *> An approximate eigenvalue is accepted as converged *> when it is determined to lie in an interval [a,b] *> of width less than or equal to *> *> ABSTOL + EPS * max( |a|,|b| ) , *> *> where EPS is the machine precision. If ABSTOL is less than *> or equal to zero, then EPS*|T| will be used in its place, *> where |T| is the 1-norm of the tridiagonal matrix obtained *> by reducing A to tridiagonal form. *> *> Eigenvalues will be computed most accurately when ABSTOL is *> set to twice the underflow threshold 2*DLAMCH('S'), not zero. *> If this routine returns with INFO>0, indicating that some *> eigenvectors did not converge, try setting ABSTOL to *> 2*DLAMCH('S'). *> *> See "Computing Small Singular Values of Bidiagonal Matrices *> with Guaranteed High Relative Accuracy," by Demmel and *> Kahan, LAPACK Working Note #3. *> \endverbatim *> *> \param[out] M *> \verbatim *> M is INTEGER *> The total number of eigenvalues found. 0 <= M <= N. *> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. *> \endverbatim *> *> \param[out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> On normal exit, the first M elements contain the selected *> eigenvalues in ascending order. *> \endverbatim *> *> \param[out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M)) *> If JOBZ = 'V', then if INFO = 0, the first M columns of Z *> contain the orthonormal eigenvectors of the matrix A *> corresponding to the selected eigenvalues, with the i-th *> column of Z holding the eigenvector associated with W(i). *> If an eigenvector fails to converge, then that column of Z *> contains the latest approximation to the eigenvector, and the *> index of the eigenvector is returned in IFAIL. *> If JOBZ = 'N', then Z is not referenced. *> Note: the user must ensure that at least max(1,M) columns are *> supplied in the array Z; if RANGE = 'V', the exact value of M *> is not known in advance and an upper bound must be used. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1, and if *> JOBZ = 'V', LDZ >= max(1,N). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The length of the array WORK. LWORK >= 1, when N <= 1; *> otherwise 8*N. *> For optimal efficiency, LWORK >= (NB+3)*N, *> where NB is the max of the blocksize for DSYTRD and DORMTR *> 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. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (5*N) *> \endverbatim *> *> \param[out] IFAIL *> \verbatim *> IFAIL is INTEGER array, dimension (N) *> If JOBZ = 'V', then if INFO = 0, the first M elements of *> IFAIL are zero. If INFO > 0, then IFAIL contains the *> indices of the eigenvectors that failed to converge. *> If JOBZ = 'N', then IFAIL is not referenced. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, then i eigenvectors failed to converge. *> Their indices are stored in array IFAIL. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleSYeigen * * ===================================================================== SUBROUTINE DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, $ ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, $ IFAIL, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N DOUBLE PRECISION ABSTOL, VL, VU * .. * .. Array Arguments .. INTEGER IFAIL( * ), IWORK( * ) DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG, $ WANTZ CHARACTER ORDER INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, $ INDISP, INDIWO, INDTAU, INDWKN, INDWRK, ISCALE, $ ITMP1, J, JJ, LLWORK, LLWRKN, LWKMIN, $ LWKOPT, NB, NSPLIT DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, $ SIGMA, SMLNUM, TMP1, VLL, VUU * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANSY EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY * .. * .. External Subroutines .. EXTERNAL DCOPY, DLACPY, DORGTR, DORMTR, DSCAL, DSTEBZ, $ DSTEIN, DSTEQR, DSTERF, DSWAP, DSYTRD, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * LOWER = LSAME( UPLO, 'L' ) WANTZ = LSAME( JOBZ, 'V' ) ALLEIG = LSAME( RANGE, 'A' ) VALEIG = LSAME( RANGE, 'V' ) INDEIG = LSAME( RANGE, 'I' ) LQUERY = ( LWORK.EQ.-1 ) * INFO = 0 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN INFO = -2 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( VALEIG ) THEN IF( N.GT.0 .AND. VU.LE.VL ) $ INFO = -8 ELSE IF( INDEIG ) THEN IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN INFO = -10 END IF END IF END IF IF( INFO.EQ.0 ) THEN IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN INFO = -15 END IF END IF * IF( INFO.EQ.0 ) THEN IF( N.LE.1 ) THEN LWKMIN = 1 WORK( 1 ) = LWKMIN ELSE LWKMIN = 8*N NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) NB = MAX( NB, ILAENV( 1, 'DORMTR', UPLO, N, -1, -1, -1 ) ) LWKOPT = MAX( LWKMIN, ( NB + 3 )*N ) WORK( 1 ) = LWKOPT END IF * IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) $ INFO = -17 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYEVX', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * M = 0 IF( N.EQ.0 ) THEN RETURN END IF * IF( N.EQ.1 ) THEN IF( ALLEIG .OR. INDEIG ) THEN M = 1 W( 1 ) = A( 1, 1 ) ELSE IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN M = 1 W( 1 ) = A( 1, 1 ) END IF END IF IF( WANTZ ) $ Z( 1, 1 ) = ONE RETURN END IF * * Get machine constants. * SAFMIN = DLAMCH( 'Safe minimum' ) EPS = DLAMCH( 'Precision' ) SMLNUM = SAFMIN / EPS BIGNUM = ONE / SMLNUM RMIN = SQRT( SMLNUM ) RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) * * Scale matrix to allowable range, if necessary. * ISCALE = 0 ABSTLL = ABSTOL IF( VALEIG ) THEN VLL = VL VUU = VU END IF ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN ISCALE = 1 SIGMA = RMAX / ANRM END IF IF( ISCALE.EQ.1 ) THEN IF( LOWER ) THEN DO 10 J = 1, N CALL DSCAL( N-J+1, SIGMA, A( J, J ), 1 ) 10 CONTINUE ELSE DO 20 J = 1, N CALL DSCAL( J, SIGMA, A( 1, J ), 1 ) 20 CONTINUE END IF IF( ABSTOL.GT.0 ) $ ABSTLL = ABSTOL*SIGMA IF( VALEIG ) THEN VLL = VL*SIGMA VUU = VU*SIGMA END IF END IF * * Call DSYTRD to reduce symmetric matrix to tridiagonal form. * INDTAU = 1 INDE = INDTAU + N INDD = INDE + N INDWRK = INDD + N LLWORK = LWORK - INDWRK + 1 CALL DSYTRD( UPLO, N, A, LDA, WORK( INDD ), WORK( INDE ), $ WORK( INDTAU ), WORK( INDWRK ), LLWORK, IINFO ) * * If all eigenvalues are desired and ABSTOL is less than or equal to * zero, then call DSTERF or DORGTR and SSTEQR. If this fails for * some eigenvalue, then try DSTEBZ. * TEST = .FALSE. IF( INDEIG ) THEN IF( IL.EQ.1 .AND. IU.EQ.N ) THEN TEST = .TRUE. END IF END IF IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN CALL DCOPY( N, WORK( INDD ), 1, W, 1 ) INDEE = INDWRK + 2*N IF( .NOT.WANTZ ) THEN CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) CALL DSTERF( N, W, WORK( INDEE ), INFO ) ELSE CALL DLACPY( 'A', N, N, A, LDA, Z, LDZ ) CALL DORGTR( UPLO, N, Z, LDZ, WORK( INDTAU ), $ WORK( INDWRK ), LLWORK, IINFO ) CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ, $ WORK( INDWRK ), INFO ) IF( INFO.EQ.0 ) THEN DO 30 I = 1, N IFAIL( I ) = 0 30 CONTINUE END IF END IF IF( INFO.EQ.0 ) THEN M = N GO TO 40 END IF INFO = 0 END IF * * Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. * IF( WANTZ ) THEN ORDER = 'B' ELSE ORDER = 'E' END IF INDIBL = 1 INDISP = INDIBL + N INDIWO = INDISP + N CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W, $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ), $ IWORK( INDIWO ), INFO ) * IF( WANTZ ) THEN CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, $ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO ) * * Apply orthogonal matrix used in reduction to tridiagonal * form to eigenvectors returned by DSTEIN. * INDWKN = INDE LLWRKN = LWORK - INDWKN + 1 CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, $ LDZ, WORK( INDWKN ), LLWRKN, IINFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * 40 CONTINUE IF( ISCALE.EQ.1 ) THEN IF( INFO.EQ.0 ) THEN IMAX = M ELSE IMAX = INFO - 1 END IF CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) END IF * * If eigenvalues are not in order, then sort them, along with * eigenvectors. * IF( WANTZ ) THEN DO 60 J = 1, M - 1 I = 0 TMP1 = W( J ) DO 50 JJ = J + 1, M IF( W( JJ ).LT.TMP1 ) THEN I = JJ TMP1 = W( JJ ) END IF 50 CONTINUE * IF( I.NE.0 ) THEN ITMP1 = IWORK( INDIBL+I-1 ) W( I ) = W( J ) IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) W( J ) = TMP1 IWORK( INDIBL+J-1 ) = ITMP1 CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) IF( INFO.NE.0 ) THEN ITMP1 = IFAIL( I ) IFAIL( I ) = IFAIL( J ) IFAIL( J ) = ITMP1 END IF END IF 60 CONTINUE END IF * * Set WORK(1) to optimal workspace size. * WORK( 1 ) = LWKOPT * RETURN * * End of DSYEVX * END *> \brief \b DSYGS2 reduces a symmetric definite generalized eigenproblem to standard form, using the factorization results obtained from spotrf (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSYGS2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, ITYPE, LDA, LDB, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSYGS2 reduces a real symmetric-definite generalized eigenproblem *> to standard form. *> *> If ITYPE = 1, the problem is A*x = lambda*B*x, *> and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T) *> *> If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or *> B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T *A*L. *> *> B must have been previously factorized as U**T *U or L*L**T by DPOTRF. *> \endverbatim * * Arguments: * ========== * *> \param[in] ITYPE *> \verbatim *> ITYPE is INTEGER *> = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T); *> = 2 or 3: compute U*A*U**T or L**T *A*L. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the upper or lower triangular part of the *> symmetric matrix A is stored, and how B has been factorized. *> = 'U': Upper triangular *> = 'L': Lower triangular *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A and B. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the symmetric matrix A. If UPLO = 'U', the leading *> n by n upper triangular part of A contains the upper *> triangular part of the matrix A, and the strictly lower *> triangular part of A is not referenced. If UPLO = 'L', the *> leading n by n lower triangular part of A contains the lower *> triangular part of the matrix A, and the strictly upper *> triangular part of A is not referenced. *> *> On exit, if INFO = 0, the transformed matrix, stored in the *> same format as A. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,N) *> The triangular factor from the Cholesky factorization of B, *> as returned by DPOTRF. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleSYcomputational * * ===================================================================== SUBROUTINE DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, ITYPE, LDA, LDB, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, HALF PARAMETER ( ONE = 1.0D0, HALF = 0.5D0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER K DOUBLE PRECISION AKK, BKK, CT * .. * .. External Subroutines .. EXTERNAL DAXPY, DSCAL, DSYR2, DTRMV, DTRSV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN INFO = -1 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYGS2', -INFO ) RETURN END IF * IF( ITYPE.EQ.1 ) THEN IF( UPPER ) THEN * * Compute inv(U**T)*A*inv(U) * DO 10 K = 1, N * * Update the upper triangle of A(k:n,k:n) * AKK = A( K, K ) BKK = B( K, K ) AKK = AKK / BKK**2 A( K, K ) = AKK IF( K.LT.N ) THEN CALL DSCAL( N-K, ONE / BKK, A( K, K+1 ), LDA ) CT = -HALF*AKK CALL DAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ), $ LDA ) CALL DSYR2( UPLO, N-K, -ONE, A( K, K+1 ), LDA, $ B( K, K+1 ), LDB, A( K+1, K+1 ), LDA ) CALL DAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ), $ LDA ) CALL DTRSV( UPLO, 'Transpose', 'Non-unit', N-K, $ B( K+1, K+1 ), LDB, A( K, K+1 ), LDA ) END IF 10 CONTINUE ELSE * * Compute inv(L)*A*inv(L**T) * DO 20 K = 1, N * * Update the lower triangle of A(k:n,k:n) * AKK = A( K, K ) BKK = B( K, K ) AKK = AKK / BKK**2 A( K, K ) = AKK IF( K.LT.N ) THEN CALL DSCAL( N-K, ONE / BKK, A( K+1, K ), 1 ) CT = -HALF*AKK CALL DAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 ) CALL DSYR2( UPLO, N-K, -ONE, A( K+1, K ), 1, $ B( K+1, K ), 1, A( K+1, K+1 ), LDA ) CALL DAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 ) CALL DTRSV( UPLO, 'No transpose', 'Non-unit', N-K, $ B( K+1, K+1 ), LDB, A( K+1, K ), 1 ) END IF 20 CONTINUE END IF ELSE IF( UPPER ) THEN * * Compute U*A*U**T * DO 30 K = 1, N * * Update the upper triangle of A(1:k,1:k) * AKK = A( K, K ) BKK = B( K, K ) CALL DTRMV( UPLO, 'No transpose', 'Non-unit', K-1, B, $ LDB, A( 1, K ), 1 ) CT = HALF*AKK CALL DAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 ) CALL DSYR2( UPLO, K-1, ONE, A( 1, K ), 1, B( 1, K ), 1, $ A, LDA ) CALL DAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 ) CALL DSCAL( K-1, BKK, A( 1, K ), 1 ) A( K, K ) = AKK*BKK**2 30 CONTINUE ELSE * * Compute L**T *A*L * DO 40 K = 1, N * * Update the lower triangle of A(1:k,1:k) * AKK = A( K, K ) BKK = B( K, K ) CALL DTRMV( UPLO, 'Transpose', 'Non-unit', K-1, B, LDB, $ A( K, 1 ), LDA ) CT = HALF*AKK CALL DAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA ) CALL DSYR2( UPLO, K-1, ONE, A( K, 1 ), LDA, B( K, 1 ), $ LDB, A, LDA ) CALL DAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA ) CALL DSCAL( K-1, BKK, A( K, 1 ), LDA ) A( K, K ) = AKK*BKK**2 40 CONTINUE END IF END IF RETURN * * End of DSYGS2 * END *> \brief \b DSYGST * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSYGST + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, ITYPE, LDA, LDB, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSYGST reduces a real symmetric-definite generalized eigenproblem *> to standard form. *> *> If ITYPE = 1, the problem is A*x = lambda*B*x, *> and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T) *> *> If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or *> B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L. *> *> B must have been previously factorized as U**T*U or L*L**T by DPOTRF. *> \endverbatim * * Arguments: * ========== * *> \param[in] ITYPE *> \verbatim *> ITYPE is INTEGER *> = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T); *> = 2 or 3: compute U*A*U**T or L**T*A*L. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored and B is factored as *> U**T*U; *> = 'L': Lower triangle of A is stored and B is factored as *> L*L**T. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A and B. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the symmetric matrix A. If UPLO = 'U', the leading *> N-by-N upper triangular part of A contains the upper *> triangular part of the matrix A, and the strictly lower *> triangular part of A is not referenced. If UPLO = 'L', the *> leading N-by-N lower triangular part of A contains the lower *> triangular part of the matrix A, and the strictly upper *> triangular part of A is not referenced. *> *> On exit, if INFO = 0, the transformed matrix, stored in the *> same format as A. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,N) *> The triangular factor from the Cholesky factorization of B, *> as returned by DPOTRF. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleSYcomputational * * ===================================================================== SUBROUTINE DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, ITYPE, LDA, LDB, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, HALF PARAMETER ( ONE = 1.0D0, HALF = 0.5D0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER K, KB, NB * .. * .. External Subroutines .. EXTERNAL DSYGS2, DSYMM, DSYR2K, DTRMM, DTRSM, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN INFO = -1 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYGST', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Determine the block size for this environment. * NB = ILAENV( 1, 'DSYGST', UPLO, N, -1, -1, -1 ) * IF( NB.LE.1 .OR. NB.GE.N ) THEN * * Use unblocked code * CALL DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) ELSE * * Use blocked code * IF( ITYPE.EQ.1 ) THEN IF( UPPER ) THEN * * Compute inv(U**T)*A*inv(U) * DO 10 K = 1, N, NB KB = MIN( N-K+1, NB ) * * Update the upper triangle of A(k:n,k:n) * CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, $ B( K, K ), LDB, INFO ) IF( K+KB.LE.N ) THEN CALL DTRSM( 'Left', UPLO, 'Transpose', 'Non-unit', $ KB, N-K-KB+1, ONE, B( K, K ), LDB, $ A( K, K+KB ), LDA ) CALL DSYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF, $ A( K, K ), LDA, B( K, K+KB ), LDB, ONE, $ A( K, K+KB ), LDA ) CALL DSYR2K( UPLO, 'Transpose', N-K-KB+1, KB, -ONE, $ A( K, K+KB ), LDA, B( K, K+KB ), LDB, $ ONE, A( K+KB, K+KB ), LDA ) CALL DSYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF, $ A( K, K ), LDA, B( K, K+KB ), LDB, ONE, $ A( K, K+KB ), LDA ) CALL DTRSM( 'Right', UPLO, 'No transpose', $ 'Non-unit', KB, N-K-KB+1, ONE, $ B( K+KB, K+KB ), LDB, A( K, K+KB ), $ LDA ) END IF 10 CONTINUE ELSE * * Compute inv(L)*A*inv(L**T) * DO 20 K = 1, N, NB KB = MIN( N-K+1, NB ) * * Update the lower triangle of A(k:n,k:n) * CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, $ B( K, K ), LDB, INFO ) IF( K+KB.LE.N ) THEN CALL DTRSM( 'Right', UPLO, 'Transpose', 'Non-unit', $ N-K-KB+1, KB, ONE, B( K, K ), LDB, $ A( K+KB, K ), LDA ) CALL DSYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF, $ A( K, K ), LDA, B( K+KB, K ), LDB, ONE, $ A( K+KB, K ), LDA ) CALL DSYR2K( UPLO, 'No transpose', N-K-KB+1, KB, $ -ONE, A( K+KB, K ), LDA, B( K+KB, K ), $ LDB, ONE, A( K+KB, K+KB ), LDA ) CALL DSYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF, $ A( K, K ), LDA, B( K+KB, K ), LDB, ONE, $ A( K+KB, K ), LDA ) CALL DTRSM( 'Left', UPLO, 'No transpose', $ 'Non-unit', N-K-KB+1, KB, ONE, $ B( K+KB, K+KB ), LDB, A( K+KB, K ), $ LDA ) END IF 20 CONTINUE END IF ELSE IF( UPPER ) THEN * * Compute U*A*U**T * DO 30 K = 1, N, NB KB = MIN( N-K+1, NB ) * * Update the upper triangle of A(1:k+kb-1,1:k+kb-1) * CALL DTRMM( 'Left', UPLO, 'No transpose', 'Non-unit', $ K-1, KB, ONE, B, LDB, A( 1, K ), LDA ) CALL DSYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ), $ LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA ) CALL DSYR2K( UPLO, 'No transpose', K-1, KB, ONE, $ A( 1, K ), LDA, B( 1, K ), LDB, ONE, A, $ LDA ) CALL DSYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ), $ LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA ) CALL DTRMM( 'Right', UPLO, 'Transpose', 'Non-unit', $ K-1, KB, ONE, B( K, K ), LDB, A( 1, K ), $ LDA ) CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, $ B( K, K ), LDB, INFO ) 30 CONTINUE ELSE * * Compute L**T*A*L * DO 40 K = 1, N, NB KB = MIN( N-K+1, NB ) * * Update the lower triangle of A(1:k+kb-1,1:k+kb-1) * CALL DTRMM( 'Right', UPLO, 'No transpose', 'Non-unit', $ KB, K-1, ONE, B, LDB, A( K, 1 ), LDA ) CALL DSYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ), $ LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA ) CALL DSYR2K( UPLO, 'Transpose', K-1, KB, ONE, $ A( K, 1 ), LDA, B( K, 1 ), LDB, ONE, A, $ LDA ) CALL DSYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ), $ LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA ) CALL DTRMM( 'Left', UPLO, 'Transpose', 'Non-unit', KB, $ K-1, ONE, B( K, K ), LDB, A( K, 1 ), LDA ) CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, $ B( K, K ), LDB, INFO ) 40 CONTINUE END IF END IF END IF RETURN * * End of DSYGST * END *> \brief \b DSYGV * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSYGV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, * LWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, ITYPE, LDA, LDB, LWORK, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSYGV computes all the eigenvalues, and optionally, the eigenvectors *> of a real generalized symmetric-definite eigenproblem, of the form *> A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. *> Here A and B are assumed to be symmetric and B is also *> positive definite. *> \endverbatim * * Arguments: * ========== * *> \param[in] ITYPE *> \verbatim *> ITYPE is INTEGER *> Specifies the problem type to be solved: *> = 1: A*x = (lambda)*B*x *> = 2: A*B*x = (lambda)*x *> = 3: B*A*x = (lambda)*x *> \endverbatim *> *> \param[in] JOBZ *> \verbatim *> JOBZ is CHARACTER*1 *> = 'N': Compute eigenvalues only; *> = 'V': Compute eigenvalues and eigenvectors. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangles of A and B are stored; *> = 'L': Lower triangles of A and B are stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A and B. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA, N) *> On entry, the symmetric matrix A. If UPLO = 'U', the *> leading N-by-N upper triangular part of A contains the *> upper triangular part of the matrix A. If UPLO = 'L', *> the leading N-by-N lower triangular part of A contains *> the lower triangular part of the matrix A. *> *> On exit, if JOBZ = 'V', then if INFO = 0, A contains the *> matrix Z of eigenvectors. The eigenvectors are normalized *> as follows: *> if ITYPE = 1 or 2, Z**T*B*Z = I; *> if ITYPE = 3, Z**T*inv(B)*Z = I. *> If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') *> or the lower triangle (if UPLO='L') of A, including the *> diagonal, is destroyed. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB, N) *> On entry, the symmetric positive definite matrix B. *> If UPLO = 'U', the leading N-by-N upper triangular part of B *> contains the upper triangular part of the matrix B. *> If UPLO = 'L', the leading N-by-N lower triangular part of B *> contains the lower triangular part of the matrix B. *> *> On exit, if INFO <= N, the part of B containing the matrix is *> overwritten by the triangular factor U or L from the Cholesky *> factorization B = U**T*U or B = L*L**T. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> If INFO = 0, the eigenvalues in ascending order. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The length of the array WORK. LWORK >= max(1,3*N-1). *> For optimal efficiency, LWORK >= (NB+2)*N, *> where NB is the blocksize for DSYTRD 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: DPOTRF or DSYEV returned an error code: *> <= N: if INFO = i, DSYEV failed to converge; *> i off-diagonal elements of an intermediate *> tridiagonal form did not converge to zero; *> > N: if INFO = N + i, for 1 <= i <= N, then the leading *> minor of order i of B is not positive definite. *> The factorization of B could not be completed and *> no eigenvalues or eigenvectors were computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleSYeigen * * ===================================================================== SUBROUTINE DSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, $ LWORK, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO INTEGER INFO, ITYPE, LDA, LDB, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, UPPER, WANTZ CHARACTER TRANS INTEGER LWKMIN, LWKOPT, NB, NEIG * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DPOTRF, DSYEV, DSYGST, DTRMM, DTRSM, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * WANTZ = LSAME( JOBZ, 'V' ) UPPER = LSAME( UPLO, 'U' ) LQUERY = ( LWORK.EQ.-1 ) * INFO = 0 IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN INFO = -1 ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -2 ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 END IF * IF( INFO.EQ.0 ) THEN LWKMIN = MAX( 1, 3*N - 1 ) NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) LWKOPT = MAX( LWKMIN, ( NB + 2 )*N ) WORK( 1 ) = LWKOPT * IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN INFO = -11 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYGV ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Form a Cholesky factorization of B. * CALL DPOTRF( UPLO, N, B, LDB, INFO ) IF( INFO.NE.0 ) THEN INFO = N + INFO RETURN END IF * * Transform problem to standard eigenvalue problem and solve. * CALL DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) CALL DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) * IF( WANTZ ) THEN * * Backtransform eigenvectors to the original problem. * NEIG = N IF( INFO.GT.0 ) $ NEIG = INFO - 1 IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN * * For A*x=(lambda)*B*x and A*B*x=(lambda)*x; * backtransform eigenvectors: x = inv(L)**T*y or inv(U)*y * IF( UPPER ) THEN TRANS = 'N' ELSE TRANS = 'T' END IF * CALL DTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE, $ B, LDB, A, LDA ) * ELSE IF( ITYPE.EQ.3 ) THEN * * For B*A*x=(lambda)*x; * backtransform eigenvectors: x = L*y or U**T*y * IF( UPPER ) THEN TRANS = 'T' ELSE TRANS = 'N' END IF * CALL DTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE, $ B, LDB, A, LDA ) END IF END IF * WORK( 1 ) = LWKOPT RETURN * * End of DSYGV * END *> \brief \b DSYGVD * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSYGVD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, * LWORK, IWORK, LIWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBZ, UPLO * INTEGER INFO, ITYPE, LDA, LDB, LIWORK, LWORK, N * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSYGVD computes all the eigenvalues, and optionally, the eigenvectors *> of a real generalized symmetric-definite eigenproblem, of the form *> A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and *> B are assumed to be symmetric and B is also positive definite. *> If eigenvectors are desired, it uses a divide and conquer algorithm. *> *> The divide and conquer algorithm makes very mild assumptions about *> floating point arithmetic. It will work on machines with a guard *> digit in add/subtract, or on those binary machines without guard *> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or *> Cray-2. It could conceivably fail on hexadecimal or decimal machines *> without guard digits, but we know of none. *> \endverbatim * * Arguments: * ========== * *> \param[in] ITYPE *> \verbatim *> ITYPE is INTEGER *> Specifies the problem type to be solved: *> = 1: A*x = (lambda)*B*x *> = 2: A*B*x = (lambda)*x *> = 3: B*A*x = (lambda)*x *> \endverbatim *> *> \param[in] JOBZ *> \verbatim *> JOBZ is CHARACTER*1 *> = 'N': Compute eigenvalues only; *> = 'V': Compute eigenvalues and eigenvectors. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangles of A and B are stored; *> = 'L': Lower triangles of A and B are stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A and B. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA, N) *> On entry, the symmetric matrix A. If UPLO = 'U', the *> leading N-by-N upper triangular part of A contains the *> upper triangular part of the matrix A. If UPLO = 'L', *> the leading N-by-N lower triangular part of A contains *> the lower triangular part of the matrix A. *> *> On exit, if JOBZ = 'V', then if INFO = 0, A contains the *> matrix Z of eigenvectors. The eigenvectors are normalized *> as follows: *> if ITYPE = 1 or 2, Z**T*B*Z = I; *> if ITYPE = 3, Z**T*inv(B)*Z = I. *> If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') *> or the lower triangle (if UPLO='L') of A, including the *> diagonal, is destroyed. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB, N) *> On entry, the symmetric matrix B. If UPLO = 'U', the *> leading N-by-N upper triangular part of B contains the *> upper triangular part of the matrix B. If UPLO = 'L', *> the leading N-by-N lower triangular part of B contains *> the lower triangular part of the matrix B. *> *> On exit, if INFO <= N, the part of B containing the matrix is *> overwritten by the triangular factor U or L from the Cholesky *> factorization B = U**T*U or B = L*L**T. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> If INFO = 0, the eigenvalues in ascending order. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. *> If N <= 1, LWORK >= 1. *> If JOBZ = 'N' and N > 1, LWORK >= 2*N+1. *> If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal sizes of the WORK and IWORK *> arrays, returns these values as the first entries of the WORK *> and IWORK arrays, and no error message related to LWORK or *> LIWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) *> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. *> \endverbatim *> *> \param[in] LIWORK *> \verbatim *> LIWORK is INTEGER *> The dimension of the array IWORK. *> If N <= 1, LIWORK >= 1. *> If JOBZ = 'N' and N > 1, LIWORK >= 1. *> If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. *> *> If LIWORK = -1, then a workspace query is assumed; the *> routine only calculates the optimal sizes of the WORK and *> IWORK arrays, returns these values as the first entries of *> the WORK and IWORK arrays, and no error message related to *> LWORK or LIWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: DPOTRF or DSYEVD returned an error code: *> <= N: if INFO = i and JOBZ = 'N', then the algorithm *> failed to converge; i off-diagonal elements of an *> intermediate tridiagonal form did not converge to *> zero; *> if INFO = i and JOBZ = 'V', then the algorithm *> failed to compute an eigenvalue while working on *> the submatrix lying in rows and columns INFO/(N+1) *> through mod(INFO,N+1); *> > N: if INFO = N + i, for 1 <= i <= N, then the leading *> minor of order i of B is not positive definite. *> The factorization of B could not be completed and *> no eigenvalues or eigenvectors were computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleSYeigen * *> \par Further Details: * ===================== *> *> \verbatim *> *> Modified so that no backsubstitution is performed if DSYEVD fails to *> converge (NEIG in old code could be greater than N causing out of *> bounds reference to A - reported by Ralf Meyer). Also corrected the *> description of INFO and the test on ITYPE. Sven, 16 Feb 05. *> \endverbatim * *> \par Contributors: * ================== *> *> Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA *> * ===================================================================== SUBROUTINE DSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, $ LWORK, IWORK, LIWORK, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO INTEGER INFO, ITYPE, LDA, LDB, LIWORK, LWORK, N * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, UPPER, WANTZ CHARACTER TRANS INTEGER LIOPT, LIWMIN, LOPT, LWMIN * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DPOTRF, DSYEVD, DSYGST, DTRMM, DTRSM, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MAX * .. * .. Executable Statements .. * * Test the input parameters. * WANTZ = LSAME( JOBZ, 'V' ) UPPER = LSAME( UPLO, 'U' ) LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) * INFO = 0 IF( N.LE.1 ) THEN LIWMIN = 1 LWMIN = 1 ELSE IF( WANTZ ) THEN LIWMIN = 3 + 5*N LWMIN = 1 + 6*N + 2*N**2 ELSE LIWMIN = 1 LWMIN = 2*N + 1 END IF LOPT = LWMIN LIOPT = LIWMIN IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN INFO = -1 ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -2 ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 END IF * IF( INFO.EQ.0 ) THEN WORK( 1 ) = LOPT IWORK( 1 ) = LIOPT * IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN INFO = -11 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN INFO = -13 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYGVD', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Form a Cholesky factorization of B. * CALL DPOTRF( UPLO, N, B, LDB, INFO ) IF( INFO.NE.0 ) THEN INFO = N + INFO RETURN END IF * * Transform problem to standard eigenvalue problem and solve. * CALL DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) CALL DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, LIWORK, $ INFO ) LOPT = MAX( DBLE( LOPT ), DBLE( WORK( 1 ) ) ) LIOPT = MAX( DBLE( LIOPT ), DBLE( IWORK( 1 ) ) ) * IF( WANTZ .AND. INFO.EQ.0 ) THEN * * Backtransform eigenvectors to the original problem. * IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN * * For A*x=(lambda)*B*x and A*B*x=(lambda)*x; * backtransform eigenvectors: x = inv(L)**T*y or inv(U)*y * IF( UPPER ) THEN TRANS = 'N' ELSE TRANS = 'T' END IF * CALL DTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, N, ONE, $ B, LDB, A, LDA ) * ELSE IF( ITYPE.EQ.3 ) THEN * * For B*A*x=(lambda)*x; * backtransform eigenvectors: x = L*y or U**T*y * IF( UPPER ) THEN TRANS = 'T' ELSE TRANS = 'N' END IF * CALL DTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, N, ONE, $ B, LDB, A, LDA ) END IF END IF * WORK( 1 ) = LOPT IWORK( 1 ) = LIOPT * RETURN * * End of DSYGVD * END *> \brief \b DSYGVX * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSYGVX + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, * VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, * LWORK, IWORK, IFAIL, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBZ, RANGE, UPLO * INTEGER IL, INFO, ITYPE, IU, LDA, LDB, LDZ, LWORK, M, N * DOUBLE PRECISION ABSTOL, VL, VU * .. * .. Array Arguments .. * INTEGER IFAIL( * ), IWORK( * ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ), * $ Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSYGVX computes selected eigenvalues, and optionally, eigenvectors *> of a real generalized symmetric-definite eigenproblem, of the form *> A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A *> and B are assumed to be symmetric and B is also positive definite. *> Eigenvalues and eigenvectors can be selected by specifying either a *> range of values or a range of indices for the desired eigenvalues. *> \endverbatim * * Arguments: * ========== * *> \param[in] ITYPE *> \verbatim *> ITYPE is INTEGER *> Specifies the problem type to be solved: *> = 1: A*x = (lambda)*B*x *> = 2: A*B*x = (lambda)*x *> = 3: B*A*x = (lambda)*x *> \endverbatim *> *> \param[in] JOBZ *> \verbatim *> JOBZ is CHARACTER*1 *> = 'N': Compute eigenvalues only; *> = 'V': Compute eigenvalues and eigenvectors. *> \endverbatim *> *> \param[in] RANGE *> \verbatim *> RANGE is CHARACTER*1 *> = 'A': all eigenvalues will be found. *> = 'V': all eigenvalues in the half-open interval (VL,VU] *> will be found. *> = 'I': the IL-th through IU-th eigenvalues will be found. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A and B are stored; *> = 'L': Lower triangle of A and B are stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix pencil (A,B). N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA, N) *> On entry, the symmetric matrix A. If UPLO = 'U', the *> leading N-by-N upper triangular part of A contains the *> upper triangular part of the matrix A. If UPLO = 'L', *> the leading N-by-N lower triangular part of A contains *> the lower triangular part of the matrix A. *> *> On exit, the lower triangle (if UPLO='L') or the upper *> triangle (if UPLO='U') of A, including the diagonal, is *> destroyed. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB, N) *> On entry, the symmetric matrix B. If UPLO = 'U', the *> leading N-by-N upper triangular part of B contains the *> upper triangular part of the matrix B. If UPLO = 'L', *> the leading N-by-N lower triangular part of B contains *> the lower triangular part of the matrix B. *> *> On exit, if INFO <= N, the part of B containing the matrix is *> overwritten by the triangular factor U or L from the Cholesky *> factorization B = U**T*U or B = L*L**T. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION *> If RANGE='V', the lower bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] VU *> \verbatim *> VU is DOUBLE PRECISION *> If RANGE='V', the upper bound of the interval to *> be searched for eigenvalues. VL < VU. *> Not referenced if RANGE = 'A' or 'I'. *> \endverbatim *> *> \param[in] IL *> \verbatim *> IL is INTEGER *> If RANGE='I', the index of the *> smallest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] IU *> \verbatim *> IU is INTEGER *> If RANGE='I', the index of the *> largest eigenvalue to be returned. *> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. *> Not referenced if RANGE = 'A' or 'V'. *> \endverbatim *> *> \param[in] ABSTOL *> \verbatim *> ABSTOL is DOUBLE PRECISION *> The absolute error tolerance for the eigenvalues. *> An approximate eigenvalue is accepted as converged *> when it is determined to lie in an interval [a,b] *> of width less than or equal to *> *> ABSTOL + EPS * max( |a|,|b| ) , *> *> where EPS is the machine precision. If ABSTOL is less than *> or equal to zero, then EPS*|T| will be used in its place, *> where |T| is the 1-norm of the tridiagonal matrix obtained *> by reducing C to tridiagonal form, where C is the symmetric *> matrix of the standard symmetric problem to which the *> generalized problem is transformed. *> *> Eigenvalues will be computed most accurately when ABSTOL is *> set to twice the underflow threshold 2*DLAMCH('S'), not zero. *> If this routine returns with INFO>0, indicating that some *> eigenvectors did not converge, try setting ABSTOL to *> 2*DLAMCH('S'). *> \endverbatim *> *> \param[out] M *> \verbatim *> M is INTEGER *> The total number of eigenvalues found. 0 <= M <= N. *> If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. *> \endverbatim *> *> \param[out] W *> \verbatim *> W is DOUBLE PRECISION array, dimension (N) *> On normal exit, the first M elements contain the selected *> eigenvalues in ascending order. *> \endverbatim *> *> \param[out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M)) *> If JOBZ = 'N', then Z is not referenced. *> If JOBZ = 'V', then if INFO = 0, the first M columns of Z *> contain the orthonormal eigenvectors of the matrix A *> corresponding to the selected eigenvalues, with the i-th *> column of Z holding the eigenvector associated with W(i). *> The eigenvectors are normalized as follows: *> if ITYPE = 1 or 2, Z**T*B*Z = I; *> if ITYPE = 3, Z**T*inv(B)*Z = I. *> *> If an eigenvector fails to converge, then that column of Z *> contains the latest approximation to the eigenvector, and the *> index of the eigenvector is returned in IFAIL. *> Note: the user must ensure that at least max(1,M) columns are *> supplied in the array Z; if RANGE = 'V', the exact value of M *> is not known in advance and an upper bound must be used. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1, and if *> JOBZ = 'V', LDZ >= max(1,N). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The length of the array WORK. LWORK >= max(1,8*N). *> For optimal efficiency, LWORK >= (NB+3)*N, *> where NB is the blocksize for DSYTRD returned by ILAENV. *> *> 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. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (5*N) *> \endverbatim *> *> \param[out] IFAIL *> \verbatim *> IFAIL is INTEGER array, dimension (N) *> If JOBZ = 'V', then if INFO = 0, the first M elements of *> IFAIL are zero. If INFO > 0, then IFAIL contains the *> indices of the eigenvectors that failed to converge. *> If JOBZ = 'N', then IFAIL is not referenced. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: DPOTRF or DSYEVX returned an error code: *> <= N: if INFO = i, DSYEVX failed to converge; *> i eigenvectors failed to converge. Their indices *> are stored in array IFAIL. *> > N: if INFO = N + i, for 1 <= i <= N, then the leading *> minor of order i of B is not positive definite. *> The factorization of B could not be completed and *> no eigenvalues or eigenvectors were computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleSYeigen * *> \par Contributors: * ================== *> *> Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA * * ===================================================================== SUBROUTINE DSYGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, $ VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, $ LWORK, IWORK, IFAIL, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO INTEGER IL, INFO, ITYPE, IU, LDA, LDB, LDZ, LWORK, M, N DOUBLE PRECISION ABSTOL, VL, VU * .. * .. Array Arguments .. INTEGER IFAIL( * ), IWORK( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ), $ Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL ALLEIG, INDEIG, LQUERY, UPPER, VALEIG, WANTZ CHARACTER TRANS INTEGER LWKMIN, LWKOPT, NB * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DPOTRF, DSYEVX, DSYGST, DTRMM, DTRSM, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters. * UPPER = LSAME( UPLO, 'U' ) WANTZ = LSAME( JOBZ, 'V' ) ALLEIG = LSAME( RANGE, 'A' ) VALEIG = LSAME( RANGE, 'V' ) INDEIG = LSAME( RANGE, 'I' ) LQUERY = ( LWORK.EQ.-1 ) * INFO = 0 IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN INFO = -1 ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -2 ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN INFO = -3 ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN INFO = -4 ELSE IF( N.LT.0 ) 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( VALEIG ) THEN IF( N.GT.0 .AND. VU.LE.VL ) $ INFO = -11 ELSE IF( INDEIG ) THEN IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN INFO = -12 ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN INFO = -13 END IF END IF END IF IF (INFO.EQ.0) THEN IF (LDZ.LT.1 .OR. (WANTZ .AND. LDZ.LT.N)) THEN INFO = -18 END IF END IF * IF( INFO.EQ.0 ) THEN LWKMIN = MAX( 1, 8*N ) NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) LWKOPT = MAX( LWKMIN, ( NB + 3 )*N ) WORK( 1 ) = LWKOPT * IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN INFO = -20 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYGVX', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * M = 0 IF( N.EQ.0 ) THEN RETURN END IF * * Form a Cholesky factorization of B. * CALL DPOTRF( UPLO, N, B, LDB, INFO ) IF( INFO.NE.0 ) THEN INFO = N + INFO RETURN END IF * * Transform problem to standard eigenvalue problem and solve. * CALL DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) CALL DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, $ M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO ) * IF( WANTZ ) THEN * * Backtransform eigenvectors to the original problem. * IF( INFO.GT.0 ) $ M = INFO - 1 IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN * * For A*x=(lambda)*B*x and A*B*x=(lambda)*x; * backtransform eigenvectors: x = inv(L)**T*y or inv(U)*y * IF( UPPER ) THEN TRANS = 'N' ELSE TRANS = 'T' END IF * CALL DTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, M, ONE, B, $ LDB, Z, LDZ ) * ELSE IF( ITYPE.EQ.3 ) THEN * * For B*A*x=(lambda)*x; * backtransform eigenvectors: x = L*y or U**T*y * IF( UPPER ) THEN TRANS = 'T' ELSE TRANS = 'N' END IF * CALL DTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, M, ONE, B, $ LDB, Z, LDZ ) END IF END IF * * Set WORK(1) to optimal workspace size. * WORK( 1 ) = LWKOPT * RETURN * * End of DSYGVX * END *> \brief \b DSYRFS * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSYRFS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, * X, LDX, FERR, BERR, WORK, IWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * 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, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSYRFS improves the computed solution to a system of linear *> equations when the coefficient matrix is symmetric indefinite, and *> provides error bounds and backward error estimates for the solution. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrices B and X. NRHS >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The symmetric matrix A. If UPLO = 'U', the leading N-by-N *> upper triangular part of A contains the upper triangular part *> of the matrix A, and the strictly lower triangular part of A *> is not referenced. If UPLO = 'L', the leading N-by-N lower *> triangular part of A contains the lower triangular part of *> the matrix A, and the strictly upper triangular part of A is *> not referenced. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in] AF *> \verbatim *> AF is DOUBLE PRECISION array, dimension (LDAF,N) *> The factored form of the matrix A. AF contains the block *> diagonal matrix D and the multipliers used to obtain the *> factor U or L from the factorization A = U*D*U**T or *> A = L*D*L**T as computed by DSYTRF. *> \endverbatim *> *> \param[in] LDAF *> \verbatim *> LDAF is INTEGER *> The leading dimension of the array AF. LDAF >= max(1,N). *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N) *> Details of the interchanges and the block structure of D *> as determined by DSYTRF. *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> The right hand side matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in,out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,NRHS) *> On entry, the solution matrix X, as computed by DSYTRS. *> On exit, the improved solution matrix X. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the array X. LDX >= max(1,N). *> \endverbatim *> *> \param[out] FERR *> \verbatim *> FERR is 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. *> \endverbatim *> *> \param[out] BERR *> \verbatim *> BERR is 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). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * *> \par Internal Parameters: * ========================= *> *> \verbatim *> ITMAX is the maximum number of steps of iterative refinement. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleSYcomputational * * ===================================================================== SUBROUTINE DSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, $ X, LDX, FERR, BERR, WORK, IWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO 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, * ) * .. * * ===================================================================== * * .. 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 UPPER 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, DLACN2, DSYMV, DSYTRS, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL LSAME, DLAMCH * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( 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( 'DSYRFS', -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 * * 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 - A * X * CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 ) CALL DSYMV( UPLO, 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(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(A)*abs(X) + abs(B). * IF( UPPER ) THEN DO 50 K = 1, N S = ZERO XK = ABS( X( K, J ) ) DO 40 I = 1, K - 1 WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK S = S + ABS( A( I, K ) )*ABS( X( I, J ) ) 40 CONTINUE WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK + S 50 CONTINUE ELSE DO 70 K = 1, N S = ZERO XK = ABS( X( K, J ) ) WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK DO 60 I = K + 1, N WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK 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 DSYTRS( UPLO, 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(A))* * ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) * * where * norm(Z) is the magnitude of the largest component of Z * inv(A) is the inverse of 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(A)*abs(X)+abs(B)) * is incremented by SAFE1 if the i-th component of * abs(A)*abs(X) + abs(B) is less than SAFE2. * * Use DLACN2 to estimate the infinity-norm of the matrix * inv(A) * diag(W), * where W = abs(R) + NZ*EPS*( abs(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(A**T). * CALL DSYTRS( UPLO, 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 IF( KASE.EQ.2 ) THEN * * Multiply by inv(A)*diag(W). * DO 120 I = 1, N WORK( N+I ) = WORK( I )*WORK( N+I ) 120 CONTINUE CALL DSYTRS( UPLO, 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 DSYRFS * END *> \brief DSYSV computes the solution to system of linear equations A * X = B for SY matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSYSV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, * LWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, LWORK, N, NRHS * .. * .. Array Arguments .. * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSYSV computes the solution to a real system of linear equations *> A * X = B, *> where A is an N-by-N symmetric matrix and X and B are N-by-NRHS *> matrices. *> *> The diagonal pivoting method is used to factor A as *> A = U * D * U**T, if UPLO = 'U', or *> A = L * D * L**T, if UPLO = 'L', *> where U (or L) is a product of permutation and unit upper (lower) *> triangular matrices, and D is symmetric and block diagonal with *> 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then *> used to solve the system of equations A * X = B. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of linear equations, i.e., the order of the *> matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrix B. NRHS >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the symmetric matrix A. If UPLO = 'U', the leading *> N-by-N upper triangular part of A contains the upper *> triangular part of the matrix A, and the strictly lower *> triangular part of A is not referenced. If UPLO = 'L', the *> leading N-by-N lower triangular part of A contains the lower *> triangular part of the matrix A, and the strictly upper *> triangular part of A is not referenced. *> *> On exit, if INFO = 0, the block diagonal matrix D and the *> multipliers used to obtain the factor U or L from the *> factorization A = U*D*U**T or A = L*D*L**T as computed by *> DSYTRF. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N) *> Details of the interchanges and the block structure of D, as *> determined by DSYTRF. If IPIV(k) > 0, then rows and columns *> k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1 *> diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, *> then rows and columns k-1 and -IPIV(k) were interchanged and *> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and *> IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and *> -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 *> diagonal block. *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> On entry, the N-by-NRHS right hand side matrix B. *> On exit, if INFO = 0, the N-by-NRHS solution matrix X. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The length of WORK. LWORK >= 1, and for best performance *> LWORK >= max(1,N*NB), where NB is the optimal blocksize for *> DSYTRF. *> for LWORK < N, TRS will be done with Level BLAS 2 *> for LWORK >= N, TRS will be done with Level BLAS 3 *> *> 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, D(i,i) is exactly zero. The factorization *> has been completed, but the block diagonal matrix D is *> exactly singular, so the solution could not be computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleSYsolve * * ===================================================================== SUBROUTINE DSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, $ LWORK, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, LDB, LWORK, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL LQUERY INTEGER LWKOPT * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, DSYTRF, DSYTRS, DSYTRS2 * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) 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 ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN INFO = -10 END IF * IF( INFO.EQ.0 ) THEN IF( N.EQ.0 ) THEN LWKOPT = 1 ELSE CALL DSYTRF( UPLO, N, A, LDA, IPIV, WORK, -1, INFO ) LWKOPT = WORK(1) END IF WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYSV ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Compute the factorization A = U*D*U**T or A = L*D*L**T. * CALL DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) IF( INFO.EQ.0 ) THEN * * Solve the system A*X = B, overwriting B with X. * IF ( LWORK.LT.N ) THEN * * Solve with TRS ( Use Level BLAS 2) * CALL DSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * ELSE * * Solve with TRS2 ( Use Level BLAS 3) * CALL DSYTRS2( UPLO,N,NRHS,A,LDA,IPIV,B,LDB,WORK,INFO ) * END IF * END IF * WORK( 1 ) = LWKOPT * RETURN * * End of DSYSV * END *> \brief DSYSVX computes the solution to system of linear equations A * X = B for SY matrices * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSYSVX + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, * LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, * IWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER FACT, UPLO * INTEGER INFO, LDA, LDAF, LDB, LDX, LWORK, N, NRHS * DOUBLE PRECISION RCOND * .. * .. Array Arguments .. * INTEGER IPIV( * ), IWORK( * ) * DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), * $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSYSVX uses the diagonal pivoting factorization to compute the *> solution to a real system of linear equations A * X = B, *> where A is an N-by-N symmetric matrix and X and B are N-by-NRHS *> matrices. *> *> Error bounds on the solution and a condition estimate are also *> provided. *> \endverbatim * *> \par Description: * ================= *> *> \verbatim *> *> The following steps are performed: *> *> 1. If FACT = 'N', the diagonal pivoting method is used to factor A. *> The form of the factorization is *> A = U * D * U**T, if UPLO = 'U', or *> A = L * D * L**T, if UPLO = 'L', *> where U (or L) is a product of permutation and unit upper (lower) *> triangular matrices, and D is symmetric and block diagonal with *> 1-by-1 and 2-by-2 diagonal blocks. *> *> 2. If some D(i,i)=0, so that D 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. *> \endverbatim * * Arguments: * ========== * *> \param[in] FACT *> \verbatim *> FACT is CHARACTER*1 *> Specifies whether or not the factored form of A has been *> supplied on entry. *> = 'F': On entry, AF and IPIV contain the factored form of *> A. AF and IPIV will not be modified. *> = 'N': The matrix A will be copied to AF and factored. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of linear equations, i.e., the order of the *> matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrices B and X. NRHS >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The symmetric matrix A. If UPLO = 'U', the leading N-by-N *> upper triangular part of A contains the upper triangular part *> of the matrix A, and the strictly lower triangular part of A *> is not referenced. If UPLO = 'L', the leading N-by-N lower *> triangular part of A contains the lower triangular part of *> the matrix A, and the strictly upper triangular part of A is *> not referenced. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] AF *> \verbatim *> AF is DOUBLE PRECISION array, dimension (LDAF,N) *> If FACT = 'F', then AF is an input argument and on entry *> contains the block diagonal matrix D and the multipliers used *> to obtain the factor U or L from the factorization *> A = U*D*U**T or A = L*D*L**T as computed by DSYTRF. *> *> If FACT = 'N', then AF is an output argument and on exit *> returns the block diagonal matrix D and the multipliers used *> to obtain the factor U or L from the factorization *> A = U*D*U**T or A = L*D*L**T. *> \endverbatim *> *> \param[in] LDAF *> \verbatim *> LDAF is INTEGER *> The leading dimension of the array AF. LDAF >= max(1,N). *> \endverbatim *> *> \param[in,out] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N) *> If FACT = 'F', then IPIV is an input argument and on entry *> contains details of the interchanges and the block structure *> of D, as determined by DSYTRF. *> If IPIV(k) > 0, then rows and columns k and IPIV(k) were *> interchanged and D(k,k) is a 1-by-1 diagonal block. *> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and *> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) *> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = *> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were *> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. *> *> If FACT = 'N', then IPIV is an output argument and on exit *> contains details of the interchanges and the block structure *> of D, as determined by DSYTRF. *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> The N-by-NRHS right hand side matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,NRHS) *> If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the array X. LDX >= max(1,N). *> \endverbatim *> *> \param[out] RCOND *> \verbatim *> RCOND is 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. *> \endverbatim *> *> \param[out] FERR *> \verbatim *> FERR is 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. *> \endverbatim *> *> \param[out] BERR *> \verbatim *> BERR is 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). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The length of WORK. LWORK >= max(1,3*N), and for best *> performance, when FACT = 'N', LWORK >= max(1,3*N,N*NB), where *> NB is the optimal blocksize for DSYTRF. *> *> 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. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, and i is *> <= N: D(i,i) is exactly zero. The factorization *> has been completed but the factor D is exactly *> singular, so the solution and error bounds could *> not be computed. RCOND = 0 is returned. *> = N+1: D 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. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date April 2012 * *> \ingroup doubleSYsolve * * ===================================================================== SUBROUTINE DSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, $ LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, $ IWORK, INFO ) * * -- LAPACK driver routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * April 2012 * * .. Scalar Arguments .. CHARACTER FACT, UPLO INTEGER INFO, LDA, LDAF, LDB, LDX, LWORK, N, NRHS DOUBLE PRECISION RCOND * .. * .. Array Arguments .. INTEGER IPIV( * ), IWORK( * ) DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, NOFACT INTEGER LWKOPT, NB DOUBLE PRECISION ANORM * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANSY EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY * .. * .. External Subroutines .. EXTERNAL DLACPY, DSYCON, DSYRFS, DSYTRF, DSYTRS, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 NOFACT = LSAME( FACT, 'N' ) LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN INFO = -1 ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) $ THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( NRHS.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -13 ELSE IF( LWORK.LT.MAX( 1, 3*N ) .AND. .NOT.LQUERY ) THEN INFO = -18 END IF * IF( INFO.EQ.0 ) THEN LWKOPT = MAX( 1, 3*N ) IF( NOFACT ) THEN NB = ILAENV( 1, 'DSYTRF', UPLO, N, -1, -1, -1 ) LWKOPT = MAX( LWKOPT, N*NB ) END IF WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYSVX', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * IF( NOFACT ) THEN * * Compute the factorization A = U*D*U**T or A = L*D*L**T. * CALL DLACPY( UPLO, N, N, A, LDA, AF, LDAF ) CALL DSYTRF( UPLO, N, AF, LDAF, IPIV, WORK, LWORK, 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. * ANORM = DLANSY( 'I', UPLO, N, A, LDA, WORK ) * * Compute the reciprocal of the condition number of A. * CALL DSYCON( UPLO, N, AF, LDAF, IPIV, ANORM, RCOND, WORK, IWORK, $ INFO ) * * Compute the solution vectors X. * CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) CALL DSYTRS( UPLO, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO ) * * Use iterative refinement to improve the computed solutions and * compute error bounds and backward error estimates for them. * CALL DSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, 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 * WORK( 1 ) = LWKOPT * RETURN * * End of DSYSVX * END *> \brief \b DSYSWAPR applies an elementary permutation on the rows and columns of a symmetric matrix. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSYSWAPR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYSWAPR( UPLO, N, A, LDA, I1, I2) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER I1, I2, LDA, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, N ) * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSYSWAPR applies an elementary permutation on the rows and the columns of *> a symmetric matrix. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the details of the factorization are stored *> as an upper or lower triangular matrix. *> = 'U': Upper triangular, form is A = U*D*U**T; *> = 'L': Lower triangular, form is A = L*D*L**T. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the NB diagonal matrix D and the multipliers *> used to obtain the factor U or L as computed by DSYTRF. *> *> On exit, if INFO = 0, the (symmetric) inverse of the original *> matrix. If UPLO = 'U', the upper triangular part of the *> inverse is formed and the part of A below the diagonal is not *> referenced; if UPLO = 'L' the lower triangular part of the *> inverse is formed and the part of A above the diagonal is *> not referenced. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in] I1 *> \verbatim *> I1 is INTEGER *> Index of the first row to swap *> \endverbatim *> *> \param[in] I2 *> \verbatim *> I2 is INTEGER *> Index of the second row to swap *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleSYauxiliary * * ===================================================================== SUBROUTINE DSYSWAPR( UPLO, N, A, LDA, I1, I2) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER I1, I2, LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, N ) * * ===================================================================== * * .. * .. Local Scalars .. LOGICAL UPPER INTEGER I DOUBLE PRECISION TMP * * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DSWAP * .. * .. Executable Statements .. * UPPER = LSAME( UPLO, 'U' ) IF (UPPER) THEN * * UPPER * first swap * - swap column I1 and I2 from I1 to I1-1 CALL DSWAP( I1-1, A(1,I1), 1, A(1,I2), 1 ) * * second swap : * - swap A(I1,I1) and A(I2,I2) * - swap row I1 from I1+1 to I2-1 with col I2 from I1+1 to I2-1 TMP=A(I1,I1) A(I1,I1)=A(I2,I2) A(I2,I2)=TMP * DO I=1,I2-I1-1 TMP=A(I1,I1+I) A(I1,I1+I)=A(I1+I,I2) A(I1+I,I2)=TMP END DO * * third swap * - swap row I1 and I2 from I2+1 to N DO I=I2+1,N TMP=A(I1,I) A(I1,I)=A(I2,I) A(I2,I)=TMP END DO * ELSE * * LOWER * first swap * - swap row I1 and I2 from I1 to I1-1 CALL DSWAP( I1-1, A(I1,1), LDA, A(I2,1), LDA ) * * second swap : * - swap A(I1,I1) and A(I2,I2) * - swap col I1 from I1+1 to I2-1 with row I2 from I1+1 to I2-1 TMP=A(I1,I1) A(I1,I1)=A(I2,I2) A(I2,I2)=TMP * DO I=1,I2-I1-1 TMP=A(I1+I,I1) A(I1+I,I1)=A(I2,I1+I) A(I2,I1+I)=TMP END DO * * third swap * - swap col I1 and I2 from I2+1 to N DO I=I2+1,N TMP=A(I,I1) A(I,I1)=A(I,I2) A(I,I2)=TMP END DO * ENDIF END SUBROUTINE DSYSWAPR *> \brief \b DSYTD2 reduces a symmetric matrix to real symmetric tridiagonal form by an orthogonal similarity transformation (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSYTD2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal *> form T by an orthogonal similarity transformation: Q**T * A * Q = T. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the upper or lower triangular part of the *> symmetric matrix A is stored: *> = 'U': Upper triangular *> = 'L': Lower triangular *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the symmetric matrix A. If UPLO = 'U', the leading *> n-by-n upper triangular part of A contains the upper *> triangular part of the matrix A, and the strictly lower *> triangular part of A is not referenced. If UPLO = 'L', the *> leading n-by-n lower triangular part of A contains the lower *> triangular part of the matrix A, and the strictly upper *> triangular part of A is not referenced. *> On exit, if UPLO = 'U', the diagonal and first superdiagonal *> of A are overwritten by the corresponding elements of the *> tridiagonal matrix T, and the elements above the first *> superdiagonal, with the array TAU, represent the orthogonal *> matrix Q as a product of elementary reflectors; if UPLO *> = 'L', the diagonal and first subdiagonal of A are over- *> written by the corresponding elements of the tridiagonal *> matrix T, and the elements below the first subdiagonal, with *> the array TAU, represent the orthogonal matrix Q as a product *> of elementary reflectors. See Further Details. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The diagonal elements of the tridiagonal matrix T: *> D(i) = A(i,i). *> \endverbatim *> *> \param[out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N-1) *> The off-diagonal elements of the tridiagonal matrix T: *> E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (N-1) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleSYcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> If UPLO = 'U', the matrix Q is represented as a product of elementary *> reflectors *> *> Q = H(n-1) . . . H(2) H(1). *> *> Each H(i) has the form *> *> H(i) = I - tau * v * v**T *> *> where tau is a real scalar, and v is a real vector with *> v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in *> A(1:i-1,i+1), and tau in TAU(i). *> *> If UPLO = 'L', the matrix Q is represented as a product of elementary *> reflectors *> *> Q = H(1) H(2) . . . H(n-1). *> *> Each H(i) has the form *> *> H(i) = I - tau * v * v**T *> *> where tau is a real scalar, and v is a real vector with *> v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), *> and tau in TAU(i). *> *> The contents of A on exit are illustrated by the following examples *> with n = 5: *> *> if UPLO = 'U': if UPLO = 'L': *> *> ( d e v2 v3 v4 ) ( d ) *> ( d e v3 v4 ) ( e d ) *> ( d e v4 ) ( v1 e d ) *> ( d e ) ( v1 v2 e d ) *> ( d ) ( v1 v2 v3 e d ) *> *> where d and e denote diagonal and off-diagonal elements of T, and vi *> denotes an element of the vector defining H(i). *> \endverbatim *> * ===================================================================== SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO, HALF PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0, $ HALF = 1.0D0 / 2.0D0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER I DOUBLE PRECISION ALPHA, TAUI * .. * .. External Subroutines .. EXTERNAL DAXPY, DLARFG, DSYMV, DSYR2, XERBLA * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT EXTERNAL LSAME, DDOT * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYTD2', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.0 ) $ RETURN * IF( UPPER ) THEN * * Reduce the upper triangle of A * DO 10 I = N - 1, 1, -1 * * Generate elementary reflector H(i) = I - tau * v * v**T * to annihilate A(1:i-1,i+1) * CALL DLARFG( I, A( I, I+1 ), A( 1, I+1 ), 1, TAUI ) E( I ) = A( I, I+1 ) * IF( TAUI.NE.ZERO ) THEN * * Apply H(i) from both sides to A(1:i,1:i) * A( I, I+1 ) = ONE * * Compute x := tau * A * v storing x in TAU(1:i) * CALL DSYMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO, $ TAU, 1 ) * * Compute w := x - 1/2 * tau * (x**T * v) * v * ALPHA = -HALF*TAUI*DDOT( I, TAU, 1, A( 1, I+1 ), 1 ) CALL DAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 ) * * Apply the transformation as a rank-2 update: * A := A - v * w**T - w * v**T * CALL DSYR2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A, $ LDA ) * A( I, I+1 ) = E( I ) END IF D( I+1 ) = A( I+1, I+1 ) TAU( I ) = TAUI 10 CONTINUE D( 1 ) = A( 1, 1 ) ELSE * * Reduce the lower triangle of A * DO 20 I = 1, N - 1 * * Generate elementary reflector H(i) = I - tau * v * v**T * to annihilate A(i+2:n,i) * CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, $ TAUI ) E( I ) = A( I+1, I ) * IF( TAUI.NE.ZERO ) THEN * * Apply H(i) from both sides to A(i+1:n,i+1:n) * A( I+1, I ) = ONE * * Compute x := tau * A * v storing y in TAU(i:n-1) * CALL DSYMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA, $ A( I+1, I ), 1, ZERO, TAU( I ), 1 ) * * Compute w := x - 1/2 * tau * (x**T * v) * v * ALPHA = -HALF*TAUI*DDOT( N-I, TAU( I ), 1, A( I+1, I ), $ 1 ) CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 ) * * Apply the transformation as a rank-2 update: * A := A - v * w**T - w * v**T * CALL DSYR2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1, $ A( I+1, I+1 ), LDA ) * A( I+1, I ) = E( I ) END IF D( I ) = A( I, I ) TAU( I ) = TAUI 20 CONTINUE D( N ) = A( N, N ) END IF * RETURN * * End of DSYTD2 * END *> \brief \b DSYTF2 computes the factorization of a real symmetric indefinite matrix, using the diagonal pivoting method (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSYTF2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N * .. * .. Array Arguments .. * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSYTF2 computes the factorization of a real symmetric matrix A using *> the Bunch-Kaufman diagonal pivoting method: *> *> A = U*D*U**T or A = L*D*L**T *> *> where U (or L) is a product of permutation and unit upper (lower) *> triangular matrices, U**T is the transpose of U, and D is symmetric and *> block diagonal with 1-by-1 and 2-by-2 diagonal blocks. *> *> This is the unblocked version of the algorithm, calling Level 2 BLAS. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the upper or lower triangular part of the *> symmetric matrix A is stored: *> = 'U': Upper triangular *> = 'L': Lower triangular *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the symmetric matrix A. If UPLO = 'U', the leading *> n-by-n upper triangular part of A contains the upper *> triangular part of the matrix A, and the strictly lower *> triangular part of A is not referenced. If UPLO = 'L', the *> leading n-by-n lower triangular part of A contains the lower *> triangular part of the matrix A, and the strictly upper *> triangular part of A is not referenced. *> *> On exit, the block diagonal matrix D and the multipliers used *> to obtain the factor U or L (see below for further details). *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N) *> Details of the interchanges and the block structure of D. *> *> If UPLO = 'U': *> If IPIV(k) > 0, then rows and columns k and IPIV(k) were *> interchanged and D(k,k) is a 1-by-1 diagonal block. *> *> If IPIV(k) = IPIV(k-1) < 0, then rows and columns *> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) *> is a 2-by-2 diagonal block. *> *> If UPLO = 'L': *> If IPIV(k) > 0, then rows and columns k and IPIV(k) were *> interchanged and D(k,k) is a 1-by-1 diagonal block. *> *> If IPIV(k) = IPIV(k+1) < 0, then rows and columns *> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1) *> is a 2-by-2 diagonal block. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -k, the k-th argument had an illegal value *> > 0: if INFO = k, D(k,k) is exactly zero. The factorization *> has been completed, but the block diagonal matrix D is *> exactly singular, and division by zero will occur if it *> is used to solve a system of equations. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleSYcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> If UPLO = 'U', then A = U*D*U**T, where *> U = P(n)*U(n)* ... *P(k)U(k)* ..., *> i.e., U is a product of terms P(k)*U(k), where k decreases from n to *> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 *> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as *> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such *> that if the diagonal block D(k) is of order s (s = 1 or 2), then *> *> ( I v 0 ) k-s *> U(k) = ( 0 I 0 ) s *> ( 0 0 I ) n-k *> k-s s n-k *> *> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). *> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), *> and A(k,k), and v overwrites A(1:k-2,k-1:k). *> *> If UPLO = 'L', then A = L*D*L**T, where *> L = P(1)*L(1)* ... *P(k)*L(k)* ..., *> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to *> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 *> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as *> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such *> that if the diagonal block D(k) is of order s (s = 1 or 2), then *> *> ( I 0 0 ) k-1 *> L(k) = ( 0 I 0 ) s *> ( 0 v I ) n-k-s+1 *> k-1 s n-k-s+1 *> *> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). *> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), *> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). *> \endverbatim * *> \par Contributors: * ================== *> *> \verbatim *> *> 09-29-06 - patch from *> Bobby Cheng, MathWorks *> *> Replace l.204 and l.372 *> IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN *> by *> IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN *> *> 01-01-96 - Based on modifications by *> J. Lewis, Boeing Computer Services Company *> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA *> 1-96 - Based on modifications by J. Lewis, Boeing Computer Services *> Company *> \endverbatim * * ===================================================================== SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION EIGHT, SEVTEN PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER I, IMAX, J, JMAX, K, KK, KP, KSTEP DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, R1, $ ROWMAX, T, WK, WKM1, WKP1 * .. * .. External Functions .. LOGICAL LSAME, DISNAN INTEGER IDAMAX EXTERNAL LSAME, IDAMAX, DISNAN * .. * .. External Subroutines .. EXTERNAL DSCAL, DSWAP, DSYR, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYTF2', -INFO ) RETURN END IF * * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT * IF( UPPER ) THEN * * Factorize A as U*D*U**T using the upper triangle of A * * K is the main loop index, decreasing from N to 1 in steps of * 1 or 2 * K = N 10 CONTINUE * * If K < 1, exit from loop * IF( K.LT.1 ) $ GO TO 70 KSTEP = 1 * * Determine rows and columns to be interchanged and whether * a 1-by-1 or 2-by-2 pivot block will be used * ABSAKK = ABS( A( K, K ) ) * * IMAX is the row-index of the largest off-diagonal element in * column K, and COLMAX is its absolute value. * Determine both COLMAX and IMAX. * IF( K.GT.1 ) THEN IMAX = IDAMAX( K-1, A( 1, K ), 1 ) COLMAX = ABS( A( IMAX, K ) ) ELSE COLMAX = ZERO END IF * IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN * * Column K is zero or underflow, or contains a NaN: * set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K KP = K ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * * no interchange, use 1-by-1 pivot block * KP = K ELSE * * JMAX is the column-index of the largest off-diagonal * element in row IMAX, and ROWMAX is its absolute value * JMAX = IMAX + IDAMAX( K-IMAX, A( IMAX, IMAX+1 ), LDA ) ROWMAX = ABS( A( IMAX, JMAX ) ) IF( IMAX.GT.1 ) THEN JMAX = IDAMAX( IMAX-1, A( 1, IMAX ), 1 ) ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) ) END IF * IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN * * no interchange, use 1-by-1 pivot block * KP = K ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN * * interchange rows and columns K and IMAX, use 1-by-1 * pivot block * KP = IMAX ELSE * * interchange rows and columns K-1 and IMAX, use 2-by-2 * pivot block * KP = IMAX KSTEP = 2 END IF END IF * KK = K - KSTEP + 1 IF( KP.NE.KK ) THEN * * Interchange rows and columns KK and KP in the leading * submatrix A(1:k,1:k) * CALL DSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) CALL DSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ), $ LDA ) T = A( KK, KK ) A( KK, KK ) = A( KP, KP ) A( KP, KP ) = T IF( KSTEP.EQ.2 ) THEN T = A( K-1, K ) A( K-1, K ) = A( KP, K ) A( KP, K ) = T END IF END IF * * Update the leading submatrix * IF( KSTEP.EQ.1 ) THEN * * 1-by-1 pivot block D(k): column k now holds * * W(k) = U(k)*D(k) * * where U(k) is the k-th column of U * * Perform a rank-1 update of A(1:k-1,1:k-1) as * * A := A - U(k)*D(k)*U(k)**T = A - W(k)*1/D(k)*W(k)**T * R1 = ONE / A( K, K ) CALL DSYR( UPLO, K-1, -R1, A( 1, K ), 1, A, LDA ) * * Store U(k) in column k * CALL DSCAL( K-1, R1, A( 1, K ), 1 ) ELSE * * 2-by-2 pivot block D(k): columns k and k-1 now hold * * ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) * * where U(k) and U(k-1) are the k-th and (k-1)-th columns * of U * * Perform a rank-2 update of A(1:k-2,1:k-2) as * * A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T * = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )**T * IF( K.GT.2 ) THEN * D12 = A( K-1, K ) D22 = A( K-1, K-1 ) / D12 D11 = A( K, K ) / D12 T = ONE / ( D11*D22-ONE ) D12 = T / D12 * DO 30 J = K - 2, 1, -1 WKM1 = D12*( D11*A( J, K-1 )-A( J, K ) ) WK = D12*( D22*A( J, K )-A( J, K-1 ) ) DO 20 I = J, 1, -1 A( I, J ) = A( I, J ) - A( I, K )*WK - $ A( I, K-1 )*WKM1 20 CONTINUE A( J, K ) = WK A( J, K-1 ) = WKM1 30 CONTINUE * END IF * END IF END IF * * Store details of the interchanges in IPIV * IF( KSTEP.EQ.1 ) THEN IPIV( K ) = KP ELSE IPIV( K ) = -KP IPIV( K-1 ) = -KP END IF * * Decrease K and return to the start of the main loop * K = K - KSTEP GO TO 10 * ELSE * * Factorize A as L*D*L**T using the lower triangle of A * * K is the main loop index, increasing from 1 to N in steps of * 1 or 2 * K = 1 40 CONTINUE * * If K > N, exit from loop * IF( K.GT.N ) $ GO TO 70 KSTEP = 1 * * Determine rows and columns to be interchanged and whether * a 1-by-1 or 2-by-2 pivot block will be used * ABSAKK = ABS( A( K, K ) ) * * IMAX is the row-index of the largest off-diagonal element in * column K, and COLMAX is its absolute value. * Determine both COLMAX and IMAX. * IF( K.LT.N ) THEN IMAX = K + IDAMAX( N-K, A( K+1, K ), 1 ) COLMAX = ABS( A( IMAX, K ) ) ELSE COLMAX = ZERO END IF * IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN * * Column K is zero or underflow, or contains a NaN: * set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K KP = K ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * * no interchange, use 1-by-1 pivot block * KP = K ELSE * * JMAX is the column-index of the largest off-diagonal * element in row IMAX, and ROWMAX is its absolute value * JMAX = K - 1 + IDAMAX( IMAX-K, A( IMAX, K ), LDA ) ROWMAX = ABS( A( IMAX, JMAX ) ) IF( IMAX.LT.N ) THEN JMAX = IMAX + IDAMAX( N-IMAX, A( IMAX+1, IMAX ), 1 ) ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) ) END IF * IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN * * no interchange, use 1-by-1 pivot block * KP = K ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN * * interchange rows and columns K and IMAX, use 1-by-1 * pivot block * KP = IMAX ELSE * * interchange rows and columns K+1 and IMAX, use 2-by-2 * pivot block * KP = IMAX KSTEP = 2 END IF END IF * KK = K + KSTEP - 1 IF( KP.NE.KK ) THEN * * Interchange rows and columns KK and KP in the trailing * submatrix A(k:n,k:n) * IF( KP.LT.N ) $ CALL DSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) CALL DSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), $ LDA ) T = A( KK, KK ) A( KK, KK ) = A( KP, KP ) A( KP, KP ) = T IF( KSTEP.EQ.2 ) THEN T = A( K+1, K ) A( K+1, K ) = A( KP, K ) A( KP, K ) = T END IF END IF * * Update the trailing submatrix * IF( KSTEP.EQ.1 ) THEN * * 1-by-1 pivot block D(k): column k now holds * * W(k) = L(k)*D(k) * * where L(k) is the k-th column of L * IF( K.LT.N ) THEN * * Perform a rank-1 update of A(k+1:n,k+1:n) as * * A := A - L(k)*D(k)*L(k)**T = A - W(k)*(1/D(k))*W(k)**T * D11 = ONE / A( K, K ) CALL DSYR( UPLO, N-K, -D11, A( K+1, K ), 1, $ A( K+1, K+1 ), LDA ) * * Store L(k) in column K * CALL DSCAL( N-K, D11, A( K+1, K ), 1 ) END IF ELSE * * 2-by-2 pivot block D(k) * IF( K.LT.N-1 ) THEN * * Perform a rank-2 update of A(k+2:n,k+2:n) as * * A := A - ( (A(k) A(k+1))*D(k)**(-1) ) * (A(k) A(k+1))**T * * where L(k) and L(k+1) are the k-th and (k+1)-th * columns of L * D21 = A( K+1, K ) D11 = A( K+1, K+1 ) / D21 D22 = A( K, K ) / D21 T = ONE / ( D11*D22-ONE ) D21 = T / D21 * DO 60 J = K + 2, N * WK = D21*( D11*A( J, K )-A( J, K+1 ) ) WKP1 = D21*( D22*A( J, K+1 )-A( J, K ) ) * DO 50 I = J, N A( I, J ) = A( I, J ) - A( I, K )*WK - $ A( I, K+1 )*WKP1 50 CONTINUE * A( J, K ) = WK A( J, K+1 ) = WKP1 * 60 CONTINUE END IF END IF END IF * * Store details of the interchanges in IPIV * IF( KSTEP.EQ.1 ) THEN IPIV( K ) = KP ELSE IPIV( K ) = -KP IPIV( K+1 ) = -KP END IF * * Increase K and return to the start of the main loop * K = K + KSTEP GO TO 40 * END IF * 70 CONTINUE * RETURN * * End of DSYTF2 * END *> \brief \b DSYTRD * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSYTRD + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LWORK, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSYTRD reduces a real symmetric matrix A to real symmetric *> tridiagonal form T by an orthogonal similarity transformation: *> Q**T * A * Q = T. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the symmetric matrix A. If UPLO = 'U', the leading *> N-by-N upper triangular part of A contains the upper *> triangular part of the matrix A, and the strictly lower *> triangular part of A is not referenced. If UPLO = 'L', the *> leading N-by-N lower triangular part of A contains the lower *> triangular part of the matrix A, and the strictly upper *> triangular part of A is not referenced. *> On exit, if UPLO = 'U', the diagonal and first superdiagonal *> of A are overwritten by the corresponding elements of the *> tridiagonal matrix T, and the elements above the first *> superdiagonal, with the array TAU, represent the orthogonal *> matrix Q as a product of elementary reflectors; if UPLO *> = 'L', the diagonal and first subdiagonal of A are over- *> written by the corresponding elements of the tridiagonal *> matrix T, and the elements below the first subdiagonal, with *> the array TAU, represent the orthogonal matrix Q as a product *> of elementary reflectors. See Further Details. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (N) *> The diagonal elements of the tridiagonal matrix T: *> D(i) = A(i,i). *> \endverbatim *> *> \param[out] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (N-1) *> The off-diagonal elements of the tridiagonal matrix T: *> E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (N-1) *> The scalar factors of the elementary reflectors (see Further *> Details). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= 1. *> For optimum performance LWORK >= N*NB, where NB is the *> optimal blocksize. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error *> message related to LWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleSYcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> If UPLO = 'U', the matrix Q is represented as a product of elementary *> reflectors *> *> Q = H(n-1) . . . H(2) H(1). *> *> Each H(i) has the form *> *> H(i) = I - tau * v * v**T *> *> where tau is a real scalar, and v is a real vector with *> v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in *> A(1:i-1,i+1), and tau in TAU(i). *> *> If UPLO = 'L', the matrix Q is represented as a product of elementary *> reflectors *> *> Q = H(1) H(2) . . . H(n-1). *> *> Each H(i) has the form *> *> H(i) = I - tau * v * v**T *> *> where tau is a real scalar, and v is a real vector with *> v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), *> and tau in TAU(i). *> *> The contents of A on exit are illustrated by the following examples *> with n = 5: *> *> if UPLO = 'U': if UPLO = 'L': *> *> ( d e v2 v3 v4 ) ( d ) *> ( d e v3 v4 ) ( e d ) *> ( d e v4 ) ( v1 e d ) *> ( d e ) ( v1 v2 e d ) *> ( d ) ( v1 v2 v3 e d ) *> *> where d and e denote diagonal and off-diagonal elements of T, and vi *> denotes an element of the vector defining H(i). *> \endverbatim *> * ===================================================================== SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ), $ WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, UPPER INTEGER I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB, $ NBMIN, NX * .. * .. External Subroutines .. EXTERNAL DLATRD, DSYR2K, DSYTD2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 UPPER = LSAME( UPLO, 'U' ) LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN INFO = -9 END IF * IF( INFO.EQ.0 ) THEN * * Determine the block size. * NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) LWKOPT = N*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYTRD', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NX = N IWS = 1 IF( NB.GT.1 .AND. NB.LT.N ) THEN * * Determine when to cross over from blocked to unblocked code * (last block is always handled by unblocked code). * NX = MAX( NB, ILAENV( 3, 'DSYTRD', UPLO, N, -1, -1, -1 ) ) IF( NX.LT.N ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = N IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: determine the * minimum value of NB, and reduce NB or force use of * unblocked code by setting NX = N. * NB = MAX( LWORK / LDWORK, 1 ) NBMIN = ILAENV( 2, 'DSYTRD', UPLO, N, -1, -1, -1 ) IF( NB.LT.NBMIN ) $ NX = N END IF ELSE NX = N END IF ELSE NB = 1 END IF * IF( UPPER ) THEN * * Reduce the upper triangle of A. * Columns 1:kk are handled by the unblocked method. * KK = N - ( ( N-NX+NB-1 ) / NB )*NB DO 20 I = N - NB + 1, KK + 1, -NB * * Reduce columns i:i+nb-1 to tridiagonal form and form the * matrix W which is needed to update the unreduced part of * the matrix * CALL DLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK, $ LDWORK ) * * Update the unreduced submatrix A(1:i-1,1:i-1), using an * update of the form: A := A - V*W**T - W*V**T * CALL DSYR2K( UPLO, 'No transpose', I-1, NB, -ONE, A( 1, I ), $ LDA, WORK, LDWORK, ONE, A, LDA ) * * Copy superdiagonal elements back into A, and diagonal * elements into D * DO 10 J = I, I + NB - 1 A( J-1, J ) = E( J-1 ) D( J ) = A( J, J ) 10 CONTINUE 20 CONTINUE * * Use unblocked code to reduce the last or only block * CALL DSYTD2( UPLO, KK, A, LDA, D, E, TAU, IINFO ) ELSE * * Reduce the lower triangle of A * DO 40 I = 1, N - NX, NB * * Reduce columns i:i+nb-1 to tridiagonal form and form the * matrix W which is needed to update the unreduced part of * the matrix * CALL DLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ), $ TAU( I ), WORK, LDWORK ) * * Update the unreduced submatrix A(i+ib:n,i+ib:n), using * an update of the form: A := A - V*W**T - W*V**T * CALL DSYR2K( UPLO, 'No transpose', N-I-NB+1, NB, -ONE, $ A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE, $ A( I+NB, I+NB ), LDA ) * * Copy subdiagonal elements back into A, and diagonal * elements into D * DO 30 J = I, I + NB - 1 A( J+1, J ) = E( J ) D( J ) = A( J, J ) 30 CONTINUE 40 CONTINUE * * Use unblocked code to reduce the last or only block * CALL DSYTD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ), $ TAU( I ), IINFO ) END IF * WORK( 1 ) = LWKOPT RETURN * * End of DSYTRD * END *> \brief \b DSYTRF * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSYTRF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LWORK, N * .. * .. Array Arguments .. * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSYTRF computes the factorization of a real symmetric matrix A using *> the Bunch-Kaufman diagonal pivoting method. The form of the *> factorization is *> *> A = U*D*U**T or A = L*D*L**T *> *> where U (or L) is a product of permutation and unit upper (lower) *> triangular matrices, and D is symmetric and block diagonal with *> 1-by-1 and 2-by-2 diagonal blocks. *> *> This is the blocked version of the algorithm, calling Level 3 BLAS. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the symmetric matrix A. If UPLO = 'U', the leading *> N-by-N upper triangular part of A contains the upper *> triangular part of the matrix A, and the strictly lower *> triangular part of A is not referenced. If UPLO = 'L', the *> leading N-by-N lower triangular part of A contains the lower *> triangular part of the matrix A, and the strictly upper *> triangular part of A is not referenced. *> *> On exit, the block diagonal matrix D and the multipliers used *> to obtain the factor U or L (see below for further details). *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N) *> Details of the interchanges and the block structure of D. *> If IPIV(k) > 0, then rows and columns k and IPIV(k) were *> interchanged and D(k,k) is a 1-by-1 diagonal block. *> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and *> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) *> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = *> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were *> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The length of WORK. LWORK >=1. For best performance *> LWORK >= N*NB, where NB is the block size returned by ILAENV. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error *> message related to LWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, D(i,i) is exactly zero. The factorization *> has been completed, but the block diagonal matrix D is *> exactly singular, and division by zero will occur if it *> is used to solve a system of equations. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleSYcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> If UPLO = 'U', then A = U*D*U**T, where *> U = P(n)*U(n)* ... *P(k)U(k)* ..., *> i.e., U is a product of terms P(k)*U(k), where k decreases from n to *> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 *> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as *> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such *> that if the diagonal block D(k) is of order s (s = 1 or 2), then *> *> ( I v 0 ) k-s *> U(k) = ( 0 I 0 ) s *> ( 0 0 I ) n-k *> k-s s n-k *> *> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). *> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), *> and A(k,k), and v overwrites A(1:k-2,k-1:k). *> *> If UPLO = 'L', then A = L*D*L**T, where *> L = P(1)*L(1)* ... *P(k)*L(k)* ..., *> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to *> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 *> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as *> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such *> that if the diagonal block D(k) is of order s (s = 1 or 2), then *> *> ( I 0 0 ) k-1 *> L(k) = ( 0 I 0 ) s *> ( 0 v I ) n-k-s+1 *> k-1 s n-k-s+1 *> *> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). *> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), *> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). *> \endverbatim *> * ===================================================================== SUBROUTINE DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, LWORK, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL LQUERY, UPPER INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DLASYF, DSYTF2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN INFO = -7 END IF * IF( INFO.EQ.0 ) THEN * * Determine the block size * NB = ILAENV( 1, 'DSYTRF', UPLO, N, -1, -1, -1 ) LWKOPT = N*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYTRF', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * NBMIN = 2 LDWORK = N IF( NB.GT.1 .AND. NB.LT.N ) THEN IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN NB = MAX( LWORK / LDWORK, 1 ) NBMIN = MAX( 2, ILAENV( 2, 'DSYTRF', UPLO, N, -1, -1, -1 ) ) END IF ELSE IWS = 1 END IF IF( NB.LT.NBMIN ) $ NB = N * IF( UPPER ) THEN * * Factorize A as U*D*U**T using the upper triangle of A * * K is the main loop index, decreasing from N to 1 in steps of * KB, where KB is the number of columns factorized by DLASYF; * KB is either NB or NB-1, or K for the last block * K = N 10 CONTINUE * * If K < 1, exit from loop * IF( K.LT.1 ) $ GO TO 40 * IF( K.GT.NB ) THEN * * Factorize columns k-kb+1:k of A and use blocked code to * update columns 1:k-kb * CALL DLASYF( UPLO, K, NB, KB, A, LDA, IPIV, WORK, LDWORK, $ IINFO ) ELSE * * Use unblocked code to factorize columns 1:k of A * CALL DSYTF2( UPLO, K, A, LDA, IPIV, IINFO ) KB = K END IF * * Set INFO on the first occurrence of a zero pivot * IF( INFO.EQ.0 .AND. IINFO.GT.0 ) $ INFO = IINFO * * Decrease K and return to the start of the main loop * K = K - KB GO TO 10 * ELSE * * Factorize A as L*D*L**T using the lower triangle of A * * K is the main loop index, increasing from 1 to N in steps of * KB, where KB is the number of columns factorized by DLASYF; * KB is either NB or NB-1, or N-K+1 for the last block * K = 1 20 CONTINUE * * If K > N, exit from loop * IF( K.GT.N ) $ GO TO 40 * IF( K.LE.N-NB ) THEN * * Factorize columns k:k+kb-1 of A and use blocked code to * update columns k+kb:n * CALL DLASYF( UPLO, N-K+1, NB, KB, A( K, K ), LDA, IPIV( K ), $ WORK, LDWORK, IINFO ) ELSE * * Use unblocked code to factorize columns k:n of A * CALL DSYTF2( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ), IINFO ) KB = N - K + 1 END IF * * Set INFO on the first occurrence of a zero pivot * IF( INFO.EQ.0 .AND. IINFO.GT.0 ) $ INFO = IINFO + K - 1 * * Adjust IPIV * DO 30 J = K, K + KB - 1 IF( IPIV( J ).GT.0 ) THEN IPIV( J ) = IPIV( J ) + K - 1 ELSE IPIV( J ) = IPIV( J ) - K + 1 END IF 30 CONTINUE * * Increase K and return to the start of the main loop * K = K + KB GO TO 20 * END IF * 40 CONTINUE WORK( 1 ) = LWKOPT RETURN * * End of DSYTRF * END *> \brief \b DSYTRI * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSYTRI + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N * .. * .. Array Arguments .. * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSYTRI computes the inverse of a real symmetric indefinite matrix *> A using the factorization A = U*D*U**T or A = L*D*L**T computed by *> DSYTRF. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the details of the factorization are stored *> as an upper or lower triangular matrix. *> = 'U': Upper triangular, form is A = U*D*U**T; *> = 'L': Lower triangular, form is A = L*D*L**T. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the block diagonal matrix D and the multipliers *> used to obtain the factor U or L as computed by DSYTRF. *> *> On exit, if INFO = 0, the (symmetric) inverse of the original *> matrix. If UPLO = 'U', the upper triangular part of the *> inverse is formed and the part of A below the diagonal is not *> referenced; if UPLO = 'L' the lower triangular part of the *> inverse is formed and the part of A above the diagonal is *> not referenced. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N) *> Details of the interchanges and the block structure of D *> as determined by DSYTRF. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its *> inverse could not be computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleSYcomputational * * ===================================================================== SUBROUTINE DSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER K, KP, KSTEP DOUBLE PRECISION AK, AKKP1, AKP1, D, T, TEMP * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT EXTERNAL LSAME, DDOT * .. * .. External Subroutines .. EXTERNAL DCOPY, DSWAP, DSYMV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYTRI', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Check that the diagonal matrix D is nonsingular. * IF( UPPER ) THEN * * Upper triangular storage: examine D from bottom to top * DO 10 INFO = N, 1, -1 IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) $ RETURN 10 CONTINUE ELSE * * Lower triangular storage: examine D from top to bottom. * DO 20 INFO = 1, N IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) $ RETURN 20 CONTINUE END IF INFO = 0 * IF( UPPER ) THEN * * Compute inv(A) from the factorization A = U*D*U**T. * * K is the main loop index, increasing from 1 to N in steps of * 1 or 2, depending on the size of the diagonal blocks. * K = 1 30 CONTINUE * * If K > N, exit from loop. * IF( K.GT.N ) $ GO TO 40 * IF( IPIV( K ).GT.0 ) THEN * * 1 x 1 diagonal block * * Invert the diagonal block. * A( K, K ) = ONE / A( K, K ) * * Compute column K of the inverse. * IF( K.GT.1 ) THEN CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 ) CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, $ A( 1, K ), 1 ) A( K, K ) = A( K, K ) - DDOT( K-1, WORK, 1, A( 1, K ), $ 1 ) END IF KSTEP = 1 ELSE * * 2 x 2 diagonal block * * Invert the diagonal block. * T = ABS( A( K, K+1 ) ) AK = A( K, K ) / T AKP1 = A( K+1, K+1 ) / T AKKP1 = A( K, K+1 ) / T D = T*( AK*AKP1-ONE ) A( K, K ) = AKP1 / D A( K+1, K+1 ) = AK / D A( K, K+1 ) = -AKKP1 / D * * Compute columns K and K+1 of the inverse. * IF( K.GT.1 ) THEN CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 ) CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, $ A( 1, K ), 1 ) A( K, K ) = A( K, K ) - DDOT( K-1, WORK, 1, A( 1, K ), $ 1 ) A( K, K+1 ) = A( K, K+1 ) - $ DDOT( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 ) CALL DCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 ) CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, $ A( 1, K+1 ), 1 ) A( K+1, K+1 ) = A( K+1, K+1 ) - $ DDOT( K-1, WORK, 1, A( 1, K+1 ), 1 ) END IF KSTEP = 2 END IF * KP = ABS( IPIV( K ) ) IF( KP.NE.K ) THEN * * Interchange rows and columns K and KP in the leading * submatrix A(1:k+1,1:k+1) * CALL DSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) CALL DSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA ) TEMP = A( K, K ) A( K, K ) = A( KP, KP ) A( KP, KP ) = TEMP IF( KSTEP.EQ.2 ) THEN TEMP = A( K, K+1 ) A( K, K+1 ) = A( KP, K+1 ) A( KP, K+1 ) = TEMP END IF END IF * K = K + KSTEP GO TO 30 40 CONTINUE * ELSE * * Compute inv(A) from the factorization A = L*D*L**T. * * K is the main loop index, increasing from 1 to N in steps of * 1 or 2, depending on the size of the diagonal blocks. * K = N 50 CONTINUE * * If K < 1, exit from loop. * IF( K.LT.1 ) $ GO TO 60 * IF( IPIV( K ).GT.0 ) THEN * * 1 x 1 diagonal block * * Invert the diagonal block. * A( K, K ) = ONE / A( K, K ) * * Compute column K of the inverse. * IF( K.LT.N ) THEN CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 ) CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, $ ZERO, A( K+1, K ), 1 ) A( K, K ) = A( K, K ) - DDOT( N-K, WORK, 1, A( K+1, K ), $ 1 ) END IF KSTEP = 1 ELSE * * 2 x 2 diagonal block * * Invert the diagonal block. * T = ABS( A( K, K-1 ) ) AK = A( K-1, K-1 ) / T AKP1 = A( K, K ) / T AKKP1 = A( K, K-1 ) / T D = T*( AK*AKP1-ONE ) A( K-1, K-1 ) = AKP1 / D A( K, K ) = AK / D A( K, K-1 ) = -AKKP1 / D * * Compute columns K-1 and K of the inverse. * IF( K.LT.N ) THEN CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 ) CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, $ ZERO, A( K+1, K ), 1 ) A( K, K ) = A( K, K ) - DDOT( N-K, WORK, 1, A( K+1, K ), $ 1 ) A( K, K-1 ) = A( K, K-1 ) - $ DDOT( N-K, A( K+1, K ), 1, A( K+1, K-1 ), $ 1 ) CALL DCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 ) CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, $ ZERO, A( K+1, K-1 ), 1 ) A( K-1, K-1 ) = A( K-1, K-1 ) - $ DDOT( N-K, WORK, 1, A( K+1, K-1 ), 1 ) END IF KSTEP = 2 END IF * KP = ABS( IPIV( K ) ) IF( KP.NE.K ) THEN * * Interchange rows and columns K and KP in the trailing * submatrix A(k-1:n,k-1:n) * IF( KP.LT.N ) $ CALL DSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 ) CALL DSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA ) TEMP = A( K, K ) A( K, K ) = A( KP, KP ) A( KP, KP ) = TEMP IF( KSTEP.EQ.2 ) THEN TEMP = A( K, K-1 ) A( K, K-1 ) = A( KP, K-1 ) A( KP, K-1 ) = TEMP END IF END IF * K = K - KSTEP GO TO 50 60 CONTINUE END IF * RETURN * * End of DSYTRI * END *> \brief \b DSYTRI2 * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSYTRI2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LWORK, N * .. * .. Array Arguments .. * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSYTRI2 computes the inverse of a DOUBLE PRECISION symmetric indefinite matrix *> A using the factorization A = U*D*U**T or A = L*D*L**T computed by *> DSYTRF. DSYTRI2 sets the LEADING DIMENSION of the workspace *> before calling DSYTRI2X that actually computes the inverse. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the details of the factorization are stored *> as an upper or lower triangular matrix. *> = 'U': Upper triangular, form is A = U*D*U**T; *> = 'L': Lower triangular, form is A = L*D*L**T. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the NB diagonal matrix D and the multipliers *> used to obtain the factor U or L as computed by DSYTRF. *> *> On exit, if INFO = 0, the (symmetric) inverse of the original *> matrix. If UPLO = 'U', the upper triangular part of the *> inverse is formed and the part of A below the diagonal is not *> referenced; if UPLO = 'L' the lower triangular part of the *> inverse is formed and the part of A above the diagonal is *> not referenced. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N) *> Details of the interchanges and the NB structure of D *> as determined by DSYTRF. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (N+NB+1)*(NB+3) *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. *> WORK is size >= (N+NB+1)*(NB+3) *> If LDWORK = -1, then a workspace query is assumed; the routine *> 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 LDWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its *> inverse could not be computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date November 2017 * *> \ingroup doubleSYcomputational * * ===================================================================== SUBROUTINE DSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, LWORK, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * ===================================================================== * * .. Local Scalars .. LOGICAL UPPER, LQUERY INTEGER MINSIZE, NBMAX * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DSYTRI, DSYTRI2X, XERBLA * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) LQUERY = ( LWORK.EQ.-1 ) * Get blocksize NBMAX = ILAENV( 1, 'DSYTRF', UPLO, N, -1, -1, -1 ) IF ( NBMAX .GE. N ) THEN MINSIZE = N ELSE MINSIZE = (N+NBMAX+1)*(NBMAX+3) END IF * IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF (LWORK .LT. MINSIZE .AND. .NOT.LQUERY ) THEN INFO = -7 END IF * * Quick return if possible * * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYTRI2', -INFO ) RETURN ELSE IF( LQUERY ) THEN WORK(1)=MINSIZE RETURN END IF IF( N.EQ.0 ) $ RETURN IF( NBMAX .GE. N ) THEN CALL DSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) ELSE CALL DSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NBMAX, INFO ) END IF RETURN * * End of DSYTRI2 * END *> \brief \b DSYTRI2X * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSYTRI2X + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N, NB * .. * .. Array Arguments .. * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), WORK( N+NB+1,* ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSYTRI2X computes the inverse of a real symmetric indefinite matrix *> A using the factorization A = U*D*U**T or A = L*D*L**T computed by *> DSYTRF. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the details of the factorization are stored *> as an upper or lower triangular matrix. *> = 'U': Upper triangular, form is A = U*D*U**T; *> = 'L': Lower triangular, form is A = L*D*L**T. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the NNB diagonal matrix D and the multipliers *> used to obtain the factor U or L as computed by DSYTRF. *> *> On exit, if INFO = 0, the (symmetric) inverse of the original *> matrix. If UPLO = 'U', the upper triangular part of the *> inverse is formed and the part of A below the diagonal is not *> referenced; if UPLO = 'L' the lower triangular part of the *> inverse is formed and the part of A above the diagonal is *> not referenced. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N) *> Details of the interchanges and the NNB structure of D *> as determined by DSYTRF. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (N+NB+1,NB+3) *> \endverbatim *> *> \param[in] NB *> \verbatim *> NB is INTEGER *> Block size *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its *> inverse could not be computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup doubleSYcomputational * * ===================================================================== SUBROUTINE DSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) * * -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, N, NB * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ), WORK( N+NB+1,* ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER I, IINFO, IP, K, CUT, NNB INTEGER COUNT INTEGER J, U11, INVD DOUBLE PRECISION AK, AKKP1, AKP1, D, T DOUBLE PRECISION U01_I_J, U01_IP1_J DOUBLE PRECISION U11_I_J, U11_IP1_J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DSYCONV, XERBLA, DTRTRI EXTERNAL DGEMM, DTRMM, DSYSWAPR * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 END IF * * Quick return if possible * * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYTRI2X', -INFO ) RETURN END IF IF( N.EQ.0 ) $ RETURN * * Convert A * Workspace got Non-diag elements of D * CALL DSYCONV( UPLO, 'C', N, A, LDA, IPIV, WORK, IINFO ) * * Check that the diagonal matrix D is nonsingular. * IF( UPPER ) THEN * * Upper triangular storage: examine D from bottom to top * DO INFO = N, 1, -1 IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) $ RETURN END DO ELSE * * Lower triangular storage: examine D from top to bottom. * DO INFO = 1, N IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) $ RETURN END DO END IF INFO = 0 * * Splitting Workspace * U01 is a block (N,NB+1) * The first element of U01 is in WORK(1,1) * U11 is a block (NB+1,NB+1) * The first element of U11 is in WORK(N+1,1) U11 = N * INVD is a block (N,2) * The first element of INVD is in WORK(1,INVD) INVD = NB+2 IF( UPPER ) THEN * * invA = P * inv(U**T)*inv(D)*inv(U)*P**T. * CALL DTRTRI( UPLO, 'U', N, A, LDA, INFO ) * * inv(D) and inv(D)*inv(U) * K=1 DO WHILE ( K .LE. N ) IF( IPIV( K ).GT.0 ) THEN * 1 x 1 diagonal NNB WORK(K,INVD) = ONE / A( K, K ) WORK(K,INVD+1) = 0 K=K+1 ELSE * 2 x 2 diagonal NNB T = WORK(K+1,1) AK = A( K, K ) / T AKP1 = A( K+1, K+1 ) / T AKKP1 = WORK(K+1,1) / T D = T*( AK*AKP1-ONE ) WORK(K,INVD) = AKP1 / D WORK(K+1,INVD+1) = AK / D WORK(K,INVD+1) = -AKKP1 / D WORK(K+1,INVD) = -AKKP1 / D K=K+2 END IF END DO * * inv(U**T) = (inv(U))**T * * inv(U**T)*inv(D)*inv(U) * CUT=N DO WHILE (CUT .GT. 0) NNB=NB IF (CUT .LE. NNB) THEN NNB=CUT ELSE COUNT = 0 * count negative elements, DO I=CUT+1-NNB,CUT IF (IPIV(I) .LT. 0) COUNT=COUNT+1 END DO * need a even number for a clear cut IF (MOD(COUNT,2) .EQ. 1) NNB=NNB+1 END IF CUT=CUT-NNB * * U01 Block * DO I=1,CUT DO J=1,NNB WORK(I,J)=A(I,CUT+J) END DO END DO * * U11 Block * DO I=1,NNB WORK(U11+I,I)=ONE DO J=1,I-1 WORK(U11+I,J)=ZERO END DO DO J=I+1,NNB WORK(U11+I,J)=A(CUT+I,CUT+J) END DO END DO * * invD*U01 * I=1 DO WHILE (I .LE. CUT) IF (IPIV(I) > 0) THEN DO J=1,NNB WORK(I,J)=WORK(I,INVD)*WORK(I,J) END DO I=I+1 ELSE DO J=1,NNB U01_I_J = WORK(I,J) U01_IP1_J = WORK(I+1,J) WORK(I,J)=WORK(I,INVD)*U01_I_J+ $ WORK(I,INVD+1)*U01_IP1_J WORK(I+1,J)=WORK(I+1,INVD)*U01_I_J+ $ WORK(I+1,INVD+1)*U01_IP1_J END DO I=I+2 END IF END DO * * invD1*U11 * I=1 DO WHILE (I .LE. NNB) IF (IPIV(CUT+I) > 0) THEN DO J=I,NNB WORK(U11+I,J)=WORK(CUT+I,INVD)*WORK(U11+I,J) END DO I=I+1 ELSE DO J=I,NNB U11_I_J = WORK(U11+I,J) U11_IP1_J = WORK(U11+I+1,J) WORK(U11+I,J)=WORK(CUT+I,INVD)*WORK(U11+I,J) + $ WORK(CUT+I,INVD+1)*WORK(U11+I+1,J) WORK(U11+I+1,J)=WORK(CUT+I+1,INVD)*U11_I_J+ $ WORK(CUT+I+1,INVD+1)*U11_IP1_J END DO I=I+2 END IF END DO * * U11**T*invD1*U11->U11 * CALL DTRMM('L','U','T','U',NNB, NNB, $ ONE,A(CUT+1,CUT+1),LDA,WORK(U11+1,1),N+NB+1) * DO I=1,NNB DO J=I,NNB A(CUT+I,CUT+J)=WORK(U11+I,J) END DO END DO * * U01**T*invD*U01->A(CUT+I,CUT+J) * CALL DGEMM('T','N',NNB,NNB,CUT,ONE,A(1,CUT+1),LDA, $ WORK,N+NB+1, ZERO, WORK(U11+1,1), N+NB+1) * * U11 = U11**T*invD1*U11 + U01**T*invD*U01 * DO I=1,NNB DO J=I,NNB A(CUT+I,CUT+J)=A(CUT+I,CUT+J)+WORK(U11+I,J) END DO END DO * * U01 = U00**T*invD0*U01 * CALL DTRMM('L',UPLO,'T','U',CUT, NNB, $ ONE,A,LDA,WORK,N+NB+1) * * Update U01 * DO I=1,CUT DO J=1,NNB A(I,CUT+J)=WORK(I,J) END DO END DO * * Next Block * END DO * * Apply PERMUTATIONS P and P**T: P * inv(U**T)*inv(D)*inv(U) *P**T * I=1 DO WHILE ( I .LE. N ) IF( IPIV(I) .GT. 0 ) THEN IP=IPIV(I) IF (I .LT. IP) CALL DSYSWAPR( UPLO, N, A, LDA, I ,IP ) IF (I .GT. IP) CALL DSYSWAPR( UPLO, N, A, LDA, IP ,I ) ELSE IP=-IPIV(I) I=I+1 IF ( (I-1) .LT. IP) $ CALL DSYSWAPR( UPLO, N, A, LDA, I-1 ,IP ) IF ( (I-1) .GT. IP) $ CALL DSYSWAPR( UPLO, N, A, LDA, IP ,I-1 ) ENDIF I=I+1 END DO ELSE * * LOWER... * * invA = P * inv(U**T)*inv(D)*inv(U)*P**T. * CALL DTRTRI( UPLO, 'U', N, A, LDA, INFO ) * * inv(D) and inv(D)*inv(U) * K=N DO WHILE ( K .GE. 1 ) IF( IPIV( K ).GT.0 ) THEN * 1 x 1 diagonal NNB WORK(K,INVD) = ONE / A( K, K ) WORK(K,INVD+1) = 0 K=K-1 ELSE * 2 x 2 diagonal NNB T = WORK(K-1,1) AK = A( K-1, K-1 ) / T AKP1 = A( K, K ) / T AKKP1 = WORK(K-1,1) / T D = T*( AK*AKP1-ONE ) WORK(K-1,INVD) = AKP1 / D WORK(K,INVD) = AK / D WORK(K,INVD+1) = -AKKP1 / D WORK(K-1,INVD+1) = -AKKP1 / D K=K-2 END IF END DO * * inv(U**T) = (inv(U))**T * * inv(U**T)*inv(D)*inv(U) * CUT=0 DO WHILE (CUT .LT. N) NNB=NB IF (CUT + NNB .GT. N) THEN NNB=N-CUT ELSE COUNT = 0 * count negative elements, DO I=CUT+1,CUT+NNB IF (IPIV(I) .LT. 0) COUNT=COUNT+1 END DO * need a even number for a clear cut IF (MOD(COUNT,2) .EQ. 1) NNB=NNB+1 END IF * L21 Block DO I=1,N-CUT-NNB DO J=1,NNB WORK(I,J)=A(CUT+NNB+I,CUT+J) END DO END DO * L11 Block DO I=1,NNB WORK(U11+I,I)=ONE DO J=I+1,NNB WORK(U11+I,J)=ZERO END DO DO J=1,I-1 WORK(U11+I,J)=A(CUT+I,CUT+J) END DO END DO * * invD*L21 * I=N-CUT-NNB DO WHILE (I .GE. 1) IF (IPIV(CUT+NNB+I) > 0) THEN DO J=1,NNB WORK(I,J)=WORK(CUT+NNB+I,INVD)*WORK(I,J) END DO I=I-1 ELSE DO J=1,NNB U01_I_J = WORK(I,J) U01_IP1_J = WORK(I-1,J) WORK(I,J)=WORK(CUT+NNB+I,INVD)*U01_I_J+ $ WORK(CUT+NNB+I,INVD+1)*U01_IP1_J WORK(I-1,J)=WORK(CUT+NNB+I-1,INVD+1)*U01_I_J+ $ WORK(CUT+NNB+I-1,INVD)*U01_IP1_J END DO I=I-2 END IF END DO * * invD1*L11 * I=NNB DO WHILE (I .GE. 1) IF (IPIV(CUT+I) > 0) THEN DO J=1,NNB WORK(U11+I,J)=WORK(CUT+I,INVD)*WORK(U11+I,J) END DO I=I-1 ELSE DO J=1,NNB U11_I_J = WORK(U11+I,J) U11_IP1_J = WORK(U11+I-1,J) WORK(U11+I,J)=WORK(CUT+I,INVD)*WORK(U11+I,J) + $ WORK(CUT+I,INVD+1)*U11_IP1_J WORK(U11+I-1,J)=WORK(CUT+I-1,INVD+1)*U11_I_J+ $ WORK(CUT+I-1,INVD)*U11_IP1_J END DO I=I-2 END IF END DO * * L11**T*invD1*L11->L11 * CALL DTRMM('L',UPLO,'T','U',NNB, NNB, $ ONE,A(CUT+1,CUT+1),LDA,WORK(U11+1,1),N+NB+1) * DO I=1,NNB DO J=1,I A(CUT+I,CUT+J)=WORK(U11+I,J) END DO END DO * IF ( (CUT+NNB) .LT. N ) THEN * * L21**T*invD2*L21->A(CUT+I,CUT+J) * CALL DGEMM('T','N',NNB,NNB,N-NNB-CUT,ONE,A(CUT+NNB+1,CUT+1) $ ,LDA,WORK,N+NB+1, ZERO, WORK(U11+1,1), N+NB+1) * * L11 = L11**T*invD1*L11 + U01**T*invD*U01 * DO I=1,NNB DO J=1,I A(CUT+I,CUT+J)=A(CUT+I,CUT+J)+WORK(U11+I,J) END DO END DO * * L01 = L22**T*invD2*L21 * CALL DTRMM('L',UPLO,'T','U', N-NNB-CUT, NNB, $ ONE,A(CUT+NNB+1,CUT+NNB+1),LDA,WORK,N+NB+1) * * Update L21 * DO I=1,N-CUT-NNB DO J=1,NNB A(CUT+NNB+I,CUT+J)=WORK(I,J) END DO END DO ELSE * * L11 = L11**T*invD1*L11 * DO I=1,NNB DO J=1,I A(CUT+I,CUT+J)=WORK(U11+I,J) END DO END DO END IF * * Next Block * CUT=CUT+NNB END DO * * Apply PERMUTATIONS P and P**T: P * inv(U**T)*inv(D)*inv(U) *P**T * I=N DO WHILE ( I .GE. 1 ) IF( IPIV(I) .GT. 0 ) THEN IP=IPIV(I) IF (I .LT. IP) CALL DSYSWAPR( UPLO, N, A, LDA, I ,IP ) IF (I .GT. IP) CALL DSYSWAPR( UPLO, N, A, LDA, IP ,I ) ELSE IP=-IPIV(I) IF ( I .LT. IP) CALL DSYSWAPR( UPLO, N, A, LDA, I ,IP ) IF ( I .GT. IP) CALL DSYSWAPR( UPLO, N, A, LDA, IP, I ) I=I-1 ENDIF I=I-1 END DO END IF * RETURN * * End of DSYTRI2X * END *> \brief \b DSYTRS * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSYTRS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, N, NRHS * .. * .. Array Arguments .. * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSYTRS solves a system of linear equations A*X = B with a real *> symmetric matrix A using the factorization A = U*D*U**T or *> A = L*D*L**T computed by DSYTRF. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the details of the factorization are stored *> as an upper or lower triangular matrix. *> = 'U': Upper triangular, form is A = U*D*U**T; *> = 'L': Lower triangular, form is A = L*D*L**T. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrix B. NRHS >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The block diagonal matrix D and the multipliers used to *> obtain the factor U or L as computed by DSYTRF. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N) *> Details of the interchanges and the block structure of D *> as determined by DSYTRF. *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> On entry, the right hand side matrix B. *> On exit, the solution matrix X. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleSYcomputational * * ===================================================================== SUBROUTINE DSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, LDB, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER J, K, KP DOUBLE PRECISION AK, AKM1, AKM1K, BK, BKM1, DENOM * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DGEMV, DGER, DSCAL, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( 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( 'DSYTRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * IF( UPPER ) THEN * * Solve A*X = B, where A = U*D*U**T. * * First solve U*D*X = B, overwriting B with X. * * K is the main loop index, decreasing from N to 1 in steps of * 1 or 2, depending on the size of the diagonal blocks. * K = N 10 CONTINUE * * If K < 1, exit from loop. * IF( K.LT.1 ) $ GO TO 30 * IF( IPIV( K ).GT.0 ) THEN * * 1 x 1 diagonal block * * Interchange rows K and IPIV(K). * KP = IPIV( K ) IF( KP.NE.K ) $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) * * Multiply by inv(U(K)), where U(K) is the transformation * stored in column K of A. * CALL DGER( K-1, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB, $ B( 1, 1 ), LDB ) * * Multiply by the inverse of the diagonal block. * CALL DSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB ) K = K - 1 ELSE * * 2 x 2 diagonal block * * Interchange rows K-1 and -IPIV(K). * KP = -IPIV( K ) IF( KP.NE.K-1 ) $ CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) * * Multiply by inv(U(K)), where U(K) is the transformation * stored in columns K-1 and K of A. * CALL DGER( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB, $ B( 1, 1 ), LDB ) CALL DGER( K-2, NRHS, -ONE, A( 1, K-1 ), 1, B( K-1, 1 ), $ LDB, B( 1, 1 ), LDB ) * * Multiply by the inverse of the diagonal block. * AKM1K = A( K-1, K ) AKM1 = A( K-1, K-1 ) / AKM1K AK = A( K, K ) / AKM1K DENOM = AKM1*AK - ONE DO 20 J = 1, NRHS BKM1 = B( K-1, J ) / AKM1K BK = B( K, J ) / AKM1K B( K-1, J ) = ( AK*BKM1-BK ) / DENOM B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM 20 CONTINUE K = K - 2 END IF * GO TO 10 30 CONTINUE * * Next solve U**T *X = B, overwriting B with X. * * K is the main loop index, increasing from 1 to N in steps of * 1 or 2, depending on the size of the diagonal blocks. * K = 1 40 CONTINUE * * If K > N, exit from loop. * IF( K.GT.N ) $ GO TO 50 * IF( IPIV( K ).GT.0 ) THEN * * 1 x 1 diagonal block * * Multiply by inv(U**T(K)), where U(K) is the transformation * stored in column K of A. * CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1, K ), $ 1, ONE, B( K, 1 ), LDB ) * * Interchange rows K and IPIV(K). * KP = IPIV( K ) IF( KP.NE.K ) $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) K = K + 1 ELSE * * 2 x 2 diagonal block * * Multiply by inv(U**T(K+1)), where U(K+1) is the transformation * stored in columns K and K+1 of A. * CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1, K ), $ 1, ONE, B( K, 1 ), LDB ) CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, $ A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB ) * * Interchange rows K and -IPIV(K). * KP = -IPIV( K ) IF( KP.NE.K ) $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) K = K + 2 END IF * GO TO 40 50 CONTINUE * ELSE * * Solve A*X = B, where A = L*D*L**T. * * First solve L*D*X = B, overwriting B with X. * * K is the main loop index, increasing from 1 to N in steps of * 1 or 2, depending on the size of the diagonal blocks. * K = 1 60 CONTINUE * * If K > N, exit from loop. * IF( K.GT.N ) $ GO TO 80 * IF( IPIV( K ).GT.0 ) THEN * * 1 x 1 diagonal block * * Interchange rows K and IPIV(K). * KP = IPIV( K ) IF( KP.NE.K ) $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) * * Multiply by inv(L(K)), where L(K) is the transformation * stored in column K of A. * IF( K.LT.N ) $ CALL DGER( N-K, NRHS, -ONE, A( K+1, K ), 1, B( K, 1 ), $ LDB, B( K+1, 1 ), LDB ) * * Multiply by the inverse of the diagonal block. * CALL DSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB ) K = K + 1 ELSE * * 2 x 2 diagonal block * * Interchange rows K+1 and -IPIV(K). * KP = -IPIV( K ) IF( KP.NE.K+1 ) $ CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) * * Multiply by inv(L(K)), where L(K) is the transformation * stored in columns K and K+1 of A. * IF( K.LT.N-1 ) THEN CALL DGER( N-K-1, NRHS, -ONE, A( K+2, K ), 1, B( K, 1 ), $ LDB, B( K+2, 1 ), LDB ) CALL DGER( N-K-1, NRHS, -ONE, A( K+2, K+1 ), 1, $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB ) END IF * * Multiply by the inverse of the diagonal block. * AKM1K = A( K+1, K ) AKM1 = A( K, K ) / AKM1K AK = A( K+1, K+1 ) / AKM1K DENOM = AKM1*AK - ONE DO 70 J = 1, NRHS BKM1 = B( K, J ) / AKM1K BK = B( K+1, J ) / AKM1K B( K, J ) = ( AK*BKM1-BK ) / DENOM B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM 70 CONTINUE K = K + 2 END IF * GO TO 60 80 CONTINUE * * Next solve L**T *X = B, overwriting B with X. * * K is the main loop index, decreasing from N to 1 in steps of * 1 or 2, depending on the size of the diagonal blocks. * K = N 90 CONTINUE * * If K < 1, exit from loop. * IF( K.LT.1 ) $ GO TO 100 * IF( IPIV( K ).GT.0 ) THEN * * 1 x 1 diagonal block * * Multiply by inv(L**T(K)), where L(K) is the transformation * stored in column K of A. * IF( K.LT.N ) $ CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB ) * * Interchange rows K and IPIV(K). * KP = IPIV( K ) IF( KP.NE.K ) $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) K = K - 1 ELSE * * 2 x 2 diagonal block * * Multiply by inv(L**T(K-1)), where L(K-1) is the transformation * stored in columns K-1 and K of A. * IF( K.LT.N ) THEN CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB ) CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), $ LDB, A( K+1, K-1 ), 1, ONE, B( K-1, 1 ), $ LDB ) END IF * * Interchange rows K and -IPIV(K). * KP = -IPIV( K ) IF( KP.NE.K ) $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) K = K - 2 END IF * GO TO 90 100 CONTINUE END IF * RETURN * * End of DSYTRS * END *> \brief \b DSYTRS2 * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DSYTRS2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, * WORK, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, LDB, N, NRHS * .. * .. Array Arguments .. * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DSYTRS2 solves a system of linear equations A*X = B with a real *> symmetric matrix A using the factorization A = U*D*U**T or *> A = L*D*L**T computed by DSYTRF and converted by DSYCONV. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the details of the factorization are stored *> as an upper or lower triangular matrix. *> = 'U': Upper triangular, form is A = U*D*U**T; *> = 'L': Lower triangular, form is A = L*D*L**T. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrix B. NRHS >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The block diagonal matrix D and the multipliers used to *> obtain the factor U or L as computed by DSYTRF. *> Note that A is input / output. This might be counter-intuitive, *> and one may think that A is input only. A is input / output. This *> is because, at the start of the subroutine, we permute A in a *> "better" form and then we permute A back to its original form at *> the end. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (N) *> Details of the interchanges and the block structure of D *> as determined by DSYTRF. *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> On entry, the right hand side matrix B. *> On exit, the solution matrix X. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleSYcomputational * * ===================================================================== SUBROUTINE DSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, $ WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, LDB, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER I, IINFO, J, K, KP DOUBLE PRECISION AK, AKM1, AKM1K, BK, BKM1, DENOM * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DSCAL, DSYCONV, DSWAP, DTRSM, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( 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( 'DSYTRS2', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * * Convert A * CALL DSYCONV( UPLO, 'C', N, A, LDA, IPIV, WORK, IINFO ) * IF( UPPER ) THEN * * Solve A*X = B, where A = U*D*U**T. * * P**T * B K=N DO WHILE ( K .GE. 1 ) IF( IPIV( K ).GT.0 ) THEN * 1 x 1 diagonal block * Interchange rows K and IPIV(K). KP = IPIV( K ) IF( KP.NE.K ) $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) K=K-1 ELSE * 2 x 2 diagonal block * Interchange rows K-1 and -IPIV(K). KP = -IPIV( K ) IF( KP.EQ.-IPIV( K-1 ) ) $ CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) K=K-2 END IF END DO * * Compute (U \P**T * B) -> B [ (U \P**T * B) ] * CALL DTRSM('L','U','N','U',N,NRHS,ONE,A,LDA,B,LDB) * * Compute D \ B -> B [ D \ (U \P**T * B) ] * I=N DO WHILE ( I .GE. 1 ) IF( IPIV(I) .GT. 0 ) THEN CALL DSCAL( NRHS, ONE / A( I, I ), B( I, 1 ), LDB ) ELSEIF ( I .GT. 1) THEN IF ( IPIV(I-1) .EQ. IPIV(I) ) THEN AKM1K = WORK(I) AKM1 = A( I-1, I-1 ) / AKM1K AK = A( I, I ) / AKM1K DENOM = AKM1*AK - ONE DO 15 J = 1, NRHS BKM1 = B( I-1, J ) / AKM1K BK = B( I, J ) / AKM1K B( I-1, J ) = ( AK*BKM1-BK ) / DENOM B( I, J ) = ( AKM1*BK-BKM1 ) / DENOM 15 CONTINUE I = I - 1 ENDIF ENDIF I = I - 1 END DO * * Compute (U**T \ B) -> B [ U**T \ (D \ (U \P**T * B) ) ] * CALL DTRSM('L','U','T','U',N,NRHS,ONE,A,LDA,B,LDB) * * P * B [ P * (U**T \ (D \ (U \P**T * B) )) ] * K=1 DO WHILE ( K .LE. N ) IF( IPIV( K ).GT.0 ) THEN * 1 x 1 diagonal block * Interchange rows K and IPIV(K). KP = IPIV( K ) IF( KP.NE.K ) $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) K=K+1 ELSE * 2 x 2 diagonal block * Interchange rows K-1 and -IPIV(K). KP = -IPIV( K ) IF( K .LT. N .AND. KP.EQ.-IPIV( K+1 ) ) $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) K=K+2 ENDIF END DO * ELSE * * Solve A*X = B, where A = L*D*L**T. * * P**T * B K=1 DO WHILE ( K .LE. N ) IF( IPIV( K ).GT.0 ) THEN * 1 x 1 diagonal block * Interchange rows K and IPIV(K). KP = IPIV( K ) IF( KP.NE.K ) $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) K=K+1 ELSE * 2 x 2 diagonal block * Interchange rows K and -IPIV(K+1). KP = -IPIV( K+1 ) IF( KP.EQ.-IPIV( K ) ) $ CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) K=K+2 ENDIF END DO * * Compute (L \P**T * B) -> B [ (L \P**T * B) ] * CALL DTRSM('L','L','N','U',N,NRHS,ONE,A,LDA,B,LDB) * * Compute D \ B -> B [ D \ (L \P**T * B) ] * I=1 DO WHILE ( I .LE. N ) IF( IPIV(I) .GT. 0 ) THEN CALL DSCAL( NRHS, ONE / A( I, I ), B( I, 1 ), LDB ) ELSE AKM1K = WORK(I) AKM1 = A( I, I ) / AKM1K AK = A( I+1, I+1 ) / AKM1K DENOM = AKM1*AK - ONE DO 25 J = 1, NRHS BKM1 = B( I, J ) / AKM1K BK = B( I+1, J ) / AKM1K B( I, J ) = ( AK*BKM1-BK ) / DENOM B( I+1, J ) = ( AKM1*BK-BKM1 ) / DENOM 25 CONTINUE I = I + 1 ENDIF I = I + 1 END DO * * Compute (L**T \ B) -> B [ L**T \ (D \ (L \P**T * B) ) ] * CALL DTRSM('L','L','T','U',N,NRHS,ONE,A,LDA,B,LDB) * * P * B [ P * (L**T \ (D \ (L \P**T * B) )) ] * K=N DO WHILE ( K .GE. 1 ) IF( IPIV( K ).GT.0 ) THEN * 1 x 1 diagonal block * Interchange rows K and IPIV(K). KP = IPIV( K ) IF( KP.NE.K ) $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) K=K-1 ELSE * 2 x 2 diagonal block * Interchange rows K-1 and -IPIV(K). KP = -IPIV( K ) IF( K.GT.1 .AND. KP.EQ.-IPIV( K-1 ) ) $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) K=K-2 ENDIF END DO * END IF * * Revert A * CALL DSYCONV( UPLO, 'R', N, A, LDA, IPIV, WORK, IINFO ) * RETURN * * End of DSYTRS2 * END *> \brief \b DTBCON * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTBCON + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, * IWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER DIAG, NORM, UPLO * INTEGER INFO, KD, LDAB, N * DOUBLE PRECISION RCOND * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION AB( LDAB, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTBCON estimates the reciprocal of the condition number of a *> triangular band matrix A, in either the 1-norm or the infinity-norm. *> *> The norm of A is computed and an estimate is obtained for *> norm(inv(A)), then the reciprocal of the condition number is *> computed as *> RCOND = 1 / ( norm(A) * norm(inv(A)) ). *> \endverbatim * * Arguments: * ========== * *> \param[in] NORM *> \verbatim *> NORM is 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. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': A is upper triangular; *> = 'L': A is lower triangular. *> \endverbatim *> *> \param[in] DIAG *> \verbatim *> DIAG is CHARACTER*1 *> = 'N': A is non-unit triangular; *> = 'U': A is unit triangular. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] KD *> \verbatim *> KD is INTEGER *> The number of superdiagonals or subdiagonals of the *> triangular band matrix A. KD >= 0. *> \endverbatim *> *> \param[in] AB *> \verbatim *> AB is DOUBLE PRECISION array, dimension (LDAB,N) *> The upper or lower triangular band matrix A, stored in the *> first kd+1 rows of the array. The j-th column of A is stored *> in the j-th column of the array AB as follows: *> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; *> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). *> If DIAG = 'U', the diagonal elements of A are not referenced *> and are assumed to be 1. *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array AB. LDAB >= KD+1. *> \endverbatim *> *> \param[out] RCOND *> \verbatim *> RCOND is DOUBLE PRECISION *> The reciprocal of the condition number of the matrix A, *> computed as RCOND = 1/(norm(A) * norm(inv(A))). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, $ IWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO INTEGER INFO, KD, LDAB, N DOUBLE PRECISION RCOND * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION AB( LDAB, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOUNIT, ONENRM, UPPER CHARACTER NORMIN INTEGER IX, KASE, KASE1 DOUBLE PRECISION AINVNM, ANORM, SCALE, SMLNUM, XNORM * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DLANTB EXTERNAL LSAME, IDAMAX, DLAMCH, DLANTB * .. * .. External Subroutines .. EXTERNAL DLACN2, DLATBS, DRSCL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' ) NOUNIT = LSAME( DIAG, 'N' ) * IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN INFO = -1 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -2 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( KD.LT.0 ) THEN INFO = -5 ELSE IF( LDAB.LT.KD+1 ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTBCON', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN RCOND = ONE RETURN END IF * RCOND = ZERO SMLNUM = DLAMCH( 'Safe minimum' )*DBLE( MAX( 1, N ) ) * * Compute the norm of the triangular matrix A. * ANORM = DLANTB( NORM, UPLO, DIAG, N, KD, AB, LDAB, WORK ) * * Continue only if ANORM > 0. * IF( ANORM.GT.ZERO ) THEN * * Estimate the norm of the inverse of 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(A). * CALL DLATBS( UPLO, 'No transpose', DIAG, NORMIN, N, KD, $ AB, LDAB, WORK, SCALE, WORK( 2*N+1 ), INFO ) ELSE * * Multiply by inv(A**T). * CALL DLATBS( UPLO, 'Transpose', DIAG, NORMIN, N, KD, AB, $ LDAB, WORK, SCALE, WORK( 2*N+1 ), INFO ) END IF NORMIN = 'Y' * * Multiply by 1/SCALE if doing so will not cause overflow. * IF( SCALE.NE.ONE ) THEN IX = IDAMAX( N, WORK, 1 ) XNORM = ABS( WORK( IX ) ) IF( SCALE.LT.XNORM*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 / ANORM ) / AINVNM END IF * 20 CONTINUE RETURN * * End of DTBCON * END *> \brief \b DTBRFS * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTBRFS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, * LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, KD, LDAB, LDB, LDX, N, NRHS * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ), BERR( * ), * $ FERR( * ), WORK( * ), X( LDX, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTBRFS provides error bounds and backward error estimates for the *> solution to a system of linear equations with a triangular band *> coefficient matrix. *> *> The solution matrix X must be computed by DTBTRS or some other *> means before entering this routine. DTBRFS does not do iterative *> refinement because doing so cannot improve the backward error. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': A is upper triangular; *> = 'L': A is lower triangular. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is 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) *> \endverbatim *> *> \param[in] DIAG *> \verbatim *> DIAG is CHARACTER*1 *> = 'N': A is non-unit triangular; *> = 'U': A is unit triangular. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] KD *> \verbatim *> KD is INTEGER *> The number of superdiagonals or subdiagonals of the *> triangular band matrix A. KD >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrices B and X. NRHS >= 0. *> \endverbatim *> *> \param[in] AB *> \verbatim *> AB is DOUBLE PRECISION array, dimension (LDAB,N) *> The upper or lower triangular band matrix A, stored in the *> first kd+1 rows of the array. The j-th column of A is stored *> in the j-th column of the array AB as follows: *> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; *> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). *> If DIAG = 'U', the diagonal elements of A are not referenced *> and are assumed to be 1. *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array AB. LDAB >= KD+1. *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> The right hand side matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,NRHS) *> The solution matrix X. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the array X. LDX >= max(1,N). *> \endverbatim *> *> \param[out] FERR *> \verbatim *> FERR is 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. *> \endverbatim *> *> \param[out] BERR *> \verbatim *> BERR is 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). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, $ LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO INTEGER INFO, KD, LDAB, LDB, LDX, N, NRHS * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ), BERR( * ), $ FERR( * ), WORK( * ), X( LDX, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOTRAN, NOUNIT, UPPER CHARACTER TRANST INTEGER I, J, K, KASE, NZ DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) * .. * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DLACN2, DTBMV, DTBSV, 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 UPPER = LSAME( UPLO, 'U' ) NOTRAN = LSAME( TRANS, 'N' ) NOUNIT = LSAME( DIAG, 'N' ) * IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. $ LSAME( TRANS, 'C' ) ) THEN INFO = -2 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( KD.LT.0 ) THEN INFO = -5 ELSE IF( NRHS.LT.0 ) THEN INFO = -6 ELSE IF( LDAB.LT.KD+1 ) THEN INFO = -8 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( 'DTBRFS', -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 = KD + 2 EPS = DLAMCH( 'Epsilon' ) SAFMIN = DLAMCH( 'Safe minimum' ) SAFE1 = NZ*SAFMIN SAFE2 = SAFE1 / EPS * * Do for each right hand side * DO 250 J = 1, NRHS * * Compute residual R = B - op(A) * X, * where op(A) = A or A**T, depending on TRANS. * CALL DCOPY( N, X( 1, J ), 1, WORK( N+1 ), 1 ) CALL DTBMV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, WORK( N+1 ), $ 1 ) CALL DAXPY( N, -ONE, B( 1, J ), 1, 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 20 I = 1, N WORK( I ) = ABS( B( I, J ) ) 20 CONTINUE * IF( NOTRAN ) THEN * * Compute abs(A)*abs(X) + abs(B). * IF( UPPER ) THEN IF( NOUNIT ) THEN DO 40 K = 1, N XK = ABS( X( K, J ) ) DO 30 I = MAX( 1, K-KD ), K WORK( I ) = WORK( I ) + $ ABS( AB( KD+1+I-K, K ) )*XK 30 CONTINUE 40 CONTINUE ELSE DO 60 K = 1, N XK = ABS( X( K, J ) ) DO 50 I = MAX( 1, K-KD ), K - 1 WORK( I ) = WORK( I ) + $ ABS( AB( KD+1+I-K, K ) )*XK 50 CONTINUE WORK( K ) = WORK( K ) + XK 60 CONTINUE END IF ELSE IF( NOUNIT ) THEN DO 80 K = 1, N XK = ABS( X( K, J ) ) DO 70 I = K, MIN( N, K+KD ) WORK( I ) = WORK( I ) + ABS( AB( 1+I-K, K ) )*XK 70 CONTINUE 80 CONTINUE ELSE DO 100 K = 1, N XK = ABS( X( K, J ) ) DO 90 I = K + 1, MIN( N, K+KD ) WORK( I ) = WORK( I ) + ABS( AB( 1+I-K, K ) )*XK 90 CONTINUE WORK( K ) = WORK( K ) + XK 100 CONTINUE END IF END IF ELSE * * Compute abs(A**T)*abs(X) + abs(B). * IF( UPPER ) THEN IF( NOUNIT ) THEN DO 120 K = 1, N S = ZERO DO 110 I = MAX( 1, K-KD ), K S = S + ABS( AB( KD+1+I-K, K ) )* $ ABS( X( I, J ) ) 110 CONTINUE WORK( K ) = WORK( K ) + S 120 CONTINUE ELSE DO 140 K = 1, N S = ABS( X( K, J ) ) DO 130 I = MAX( 1, K-KD ), K - 1 S = S + ABS( AB( KD+1+I-K, K ) )* $ ABS( X( I, J ) ) 130 CONTINUE WORK( K ) = WORK( K ) + S 140 CONTINUE END IF ELSE IF( NOUNIT ) THEN DO 160 K = 1, N S = ZERO DO 150 I = K, MIN( N, K+KD ) S = S + ABS( AB( 1+I-K, K ) )*ABS( X( I, J ) ) 150 CONTINUE WORK( K ) = WORK( K ) + S 160 CONTINUE ELSE DO 180 K = 1, N S = ABS( X( K, J ) ) DO 170 I = K + 1, MIN( N, K+KD ) S = S + ABS( AB( 1+I-K, K ) )*ABS( X( I, J ) ) 170 CONTINUE WORK( K ) = WORK( K ) + S 180 CONTINUE END IF END IF END IF S = ZERO DO 190 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 190 CONTINUE BERR( J ) = S * * 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 200 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 200 CONTINUE * KASE = 0 210 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 DTBSV( UPLO, TRANST, DIAG, N, KD, AB, LDAB, $ WORK( N+1 ), 1 ) DO 220 I = 1, N WORK( N+I ) = WORK( I )*WORK( N+I ) 220 CONTINUE ELSE * * Multiply by inv(op(A))*diag(W). * DO 230 I = 1, N WORK( N+I ) = WORK( I )*WORK( N+I ) 230 CONTINUE CALL DTBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, $ WORK( N+1 ), 1 ) END IF GO TO 210 END IF * * Normalize error. * LSTRES = ZERO DO 240 I = 1, N LSTRES = MAX( LSTRES, ABS( X( I, J ) ) ) 240 CONTINUE IF( LSTRES.NE.ZERO ) $ FERR( J ) = FERR( J ) / LSTRES * 250 CONTINUE * RETURN * * End of DTBRFS * END *> \brief \b DTBTRS * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTBTRS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, * LDB, INFO ) * * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, KD, LDAB, LDB, N, NRHS * .. * .. Array Arguments .. * DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTBTRS solves a triangular system of the form *> *> A * X = B or A**T * X = B, *> *> where A is a triangular band matrix of order N, and B is an *> N-by NRHS matrix. A check is made to verify that A is nonsingular. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': A is upper triangular; *> = 'L': A is lower triangular. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> Specifies the form the system of equations: *> = 'N': A * X = B (No transpose) *> = 'T': A**T * X = B (Transpose) *> = 'C': A**H * X = B (Conjugate transpose = Transpose) *> \endverbatim *> *> \param[in] DIAG *> \verbatim *> DIAG is CHARACTER*1 *> = 'N': A is non-unit triangular; *> = 'U': A is unit triangular. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] KD *> \verbatim *> KD is INTEGER *> The number of superdiagonals or subdiagonals of the *> triangular band matrix A. KD >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrix B. NRHS >= 0. *> \endverbatim *> *> \param[in] AB *> \verbatim *> AB is DOUBLE PRECISION array, dimension (LDAB,N) *> The upper or lower triangular band matrix A, stored in the *> first kd+1 rows of AB. The j-th column of A is stored *> in the j-th column of the array AB as follows: *> if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; *> if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). *> If DIAG = 'U', the diagonal elements of A are not referenced *> and are assumed to be 1. *> \endverbatim *> *> \param[in] LDAB *> \verbatim *> LDAB is INTEGER *> The leading dimension of the array AB. LDAB >= KD+1. *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> On entry, the right hand side matrix B. *> On exit, if INFO = 0, the solution matrix X. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, the i-th diagonal element of A is zero, *> indicating that the matrix is singular and the *> solutions X have not been computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, $ LDB, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO INTEGER INFO, KD, LDAB, LDB, N, NRHS * .. * .. Array Arguments .. DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOUNIT, UPPER INTEGER J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DTBSV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 NOUNIT = LSAME( DIAG, 'N' ) UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT. $ LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN INFO = -2 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( KD.LT.0 ) THEN INFO = -5 ELSE IF( NRHS.LT.0 ) THEN INFO = -6 ELSE IF( LDAB.LT.KD+1 ) THEN INFO = -8 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTBTRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Check for singularity. * IF( NOUNIT ) THEN IF( UPPER ) THEN DO 10 INFO = 1, N IF( AB( KD+1, INFO ).EQ.ZERO ) $ RETURN 10 CONTINUE ELSE DO 20 INFO = 1, N IF( AB( 1, INFO ).EQ.ZERO ) $ RETURN 20 CONTINUE END IF END IF INFO = 0 * * Solve A * X = B or A**T * X = B. * DO 30 J = 1, NRHS CALL DTBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, B( 1, J ), 1 ) 30 CONTINUE * RETURN * * End of DTBTRS * END *> \brief \b DTFSM solves a matrix equation (one operand is a triangular matrix in RFP format). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTFSM + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, * B, LDB ) * * .. Scalar Arguments .. * CHARACTER TRANSR, DIAG, SIDE, TRANS, UPLO * INTEGER LDB, M, N * DOUBLE PRECISION ALPHA * .. * .. Array Arguments .. * DOUBLE PRECISION A( 0: * ), B( 0: LDB-1, 0: * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> Level 3 BLAS like routine for A in RFP Format. *> *> DTFSM solves the matrix equation *> *> op( A )*X = alpha*B or X*op( A ) = alpha*B *> *> where alpha is a scalar, X and B are m by n matrices, A is a unit, or *> non-unit, upper or lower triangular matrix and op( A ) is one of *> *> op( A ) = A or op( A ) = A**T. *> *> A is in Rectangular Full Packed (RFP) Format. *> *> The matrix X is overwritten on B. *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANSR *> \verbatim *> TRANSR is CHARACTER*1 *> = 'N': The Normal Form of RFP A is stored; *> = 'T': The Transpose Form of RFP A is stored. *> \endverbatim *> *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> On entry, SIDE specifies whether op( A ) appears on the left *> or right of X as follows: *> *> SIDE = 'L' or 'l' op( A )*X = alpha*B. *> *> SIDE = 'R' or 'r' X*op( A ) = alpha*B. *> *> Unchanged on exit. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> On entry, UPLO specifies whether the RFP matrix A came from *> an upper or lower triangular matrix as follows: *> UPLO = 'U' or 'u' RFP A came from an upper triangular matrix *> UPLO = 'L' or 'l' RFP A came from a lower triangular matrix *> *> Unchanged on exit. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> On entry, TRANS specifies the form of op( A ) to be used *> in the matrix multiplication as follows: *> *> TRANS = 'N' or 'n' op( A ) = A. *> *> TRANS = 'T' or 't' op( A ) = A'. *> *> Unchanged on exit. *> \endverbatim *> *> \param[in] DIAG *> \verbatim *> DIAG is CHARACTER*1 *> On entry, DIAG specifies whether or not RFP A is unit *> triangular as follows: *> *> DIAG = 'U' or 'u' A is assumed to be unit triangular. *> *> DIAG = 'N' or 'n' A is not assumed to be unit *> triangular. *> *> Unchanged on exit. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> On entry, M specifies the number of rows of B. M must be at *> least zero. *> Unchanged on exit. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> On entry, N specifies the number of columns of B. N must be *> at least zero. *> Unchanged on exit. *> \endverbatim *> *> \param[in] ALPHA *> \verbatim *> ALPHA is DOUBLE PRECISION *> On entry, ALPHA specifies the scalar alpha. When alpha is *> zero then A is not referenced and B need not be set before *> entry. *> Unchanged on exit. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (NT) *> NT = N*(N+1)/2. On entry, the matrix A in RFP Format. *> RFP Format is described by TRANSR, UPLO and N as follows: *> If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even; *> K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If *> TRANSR = 'T' then RFP is the transpose of RFP A as *> defined when TRANSR = 'N'. The contents of RFP A are defined *> by UPLO as follows: If UPLO = 'U' the RFP A contains the NT *> elements of upper packed A either in normal or *> transpose Format. If UPLO = 'L' the RFP A contains *> the NT elements of lower packed A either in normal or *> transpose Format. The LDA of RFP A is (N+1)/2 when *> TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is *> even and is N when is odd. *> See the Note below for more details. Unchanged on exit. *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,N) *> Before entry, the leading m by n part of the array B must *> contain the right-hand side matrix B, and on exit is *> overwritten by the solution matrix X. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> On entry, LDB specifies the first dimension of B as declared *> in the calling (sub) program. LDB must be at least *> max( 1, m ). *> Unchanged on exit. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> We first consider Rectangular Full Packed (RFP) Format when N is *> even. We give an example where N = 6. *> *> AP is Upper AP is Lower *> *> 00 01 02 03 04 05 00 *> 11 12 13 14 15 10 11 *> 22 23 24 25 20 21 22 *> 33 34 35 30 31 32 33 *> 44 45 40 41 42 43 44 *> 55 50 51 52 53 54 55 *> *> *> Let TRANSR = 'N'. RFP holds AP as follows: *> For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last *> three columns of AP upper. The lower triangle A(4:6,0:2) consists of *> the transpose of the first three columns of AP upper. *> For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first *> three columns of AP lower. The upper triangle A(0:2,0:2) consists of *> the transpose of the last three columns of AP lower. *> This covers the case N even and TRANSR = 'N'. *> *> RFP A RFP A *> *> 03 04 05 33 43 53 *> 13 14 15 00 44 54 *> 23 24 25 10 11 55 *> 33 34 35 20 21 22 *> 00 44 45 30 31 32 *> 01 11 55 40 41 42 *> 02 12 22 50 51 52 *> *> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the *> transpose of RFP A above. One therefore gets: *> *> *> RFP A RFP A *> *> 03 13 23 33 00 01 02 33 00 10 20 30 40 50 *> 04 14 24 34 44 11 12 43 44 11 21 31 41 51 *> 05 15 25 35 45 55 22 53 54 55 22 32 42 52 *> *> *> We then consider Rectangular Full Packed (RFP) Format when N is *> odd. We give an example where N = 5. *> *> AP is Upper AP is Lower *> *> 00 01 02 03 04 00 *> 11 12 13 14 10 11 *> 22 23 24 20 21 22 *> 33 34 30 31 32 33 *> 44 40 41 42 43 44 *> *> *> Let TRANSR = 'N'. RFP holds AP as follows: *> For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last *> three columns of AP upper. The lower triangle A(3:4,0:1) consists of *> the transpose of the first two columns of AP upper. *> For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first *> three columns of AP lower. The upper triangle A(0:1,1:2) consists of *> the transpose of the last two columns of AP lower. *> This covers the case N odd and TRANSR = 'N'. *> *> RFP A RFP A *> *> 02 03 04 00 33 43 *> 12 13 14 10 11 44 *> 22 23 24 20 21 22 *> 00 33 34 30 31 32 *> 01 11 44 40 41 42 *> *> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the *> transpose of RFP A above. One therefore gets: *> *> RFP A RFP A *> *> 02 12 22 00 01 00 10 20 30 40 50 *> 03 13 23 33 11 33 11 21 31 41 51 *> 04 14 24 34 44 43 44 22 32 42 52 *> \endverbatim * * ===================================================================== SUBROUTINE DTFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, $ B, LDB ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, DIAG, SIDE, TRANS, UPLO INTEGER LDB, M, N DOUBLE PRECISION ALPHA * .. * .. Array Arguments .. DOUBLE PRECISION A( 0: * ), B( 0: LDB-1, 0: * ) * .. * * ===================================================================== * * .. * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL LOWER, LSIDE, MISODD, NISODD, NORMALTRANSR, $ NOTRANS INTEGER M1, M2, N1, N2, K, INFO, I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, DGEMM, DTRSM * .. * .. Intrinsic Functions .. INTRINSIC MAX, MOD * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 NORMALTRANSR = LSAME( TRANSR, 'N' ) LSIDE = LSAME( SIDE, 'L' ) LOWER = LSAME( UPLO, 'L' ) NOTRANS = LSAME( TRANS, 'N' ) IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN INFO = -1 ELSE IF( .NOT.LSIDE .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -2 ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN INFO = -3 ELSE IF( .NOT.NOTRANS .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN INFO = -4 ELSE IF( .NOT.LSAME( DIAG, 'N' ) .AND. .NOT.LSAME( DIAG, 'U' ) ) $ THEN INFO = -5 ELSE IF( M.LT.0 ) THEN INFO = -6 ELSE IF( N.LT.0 ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -11 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTFSM ', -INFO ) RETURN END IF * * Quick return when ( (N.EQ.0).OR.(M.EQ.0) ) * IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) $ RETURN * * Quick return when ALPHA.EQ.(0D+0) * IF( ALPHA.EQ.ZERO ) THEN DO 20 J = 0, N - 1 DO 10 I = 0, M - 1 B( I, J ) = ZERO 10 CONTINUE 20 CONTINUE RETURN END IF * IF( LSIDE ) THEN * * SIDE = 'L' * * A is M-by-M. * If M is odd, set NISODD = .TRUE., and M1 and M2. * If M is even, NISODD = .FALSE., and M. * IF( MOD( M, 2 ).EQ.0 ) THEN MISODD = .FALSE. K = M / 2 ELSE MISODD = .TRUE. IF( LOWER ) THEN M2 = M / 2 M1 = M - M2 ELSE M1 = M / 2 M2 = M - M1 END IF END IF * * IF( MISODD ) THEN * * SIDE = 'L' and N is odd * IF( NORMALTRANSR ) THEN * * SIDE = 'L', N is odd, and TRANSR = 'N' * IF( LOWER ) THEN * * SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'L' * IF( NOTRANS ) THEN * * SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and * TRANS = 'N' * IF( M.EQ.1 ) THEN CALL DTRSM( 'L', 'L', 'N', DIAG, M1, N, ALPHA, $ A, M, B, LDB ) ELSE CALL DTRSM( 'L', 'L', 'N', DIAG, M1, N, ALPHA, $ A( 0 ), M, B, LDB ) CALL DGEMM( 'N', 'N', M2, N, M1, -ONE, A( M1 ), $ M, B, LDB, ALPHA, B( M1, 0 ), LDB ) CALL DTRSM( 'L', 'U', 'T', DIAG, M2, N, ONE, $ A( M ), M, B( M1, 0 ), LDB ) END IF * ELSE * * SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and * TRANS = 'T' * IF( M.EQ.1 ) THEN CALL DTRSM( 'L', 'L', 'T', DIAG, M1, N, ALPHA, $ A( 0 ), M, B, LDB ) ELSE CALL DTRSM( 'L', 'U', 'N', DIAG, M2, N, ALPHA, $ A( M ), M, B( M1, 0 ), LDB ) CALL DGEMM( 'T', 'N', M1, N, M2, -ONE, A( M1 ), $ M, B( M1, 0 ), LDB, ALPHA, B, LDB ) CALL DTRSM( 'L', 'L', 'T', DIAG, M1, N, ONE, $ A( 0 ), M, B, LDB ) END IF * END IF * ELSE * * SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'U' * IF( .NOT.NOTRANS ) THEN * * SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and * TRANS = 'N' * CALL DTRSM( 'L', 'L', 'N', DIAG, M1, N, ALPHA, $ A( M2 ), M, B, LDB ) CALL DGEMM( 'T', 'N', M2, N, M1, -ONE, A( 0 ), M, $ B, LDB, ALPHA, B( M1, 0 ), LDB ) CALL DTRSM( 'L', 'U', 'T', DIAG, M2, N, ONE, $ A( M1 ), M, B( M1, 0 ), LDB ) * ELSE * * SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and * TRANS = 'T' * CALL DTRSM( 'L', 'U', 'N', DIAG, M2, N, ALPHA, $ A( M1 ), M, B( M1, 0 ), LDB ) CALL DGEMM( 'N', 'N', M1, N, M2, -ONE, A( 0 ), M, $ B( M1, 0 ), LDB, ALPHA, B, LDB ) CALL DTRSM( 'L', 'L', 'T', DIAG, M1, N, ONE, $ A( M2 ), M, B, LDB ) * END IF * END IF * ELSE * * SIDE = 'L', N is odd, and TRANSR = 'T' * IF( LOWER ) THEN * * SIDE ='L', N is odd, TRANSR = 'T', and UPLO = 'L' * IF( NOTRANS ) THEN * * SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'L', and * TRANS = 'N' * IF( M.EQ.1 ) THEN CALL DTRSM( 'L', 'U', 'T', DIAG, M1, N, ALPHA, $ A( 0 ), M1, B, LDB ) ELSE CALL DTRSM( 'L', 'U', 'T', DIAG, M1, N, ALPHA, $ A( 0 ), M1, B, LDB ) CALL DGEMM( 'T', 'N', M2, N, M1, -ONE, $ A( M1*M1 ), M1, B, LDB, ALPHA, $ B( M1, 0 ), LDB ) CALL DTRSM( 'L', 'L', 'N', DIAG, M2, N, ONE, $ A( 1 ), M1, B( M1, 0 ), LDB ) END IF * ELSE * * SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'L', and * TRANS = 'T' * IF( M.EQ.1 ) THEN CALL DTRSM( 'L', 'U', 'N', DIAG, M1, N, ALPHA, $ A( 0 ), M1, B, LDB ) ELSE CALL DTRSM( 'L', 'L', 'T', DIAG, M2, N, ALPHA, $ A( 1 ), M1, B( M1, 0 ), LDB ) CALL DGEMM( 'N', 'N', M1, N, M2, -ONE, $ A( M1*M1 ), M1, B( M1, 0 ), LDB, $ ALPHA, B, LDB ) CALL DTRSM( 'L', 'U', 'N', DIAG, M1, N, ONE, $ A( 0 ), M1, B, LDB ) END IF * END IF * ELSE * * SIDE ='L', N is odd, TRANSR = 'T', and UPLO = 'U' * IF( .NOT.NOTRANS ) THEN * * SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'U', and * TRANS = 'N' * CALL DTRSM( 'L', 'U', 'T', DIAG, M1, N, ALPHA, $ A( M2*M2 ), M2, B, LDB ) CALL DGEMM( 'N', 'N', M2, N, M1, -ONE, A( 0 ), M2, $ B, LDB, ALPHA, B( M1, 0 ), LDB ) CALL DTRSM( 'L', 'L', 'N', DIAG, M2, N, ONE, $ A( M1*M2 ), M2, B( M1, 0 ), LDB ) * ELSE * * SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'U', and * TRANS = 'T' * CALL DTRSM( 'L', 'L', 'T', DIAG, M2, N, ALPHA, $ A( M1*M2 ), M2, B( M1, 0 ), LDB ) CALL DGEMM( 'T', 'N', M1, N, M2, -ONE, A( 0 ), M2, $ B( M1, 0 ), LDB, ALPHA, B, LDB ) CALL DTRSM( 'L', 'U', 'N', DIAG, M1, N, ONE, $ A( M2*M2 ), M2, B, LDB ) * END IF * END IF * END IF * ELSE * * SIDE = 'L' and N is even * IF( NORMALTRANSR ) THEN * * SIDE = 'L', N is even, and TRANSR = 'N' * IF( LOWER ) THEN * * SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'L' * IF( NOTRANS ) THEN * * SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', * and TRANS = 'N' * CALL DTRSM( 'L', 'L', 'N', DIAG, K, N, ALPHA, $ A( 1 ), M+1, B, LDB ) CALL DGEMM( 'N', 'N', K, N, K, -ONE, A( K+1 ), $ M+1, B, LDB, ALPHA, B( K, 0 ), LDB ) CALL DTRSM( 'L', 'U', 'T', DIAG, K, N, ONE, $ A( 0 ), M+1, B( K, 0 ), LDB ) * ELSE * * SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', * and TRANS = 'T' * CALL DTRSM( 'L', 'U', 'N', DIAG, K, N, ALPHA, $ A( 0 ), M+1, B( K, 0 ), LDB ) CALL DGEMM( 'T', 'N', K, N, K, -ONE, A( K+1 ), $ M+1, B( K, 0 ), LDB, ALPHA, B, LDB ) CALL DTRSM( 'L', 'L', 'T', DIAG, K, N, ONE, $ A( 1 ), M+1, B, LDB ) * END IF * ELSE * * SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'U' * IF( .NOT.NOTRANS ) THEN * * SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', * and TRANS = 'N' * CALL DTRSM( 'L', 'L', 'N', DIAG, K, N, ALPHA, $ A( K+1 ), M+1, B, LDB ) CALL DGEMM( 'T', 'N', K, N, K, -ONE, A( 0 ), M+1, $ B, LDB, ALPHA, B( K, 0 ), LDB ) CALL DTRSM( 'L', 'U', 'T', DIAG, K, N, ONE, $ A( K ), M+1, B( K, 0 ), LDB ) * ELSE * * SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', * and TRANS = 'T' CALL DTRSM( 'L', 'U', 'N', DIAG, K, N, ALPHA, $ A( K ), M+1, B( K, 0 ), LDB ) CALL DGEMM( 'N', 'N', K, N, K, -ONE, A( 0 ), M+1, $ B( K, 0 ), LDB, ALPHA, B, LDB ) CALL DTRSM( 'L', 'L', 'T', DIAG, K, N, ONE, $ A( K+1 ), M+1, B, LDB ) * END IF * END IF * ELSE * * SIDE = 'L', N is even, and TRANSR = 'T' * IF( LOWER ) THEN * * SIDE ='L', N is even, TRANSR = 'T', and UPLO = 'L' * IF( NOTRANS ) THEN * * SIDE ='L', N is even, TRANSR = 'T', UPLO = 'L', * and TRANS = 'N' * CALL DTRSM( 'L', 'U', 'T', DIAG, K, N, ALPHA, $ A( K ), K, B, LDB ) CALL DGEMM( 'T', 'N', K, N, K, -ONE, $ A( K*( K+1 ) ), K, B, LDB, ALPHA, $ B( K, 0 ), LDB ) CALL DTRSM( 'L', 'L', 'N', DIAG, K, N, ONE, $ A( 0 ), K, B( K, 0 ), LDB ) * ELSE * * SIDE ='L', N is even, TRANSR = 'T', UPLO = 'L', * and TRANS = 'T' * CALL DTRSM( 'L', 'L', 'T', DIAG, K, N, ALPHA, $ A( 0 ), K, B( K, 0 ), LDB ) CALL DGEMM( 'N', 'N', K, N, K, -ONE, $ A( K*( K+1 ) ), K, B( K, 0 ), LDB, $ ALPHA, B, LDB ) CALL DTRSM( 'L', 'U', 'N', DIAG, K, N, ONE, $ A( K ), K, B, LDB ) * END IF * ELSE * * SIDE ='L', N is even, TRANSR = 'T', and UPLO = 'U' * IF( .NOT.NOTRANS ) THEN * * SIDE ='L', N is even, TRANSR = 'T', UPLO = 'U', * and TRANS = 'N' * CALL DTRSM( 'L', 'U', 'T', DIAG, K, N, ALPHA, $ A( K*( K+1 ) ), K, B, LDB ) CALL DGEMM( 'N', 'N', K, N, K, -ONE, A( 0 ), K, B, $ LDB, ALPHA, B( K, 0 ), LDB ) CALL DTRSM( 'L', 'L', 'N', DIAG, K, N, ONE, $ A( K*K ), K, B( K, 0 ), LDB ) * ELSE * * SIDE ='L', N is even, TRANSR = 'T', UPLO = 'U', * and TRANS = 'T' * CALL DTRSM( 'L', 'L', 'T', DIAG, K, N, ALPHA, $ A( K*K ), K, B( K, 0 ), LDB ) CALL DGEMM( 'T', 'N', K, N, K, -ONE, A( 0 ), K, $ B( K, 0 ), LDB, ALPHA, B, LDB ) CALL DTRSM( 'L', 'U', 'N', DIAG, K, N, ONE, $ A( K*( K+1 ) ), K, B, LDB ) * END IF * END IF * END IF * END IF * ELSE * * SIDE = 'R' * * A is N-by-N. * If N is odd, set NISODD = .TRUE., and N1 and N2. * If N is even, NISODD = .FALSE., and K. * IF( MOD( N, 2 ).EQ.0 ) THEN NISODD = .FALSE. K = N / 2 ELSE NISODD = .TRUE. IF( LOWER ) THEN N2 = N / 2 N1 = N - N2 ELSE N1 = N / 2 N2 = N - N1 END IF END IF * IF( NISODD ) THEN * * SIDE = 'R' and N is odd * IF( NORMALTRANSR ) THEN * * SIDE = 'R', N is odd, and TRANSR = 'N' * IF( LOWER ) THEN * * SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'L' * IF( NOTRANS ) THEN * * SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and * TRANS = 'N' * CALL DTRSM( 'R', 'U', 'T', DIAG, M, N2, ALPHA, $ A( N ), N, B( 0, N1 ), LDB ) CALL DGEMM( 'N', 'N', M, N1, N2, -ONE, B( 0, N1 ), $ LDB, A( N1 ), N, ALPHA, B( 0, 0 ), $ LDB ) CALL DTRSM( 'R', 'L', 'N', DIAG, M, N1, ONE, $ A( 0 ), N, B( 0, 0 ), LDB ) * ELSE * * SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and * TRANS = 'T' * CALL DTRSM( 'R', 'L', 'T', DIAG, M, N1, ALPHA, $ A( 0 ), N, B( 0, 0 ), LDB ) CALL DGEMM( 'N', 'T', M, N2, N1, -ONE, B( 0, 0 ), $ LDB, A( N1 ), N, ALPHA, B( 0, N1 ), $ LDB ) CALL DTRSM( 'R', 'U', 'N', DIAG, M, N2, ONE, $ A( N ), N, B( 0, N1 ), LDB ) * END IF * ELSE * * SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'U' * IF( NOTRANS ) THEN * * SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and * TRANS = 'N' * CALL DTRSM( 'R', 'L', 'T', DIAG, M, N1, ALPHA, $ A( N2 ), N, B( 0, 0 ), LDB ) CALL DGEMM( 'N', 'N', M, N2, N1, -ONE, B( 0, 0 ), $ LDB, A( 0 ), N, ALPHA, B( 0, N1 ), $ LDB ) CALL DTRSM( 'R', 'U', 'N', DIAG, M, N2, ONE, $ A( N1 ), N, B( 0, N1 ), LDB ) * ELSE * * SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and * TRANS = 'T' * CALL DTRSM( 'R', 'U', 'T', DIAG, M, N2, ALPHA, $ A( N1 ), N, B( 0, N1 ), LDB ) CALL DGEMM( 'N', 'T', M, N1, N2, -ONE, B( 0, N1 ), $ LDB, A( 0 ), N, ALPHA, B( 0, 0 ), LDB ) CALL DTRSM( 'R', 'L', 'N', DIAG, M, N1, ONE, $ A( N2 ), N, B( 0, 0 ), LDB ) * END IF * END IF * ELSE * * SIDE = 'R', N is odd, and TRANSR = 'T' * IF( LOWER ) THEN * * SIDE ='R', N is odd, TRANSR = 'T', and UPLO = 'L' * IF( NOTRANS ) THEN * * SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'L', and * TRANS = 'N' * CALL DTRSM( 'R', 'L', 'N', DIAG, M, N2, ALPHA, $ A( 1 ), N1, B( 0, N1 ), LDB ) CALL DGEMM( 'N', 'T', M, N1, N2, -ONE, B( 0, N1 ), $ LDB, A( N1*N1 ), N1, ALPHA, B( 0, 0 ), $ LDB ) CALL DTRSM( 'R', 'U', 'T', DIAG, M, N1, ONE, $ A( 0 ), N1, B( 0, 0 ), LDB ) * ELSE * * SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'L', and * TRANS = 'T' * CALL DTRSM( 'R', 'U', 'N', DIAG, M, N1, ALPHA, $ A( 0 ), N1, B( 0, 0 ), LDB ) CALL DGEMM( 'N', 'N', M, N2, N1, -ONE, B( 0, 0 ), $ LDB, A( N1*N1 ), N1, ALPHA, B( 0, N1 ), $ LDB ) CALL DTRSM( 'R', 'L', 'T', DIAG, M, N2, ONE, $ A( 1 ), N1, B( 0, N1 ), LDB ) * END IF * ELSE * * SIDE ='R', N is odd, TRANSR = 'T', and UPLO = 'U' * IF( NOTRANS ) THEN * * SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'U', and * TRANS = 'N' * CALL DTRSM( 'R', 'U', 'N', DIAG, M, N1, ALPHA, $ A( N2*N2 ), N2, B( 0, 0 ), LDB ) CALL DGEMM( 'N', 'T', M, N2, N1, -ONE, B( 0, 0 ), $ LDB, A( 0 ), N2, ALPHA, B( 0, N1 ), $ LDB ) CALL DTRSM( 'R', 'L', 'T', DIAG, M, N2, ONE, $ A( N1*N2 ), N2, B( 0, N1 ), LDB ) * ELSE * * SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'U', and * TRANS = 'T' * CALL DTRSM( 'R', 'L', 'N', DIAG, M, N2, ALPHA, $ A( N1*N2 ), N2, B( 0, N1 ), LDB ) CALL DGEMM( 'N', 'N', M, N1, N2, -ONE, B( 0, N1 ), $ LDB, A( 0 ), N2, ALPHA, B( 0, 0 ), $ LDB ) CALL DTRSM( 'R', 'U', 'T', DIAG, M, N1, ONE, $ A( N2*N2 ), N2, B( 0, 0 ), LDB ) * END IF * END IF * END IF * ELSE * * SIDE = 'R' and N is even * IF( NORMALTRANSR ) THEN * * SIDE = 'R', N is even, and TRANSR = 'N' * IF( LOWER ) THEN * * SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'L' * IF( NOTRANS ) THEN * * SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', * and TRANS = 'N' * CALL DTRSM( 'R', 'U', 'T', DIAG, M, K, ALPHA, $ A( 0 ), N+1, B( 0, K ), LDB ) CALL DGEMM( 'N', 'N', M, K, K, -ONE, B( 0, K ), $ LDB, A( K+1 ), N+1, ALPHA, B( 0, 0 ), $ LDB ) CALL DTRSM( 'R', 'L', 'N', DIAG, M, K, ONE, $ A( 1 ), N+1, B( 0, 0 ), LDB ) * ELSE * * SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', * and TRANS = 'T' * CALL DTRSM( 'R', 'L', 'T', DIAG, M, K, ALPHA, $ A( 1 ), N+1, B( 0, 0 ), LDB ) CALL DGEMM( 'N', 'T', M, K, K, -ONE, B( 0, 0 ), $ LDB, A( K+1 ), N+1, ALPHA, B( 0, K ), $ LDB ) CALL DTRSM( 'R', 'U', 'N', DIAG, M, K, ONE, $ A( 0 ), N+1, B( 0, K ), LDB ) * END IF * ELSE * * SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'U' * IF( NOTRANS ) THEN * * SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', * and TRANS = 'N' * CALL DTRSM( 'R', 'L', 'T', DIAG, M, K, ALPHA, $ A( K+1 ), N+1, B( 0, 0 ), LDB ) CALL DGEMM( 'N', 'N', M, K, K, -ONE, B( 0, 0 ), $ LDB, A( 0 ), N+1, ALPHA, B( 0, K ), $ LDB ) CALL DTRSM( 'R', 'U', 'N', DIAG, M, K, ONE, $ A( K ), N+1, B( 0, K ), LDB ) * ELSE * * SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', * and TRANS = 'T' * CALL DTRSM( 'R', 'U', 'T', DIAG, M, K, ALPHA, $ A( K ), N+1, B( 0, K ), LDB ) CALL DGEMM( 'N', 'T', M, K, K, -ONE, B( 0, K ), $ LDB, A( 0 ), N+1, ALPHA, B( 0, 0 ), $ LDB ) CALL DTRSM( 'R', 'L', 'N', DIAG, M, K, ONE, $ A( K+1 ), N+1, B( 0, 0 ), LDB ) * END IF * END IF * ELSE * * SIDE = 'R', N is even, and TRANSR = 'T' * IF( LOWER ) THEN * * SIDE ='R', N is even, TRANSR = 'T', and UPLO = 'L' * IF( NOTRANS ) THEN * * SIDE ='R', N is even, TRANSR = 'T', UPLO = 'L', * and TRANS = 'N' * CALL DTRSM( 'R', 'L', 'N', DIAG, M, K, ALPHA, $ A( 0 ), K, B( 0, K ), LDB ) CALL DGEMM( 'N', 'T', M, K, K, -ONE, B( 0, K ), $ LDB, A( ( K+1 )*K ), K, ALPHA, $ B( 0, 0 ), LDB ) CALL DTRSM( 'R', 'U', 'T', DIAG, M, K, ONE, $ A( K ), K, B( 0, 0 ), LDB ) * ELSE * * SIDE ='R', N is even, TRANSR = 'T', UPLO = 'L', * and TRANS = 'T' * CALL DTRSM( 'R', 'U', 'N', DIAG, M, K, ALPHA, $ A( K ), K, B( 0, 0 ), LDB ) CALL DGEMM( 'N', 'N', M, K, K, -ONE, B( 0, 0 ), $ LDB, A( ( K+1 )*K ), K, ALPHA, $ B( 0, K ), LDB ) CALL DTRSM( 'R', 'L', 'T', DIAG, M, K, ONE, $ A( 0 ), K, B( 0, K ), LDB ) * END IF * ELSE * * SIDE ='R', N is even, TRANSR = 'T', and UPLO = 'U' * IF( NOTRANS ) THEN * * SIDE ='R', N is even, TRANSR = 'T', UPLO = 'U', * and TRANS = 'N' * CALL DTRSM( 'R', 'U', 'N', DIAG, M, K, ALPHA, $ A( ( K+1 )*K ), K, B( 0, 0 ), LDB ) CALL DGEMM( 'N', 'T', M, K, K, -ONE, B( 0, 0 ), $ LDB, A( 0 ), K, ALPHA, B( 0, K ), LDB ) CALL DTRSM( 'R', 'L', 'T', DIAG, M, K, ONE, $ A( K*K ), K, B( 0, K ), LDB ) * ELSE * * SIDE ='R', N is even, TRANSR = 'T', UPLO = 'U', * and TRANS = 'T' * CALL DTRSM( 'R', 'L', 'N', DIAG, M, K, ALPHA, $ A( K*K ), K, B( 0, K ), LDB ) CALL DGEMM( 'N', 'N', M, K, K, -ONE, B( 0, K ), $ LDB, A( 0 ), K, ALPHA, B( 0, 0 ), LDB ) CALL DTRSM( 'R', 'U', 'T', DIAG, M, K, ONE, $ A( ( K+1 )*K ), K, B( 0, 0 ), LDB ) * END IF * END IF * END IF * END IF END IF * RETURN * * End of DTFSM * END *> \brief \b DTFTRI * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTFTRI + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTFTRI( TRANSR, UPLO, DIAG, N, A, INFO ) * * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO, DIAG * INTEGER INFO, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( 0: * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTFTRI computes the inverse of a triangular matrix A stored in RFP *> format. *> *> This is a Level 3 BLAS version of the algorithm. *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANSR *> \verbatim *> TRANSR is CHARACTER*1 *> = 'N': The Normal TRANSR of RFP A is stored; *> = 'T': The Transpose TRANSR of RFP A is stored. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': A is upper triangular; *> = 'L': A is lower triangular. *> \endverbatim *> *> \param[in] DIAG *> \verbatim *> DIAG is CHARACTER*1 *> = 'N': A is non-unit triangular; *> = 'U': A is unit triangular. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (0:nt-1); *> nt=N*(N+1)/2. On entry, the triangular factor of a Hermitian *> Positive Definite matrix A in RFP format. RFP format is *> described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' *> then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is *> (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is *> the transpose of RFP A as defined when *> TRANSR = 'N'. The contents of RFP A are defined by UPLO as *> follows: If UPLO = 'U' the RFP A contains the nt elements of *> upper packed A; If UPLO = 'L' the RFP A contains the nt *> elements of lower packed A. The LDA of RFP A is (N+1)/2 when *> TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is *> even and N is odd. See the Note below for more details. *> *> On exit, the (triangular) inverse of the original matrix, in *> the same storage format. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, A(i,i) is exactly zero. The triangular *> matrix is singular and its inverse can not be computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> We first consider Rectangular Full Packed (RFP) Format when N is *> even. We give an example where N = 6. *> *> AP is Upper AP is Lower *> *> 00 01 02 03 04 05 00 *> 11 12 13 14 15 10 11 *> 22 23 24 25 20 21 22 *> 33 34 35 30 31 32 33 *> 44 45 40 41 42 43 44 *> 55 50 51 52 53 54 55 *> *> *> Let TRANSR = 'N'. RFP holds AP as follows: *> For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last *> three columns of AP upper. The lower triangle A(4:6,0:2) consists of *> the transpose of the first three columns of AP upper. *> For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first *> three columns of AP lower. The upper triangle A(0:2,0:2) consists of *> the transpose of the last three columns of AP lower. *> This covers the case N even and TRANSR = 'N'. *> *> RFP A RFP A *> *> 03 04 05 33 43 53 *> 13 14 15 00 44 54 *> 23 24 25 10 11 55 *> 33 34 35 20 21 22 *> 00 44 45 30 31 32 *> 01 11 55 40 41 42 *> 02 12 22 50 51 52 *> *> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the *> transpose of RFP A above. One therefore gets: *> *> *> RFP A RFP A *> *> 03 13 23 33 00 01 02 33 00 10 20 30 40 50 *> 04 14 24 34 44 11 12 43 44 11 21 31 41 51 *> 05 15 25 35 45 55 22 53 54 55 22 32 42 52 *> *> *> We then consider Rectangular Full Packed (RFP) Format when N is *> odd. We give an example where N = 5. *> *> AP is Upper AP is Lower *> *> 00 01 02 03 04 00 *> 11 12 13 14 10 11 *> 22 23 24 20 21 22 *> 33 34 30 31 32 33 *> 44 40 41 42 43 44 *> *> *> Let TRANSR = 'N'. RFP holds AP as follows: *> For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last *> three columns of AP upper. The lower triangle A(3:4,0:1) consists of *> the transpose of the first two columns of AP upper. *> For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first *> three columns of AP lower. The upper triangle A(0:1,1:2) consists of *> the transpose of the last two columns of AP lower. *> This covers the case N odd and TRANSR = 'N'. *> *> RFP A RFP A *> *> 02 03 04 00 33 43 *> 12 13 14 10 11 44 *> 22 23 24 20 21 22 *> 00 33 34 30 31 32 *> 01 11 44 40 41 42 *> *> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the *> transpose of RFP A above. One therefore gets: *> *> RFP A RFP A *> *> 02 12 22 00 01 00 10 20 30 40 50 *> 03 13 23 33 11 33 11 21 31 41 51 *> 04 14 24 34 44 43 44 22 32 42 52 *> \endverbatim *> * ===================================================================== SUBROUTINE DTFTRI( TRANSR, UPLO, DIAG, N, A, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO, DIAG INTEGER INFO, N * .. * .. Array Arguments .. DOUBLE PRECISION A( 0: * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LOWER, NISODD, NORMALTRANSR INTEGER N1, N2, K * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, DTRMM, DTRTRI * .. * .. Intrinsic Functions .. INTRINSIC MOD * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 NORMALTRANSR = LSAME( TRANSR, 'N' ) LOWER = LSAME( UPLO, 'L' ) IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN INFO = -1 ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN INFO = -2 ELSE IF( .NOT.LSAME( DIAG, 'N' ) .AND. .NOT.LSAME( DIAG, 'U' ) ) $ THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTFTRI', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * If N is odd, set NISODD = .TRUE. * If N is even, set K = N/2 and NISODD = .FALSE. * IF( MOD( N, 2 ).EQ.0 ) THEN K = N / 2 NISODD = .FALSE. ELSE NISODD = .TRUE. END IF * * Set N1 and N2 depending on LOWER * IF( LOWER ) THEN N2 = N / 2 N1 = N - N2 ELSE N1 = N / 2 N2 = N - N1 END IF * * * start execution: there are eight cases * IF( NISODD ) THEN * * N is odd * IF( NORMALTRANSR ) THEN * * N is odd and TRANSR = 'N' * IF( LOWER ) THEN * * SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) * T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) * T1 -> a(0), T2 -> a(n), S -> a(n1) * CALL DTRTRI( 'L', DIAG, N1, A( 0 ), N, INFO ) IF( INFO.GT.0 ) $ RETURN CALL DTRMM( 'R', 'L', 'N', DIAG, N2, N1, -ONE, A( 0 ), $ N, A( N1 ), N ) CALL DTRTRI( 'U', DIAG, N2, A( N ), N, INFO ) IF( INFO.GT.0 ) $ INFO = INFO + N1 IF( INFO.GT.0 ) $ RETURN CALL DTRMM( 'L', 'U', 'T', DIAG, N2, N1, ONE, A( N ), N, $ A( N1 ), N ) * ELSE * * SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) * T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) * T1 -> a(n2), T2 -> a(n1), S -> a(0) * CALL DTRTRI( 'L', DIAG, N1, A( N2 ), N, INFO ) IF( INFO.GT.0 ) $ RETURN CALL DTRMM( 'L', 'L', 'T', DIAG, N1, N2, -ONE, A( N2 ), $ N, A( 0 ), N ) CALL DTRTRI( 'U', DIAG, N2, A( N1 ), N, INFO ) IF( INFO.GT.0 ) $ INFO = INFO + N1 IF( INFO.GT.0 ) $ RETURN CALL DTRMM( 'R', 'U', 'N', DIAG, N1, N2, ONE, A( N1 ), $ N, A( 0 ), N ) * END IF * ELSE * * N is odd and TRANSR = 'T' * IF( LOWER ) THEN * * SRPA for LOWER, TRANSPOSE and N is odd * T1 -> a(0), T2 -> a(1), S -> a(0+n1*n1) * CALL DTRTRI( 'U', DIAG, N1, A( 0 ), N1, INFO ) IF( INFO.GT.0 ) $ RETURN CALL DTRMM( 'L', 'U', 'N', DIAG, N1, N2, -ONE, A( 0 ), $ N1, A( N1*N1 ), N1 ) CALL DTRTRI( 'L', DIAG, N2, A( 1 ), N1, INFO ) IF( INFO.GT.0 ) $ INFO = INFO + N1 IF( INFO.GT.0 ) $ RETURN CALL DTRMM( 'R', 'L', 'T', DIAG, N1, N2, ONE, A( 1 ), $ N1, A( N1*N1 ), N1 ) * ELSE * * SRPA for UPPER, TRANSPOSE and N is odd * T1 -> a(0+n2*n2), T2 -> a(0+n1*n2), S -> a(0) * CALL DTRTRI( 'U', DIAG, N1, A( N2*N2 ), N2, INFO ) IF( INFO.GT.0 ) $ RETURN CALL DTRMM( 'R', 'U', 'T', DIAG, N2, N1, -ONE, $ A( N2*N2 ), N2, A( 0 ), N2 ) CALL DTRTRI( 'L', DIAG, N2, A( N1*N2 ), N2, INFO ) IF( INFO.GT.0 ) $ INFO = INFO + N1 IF( INFO.GT.0 ) $ RETURN CALL DTRMM( 'L', 'L', 'N', DIAG, N2, N1, ONE, $ A( N1*N2 ), N2, A( 0 ), N2 ) END IF * END IF * ELSE * * N is even * IF( NORMALTRANSR ) THEN * * N is even and TRANSR = 'N' * IF( LOWER ) THEN * * SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) * T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) * T1 -> a(1), T2 -> a(0), S -> a(k+1) * CALL DTRTRI( 'L', DIAG, K, A( 1 ), N+1, INFO ) IF( INFO.GT.0 ) $ RETURN CALL DTRMM( 'R', 'L', 'N', DIAG, K, K, -ONE, A( 1 ), $ N+1, A( K+1 ), N+1 ) CALL DTRTRI( 'U', DIAG, K, A( 0 ), N+1, INFO ) IF( INFO.GT.0 ) $ INFO = INFO + K IF( INFO.GT.0 ) $ RETURN CALL DTRMM( 'L', 'U', 'T', DIAG, K, K, ONE, A( 0 ), N+1, $ A( K+1 ), N+1 ) * ELSE * * SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) * T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) * T1 -> a(k+1), T2 -> a(k), S -> a(0) * CALL DTRTRI( 'L', DIAG, K, A( K+1 ), N+1, INFO ) IF( INFO.GT.0 ) $ RETURN CALL DTRMM( 'L', 'L', 'T', DIAG, K, K, -ONE, A( K+1 ), $ N+1, A( 0 ), N+1 ) CALL DTRTRI( 'U', DIAG, K, A( K ), N+1, INFO ) IF( INFO.GT.0 ) $ INFO = INFO + K IF( INFO.GT.0 ) $ RETURN CALL DTRMM( 'R', 'U', 'N', DIAG, K, K, ONE, A( K ), N+1, $ A( 0 ), N+1 ) END IF ELSE * * N is even and TRANSR = 'T' * IF( LOWER ) THEN * * SRPA for LOWER, TRANSPOSE and N is even (see paper) * T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) * T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k * CALL DTRTRI( 'U', DIAG, K, A( K ), K, INFO ) IF( INFO.GT.0 ) $ RETURN CALL DTRMM( 'L', 'U', 'N', DIAG, K, K, -ONE, A( K ), K, $ A( K*( K+1 ) ), K ) CALL DTRTRI( 'L', DIAG, K, A( 0 ), K, INFO ) IF( INFO.GT.0 ) $ INFO = INFO + K IF( INFO.GT.0 ) $ RETURN CALL DTRMM( 'R', 'L', 'T', DIAG, K, K, ONE, A( 0 ), K, $ A( K*( K+1 ) ), K ) ELSE * * SRPA for UPPER, TRANSPOSE and N is even (see paper) * T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) * T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k * CALL DTRTRI( 'U', DIAG, K, A( K*( K+1 ) ), K, INFO ) IF( INFO.GT.0 ) $ RETURN CALL DTRMM( 'R', 'U', 'T', DIAG, K, K, -ONE, $ A( K*( K+1 ) ), K, A( 0 ), K ) CALL DTRTRI( 'L', DIAG, K, A( K*K ), K, INFO ) IF( INFO.GT.0 ) $ INFO = INFO + K IF( INFO.GT.0 ) $ RETURN CALL DTRMM( 'L', 'L', 'N', DIAG, K, K, ONE, A( K*K ), K, $ A( 0 ), K ) END IF END IF END IF * RETURN * * End of DTFTRI * END *> \brief \b DTFTTP copies a triangular matrix from the rectangular full packed format (TF) to the standard packed format (TP). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTFTTP + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTFTTP( TRANSR, UPLO, N, ARF, AP, INFO ) * * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER INFO, N * .. * .. Array Arguments .. * DOUBLE PRECISION AP( 0: * ), ARF( 0: * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTFTTP copies a triangular matrix A from rectangular full packed *> format (TF) to standard packed format (TP). *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANSR *> \verbatim *> TRANSR is CHARACTER*1 *> = 'N': ARF is in Normal format; *> = 'T': ARF is in Transpose format; *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': A is upper triangular; *> = 'L': A is lower triangular. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] ARF *> \verbatim *> ARF is DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), *> On entry, the upper or lower triangular matrix A stored in *> RFP format. For a further discussion see Notes below. *> \endverbatim *> *> \param[out] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), *> On exit, the upper or lower triangular matrix A, packed *> columnwise in a linear array. The j-th column of A is stored *> in the array AP as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> We first consider Rectangular Full Packed (RFP) Format when N is *> even. We give an example where N = 6. *> *> AP is Upper AP is Lower *> *> 00 01 02 03 04 05 00 *> 11 12 13 14 15 10 11 *> 22 23 24 25 20 21 22 *> 33 34 35 30 31 32 33 *> 44 45 40 41 42 43 44 *> 55 50 51 52 53 54 55 *> *> *> Let TRANSR = 'N'. RFP holds AP as follows: *> For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last *> three columns of AP upper. The lower triangle A(4:6,0:2) consists of *> the transpose of the first three columns of AP upper. *> For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first *> three columns of AP lower. The upper triangle A(0:2,0:2) consists of *> the transpose of the last three columns of AP lower. *> This covers the case N even and TRANSR = 'N'. *> *> RFP A RFP A *> *> 03 04 05 33 43 53 *> 13 14 15 00 44 54 *> 23 24 25 10 11 55 *> 33 34 35 20 21 22 *> 00 44 45 30 31 32 *> 01 11 55 40 41 42 *> 02 12 22 50 51 52 *> *> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the *> transpose of RFP A above. One therefore gets: *> *> *> RFP A RFP A *> *> 03 13 23 33 00 01 02 33 00 10 20 30 40 50 *> 04 14 24 34 44 11 12 43 44 11 21 31 41 51 *> 05 15 25 35 45 55 22 53 54 55 22 32 42 52 *> *> *> We then consider Rectangular Full Packed (RFP) Format when N is *> odd. We give an example where N = 5. *> *> AP is Upper AP is Lower *> *> 00 01 02 03 04 00 *> 11 12 13 14 10 11 *> 22 23 24 20 21 22 *> 33 34 30 31 32 33 *> 44 40 41 42 43 44 *> *> *> Let TRANSR = 'N'. RFP holds AP as follows: *> For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last *> three columns of AP upper. The lower triangle A(3:4,0:1) consists of *> the transpose of the first two columns of AP upper. *> For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first *> three columns of AP lower. The upper triangle A(0:1,1:2) consists of *> the transpose of the last two columns of AP lower. *> This covers the case N odd and TRANSR = 'N'. *> *> RFP A RFP A *> *> 02 03 04 00 33 43 *> 12 13 14 10 11 44 *> 22 23 24 20 21 22 *> 00 33 34 30 31 32 *> 01 11 44 40 41 42 *> *> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the *> transpose of RFP A above. One therefore gets: *> *> RFP A RFP A *> *> 02 12 22 00 01 00 10 20 30 40 50 *> 03 13 23 33 11 33 11 21 31 41 51 *> 04 14 24 34 44 43 44 22 32 42 52 *> \endverbatim *> * ===================================================================== SUBROUTINE DTFTTP( TRANSR, UPLO, N, ARF, AP, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO INTEGER INFO, N * .. * .. Array Arguments .. DOUBLE PRECISION AP( 0: * ), ARF( 0: * ) * .. * * ===================================================================== * * .. Parameters .. * .. * .. Local Scalars .. LOGICAL LOWER, NISODD, NORMALTRANSR INTEGER N1, N2, K, NT INTEGER I, J, IJ INTEGER IJP, JP, LDA, JS * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 NORMALTRANSR = LSAME( TRANSR, 'N' ) LOWER = LSAME( UPLO, 'L' ) IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN INFO = -1 ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTFTTP', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( N.EQ.1 ) THEN IF( NORMALTRANSR ) THEN AP( 0 ) = ARF( 0 ) ELSE AP( 0 ) = ARF( 0 ) END IF RETURN END IF * * Size of array ARF(0:NT-1) * NT = N*( N+1 ) / 2 * * Set N1 and N2 depending on LOWER * IF( LOWER ) THEN N2 = N / 2 N1 = N - N2 ELSE N1 = N / 2 N2 = N - N1 END IF * * If N is odd, set NISODD = .TRUE. * If N is even, set K = N/2 and NISODD = .FALSE. * * set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe) * where noe = 0 if n is even, noe = 1 if n is odd * IF( MOD( N, 2 ).EQ.0 ) THEN K = N / 2 NISODD = .FALSE. LDA = N + 1 ELSE NISODD = .TRUE. LDA = N END IF * * ARF^C has lda rows and n+1-noe cols * IF( .NOT.NORMALTRANSR ) $ LDA = ( N+1 ) / 2 * * start execution: there are eight cases * IF( NISODD ) THEN * * N is odd * IF( NORMALTRANSR ) THEN * * N is odd and TRANSR = 'N' * IF( LOWER ) THEN * * SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) * T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) * T1 -> a(0), T2 -> a(n), S -> a(n1); lda = n * IJP = 0 JP = 0 DO J = 0, N2 DO I = J, N - 1 IJ = I + JP AP( IJP ) = ARF( IJ ) IJP = IJP + 1 END DO JP = JP + LDA END DO DO I = 0, N2 - 1 DO J = 1 + I, N2 IJ = I + J*LDA AP( IJP ) = ARF( IJ ) IJP = IJP + 1 END DO END DO * ELSE * * SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) * T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) * T1 -> a(n2), T2 -> a(n1), S -> a(0) * IJP = 0 DO J = 0, N1 - 1 IJ = N2 + J DO I = 0, J AP( IJP ) = ARF( IJ ) IJP = IJP + 1 IJ = IJ + LDA END DO END DO JS = 0 DO J = N1, N - 1 IJ = JS DO IJ = JS, JS + J AP( IJP ) = ARF( IJ ) IJP = IJP + 1 END DO JS = JS + LDA END DO * END IF * ELSE * * N is odd and TRANSR = 'T' * IF( LOWER ) THEN * * SRPA for LOWER, TRANSPOSE and N is odd * T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) * T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 * IJP = 0 DO I = 0, N2 DO IJ = I*( LDA+1 ), N*LDA - 1, LDA AP( IJP ) = ARF( IJ ) IJP = IJP + 1 END DO END DO JS = 1 DO J = 0, N2 - 1 DO IJ = JS, JS + N2 - J - 1 AP( IJP ) = ARF( IJ ) IJP = IJP + 1 END DO JS = JS + LDA + 1 END DO * ELSE * * SRPA for UPPER, TRANSPOSE and N is odd * T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) * T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 * IJP = 0 JS = N2*LDA DO J = 0, N1 - 1 DO IJ = JS, JS + J AP( IJP ) = ARF( IJ ) IJP = IJP + 1 END DO JS = JS + LDA END DO DO I = 0, N1 DO IJ = I, I + ( N1+I )*LDA, LDA AP( IJP ) = ARF( IJ ) IJP = IJP + 1 END DO END DO * END IF * END IF * ELSE * * N is even * IF( NORMALTRANSR ) THEN * * N is even and TRANSR = 'N' * IF( LOWER ) THEN * * SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) * T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) * T1 -> a(1), T2 -> a(0), S -> a(k+1) * IJP = 0 JP = 0 DO J = 0, K - 1 DO I = J, N - 1 IJ = 1 + I + JP AP( IJP ) = ARF( IJ ) IJP = IJP + 1 END DO JP = JP + LDA END DO DO I = 0, K - 1 DO J = I, K - 1 IJ = I + J*LDA AP( IJP ) = ARF( IJ ) IJP = IJP + 1 END DO END DO * ELSE * * SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) * T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) * T1 -> a(k+1), T2 -> a(k), S -> a(0) * IJP = 0 DO J = 0, K - 1 IJ = K + 1 + J DO I = 0, J AP( IJP ) = ARF( IJ ) IJP = IJP + 1 IJ = IJ + LDA END DO END DO JS = 0 DO J = K, N - 1 IJ = JS DO IJ = JS, JS + J AP( IJP ) = ARF( IJ ) IJP = IJP + 1 END DO JS = JS + LDA END DO * END IF * ELSE * * N is even and TRANSR = 'T' * IF( LOWER ) THEN * * SRPA for LOWER, TRANSPOSE and N is even (see paper) * T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) * T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k * IJP = 0 DO I = 0, K - 1 DO IJ = I + ( I+1 )*LDA, ( N+1 )*LDA - 1, LDA AP( IJP ) = ARF( IJ ) IJP = IJP + 1 END DO END DO JS = 0 DO J = 0, K - 1 DO IJ = JS, JS + K - J - 1 AP( IJP ) = ARF( IJ ) IJP = IJP + 1 END DO JS = JS + LDA + 1 END DO * ELSE * * SRPA for UPPER, TRANSPOSE and N is even (see paper) * T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) * T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k * IJP = 0 JS = ( K+1 )*LDA DO J = 0, K - 1 DO IJ = JS, JS + J AP( IJP ) = ARF( IJ ) IJP = IJP + 1 END DO JS = JS + LDA END DO DO I = 0, K - 1 DO IJ = I, I + ( K+I )*LDA, LDA AP( IJP ) = ARF( IJ ) IJP = IJP + 1 END DO END DO * END IF * END IF * END IF * RETURN * * End of DTFTTP * END *> \brief \b DTFTTR copies a triangular matrix from the rectangular full packed format (TF) to the standard full format (TR). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTFTTR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO ) * * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER INFO, N, LDA * .. * .. Array Arguments .. * DOUBLE PRECISION A( 0: LDA-1, 0: * ), ARF( 0: * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTFTTR copies a triangular matrix A from rectangular full packed *> format (TF) to standard full format (TR). *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANSR *> \verbatim *> TRANSR is CHARACTER*1 *> = 'N': ARF is in Normal format; *> = 'T': ARF is in Transpose format. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': A is upper triangular; *> = 'L': A is lower triangular. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices ARF and A. N >= 0. *> \endverbatim *> *> \param[in] ARF *> \verbatim *> ARF is DOUBLE PRECISION array, dimension (N*(N+1)/2). *> On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L') *> matrix A in RFP format. See the "Notes" below for more *> details. *> \endverbatim *> *> \param[out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On exit, the triangular matrix A. If UPLO = 'U', the *> leading N-by-N upper triangular part of the array A contains *> the upper triangular matrix, and the strictly lower *> triangular part of A is not referenced. If UPLO = 'L', the *> leading N-by-N lower triangular part of the array A contains *> the lower triangular matrix, and the strictly upper *> triangular part of A is not referenced. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> We first consider Rectangular Full Packed (RFP) Format when N is *> even. We give an example where N = 6. *> *> AP is Upper AP is Lower *> *> 00 01 02 03 04 05 00 *> 11 12 13 14 15 10 11 *> 22 23 24 25 20 21 22 *> 33 34 35 30 31 32 33 *> 44 45 40 41 42 43 44 *> 55 50 51 52 53 54 55 *> *> *> Let TRANSR = 'N'. RFP holds AP as follows: *> For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last *> three columns of AP upper. The lower triangle A(4:6,0:2) consists of *> the transpose of the first three columns of AP upper. *> For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first *> three columns of AP lower. The upper triangle A(0:2,0:2) consists of *> the transpose of the last three columns of AP lower. *> This covers the case N even and TRANSR = 'N'. *> *> RFP A RFP A *> *> 03 04 05 33 43 53 *> 13 14 15 00 44 54 *> 23 24 25 10 11 55 *> 33 34 35 20 21 22 *> 00 44 45 30 31 32 *> 01 11 55 40 41 42 *> 02 12 22 50 51 52 *> *> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the *> transpose of RFP A above. One therefore gets: *> *> *> RFP A RFP A *> *> 03 13 23 33 00 01 02 33 00 10 20 30 40 50 *> 04 14 24 34 44 11 12 43 44 11 21 31 41 51 *> 05 15 25 35 45 55 22 53 54 55 22 32 42 52 *> *> *> We then consider Rectangular Full Packed (RFP) Format when N is *> odd. We give an example where N = 5. *> *> AP is Upper AP is Lower *> *> 00 01 02 03 04 00 *> 11 12 13 14 10 11 *> 22 23 24 20 21 22 *> 33 34 30 31 32 33 *> 44 40 41 42 43 44 *> *> *> Let TRANSR = 'N'. RFP holds AP as follows: *> For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last *> three columns of AP upper. The lower triangle A(3:4,0:1) consists of *> the transpose of the first two columns of AP upper. *> For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first *> three columns of AP lower. The upper triangle A(0:1,1:2) consists of *> the transpose of the last two columns of AP lower. *> This covers the case N odd and TRANSR = 'N'. *> *> RFP A RFP A *> *> 02 03 04 00 33 43 *> 12 13 14 10 11 44 *> 22 23 24 20 21 22 *> 00 33 34 30 31 32 *> 01 11 44 40 41 42 *> *> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the *> transpose of RFP A above. One therefore gets: *> *> RFP A RFP A *> *> 02 12 22 00 01 00 10 20 30 40 50 *> 03 13 23 33 11 33 11 21 31 41 51 *> 04 14 24 34 44 43 44 22 32 42 52 *> \endverbatim * * ===================================================================== SUBROUTINE DTFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO INTEGER INFO, N, LDA * .. * .. Array Arguments .. DOUBLE PRECISION A( 0: LDA-1, 0: * ), ARF( 0: * ) * .. * * ===================================================================== * * .. * .. Local Scalars .. LOGICAL LOWER, NISODD, NORMALTRANSR INTEGER N1, N2, K, NT, NX2, NP1X2 INTEGER I, J, L, IJ * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MOD * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 NORMALTRANSR = LSAME( TRANSR, 'N' ) LOWER = LSAME( UPLO, 'L' ) IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN INFO = -1 ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTFTTR', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.1 ) THEN IF( N.EQ.1 ) THEN A( 0, 0 ) = ARF( 0 ) END IF RETURN END IF * * Size of array ARF(0:nt-1) * NT = N*( N+1 ) / 2 * * set N1 and N2 depending on LOWER: for N even N1=N2=K * IF( LOWER ) THEN N2 = N / 2 N1 = N - N2 ELSE N1 = N / 2 N2 = N - N1 END IF * * If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2. * If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is * N--by--(N+1)/2. * IF( MOD( N, 2 ).EQ.0 ) THEN K = N / 2 NISODD = .FALSE. IF( .NOT.LOWER ) $ NP1X2 = N + N + 2 ELSE NISODD = .TRUE. IF( .NOT.LOWER ) $ NX2 = N + N END IF * IF( NISODD ) THEN * * N is odd * IF( NORMALTRANSR ) THEN * * N is odd and TRANSR = 'N' * IF( LOWER ) THEN * * N is odd, TRANSR = 'N', and UPLO = 'L' * IJ = 0 DO J = 0, N2 DO I = N1, N2 + J A( N2+J, I ) = ARF( IJ ) IJ = IJ + 1 END DO DO I = J, N - 1 A( I, J ) = ARF( IJ ) IJ = IJ + 1 END DO END DO * ELSE * * N is odd, TRANSR = 'N', and UPLO = 'U' * IJ = NT - N DO J = N - 1, N1, -1 DO I = 0, J A( I, J ) = ARF( IJ ) IJ = IJ + 1 END DO DO L = J - N1, N1 - 1 A( J-N1, L ) = ARF( IJ ) IJ = IJ + 1 END DO IJ = IJ - NX2 END DO * END IF * ELSE * * N is odd and TRANSR = 'T' * IF( LOWER ) THEN * * N is odd, TRANSR = 'T', and UPLO = 'L' * IJ = 0 DO J = 0, N2 - 1 DO I = 0, J A( J, I ) = ARF( IJ ) IJ = IJ + 1 END DO DO I = N1 + J, N - 1 A( I, N1+J ) = ARF( IJ ) IJ = IJ + 1 END DO END DO DO J = N2, N - 1 DO I = 0, N1 - 1 A( J, I ) = ARF( IJ ) IJ = IJ + 1 END DO END DO * ELSE * * N is odd, TRANSR = 'T', and UPLO = 'U' * IJ = 0 DO J = 0, N1 DO I = N1, N - 1 A( J, I ) = ARF( IJ ) IJ = IJ + 1 END DO END DO DO J = 0, N1 - 1 DO I = 0, J A( I, J ) = ARF( IJ ) IJ = IJ + 1 END DO DO L = N2 + J, N - 1 A( N2+J, L ) = ARF( IJ ) IJ = IJ + 1 END DO END DO * END IF * END IF * ELSE * * N is even * IF( NORMALTRANSR ) THEN * * N is even and TRANSR = 'N' * IF( LOWER ) THEN * * N is even, TRANSR = 'N', and UPLO = 'L' * IJ = 0 DO J = 0, K - 1 DO I = K, K + J A( K+J, I ) = ARF( IJ ) IJ = IJ + 1 END DO DO I = J, N - 1 A( I, J ) = ARF( IJ ) IJ = IJ + 1 END DO END DO * ELSE * * N is even, TRANSR = 'N', and UPLO = 'U' * IJ = NT - N - 1 DO J = N - 1, K, -1 DO I = 0, J A( I, J ) = ARF( IJ ) IJ = IJ + 1 END DO DO L = J - K, K - 1 A( J-K, L ) = ARF( IJ ) IJ = IJ + 1 END DO IJ = IJ - NP1X2 END DO * END IF * ELSE * * N is even and TRANSR = 'T' * IF( LOWER ) THEN * * N is even, TRANSR = 'T', and UPLO = 'L' * IJ = 0 J = K DO I = K, N - 1 A( I, J ) = ARF( IJ ) IJ = IJ + 1 END DO DO J = 0, K - 2 DO I = 0, J A( J, I ) = ARF( IJ ) IJ = IJ + 1 END DO DO I = K + 1 + J, N - 1 A( I, K+1+J ) = ARF( IJ ) IJ = IJ + 1 END DO END DO DO J = K - 1, N - 1 DO I = 0, K - 1 A( J, I ) = ARF( IJ ) IJ = IJ + 1 END DO END DO * ELSE * * N is even, TRANSR = 'T', and UPLO = 'U' * IJ = 0 DO J = 0, K DO I = K, N - 1 A( J, I ) = ARF( IJ ) IJ = IJ + 1 END DO END DO DO J = 0, K - 2 DO I = 0, J A( I, J ) = ARF( IJ ) IJ = IJ + 1 END DO DO L = K + 1 + J, N - 1 A( K+1+J, L ) = ARF( IJ ) IJ = IJ + 1 END DO END DO * Note that here, on exit of the loop, J = K-1 DO I = 0, J A( I, J ) = ARF( IJ ) IJ = IJ + 1 END DO * END IF * END IF * END IF * RETURN * * End of DTFTTR * END *> \brief \b DTGEVC * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTGEVC + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, * LDVL, VR, LDVR, MM, M, WORK, INFO ) * * .. Scalar Arguments .. * CHARACTER HOWMNY, SIDE * INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N * .. * .. Array Arguments .. * LOGICAL SELECT( * ) * DOUBLE PRECISION P( LDP, * ), S( LDS, * ), VL( LDVL, * ), * $ VR( LDVR, * ), WORK( * ) * .. * * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTGEVC computes some or all of the right and/or left eigenvectors of *> a pair of real matrices (S,P), where S is a quasi-triangular matrix *> and P is upper triangular. Matrix pairs of this type are produced by *> the generalized Schur factorization of a matrix pair (A,B): *> *> A = Q*S*Z**T, B = Q*P*Z**T *> *> as computed by DGGHRD + DHGEQZ. *> *> The right eigenvector x and the left eigenvector y of (S,P) *> corresponding to an eigenvalue w are defined by: *> *> S*x = w*P*x, (y**H)*S = w*(y**H)*P, *> *> where y**H denotes the conjugate tranpose of y. *> The eigenvalues are not input to this routine, but are computed *> directly from the diagonal blocks of S and P. *> *> This routine returns the matrices X and/or Y of right and left *> eigenvectors of (S,P), or the products Z*X and/or Q*Y, *> where Z and Q are input matrices. *> If Q and Z are the orthogonal factors from the generalized Schur *> factorization of a matrix pair (A,B), then Z*X and Q*Y *> are the matrices of right and left eigenvectors of (A,B). *> *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'R': compute right eigenvectors only; *> = 'L': compute left eigenvectors only; *> = 'B': compute both right and left eigenvectors. *> \endverbatim *> *> \param[in] HOWMNY *> \verbatim *> HOWMNY is CHARACTER*1 *> = 'A': compute all right and/or left eigenvectors; *> = 'B': compute all right and/or left eigenvectors, *> backtransformed by the matrices in VR and/or VL; *> = 'S': compute selected right and/or left eigenvectors, *> specified by the logical array SELECT. *> \endverbatim *> *> \param[in] SELECT *> \verbatim *> SELECT is LOGICAL array, dimension (N) *> If HOWMNY='S', SELECT specifies the eigenvectors to be *> computed. If w(j) is a real eigenvalue, the corresponding *> real eigenvector is computed if SELECT(j) is .TRUE.. *> If w(j) and w(j+1) are the real and imaginary parts of a *> complex eigenvalue, the corresponding complex eigenvector *> is computed if either SELECT(j) or SELECT(j+1) is .TRUE., *> and on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is *> set to .FALSE.. *> Not referenced if HOWMNY = 'A' or 'B'. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices S and P. N >= 0. *> \endverbatim *> *> \param[in] S *> \verbatim *> S is DOUBLE PRECISION array, dimension (LDS,N) *> The upper quasi-triangular matrix S from a generalized Schur *> factorization, as computed by DHGEQZ. *> \endverbatim *> *> \param[in] LDS *> \verbatim *> LDS is INTEGER *> The leading dimension of array S. LDS >= max(1,N). *> \endverbatim *> *> \param[in] P *> \verbatim *> P is DOUBLE PRECISION array, dimension (LDP,N) *> The upper triangular matrix P from a generalized Schur *> factorization, as computed by DHGEQZ. *> 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks *> of S must be in positive diagonal form. *> \endverbatim *> *> \param[in] LDP *> \verbatim *> LDP is INTEGER *> The leading dimension of array P. LDP >= max(1,N). *> \endverbatim *> *> \param[in,out] VL *> \verbatim *> VL is DOUBLE PRECISION array, dimension (LDVL,MM) *> On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must *> contain an N-by-N matrix Q (usually the orthogonal matrix Q *> of left Schur vectors returned by DHGEQZ). *> On exit, if SIDE = 'L' or 'B', VL contains: *> if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P); *> if HOWMNY = 'B', the matrix Q*Y; *> if HOWMNY = 'S', the left eigenvectors of (S,P) specified by *> SELECT, stored consecutively in the columns of *> VL, in the same order as their eigenvalues. *> *> A complex eigenvector corresponding to a complex eigenvalue *> is stored in two consecutive columns, the first holding the *> real part, and the second the imaginary part. *> *> Not referenced if SIDE = 'R'. *> \endverbatim *> *> \param[in] LDVL *> \verbatim *> LDVL is INTEGER *> The leading dimension of array VL. LDVL >= 1, and if *> SIDE = 'L' or 'B', LDVL >= N. *> \endverbatim *> *> \param[in,out] VR *> \verbatim *> VR is DOUBLE PRECISION array, dimension (LDVR,MM) *> On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must *> contain an N-by-N matrix Z (usually the orthogonal matrix Z *> of right Schur vectors returned by DHGEQZ). *> *> On exit, if SIDE = 'R' or 'B', VR contains: *> if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P); *> if HOWMNY = 'B' or 'b', the matrix Z*X; *> if HOWMNY = 'S' or 's', the right eigenvectors of (S,P) *> specified by SELECT, stored consecutively in the *> columns of VR, in the same order as their *> eigenvalues. *> *> A complex eigenvector corresponding to a complex eigenvalue *> is stored in two consecutive columns, the first holding the *> real part and the second the imaginary part. *> *> Not referenced if SIDE = 'L'. *> \endverbatim *> *> \param[in] LDVR *> \verbatim *> LDVR is INTEGER *> The leading dimension of the array VR. LDVR >= 1, and if *> SIDE = 'R' or 'B', LDVR >= N. *> \endverbatim *> *> \param[in] MM *> \verbatim *> MM is INTEGER *> The number of columns in the arrays VL and/or VR. MM >= M. *> \endverbatim *> *> \param[out] M *> \verbatim *> M is INTEGER *> The number of columns in the arrays VL and/or VR actually *> used to store the eigenvectors. If HOWMNY = 'A' or 'B', M *> is set to N. Each selected real eigenvector occupies one *> column and each selected complex eigenvector occupies two *> columns. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (6*N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: the 2-by-2 block (INFO:INFO+1) does not have a complex *> eigenvalue. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> Allocation of workspace: *> ---------- -- --------- *> *> WORK( j ) = 1-norm of j-th column of A, above the diagonal *> WORK( N+j ) = 1-norm of j-th column of B, above the diagonal *> WORK( 2*N+1:3*N ) = real part of eigenvector *> WORK( 3*N+1:4*N ) = imaginary part of eigenvector *> WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector *> WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector *> *> Rowwise vs. columnwise solution methods: *> ------- -- ---------- -------- ------- *> *> Finding a generalized eigenvector consists basically of solving the *> singular triangular system *> *> (A - w B) x = 0 (for right) or: (A - w B)**H y = 0 (for left) *> *> Consider finding the i-th right eigenvector (assume all eigenvalues *> are real). The equation to be solved is: *> n i *> 0 = sum C(j,k) v(k) = sum C(j,k) v(k) for j = i,. . .,1 *> k=j k=j *> *> where C = (A - w B) (The components v(i+1:n) are 0.) *> *> The "rowwise" method is: *> *> (1) v(i) := 1 *> for j = i-1,. . .,1: *> i *> (2) compute s = - sum C(j,k) v(k) and *> k=j+1 *> *> (3) v(j) := s / C(j,j) *> *> Step 2 is sometimes called the "dot product" step, since it is an *> inner product between the j-th row and the portion of the eigenvector *> that has been computed so far. *> *> The "columnwise" method consists basically in doing the sums *> for all the rows in parallel. As each v(j) is computed, the *> contribution of v(j) times the j-th column of C is added to the *> partial sums. Since FORTRAN arrays are stored columnwise, this has *> the advantage that at each step, the elements of C that are accessed *> are adjacent to one another, whereas with the rowwise method, the *> elements accessed at a step are spaced LDS (and LDP) words apart. *> *> When finding left eigenvectors, the matrix in question is the *> transpose of the one in storage, so the rowwise method then *> actually accesses columns of A and B at each step, and so is the *> preferred method. *> \endverbatim *> * ===================================================================== SUBROUTINE DTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, $ LDVL, VR, LDVR, MM, M, WORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N * .. * .. Array Arguments .. LOGICAL SELECT( * ) DOUBLE PRECISION P( LDP, * ), S( LDS, * ), VL( LDVL, * ), $ VR( LDVR, * ), WORK( * ) * .. * * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, SAFETY PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, $ SAFETY = 1.0D+2 ) * .. * .. Local Scalars .. LOGICAL COMPL, COMPR, IL2BY2, ILABAD, ILALL, ILBACK, $ ILBBAD, ILCOMP, ILCPLX, LSA, LSB INTEGER I, IBEG, IEIG, IEND, IHWMNY, IINFO, IM, ISIDE, $ J, JA, JC, JE, JR, JW, NA, NW DOUBLE PRECISION ACOEF, ACOEFA, ANORM, ASCALE, BCOEFA, BCOEFI, $ BCOEFR, BIG, BIGNUM, BNORM, BSCALE, CIM2A, $ CIM2B, CIMAGA, CIMAGB, CRE2A, CRE2B, CREALA, $ CREALB, DMIN, SAFMIN, SALFAR, SBETA, SCALE, $ SMALL, TEMP, TEMP2, TEMP2I, TEMP2R, ULP, XMAX, $ XSCALE * .. * .. Local Arrays .. DOUBLE PRECISION BDIAG( 2 ), SUM( 2, 2 ), SUMS( 2, 2 ), $ SUMP( 2, 2 ) * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL LSAME, DLAMCH * .. * .. External Subroutines .. EXTERNAL DGEMV, DLABAD, DLACPY, DLAG2, DLALN2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. Executable Statements .. * * Decode and Test the input parameters * IF( LSAME( HOWMNY, 'A' ) ) THEN IHWMNY = 1 ILALL = .TRUE. ILBACK = .FALSE. ELSE IF( LSAME( HOWMNY, 'S' ) ) THEN IHWMNY = 2 ILALL = .FALSE. ILBACK = .FALSE. ELSE IF( LSAME( HOWMNY, 'B' ) ) THEN IHWMNY = 3 ILALL = .TRUE. ILBACK = .TRUE. ELSE IHWMNY = -1 ILALL = .TRUE. END IF * IF( LSAME( SIDE, 'R' ) ) THEN ISIDE = 1 COMPL = .FALSE. COMPR = .TRUE. ELSE IF( LSAME( SIDE, 'L' ) ) THEN ISIDE = 2 COMPL = .TRUE. COMPR = .FALSE. ELSE IF( LSAME( SIDE, 'B' ) ) THEN ISIDE = 3 COMPL = .TRUE. COMPR = .TRUE. ELSE ISIDE = -1 END IF * INFO = 0 IF( ISIDE.LT.0 ) THEN INFO = -1 ELSE IF( IHWMNY.LT.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDS.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDP.LT.MAX( 1, N ) ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTGEVC', -INFO ) RETURN END IF * * Count the number of eigenvectors to be computed * IF( .NOT.ILALL ) THEN IM = 0 ILCPLX = .FALSE. DO 10 J = 1, N IF( ILCPLX ) THEN ILCPLX = .FALSE. GO TO 10 END IF IF( J.LT.N ) THEN IF( S( J+1, J ).NE.ZERO ) $ ILCPLX = .TRUE. END IF IF( ILCPLX ) THEN IF( SELECT( J ) .OR. SELECT( J+1 ) ) $ IM = IM + 2 ELSE IF( SELECT( J ) ) $ IM = IM + 1 END IF 10 CONTINUE ELSE IM = N END IF * * Check 2-by-2 diagonal blocks of A, B * ILABAD = .FALSE. ILBBAD = .FALSE. DO 20 J = 1, N - 1 IF( S( J+1, J ).NE.ZERO ) THEN IF( P( J, J ).EQ.ZERO .OR. P( J+1, J+1 ).EQ.ZERO .OR. $ P( J, J+1 ).NE.ZERO )ILBBAD = .TRUE. IF( J.LT.N-1 ) THEN IF( S( J+2, J+1 ).NE.ZERO ) $ ILABAD = .TRUE. END IF END IF 20 CONTINUE * IF( ILABAD ) THEN INFO = -5 ELSE IF( ILBBAD ) THEN INFO = -7 ELSE IF( COMPL .AND. LDVL.LT.N .OR. LDVL.LT.1 ) THEN INFO = -10 ELSE IF( COMPR .AND. LDVR.LT.N .OR. LDVR.LT.1 ) THEN INFO = -12 ELSE IF( MM.LT.IM ) THEN INFO = -13 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTGEVC', -INFO ) RETURN END IF * * Quick return if possible * M = IM IF( N.EQ.0 ) $ RETURN * * Machine Constants * SAFMIN = DLAMCH( 'Safe minimum' ) BIG = ONE / SAFMIN CALL DLABAD( SAFMIN, BIG ) ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) SMALL = SAFMIN*N / ULP BIG = ONE / SMALL BIGNUM = ONE / ( SAFMIN*N ) * * Compute the 1-norm of each column of the strictly upper triangular * part (i.e., excluding all elements belonging to the diagonal * blocks) of A and B to check for possible overflow in the * triangular solver. * ANORM = ABS( S( 1, 1 ) ) IF( N.GT.1 ) $ ANORM = ANORM + ABS( S( 2, 1 ) ) BNORM = ABS( P( 1, 1 ) ) WORK( 1 ) = ZERO WORK( N+1 ) = ZERO * DO 50 J = 2, N TEMP = ZERO TEMP2 = ZERO IF( S( J, J-1 ).EQ.ZERO ) THEN IEND = J - 1 ELSE IEND = J - 2 END IF DO 30 I = 1, IEND TEMP = TEMP + ABS( S( I, J ) ) TEMP2 = TEMP2 + ABS( P( I, J ) ) 30 CONTINUE WORK( J ) = TEMP WORK( N+J ) = TEMP2 DO 40 I = IEND + 1, MIN( J+1, N ) TEMP = TEMP + ABS( S( I, J ) ) TEMP2 = TEMP2 + ABS( P( I, J ) ) 40 CONTINUE ANORM = MAX( ANORM, TEMP ) BNORM = MAX( BNORM, TEMP2 ) 50 CONTINUE * ASCALE = ONE / MAX( ANORM, SAFMIN ) BSCALE = ONE / MAX( BNORM, SAFMIN ) * * Left eigenvectors * IF( COMPL ) THEN IEIG = 0 * * Main loop over eigenvalues * ILCPLX = .FALSE. DO 220 JE = 1, N * * Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or * (b) this would be the second of a complex pair. * Check for complex eigenvalue, so as to be sure of which * entry(-ies) of SELECT to look at. * IF( ILCPLX ) THEN ILCPLX = .FALSE. GO TO 220 END IF NW = 1 IF( JE.LT.N ) THEN IF( S( JE+1, JE ).NE.ZERO ) THEN ILCPLX = .TRUE. NW = 2 END IF END IF IF( ILALL ) THEN ILCOMP = .TRUE. ELSE IF( ILCPLX ) THEN ILCOMP = SELECT( JE ) .OR. SELECT( JE+1 ) ELSE ILCOMP = SELECT( JE ) END IF IF( .NOT.ILCOMP ) $ GO TO 220 * * Decide if (a) singular pencil, (b) real eigenvalue, or * (c) complex eigenvalue. * IF( .NOT.ILCPLX ) THEN IF( ABS( S( JE, JE ) ).LE.SAFMIN .AND. $ ABS( P( JE, JE ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- return unit eigenvector * IEIG = IEIG + 1 DO 60 JR = 1, N VL( JR, IEIG ) = ZERO 60 CONTINUE VL( IEIG, IEIG ) = ONE GO TO 220 END IF END IF * * Clear vector * DO 70 JR = 1, NW*N WORK( 2*N+JR ) = ZERO 70 CONTINUE * T * Compute coefficients in ( a A - b B ) y = 0 * a is ACOEF * b is BCOEFR + i*BCOEFI * IF( .NOT.ILCPLX ) THEN * * Real eigenvalue * TEMP = ONE / MAX( ABS( S( JE, JE ) )*ASCALE, $ ABS( P( JE, JE ) )*BSCALE, SAFMIN ) SALFAR = ( TEMP*S( JE, JE ) )*ASCALE SBETA = ( TEMP*P( JE, JE ) )*BSCALE ACOEF = SBETA*ASCALE BCOEFR = SALFAR*BSCALE BCOEFI = ZERO * * Scale to avoid underflow * SCALE = ONE LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEF ).LT.SMALL LSB = ABS( SALFAR ).GE.SAFMIN .AND. ABS( BCOEFR ).LT. $ SMALL IF( LSA ) $ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG ) IF( LSB ) $ SCALE = MAX( SCALE, ( SMALL / ABS( SALFAR ) )* $ MIN( BNORM, BIG ) ) IF( LSA .OR. LSB ) THEN SCALE = MIN( SCALE, ONE / $ ( SAFMIN*MAX( ONE, ABS( ACOEF ), $ ABS( BCOEFR ) ) ) ) IF( LSA ) THEN ACOEF = ASCALE*( SCALE*SBETA ) ELSE ACOEF = SCALE*ACOEF END IF IF( LSB ) THEN BCOEFR = BSCALE*( SCALE*SALFAR ) ELSE BCOEFR = SCALE*BCOEFR END IF END IF ACOEFA = ABS( ACOEF ) BCOEFA = ABS( BCOEFR ) * * First component is 1 * WORK( 2*N+JE ) = ONE XMAX = ONE ELSE * * Complex eigenvalue * CALL DLAG2( S( JE, JE ), LDS, P( JE, JE ), LDP, $ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2, $ BCOEFI ) BCOEFI = -BCOEFI IF( BCOEFI.EQ.ZERO ) THEN INFO = JE RETURN END IF * * Scale to avoid over/underflow * ACOEFA = ABS( ACOEF ) BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI ) SCALE = ONE IF( ACOEFA*ULP.LT.SAFMIN .AND. ACOEFA.GE.SAFMIN ) $ SCALE = ( SAFMIN / ULP ) / ACOEFA IF( BCOEFA*ULP.LT.SAFMIN .AND. BCOEFA.GE.SAFMIN ) $ SCALE = MAX( SCALE, ( SAFMIN / ULP ) / BCOEFA ) IF( SAFMIN*ACOEFA.GT.ASCALE ) $ SCALE = ASCALE / ( SAFMIN*ACOEFA ) IF( SAFMIN*BCOEFA.GT.BSCALE ) $ SCALE = MIN( SCALE, BSCALE / ( SAFMIN*BCOEFA ) ) IF( SCALE.NE.ONE ) THEN ACOEF = SCALE*ACOEF ACOEFA = ABS( ACOEF ) BCOEFR = SCALE*BCOEFR BCOEFI = SCALE*BCOEFI BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI ) END IF * * Compute first two components of eigenvector * TEMP = ACOEF*S( JE+1, JE ) TEMP2R = ACOEF*S( JE, JE ) - BCOEFR*P( JE, JE ) TEMP2I = -BCOEFI*P( JE, JE ) IF( ABS( TEMP ).GT.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN WORK( 2*N+JE ) = ONE WORK( 3*N+JE ) = ZERO WORK( 2*N+JE+1 ) = -TEMP2R / TEMP WORK( 3*N+JE+1 ) = -TEMP2I / TEMP ELSE WORK( 2*N+JE+1 ) = ONE WORK( 3*N+JE+1 ) = ZERO TEMP = ACOEF*S( JE, JE+1 ) WORK( 2*N+JE ) = ( BCOEFR*P( JE+1, JE+1 )-ACOEF* $ S( JE+1, JE+1 ) ) / TEMP WORK( 3*N+JE ) = BCOEFI*P( JE+1, JE+1 ) / TEMP END IF XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ), $ ABS( WORK( 2*N+JE+1 ) )+ABS( WORK( 3*N+JE+1 ) ) ) END IF * DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN ) * * T * Triangular solve of (a A - b B) y = 0 * * T * (rowwise in (a A - b B) , or columnwise in (a A - b B) ) * IL2BY2 = .FALSE. * DO 160 J = JE + NW, N IF( IL2BY2 ) THEN IL2BY2 = .FALSE. GO TO 160 END IF * NA = 1 BDIAG( 1 ) = P( J, J ) IF( J.LT.N ) THEN IF( S( J+1, J ).NE.ZERO ) THEN IL2BY2 = .TRUE. BDIAG( 2 ) = P( J+1, J+1 ) NA = 2 END IF END IF * * Check whether scaling is necessary for dot products * XSCALE = ONE / MAX( ONE, XMAX ) TEMP = MAX( WORK( J ), WORK( N+J ), $ ACOEFA*WORK( J )+BCOEFA*WORK( N+J ) ) IF( IL2BY2 ) $ TEMP = MAX( TEMP, WORK( J+1 ), WORK( N+J+1 ), $ ACOEFA*WORK( J+1 )+BCOEFA*WORK( N+J+1 ) ) IF( TEMP.GT.BIGNUM*XSCALE ) THEN DO 90 JW = 0, NW - 1 DO 80 JR = JE, J - 1 WORK( ( JW+2 )*N+JR ) = XSCALE* $ WORK( ( JW+2 )*N+JR ) 80 CONTINUE 90 CONTINUE XMAX = XMAX*XSCALE END IF * * Compute dot products * * j-1 * SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k) * k=je * * To reduce the op count, this is done as * * _ j-1 _ j-1 * a*conjg( sum S(k,j)*x(k) ) - b*conjg( sum P(k,j)*x(k) ) * k=je k=je * * which may cause underflow problems if A or B are close * to underflow. (E.g., less than SMALL.) * * DO 120 JW = 1, NW DO 110 JA = 1, NA SUMS( JA, JW ) = ZERO SUMP( JA, JW ) = ZERO * DO 100 JR = JE, J - 1 SUMS( JA, JW ) = SUMS( JA, JW ) + $ S( JR, J+JA-1 )* $ WORK( ( JW+1 )*N+JR ) SUMP( JA, JW ) = SUMP( JA, JW ) + $ P( JR, J+JA-1 )* $ WORK( ( JW+1 )*N+JR ) 100 CONTINUE 110 CONTINUE 120 CONTINUE * DO 130 JA = 1, NA IF( ILCPLX ) THEN SUM( JA, 1 ) = -ACOEF*SUMS( JA, 1 ) + $ BCOEFR*SUMP( JA, 1 ) - $ BCOEFI*SUMP( JA, 2 ) SUM( JA, 2 ) = -ACOEF*SUMS( JA, 2 ) + $ BCOEFR*SUMP( JA, 2 ) + $ BCOEFI*SUMP( JA, 1 ) ELSE SUM( JA, 1 ) = -ACOEF*SUMS( JA, 1 ) + $ BCOEFR*SUMP( JA, 1 ) END IF 130 CONTINUE * * T * Solve ( a A - b B ) y = SUM(,) * with scaling and perturbation of the denominator * CALL DLALN2( .TRUE., NA, NW, DMIN, ACOEF, S( J, J ), LDS, $ BDIAG( 1 ), BDIAG( 2 ), SUM, 2, BCOEFR, $ BCOEFI, WORK( 2*N+J ), N, SCALE, TEMP, $ IINFO ) IF( SCALE.LT.ONE ) THEN DO 150 JW = 0, NW - 1 DO 140 JR = JE, J - 1 WORK( ( JW+2 )*N+JR ) = SCALE* $ WORK( ( JW+2 )*N+JR ) 140 CONTINUE 150 CONTINUE XMAX = SCALE*XMAX END IF XMAX = MAX( XMAX, TEMP ) 160 CONTINUE * * Copy eigenvector to VL, back transforming if * HOWMNY='B'. * IEIG = IEIG + 1 IF( ILBACK ) THEN DO 170 JW = 0, NW - 1 CALL DGEMV( 'N', N, N+1-JE, ONE, VL( 1, JE ), LDVL, $ WORK( ( JW+2 )*N+JE ), 1, ZERO, $ WORK( ( JW+4 )*N+1 ), 1 ) 170 CONTINUE CALL DLACPY( ' ', N, NW, WORK( 4*N+1 ), N, VL( 1, JE ), $ LDVL ) IBEG = 1 ELSE CALL DLACPY( ' ', N, NW, WORK( 2*N+1 ), N, VL( 1, IEIG ), $ LDVL ) IBEG = JE END IF * * Scale eigenvector * XMAX = ZERO IF( ILCPLX ) THEN DO 180 J = IBEG, N XMAX = MAX( XMAX, ABS( VL( J, IEIG ) )+ $ ABS( VL( J, IEIG+1 ) ) ) 180 CONTINUE ELSE DO 190 J = IBEG, N XMAX = MAX( XMAX, ABS( VL( J, IEIG ) ) ) 190 CONTINUE END IF * IF( XMAX.GT.SAFMIN ) THEN XSCALE = ONE / XMAX * DO 210 JW = 0, NW - 1 DO 200 JR = IBEG, N VL( JR, IEIG+JW ) = XSCALE*VL( JR, IEIG+JW ) 200 CONTINUE 210 CONTINUE END IF IEIG = IEIG + NW - 1 * 220 CONTINUE END IF * * Right eigenvectors * IF( COMPR ) THEN IEIG = IM + 1 * * Main loop over eigenvalues * ILCPLX = .FALSE. DO 500 JE = N, 1, -1 * * Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or * (b) this would be the second of a complex pair. * Check for complex eigenvalue, so as to be sure of which * entry(-ies) of SELECT to look at -- if complex, SELECT(JE) * or SELECT(JE-1). * If this is a complex pair, the 2-by-2 diagonal block * corresponding to the eigenvalue is in rows/columns JE-1:JE * IF( ILCPLX ) THEN ILCPLX = .FALSE. GO TO 500 END IF NW = 1 IF( JE.GT.1 ) THEN IF( S( JE, JE-1 ).NE.ZERO ) THEN ILCPLX = .TRUE. NW = 2 END IF END IF IF( ILALL ) THEN ILCOMP = .TRUE. ELSE IF( ILCPLX ) THEN ILCOMP = SELECT( JE ) .OR. SELECT( JE-1 ) ELSE ILCOMP = SELECT( JE ) END IF IF( .NOT.ILCOMP ) $ GO TO 500 * * Decide if (a) singular pencil, (b) real eigenvalue, or * (c) complex eigenvalue. * IF( .NOT.ILCPLX ) THEN IF( ABS( S( JE, JE ) ).LE.SAFMIN .AND. $ ABS( P( JE, JE ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- unit eigenvector * IEIG = IEIG - 1 DO 230 JR = 1, N VR( JR, IEIG ) = ZERO 230 CONTINUE VR( IEIG, IEIG ) = ONE GO TO 500 END IF END IF * * Clear vector * DO 250 JW = 0, NW - 1 DO 240 JR = 1, N WORK( ( JW+2 )*N+JR ) = ZERO 240 CONTINUE 250 CONTINUE * * Compute coefficients in ( a A - b B ) x = 0 * a is ACOEF * b is BCOEFR + i*BCOEFI * IF( .NOT.ILCPLX ) THEN * * Real eigenvalue * TEMP = ONE / MAX( ABS( S( JE, JE ) )*ASCALE, $ ABS( P( JE, JE ) )*BSCALE, SAFMIN ) SALFAR = ( TEMP*S( JE, JE ) )*ASCALE SBETA = ( TEMP*P( JE, JE ) )*BSCALE ACOEF = SBETA*ASCALE BCOEFR = SALFAR*BSCALE BCOEFI = ZERO * * Scale to avoid underflow * SCALE = ONE LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEF ).LT.SMALL LSB = ABS( SALFAR ).GE.SAFMIN .AND. ABS( BCOEFR ).LT. $ SMALL IF( LSA ) $ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG ) IF( LSB ) $ SCALE = MAX( SCALE, ( SMALL / ABS( SALFAR ) )* $ MIN( BNORM, BIG ) ) IF( LSA .OR. LSB ) THEN SCALE = MIN( SCALE, ONE / $ ( SAFMIN*MAX( ONE, ABS( ACOEF ), $ ABS( BCOEFR ) ) ) ) IF( LSA ) THEN ACOEF = ASCALE*( SCALE*SBETA ) ELSE ACOEF = SCALE*ACOEF END IF IF( LSB ) THEN BCOEFR = BSCALE*( SCALE*SALFAR ) ELSE BCOEFR = SCALE*BCOEFR END IF END IF ACOEFA = ABS( ACOEF ) BCOEFA = ABS( BCOEFR ) * * First component is 1 * WORK( 2*N+JE ) = ONE XMAX = ONE * * Compute contribution from column JE of A and B to sum * (See "Further Details", above.) * DO 260 JR = 1, JE - 1 WORK( 2*N+JR ) = BCOEFR*P( JR, JE ) - $ ACOEF*S( JR, JE ) 260 CONTINUE ELSE * * Complex eigenvalue * CALL DLAG2( S( JE-1, JE-1 ), LDS, P( JE-1, JE-1 ), LDP, $ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2, $ BCOEFI ) IF( BCOEFI.EQ.ZERO ) THEN INFO = JE - 1 RETURN END IF * * Scale to avoid over/underflow * ACOEFA = ABS( ACOEF ) BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI ) SCALE = ONE IF( ACOEFA*ULP.LT.SAFMIN .AND. ACOEFA.GE.SAFMIN ) $ SCALE = ( SAFMIN / ULP ) / ACOEFA IF( BCOEFA*ULP.LT.SAFMIN .AND. BCOEFA.GE.SAFMIN ) $ SCALE = MAX( SCALE, ( SAFMIN / ULP ) / BCOEFA ) IF( SAFMIN*ACOEFA.GT.ASCALE ) $ SCALE = ASCALE / ( SAFMIN*ACOEFA ) IF( SAFMIN*BCOEFA.GT.BSCALE ) $ SCALE = MIN( SCALE, BSCALE / ( SAFMIN*BCOEFA ) ) IF( SCALE.NE.ONE ) THEN ACOEF = SCALE*ACOEF ACOEFA = ABS( ACOEF ) BCOEFR = SCALE*BCOEFR BCOEFI = SCALE*BCOEFI BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI ) END IF * * Compute first two components of eigenvector * and contribution to sums * TEMP = ACOEF*S( JE, JE-1 ) TEMP2R = ACOEF*S( JE, JE ) - BCOEFR*P( JE, JE ) TEMP2I = -BCOEFI*P( JE, JE ) IF( ABS( TEMP ).GE.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN WORK( 2*N+JE ) = ONE WORK( 3*N+JE ) = ZERO WORK( 2*N+JE-1 ) = -TEMP2R / TEMP WORK( 3*N+JE-1 ) = -TEMP2I / TEMP ELSE WORK( 2*N+JE-1 ) = ONE WORK( 3*N+JE-1 ) = ZERO TEMP = ACOEF*S( JE-1, JE ) WORK( 2*N+JE ) = ( BCOEFR*P( JE-1, JE-1 )-ACOEF* $ S( JE-1, JE-1 ) ) / TEMP WORK( 3*N+JE ) = BCOEFI*P( JE-1, JE-1 ) / TEMP END IF * XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ), $ ABS( WORK( 2*N+JE-1 ) )+ABS( WORK( 3*N+JE-1 ) ) ) * * Compute contribution from columns JE and JE-1 * of A and B to the sums. * CREALA = ACOEF*WORK( 2*N+JE-1 ) CIMAGA = ACOEF*WORK( 3*N+JE-1 ) CREALB = BCOEFR*WORK( 2*N+JE-1 ) - $ BCOEFI*WORK( 3*N+JE-1 ) CIMAGB = BCOEFI*WORK( 2*N+JE-1 ) + $ BCOEFR*WORK( 3*N+JE-1 ) CRE2A = ACOEF*WORK( 2*N+JE ) CIM2A = ACOEF*WORK( 3*N+JE ) CRE2B = BCOEFR*WORK( 2*N+JE ) - BCOEFI*WORK( 3*N+JE ) CIM2B = BCOEFI*WORK( 2*N+JE ) + BCOEFR*WORK( 3*N+JE ) DO 270 JR = 1, JE - 2 WORK( 2*N+JR ) = -CREALA*S( JR, JE-1 ) + $ CREALB*P( JR, JE-1 ) - $ CRE2A*S( JR, JE ) + CRE2B*P( JR, JE ) WORK( 3*N+JR ) = -CIMAGA*S( JR, JE-1 ) + $ CIMAGB*P( JR, JE-1 ) - $ CIM2A*S( JR, JE ) + CIM2B*P( JR, JE ) 270 CONTINUE END IF * DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN ) * * Columnwise triangular solve of (a A - b B) x = 0 * IL2BY2 = .FALSE. DO 370 J = JE - NW, 1, -1 * * If a 2-by-2 block, is in position j-1:j, wait until * next iteration to process it (when it will be j:j+1) * IF( .NOT.IL2BY2 .AND. J.GT.1 ) THEN IF( S( J, J-1 ).NE.ZERO ) THEN IL2BY2 = .TRUE. GO TO 370 END IF END IF BDIAG( 1 ) = P( J, J ) IF( IL2BY2 ) THEN NA = 2 BDIAG( 2 ) = P( J+1, J+1 ) ELSE NA = 1 END IF * * Compute x(j) (and x(j+1), if 2-by-2 block) * CALL DLALN2( .FALSE., NA, NW, DMIN, ACOEF, S( J, J ), $ LDS, BDIAG( 1 ), BDIAG( 2 ), WORK( 2*N+J ), $ N, BCOEFR, BCOEFI, SUM, 2, SCALE, TEMP, $ IINFO ) IF( SCALE.LT.ONE ) THEN * DO 290 JW = 0, NW - 1 DO 280 JR = 1, JE WORK( ( JW+2 )*N+JR ) = SCALE* $ WORK( ( JW+2 )*N+JR ) 280 CONTINUE 290 CONTINUE END IF XMAX = MAX( SCALE*XMAX, TEMP ) * DO 310 JW = 1, NW DO 300 JA = 1, NA WORK( ( JW+1 )*N+J+JA-1 ) = SUM( JA, JW ) 300 CONTINUE 310 CONTINUE * * w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling * IF( J.GT.1 ) THEN * * Check whether scaling is necessary for sum. * XSCALE = ONE / MAX( ONE, XMAX ) TEMP = ACOEFA*WORK( J ) + BCOEFA*WORK( N+J ) IF( IL2BY2 ) $ TEMP = MAX( TEMP, ACOEFA*WORK( J+1 )+BCOEFA* $ WORK( N+J+1 ) ) TEMP = MAX( TEMP, ACOEFA, BCOEFA ) IF( TEMP.GT.BIGNUM*XSCALE ) THEN * DO 330 JW = 0, NW - 1 DO 320 JR = 1, JE WORK( ( JW+2 )*N+JR ) = XSCALE* $ WORK( ( JW+2 )*N+JR ) 320 CONTINUE 330 CONTINUE XMAX = XMAX*XSCALE END IF * * Compute the contributions of the off-diagonals of * column j (and j+1, if 2-by-2 block) of A and B to the * sums. * * DO 360 JA = 1, NA IF( ILCPLX ) THEN CREALA = ACOEF*WORK( 2*N+J+JA-1 ) CIMAGA = ACOEF*WORK( 3*N+J+JA-1 ) CREALB = BCOEFR*WORK( 2*N+J+JA-1 ) - $ BCOEFI*WORK( 3*N+J+JA-1 ) CIMAGB = BCOEFI*WORK( 2*N+J+JA-1 ) + $ BCOEFR*WORK( 3*N+J+JA-1 ) DO 340 JR = 1, J - 1 WORK( 2*N+JR ) = WORK( 2*N+JR ) - $ CREALA*S( JR, J+JA-1 ) + $ CREALB*P( JR, J+JA-1 ) WORK( 3*N+JR ) = WORK( 3*N+JR ) - $ CIMAGA*S( JR, J+JA-1 ) + $ CIMAGB*P( JR, J+JA-1 ) 340 CONTINUE ELSE CREALA = ACOEF*WORK( 2*N+J+JA-1 ) CREALB = BCOEFR*WORK( 2*N+J+JA-1 ) DO 350 JR = 1, J - 1 WORK( 2*N+JR ) = WORK( 2*N+JR ) - $ CREALA*S( JR, J+JA-1 ) + $ CREALB*P( JR, J+JA-1 ) 350 CONTINUE END IF 360 CONTINUE END IF * IL2BY2 = .FALSE. 370 CONTINUE * * Copy eigenvector to VR, back transforming if * HOWMNY='B'. * IEIG = IEIG - NW IF( ILBACK ) THEN * DO 410 JW = 0, NW - 1 DO 380 JR = 1, N WORK( ( JW+4 )*N+JR ) = WORK( ( JW+2 )*N+1 )* $ VR( JR, 1 ) 380 CONTINUE * * A series of compiler directives to defeat * vectorization for the next loop * * DO 400 JC = 2, JE DO 390 JR = 1, N WORK( ( JW+4 )*N+JR ) = WORK( ( JW+4 )*N+JR ) + $ WORK( ( JW+2 )*N+JC )*VR( JR, JC ) 390 CONTINUE 400 CONTINUE 410 CONTINUE * DO 430 JW = 0, NW - 1 DO 420 JR = 1, N VR( JR, IEIG+JW ) = WORK( ( JW+4 )*N+JR ) 420 CONTINUE 430 CONTINUE * IEND = N ELSE DO 450 JW = 0, NW - 1 DO 440 JR = 1, N VR( JR, IEIG+JW ) = WORK( ( JW+2 )*N+JR ) 440 CONTINUE 450 CONTINUE * IEND = JE END IF * * Scale eigenvector * XMAX = ZERO IF( ILCPLX ) THEN DO 460 J = 1, IEND XMAX = MAX( XMAX, ABS( VR( J, IEIG ) )+ $ ABS( VR( J, IEIG+1 ) ) ) 460 CONTINUE ELSE DO 470 J = 1, IEND XMAX = MAX( XMAX, ABS( VR( J, IEIG ) ) ) 470 CONTINUE END IF * IF( XMAX.GT.SAFMIN ) THEN XSCALE = ONE / XMAX DO 490 JW = 0, NW - 1 DO 480 JR = 1, IEND VR( JR, IEIG+JW ) = XSCALE*VR( JR, IEIG+JW ) 480 CONTINUE 490 CONTINUE END IF 500 CONTINUE END IF * RETURN * * End of DTGEVC * END *> \brief \b DTGEX2 swaps adjacent diagonal blocks in an upper (quasi) triangular matrix pair by an orthogonal equivalence transformation. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTGEX2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, * LDZ, J1, N1, N2, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * LOGICAL WANTQ, WANTZ * INTEGER INFO, J1, LDA, LDB, LDQ, LDZ, LWORK, N, N1, N2 * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22) *> of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair *> (A, B) by an orthogonal equivalence transformation. *> *> (A, B) must be in generalized real Schur canonical form (as returned *> by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2 *> diagonal blocks. B is upper triangular. *> *> Optionally, the matrices Q and Z of generalized Schur vectors are *> updated. *> *> Q(in) * A(in) * Z(in)**T = Q(out) * A(out) * Z(out)**T *> Q(in) * B(in) * Z(in)**T = Q(out) * B(out) * Z(out)**T *> *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTQ *> \verbatim *> WANTQ is LOGICAL *> .TRUE. : update the left transformation matrix Q; *> .FALSE.: do not update Q. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> .TRUE. : update the right transformation matrix Z; *> .FALSE.: do not update Z. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A and B. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimensions (LDA,N) *> On entry, the matrix A in the pair (A, B). *> On exit, the updated matrix A. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimensions (LDB,N) *> On entry, the matrix B in the pair (A, B). *> On exit, the updated matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is DOUBLE PRECISION array, dimension (LDQ,N) *> On entry, if WANTQ = .TRUE., the orthogonal matrix Q. *> On exit, the updated matrix Q. *> Not referenced if WANTQ = .FALSE.. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= 1. *> If WANTQ = .TRUE., LDQ >= N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ,N) *> On entry, if WANTZ =.TRUE., the orthogonal matrix Z. *> On exit, the updated matrix Z. *> Not referenced if WANTZ = .FALSE.. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1. *> If WANTZ = .TRUE., LDZ >= N. *> \endverbatim *> *> \param[in] J1 *> \verbatim *> J1 is INTEGER *> The index to the first block (A11, B11). 1 <= J1 <= N. *> \endverbatim *> *> \param[in] N1 *> \verbatim *> N1 is INTEGER *> The order of the first block (A11, B11). N1 = 0, 1 or 2. *> \endverbatim *> *> \param[in] N2 *> \verbatim *> N2 is INTEGER *> The order of the second block (A22, B22). N2 = 0, 1 or 2. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)). *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. *> LWORK >= MAX( 1, N*(N2+N1), (N2+N1)*(N2+N1)*2 ) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> =0: Successful exit *> >0: If INFO = 1, the transformed matrix (A, B) would be *> too far from generalized Schur form; the blocks are *> not swapped and (A, B) and (Q, Z) are unchanged. *> The problem of swapping is too ill-conditioned. *> <0: If INFO = -16: LWORK is too small. Appropriate value *> for LWORK is returned in WORK(1). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEauxiliary * *> \par Further Details: * ===================== *> *> In the current code both weak and strong stability tests are *> performed. The user can omit the strong stability test by changing *> the internal logical parameter WANDS to .FALSE.. See ref. [2] for *> details. * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * *> \par References: * ================ *> *> \verbatim *> *> [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the *> Generalized Real Schur Form of a Regular Matrix Pair (A, B), in *> M.S. Moonen et al (eds), Linear Algebra for Large Scale and *> Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. *> *> [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified *> Eigenvalues of a Regular Matrix Pair (A, B) and Condition *> Estimation: Theory, Algorithms and Software, *> Report UMINF - 94.04, Department of Computing Science, Umea *> University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working *> Note 87. To appear in Numerical Algorithms, 1996. *> \endverbatim *> * ===================================================================== SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, J1, N1, N2, WORK, LWORK, INFO ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. LOGICAL WANTQ, WANTZ INTEGER INFO, J1, LDA, LDB, LDQ, LDZ, LWORK, N, N1, N2 * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), $ WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * Replaced various illegal calls to DCOPY by calls to DLASET, or by DO * loops. Sven Hammarling, 1/5/02. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION TWENTY PARAMETER ( TWENTY = 2.0D+01 ) INTEGER LDST PARAMETER ( LDST = 4 ) LOGICAL WANDS PARAMETER ( WANDS = .TRUE. ) * .. * .. Local Scalars .. LOGICAL DTRONG, WEAK INTEGER I, IDUM, LINFO, M DOUBLE PRECISION BQRA21, BRQA21, DDUM, DNORM, DSCALE, DSUM, EPS, $ F, G, SA, SB, SCALE, SMLNUM, SS, THRESH, WS * .. * .. Local Arrays .. INTEGER IWORK( LDST ) DOUBLE PRECISION AI( 2 ), AR( 2 ), BE( 2 ), IR( LDST, LDST ), $ IRCOP( LDST, LDST ), LI( LDST, LDST ), $ LICOP( LDST, LDST ), S( LDST, LDST ), $ SCPY( LDST, LDST ), T( LDST, LDST ), $ TAUL( LDST ), TAUR( LDST ), TCPY( LDST, LDST ) * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. External Subroutines .. EXTERNAL DGEMM, DGEQR2, DGERQ2, DLACPY, DLAGV2, DLARTG, $ DLASET, DLASSQ, DORG2R, DORGR2, DORM2R, DORMR2, $ DROT, DSCAL, DTGSY2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.LE.1 .OR. N1.LE.0 .OR. N2.LE.0 ) $ RETURN IF( N1.GT.N .OR. ( J1+N1 ).GT.N ) $ RETURN M = N1 + N2 IF( LWORK.LT.MAX( 1, N*M, M*M*2 ) ) THEN INFO = -16 WORK( 1 ) = MAX( 1, N*M, M*M*2 ) RETURN END IF * WEAK = .FALSE. DTRONG = .FALSE. * * Make a local copy of selected block * CALL DLASET( 'Full', LDST, LDST, ZERO, ZERO, LI, LDST ) CALL DLASET( 'Full', LDST, LDST, ZERO, ZERO, IR, LDST ) CALL DLACPY( 'Full', M, M, A( J1, J1 ), LDA, S, LDST ) CALL DLACPY( 'Full', M, M, B( J1, J1 ), LDB, T, LDST ) * * Compute threshold for testing acceptance of swapping. * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) / EPS DSCALE = ZERO DSUM = ONE CALL DLACPY( 'Full', M, M, S, LDST, WORK, M ) CALL DLASSQ( M*M, WORK, 1, DSCALE, DSUM ) CALL DLACPY( 'Full', M, M, T, LDST, WORK, M ) CALL DLASSQ( M*M, WORK, 1, DSCALE, DSUM ) DNORM = DSCALE*SQRT( DSUM ) * * THRES has been changed from * THRESH = MAX( TEN*EPS*SA, SMLNUM ) * to * THRESH = MAX( TWENTY*EPS*SA, SMLNUM ) * on 04/01/10. * "Bug" reported by Ondra Kamenik, confirmed by Julie Langou, fixed by * Jim Demmel and Guillaume Revy. See forum post 1783. * THRESH = MAX( TWENTY*EPS*DNORM, SMLNUM ) * IF( M.EQ.2 ) THEN * * CASE 1: Swap 1-by-1 and 1-by-1 blocks. * * Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks * using Givens rotations and perform the swap tentatively. * F = S( 2, 2 )*T( 1, 1 ) - T( 2, 2 )*S( 1, 1 ) G = S( 2, 2 )*T( 1, 2 ) - T( 2, 2 )*S( 1, 2 ) SB = ABS( T( 2, 2 ) ) SA = ABS( S( 2, 2 ) ) CALL DLARTG( F, G, IR( 1, 2 ), IR( 1, 1 ), DDUM ) IR( 2, 1 ) = -IR( 1, 2 ) IR( 2, 2 ) = IR( 1, 1 ) CALL DROT( 2, S( 1, 1 ), 1, S( 1, 2 ), 1, IR( 1, 1 ), $ IR( 2, 1 ) ) CALL DROT( 2, T( 1, 1 ), 1, T( 1, 2 ), 1, IR( 1, 1 ), $ IR( 2, 1 ) ) IF( SA.GE.SB ) THEN CALL DLARTG( S( 1, 1 ), S( 2, 1 ), LI( 1, 1 ), LI( 2, 1 ), $ DDUM ) ELSE CALL DLARTG( T( 1, 1 ), T( 2, 1 ), LI( 1, 1 ), LI( 2, 1 ), $ DDUM ) END IF CALL DROT( 2, S( 1, 1 ), LDST, S( 2, 1 ), LDST, LI( 1, 1 ), $ LI( 2, 1 ) ) CALL DROT( 2, T( 1, 1 ), LDST, T( 2, 1 ), LDST, LI( 1, 1 ), $ LI( 2, 1 ) ) LI( 2, 2 ) = LI( 1, 1 ) LI( 1, 2 ) = -LI( 2, 1 ) * * Weak stability test: * |S21| + |T21| <= O(EPS * F-norm((S, T))) * WS = ABS( S( 2, 1 ) ) + ABS( T( 2, 1 ) ) WEAK = WS.LE.THRESH IF( .NOT.WEAK ) $ GO TO 70 * IF( WANDS ) THEN * * Strong stability test: * F-norm((A-QL**T*S*QR, B-QL**T*T*QR)) <= O(EPS*F-norm((A,B))) * CALL DLACPY( 'Full', M, M, A( J1, J1 ), LDA, WORK( M*M+1 ), $ M ) CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO, $ WORK, M ) CALL DGEMM( 'N', 'T', M, M, M, -ONE, WORK, M, IR, LDST, ONE, $ WORK( M*M+1 ), M ) DSCALE = ZERO DSUM = ONE CALL DLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM ) * CALL DLACPY( 'Full', M, M, B( J1, J1 ), LDB, WORK( M*M+1 ), $ M ) CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO, $ WORK, M ) CALL DGEMM( 'N', 'T', M, M, M, -ONE, WORK, M, IR, LDST, ONE, $ WORK( M*M+1 ), M ) CALL DLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM ) SS = DSCALE*SQRT( DSUM ) DTRONG = SS.LE.THRESH IF( .NOT.DTRONG ) $ GO TO 70 END IF * * Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and * (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). * CALL DROT( J1+1, A( 1, J1 ), 1, A( 1, J1+1 ), 1, IR( 1, 1 ), $ IR( 2, 1 ) ) CALL DROT( J1+1, B( 1, J1 ), 1, B( 1, J1+1 ), 1, IR( 1, 1 ), $ IR( 2, 1 ) ) CALL DROT( N-J1+1, A( J1, J1 ), LDA, A( J1+1, J1 ), LDA, $ LI( 1, 1 ), LI( 2, 1 ) ) CALL DROT( N-J1+1, B( J1, J1 ), LDB, B( J1+1, J1 ), LDB, $ LI( 1, 1 ), LI( 2, 1 ) ) * * Set N1-by-N2 (2,1) - blocks to ZERO. * A( J1+1, J1 ) = ZERO B( J1+1, J1 ) = ZERO * * Accumulate transformations into Q and Z if requested. * IF( WANTZ ) $ CALL DROT( N, Z( 1, J1 ), 1, Z( 1, J1+1 ), 1, IR( 1, 1 ), $ IR( 2, 1 ) ) IF( WANTQ ) $ CALL DROT( N, Q( 1, J1 ), 1, Q( 1, J1+1 ), 1, LI( 1, 1 ), $ LI( 2, 1 ) ) * * Exit with INFO = 0 if swap was successfully performed. * RETURN * ELSE * * CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2 * and 2-by-2 blocks. * * Solve the generalized Sylvester equation * S11 * R - L * S22 = SCALE * S12 * T11 * R - L * T22 = SCALE * T12 * for R and L. Solutions in LI and IR. * CALL DLACPY( 'Full', N1, N2, T( 1, N1+1 ), LDST, LI, LDST ) CALL DLACPY( 'Full', N1, N2, S( 1, N1+1 ), LDST, $ IR( N2+1, N1+1 ), LDST ) CALL DTGSY2( 'N', 0, N1, N2, S, LDST, S( N1+1, N1+1 ), LDST, $ IR( N2+1, N1+1 ), LDST, T, LDST, T( N1+1, N1+1 ), $ LDST, LI, LDST, SCALE, DSUM, DSCALE, IWORK, IDUM, $ LINFO ) * * Compute orthogonal matrix QL: * * QL**T * LI = [ TL ] * [ 0 ] * where * LI = [ -L ] * [ SCALE * identity(N2) ] * DO 10 I = 1, N2 CALL DSCAL( N1, -ONE, LI( 1, I ), 1 ) LI( N1+I, I ) = SCALE 10 CONTINUE CALL DGEQR2( M, N2, LI, LDST, TAUL, WORK, LINFO ) IF( LINFO.NE.0 ) $ GO TO 70 CALL DORG2R( M, M, N2, LI, LDST, TAUL, WORK, LINFO ) IF( LINFO.NE.0 ) $ GO TO 70 * * Compute orthogonal matrix RQ: * * IR * RQ**T = [ 0 TR], * * where IR = [ SCALE * identity(N1), R ] * DO 20 I = 1, N1 IR( N2+I, I ) = SCALE 20 CONTINUE CALL DGERQ2( N1, M, IR( N2+1, 1 ), LDST, TAUR, WORK, LINFO ) IF( LINFO.NE.0 ) $ GO TO 70 CALL DORGR2( M, M, N1, IR, LDST, TAUR, WORK, LINFO ) IF( LINFO.NE.0 ) $ GO TO 70 * * Perform the swapping tentatively: * CALL DGEMM( 'T', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO, $ WORK, M ) CALL DGEMM( 'N', 'T', M, M, M, ONE, WORK, M, IR, LDST, ZERO, S, $ LDST ) CALL DGEMM( 'T', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO, $ WORK, M ) CALL DGEMM( 'N', 'T', M, M, M, ONE, WORK, M, IR, LDST, ZERO, T, $ LDST ) CALL DLACPY( 'F', M, M, S, LDST, SCPY, LDST ) CALL DLACPY( 'F', M, M, T, LDST, TCPY, LDST ) CALL DLACPY( 'F', M, M, IR, LDST, IRCOP, LDST ) CALL DLACPY( 'F', M, M, LI, LDST, LICOP, LDST ) * * Triangularize the B-part by an RQ factorization. * Apply transformation (from left) to A-part, giving S. * CALL DGERQ2( M, M, T, LDST, TAUR, WORK, LINFO ) IF( LINFO.NE.0 ) $ GO TO 70 CALL DORMR2( 'R', 'T', M, M, M, T, LDST, TAUR, S, LDST, WORK, $ LINFO ) IF( LINFO.NE.0 ) $ GO TO 70 CALL DORMR2( 'L', 'N', M, M, M, T, LDST, TAUR, IR, LDST, WORK, $ LINFO ) IF( LINFO.NE.0 ) $ GO TO 70 * * Compute F-norm(S21) in BRQA21. (T21 is 0.) * DSCALE = ZERO DSUM = ONE DO 30 I = 1, N2 CALL DLASSQ( N1, S( N2+1, I ), 1, DSCALE, DSUM ) 30 CONTINUE BRQA21 = DSCALE*SQRT( DSUM ) * * Triangularize the B-part by a QR factorization. * Apply transformation (from right) to A-part, giving S. * CALL DGEQR2( M, M, TCPY, LDST, TAUL, WORK, LINFO ) IF( LINFO.NE.0 ) $ GO TO 70 CALL DORM2R( 'L', 'T', M, M, M, TCPY, LDST, TAUL, SCPY, LDST, $ WORK, INFO ) CALL DORM2R( 'R', 'N', M, M, M, TCPY, LDST, TAUL, LICOP, LDST, $ WORK, INFO ) IF( LINFO.NE.0 ) $ GO TO 70 * * Compute F-norm(S21) in BQRA21. (T21 is 0.) * DSCALE = ZERO DSUM = ONE DO 40 I = 1, N2 CALL DLASSQ( N1, SCPY( N2+1, I ), 1, DSCALE, DSUM ) 40 CONTINUE BQRA21 = DSCALE*SQRT( DSUM ) * * Decide which method to use. * Weak stability test: * F-norm(S21) <= O(EPS * F-norm((S, T))) * IF( BQRA21.LE.BRQA21 .AND. BQRA21.LE.THRESH ) THEN CALL DLACPY( 'F', M, M, SCPY, LDST, S, LDST ) CALL DLACPY( 'F', M, M, TCPY, LDST, T, LDST ) CALL DLACPY( 'F', M, M, IRCOP, LDST, IR, LDST ) CALL DLACPY( 'F', M, M, LICOP, LDST, LI, LDST ) ELSE IF( BRQA21.GE.THRESH ) THEN GO TO 70 END IF * * Set lower triangle of B-part to zero * CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, T(2,1), LDST ) * IF( WANDS ) THEN * * Strong stability test: * F-norm((A-QL*S*QR**T, B-QL*T*QR**T)) <= O(EPS*F-norm((A,B))) * CALL DLACPY( 'Full', M, M, A( J1, J1 ), LDA, WORK( M*M+1 ), $ M ) CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO, $ WORK, M ) CALL DGEMM( 'N', 'N', M, M, M, -ONE, WORK, M, IR, LDST, ONE, $ WORK( M*M+1 ), M ) DSCALE = ZERO DSUM = ONE CALL DLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM ) * CALL DLACPY( 'Full', M, M, B( J1, J1 ), LDB, WORK( M*M+1 ), $ M ) CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO, $ WORK, M ) CALL DGEMM( 'N', 'N', M, M, M, -ONE, WORK, M, IR, LDST, ONE, $ WORK( M*M+1 ), M ) CALL DLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM ) SS = DSCALE*SQRT( DSUM ) DTRONG = ( SS.LE.THRESH ) IF( .NOT.DTRONG ) $ GO TO 70 * END IF * * If the swap is accepted ("weakly" and "strongly"), apply the * transformations and set N1-by-N2 (2,1)-block to zero. * CALL DLASET( 'Full', N1, N2, ZERO, ZERO, S(N2+1,1), LDST ) * * copy back M-by-M diagonal block starting at index J1 of (A, B) * CALL DLACPY( 'F', M, M, S, LDST, A( J1, J1 ), LDA ) CALL DLACPY( 'F', M, M, T, LDST, B( J1, J1 ), LDB ) CALL DLASET( 'Full', LDST, LDST, ZERO, ZERO, T, LDST ) * * Standardize existing 2-by-2 blocks. * CALL DLASET( 'Full', M, M, ZERO, ZERO, WORK, M ) WORK( 1 ) = ONE T( 1, 1 ) = ONE IDUM = LWORK - M*M - 2 IF( N2.GT.1 ) THEN CALL DLAGV2( A( J1, J1 ), LDA, B( J1, J1 ), LDB, AR, AI, BE, $ WORK( 1 ), WORK( 2 ), T( 1, 1 ), T( 2, 1 ) ) WORK( M+1 ) = -WORK( 2 ) WORK( M+2 ) = WORK( 1 ) T( N2, N2 ) = T( 1, 1 ) T( 1, 2 ) = -T( 2, 1 ) END IF WORK( M*M ) = ONE T( M, M ) = ONE * IF( N1.GT.1 ) THEN CALL DLAGV2( A( J1+N2, J1+N2 ), LDA, B( J1+N2, J1+N2 ), LDB, $ TAUR, TAUL, WORK( M*M+1 ), WORK( N2*M+N2+1 ), $ WORK( N2*M+N2+2 ), T( N2+1, N2+1 ), $ T( M, M-1 ) ) WORK( M*M ) = WORK( N2*M+N2+1 ) WORK( M*M-1 ) = -WORK( N2*M+N2+2 ) T( M, M ) = T( N2+1, N2+1 ) T( M-1, M ) = -T( M, M-1 ) END IF CALL DGEMM( 'T', 'N', N2, N1, N2, ONE, WORK, M, A( J1, J1+N2 ), $ LDA, ZERO, WORK( M*M+1 ), N2 ) CALL DLACPY( 'Full', N2, N1, WORK( M*M+1 ), N2, A( J1, J1+N2 ), $ LDA ) CALL DGEMM( 'T', 'N', N2, N1, N2, ONE, WORK, M, B( J1, J1+N2 ), $ LDB, ZERO, WORK( M*M+1 ), N2 ) CALL DLACPY( 'Full', N2, N1, WORK( M*M+1 ), N2, B( J1, J1+N2 ), $ LDB ) CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, WORK, M, ZERO, $ WORK( M*M+1 ), M ) CALL DLACPY( 'Full', M, M, WORK( M*M+1 ), M, LI, LDST ) CALL DGEMM( 'N', 'N', N2, N1, N1, ONE, A( J1, J1+N2 ), LDA, $ T( N2+1, N2+1 ), LDST, ZERO, WORK, N2 ) CALL DLACPY( 'Full', N2, N1, WORK, N2, A( J1, J1+N2 ), LDA ) CALL DGEMM( 'N', 'N', N2, N1, N1, ONE, B( J1, J1+N2 ), LDB, $ T( N2+1, N2+1 ), LDST, ZERO, WORK, N2 ) CALL DLACPY( 'Full', N2, N1, WORK, N2, B( J1, J1+N2 ), LDB ) CALL DGEMM( 'T', 'N', M, M, M, ONE, IR, LDST, T, LDST, ZERO, $ WORK, M ) CALL DLACPY( 'Full', M, M, WORK, M, IR, LDST ) * * Accumulate transformations into Q and Z if requested. * IF( WANTQ ) THEN CALL DGEMM( 'N', 'N', N, M, M, ONE, Q( 1, J1 ), LDQ, LI, $ LDST, ZERO, WORK, N ) CALL DLACPY( 'Full', N, M, WORK, N, Q( 1, J1 ), LDQ ) * END IF * IF( WANTZ ) THEN CALL DGEMM( 'N', 'N', N, M, M, ONE, Z( 1, J1 ), LDZ, IR, $ LDST, ZERO, WORK, N ) CALL DLACPY( 'Full', N, M, WORK, N, Z( 1, J1 ), LDZ ) * END IF * * Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and * (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). * I = J1 + M IF( I.LE.N ) THEN CALL DGEMM( 'T', 'N', M, N-I+1, M, ONE, LI, LDST, $ A( J1, I ), LDA, ZERO, WORK, M ) CALL DLACPY( 'Full', M, N-I+1, WORK, M, A( J1, I ), LDA ) CALL DGEMM( 'T', 'N', M, N-I+1, M, ONE, LI, LDST, $ B( J1, I ), LDB, ZERO, WORK, M ) CALL DLACPY( 'Full', M, N-I+1, WORK, M, B( J1, I ), LDB ) END IF I = J1 - 1 IF( I.GT.0 ) THEN CALL DGEMM( 'N', 'N', I, M, M, ONE, A( 1, J1 ), LDA, IR, $ LDST, ZERO, WORK, I ) CALL DLACPY( 'Full', I, M, WORK, I, A( 1, J1 ), LDA ) CALL DGEMM( 'N', 'N', I, M, M, ONE, B( 1, J1 ), LDB, IR, $ LDST, ZERO, WORK, I ) CALL DLACPY( 'Full', I, M, WORK, I, B( 1, J1 ), LDB ) END IF * * Exit with INFO = 0 if swap was successfully performed. * RETURN * END IF * * Exit with INFO = 1 if swap was rejected. * 70 CONTINUE * INFO = 1 RETURN * * End of DTGEX2 * END *> \brief \b DTGEXC * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTGEXC + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, * LDZ, IFST, ILST, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * LOGICAL WANTQ, WANTZ * INTEGER IFST, ILST, INFO, LDA, LDB, LDQ, LDZ, LWORK, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), * $ WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTGEXC reorders the generalized real Schur decomposition of a real *> matrix pair (A,B) using an orthogonal equivalence transformation *> *> (A, B) = Q * (A, B) * Z**T, *> *> so that the diagonal block of (A, B) with row index IFST is moved *> to row ILST. *> *> (A, B) must be in generalized real Schur canonical form (as returned *> by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2 *> diagonal blocks. B is upper triangular. *> *> Optionally, the matrices Q and Z of generalized Schur vectors are *> updated. *> *> Q(in) * A(in) * Z(in)**T = Q(out) * A(out) * Z(out)**T *> Q(in) * B(in) * Z(in)**T = Q(out) * B(out) * Z(out)**T *> *> \endverbatim * * Arguments: * ========== * *> \param[in] WANTQ *> \verbatim *> WANTQ is LOGICAL *> .TRUE. : update the left transformation matrix Q; *> .FALSE.: do not update Q. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> .TRUE. : update the right transformation matrix Z; *> .FALSE.: do not update Z. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A and B. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the matrix A in generalized real Schur canonical *> form. *> On exit, the updated matrix A, again in generalized *> real Schur canonical form. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,N) *> On entry, the matrix B in generalized real Schur canonical *> form (A,B). *> On exit, the updated matrix B, again in generalized *> real Schur canonical form (A,B). *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is DOUBLE PRECISION array, dimension (LDQ,N) *> On entry, if WANTQ = .TRUE., the orthogonal matrix Q. *> On exit, the updated matrix Q. *> If WANTQ = .FALSE., Q is not referenced. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= 1. *> If WANTQ = .TRUE., LDQ >= N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ,N) *> On entry, if WANTZ = .TRUE., the orthogonal matrix Z. *> On exit, the updated matrix Z. *> If WANTZ = .FALSE., Z is not referenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1. *> If WANTZ = .TRUE., LDZ >= N. *> \endverbatim *> *> \param[in,out] IFST *> \verbatim *> IFST is INTEGER *> \endverbatim *> *> \param[in,out] ILST *> \verbatim *> ILST is INTEGER *> Specify the reordering of the diagonal blocks of (A, B). *> The block with row index IFST is moved to row ILST, by a *> sequence of swapping between adjacent blocks. *> On exit, if IFST pointed on entry to the second row of *> a 2-by-2 block, it is changed to point to the first row; *> ILST always points to the first row of the block in its *> final position (which may differ from its input value by *> +1 or -1). 1 <= IFST, ILST <= N. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. *> LWORK >= 1 when N <= 1, otherwise LWORK >= 4*N + 16. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error *> message related to LWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> =0: successful exit. *> <0: if INFO = -i, the i-th argument had an illegal value. *> =1: The transformed matrix pair (A, B) would be too far *> from generalized Schur form; the problem is ill- *> conditioned. (A, B) may have been partially reordered, *> and ILST points to the first row of the current *> position of the block being moved. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleGEcomputational * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * *> \par References: * ================ *> *> \verbatim *> *> [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the *> Generalized Real Schur Form of a Regular Matrix Pair (A, B), in *> M.S. Moonen et al (eds), Linear Algebra for Large Scale and *> Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. *> \endverbatim *> * ===================================================================== SUBROUTINE DTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, IFST, ILST, WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. LOGICAL WANTQ, WANTZ INTEGER IFST, ILST, INFO, LDA, LDB, LDQ, LDZ, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), $ WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER HERE, LWMIN, NBF, NBL, NBNEXT * .. * .. External Subroutines .. EXTERNAL DTGEX2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Decode and test input arguments. * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDQ.LT.1 .OR. WANTQ .AND. ( LDQ.LT.MAX( 1, N ) ) ) THEN INFO = -9 ELSE IF( LDZ.LT.1 .OR. WANTZ .AND. ( LDZ.LT.MAX( 1, N ) ) ) THEN INFO = -11 ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN INFO = -12 ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN INFO = -13 END IF * IF( INFO.EQ.0 ) THEN IF( N.LE.1 ) THEN LWMIN = 1 ELSE LWMIN = 4*N + 16 END IF WORK(1) = LWMIN * IF (LWORK.LT.LWMIN .AND. .NOT.LQUERY) THEN INFO = -15 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTGEXC', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.LE.1 ) $ RETURN * * Determine the first row of the specified block and find out * if it is 1-by-1 or 2-by-2. * IF( IFST.GT.1 ) THEN IF( A( IFST, IFST-1 ).NE.ZERO ) $ IFST = IFST - 1 END IF NBF = 1 IF( IFST.LT.N ) THEN IF( A( IFST+1, IFST ).NE.ZERO ) $ NBF = 2 END IF * * Determine the first row of the final block * and find out if it is 1-by-1 or 2-by-2. * IF( ILST.GT.1 ) THEN IF( A( ILST, ILST-1 ).NE.ZERO ) $ ILST = ILST - 1 END IF NBL = 1 IF( ILST.LT.N ) THEN IF( A( ILST+1, ILST ).NE.ZERO ) $ NBL = 2 END IF IF( IFST.EQ.ILST ) $ RETURN * IF( IFST.LT.ILST ) THEN * * Update ILST. * IF( NBF.EQ.2 .AND. NBL.EQ.1 ) $ ILST = ILST - 1 IF( NBF.EQ.1 .AND. NBL.EQ.2 ) $ ILST = ILST + 1 * HERE = IFST * 10 CONTINUE * * Swap with next one below. * IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN * * Current block either 1-by-1 or 2-by-2. * NBNEXT = 1 IF( HERE+NBF+1.LE.N ) THEN IF( A( HERE+NBF+1, HERE+NBF ).NE.ZERO ) $ NBNEXT = 2 END IF CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, HERE, NBF, NBNEXT, WORK, LWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + NBNEXT * * Test if 2-by-2 block breaks into two 1-by-1 blocks. * IF( NBF.EQ.2 ) THEN IF( A( HERE+1, HERE ).EQ.ZERO ) $ NBF = 3 END IF * ELSE * * Current block consists of two 1-by-1 blocks, each of which * must be swapped individually. * NBNEXT = 1 IF( HERE+3.LE.N ) THEN IF( A( HERE+3, HERE+2 ).NE.ZERO ) $ NBNEXT = 2 END IF CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, HERE+1, 1, NBNEXT, WORK, LWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF IF( NBNEXT.EQ.1 ) THEN * * Swap two 1-by-1 blocks. * CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, HERE, 1, 1, WORK, LWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + 1 * ELSE * * Recompute NBNEXT in case of 2-by-2 split. * IF( A( HERE+2, HERE+1 ).EQ.ZERO ) $ NBNEXT = 1 IF( NBNEXT.EQ.2 ) THEN * * 2-by-2 block did not split. * CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, $ Z, LDZ, HERE, 1, NBNEXT, WORK, LWORK, $ INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + 2 ELSE * * 2-by-2 block did split. * CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, $ Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + 1 CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, $ Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + 1 END IF * END IF END IF IF( HERE.LT.ILST ) $ GO TO 10 ELSE HERE = IFST * 20 CONTINUE * * Swap with next one below. * IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN * * Current block either 1-by-1 or 2-by-2. * NBNEXT = 1 IF( HERE.GE.3 ) THEN IF( A( HERE-1, HERE-2 ).NE.ZERO ) $ NBNEXT = 2 END IF CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, HERE-NBNEXT, NBNEXT, NBF, WORK, LWORK, $ INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - NBNEXT * * Test if 2-by-2 block breaks into two 1-by-1 blocks. * IF( NBF.EQ.2 ) THEN IF( A( HERE+1, HERE ).EQ.ZERO ) $ NBF = 3 END IF * ELSE * * Current block consists of two 1-by-1 blocks, each of which * must be swapped individually. * NBNEXT = 1 IF( HERE.GE.3 ) THEN IF( A( HERE-1, HERE-2 ).NE.ZERO ) $ NBNEXT = 2 END IF CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, HERE-NBNEXT, NBNEXT, 1, WORK, LWORK, $ INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF IF( NBNEXT.EQ.1 ) THEN * * Swap two 1-by-1 blocks. * CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, HERE, NBNEXT, 1, WORK, LWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - 1 ELSE * * Recompute NBNEXT in case of 2-by-2 split. * IF( A( HERE, HERE-1 ).EQ.ZERO ) $ NBNEXT = 1 IF( NBNEXT.EQ.2 ) THEN * * 2-by-2 block did not split. * CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, $ Z, LDZ, HERE-1, 2, 1, WORK, LWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - 2 ELSE * * 2-by-2 block did split. * CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, $ Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - 1 CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, $ Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - 1 END IF END IF END IF IF( HERE.GT.ILST ) $ GO TO 20 END IF ILST = HERE WORK( 1 ) = LWMIN RETURN * * End of DTGEXC * END *> \brief \b DTGSEN * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTGSEN + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, * ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, M, PL, * PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO ) * * .. Scalar Arguments .. * LOGICAL WANTQ, WANTZ * INTEGER IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK, * $ M, N * DOUBLE PRECISION PL, PR * .. * .. Array Arguments .. * LOGICAL SELECT( * ) * INTEGER IWORK( * ) * DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), * $ B( LDB, * ), BETA( * ), DIF( * ), Q( LDQ, * ), * $ WORK( * ), Z( LDZ, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTGSEN reorders the generalized real Schur decomposition of a real *> matrix pair (A, B) (in terms of an orthonormal equivalence trans- *> formation Q**T * (A, B) * Z), so that a selected cluster of eigenvalues *> appears in the leading diagonal blocks of the upper quasi-triangular *> matrix A and the upper triangular B. The leading columns of Q and *> Z form orthonormal bases of the corresponding left and right eigen- *> spaces (deflating subspaces). (A, B) must be in generalized real *> Schur canonical form (as returned by DGGES), i.e. A is block upper *> triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper *> triangular. *> *> DTGSEN also computes the generalized eigenvalues *> *> w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j) *> *> of the reordered matrix pair (A, B). *> *> Optionally, DTGSEN computes the estimates of reciprocal condition *> numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11), *> (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s) *> between the matrix pairs (A11, B11) and (A22,B22) that correspond to *> the selected cluster and the eigenvalues outside the cluster, resp., *> and norms of "projections" onto left and right eigenspaces w.r.t. *> the selected cluster in the (1,1)-block. *> \endverbatim * * Arguments: * ========== * *> \param[in] IJOB *> \verbatim *> IJOB is INTEGER *> Specifies whether condition numbers are required for the *> cluster of eigenvalues (PL and PR) or the deflating subspaces *> (Difu and Difl): *> =0: Only reorder w.r.t. SELECT. No extras. *> =1: Reciprocal of norms of "projections" onto left and right *> eigenspaces w.r.t. the selected cluster (PL and PR). *> =2: Upper bounds on Difu and Difl. F-norm-based estimate *> (DIF(1:2)). *> =3: Estimate of Difu and Difl. 1-norm-based estimate *> (DIF(1:2)). *> About 5 times as expensive as IJOB = 2. *> =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic *> version to get it all. *> =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above) *> \endverbatim *> *> \param[in] WANTQ *> \verbatim *> WANTQ is LOGICAL *> .TRUE. : update the left transformation matrix Q; *> .FALSE.: do not update Q. *> \endverbatim *> *> \param[in] WANTZ *> \verbatim *> WANTZ is LOGICAL *> .TRUE. : update the right transformation matrix Z; *> .FALSE.: do not update Z. *> \endverbatim *> *> \param[in] SELECT *> \verbatim *> SELECT is LOGICAL array, dimension (N) *> SELECT specifies the eigenvalues in the selected cluster. *> To select a real eigenvalue w(j), SELECT(j) must be set to *> .TRUE.. To select a complex conjugate pair of eigenvalues *> w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, *> either SELECT(j) or SELECT(j+1) or both must be set to *> .TRUE.; a complex conjugate pair of eigenvalues must be *> either both included in the cluster or both excluded. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A and B. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension(LDA,N) *> On entry, the upper quasi-triangular matrix A, with (A, B) in *> generalized real Schur canonical form. *> On exit, A is overwritten by the reordered matrix A. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension(LDB,N) *> On entry, the upper triangular matrix B, with (A, B) in *> generalized real Schur canonical form. *> On exit, B is overwritten by the reordered matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] ALPHAR *> \verbatim *> ALPHAR is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] ALPHAI *> \verbatim *> ALPHAI is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] BETA *> \verbatim *> BETA is DOUBLE PRECISION array, dimension (N) *> *> On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will *> be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i *> and BETA(j),j=1,...,N are the diagonals of the complex Schur *> form (S,T) that would result if the 2-by-2 diagonal blocks of *> the real generalized Schur form of (A,B) were further reduced *> to triangular form using complex unitary transformations. *> If ALPHAI(j) is zero, then the j-th eigenvalue is real; if *> positive, then the j-th and (j+1)-st eigenvalues are a *> complex conjugate pair, with ALPHAI(j+1) negative. *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is DOUBLE PRECISION array, dimension (LDQ,N) *> On entry, if WANTQ = .TRUE., Q is an N-by-N matrix. *> On exit, Q has been postmultiplied by the left orthogonal *> transformation matrix which reorder (A, B); The leading M *> columns of Q form orthonormal bases for the specified pair of *> left eigenspaces (deflating subspaces). *> If WANTQ = .FALSE., Q is not referenced. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= 1; *> and if WANTQ = .TRUE., LDQ >= N. *> \endverbatim *> *> \param[in,out] Z *> \verbatim *> Z is DOUBLE PRECISION array, dimension (LDZ,N) *> On entry, if WANTZ = .TRUE., Z is an N-by-N matrix. *> On exit, Z has been postmultiplied by the left orthogonal *> transformation matrix which reorder (A, B); The leading M *> columns of Z form orthonormal bases for the specified pair of *> left eigenspaces (deflating subspaces). *> If WANTZ = .FALSE., Z is not referenced. *> \endverbatim *> *> \param[in] LDZ *> \verbatim *> LDZ is INTEGER *> The leading dimension of the array Z. LDZ >= 1; *> If WANTZ = .TRUE., LDZ >= N. *> \endverbatim *> *> \param[out] M *> \verbatim *> M is INTEGER *> The dimension of the specified pair of left and right eigen- *> spaces (deflating subspaces). 0 <= M <= N. *> \endverbatim *> *> \param[out] PL *> \verbatim *> PL is DOUBLE PRECISION *> \endverbatim *> *> \param[out] PR *> \verbatim *> PR is DOUBLE PRECISION *> *> If IJOB = 1, 4 or 5, PL, PR are lower bounds on the *> reciprocal of the norm of "projections" onto left and right *> eigenspaces with respect to the selected cluster. *> 0 < PL, PR <= 1. *> If M = 0 or M = N, PL = PR = 1. *> If IJOB = 0, 2 or 3, PL and PR are not referenced. *> \endverbatim *> *> \param[out] DIF *> \verbatim *> DIF is DOUBLE PRECISION array, dimension (2). *> If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl. *> If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on *> Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based *> estimates of Difu and Difl. *> If M = 0 or N, DIF(1:2) = F-norm([A, B]). *> If IJOB = 0 or 1, DIF is not referenced. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= 4*N+16. *> If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)). *> If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)). *> *> 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. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) *> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. *> \endverbatim *> *> \param[in] LIWORK *> \verbatim *> LIWORK is INTEGER *> The dimension of the array IWORK. LIWORK >= 1. *> If IJOB = 1, 2 or 4, LIWORK >= N+6. *> If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6). *> *> If LIWORK = -1, then a workspace query is assumed; the *> routine only calculates the optimal size of the IWORK array, *> returns this value as the first entry of the IWORK array, and *> no error message related to LIWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> =0: Successful exit. *> <0: If INFO = -i, the i-th argument had an illegal value. *> =1: Reordering of (A, B) failed because the transformed *> matrix pair (A, B) would be too far from generalized *> Schur form; the problem is very ill-conditioned. *> (A, B) may have been partially reordered. *> If requested, 0 is returned in DIF(*), PL and PR. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> DTGSEN first collects the selected eigenvalues by computing *> orthogonal U and W that move them to the top left corner of (A, B). *> In other words, the selected eigenvalues are the eigenvalues of *> (A11, B11) in: *> *> U**T*(A, B)*W = (A11 A12) (B11 B12) n1 *> ( 0 A22),( 0 B22) n2 *> n1 n2 n1 n2 *> *> where N = n1+n2 and U**T means the transpose of U. The first n1 columns *> of U and W span the specified pair of left and right eigenspaces *> (deflating subspaces) of (A, B). *> *> If (A, B) has been obtained from the generalized real Schur *> decomposition of a matrix pair (C, D) = Q*(A, B)*Z**T, then the *> reordered generalized real Schur form of (C, D) is given by *> *> (C, D) = (Q*U)*(U**T*(A, B)*W)*(Z*W)**T, *> *> and the first n1 columns of Q*U and Z*W span the corresponding *> deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.). *> *> Note that if the selected eigenvalue is sufficiently ill-conditioned, *> then its value may differ significantly from its value before *> reordering. *> *> The reciprocal condition numbers of the left and right eigenspaces *> spanned by the first n1 columns of U and W (or Q*U and Z*W) may *> be returned in DIF(1:2), corresponding to Difu and Difl, resp. *> *> The Difu and Difl are defined as: *> *> Difu[(A11, B11), (A22, B22)] = sigma-min( Zu ) *> and *> Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)], *> *> where sigma-min(Zu) is the smallest singular value of the *> (2*n1*n2)-by-(2*n1*n2) matrix *> *> Zu = [ kron(In2, A11) -kron(A22**T, In1) ] *> [ kron(In2, B11) -kron(B22**T, In1) ]. *> *> Here, Inx is the identity matrix of size nx and A22**T is the *> transpose of A22. kron(X, Y) is the Kronecker product between *> the matrices X and Y. *> *> When DIF(2) is small, small changes in (A, B) can cause large changes *> in the deflating subspace. An approximate (asymptotic) bound on the *> maximum angular error in the computed deflating subspaces is *> *> EPS * norm((A, B)) / DIF(2), *> *> where EPS is the machine precision. *> *> The reciprocal norm of the projectors on the left and right *> eigenspaces associated with (A11, B11) may be returned in PL and PR. *> They are computed as follows. First we compute L and R so that *> P*(A, B)*Q is block diagonal, where *> *> P = ( I -L ) n1 Q = ( I R ) n1 *> ( 0 I ) n2 and ( 0 I ) n2 *> n1 n2 n1 n2 *> *> and (L, R) is the solution to the generalized Sylvester equation *> *> A11*R - L*A22 = -A12 *> B11*R - L*B22 = -B12 *> *> Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2). *> An approximate (asymptotic) bound on the average absolute error of *> the selected eigenvalues is *> *> EPS * norm((A, B)) / PL. *> *> There are also global error bounds which valid for perturbations up *> to a certain restriction: A lower bound (x) on the smallest *> F-norm(E,F) for which an eigenvalue of (A11, B11) may move and *> coalesce with an eigenvalue of (A22, B22) under perturbation (E,F), *> (i.e. (A + E, B + F), is *> *> x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)). *> *> An approximate bound on x can be computed from DIF(1:2), PL and PR. *> *> If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed *> (L', R') and unperturbed (L, R) left and right deflating subspaces *> associated with the selected cluster in the (1,1)-blocks can be *> bounded as *> *> max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2)) *> max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2)) *> *> See LAPACK User's Guide section 4.11 or the following references *> for more information. *> *> Note that if the default method for computing the Frobenius-norm- *> based estimate DIF is not wanted (see DLATDF), then the parameter *> IDIFJB (see below) should be changed from 3 to 4 (routine DLATDF *> (IJOB = 2 will be used)). See DTGSYL for more details. *> \endverbatim * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * *> \par References: * ================ *> *> \verbatim *> *> [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the *> Generalized Real Schur Form of a Regular Matrix Pair (A, B), in *> M.S. Moonen et al (eds), Linear Algebra for Large Scale and *> Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. *> *> [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified *> Eigenvalues of a Regular Matrix Pair (A, B) and Condition *> Estimation: Theory, Algorithms and Software, *> Report UMINF - 94.04, Department of Computing Science, Umea *> University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working *> Note 87. To appear in Numerical Algorithms, 1996. *> *> [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software *> for Solving the Generalized Sylvester Equation and Estimating the *> Separation between Regular Matrix Pairs, Report UMINF - 93.23, *> Department of Computing Science, Umea University, S-901 87 Umea, *> Sweden, December 1993, Revised April 1994, Also as LAPACK Working *> Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, *> 1996. *> \endverbatim *> * ===================================================================== SUBROUTINE DTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, M, PL, $ PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO ) * * -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. LOGICAL WANTQ, WANTZ INTEGER IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK, $ M, N DOUBLE PRECISION PL, PR * .. * .. Array Arguments .. LOGICAL SELECT( * ) INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), $ B( LDB, * ), BETA( * ), DIF( * ), Q( LDQ, * ), $ WORK( * ), Z( LDZ, * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER IDIFJB PARAMETER ( IDIFJB = 3 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, PAIR, SWAP, WANTD, WANTD1, WANTD2, $ WANTP INTEGER I, IERR, IJB, K, KASE, KK, KS, LIWMIN, LWMIN, $ MN2, N1, N2 DOUBLE PRECISION DSCALE, DSUM, EPS, RDSCAL, SMLNUM * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) * .. * .. External Subroutines .. EXTERNAL DLACN2, DLACPY, DLAG2, DLASSQ, DTGEXC, DTGSYL, $ XERBLA * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC MAX, SIGN, SQRT * .. * .. Executable Statements .. * * Decode and test the input parameters * INFO = 0 LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) * IF( IJOB.LT.0 .OR. IJOB.GT.5 ) THEN INFO = -1 ELSE IF( N.LT.0 ) 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( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN INFO = -14 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN INFO = -16 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTGSEN', -INFO ) RETURN END IF * * Get machine constants * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) / EPS IERR = 0 * WANTP = IJOB.EQ.1 .OR. IJOB.GE.4 WANTD1 = IJOB.EQ.2 .OR. IJOB.EQ.4 WANTD2 = IJOB.EQ.3 .OR. IJOB.EQ.5 WANTD = WANTD1 .OR. WANTD2 * * Set M to the dimension of the specified pair of deflating * subspaces. * M = 0 PAIR = .FALSE. IF( .NOT.LQUERY .OR. IJOB.NE.0 ) THEN DO 10 K = 1, N IF( PAIR ) THEN PAIR = .FALSE. ELSE IF( K.LT.N ) THEN IF( A( K+1, K ).EQ.ZERO ) THEN IF( SELECT( K ) ) $ M = M + 1 ELSE PAIR = .TRUE. IF( SELECT( K ) .OR. SELECT( K+1 ) ) $ M = M + 2 END IF ELSE IF( SELECT( N ) ) $ M = M + 1 END IF END IF 10 CONTINUE END IF * IF( IJOB.EQ.1 .OR. IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN LWMIN = MAX( 1, 4*N+16, 2*M*( N-M ) ) LIWMIN = MAX( 1, N+6 ) ELSE IF( IJOB.EQ.3 .OR. IJOB.EQ.5 ) THEN LWMIN = MAX( 1, 4*N+16, 4*M*( N-M ) ) LIWMIN = MAX( 1, 2*M*( N-M ), N+6 ) ELSE LWMIN = MAX( 1, 4*N+16 ) LIWMIN = 1 END IF * WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN * IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN INFO = -22 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN INFO = -24 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTGSEN', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible. * IF( M.EQ.N .OR. M.EQ.0 ) THEN IF( WANTP ) THEN PL = ONE PR = ONE END IF IF( WANTD ) THEN DSCALE = ZERO DSUM = ONE DO 20 I = 1, N CALL DLASSQ( N, A( 1, I ), 1, DSCALE, DSUM ) CALL DLASSQ( N, B( 1, I ), 1, DSCALE, DSUM ) 20 CONTINUE DIF( 1 ) = DSCALE*SQRT( DSUM ) DIF( 2 ) = DIF( 1 ) END IF GO TO 60 END IF * * Collect the selected blocks at the top-left corner of (A, B). * KS = 0 PAIR = .FALSE. DO 30 K = 1, N IF( PAIR ) THEN PAIR = .FALSE. ELSE * SWAP = SELECT( K ) IF( K.LT.N ) THEN IF( A( K+1, K ).NE.ZERO ) THEN PAIR = .TRUE. SWAP = SWAP .OR. SELECT( K+1 ) END IF END IF * IF( SWAP ) THEN KS = KS + 1 * * Swap the K-th block to position KS. * Perform the reordering of diagonal blocks in (A, B) * by orthogonal transformation matrices and update * Q and Z accordingly (if requested): * KK = K IF( K.NE.KS ) $ CALL DTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, $ Z, LDZ, KK, KS, WORK, LWORK, IERR ) * IF( IERR.GT.0 ) THEN * * Swap is rejected: exit. * INFO = 1 IF( WANTP ) THEN PL = ZERO PR = ZERO END IF IF( WANTD ) THEN DIF( 1 ) = ZERO DIF( 2 ) = ZERO END IF GO TO 60 END IF * IF( PAIR ) $ KS = KS + 1 END IF END IF 30 CONTINUE IF( WANTP ) THEN * * Solve generalized Sylvester equation for R and L * and compute PL and PR. * N1 = M N2 = N - M I = N1 + 1 IJB = 0 CALL DLACPY( 'Full', N1, N2, A( 1, I ), LDA, WORK, N1 ) CALL DLACPY( 'Full', N1, N2, B( 1, I ), LDB, WORK( N1*N2+1 ), $ N1 ) CALL DTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK, $ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), N1, $ DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ), $ LWORK-2*N1*N2, IWORK, IERR ) * * Estimate the reciprocal of norms of "projections" onto left * and right eigenspaces. * RDSCAL = ZERO DSUM = ONE CALL DLASSQ( N1*N2, WORK, 1, RDSCAL, DSUM ) PL = RDSCAL*SQRT( DSUM ) IF( PL.EQ.ZERO ) THEN PL = ONE ELSE PL = DSCALE / ( SQRT( DSCALE*DSCALE / PL+PL )*SQRT( PL ) ) END IF RDSCAL = ZERO DSUM = ONE CALL DLASSQ( N1*N2, WORK( N1*N2+1 ), 1, RDSCAL, DSUM ) PR = RDSCAL*SQRT( DSUM ) IF( PR.EQ.ZERO ) THEN PR = ONE ELSE PR = DSCALE / ( SQRT( DSCALE*DSCALE / PR+PR )*SQRT( PR ) ) END IF END IF * IF( WANTD ) THEN * * Compute estimates of Difu and Difl. * IF( WANTD1 ) THEN N1 = M N2 = N - M I = N1 + 1 IJB = IDIFJB * * Frobenius norm-based Difu-estimate. * CALL DTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK, $ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), $ N1, DSCALE, DIF( 1 ), WORK( 2*N1*N2+1 ), $ LWORK-2*N1*N2, IWORK, IERR ) * * Frobenius norm-based Difl-estimate. * CALL DTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, WORK, $ N2, B( I, I ), LDB, B, LDB, WORK( N1*N2+1 ), $ N2, DSCALE, DIF( 2 ), WORK( 2*N1*N2+1 ), $ LWORK-2*N1*N2, IWORK, IERR ) ELSE * * * Compute 1-norm-based estimates of Difu and Difl using * reversed communication with DLACN2. In each step a * generalized Sylvester equation or a transposed variant * is solved. * KASE = 0 N1 = M N2 = N - M I = N1 + 1 IJB = 0 MN2 = 2*N1*N2 * * 1-norm-based estimate of Difu. * 40 CONTINUE CALL DLACN2( MN2, WORK( MN2+1 ), WORK, IWORK, DIF( 1 ), $ KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN * * Solve generalized Sylvester equation. * CALL DTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, $ WORK, N1, B, LDB, B( I, I ), LDB, $ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ), $ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK, $ IERR ) ELSE * * Solve the transposed variant. * CALL DTGSYL( 'T', IJB, N1, N2, A, LDA, A( I, I ), LDA, $ WORK, N1, B, LDB, B( I, I ), LDB, $ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ), $ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK, $ IERR ) END IF GO TO 40 END IF DIF( 1 ) = DSCALE / DIF( 1 ) * * 1-norm-based estimate of Difl. * 50 CONTINUE CALL DLACN2( MN2, WORK( MN2+1 ), WORK, IWORK, DIF( 2 ), $ KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN * * Solve generalized Sylvester equation. * CALL DTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, $ WORK, N2, B( I, I ), LDB, B, LDB, $ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ), $ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK, $ IERR ) ELSE * * Solve the transposed variant. * CALL DTGSYL( 'T', IJB, N2, N1, A( I, I ), LDA, A, LDA, $ WORK, N2, B( I, I ), LDB, B, LDB, $ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ), $ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK, $ IERR ) END IF GO TO 50 END IF DIF( 2 ) = DSCALE / DIF( 2 ) * END IF END IF * 60 CONTINUE * * Compute generalized eigenvalues of reordered pair (A, B) and * normalize the generalized Schur form. * PAIR = .FALSE. DO 80 K = 1, N IF( PAIR ) THEN PAIR = .FALSE. ELSE * IF( K.LT.N ) THEN IF( A( K+1, K ).NE.ZERO ) THEN PAIR = .TRUE. END IF END IF * IF( PAIR ) THEN * * Compute the eigenvalue(s) at position K. * WORK( 1 ) = A( K, K ) WORK( 2 ) = A( K+1, K ) WORK( 3 ) = A( K, K+1 ) WORK( 4 ) = A( K+1, K+1 ) WORK( 5 ) = B( K, K ) WORK( 6 ) = B( K+1, K ) WORK( 7 ) = B( K, K+1 ) WORK( 8 ) = B( K+1, K+1 ) CALL DLAG2( WORK, 2, WORK( 5 ), 2, SMLNUM*EPS, BETA( K ), $ BETA( K+1 ), ALPHAR( K ), ALPHAR( K+1 ), $ ALPHAI( K ) ) ALPHAI( K+1 ) = -ALPHAI( K ) * ELSE * IF( SIGN( ONE, B( K, K ) ).LT.ZERO ) THEN * * If B(K,K) is negative, make it positive * DO 70 I = 1, N A( K, I ) = -A( K, I ) B( K, I ) = -B( K, I ) IF( WANTQ ) Q( I, K ) = -Q( I, K ) 70 CONTINUE END IF * ALPHAR( K ) = A( K, K ) ALPHAI( K ) = ZERO BETA( K ) = B( K, K ) * END IF END IF 80 CONTINUE * WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN * RETURN * * End of DTGSEN * END *> \brief \b DTGSJA * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTGSJA + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, * LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, * Q, LDQ, WORK, NCYCLE, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBQ, JOBU, JOBV * INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, * $ NCYCLE, P * DOUBLE PRECISION TOLA, TOLB * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), ALPHA( * ), B( LDB, * ), * $ BETA( * ), Q( LDQ, * ), U( LDU, * ), * $ V( LDV, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTGSJA computes the generalized singular value decomposition (GSVD) *> of two real upper triangular (or trapezoidal) matrices A and B. *> *> On entry, it is assumed that matrices A and B have the following *> forms, which may be obtained by the preprocessing subroutine DGGSVP *> from a general M-by-N matrix A and P-by-N matrix B: *> *> N-K-L K L *> A = K ( 0 A12 A13 ) if M-K-L >= 0; *> L ( 0 0 A23 ) *> M-K-L ( 0 0 0 ) *> *> N-K-L K L *> A = K ( 0 A12 A13 ) if M-K-L < 0; *> M-K ( 0 0 A23 ) *> *> N-K-L K L *> B = 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. *> *> On exit, *> *> U**T *A*Q = D1*( 0 R ), V**T *B*Q = D2*( 0 R ), *> *> where U, V and Q are orthogonal matrices. *> R is a nonsingular upper triangular matrix, and D1 and D2 are *> ``diagonal'' matrices, which are of the following structures: *> *> If M-K-L >= 0, *> *> K L *> D1 = K ( I 0 ) *> L ( 0 C ) *> M-K-L ( 0 0 ) *> *> K L *> D2 = L ( 0 S ) *> P-L ( 0 0 ) *> *> N-K-L K L *> ( 0 R ) = K ( 0 R11 R12 ) K *> L ( 0 0 R22 ) L *> *> where *> *> C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), *> S = diag( BETA(K+1), ... , BETA(K+L) ), *> C**2 + S**2 = I. *> *> R is stored in A(1:K+L,N-K-L+1:N) on exit. *> *> If M-K-L < 0, *> *> K M-K K+L-M *> D1 = K ( I 0 0 ) *> M-K ( 0 C 0 ) *> *> K M-K K+L-M *> D2 = M-K ( 0 S 0 ) *> K+L-M ( 0 0 I ) *> P-L ( 0 0 0 ) *> *> N-K-L K M-K K+L-M *> ( 0 R ) = K ( 0 R11 R12 R13 ) *> M-K ( 0 0 R22 R23 ) *> K+L-M ( 0 0 0 R33 ) *> *> where *> C = diag( ALPHA(K+1), ... , ALPHA(M) ), *> S = diag( BETA(K+1), ... , BETA(M) ), *> C**2 + S**2 = I. *> *> R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored *> ( 0 R22 R23 ) *> in B(M-K+1:L,N+M-K-L+1:N) on exit. *> *> The computation of the orthogonal transformation matrices U, V or Q *> is optional. These matrices may either be formed explicitly, or they *> may be postmultiplied into input matrices U1, V1, or Q1. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBU *> \verbatim *> JOBU is CHARACTER*1 *> = 'U': U must contain an orthogonal matrix U1 on entry, and *> the product U1*U is returned; *> = 'I': U is initialized to the unit matrix, and the *> orthogonal matrix U is returned; *> = 'N': U is not computed. *> \endverbatim *> *> \param[in] JOBV *> \verbatim *> JOBV is CHARACTER*1 *> = 'V': V must contain an orthogonal matrix V1 on entry, and *> the product V1*V is returned; *> = 'I': V is initialized to the unit matrix, and the *> orthogonal matrix V is returned; *> = 'N': V is not computed. *> \endverbatim *> *> \param[in] JOBQ *> \verbatim *> JOBQ is CHARACTER*1 *> = 'Q': Q must contain an orthogonal matrix Q1 on entry, and *> the product Q1*Q is returned; *> = 'I': Q is initialized to the unit matrix, and the *> orthogonal matrix Q is returned; *> = 'N': Q is not computed. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] P *> \verbatim *> P is INTEGER *> The number of rows of the matrix B. P >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrices A and B. N >= 0. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> \endverbatim *> *> \param[in] L *> \verbatim *> L is INTEGER *> *> K and L specify the subblocks in the input matrices A and B: *> A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,N-L+1:N) *> of A and B, whose GSVD is going to be computed by DTGSJA. *> See Further Details. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the M-by-N matrix A. *> On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular *> matrix R or part of R. See Purpose for details. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,N) *> On entry, the P-by-N matrix B. *> On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains *> a part of R. See Purpose for details. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,P). *> \endverbatim *> *> \param[in] TOLA *> \verbatim *> TOLA is DOUBLE PRECISION *> \endverbatim *> *> \param[in] TOLB *> \verbatim *> TOLB is DOUBLE PRECISION *> *> TOLA and TOLB are the convergence criteria for the Jacobi- *> Kogbetliantz iteration procedure. Generally, they are the *> same as used in the preprocessing step, say *> TOLA = max(M,N)*norm(A)*MAZHEPS, *> TOLB = max(P,N)*norm(B)*MAZHEPS. *> \endverbatim *> *> \param[out] ALPHA *> \verbatim *> ALPHA is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] BETA *> \verbatim *> BETA is DOUBLE PRECISION array, dimension (N) *> *> On exit, ALPHA and BETA contain the generalized singular *> value pairs of A and B; *> ALPHA(1:K) = 1, *> BETA(1:K) = 0, *> and if M-K-L >= 0, *> ALPHA(K+1:K+L) = diag(C), *> BETA(K+1:K+L) = diag(S), *> or if M-K-L < 0, *> ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0 *> BETA(K+1:M) = S, BETA(M+1:K+L) = 1. *> Furthermore, if K+L < N, *> ALPHA(K+L+1:N) = 0 and *> BETA(K+L+1:N) = 0. *> \endverbatim *> *> \param[in,out] U *> \verbatim *> U is DOUBLE PRECISION array, dimension (LDU,M) *> On entry, if JOBU = 'U', U must contain a matrix U1 (usually *> the orthogonal matrix returned by DGGSVP). *> On exit, *> if JOBU = 'I', U contains the orthogonal matrix U; *> if JOBU = 'U', U contains the product U1*U. *> If JOBU = 'N', U is not referenced. *> \endverbatim *> *> \param[in] LDU *> \verbatim *> LDU is INTEGER *> The leading dimension of the array U. LDU >= max(1,M) if *> JOBU = 'U'; LDU >= 1 otherwise. *> \endverbatim *> *> \param[in,out] V *> \verbatim *> V is DOUBLE PRECISION array, dimension (LDV,P) *> On entry, if JOBV = 'V', V must contain a matrix V1 (usually *> the orthogonal matrix returned by DGGSVP). *> On exit, *> if JOBV = 'I', V contains the orthogonal matrix V; *> if JOBV = 'V', V contains the product V1*V. *> If JOBV = 'N', V is not referenced. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the array V. LDV >= max(1,P) if *> JOBV = 'V'; LDV >= 1 otherwise. *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is DOUBLE PRECISION array, dimension (LDQ,N) *> On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually *> the orthogonal matrix returned by DGGSVP). *> On exit, *> if JOBQ = 'I', Q contains the orthogonal matrix Q; *> if JOBQ = 'Q', Q contains the product Q1*Q. *> If JOBQ = 'N', Q is not referenced. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= max(1,N) if *> JOBQ = 'Q'; LDQ >= 1 otherwise. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (2*N) *> \endverbatim *> *> \param[out] NCYCLE *> \verbatim *> NCYCLE is INTEGER *> The number of cycles required for convergence. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> = 1: the procedure does not converge after MAXIT cycles. *> \endverbatim *> *> \verbatim *> Internal Parameters *> =================== *> *> MAXIT INTEGER *> MAXIT specifies the total loops that the iterative procedure *> may take. If after MAXIT cycles, the routine fails to *> converge, we return INFO = 1. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> DTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce *> min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L *> matrix B13 to the form: *> *> U1**T *A13*Q1 = C1*R1; V1**T *B13*Q1 = S1*R1, *> *> where U1, V1 and Q1 are orthogonal matrix, and Z**T is the transpose *> of Z. C1 and S1 are diagonal matrices satisfying *> *> C1**2 + S1**2 = I, *> *> and R1 is an L-by-L nonsingular upper triangular matrix. *> \endverbatim *> * ===================================================================== SUBROUTINE DTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, $ LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, $ Q, LDQ, WORK, NCYCLE, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER JOBQ, JOBU, JOBV INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, $ NCYCLE, P DOUBLE PRECISION TOLA, TOLB * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), ALPHA( * ), B( LDB, * ), $ BETA( * ), Q( LDQ, * ), U( LDU, * ), $ V( LDV, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER MAXIT PARAMETER ( MAXIT = 40 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. * LOGICAL INITQ, INITU, INITV, UPPER, WANTQ, WANTU, WANTV INTEGER I, J, KCYCLE DOUBLE PRECISION A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, ERROR, $ GAMMA, RWK, SNQ, SNU, SNV, SSMIN * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DCOPY, DLAGS2, DLAPLL, DLARTG, DLASET, DROT, $ DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. Executable Statements .. * * Decode and test the input parameters * INITU = LSAME( JOBU, 'I' ) WANTU = INITU .OR. LSAME( JOBU, 'U' ) * INITV = LSAME( JOBV, 'I' ) WANTV = INITV .OR. LSAME( JOBV, 'V' ) * INITQ = LSAME( JOBQ, 'I' ) WANTQ = INITQ .OR. LSAME( JOBQ, 'Q' ) * INFO = 0 IF( .NOT.( INITU .OR. WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( INITV .OR. WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN INFO = -2 ELSE IF( .NOT.( INITQ .OR. 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 = -10 ELSE IF( LDB.LT.MAX( 1, P ) ) THEN INFO = -12 ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN INFO = -18 ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN INFO = -20 ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN INFO = -22 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTGSJA', -INFO ) RETURN END IF * * Initialize U, V and Q, if necessary * IF( INITU ) $ CALL DLASET( 'Full', M, M, ZERO, ONE, U, LDU ) IF( INITV ) $ CALL DLASET( 'Full', P, P, ZERO, ONE, V, LDV ) IF( INITQ ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) * * Loop until convergence * UPPER = .FALSE. DO 40 KCYCLE = 1, MAXIT * UPPER = .NOT.UPPER * DO 20 I = 1, L - 1 DO 10 J = I + 1, L * A1 = ZERO A2 = ZERO A3 = ZERO IF( K+I.LE.M ) $ A1 = A( K+I, N-L+I ) IF( K+J.LE.M ) $ A3 = A( K+J, N-L+J ) * B1 = B( I, N-L+I ) B3 = B( J, N-L+J ) * IF( UPPER ) THEN IF( K+I.LE.M ) $ A2 = A( K+I, N-L+J ) B2 = B( I, N-L+J ) ELSE IF( K+J.LE.M ) $ A2 = A( K+J, N-L+I ) B2 = B( J, N-L+I ) END IF * CALL DLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, $ CSV, SNV, CSQ, SNQ ) * * Update (K+I)-th and (K+J)-th rows of matrix A: U**T *A * IF( K+J.LE.M ) $ CALL DROT( L, A( K+J, N-L+1 ), LDA, A( K+I, N-L+1 ), $ LDA, CSU, SNU ) * * Update I-th and J-th rows of matrix B: V**T *B * CALL DROT( L, B( J, N-L+1 ), LDB, B( I, N-L+1 ), LDB, $ CSV, SNV ) * * Update (N-L+I)-th and (N-L+J)-th columns of matrices * A and B: A*Q and B*Q * CALL DROT( MIN( K+L, M ), A( 1, N-L+J ), 1, $ A( 1, N-L+I ), 1, CSQ, SNQ ) * CALL DROT( L, B( 1, N-L+J ), 1, B( 1, N-L+I ), 1, CSQ, $ SNQ ) * IF( UPPER ) THEN IF( K+I.LE.M ) $ A( K+I, N-L+J ) = ZERO B( I, N-L+J ) = ZERO ELSE IF( K+J.LE.M ) $ A( K+J, N-L+I ) = ZERO B( J, N-L+I ) = ZERO END IF * * Update orthogonal matrices U, V, Q, if desired. * IF( WANTU .AND. K+J.LE.M ) $ CALL DROT( M, U( 1, K+J ), 1, U( 1, K+I ), 1, CSU, $ SNU ) * IF( WANTV ) $ CALL DROT( P, V( 1, J ), 1, V( 1, I ), 1, CSV, SNV ) * IF( WANTQ ) $ CALL DROT( N, Q( 1, N-L+J ), 1, Q( 1, N-L+I ), 1, CSQ, $ SNQ ) * 10 CONTINUE 20 CONTINUE * IF( .NOT.UPPER ) THEN * * The matrices A13 and B13 were lower triangular at the start * of the cycle, and are now upper triangular. * * Convergence test: test the parallelism of the corresponding * rows of A and B. * ERROR = ZERO DO 30 I = 1, MIN( L, M-K ) CALL DCOPY( L-I+1, A( K+I, N-L+I ), LDA, WORK, 1 ) CALL DCOPY( L-I+1, B( I, N-L+I ), LDB, WORK( L+1 ), 1 ) CALL DLAPLL( L-I+1, WORK, 1, WORK( L+1 ), 1, SSMIN ) ERROR = MAX( ERROR, SSMIN ) 30 CONTINUE * IF( ABS( ERROR ).LE.MIN( TOLA, TOLB ) ) $ GO TO 50 END IF * * End of cycle loop * 40 CONTINUE * * The algorithm has not converged after MAXIT cycles. * INFO = 1 GO TO 100 * 50 CONTINUE * * If ERROR <= MIN(TOLA,TOLB), then the algorithm has converged. * Compute the generalized singular value pairs (ALPHA, BETA), and * set the triangular matrix R to array A. * DO 60 I = 1, K ALPHA( I ) = ONE BETA( I ) = ZERO 60 CONTINUE * DO 70 I = 1, MIN( L, M-K ) * A1 = A( K+I, N-L+I ) B1 = B( I, N-L+I ) * IF( A1.NE.ZERO ) THEN GAMMA = B1 / A1 * * change sign if necessary * IF( GAMMA.LT.ZERO ) THEN CALL DSCAL( L-I+1, -ONE, B( I, N-L+I ), LDB ) IF( WANTV ) $ CALL DSCAL( P, -ONE, V( 1, I ), 1 ) END IF * CALL DLARTG( ABS( GAMMA ), ONE, BETA( K+I ), ALPHA( K+I ), $ RWK ) * IF( ALPHA( K+I ).GE.BETA( K+I ) ) THEN CALL DSCAL( L-I+1, ONE / ALPHA( K+I ), A( K+I, N-L+I ), $ LDA ) ELSE CALL DSCAL( L-I+1, ONE / BETA( K+I ), B( I, N-L+I ), $ LDB ) CALL DCOPY( L-I+1, B( I, N-L+I ), LDB, A( K+I, N-L+I ), $ LDA ) END IF * ELSE * ALPHA( K+I ) = ZERO BETA( K+I ) = ONE CALL DCOPY( L-I+1, B( I, N-L+I ), LDB, A( K+I, N-L+I ), $ LDA ) * END IF * 70 CONTINUE * * Post-assignment * DO 80 I = M + 1, K + L ALPHA( I ) = ZERO BETA( I ) = ONE 80 CONTINUE * IF( K+L.LT.N ) THEN DO 90 I = K + L + 1, N ALPHA( I ) = ZERO BETA( I ) = ZERO 90 CONTINUE END IF * 100 CONTINUE NCYCLE = KCYCLE RETURN * * End of DTGSJA * END *> \brief \b DTGSNA * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTGSNA + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, * LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, * IWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER HOWMNY, JOB * INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, M, MM, N * .. * .. Array Arguments .. * LOGICAL SELECT( * ) * INTEGER IWORK( * ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DIF( * ), S( * ), * $ VL( LDVL, * ), VR( LDVR, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTGSNA estimates reciprocal condition numbers for specified *> eigenvalues and/or eigenvectors of a matrix pair (A, B) in *> generalized real Schur canonical form (or of any matrix pair *> (Q*A*Z**T, Q*B*Z**T) with orthogonal matrices Q and Z, where *> Z**T denotes the transpose of Z. *> *> (A, B) must be in generalized real Schur form (as returned by DGGES), *> i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal *> blocks. B is upper triangular. *> *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> Specifies whether condition numbers are required for *> eigenvalues (S) or eigenvectors (DIF): *> = 'E': for eigenvalues only (S); *> = 'V': for eigenvectors only (DIF); *> = 'B': for both eigenvalues and eigenvectors (S and DIF). *> \endverbatim *> *> \param[in] HOWMNY *> \verbatim *> HOWMNY is CHARACTER*1 *> = 'A': compute condition numbers for all eigenpairs; *> = 'S': compute condition numbers for selected eigenpairs *> specified by the array SELECT. *> \endverbatim *> *> \param[in] SELECT *> \verbatim *> SELECT is LOGICAL array, dimension (N) *> If HOWMNY = 'S', SELECT specifies the eigenpairs for which *> condition numbers are required. To select condition numbers *> for the eigenpair corresponding to a real eigenvalue w(j), *> SELECT(j) must be set to .TRUE.. To select condition numbers *> corresponding to a complex conjugate pair of eigenvalues w(j) *> and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be *> set to .TRUE.. *> If HOWMNY = 'A', SELECT is not referenced. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the square matrix pair (A, B). N >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The upper quasi-triangular matrix A in the pair (A,B). *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,N) *> The upper triangular matrix B in the pair (A,B). *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION array, dimension (LDVL,M) *> If JOB = 'E' or 'B', VL must contain left eigenvectors of *> (A, B), corresponding to the eigenpairs specified by HOWMNY *> and SELECT. The eigenvectors must be stored in consecutive *> columns of VL, as returned by DTGEVC. *> If JOB = 'V', VL is not referenced. *> \endverbatim *> *> \param[in] LDVL *> \verbatim *> LDVL is INTEGER *> The leading dimension of the array VL. LDVL >= 1. *> If JOB = 'E' or 'B', LDVL >= N. *> \endverbatim *> *> \param[in] VR *> \verbatim *> VR is DOUBLE PRECISION array, dimension (LDVR,M) *> If JOB = 'E' or 'B', VR must contain right eigenvectors of *> (A, B), corresponding to the eigenpairs specified by HOWMNY *> and SELECT. The eigenvectors must be stored in consecutive *> columns ov VR, as returned by DTGEVC. *> If JOB = 'V', VR is not referenced. *> \endverbatim *> *> \param[in] LDVR *> \verbatim *> LDVR is INTEGER *> The leading dimension of the array VR. LDVR >= 1. *> If JOB = 'E' or 'B', LDVR >= N. *> \endverbatim *> *> \param[out] S *> \verbatim *> S is DOUBLE PRECISION array, dimension (MM) *> If JOB = 'E' or 'B', the reciprocal condition numbers of the *> selected eigenvalues, stored in consecutive elements of the *> array. For a complex conjugate pair of eigenvalues two *> consecutive elements of S are set to the same value. Thus *> S(j), DIF(j), and the j-th columns of VL and VR all *> correspond to the same eigenpair (but not in general the *> j-th eigenpair, unless all eigenpairs are selected). *> If JOB = 'V', S is not referenced. *> \endverbatim *> *> \param[out] DIF *> \verbatim *> DIF is DOUBLE PRECISION array, dimension (MM) *> If JOB = 'V' or 'B', the estimated reciprocal condition *> numbers of the selected eigenvectors, stored in consecutive *> elements of the array. For a complex eigenvector two *> consecutive elements of DIF are set to the same value. If *> the eigenvalues cannot be reordered to compute DIF(j), DIF(j) *> is set to 0; this can only occur when the true value would be *> very small anyway. *> If JOB = 'E', DIF is not referenced. *> \endverbatim *> *> \param[in] MM *> \verbatim *> MM is INTEGER *> The number of elements in the arrays S and DIF. MM >= M. *> \endverbatim *> *> \param[out] M *> \verbatim *> M is INTEGER *> The number of elements of the arrays S and DIF used to store *> the specified condition numbers; for each selected real *> eigenvalue one element is used, and for each selected complex *> conjugate pair of eigenvalues, two elements are used. *> If HOWMNY = 'A', M is set to N. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= max(1,N). *> If JOB = 'V' or 'B' LWORK >= 2*N*(N+2)+16. *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error *> message related to LWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N + 6) *> If JOB = 'E', IWORK is not referenced. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> =0: Successful exit *> <0: If INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The reciprocal of the condition number of a generalized eigenvalue *> w = (a, b) is defined as *> *> S(w) = (|u**TAv|**2 + |u**TBv|**2)**(1/2) / (norm(u)*norm(v)) *> *> where u and v are the left and right eigenvectors of (A, B) *> corresponding to w; |z| denotes the absolute value of the complex *> number, and norm(u) denotes the 2-norm of the vector u. *> The pair (a, b) corresponds to an eigenvalue w = a/b (= u**TAv/u**TBv) *> of the matrix pair (A, B). If both a and b equal zero, then (A B) is *> singular and S(I) = -1 is returned. *> *> An approximate error bound on the chordal distance between the i-th *> computed generalized eigenvalue w and the corresponding exact *> eigenvalue lambda is *> *> chord(w, lambda) <= EPS * norm(A, B) / S(I) *> *> where EPS is the machine precision. *> *> The reciprocal of the condition number DIF(i) of right eigenvector u *> and left eigenvector v corresponding to the generalized eigenvalue w *> is defined as follows: *> *> a) If the i-th eigenvalue w = (a,b) is real *> *> Suppose U and V are orthogonal transformations such that *> *> U**T*(A, B)*V = (S, T) = ( a * ) ( b * ) 1 *> ( 0 S22 ),( 0 T22 ) n-1 *> 1 n-1 1 n-1 *> *> Then the reciprocal condition number DIF(i) is *> *> Difl((a, b), (S22, T22)) = sigma-min( Zl ), *> *> where sigma-min(Zl) denotes the smallest singular value of the *> 2(n-1)-by-2(n-1) matrix *> *> Zl = [ kron(a, In-1) -kron(1, S22) ] *> [ kron(b, In-1) -kron(1, T22) ] . *> *> Here In-1 is the identity matrix of size n-1. kron(X, Y) is the *> Kronecker product between the matrices X and Y. *> *> Note that if the default method for computing DIF(i) is wanted *> (see DLATDF), then the parameter DIFDRI (see below) should be *> changed from 3 to 4 (routine DLATDF(IJOB = 2 will be used)). *> See DTGSYL for more details. *> *> b) If the i-th and (i+1)-th eigenvalues are complex conjugate pair, *> *> Suppose U and V are orthogonal transformations such that *> *> U**T*(A, B)*V = (S, T) = ( S11 * ) ( T11 * ) 2 *> ( 0 S22 ),( 0 T22) n-2 *> 2 n-2 2 n-2 *> *> and (S11, T11) corresponds to the complex conjugate eigenvalue *> pair (w, conjg(w)). There exist unitary matrices U1 and V1 such *> that *> *> U1**T*S11*V1 = ( s11 s12 ) and U1**T*T11*V1 = ( t11 t12 ) *> ( 0 s22 ) ( 0 t22 ) *> *> where the generalized eigenvalues w = s11/t11 and *> conjg(w) = s22/t22. *> *> Then the reciprocal condition number DIF(i) is bounded by *> *> min( d1, max( 1, |real(s11)/real(s22)| )*d2 ) *> *> where, d1 = Difl((s11, t11), (s22, t22)) = sigma-min(Z1), where *> Z1 is the complex 2-by-2 matrix *> *> Z1 = [ s11 -s22 ] *> [ t11 -t22 ], *> *> This is done by computing (using real arithmetic) the *> roots of the characteristical polynomial det(Z1**T * Z1 - lambda I), *> where Z1**T denotes the transpose of Z1 and det(X) denotes *> the determinant of X. *> *> and d2 is an upper bound on Difl((S11, T11), (S22, T22)), i.e. an *> upper bound on sigma-min(Z2), where Z2 is (2n-2)-by-(2n-2) *> *> Z2 = [ kron(S11**T, In-2) -kron(I2, S22) ] *> [ kron(T11**T, In-2) -kron(I2, T22) ] *> *> Note that if the default method for computing DIF is wanted (see *> DLATDF), then the parameter DIFDRI (see below) should be changed *> from 3 to 4 (routine DLATDF(IJOB = 2 will be used)). See DTGSYL *> for more details. *> *> For each eigenvalue/vector specified by SELECT, DIF stores a *> Frobenius norm-based estimate of Difl. *> *> An approximate error bound for the i-th computed eigenvector VL(i) or *> VR(i) is given by *> *> EPS * norm(A, B) / DIF(i). *> *> See ref. [2-3] for more details and further references. *> \endverbatim * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * *> \par References: * ================ *> *> \verbatim *> *> [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the *> Generalized Real Schur Form of a Regular Matrix Pair (A, B), in *> M.S. Moonen et al (eds), Linear Algebra for Large Scale and *> Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. *> *> [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified *> Eigenvalues of a Regular Matrix Pair (A, B) and Condition *> Estimation: Theory, Algorithms and Software, *> Report UMINF - 94.04, Department of Computing Science, Umea *> University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working *> Note 87. To appear in Numerical Algorithms, 1996. *> *> [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software *> for Solving the Generalized Sylvester Equation and Estimating the *> Separation between Regular Matrix Pairs, Report UMINF - 93.23, *> Department of Computing Science, Umea University, S-901 87 Umea, *> Sweden, December 1993, Revised April 1994, Also as LAPACK Working *> Note 75. To appear in ACM Trans. on Math. Software, Vol 22, *> No 1, 1996. *> \endverbatim *> * ===================================================================== SUBROUTINE DTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, $ LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, $ IWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER HOWMNY, JOB INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, M, MM, N * .. * .. Array Arguments .. LOGICAL SELECT( * ) INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DIF( * ), S( * ), $ VL( LDVL, * ), VR( LDVR, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. INTEGER DIFDRI PARAMETER ( DIFDRI = 3 ) DOUBLE PRECISION ZERO, ONE, TWO, FOUR PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, $ FOUR = 4.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, PAIR, SOMCON, WANTBH, WANTDF, WANTS INTEGER I, IERR, IFST, ILST, IZ, K, KS, LWMIN, N1, N2 DOUBLE PRECISION ALPHAI, ALPHAR, ALPRQT, BETA, C1, C2, COND, $ EPS, LNRM, RNRM, ROOT1, ROOT2, SCALE, SMLNUM, $ TMPII, TMPIR, TMPRI, TMPRR, UHAV, UHAVI, UHBV, $ UHBVI * .. * .. Local Arrays .. DOUBLE PRECISION DUMMY( 1 ), DUMMY1( 1 ) * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT, DLAMCH, DLAPY2, DNRM2 EXTERNAL LSAME, DDOT, DLAMCH, DLAPY2, DNRM2 * .. * .. External Subroutines .. EXTERNAL DGEMV, DLACPY, DLAG2, DTGEXC, DTGSYL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT * .. * .. Executable Statements .. * * Decode and test the input parameters * WANTBH = LSAME( JOB, 'B' ) WANTS = LSAME( JOB, 'E' ) .OR. WANTBH WANTDF = LSAME( JOB, 'V' ) .OR. WANTBH * SOMCON = LSAME( HOWMNY, 'S' ) * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) * IF( .NOT.WANTS .AND. .NOT.WANTDF ) THEN INFO = -1 ELSE IF( .NOT.LSAME( HOWMNY, 'A' ) .AND. .NOT.SOMCON ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( WANTS .AND. LDVL.LT.N ) THEN INFO = -10 ELSE IF( WANTS .AND. LDVR.LT.N ) THEN INFO = -12 ELSE * * Set M to the number of eigenpairs for which condition numbers * are required, and test MM. * IF( SOMCON ) THEN M = 0 PAIR = .FALSE. DO 10 K = 1, N IF( PAIR ) THEN PAIR = .FALSE. ELSE IF( K.LT.N ) THEN IF( A( K+1, K ).EQ.ZERO ) THEN IF( SELECT( K ) ) $ M = M + 1 ELSE PAIR = .TRUE. IF( SELECT( K ) .OR. SELECT( K+1 ) ) $ M = M + 2 END IF ELSE IF( SELECT( N ) ) $ M = M + 1 END IF END IF 10 CONTINUE ELSE M = N END IF * IF( N.EQ.0 ) THEN LWMIN = 1 ELSE IF( LSAME( JOB, 'V' ) .OR. LSAME( JOB, 'B' ) ) THEN LWMIN = 2*N*( N + 2 ) + 16 ELSE LWMIN = N END IF WORK( 1 ) = LWMIN * IF( MM.LT.M ) THEN INFO = -15 ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN INFO = -18 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTGSNA', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Get machine constants * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) / EPS KS = 0 PAIR = .FALSE. * DO 20 K = 1, N * * Determine whether A(k,k) begins a 1-by-1 or 2-by-2 block. * IF( PAIR ) THEN PAIR = .FALSE. GO TO 20 ELSE IF( K.LT.N ) $ PAIR = A( K+1, K ).NE.ZERO END IF * * Determine whether condition numbers are required for the k-th * eigenpair. * IF( SOMCON ) THEN IF( PAIR ) THEN IF( .NOT.SELECT( K ) .AND. .NOT.SELECT( K+1 ) ) $ GO TO 20 ELSE IF( .NOT.SELECT( K ) ) $ GO TO 20 END IF END IF * KS = KS + 1 * IF( WANTS ) THEN * * Compute the reciprocal condition number of the k-th * eigenvalue. * IF( PAIR ) THEN * * Complex eigenvalue pair. * RNRM = DLAPY2( DNRM2( N, VR( 1, KS ), 1 ), $ DNRM2( N, VR( 1, KS+1 ), 1 ) ) LNRM = DLAPY2( DNRM2( N, VL( 1, KS ), 1 ), $ DNRM2( N, VL( 1, KS+1 ), 1 ) ) CALL DGEMV( 'N', N, N, ONE, A, LDA, VR( 1, KS ), 1, ZERO, $ WORK, 1 ) TMPRR = DDOT( N, WORK, 1, VL( 1, KS ), 1 ) TMPRI = DDOT( N, WORK, 1, VL( 1, KS+1 ), 1 ) CALL DGEMV( 'N', N, N, ONE, A, LDA, VR( 1, KS+1 ), 1, $ ZERO, WORK, 1 ) TMPII = DDOT( N, WORK, 1, VL( 1, KS+1 ), 1 ) TMPIR = DDOT( N, WORK, 1, VL( 1, KS ), 1 ) UHAV = TMPRR + TMPII UHAVI = TMPIR - TMPRI CALL DGEMV( 'N', N, N, ONE, B, LDB, VR( 1, KS ), 1, ZERO, $ WORK, 1 ) TMPRR = DDOT( N, WORK, 1, VL( 1, KS ), 1 ) TMPRI = DDOT( N, WORK, 1, VL( 1, KS+1 ), 1 ) CALL DGEMV( 'N', N, N, ONE, B, LDB, VR( 1, KS+1 ), 1, $ ZERO, WORK, 1 ) TMPII = DDOT( N, WORK, 1, VL( 1, KS+1 ), 1 ) TMPIR = DDOT( N, WORK, 1, VL( 1, KS ), 1 ) UHBV = TMPRR + TMPII UHBVI = TMPIR - TMPRI UHAV = DLAPY2( UHAV, UHAVI ) UHBV = DLAPY2( UHBV, UHBVI ) COND = DLAPY2( UHAV, UHBV ) S( KS ) = COND / ( RNRM*LNRM ) S( KS+1 ) = S( KS ) * ELSE * * Real eigenvalue. * RNRM = DNRM2( N, VR( 1, KS ), 1 ) LNRM = DNRM2( N, VL( 1, KS ), 1 ) CALL DGEMV( 'N', N, N, ONE, A, LDA, VR( 1, KS ), 1, ZERO, $ WORK, 1 ) UHAV = DDOT( N, WORK, 1, VL( 1, KS ), 1 ) CALL DGEMV( 'N', N, N, ONE, B, LDB, VR( 1, KS ), 1, ZERO, $ WORK, 1 ) UHBV = DDOT( N, WORK, 1, VL( 1, KS ), 1 ) COND = DLAPY2( UHAV, UHBV ) IF( COND.EQ.ZERO ) THEN S( KS ) = -ONE ELSE S( KS ) = COND / ( RNRM*LNRM ) END IF END IF END IF * IF( WANTDF ) THEN IF( N.EQ.1 ) THEN DIF( KS ) = DLAPY2( A( 1, 1 ), B( 1, 1 ) ) GO TO 20 END IF * * Estimate the reciprocal condition number of the k-th * eigenvectors. IF( PAIR ) THEN * * Copy the 2-by 2 pencil beginning at (A(k,k), B(k, k)). * Compute the eigenvalue(s) at position K. * WORK( 1 ) = A( K, K ) WORK( 2 ) = A( K+1, K ) WORK( 3 ) = A( K, K+1 ) WORK( 4 ) = A( K+1, K+1 ) WORK( 5 ) = B( K, K ) WORK( 6 ) = B( K+1, K ) WORK( 7 ) = B( K, K+1 ) WORK( 8 ) = B( K+1, K+1 ) CALL DLAG2( WORK, 2, WORK( 5 ), 2, SMLNUM*EPS, BETA, $ DUMMY1( 1 ), ALPHAR, DUMMY( 1 ), ALPHAI ) ALPRQT = ONE C1 = TWO*( ALPHAR*ALPHAR+ALPHAI*ALPHAI+BETA*BETA ) C2 = FOUR*BETA*BETA*ALPHAI*ALPHAI ROOT1 = C1 + SQRT( C1*C1-4.0D0*C2 ) ROOT2 = C2 / ROOT1 ROOT1 = ROOT1 / TWO COND = MIN( SQRT( ROOT1 ), SQRT( ROOT2 ) ) END IF * * Copy the matrix (A, B) to the array WORK and swap the * diagonal block beginning at A(k,k) to the (1,1) position. * CALL DLACPY( 'Full', N, N, A, LDA, WORK, N ) CALL DLACPY( 'Full', N, N, B, LDB, WORK( N*N+1 ), N ) IFST = K ILST = 1 * CALL DTGEXC( .FALSE., .FALSE., N, WORK, N, WORK( N*N+1 ), N, $ DUMMY, 1, DUMMY1, 1, IFST, ILST, $ WORK( N*N*2+1 ), LWORK-2*N*N, IERR ) * IF( IERR.GT.0 ) THEN * * Ill-conditioned problem - swap rejected. * DIF( KS ) = ZERO ELSE * * Reordering successful, solve generalized Sylvester * equation for R and L, * A22 * R - L * A11 = A12 * B22 * R - L * B11 = B12, * and compute estimate of Difl((A11,B11), (A22, B22)). * N1 = 1 IF( WORK( 2 ).NE.ZERO ) $ N1 = 2 N2 = N - N1 IF( N2.EQ.0 ) THEN DIF( KS ) = COND ELSE I = N*N + 1 IZ = 2*N*N + 1 CALL DTGSYL( 'N', DIFDRI, N2, N1, WORK( N*N1+N1+1 ), $ N, WORK, N, WORK( N1+1 ), N, $ WORK( N*N1+N1+I ), N, WORK( I ), N, $ WORK( N1+I ), N, SCALE, DIF( KS ), $ WORK( IZ+1 ), LWORK-2*N*N, IWORK, IERR ) * IF( PAIR ) $ DIF( KS ) = MIN( MAX( ONE, ALPRQT )*DIF( KS ), $ COND ) END IF END IF IF( PAIR ) $ DIF( KS+1 ) = DIF( KS ) END IF IF( PAIR ) $ KS = KS + 1 * 20 CONTINUE WORK( 1 ) = LWMIN RETURN * * End of DTGSNA * END *> \brief \b DTGSY2 solves the generalized Sylvester equation (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTGSY2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, * LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, * IWORK, PQ, INFO ) * * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N, * $ PQ * DOUBLE PRECISION RDSCAL, RDSUM, SCALE * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), * $ D( LDD, * ), E( LDE, * ), F( LDF, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTGSY2 solves the generalized Sylvester equation: *> *> A * R - L * B = scale * C (1) *> D * R - L * E = scale * F, *> *> using Level 1 and 2 BLAS. where R and L are unknown M-by-N matrices, *> (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M, *> N-by-N and M-by-N, respectively, with real entries. (A, D) and (B, E) *> must be in generalized Schur canonical form, i.e. A, B are upper *> quasi triangular and D, E are upper triangular. The solution (R, L) *> overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor *> chosen to avoid overflow. *> *> In matrix notation solving equation (1) corresponds to solve *> Z*x = scale*b, where Z is defined as *> *> Z = [ kron(In, A) -kron(B**T, Im) ] (2) *> [ kron(In, D) -kron(E**T, Im) ], *> *> Ik is the identity matrix of size k and X**T is the transpose of X. *> kron(X, Y) is the Kronecker product between the matrices X and Y. *> In the process of solving (1), we solve a number of such systems *> where Dim(In), Dim(In) = 1 or 2. *> *> If TRANS = 'T', solve the transposed system Z**T*y = scale*b for y, *> which is equivalent to solve for R and L in *> *> A**T * R + D**T * L = scale * C (3) *> R * B**T + L * E**T = scale * -F *> *> This case is used to compute an estimate of Dif[(A, D), (B, E)] = *> sigma_min(Z) using reverse communicaton with DLACON. *> *> DTGSY2 also (IJOB >= 1) contributes to the computation in DTGSYL *> of an upper bound on the separation between to matrix pairs. Then *> the input (A, D), (B, E) are sub-pencils of the matrix pair in *> DTGSYL. See DTGSYL for details. *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N', solve the generalized Sylvester equation (1). *> = 'T': solve the 'transposed' system (3). *> \endverbatim *> *> \param[in] IJOB *> \verbatim *> IJOB is INTEGER *> Specifies what kind of functionality to be performed. *> = 0: solve (1) only. *> = 1: A contribution from this subsystem to a Frobenius *> norm-based estimate of the separation between two matrix *> pairs is computed. (look ahead strategy is used). *> = 2: A contribution from this subsystem to a Frobenius *> norm-based estimate of the separation between two matrix *> pairs is computed. (DGECON on sub-systems is used.) *> Not referenced if TRANS = 'T'. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> On entry, M specifies the order of A and D, and the row *> dimension of C, F, R and L. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> On entry, N specifies the order of B and E, and the column *> dimension of C, F, R and L. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA, M) *> On entry, A contains an upper quasi triangular matrix. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the matrix A. LDA >= max(1, M). *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB, N) *> On entry, B contains an upper quasi triangular matrix. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the matrix B. LDB >= max(1, N). *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (LDC, N) *> On entry, C contains the right-hand-side of the first matrix *> equation in (1). *> On exit, if IJOB = 0, C has been overwritten by the *> solution R. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the matrix C. LDC >= max(1, M). *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (LDD, M) *> On entry, D contains an upper triangular matrix. *> \endverbatim *> *> \param[in] LDD *> \verbatim *> LDD is INTEGER *> The leading dimension of the matrix D. LDD >= max(1, M). *> \endverbatim *> *> \param[in] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (LDE, N) *> On entry, E contains an upper triangular matrix. *> \endverbatim *> *> \param[in] LDE *> \verbatim *> LDE is INTEGER *> The leading dimension of the matrix E. LDE >= max(1, N). *> \endverbatim *> *> \param[in,out] F *> \verbatim *> F is DOUBLE PRECISION array, dimension (LDF, N) *> On entry, F contains the right-hand-side of the second matrix *> equation in (1). *> On exit, if IJOB = 0, F has been overwritten by the *> solution L. *> \endverbatim *> *> \param[in] LDF *> \verbatim *> LDF is INTEGER *> The leading dimension of the matrix F. LDF >= max(1, M). *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is DOUBLE PRECISION *> On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions *> R and L (C and F on entry) will hold the solutions to a *> slightly perturbed system but the input matrices A, B, D and *> E have not been changed. If SCALE = 0, R and L will hold the *> solutions to the homogeneous system with C = F = 0. Normally, *> SCALE = 1. *> \endverbatim *> *> \param[in,out] RDSUM *> \verbatim *> RDSUM is DOUBLE PRECISION *> On entry, the sum of squares of computed contributions to *> the Dif-estimate under computation by DTGSYL, where the *> scaling factor RDSCAL (see below) has been factored out. *> On exit, the corresponding sum of squares updated with the *> contributions from the current sub-system. *> If TRANS = 'T' RDSUM is not touched. *> NOTE: RDSUM only makes sense when DTGSY2 is called by DTGSYL. *> \endverbatim *> *> \param[in,out] RDSCAL *> \verbatim *> RDSCAL is DOUBLE PRECISION *> On entry, scaling factor used to prevent overflow in RDSUM. *> On exit, RDSCAL is updated w.r.t. the current contributions *> in RDSUM. *> If TRANS = 'T', RDSCAL is not touched. *> NOTE: RDSCAL only makes sense when DTGSY2 is called by *> DTGSYL. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (M+N+2) *> \endverbatim *> *> \param[out] PQ *> \verbatim *> PQ is INTEGER *> On exit, the number of subsystems (of size 2-by-2, 4-by-4 and *> 8-by-8) solved by this routine. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> On exit, if INFO is set to *> =0: Successful exit *> <0: If INFO = -i, the i-th argument had an illegal value. *> >0: The matrix pairs (A, D) and (B, E) have common or very *> close eigenvalues. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleSYauxiliary * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * * ===================================================================== SUBROUTINE DTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, $ LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, $ IWORK, PQ, INFO ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER TRANS INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N, $ PQ DOUBLE PRECISION RDSCAL, RDSUM, SCALE * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), $ D( LDD, * ), E( LDE, * ), F( LDF, * ) * .. * * ===================================================================== * Replaced various illegal calls to DCOPY by calls to DLASET. * Sven Hammarling, 27/5/02. * * .. Parameters .. INTEGER LDZ PARAMETER ( LDZ = 8 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOTRAN INTEGER I, IE, IERR, II, IS, ISP1, J, JE, JJ, JS, JSP1, $ K, MB, NB, P, Q, ZDIM DOUBLE PRECISION ALPHA, SCALOC * .. * .. Local Arrays .. INTEGER IPIV( LDZ ), JPIV( LDZ ) DOUBLE PRECISION RHS( LDZ ), Z( LDZ, LDZ ) * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DGER, DGESC2, $ DGETC2, DLASET, DLATDF, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Decode and test input parameters * INFO = 0 IERR = 0 NOTRAN = LSAME( TRANS, 'N' ) IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN INFO = -1 ELSE IF( NOTRAN ) THEN IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.2 ) ) THEN INFO = -2 END IF END IF IF( INFO.EQ.0 ) THEN IF( M.LE.0 ) THEN INFO = -3 ELSE IF( N.LE.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LDD.LT.MAX( 1, M ) ) THEN INFO = -12 ELSE IF( LDE.LT.MAX( 1, N ) ) THEN INFO = -14 ELSE IF( LDF.LT.MAX( 1, M ) ) THEN INFO = -16 END IF END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTGSY2', -INFO ) RETURN END IF * * Determine block structure of A * PQ = 0 P = 0 I = 1 10 CONTINUE IF( I.GT.M ) $ GO TO 20 P = P + 1 IWORK( P ) = I IF( I.EQ.M ) $ GO TO 20 IF( A( I+1, I ).NE.ZERO ) THEN I = I + 2 ELSE I = I + 1 END IF GO TO 10 20 CONTINUE IWORK( P+1 ) = M + 1 * * Determine block structure of B * Q = P + 1 J = 1 30 CONTINUE IF( J.GT.N ) $ GO TO 40 Q = Q + 1 IWORK( Q ) = J IF( J.EQ.N ) $ GO TO 40 IF( B( J+1, J ).NE.ZERO ) THEN J = J + 2 ELSE J = J + 1 END IF GO TO 30 40 CONTINUE IWORK( Q+1 ) = N + 1 PQ = P*( Q-P-1 ) * IF( NOTRAN ) THEN * * Solve (I, J) - subsystem * A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) * D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) * for I = P, P - 1, ..., 1; J = 1, 2, ..., Q * SCALE = ONE SCALOC = ONE DO 120 J = P + 2, Q JS = IWORK( J ) JSP1 = JS + 1 JE = IWORK( J+1 ) - 1 NB = JE - JS + 1 DO 110 I = P, 1, -1 * IS = IWORK( I ) ISP1 = IS + 1 IE = IWORK( I+1 ) - 1 MB = IE - IS + 1 ZDIM = MB*NB*2 * IF( ( MB.EQ.1 ) .AND. ( NB.EQ.1 ) ) THEN * * Build a 2-by-2 system Z * x = RHS * Z( 1, 1 ) = A( IS, IS ) Z( 2, 1 ) = D( IS, IS ) Z( 1, 2 ) = -B( JS, JS ) Z( 2, 2 ) = -E( JS, JS ) * * Set up right hand side(s) * RHS( 1 ) = C( IS, JS ) RHS( 2 ) = F( IS, JS ) * * Solve Z * x = RHS * CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) IF( IERR.GT.0 ) $ INFO = IERR * IF( IJOB.EQ.0 ) THEN CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, $ SCALOC ) IF( SCALOC.NE.ONE ) THEN DO 50 K = 1, N CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) 50 CONTINUE SCALE = SCALE*SCALOC END IF ELSE CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM, $ RDSCAL, IPIV, JPIV ) END IF * * Unpack solution vector(s) * C( IS, JS ) = RHS( 1 ) F( IS, JS ) = RHS( 2 ) * * Substitute R(I, J) and L(I, J) into remaining * equation. * IF( I.GT.1 ) THEN ALPHA = -RHS( 1 ) CALL DAXPY( IS-1, ALPHA, A( 1, IS ), 1, C( 1, JS ), $ 1 ) CALL DAXPY( IS-1, ALPHA, D( 1, IS ), 1, F( 1, JS ), $ 1 ) END IF IF( J.LT.Q ) THEN CALL DAXPY( N-JE, RHS( 2 ), B( JS, JE+1 ), LDB, $ C( IS, JE+1 ), LDC ) CALL DAXPY( N-JE, RHS( 2 ), E( JS, JE+1 ), LDE, $ F( IS, JE+1 ), LDF ) END IF * ELSE IF( ( MB.EQ.1 ) .AND. ( NB.EQ.2 ) ) THEN * * Build a 4-by-4 system Z * x = RHS * Z( 1, 1 ) = A( IS, IS ) Z( 2, 1 ) = ZERO Z( 3, 1 ) = D( IS, IS ) Z( 4, 1 ) = ZERO * Z( 1, 2 ) = ZERO Z( 2, 2 ) = A( IS, IS ) Z( 3, 2 ) = ZERO Z( 4, 2 ) = D( IS, IS ) * Z( 1, 3 ) = -B( JS, JS ) Z( 2, 3 ) = -B( JS, JSP1 ) Z( 3, 3 ) = -E( JS, JS ) Z( 4, 3 ) = -E( JS, JSP1 ) * Z( 1, 4 ) = -B( JSP1, JS ) Z( 2, 4 ) = -B( JSP1, JSP1 ) Z( 3, 4 ) = ZERO Z( 4, 4 ) = -E( JSP1, JSP1 ) * * Set up right hand side(s) * RHS( 1 ) = C( IS, JS ) RHS( 2 ) = C( IS, JSP1 ) RHS( 3 ) = F( IS, JS ) RHS( 4 ) = F( IS, JSP1 ) * * Solve Z * x = RHS * CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) IF( IERR.GT.0 ) $ INFO = IERR * IF( IJOB.EQ.0 ) THEN CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, $ SCALOC ) IF( SCALOC.NE.ONE ) THEN DO 60 K = 1, N CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) 60 CONTINUE SCALE = SCALE*SCALOC END IF ELSE CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM, $ RDSCAL, IPIV, JPIV ) END IF * * Unpack solution vector(s) * C( IS, JS ) = RHS( 1 ) C( IS, JSP1 ) = RHS( 2 ) F( IS, JS ) = RHS( 3 ) F( IS, JSP1 ) = RHS( 4 ) * * Substitute R(I, J) and L(I, J) into remaining * equation. * IF( I.GT.1 ) THEN CALL DGER( IS-1, NB, -ONE, A( 1, IS ), 1, RHS( 1 ), $ 1, C( 1, JS ), LDC ) CALL DGER( IS-1, NB, -ONE, D( 1, IS ), 1, RHS( 1 ), $ 1, F( 1, JS ), LDF ) END IF IF( J.LT.Q ) THEN CALL DAXPY( N-JE, RHS( 3 ), B( JS, JE+1 ), LDB, $ C( IS, JE+1 ), LDC ) CALL DAXPY( N-JE, RHS( 3 ), E( JS, JE+1 ), LDE, $ F( IS, JE+1 ), LDF ) CALL DAXPY( N-JE, RHS( 4 ), B( JSP1, JE+1 ), LDB, $ C( IS, JE+1 ), LDC ) CALL DAXPY( N-JE, RHS( 4 ), E( JSP1, JE+1 ), LDE, $ F( IS, JE+1 ), LDF ) END IF * ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN * * Build a 4-by-4 system Z * x = RHS * Z( 1, 1 ) = A( IS, IS ) Z( 2, 1 ) = A( ISP1, IS ) Z( 3, 1 ) = D( IS, IS ) Z( 4, 1 ) = ZERO * Z( 1, 2 ) = A( IS, ISP1 ) Z( 2, 2 ) = A( ISP1, ISP1 ) Z( 3, 2 ) = D( IS, ISP1 ) Z( 4, 2 ) = D( ISP1, ISP1 ) * Z( 1, 3 ) = -B( JS, JS ) Z( 2, 3 ) = ZERO Z( 3, 3 ) = -E( JS, JS ) Z( 4, 3 ) = ZERO * Z( 1, 4 ) = ZERO Z( 2, 4 ) = -B( JS, JS ) Z( 3, 4 ) = ZERO Z( 4, 4 ) = -E( JS, JS ) * * Set up right hand side(s) * RHS( 1 ) = C( IS, JS ) RHS( 2 ) = C( ISP1, JS ) RHS( 3 ) = F( IS, JS ) RHS( 4 ) = F( ISP1, JS ) * * Solve Z * x = RHS * CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) IF( IERR.GT.0 ) $ INFO = IERR IF( IJOB.EQ.0 ) THEN CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, $ SCALOC ) IF( SCALOC.NE.ONE ) THEN DO 70 K = 1, N CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) 70 CONTINUE SCALE = SCALE*SCALOC END IF ELSE CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM, $ RDSCAL, IPIV, JPIV ) END IF * * Unpack solution vector(s) * C( IS, JS ) = RHS( 1 ) C( ISP1, JS ) = RHS( 2 ) F( IS, JS ) = RHS( 3 ) F( ISP1, JS ) = RHS( 4 ) * * Substitute R(I, J) and L(I, J) into remaining * equation. * IF( I.GT.1 ) THEN CALL DGEMV( 'N', IS-1, MB, -ONE, A( 1, IS ), LDA, $ RHS( 1 ), 1, ONE, C( 1, JS ), 1 ) CALL DGEMV( 'N', IS-1, MB, -ONE, D( 1, IS ), LDD, $ RHS( 1 ), 1, ONE, F( 1, JS ), 1 ) END IF IF( J.LT.Q ) THEN CALL DGER( MB, N-JE, ONE, RHS( 3 ), 1, $ B( JS, JE+1 ), LDB, C( IS, JE+1 ), LDC ) CALL DGER( MB, N-JE, ONE, RHS( 3 ), 1, $ E( JS, JE+1 ), LDE, F( IS, JE+1 ), LDF ) END IF * ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.2 ) ) THEN * * Build an 8-by-8 system Z * x = RHS * CALL DLASET( 'F', LDZ, LDZ, ZERO, ZERO, Z, LDZ ) * Z( 1, 1 ) = A( IS, IS ) Z( 2, 1 ) = A( ISP1, IS ) Z( 5, 1 ) = D( IS, IS ) * Z( 1, 2 ) = A( IS, ISP1 ) Z( 2, 2 ) = A( ISP1, ISP1 ) Z( 5, 2 ) = D( IS, ISP1 ) Z( 6, 2 ) = D( ISP1, ISP1 ) * Z( 3, 3 ) = A( IS, IS ) Z( 4, 3 ) = A( ISP1, IS ) Z( 7, 3 ) = D( IS, IS ) * Z( 3, 4 ) = A( IS, ISP1 ) Z( 4, 4 ) = A( ISP1, ISP1 ) Z( 7, 4 ) = D( IS, ISP1 ) Z( 8, 4 ) = D( ISP1, ISP1 ) * Z( 1, 5 ) = -B( JS, JS ) Z( 3, 5 ) = -B( JS, JSP1 ) Z( 5, 5 ) = -E( JS, JS ) Z( 7, 5 ) = -E( JS, JSP1 ) * Z( 2, 6 ) = -B( JS, JS ) Z( 4, 6 ) = -B( JS, JSP1 ) Z( 6, 6 ) = -E( JS, JS ) Z( 8, 6 ) = -E( JS, JSP1 ) * Z( 1, 7 ) = -B( JSP1, JS ) Z( 3, 7 ) = -B( JSP1, JSP1 ) Z( 7, 7 ) = -E( JSP1, JSP1 ) * Z( 2, 8 ) = -B( JSP1, JS ) Z( 4, 8 ) = -B( JSP1, JSP1 ) Z( 8, 8 ) = -E( JSP1, JSP1 ) * * Set up right hand side(s) * K = 1 II = MB*NB + 1 DO 80 JJ = 0, NB - 1 CALL DCOPY( MB, C( IS, JS+JJ ), 1, RHS( K ), 1 ) CALL DCOPY( MB, F( IS, JS+JJ ), 1, RHS( II ), 1 ) K = K + MB II = II + MB 80 CONTINUE * * Solve Z * x = RHS * CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) IF( IERR.GT.0 ) $ INFO = IERR IF( IJOB.EQ.0 ) THEN CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, $ SCALOC ) IF( SCALOC.NE.ONE ) THEN DO 90 K = 1, N CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) 90 CONTINUE SCALE = SCALE*SCALOC END IF ELSE CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM, $ RDSCAL, IPIV, JPIV ) END IF * * Unpack solution vector(s) * K = 1 II = MB*NB + 1 DO 100 JJ = 0, NB - 1 CALL DCOPY( MB, RHS( K ), 1, C( IS, JS+JJ ), 1 ) CALL DCOPY( MB, RHS( II ), 1, F( IS, JS+JJ ), 1 ) K = K + MB II = II + MB 100 CONTINUE * * Substitute R(I, J) and L(I, J) into remaining * equation. * IF( I.GT.1 ) THEN CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE, $ A( 1, IS ), LDA, RHS( 1 ), MB, ONE, $ C( 1, JS ), LDC ) CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE, $ D( 1, IS ), LDD, RHS( 1 ), MB, ONE, $ F( 1, JS ), LDF ) END IF IF( J.LT.Q ) THEN K = MB*NB + 1 CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS( K ), $ MB, B( JS, JE+1 ), LDB, ONE, $ C( IS, JE+1 ), LDC ) CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS( K ), $ MB, E( JS, JE+1 ), LDE, ONE, $ F( IS, JE+1 ), LDF ) END IF * END IF * 110 CONTINUE 120 CONTINUE ELSE * * Solve (I, J) - subsystem * A(I, I)**T * R(I, J) + D(I, I)**T * L(J, J) = C(I, J) * R(I, I) * B(J, J) + L(I, J) * E(J, J) = -F(I, J) * for I = 1, 2, ..., P, J = Q, Q - 1, ..., 1 * SCALE = ONE SCALOC = ONE DO 200 I = 1, P * IS = IWORK( I ) ISP1 = IS + 1 IE = IWORK ( I+1 ) - 1 MB = IE - IS + 1 DO 190 J = Q, P + 2, -1 * JS = IWORK( J ) JSP1 = JS + 1 JE = IWORK( J+1 ) - 1 NB = JE - JS + 1 ZDIM = MB*NB*2 IF( ( MB.EQ.1 ) .AND. ( NB.EQ.1 ) ) THEN * * Build a 2-by-2 system Z**T * x = RHS * Z( 1, 1 ) = A( IS, IS ) Z( 2, 1 ) = -B( JS, JS ) Z( 1, 2 ) = D( IS, IS ) Z( 2, 2 ) = -E( JS, JS ) * * Set up right hand side(s) * RHS( 1 ) = C( IS, JS ) RHS( 2 ) = F( IS, JS ) * * Solve Z**T * x = RHS * CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) IF( IERR.GT.0 ) $ INFO = IERR * CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) IF( SCALOC.NE.ONE ) THEN DO 130 K = 1, N CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) 130 CONTINUE SCALE = SCALE*SCALOC END IF * * Unpack solution vector(s) * C( IS, JS ) = RHS( 1 ) F( IS, JS ) = RHS( 2 ) * * Substitute R(I, J) and L(I, J) into remaining * equation. * IF( J.GT.P+2 ) THEN ALPHA = RHS( 1 ) CALL DAXPY( JS-1, ALPHA, B( 1, JS ), 1, F( IS, 1 ), $ LDF ) ALPHA = RHS( 2 ) CALL DAXPY( JS-1, ALPHA, E( 1, JS ), 1, F( IS, 1 ), $ LDF ) END IF IF( I.LT.P ) THEN ALPHA = -RHS( 1 ) CALL DAXPY( M-IE, ALPHA, A( IS, IE+1 ), LDA, $ C( IE+1, JS ), 1 ) ALPHA = -RHS( 2 ) CALL DAXPY( M-IE, ALPHA, D( IS, IE+1 ), LDD, $ C( IE+1, JS ), 1 ) END IF * ELSE IF( ( MB.EQ.1 ) .AND. ( NB.EQ.2 ) ) THEN * * Build a 4-by-4 system Z**T * x = RHS * Z( 1, 1 ) = A( IS, IS ) Z( 2, 1 ) = ZERO Z( 3, 1 ) = -B( JS, JS ) Z( 4, 1 ) = -B( JSP1, JS ) * Z( 1, 2 ) = ZERO Z( 2, 2 ) = A( IS, IS ) Z( 3, 2 ) = -B( JS, JSP1 ) Z( 4, 2 ) = -B( JSP1, JSP1 ) * Z( 1, 3 ) = D( IS, IS ) Z( 2, 3 ) = ZERO Z( 3, 3 ) = -E( JS, JS ) Z( 4, 3 ) = ZERO * Z( 1, 4 ) = ZERO Z( 2, 4 ) = D( IS, IS ) Z( 3, 4 ) = -E( JS, JSP1 ) Z( 4, 4 ) = -E( JSP1, JSP1 ) * * Set up right hand side(s) * RHS( 1 ) = C( IS, JS ) RHS( 2 ) = C( IS, JSP1 ) RHS( 3 ) = F( IS, JS ) RHS( 4 ) = F( IS, JSP1 ) * * Solve Z**T * x = RHS * CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) IF( IERR.GT.0 ) $ INFO = IERR CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) IF( SCALOC.NE.ONE ) THEN DO 140 K = 1, N CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) 140 CONTINUE SCALE = SCALE*SCALOC END IF * * Unpack solution vector(s) * C( IS, JS ) = RHS( 1 ) C( IS, JSP1 ) = RHS( 2 ) F( IS, JS ) = RHS( 3 ) F( IS, JSP1 ) = RHS( 4 ) * * Substitute R(I, J) and L(I, J) into remaining * equation. * IF( J.GT.P+2 ) THEN CALL DAXPY( JS-1, RHS( 1 ), B( 1, JS ), 1, $ F( IS, 1 ), LDF ) CALL DAXPY( JS-1, RHS( 2 ), B( 1, JSP1 ), 1, $ F( IS, 1 ), LDF ) CALL DAXPY( JS-1, RHS( 3 ), E( 1, JS ), 1, $ F( IS, 1 ), LDF ) CALL DAXPY( JS-1, RHS( 4 ), E( 1, JSP1 ), 1, $ F( IS, 1 ), LDF ) END IF IF( I.LT.P ) THEN CALL DGER( M-IE, NB, -ONE, A( IS, IE+1 ), LDA, $ RHS( 1 ), 1, C( IE+1, JS ), LDC ) CALL DGER( M-IE, NB, -ONE, D( IS, IE+1 ), LDD, $ RHS( 3 ), 1, C( IE+1, JS ), LDC ) END IF * ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN * * Build a 4-by-4 system Z**T * x = RHS * Z( 1, 1 ) = A( IS, IS ) Z( 2, 1 ) = A( IS, ISP1 ) Z( 3, 1 ) = -B( JS, JS ) Z( 4, 1 ) = ZERO * Z( 1, 2 ) = A( ISP1, IS ) Z( 2, 2 ) = A( ISP1, ISP1 ) Z( 3, 2 ) = ZERO Z( 4, 2 ) = -B( JS, JS ) * Z( 1, 3 ) = D( IS, IS ) Z( 2, 3 ) = D( IS, ISP1 ) Z( 3, 3 ) = -E( JS, JS ) Z( 4, 3 ) = ZERO * Z( 1, 4 ) = ZERO Z( 2, 4 ) = D( ISP1, ISP1 ) Z( 3, 4 ) = ZERO Z( 4, 4 ) = -E( JS, JS ) * * Set up right hand side(s) * RHS( 1 ) = C( IS, JS ) RHS( 2 ) = C( ISP1, JS ) RHS( 3 ) = F( IS, JS ) RHS( 4 ) = F( ISP1, JS ) * * Solve Z**T * x = RHS * CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) IF( IERR.GT.0 ) $ INFO = IERR * CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) IF( SCALOC.NE.ONE ) THEN DO 150 K = 1, N CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) 150 CONTINUE SCALE = SCALE*SCALOC END IF * * Unpack solution vector(s) * C( IS, JS ) = RHS( 1 ) C( ISP1, JS ) = RHS( 2 ) F( IS, JS ) = RHS( 3 ) F( ISP1, JS ) = RHS( 4 ) * * Substitute R(I, J) and L(I, J) into remaining * equation. * IF( J.GT.P+2 ) THEN CALL DGER( MB, JS-1, ONE, RHS( 1 ), 1, B( 1, JS ), $ 1, F( IS, 1 ), LDF ) CALL DGER( MB, JS-1, ONE, RHS( 3 ), 1, E( 1, JS ), $ 1, F( IS, 1 ), LDF ) END IF IF( I.LT.P ) THEN CALL DGEMV( 'T', MB, M-IE, -ONE, A( IS, IE+1 ), $ LDA, RHS( 1 ), 1, ONE, C( IE+1, JS ), $ 1 ) CALL DGEMV( 'T', MB, M-IE, -ONE, D( IS, IE+1 ), $ LDD, RHS( 3 ), 1, ONE, C( IE+1, JS ), $ 1 ) END IF * ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.2 ) ) THEN * * Build an 8-by-8 system Z**T * x = RHS * CALL DLASET( 'F', LDZ, LDZ, ZERO, ZERO, Z, LDZ ) * Z( 1, 1 ) = A( IS, IS ) Z( 2, 1 ) = A( IS, ISP1 ) Z( 5, 1 ) = -B( JS, JS ) Z( 7, 1 ) = -B( JSP1, JS ) * Z( 1, 2 ) = A( ISP1, IS ) Z( 2, 2 ) = A( ISP1, ISP1 ) Z( 6, 2 ) = -B( JS, JS ) Z( 8, 2 ) = -B( JSP1, JS ) * Z( 3, 3 ) = A( IS, IS ) Z( 4, 3 ) = A( IS, ISP1 ) Z( 5, 3 ) = -B( JS, JSP1 ) Z( 7, 3 ) = -B( JSP1, JSP1 ) * Z( 3, 4 ) = A( ISP1, IS ) Z( 4, 4 ) = A( ISP1, ISP1 ) Z( 6, 4 ) = -B( JS, JSP1 ) Z( 8, 4 ) = -B( JSP1, JSP1 ) * Z( 1, 5 ) = D( IS, IS ) Z( 2, 5 ) = D( IS, ISP1 ) Z( 5, 5 ) = -E( JS, JS ) * Z( 2, 6 ) = D( ISP1, ISP1 ) Z( 6, 6 ) = -E( JS, JS ) * Z( 3, 7 ) = D( IS, IS ) Z( 4, 7 ) = D( IS, ISP1 ) Z( 5, 7 ) = -E( JS, JSP1 ) Z( 7, 7 ) = -E( JSP1, JSP1 ) * Z( 4, 8 ) = D( ISP1, ISP1 ) Z( 6, 8 ) = -E( JS, JSP1 ) Z( 8, 8 ) = -E( JSP1, JSP1 ) * * Set up right hand side(s) * K = 1 II = MB*NB + 1 DO 160 JJ = 0, NB - 1 CALL DCOPY( MB, C( IS, JS+JJ ), 1, RHS( K ), 1 ) CALL DCOPY( MB, F( IS, JS+JJ ), 1, RHS( II ), 1 ) K = K + MB II = II + MB 160 CONTINUE * * * Solve Z**T * x = RHS * CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) IF( IERR.GT.0 ) $ INFO = IERR * CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) IF( SCALOC.NE.ONE ) THEN DO 170 K = 1, N CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) 170 CONTINUE SCALE = SCALE*SCALOC END IF * * Unpack solution vector(s) * K = 1 II = MB*NB + 1 DO 180 JJ = 0, NB - 1 CALL DCOPY( MB, RHS( K ), 1, C( IS, JS+JJ ), 1 ) CALL DCOPY( MB, RHS( II ), 1, F( IS, JS+JJ ), 1 ) K = K + MB II = II + MB 180 CONTINUE * * Substitute R(I, J) and L(I, J) into remaining * equation. * IF( J.GT.P+2 ) THEN CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE, $ C( IS, JS ), LDC, B( 1, JS ), LDB, ONE, $ F( IS, 1 ), LDF ) CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE, $ F( IS, JS ), LDF, E( 1, JS ), LDE, ONE, $ F( IS, 1 ), LDF ) END IF IF( I.LT.P ) THEN CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE, $ A( IS, IE+1 ), LDA, C( IS, JS ), LDC, $ ONE, C( IE+1, JS ), LDC ) CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE, $ D( IS, IE+1 ), LDD, F( IS, JS ), LDF, $ ONE, C( IE+1, JS ), LDC ) END IF * END IF * 190 CONTINUE 200 CONTINUE * END IF RETURN * * End of DTGSY2 * END *> \brief \b DTGSYL * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTGSYL + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, * LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, * IWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER TRANS * INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, * $ LWORK, M, N * DOUBLE PRECISION DIF, SCALE * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), * $ D( LDD, * ), E( LDE, * ), F( LDF, * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTGSYL solves the generalized Sylvester equation: *> *> A * R - L * B = scale * C (1) *> D * R - L * E = scale * F *> *> where R and L are unknown m-by-n matrices, (A, D), (B, E) and *> (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n, *> respectively, with real entries. (A, D) and (B, E) must be in *> generalized (real) Schur canonical form, i.e. A, B are upper quasi *> triangular and D, E are upper triangular. *> *> The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output *> scaling factor chosen to avoid overflow. *> *> In matrix notation (1) is equivalent to solve Zx = scale b, where *> Z is defined as *> *> Z = [ kron(In, A) -kron(B**T, Im) ] (2) *> [ kron(In, D) -kron(E**T, Im) ]. *> *> Here Ik is the identity matrix of size k and X**T is the transpose of *> X. kron(X, Y) is the Kronecker product between the matrices X and Y. *> *> If TRANS = 'T', DTGSYL solves the transposed system Z**T*y = scale*b, *> which is equivalent to solve for R and L in *> *> A**T * R + D**T * L = scale * C (3) *> R * B**T + L * E**T = scale * -F *> *> This case (TRANS = 'T') is used to compute an one-norm-based estimate *> of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D) *> and (B,E), using DLACON. *> *> If IJOB >= 1, DTGSYL computes a Frobenius norm-based estimate *> of Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the *> reciprocal of the smallest singular value of Z. See [1-2] for more *> information. *> *> This is a level 3 BLAS algorithm. *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N', solve the generalized Sylvester equation (1). *> = 'T', solve the 'transposed' system (3). *> \endverbatim *> *> \param[in] IJOB *> \verbatim *> IJOB is INTEGER *> Specifies what kind of functionality to be performed. *> =0: solve (1) only. *> =1: The functionality of 0 and 3. *> =2: The functionality of 0 and 4. *> =3: Only an estimate of Dif[(A,D), (B,E)] is computed. *> (look ahead strategy IJOB = 1 is used). *> =4: Only an estimate of Dif[(A,D), (B,E)] is computed. *> ( DGECON on sub-systems is used ). *> Not referenced if TRANS = 'T'. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The order of the matrices A and D, and the row dimension of *> the matrices C, F, R and L. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices B and E, and the column dimension *> of the matrices C, F, R and L. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA, M) *> The upper quasi triangular matrix A. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1, M). *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB, N) *> The upper quasi triangular matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1, N). *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (LDC, N) *> On entry, C contains the right-hand-side of the first matrix *> equation in (1) or (3). *> On exit, if IJOB = 0, 1 or 2, C has been overwritten by *> the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R, *> the solution achieved during the computation of the *> Dif-estimate. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDC >= max(1, M). *> \endverbatim *> *> \param[in] D *> \verbatim *> D is DOUBLE PRECISION array, dimension (LDD, M) *> The upper triangular matrix D. *> \endverbatim *> *> \param[in] LDD *> \verbatim *> LDD is INTEGER *> The leading dimension of the array D. LDD >= max(1, M). *> \endverbatim *> *> \param[in] E *> \verbatim *> E is DOUBLE PRECISION array, dimension (LDE, N) *> The upper triangular matrix E. *> \endverbatim *> *> \param[in] LDE *> \verbatim *> LDE is INTEGER *> The leading dimension of the array E. LDE >= max(1, N). *> \endverbatim *> *> \param[in,out] F *> \verbatim *> F is DOUBLE PRECISION array, dimension (LDF, N) *> On entry, F contains the right-hand-side of the second matrix *> equation in (1) or (3). *> On exit, if IJOB = 0, 1 or 2, F has been overwritten by *> the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L, *> the solution achieved during the computation of the *> Dif-estimate. *> \endverbatim *> *> \param[in] LDF *> \verbatim *> LDF is INTEGER *> The leading dimension of the array F. LDF >= max(1, M). *> \endverbatim *> *> \param[out] DIF *> \verbatim *> DIF is DOUBLE PRECISION *> On exit DIF is the reciprocal of a lower bound of the *> reciprocal of the Dif-function, i.e. DIF is an upper bound of *> Dif[(A,D), (B,E)] = sigma_min(Z), where Z as in (2). *> IF IJOB = 0 or TRANS = 'T', DIF is not touched. *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is DOUBLE PRECISION *> On exit SCALE is the scaling factor in (1) or (3). *> If 0 < SCALE < 1, C and F hold the solutions R and L, resp., *> to a slightly perturbed system but the input matrices A, B, D *> and E have not been changed. If SCALE = 0, C and F hold the *> solutions R and L, respectively, to the homogeneous system *> with C = F = 0. Normally, SCALE = 1. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK > = 1. *> If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*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. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (M+N+6) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> =0: successful exit *> <0: If INFO = -i, the i-th argument had an illegal value. *> >0: (A, D) and (B, E) have common or close eigenvalues. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleSYcomputational * *> \par Contributors: * ================== *> *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, *> Umea University, S-901 87 Umea, Sweden. * *> \par References: * ================ *> *> \verbatim *> *> [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software *> for Solving the Generalized Sylvester Equation and Estimating the *> Separation between Regular Matrix Pairs, Report UMINF - 93.23, *> Department of Computing Science, Umea University, S-901 87 Umea, *> Sweden, December 1993, Revised April 1994, Also as LAPACK Working *> Note 75. To appear in ACM Trans. on Math. Software, Vol 22, *> No 1, 1996. *> *> [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester *> Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal. *> Appl., 15(4):1045-1060, 1994 *> *> [3] B. Kagstrom and L. Westin, Generalized Schur Methods with *> Condition Estimators for Solving the Generalized Sylvester *> Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7, *> July 1989, pp 745-751. *> \endverbatim *> * ===================================================================== SUBROUTINE DTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, $ LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, $ IWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER TRANS INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, $ LWORK, M, N DOUBLE PRECISION DIF, SCALE * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), $ D( LDD, * ), E( LDE, * ), F( LDF, * ), $ WORK( * ) * .. * * ===================================================================== * Replaced various illegal calls to DCOPY by calls to DLASET. * Sven Hammarling, 1/5/02. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, NOTRAN INTEGER I, IE, IFUNC, IROUND, IS, ISOLVE, J, JE, JS, K, $ LINFO, LWMIN, MB, NB, P, PPQQ, PQ, Q DOUBLE PRECISION DSCALE, DSUM, SCALE2, SCALOC * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DGEMM, DLACPY, DLASET, DSCAL, DTGSY2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MAX, SQRT * .. * .. Executable Statements .. * * Decode and test input parameters * INFO = 0 NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN INFO = -1 ELSE IF( NOTRAN ) THEN IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.4 ) ) THEN INFO = -2 END IF END IF IF( INFO.EQ.0 ) THEN IF( M.LE.0 ) THEN INFO = -3 ELSE IF( N.LE.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LDD.LT.MAX( 1, M ) ) THEN INFO = -12 ELSE IF( LDE.LT.MAX( 1, N ) ) THEN INFO = -14 ELSE IF( LDF.LT.MAX( 1, M ) ) THEN INFO = -16 END IF END IF * IF( INFO.EQ.0 ) THEN IF( NOTRAN ) THEN IF( IJOB.EQ.1 .OR. IJOB.EQ.2 ) THEN LWMIN = MAX( 1, 2*M*N ) ELSE LWMIN = 1 END IF ELSE LWMIN = 1 END IF WORK( 1 ) = LWMIN * IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN INFO = -20 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTGSYL', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) THEN SCALE = 1 IF( NOTRAN ) THEN IF( IJOB.NE.0 ) THEN DIF = 0 END IF END IF RETURN END IF * * Determine optimal block sizes MB and NB * MB = ILAENV( 2, 'DTGSYL', TRANS, M, N, -1, -1 ) NB = ILAENV( 5, 'DTGSYL', TRANS, M, N, -1, -1 ) * ISOLVE = 1 IFUNC = 0 IF( NOTRAN ) THEN IF( IJOB.GE.3 ) THEN IFUNC = IJOB - 2 CALL DLASET( 'F', M, N, ZERO, ZERO, C, LDC ) CALL DLASET( 'F', M, N, ZERO, ZERO, F, LDF ) ELSE IF( IJOB.GE.1 ) THEN ISOLVE = 2 END IF END IF * IF( ( MB.LE.1 .AND. NB.LE.1 ) .OR. ( MB.GE.M .AND. NB.GE.N ) ) $ THEN * DO 30 IROUND = 1, ISOLVE * * Use unblocked Level 2 solver * DSCALE = ZERO DSUM = ONE PQ = 0 CALL DTGSY2( TRANS, IFUNC, M, N, A, LDA, B, LDB, C, LDC, D, $ LDD, E, LDE, F, LDF, SCALE, DSUM, DSCALE, $ IWORK, PQ, INFO ) IF( DSCALE.NE.ZERO ) THEN IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN DIF = SQRT( DBLE( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) ) ELSE DIF = SQRT( DBLE( PQ ) ) / ( DSCALE*SQRT( DSUM ) ) END IF END IF * IF( ISOLVE.EQ.2 .AND. IROUND.EQ.1 ) THEN IF( NOTRAN ) THEN IFUNC = IJOB END IF SCALE2 = SCALE CALL DLACPY( 'F', M, N, C, LDC, WORK, M ) CALL DLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M ) CALL DLASET( 'F', M, N, ZERO, ZERO, C, LDC ) CALL DLASET( 'F', M, N, ZERO, ZERO, F, LDF ) ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN CALL DLACPY( 'F', M, N, WORK, M, C, LDC ) CALL DLACPY( 'F', M, N, WORK( M*N+1 ), M, F, LDF ) SCALE = SCALE2 END IF 30 CONTINUE * RETURN END IF * * Determine block structure of A * P = 0 I = 1 40 CONTINUE IF( I.GT.M ) $ GO TO 50 P = P + 1 IWORK( P ) = I I = I + MB IF( I.GE.M ) $ GO TO 50 IF( A( I, I-1 ).NE.ZERO ) $ I = I + 1 GO TO 40 50 CONTINUE * IWORK( P+1 ) = M + 1 IF( IWORK( P ).EQ.IWORK( P+1 ) ) $ P = P - 1 * * Determine block structure of B * Q = P + 1 J = 1 60 CONTINUE IF( J.GT.N ) $ GO TO 70 Q = Q + 1 IWORK( Q ) = J J = J + NB IF( J.GE.N ) $ GO TO 70 IF( B( J, J-1 ).NE.ZERO ) $ J = J + 1 GO TO 60 70 CONTINUE * IWORK( Q+1 ) = N + 1 IF( IWORK( Q ).EQ.IWORK( Q+1 ) ) $ Q = Q - 1 * IF( NOTRAN ) THEN * DO 150 IROUND = 1, ISOLVE * * Solve (I, J)-subsystem * A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) * D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) * for I = P, P - 1,..., 1; J = 1, 2,..., Q * DSCALE = ZERO DSUM = ONE PQ = 0 SCALE = ONE DO 130 J = P + 2, Q JS = IWORK( J ) JE = IWORK( J+1 ) - 1 NB = JE - JS + 1 DO 120 I = P, 1, -1 IS = IWORK( I ) IE = IWORK( I+1 ) - 1 MB = IE - IS + 1 PPQQ = 0 CALL DTGSY2( TRANS, IFUNC, MB, NB, A( IS, IS ), LDA, $ B( JS, JS ), LDB, C( IS, JS ), LDC, $ D( IS, IS ), LDD, E( JS, JS ), LDE, $ F( IS, JS ), LDF, SCALOC, DSUM, DSCALE, $ IWORK( Q+2 ), PPQQ, LINFO ) IF( LINFO.GT.0 ) $ INFO = LINFO * PQ = PQ + PPQQ IF( SCALOC.NE.ONE ) THEN DO 80 K = 1, JS - 1 CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) 80 CONTINUE DO 90 K = JS, JE CALL DSCAL( IS-1, SCALOC, C( 1, K ), 1 ) CALL DSCAL( IS-1, SCALOC, F( 1, K ), 1 ) 90 CONTINUE DO 100 K = JS, JE CALL DSCAL( M-IE, SCALOC, C( IE+1, K ), 1 ) CALL DSCAL( M-IE, SCALOC, F( IE+1, K ), 1 ) 100 CONTINUE DO 110 K = JE + 1, N CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) 110 CONTINUE SCALE = SCALE*SCALOC END IF * * Substitute R(I, J) and L(I, J) into remaining * equation. * IF( I.GT.1 ) THEN CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE, $ A( 1, IS ), LDA, C( IS, JS ), LDC, ONE, $ C( 1, JS ), LDC ) CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE, $ D( 1, IS ), LDD, C( IS, JS ), LDC, ONE, $ F( 1, JS ), LDF ) END IF IF( J.LT.Q ) THEN CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, $ F( IS, JS ), LDF, B( JS, JE+1 ), LDB, $ ONE, C( IS, JE+1 ), LDC ) CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, $ F( IS, JS ), LDF, E( JS, JE+1 ), LDE, $ ONE, F( IS, JE+1 ), LDF ) END IF 120 CONTINUE 130 CONTINUE IF( DSCALE.NE.ZERO ) THEN IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN DIF = SQRT( DBLE( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) ) ELSE DIF = SQRT( DBLE( PQ ) ) / ( DSCALE*SQRT( DSUM ) ) END IF END IF IF( ISOLVE.EQ.2 .AND. IROUND.EQ.1 ) THEN IF( NOTRAN ) THEN IFUNC = IJOB END IF SCALE2 = SCALE CALL DLACPY( 'F', M, N, C, LDC, WORK, M ) CALL DLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M ) CALL DLASET( 'F', M, N, ZERO, ZERO, C, LDC ) CALL DLASET( 'F', M, N, ZERO, ZERO, F, LDF ) ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN CALL DLACPY( 'F', M, N, WORK, M, C, LDC ) CALL DLACPY( 'F', M, N, WORK( M*N+1 ), M, F, LDF ) SCALE = SCALE2 END IF 150 CONTINUE * ELSE * * Solve transposed (I, J)-subsystem * A(I, I)**T * R(I, J) + D(I, I)**T * L(I, J) = C(I, J) * R(I, J) * B(J, J)**T + L(I, J) * E(J, J)**T = -F(I, J) * for I = 1,2,..., P; J = Q, Q-1,..., 1 * SCALE = ONE DO 210 I = 1, P IS = IWORK( I ) IE = IWORK( I+1 ) - 1 MB = IE - IS + 1 DO 200 J = Q, P + 2, -1 JS = IWORK( J ) JE = IWORK( J+1 ) - 1 NB = JE - JS + 1 CALL DTGSY2( TRANS, IFUNC, MB, NB, A( IS, IS ), LDA, $ B( JS, JS ), LDB, C( IS, JS ), LDC, $ D( IS, IS ), LDD, E( JS, JS ), LDE, $ F( IS, JS ), LDF, SCALOC, DSUM, DSCALE, $ IWORK( Q+2 ), PPQQ, LINFO ) IF( LINFO.GT.0 ) $ INFO = LINFO IF( SCALOC.NE.ONE ) THEN DO 160 K = 1, JS - 1 CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) 160 CONTINUE DO 170 K = JS, JE CALL DSCAL( IS-1, SCALOC, C( 1, K ), 1 ) CALL DSCAL( IS-1, SCALOC, F( 1, K ), 1 ) 170 CONTINUE DO 180 K = JS, JE CALL DSCAL( M-IE, SCALOC, C( IE+1, K ), 1 ) CALL DSCAL( M-IE, SCALOC, F( IE+1, K ), 1 ) 180 CONTINUE DO 190 K = JE + 1, N CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) 190 CONTINUE SCALE = SCALE*SCALOC END IF * * Substitute R(I, J) and L(I, J) into remaining equation. * IF( J.GT.P+2 ) THEN CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE, C( IS, JS ), $ LDC, B( 1, JS ), LDB, ONE, F( IS, 1 ), $ LDF ) CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE, F( IS, JS ), $ LDF, E( 1, JS ), LDE, ONE, F( IS, 1 ), $ LDF ) END IF IF( I.LT.P ) THEN CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE, $ A( IS, IE+1 ), LDA, C( IS, JS ), LDC, ONE, $ C( IE+1, JS ), LDC ) CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE, $ D( IS, IE+1 ), LDD, F( IS, JS ), LDF, ONE, $ C( IE+1, JS ), LDC ) END IF 200 CONTINUE 210 CONTINUE * END IF * WORK( 1 ) = LWMIN * RETURN * * End of DTGSYL * END *> \brief \b DTPCON * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTPCON + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, IWORK, * INFO ) * * .. Scalar Arguments .. * CHARACTER DIAG, NORM, UPLO * INTEGER INFO, N * DOUBLE PRECISION RCOND * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION AP( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTPCON estimates the reciprocal of the condition number of a packed *> triangular matrix A, in either the 1-norm or the infinity-norm. *> *> The norm of A is computed and an estimate is obtained for *> norm(inv(A)), then the reciprocal of the condition number is *> computed as *> RCOND = 1 / ( norm(A) * norm(inv(A)) ). *> \endverbatim * * Arguments: * ========== * *> \param[in] NORM *> \verbatim *> NORM is 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. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': A is upper triangular; *> = 'L': A is lower triangular. *> \endverbatim *> *> \param[in] DIAG *> \verbatim *> DIAG is CHARACTER*1 *> = 'N': A is non-unit triangular; *> = 'U': A is unit triangular. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> The upper or lower triangular matrix A, packed columnwise in *> a linear array. The j-th column of A is stored in the array *> AP as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. *> If DIAG = 'U', the diagonal elements of A are not referenced *> and are assumed to be 1. *> \endverbatim *> *> \param[out] RCOND *> \verbatim *> RCOND is DOUBLE PRECISION *> The reciprocal of the condition number of the matrix A, *> computed as RCOND = 1/(norm(A) * norm(inv(A))). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, IWORK, $ INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO INTEGER INFO, N DOUBLE PRECISION RCOND * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION AP( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOUNIT, ONENRM, UPPER CHARACTER NORMIN INTEGER IX, KASE, KASE1 DOUBLE PRECISION AINVNM, ANORM, SCALE, SMLNUM, XNORM * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DLANTP EXTERNAL LSAME, IDAMAX, DLAMCH, DLANTP * .. * .. External Subroutines .. EXTERNAL DLACN2, DLATPS, DRSCL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' ) NOUNIT = LSAME( DIAG, 'N' ) * IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN INFO = -1 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -2 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTPCON', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN RCOND = ONE RETURN END IF * RCOND = ZERO SMLNUM = DLAMCH( 'Safe minimum' )*DBLE( MAX( 1, N ) ) * * Compute the norm of the triangular matrix A. * ANORM = DLANTP( NORM, UPLO, DIAG, N, AP, WORK ) * * Continue only if ANORM > 0. * IF( ANORM.GT.ZERO ) THEN * * Estimate the norm of the inverse of 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(A). * CALL DLATPS( UPLO, 'No transpose', DIAG, NORMIN, N, AP, $ WORK, SCALE, WORK( 2*N+1 ), INFO ) ELSE * * Multiply by inv(A**T). * CALL DLATPS( UPLO, 'Transpose', DIAG, NORMIN, N, AP, $ WORK, SCALE, WORK( 2*N+1 ), INFO ) END IF NORMIN = 'Y' * * Multiply by 1/SCALE if doing so will not cause overflow. * IF( SCALE.NE.ONE ) THEN IX = IDAMAX( N, WORK, 1 ) XNORM = ABS( WORK( IX ) ) IF( SCALE.LT.XNORM*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 / ANORM ) / AINVNM END IF * 20 CONTINUE RETURN * * End of DTPCON * END *> \brief \b DTPMQRT * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTPMQRT + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, * A, LDA, B, LDB, WORK, INFO ) * * .. Scalar Arguments .. * CHARACTER SIDE, TRANS * INTEGER INFO, K, LDV, LDA, LDB, M, N, L, NB, LDT * .. * .. Array Arguments .. * DOUBLE PRECISION V( LDV, * ), A( LDA, * ), B( LDB, * ), * $ T( LDT, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTPMQRT applies a real orthogonal matrix Q obtained from a *> "triangular-pentagonal" real block reflector H to a general *> real matrix C, which consists of two blocks A and B. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply Q or Q**T from the Left; *> = 'R': apply Q or Q**T from the Right. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': No transpose, apply Q; *> = 'T': Transpose, apply Q**T. *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix B. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix B. N >= 0. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The number of elementary reflectors whose product defines *> the matrix Q. *> \endverbatim *> *> \param[in] L *> \verbatim *> L is INTEGER *> The order of the trapezoidal part of V. *> K >= L >= 0. See Further Details. *> \endverbatim *> *> \param[in] NB *> \verbatim *> NB is INTEGER *> The block size used for the storage of T. K >= NB >= 1. *> This must be the same value of NB used to generate T *> in CTPQRT. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is DOUBLE PRECISION array, dimension (LDA,K) *> The i-th column must contain the vector which defines the *> elementary reflector H(i), for i = 1,2,...,k, as returned by *> CTPQRT in B. See Further Details. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the array V. *> If SIDE = 'L', LDV >= max(1,M); *> if SIDE = 'R', LDV >= max(1,N). *> \endverbatim *> *> \param[in] T *> \verbatim *> T is DOUBLE PRECISION array, dimension (LDT,K) *> The upper triangular factors of the block reflectors *> as returned by CTPQRT, stored as a NB-by-K matrix. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= NB. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension *> (LDA,N) if SIDE = 'L' or *> (LDA,K) if SIDE = 'R' *> On entry, the K-by-N or M-by-K matrix A. *> On exit, A is overwritten by the corresponding block of *> Q*C or Q**T*C or C*Q or C*Q**T. See Further Details. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. *> If SIDE = 'L', LDC >= max(1,K); *> If SIDE = 'R', LDC >= max(1,M). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,N) *> On entry, the M-by-N matrix B. *> On exit, B is overwritten by the corresponding block of *> Q*C or Q**T*C or C*Q or C*Q**T. See Further Details. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. *> LDB >= max(1,M). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array. The dimension of WORK is *> N*NB if SIDE = 'L', or M*NB if SIDE = 'R'. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date November 2017 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The columns of the pentagonal matrix V contain the elementary reflectors *> H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a *> trapezoidal block V2: *> *> V = [V1] *> [V2]. *> *> The size of the trapezoidal block V2 is determined by the parameter L, *> where 0 <= L <= K; V2 is upper trapezoidal, consisting of the first L *> rows of a K-by-K upper triangular matrix. If L=K, V2 is upper triangular; *> if L=0, there is no trapezoidal block, hence V = V1 is rectangular. *> *> If SIDE = 'L': C = [A] where A is K-by-N, B is M-by-N and V is M-by-K. *> [B] *> *> If SIDE = 'R': C = [A B] where A is M-by-K, B is M-by-N and V is N-by-K. *> *> The real orthogonal matrix Q is formed from V and T. *> *> If TRANS='N' and SIDE='L', C is on exit replaced with Q * C. *> *> If TRANS='T' and SIDE='L', C is on exit replaced with Q**T * C. *> *> If TRANS='N' and SIDE='R', C is on exit replaced with C * Q. *> *> If TRANS='T' and SIDE='R', C is on exit replaced with C * Q**T. *> \endverbatim *> * ===================================================================== SUBROUTINE DTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, $ A, LDA, B, LDB, WORK, INFO ) * * -- LAPACK computational routine (version 3.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDV, LDA, LDB, M, N, L, NB, LDT * .. * .. Array Arguments .. DOUBLE PRECISION V( LDV, * ), A( LDA, * ), B( LDB, * ), $ T( LDT, * ), WORK( * ) * .. * * ===================================================================== * * .. * .. Local Scalars .. LOGICAL LEFT, RIGHT, TRAN, NOTRAN INTEGER I, IB, MB, LB, KF, LDAQ, LDVQ * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DTPRFB, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * .. Test the input arguments .. * INFO = 0 LEFT = LSAME( SIDE, 'L' ) RIGHT = LSAME( SIDE, 'R' ) TRAN = LSAME( TRANS, 'T' ) NOTRAN = LSAME( TRANS, 'N' ) * IF ( LEFT ) THEN LDVQ = MAX( 1, M ) LDAQ = MAX( 1, K ) ELSE IF ( RIGHT ) THEN LDVQ = MAX( 1, N ) LDAQ = MAX( 1, M ) END IF IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN INFO = -1 ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( K.LT.0 ) THEN INFO = -5 ELSE IF( L.LT.0 .OR. L.GT.K ) THEN INFO = -6 ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0) ) THEN INFO = -7 ELSE IF( LDV.LT.LDVQ ) THEN INFO = -9 ELSE IF( LDT.LT.NB ) THEN INFO = -11 ELSE IF( LDA.LT.LDAQ ) THEN INFO = -13 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -15 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTPMQRT', -INFO ) RETURN END IF * * .. Quick return if possible .. * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN * IF( LEFT .AND. TRAN ) THEN * DO I = 1, K, NB IB = MIN( NB, K-I+1 ) MB = MIN( M-L+I+IB-1, M ) IF( I.GE.L ) THEN LB = 0 ELSE LB = MB-M+L-I+1 END IF CALL DTPRFB( 'L', 'T', 'F', 'C', MB, N, IB, LB, $ V( 1, I ), LDV, T( 1, I ), LDT, $ A( I, 1 ), LDA, B, LDB, WORK, IB ) END DO * ELSE IF( RIGHT .AND. NOTRAN ) THEN * DO I = 1, K, NB IB = MIN( NB, K-I+1 ) MB = MIN( N-L+I+IB-1, N ) IF( I.GE.L ) THEN LB = 0 ELSE LB = MB-N+L-I+1 END IF CALL DTPRFB( 'R', 'N', 'F', 'C', M, MB, IB, LB, $ V( 1, I ), LDV, T( 1, I ), LDT, $ A( 1, I ), LDA, B, LDB, WORK, M ) END DO * ELSE IF( LEFT .AND. NOTRAN ) THEN * KF = ((K-1)/NB)*NB+1 DO I = KF, 1, -NB IB = MIN( NB, K-I+1 ) MB = MIN( M-L+I+IB-1, M ) IF( I.GE.L ) THEN LB = 0 ELSE LB = MB-M+L-I+1 END IF CALL DTPRFB( 'L', 'N', 'F', 'C', MB, N, IB, LB, $ V( 1, I ), LDV, T( 1, I ), LDT, $ A( I, 1 ), LDA, B, LDB, WORK, IB ) END DO * ELSE IF( RIGHT .AND. TRAN ) THEN * KF = ((K-1)/NB)*NB+1 DO I = KF, 1, -NB IB = MIN( NB, K-I+1 ) MB = MIN( N-L+I+IB-1, N ) IF( I.GE.L ) THEN LB = 0 ELSE LB = MB-N+L-I+1 END IF CALL DTPRFB( 'R', 'T', 'F', 'C', M, MB, IB, LB, $ V( 1, I ), LDV, T( 1, I ), LDT, $ A( 1, I ), LDA, B, LDB, WORK, M ) END DO * END IF * RETURN * * End of DTPMQRT * END *> \brief \b DTPQRT * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTPQRT + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK, * INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LDT, N, M, L, NB * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTPQRT computes a blocked QR factorization of a real *> "triangular-pentagonal" matrix C, which is composed of a *> triangular block A and pentagonal block B, using the compact *> WY representation for Q. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix B. *> M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix B, and the order of the *> triangular matrix A. *> N >= 0. *> \endverbatim *> *> \param[in] L *> \verbatim *> L is INTEGER *> The number of rows of the upper trapezoidal part of B. *> MIN(M,N) >= L >= 0. See Further Details. *> \endverbatim *> *> \param[in] NB *> \verbatim *> NB is INTEGER *> The block size to be used in the blocked QR. N >= NB >= 1. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the upper triangular N-by-N matrix A. *> On exit, the elements on and above the diagonal of the array *> contain the upper triangular matrix R. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,N) *> On entry, the pentagonal M-by-N matrix B. The first M-L rows *> are rectangular, and the last L rows are upper trapezoidal. *> On exit, B contains the pentagonal matrix V. See Further Details. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,M). *> \endverbatim *> *> \param[out] T *> \verbatim *> T is DOUBLE PRECISION array, dimension (LDT,N) *> The upper triangular block reflectors stored in compact form *> as a sequence of upper triangular blocks. See Further Details. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= NB. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (NB*N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The input matrix C is a (N+M)-by-N matrix *> *> C = [ A ] *> [ B ] *> *> where A is an upper triangular N-by-N matrix, and B is M-by-N pentagonal *> matrix consisting of a (M-L)-by-N rectangular matrix B1 on top of a L-by-N *> upper trapezoidal matrix B2: *> *> B = [ B1 ] <- (M-L)-by-N rectangular *> [ B2 ] <- L-by-N upper trapezoidal. *> *> The upper trapezoidal matrix B2 consists of the first L rows of a *> N-by-N upper triangular matrix, where 0 <= L <= MIN(M,N). If L=0, *> B is rectangular M-by-N; if M=L=N, B is upper triangular. *> *> The matrix W stores the elementary reflectors H(i) in the i-th column *> below the diagonal (of A) in the (N+M)-by-N input matrix C *> *> C = [ A ] <- upper triangular N-by-N *> [ B ] <- M-by-N pentagonal *> *> so that W can be represented as *> *> W = [ I ] <- identity, N-by-N *> [ V ] <- M-by-N, same form as B. *> *> Thus, all of information needed for W is contained on exit in B, which *> we call V above. Note that V has the same form as B; that is, *> *> V = [ V1 ] <- (M-L)-by-N rectangular *> [ V2 ] <- L-by-N upper trapezoidal. *> *> The columns of V represent the vectors which define the H(i)'s. *> *> The number of blocks is B = ceiling(N/NB), where each *> block is of order NB except for the last block, which is of order *> IB = N - (B-1)*NB. For each of the B blocks, a upper triangular block *> reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB *> for the last block) T's are stored in the NB-by-N matrix T as *> *> T = [T1 T2 ... TB]. *> \endverbatim *> * ===================================================================== SUBROUTINE DTPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK, $ INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDT, N, M, L, NB * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) * .. * * ===================================================================== * * .. * .. Local Scalars .. INTEGER I, IB, LB, MB, IINFO * .. * .. External Subroutines .. EXTERNAL DTPQRT2, DTPRFB, XERBLA * .. * .. 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( L.LT.0 .OR. (L.GT.MIN(M,N) .AND. MIN(M,N).GE.0)) THEN INFO = -3 ELSE IF( NB.LT.1 .OR. (NB.GT.N .AND. N.GT.0)) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -8 ELSE IF( LDT.LT.NB ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTPQRT', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) RETURN * DO I = 1, N, NB * * Compute the QR factorization of the current block * IB = MIN( N-I+1, NB ) MB = MIN( M-L+I+IB-1, M ) IF( I.GE.L ) THEN LB = 0 ELSE LB = MB-M+L-I+1 END IF * CALL DTPQRT2( MB, IB, LB, A(I,I), LDA, B( 1, I ), LDB, $ T(1, I ), LDT, IINFO ) * * Update by applying H**T to B(:,I+IB:N) from the left * IF( I+IB.LE.N ) THEN CALL DTPRFB( 'L', 'T', 'F', 'C', MB, N-I-IB+1, IB, LB, $ B( 1, I ), LDB, T( 1, I ), LDT, $ A( I, I+IB ), LDA, B( 1, I+IB ), LDB, $ WORK, IB ) END IF END DO RETURN * * End of DTPQRT * END *> \brief \b DTPQRT2 computes a QR factorization of a real or complex "triangular-pentagonal" matrix, which is composed of a triangular block and a pentagonal block, using the compact WY representation for Q. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTPQRT2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LDB, LDT, N, M, L * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTPQRT2 computes a QR factorization of a real "triangular-pentagonal" *> matrix C, which is composed of a triangular block A and pentagonal block B, *> using the compact WY representation for Q. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The total number of rows of the matrix B. *> M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix B, and the order of *> the triangular matrix A. *> N >= 0. *> \endverbatim *> *> \param[in] L *> \verbatim *> L is INTEGER *> The number of rows of the upper trapezoidal part of B. *> MIN(M,N) >= L >= 0. See Further Details. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the upper triangular N-by-N matrix A. *> On exit, the elements on and above the diagonal of the array *> contain the upper triangular matrix R. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,N) *> On entry, the pentagonal M-by-N matrix B. The first M-L rows *> are rectangular, and the last L rows are upper trapezoidal. *> On exit, B contains the pentagonal matrix V. See Further Details. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,M). *> \endverbatim *> *> \param[out] T *> \verbatim *> T is DOUBLE PRECISION array, dimension (LDT,N) *> The N-by-N upper triangular factor T of the block reflector. *> See Further Details. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= max(1,N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The input matrix C is a (N+M)-by-N matrix *> *> C = [ A ] *> [ B ] *> *> where A is an upper triangular N-by-N matrix, and B is M-by-N pentagonal *> matrix consisting of a (M-L)-by-N rectangular matrix B1 on top of a L-by-N *> upper trapezoidal matrix B2: *> *> B = [ B1 ] <- (M-L)-by-N rectangular *> [ B2 ] <- L-by-N upper trapezoidal. *> *> The upper trapezoidal matrix B2 consists of the first L rows of a *> N-by-N upper triangular matrix, where 0 <= L <= MIN(M,N). If L=0, *> B is rectangular M-by-N; if M=L=N, B is upper triangular. *> *> The matrix W stores the elementary reflectors H(i) in the i-th column *> below the diagonal (of A) in the (N+M)-by-N input matrix C *> *> C = [ A ] <- upper triangular N-by-N *> [ B ] <- M-by-N pentagonal *> *> so that W can be represented as *> *> W = [ I ] <- identity, N-by-N *> [ V ] <- M-by-N, same form as B. *> *> Thus, all of information needed for W is contained on exit in B, which *> we call V above. Note that V has the same form as B; that is, *> *> V = [ V1 ] <- (M-L)-by-N rectangular *> [ V2 ] <- L-by-N upper trapezoidal. *> *> The columns of V represent the vectors which define the H(i)'s. *> The (M+N)-by-(M+N) block reflector H is then given by *> *> H = I - W * T * W**T *> *> where W^H is the conjugate transpose of W and T is the upper triangular *> factor of the block reflector. *> \endverbatim *> * ===================================================================== SUBROUTINE DTPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDT, N, M, L * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER( ONE = 1.0, ZERO = 0.0 ) * .. * .. Local Scalars .. INTEGER I, J, P, MP, NP DOUBLE PRECISION ALPHA * .. * .. External Subroutines .. EXTERNAL DLARFG, DGEMV, DGER, DTRMV, 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( L.LT.0 .OR. L.GT.MIN(M,N) ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -7 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTPQRT2', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. M.EQ.0 ) RETURN * DO I = 1, N * * Generate elementary reflector H(I) to annihilate B(:,I) * P = M-L+MIN( L, I ) CALL DLARFG( P+1, A( I, I ), B( 1, I ), 1, T( I, 1 ) ) IF( I.LT.N ) THEN * * W(1:N-I) := C(I:M,I+1:N)^H * C(I:M,I) [use W = T(:,N)] * DO J = 1, N-I T( J, N ) = (A( I, I+J )) END DO CALL DGEMV( 'T', P, N-I, ONE, B( 1, I+1 ), LDB, $ B( 1, I ), 1, ONE, T( 1, N ), 1 ) * * C(I:M,I+1:N) = C(I:m,I+1:N) + alpha*C(I:M,I)*W(1:N-1)^H * ALPHA = -(T( I, 1 )) DO J = 1, N-I A( I, I+J ) = A( I, I+J ) + ALPHA*(T( J, N )) END DO CALL DGER( P, N-I, ALPHA, B( 1, I ), 1, $ T( 1, N ), 1, B( 1, I+1 ), LDB ) END IF END DO * DO I = 2, N * * T(1:I-1,I) := C(I:M,1:I-1)^H * (alpha * C(I:M,I)) * ALPHA = -T( I, 1 ) DO J = 1, I-1 T( J, I ) = ZERO END DO P = MIN( I-1, L ) MP = MIN( M-L+1, M ) NP = MIN( P+1, N ) * * Triangular part of B2 * DO J = 1, P T( J, I ) = ALPHA*B( M-L+J, I ) END DO CALL DTRMV( 'U', 'T', 'N', P, B( MP, 1 ), LDB, $ T( 1, I ), 1 ) * * Rectangular part of B2 * CALL DGEMV( 'T', L, I-1-P, ALPHA, B( MP, NP ), LDB, $ B( MP, I ), 1, ZERO, T( NP, I ), 1 ) * * B1 * CALL DGEMV( 'T', M-L, I-1, ALPHA, B, LDB, B( 1, I ), 1, $ ONE, T( 1, I ), 1 ) * * T(1:I-1,I) := T(1:I-1,1:I-1) * T(1:I-1,I) * CALL DTRMV( 'U', 'N', 'N', I-1, T, LDT, T( 1, I ), 1 ) * * T(I,I) = tau(I) * T( I, I ) = T( I, 1 ) T( I, 1 ) = ZERO END DO * * End of DTPQRT2 * END *> \brief \b DTPRFB applies a real or complex "triangular-pentagonal" blocked reflector to a real or complex matrix, which is composed of two blocks. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTPRFB + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, * V, LDV, T, LDT, A, LDA, B, LDB, WORK, LDWORK ) * * .. Scalar Arguments .. * CHARACTER DIRECT, SIDE, STOREV, TRANS * INTEGER K, L, LDA, LDB, LDT, LDV, LDWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ), * $ V( LDV, * ), WORK( LDWORK, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTPRFB applies a real "triangular-pentagonal" block reflector H or its *> transpose H**T to a real matrix C, which is composed of two *> blocks A and B, either from the left or right. *> *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': apply H or H**T from the Left *> = 'R': apply H or H**T from the Right *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is CHARACTER*1 *> = 'N': apply H (No transpose) *> = 'T': apply H**T (Transpose) *> \endverbatim *> *> \param[in] DIRECT *> \verbatim *> DIRECT is CHARACTER*1 *> Indicates how H is formed from a product of elementary *> reflectors *> = 'F': H = H(1) H(2) . . . H(k) (Forward) *> = 'B': H = H(k) . . . H(2) H(1) (Backward) *> \endverbatim *> *> \param[in] STOREV *> \verbatim *> STOREV is CHARACTER*1 *> Indicates how the vectors which define the elementary *> reflectors are stored: *> = 'C': Columns *> = 'R': Rows *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix B. *> M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix B. *> N >= 0. *> \endverbatim *> *> \param[in] K *> \verbatim *> K is INTEGER *> The order of the matrix T, i.e. the number of elementary *> reflectors whose product defines the block reflector. *> K >= 0. *> \endverbatim *> *> \param[in] L *> \verbatim *> L is INTEGER *> The order of the trapezoidal part of V. *> K >= L >= 0. See Further Details. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is DOUBLE PRECISION array, dimension *> (LDV,K) if STOREV = 'C' *> (LDV,M) if STOREV = 'R' and SIDE = 'L' *> (LDV,N) if STOREV = 'R' and SIDE = 'R' *> The pentagonal matrix V, which contains the elementary reflectors *> H(1), H(2), ..., H(K). See Further Details. *> \endverbatim *> *> \param[in] LDV *> \verbatim *> LDV is INTEGER *> The leading dimension of the array V. *> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); *> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); *> if STOREV = 'R', LDV >= K. *> \endverbatim *> *> \param[in] T *> \verbatim *> T is DOUBLE PRECISION array, dimension (LDT,K) *> The triangular K-by-K matrix T in the representation of the *> block reflector. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. *> LDT >= K. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension *> (LDA,N) if SIDE = 'L' or (LDA,K) if SIDE = 'R' *> On entry, the K-by-N or M-by-K matrix A. *> On exit, A is overwritten by the corresponding block of *> H*C or H**T*C or C*H or C*H**T. See Further Details. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. *> If SIDE = 'L', LDC >= max(1,K); *> If SIDE = 'R', LDC >= max(1,M). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,N) *> On entry, the M-by-N matrix B. *> On exit, B is overwritten by the corresponding block of *> H*C or H**T*C or C*H or C*H**T. See Further Details. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. *> LDB >= max(1,M). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension *> (LDWORK,N) if SIDE = 'L', *> (LDWORK,K) if SIDE = 'R'. *> \endverbatim *> *> \param[in] LDWORK *> \verbatim *> LDWORK is INTEGER *> The leading dimension of the array WORK. *> If SIDE = 'L', LDWORK >= K; *> if SIDE = 'R', LDWORK >= M. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> The matrix C is a composite matrix formed from blocks A and B. *> The block B is of size M-by-N; if SIDE = 'R', A is of size M-by-K, *> and if SIDE = 'L', A is of size K-by-N. *> *> If SIDE = 'R' and DIRECT = 'F', C = [A B]. *> *> If SIDE = 'L' and DIRECT = 'F', C = [A] *> [B]. *> *> If SIDE = 'R' and DIRECT = 'B', C = [B A]. *> *> If SIDE = 'L' and DIRECT = 'B', C = [B] *> [A]. *> *> The pentagonal matrix V is composed of a rectangular block V1 and a *> trapezoidal block V2. The size of the trapezoidal block is determined by *> the parameter L, where 0<=L<=K. If L=K, the V2 block of V is triangular; *> if L=0, there is no trapezoidal block, thus V = V1 is rectangular. *> *> If DIRECT = 'F' and STOREV = 'C': V = [V1] *> [V2] *> - V2 is upper trapezoidal (first L rows of K-by-K upper triangular) *> *> If DIRECT = 'F' and STOREV = 'R': V = [V1 V2] *> *> - V2 is lower trapezoidal (first L columns of K-by-K lower triangular) *> *> If DIRECT = 'B' and STOREV = 'C': V = [V2] *> [V1] *> - V2 is lower trapezoidal (last L rows of K-by-K lower triangular) *> *> If DIRECT = 'B' and STOREV = 'R': V = [V2 V1] *> *> - V2 is upper trapezoidal (last L columns of K-by-K upper triangular) *> *> If STOREV = 'C' and SIDE = 'L', V is M-by-K with V2 L-by-K. *> *> If STOREV = 'C' and SIDE = 'R', V is N-by-K with V2 L-by-K. *> *> If STOREV = 'R' and SIDE = 'L', V is K-by-M with V2 K-by-L. *> *> If STOREV = 'R' and SIDE = 'R', V is K-by-N with V2 K-by-L. *> \endverbatim *> * ===================================================================== SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, $ V, LDV, T, LDT, A, LDA, B, LDB, WORK, LDWORK ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS INTEGER K, L, LDA, LDB, LDT, LDV, LDWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ), $ V( LDV, * ), WORK( LDWORK, * ) * .. * * ========================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0, ZERO = 0.0 ) * .. * .. Local Scalars .. INTEGER I, J, MP, NP, KP LOGICAL LEFT, FORWARD, COLUMN, RIGHT, BACKWARD, ROW * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DGEMM, DTRMM * .. * .. Executable Statements .. * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 .OR. K.LE.0 .OR. L.LT.0 ) RETURN * IF( LSAME( STOREV, 'C' ) ) THEN COLUMN = .TRUE. ROW = .FALSE. ELSE IF ( LSAME( STOREV, 'R' ) ) THEN COLUMN = .FALSE. ROW = .TRUE. ELSE COLUMN = .FALSE. ROW = .FALSE. END IF * IF( LSAME( SIDE, 'L' ) ) THEN LEFT = .TRUE. RIGHT = .FALSE. ELSE IF( LSAME( SIDE, 'R' ) ) THEN LEFT = .FALSE. RIGHT = .TRUE. ELSE LEFT = .FALSE. RIGHT = .FALSE. END IF * IF( LSAME( DIRECT, 'F' ) ) THEN FORWARD = .TRUE. BACKWARD = .FALSE. ELSE IF( LSAME( DIRECT, 'B' ) ) THEN FORWARD = .FALSE. BACKWARD = .TRUE. ELSE FORWARD = .FALSE. BACKWARD = .FALSE. END IF * * --------------------------------------------------------------------------- * IF( COLUMN .AND. FORWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ I ] (K-by-K) * [ V ] (M-by-K) * * Form H C or H**T C where C = [ A ] (K-by-N) * [ B ] (M-by-N) * * H = I - W T W**T or H**T = I - W T**T W**T * * A = A - T (A + V**T B) or A = A - T**T (A + V**T B) * B = B - V T (A + V**T B) or B = B - V T**T (A + V**T B) * * --------------------------------------------------------------------------- * MP = MIN( M-L+1, M ) KP = MIN( L+1, K ) * DO J = 1, N DO I = 1, L WORK( I, J ) = B( M-L+I, J ) END DO END DO CALL DTRMM( 'L', 'U', 'T', 'N', L, N, ONE, V( MP, 1 ), LDV, $ WORK, LDWORK ) CALL DGEMM( 'T', 'N', L, N, M-L, ONE, V, LDV, B, LDB, $ ONE, WORK, LDWORK ) CALL DGEMM( 'T', 'N', K-L, N, M, ONE, V( 1, KP ), LDV, $ B, LDB, ZERO, WORK( KP, 1 ), LDWORK ) * DO J = 1, N DO I = 1, K WORK( I, J ) = WORK( I, J ) + A( I, J ) END DO END DO * CALL DTRMM( 'L', 'U', TRANS, 'N', K, N, ONE, T, LDT, $ WORK, LDWORK ) * DO J = 1, N DO I = 1, K A( I, J ) = A( I, J ) - WORK( I, J ) END DO END DO * CALL DGEMM( 'N', 'N', M-L, N, K, -ONE, V, LDV, WORK, LDWORK, $ ONE, B, LDB ) CALL DGEMM( 'N', 'N', L, N, K-L, -ONE, V( MP, KP ), LDV, $ WORK( KP, 1 ), LDWORK, ONE, B( MP, 1 ), LDB ) CALL DTRMM( 'L', 'U', 'N', 'N', L, N, ONE, V( MP, 1 ), LDV, $ WORK, LDWORK ) DO J = 1, N DO I = 1, L B( M-L+I, J ) = B( M-L+I, J ) - WORK( I, J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( COLUMN .AND. FORWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ I ] (K-by-K) * [ V ] (N-by-K) * * Form C H or C H**T where C = [ A B ] (A is M-by-K, B is M-by-N) * * H = I - W T W**T or H**T = I - W T**T W**T * * A = A - (A + B V) T or A = A - (A + B V) T**T * B = B - (A + B V) T V**T or B = B - (A + B V) T**T V**T * * --------------------------------------------------------------------------- * NP = MIN( N-L+1, N ) KP = MIN( L+1, K ) * DO J = 1, L DO I = 1, M WORK( I, J ) = B( I, N-L+J ) END DO END DO CALL DTRMM( 'R', 'U', 'N', 'N', M, L, ONE, V( NP, 1 ), LDV, $ WORK, LDWORK ) CALL DGEMM( 'N', 'N', M, L, N-L, ONE, B, LDB, $ V, LDV, ONE, WORK, LDWORK ) CALL DGEMM( 'N', 'N', M, K-L, N, ONE, B, LDB, $ V( 1, KP ), LDV, ZERO, WORK( 1, KP ), LDWORK ) * DO J = 1, K DO I = 1, M WORK( I, J ) = WORK( I, J ) + A( I, J ) END DO END DO * CALL DTRMM( 'R', 'U', TRANS, 'N', M, K, ONE, T, LDT, $ WORK, LDWORK ) * DO J = 1, K DO I = 1, M A( I, J ) = A( I, J ) - WORK( I, J ) END DO END DO * CALL DGEMM( 'N', 'T', M, N-L, K, -ONE, WORK, LDWORK, $ V, LDV, ONE, B, LDB ) CALL DGEMM( 'N', 'T', M, L, K-L, -ONE, WORK( 1, KP ), LDWORK, $ V( NP, KP ), LDV, ONE, B( 1, NP ), LDB ) CALL DTRMM( 'R', 'U', 'T', 'N', M, L, ONE, V( NP, 1 ), LDV, $ WORK, LDWORK ) DO J = 1, L DO I = 1, M B( I, N-L+J ) = B( I, N-L+J ) - WORK( I, J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( COLUMN .AND. BACKWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ V ] (M-by-K) * [ I ] (K-by-K) * * Form H C or H**T C where C = [ B ] (M-by-N) * [ A ] (K-by-N) * * H = I - W T W**T or H**T = I - W T**T W**T * * A = A - T (A + V**T B) or A = A - T**T (A + V**T B) * B = B - V T (A + V**T B) or B = B - V T**T (A + V**T B) * * --------------------------------------------------------------------------- * MP = MIN( L+1, M ) KP = MIN( K-L+1, K ) * DO J = 1, N DO I = 1, L WORK( K-L+I, J ) = B( I, J ) END DO END DO * CALL DTRMM( 'L', 'L', 'T', 'N', L, N, ONE, V( 1, KP ), LDV, $ WORK( KP, 1 ), LDWORK ) CALL DGEMM( 'T', 'N', L, N, M-L, ONE, V( MP, KP ), LDV, $ B( MP, 1 ), LDB, ONE, WORK( KP, 1 ), LDWORK ) CALL DGEMM( 'T', 'N', K-L, N, M, ONE, V, LDV, $ B, LDB, ZERO, WORK, LDWORK ) * DO J = 1, N DO I = 1, K WORK( I, J ) = WORK( I, J ) + A( I, J ) END DO END DO * CALL DTRMM( 'L', 'L', TRANS, 'N', K, N, ONE, T, LDT, $ WORK, LDWORK ) * DO J = 1, N DO I = 1, K A( I, J ) = A( I, J ) - WORK( I, J ) END DO END DO * CALL DGEMM( 'N', 'N', M-L, N, K, -ONE, V( MP, 1 ), LDV, $ WORK, LDWORK, ONE, B( MP, 1 ), LDB ) CALL DGEMM( 'N', 'N', L, N, K-L, -ONE, V, LDV, $ WORK, LDWORK, ONE, B, LDB ) CALL DTRMM( 'L', 'L', 'N', 'N', L, N, ONE, V( 1, KP ), LDV, $ WORK( KP, 1 ), LDWORK ) DO J = 1, N DO I = 1, L B( I, J ) = B( I, J ) - WORK( K-L+I, J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( COLUMN .AND. BACKWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ V ] (N-by-K) * [ I ] (K-by-K) * * Form C H or C H**T where C = [ B A ] (B is M-by-N, A is M-by-K) * * H = I - W T W**T or H**T = I - W T**T W**T * * A = A - (A + B V) T or A = A - (A + B V) T**T * B = B - (A + B V) T V**T or B = B - (A + B V) T**T V**T * * --------------------------------------------------------------------------- * NP = MIN( L+1, N ) KP = MIN( K-L+1, K ) * DO J = 1, L DO I = 1, M WORK( I, K-L+J ) = B( I, J ) END DO END DO CALL DTRMM( 'R', 'L', 'N', 'N', M, L, ONE, V( 1, KP ), LDV, $ WORK( 1, KP ), LDWORK ) CALL DGEMM( 'N', 'N', M, L, N-L, ONE, B( 1, NP ), LDB, $ V( NP, KP ), LDV, ONE, WORK( 1, KP ), LDWORK ) CALL DGEMM( 'N', 'N', M, K-L, N, ONE, B, LDB, $ V, LDV, ZERO, WORK, LDWORK ) * DO J = 1, K DO I = 1, M WORK( I, J ) = WORK( I, J ) + A( I, J ) END DO END DO * CALL DTRMM( 'R', 'L', TRANS, 'N', M, K, ONE, T, LDT, $ WORK, LDWORK ) * DO J = 1, K DO I = 1, M A( I, J ) = A( I, J ) - WORK( I, J ) END DO END DO * CALL DGEMM( 'N', 'T', M, N-L, K, -ONE, WORK, LDWORK, $ V( NP, 1 ), LDV, ONE, B( 1, NP ), LDB ) CALL DGEMM( 'N', 'T', M, L, K-L, -ONE, WORK, LDWORK, $ V, LDV, ONE, B, LDB ) CALL DTRMM( 'R', 'L', 'T', 'N', M, L, ONE, V( 1, KP ), LDV, $ WORK( 1, KP ), LDWORK ) DO J = 1, L DO I = 1, M B( I, J ) = B( I, J ) - WORK( I, K-L+J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( ROW .AND. FORWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ I V ] ( I is K-by-K, V is K-by-M ) * * Form H C or H**T C where C = [ A ] (K-by-N) * [ B ] (M-by-N) * * H = I - W**T T W or H**T = I - W**T T**T W * * A = A - T (A + V B) or A = A - T**T (A + V B) * B = B - V**T T (A + V B) or B = B - V**T T**T (A + V B) * * --------------------------------------------------------------------------- * MP = MIN( M-L+1, M ) KP = MIN( L+1, K ) * DO J = 1, N DO I = 1, L WORK( I, J ) = B( M-L+I, J ) END DO END DO CALL DTRMM( 'L', 'L', 'N', 'N', L, N, ONE, V( 1, MP ), LDV, $ WORK, LDB ) CALL DGEMM( 'N', 'N', L, N, M-L, ONE, V, LDV,B, LDB, $ ONE, WORK, LDWORK ) CALL DGEMM( 'N', 'N', K-L, N, M, ONE, V( KP, 1 ), LDV, $ B, LDB, ZERO, WORK( KP, 1 ), LDWORK ) * DO J = 1, N DO I = 1, K WORK( I, J ) = WORK( I, J ) + A( I, J ) END DO END DO * CALL DTRMM( 'L', 'U', TRANS, 'N', K, N, ONE, T, LDT, $ WORK, LDWORK ) * DO J = 1, N DO I = 1, K A( I, J ) = A( I, J ) - WORK( I, J ) END DO END DO * CALL DGEMM( 'T', 'N', M-L, N, K, -ONE, V, LDV, WORK, LDWORK, $ ONE, B, LDB ) CALL DGEMM( 'T', 'N', L, N, K-L, -ONE, V( KP, MP ), LDV, $ WORK( KP, 1 ), LDWORK, ONE, B( MP, 1 ), LDB ) CALL DTRMM( 'L', 'L', 'T', 'N', L, N, ONE, V( 1, MP ), LDV, $ WORK, LDWORK ) DO J = 1, N DO I = 1, L B( M-L+I, J ) = B( M-L+I, J ) - WORK( I, J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( ROW .AND. FORWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ I V ] ( I is K-by-K, V is K-by-N ) * * Form C H or C H**T where C = [ A B ] (A is M-by-K, B is M-by-N) * * H = I - W**T T W or H**T = I - W**T T**T W * * A = A - (A + B V**T) T or A = A - (A + B V**T) T**T * B = B - (A + B V**T) T V or B = B - (A + B V**T) T**T V * * --------------------------------------------------------------------------- * NP = MIN( N-L+1, N ) KP = MIN( L+1, K ) * DO J = 1, L DO I = 1, M WORK( I, J ) = B( I, N-L+J ) END DO END DO CALL DTRMM( 'R', 'L', 'T', 'N', M, L, ONE, V( 1, NP ), LDV, $ WORK, LDWORK ) CALL DGEMM( 'N', 'T', M, L, N-L, ONE, B, LDB, V, LDV, $ ONE, WORK, LDWORK ) CALL DGEMM( 'N', 'T', M, K-L, N, ONE, B, LDB, $ V( KP, 1 ), LDV, ZERO, WORK( 1, KP ), LDWORK ) * DO J = 1, K DO I = 1, M WORK( I, J ) = WORK( I, J ) + A( I, J ) END DO END DO * CALL DTRMM( 'R', 'U', TRANS, 'N', M, K, ONE, T, LDT, $ WORK, LDWORK ) * DO J = 1, K DO I = 1, M A( I, J ) = A( I, J ) - WORK( I, J ) END DO END DO * CALL DGEMM( 'N', 'N', M, N-L, K, -ONE, WORK, LDWORK, $ V, LDV, ONE, B, LDB ) CALL DGEMM( 'N', 'N', M, L, K-L, -ONE, WORK( 1, KP ), LDWORK, $ V( KP, NP ), LDV, ONE, B( 1, NP ), LDB ) CALL DTRMM( 'R', 'L', 'N', 'N', M, L, ONE, V( 1, NP ), LDV, $ WORK, LDWORK ) DO J = 1, L DO I = 1, M B( I, N-L+J ) = B( I, N-L+J ) - WORK( I, J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( ROW .AND. BACKWARD .AND. LEFT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ V I ] ( I is K-by-K, V is K-by-M ) * * Form H C or H**T C where C = [ B ] (M-by-N) * [ A ] (K-by-N) * * H = I - W**T T W or H**T = I - W**T T**T W * * A = A - T (A + V B) or A = A - T**T (A + V B) * B = B - V**T T (A + V B) or B = B - V**T T**T (A + V B) * * --------------------------------------------------------------------------- * MP = MIN( L+1, M ) KP = MIN( K-L+1, K ) * DO J = 1, N DO I = 1, L WORK( K-L+I, J ) = B( I, J ) END DO END DO CALL DTRMM( 'L', 'U', 'N', 'N', L, N, ONE, V( KP, 1 ), LDV, $ WORK( KP, 1 ), LDWORK ) CALL DGEMM( 'N', 'N', L, N, M-L, ONE, V( KP, MP ), LDV, $ B( MP, 1 ), LDB, ONE, WORK( KP, 1 ), LDWORK ) CALL DGEMM( 'N', 'N', K-L, N, M, ONE, V, LDV, B, LDB, $ ZERO, WORK, LDWORK ) * DO J = 1, N DO I = 1, K WORK( I, J ) = WORK( I, J ) + A( I, J ) END DO END DO * CALL DTRMM( 'L', 'L ', TRANS, 'N', K, N, ONE, T, LDT, $ WORK, LDWORK ) * DO J = 1, N DO I = 1, K A( I, J ) = A( I, J ) - WORK( I, J ) END DO END DO * CALL DGEMM( 'T', 'N', M-L, N, K, -ONE, V( 1, MP ), LDV, $ WORK, LDWORK, ONE, B( MP, 1 ), LDB ) CALL DGEMM( 'T', 'N', L, N, K-L, -ONE, V, LDV, $ WORK, LDWORK, ONE, B, LDB ) CALL DTRMM( 'L', 'U', 'T', 'N', L, N, ONE, V( KP, 1 ), LDV, $ WORK( KP, 1 ), LDWORK ) DO J = 1, N DO I = 1, L B( I, J ) = B( I, J ) - WORK( K-L+I, J ) END DO END DO * * --------------------------------------------------------------------------- * ELSE IF( ROW .AND. BACKWARD .AND. RIGHT ) THEN * * --------------------------------------------------------------------------- * * Let W = [ V I ] ( I is K-by-K, V is K-by-N ) * * Form C H or C H**T where C = [ B A ] (A is M-by-K, B is M-by-N) * * H = I - W**T T W or H**T = I - W**T T**T W * * A = A - (A + B V**T) T or A = A - (A + B V**T) T**T * B = B - (A + B V**T) T V or B = B - (A + B V**T) T**T V * * --------------------------------------------------------------------------- * NP = MIN( L+1, N ) KP = MIN( K-L+1, K ) * DO J = 1, L DO I = 1, M WORK( I, K-L+J ) = B( I, J ) END DO END DO CALL DTRMM( 'R', 'U', 'T', 'N', M, L, ONE, V( KP, 1 ), LDV, $ WORK( 1, KP ), LDWORK ) CALL DGEMM( 'N', 'T', M, L, N-L, ONE, B( 1, NP ), LDB, $ V( KP, NP ), LDV, ONE, WORK( 1, KP ), LDWORK ) CALL DGEMM( 'N', 'T', M, K-L, N, ONE, B, LDB, V, LDV, $ ZERO, WORK, LDWORK ) * DO J = 1, K DO I = 1, M WORK( I, J ) = WORK( I, J ) + A( I, J ) END DO END DO * CALL DTRMM( 'R', 'L', TRANS, 'N', M, K, ONE, T, LDT, $ WORK, LDWORK ) * DO J = 1, K DO I = 1, M A( I, J ) = A( I, J ) - WORK( I, J ) END DO END DO * CALL DGEMM( 'N', 'N', M, N-L, K, -ONE, WORK, LDWORK, $ V( 1, NP ), LDV, ONE, B( 1, NP ), LDB ) CALL DGEMM( 'N', 'N', M, L, K-L , -ONE, WORK, LDWORK, $ V, LDV, ONE, B, LDB ) CALL DTRMM( 'R', 'U', 'N', 'N', M, L, ONE, V( KP, 1 ), LDV, $ WORK( 1, KP ), LDWORK ) DO J = 1, L DO I = 1, M B( I, J ) = B( I, J ) - WORK( I, K-L+J ) END DO END DO * END IF * RETURN * * End of DTPRFB * END *> \brief \b DTPRFS * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTPRFS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, * FERR, BERR, WORK, IWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, LDB, LDX, N, NRHS * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION AP( * ), B( LDB, * ), BERR( * ), FERR( * ), * $ WORK( * ), X( LDX, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTPRFS provides error bounds and backward error estimates for the *> solution to a system of linear equations with a triangular packed *> coefficient matrix. *> *> The solution matrix X must be computed by DTPTRS or some other *> means before entering this routine. DTPRFS does not do iterative *> refinement because doing so cannot improve the backward error. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': A is upper triangular; *> = 'L': A is lower triangular. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is 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) *> \endverbatim *> *> \param[in] DIAG *> \verbatim *> DIAG is CHARACTER*1 *> = 'N': A is non-unit triangular; *> = 'U': A is unit triangular. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrices B and X. NRHS >= 0. *> \endverbatim *> *> \param[in] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> The upper or lower triangular matrix A, packed columnwise in *> a linear array. The j-th column of A is stored in the array *> AP as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. *> If DIAG = 'U', the diagonal elements of A are not referenced *> and are assumed to be 1. *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> The right hand side matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,NRHS) *> The solution matrix X. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the array X. LDX >= max(1,N). *> \endverbatim *> *> \param[out] FERR *> \verbatim *> FERR is 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. *> \endverbatim *> *> \param[out] BERR *> \verbatim *> BERR is 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). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, $ FERR, BERR, WORK, IWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO INTEGER INFO, LDB, LDX, N, NRHS * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION AP( * ), B( LDB, * ), BERR( * ), FERR( * ), $ WORK( * ), X( LDX, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOTRAN, NOUNIT, UPPER CHARACTER TRANST INTEGER I, J, K, KASE, KC, NZ DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) * .. * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DLACN2, DTPMV, DTPSV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL LSAME, DLAMCH * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) NOTRAN = LSAME( TRANS, 'N' ) NOUNIT = LSAME( DIAG, 'N' ) * IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. $ LSAME( TRANS, 'C' ) ) THEN INFO = -2 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( NRHS.LT.0 ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTPRFS', -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 250 J = 1, NRHS * * Compute residual R = B - op(A) * X, * where op(A) = A or A**T, depending on TRANS. * CALL DCOPY( N, X( 1, J ), 1, WORK( N+1 ), 1 ) CALL DTPMV( UPLO, TRANS, DIAG, N, AP, WORK( N+1 ), 1 ) CALL DAXPY( N, -ONE, B( 1, J ), 1, 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 20 I = 1, N WORK( I ) = ABS( B( I, J ) ) 20 CONTINUE * IF( NOTRAN ) THEN * * Compute abs(A)*abs(X) + abs(B). * IF( UPPER ) THEN KC = 1 IF( NOUNIT ) THEN DO 40 K = 1, N XK = ABS( X( K, J ) ) DO 30 I = 1, K WORK( I ) = WORK( I ) + ABS( AP( KC+I-1 ) )*XK 30 CONTINUE KC = KC + K 40 CONTINUE ELSE DO 60 K = 1, N XK = ABS( X( K, J ) ) DO 50 I = 1, K - 1 WORK( I ) = WORK( I ) + ABS( AP( KC+I-1 ) )*XK 50 CONTINUE WORK( K ) = WORK( K ) + XK KC = KC + K 60 CONTINUE END IF ELSE KC = 1 IF( NOUNIT ) THEN DO 80 K = 1, N XK = ABS( X( K, J ) ) DO 70 I = K, N WORK( I ) = WORK( I ) + ABS( AP( KC+I-K ) )*XK 70 CONTINUE KC = KC + N - K + 1 80 CONTINUE ELSE DO 100 K = 1, N XK = ABS( X( K, J ) ) DO 90 I = K + 1, N WORK( I ) = WORK( I ) + ABS( AP( KC+I-K ) )*XK 90 CONTINUE WORK( K ) = WORK( K ) + XK KC = KC + N - K + 1 100 CONTINUE END IF END IF ELSE * * Compute abs(A**T)*abs(X) + abs(B). * IF( UPPER ) THEN KC = 1 IF( NOUNIT ) THEN DO 120 K = 1, N S = ZERO DO 110 I = 1, K S = S + ABS( AP( KC+I-1 ) )*ABS( X( I, J ) ) 110 CONTINUE WORK( K ) = WORK( K ) + S KC = KC + K 120 CONTINUE ELSE DO 140 K = 1, N S = ABS( X( K, J ) ) DO 130 I = 1, K - 1 S = S + ABS( AP( KC+I-1 ) )*ABS( X( I, J ) ) 130 CONTINUE WORK( K ) = WORK( K ) + S KC = KC + K 140 CONTINUE END IF ELSE KC = 1 IF( NOUNIT ) THEN DO 160 K = 1, N S = ZERO DO 150 I = K, N S = S + ABS( AP( KC+I-K ) )*ABS( X( I, J ) ) 150 CONTINUE WORK( K ) = WORK( K ) + S KC = KC + N - K + 1 160 CONTINUE ELSE DO 180 K = 1, N S = ABS( X( K, J ) ) DO 170 I = K + 1, N S = S + ABS( AP( KC+I-K ) )*ABS( X( I, J ) ) 170 CONTINUE WORK( K ) = WORK( K ) + S KC = KC + N - K + 1 180 CONTINUE END IF END IF END IF S = ZERO DO 190 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 190 CONTINUE BERR( J ) = S * * 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 200 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 200 CONTINUE * KASE = 0 210 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 DTPSV( UPLO, TRANST, DIAG, N, AP, WORK( N+1 ), 1 ) DO 220 I = 1, N WORK( N+I ) = WORK( I )*WORK( N+I ) 220 CONTINUE ELSE * * Multiply by inv(op(A))*diag(W). * DO 230 I = 1, N WORK( N+I ) = WORK( I )*WORK( N+I ) 230 CONTINUE CALL DTPSV( UPLO, TRANS, DIAG, N, AP, WORK( N+1 ), 1 ) END IF GO TO 210 END IF * * Normalize error. * LSTRES = ZERO DO 240 I = 1, N LSTRES = MAX( LSTRES, ABS( X( I, J ) ) ) 240 CONTINUE IF( LSTRES.NE.ZERO ) $ FERR( J ) = FERR( J ) / LSTRES * 250 CONTINUE * RETURN * * End of DTPRFS * END *> \brief \b DTPTRI * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTPTRI + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTPTRI( UPLO, DIAG, N, AP, INFO ) * * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER INFO, N * .. * .. Array Arguments .. * DOUBLE PRECISION AP( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTPTRI computes the inverse of a real upper or lower triangular *> matrix A stored in packed format. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': A is upper triangular; *> = 'L': A is lower triangular. *> \endverbatim *> *> \param[in] DIAG *> \verbatim *> DIAG is CHARACTER*1 *> = 'N': A is non-unit triangular; *> = 'U': A is unit triangular. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> On entry, the upper or lower triangular matrix A, stored *> columnwise in a linear array. The j-th column of A is stored *> in the array AP as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n. *> See below for further details. *> On exit, the (triangular) inverse of the original matrix, in *> the same packed storage format. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, A(i,i) is exactly zero. The triangular *> matrix is singular and its inverse can not be computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> A triangular matrix A can be transferred to packed storage using one *> of the following program segments: *> *> UPLO = 'U': UPLO = 'L': *> *> JC = 1 JC = 1 *> DO 2 J = 1, N DO 2 J = 1, N *> DO 1 I = 1, J DO 1 I = J, N *> AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J) *> 1 CONTINUE 1 CONTINUE *> JC = JC + J JC = JC + N - J + 1 *> 2 CONTINUE 2 CONTINUE *> \endverbatim *> * ===================================================================== SUBROUTINE DTPTRI( UPLO, DIAG, N, AP, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO INTEGER INFO, N * .. * .. Array Arguments .. DOUBLE PRECISION AP( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOUNIT, UPPER INTEGER J, JC, JCLAST, JJ DOUBLE PRECISION AJJ * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DSCAL, DTPMV, XERBLA * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) NOUNIT = LSAME( DIAG, 'N' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTPTRI', -INFO ) RETURN END IF * * Check for singularity if non-unit. * IF( NOUNIT ) THEN IF( UPPER ) THEN JJ = 0 DO 10 INFO = 1, N JJ = JJ + INFO IF( AP( JJ ).EQ.ZERO ) $ RETURN 10 CONTINUE ELSE JJ = 1 DO 20 INFO = 1, N IF( AP( JJ ).EQ.ZERO ) $ RETURN JJ = JJ + N - INFO + 1 20 CONTINUE END IF INFO = 0 END IF * IF( UPPER ) THEN * * Compute inverse of upper triangular matrix. * JC = 1 DO 30 J = 1, N IF( NOUNIT ) THEN AP( JC+J-1 ) = ONE / AP( JC+J-1 ) AJJ = -AP( JC+J-1 ) ELSE AJJ = -ONE END IF * * Compute elements 1:j-1 of j-th column. * CALL DTPMV( 'Upper', 'No transpose', DIAG, J-1, AP, $ AP( JC ), 1 ) CALL DSCAL( J-1, AJJ, AP( JC ), 1 ) JC = JC + J 30 CONTINUE * ELSE * * Compute inverse of lower triangular matrix. * JC = N*( N+1 ) / 2 DO 40 J = N, 1, -1 IF( NOUNIT ) THEN AP( JC ) = ONE / AP( JC ) AJJ = -AP( JC ) ELSE AJJ = -ONE END IF IF( J.LT.N ) THEN * * Compute elements j+1:n of j-th column. * CALL DTPMV( 'Lower', 'No transpose', DIAG, N-J, $ AP( JCLAST ), AP( JC+1 ), 1 ) CALL DSCAL( N-J, AJJ, AP( JC+1 ), 1 ) END IF JCLAST = JC JC = JC - N + J - 2 40 CONTINUE END IF * RETURN * * End of DTPTRI * END *> \brief \b DTPTRS * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTPTRS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO ) * * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. * DOUBLE PRECISION AP( * ), B( LDB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTPTRS solves a triangular system of the form *> *> A * X = B or A**T * X = B, *> *> where A is a triangular matrix of order N stored in packed format, *> and B is an N-by-NRHS matrix. A check is made to verify that A is *> nonsingular. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': A is upper triangular; *> = 'L': A is lower triangular. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is 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) *> \endverbatim *> *> \param[in] DIAG *> \verbatim *> DIAG is CHARACTER*1 *> = 'N': A is non-unit triangular; *> = 'U': A is unit triangular. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrix B. NRHS >= 0. *> \endverbatim *> *> \param[in] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> The upper or lower triangular matrix A, packed columnwise in *> a linear array. The j-th column of A is stored in the array *> AP as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> On entry, the right hand side matrix B. *> On exit, if INFO = 0, the solution matrix X. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, the i-th diagonal element of A is zero, *> indicating that the matrix is singular and the *> solutions X have not been computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. DOUBLE PRECISION AP( * ), B( LDB, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOUNIT, UPPER INTEGER J, JC * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DTPSV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) NOUNIT = LSAME( DIAG, 'N' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT. $ LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN INFO = -2 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( NRHS.LT.0 ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTPTRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Check for singularity. * IF( NOUNIT ) THEN IF( UPPER ) THEN JC = 1 DO 10 INFO = 1, N IF( AP( JC+INFO-1 ).EQ.ZERO ) $ RETURN JC = JC + INFO 10 CONTINUE ELSE JC = 1 DO 20 INFO = 1, N IF( AP( JC ).EQ.ZERO ) $ RETURN JC = JC + N - INFO + 1 20 CONTINUE END IF END IF INFO = 0 * * Solve A * x = b or A**T * x = b. * DO 30 J = 1, NRHS CALL DTPSV( UPLO, TRANS, DIAG, N, AP, B( 1, J ), 1 ) 30 CONTINUE * RETURN * * End of DTPTRS * END *> \brief \b DTPTTF copies a triangular matrix from the standard packed format (TP) to the rectangular full packed format (TF). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTPTTF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTPTTF( TRANSR, UPLO, N, AP, ARF, INFO ) * * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER INFO, N * .. * .. Array Arguments .. * DOUBLE PRECISION AP( 0: * ), ARF( 0: * ) * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTPTTF copies a triangular matrix A from standard packed format (TP) *> to rectangular full packed format (TF). *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANSR *> \verbatim *> TRANSR is CHARACTER*1 *> = 'N': ARF in Normal format is wanted; *> = 'T': ARF in Conjugate-transpose format is wanted. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': A is upper triangular; *> = 'L': A is lower triangular. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), *> On entry, the upper or lower triangular matrix A, packed *> columnwise in a linear array. The j-th column of A is stored *> in the array AP as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. *> \endverbatim *> *> \param[out] ARF *> \verbatim *> ARF is DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), *> On exit, the upper or lower triangular matrix A stored in *> RFP format. For a further discussion see Notes below. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> We first consider Rectangular Full Packed (RFP) Format when N is *> even. We give an example where N = 6. *> *> AP is Upper AP is Lower *> *> 00 01 02 03 04 05 00 *> 11 12 13 14 15 10 11 *> 22 23 24 25 20 21 22 *> 33 34 35 30 31 32 33 *> 44 45 40 41 42 43 44 *> 55 50 51 52 53 54 55 *> *> *> Let TRANSR = 'N'. RFP holds AP as follows: *> For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last *> three columns of AP upper. The lower triangle A(4:6,0:2) consists of *> the transpose of the first three columns of AP upper. *> For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first *> three columns of AP lower. The upper triangle A(0:2,0:2) consists of *> the transpose of the last three columns of AP lower. *> This covers the case N even and TRANSR = 'N'. *> *> RFP A RFP A *> *> 03 04 05 33 43 53 *> 13 14 15 00 44 54 *> 23 24 25 10 11 55 *> 33 34 35 20 21 22 *> 00 44 45 30 31 32 *> 01 11 55 40 41 42 *> 02 12 22 50 51 52 *> *> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the *> transpose of RFP A above. One therefore gets: *> *> *> RFP A RFP A *> *> 03 13 23 33 00 01 02 33 00 10 20 30 40 50 *> 04 14 24 34 44 11 12 43 44 11 21 31 41 51 *> 05 15 25 35 45 55 22 53 54 55 22 32 42 52 *> *> *> We then consider Rectangular Full Packed (RFP) Format when N is *> odd. We give an example where N = 5. *> *> AP is Upper AP is Lower *> *> 00 01 02 03 04 00 *> 11 12 13 14 10 11 *> 22 23 24 20 21 22 *> 33 34 30 31 32 33 *> 44 40 41 42 43 44 *> *> *> Let TRANSR = 'N'. RFP holds AP as follows: *> For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last *> three columns of AP upper. The lower triangle A(3:4,0:1) consists of *> the transpose of the first two columns of AP upper. *> For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first *> three columns of AP lower. The upper triangle A(0:1,1:2) consists of *> the transpose of the last two columns of AP lower. *> This covers the case N odd and TRANSR = 'N'. *> *> RFP A RFP A *> *> 02 03 04 00 33 43 *> 12 13 14 10 11 44 *> 22 23 24 20 21 22 *> 00 33 34 30 31 32 *> 01 11 44 40 41 42 *> *> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the *> transpose of RFP A above. One therefore gets: *> *> RFP A RFP A *> *> 02 12 22 00 01 00 10 20 30 40 50 *> 03 13 23 33 11 33 11 21 31 41 51 *> 04 14 24 34 44 43 44 22 32 42 52 *> \endverbatim *> * ===================================================================== SUBROUTINE DTPTTF( TRANSR, UPLO, N, AP, ARF, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO INTEGER INFO, N * .. * .. Array Arguments .. DOUBLE PRECISION AP( 0: * ), ARF( 0: * ) * * ===================================================================== * * .. Parameters .. * .. * .. Local Scalars .. LOGICAL LOWER, NISODD, NORMALTRANSR INTEGER N1, N2, K, NT INTEGER I, J, IJ INTEGER IJP, JP, LDA, JS * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MOD * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 NORMALTRANSR = LSAME( TRANSR, 'N' ) LOWER = LSAME( UPLO, 'L' ) IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN INFO = -1 ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTPTTF', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( N.EQ.1 ) THEN IF( NORMALTRANSR ) THEN ARF( 0 ) = AP( 0 ) ELSE ARF( 0 ) = AP( 0 ) END IF RETURN END IF * * Size of array ARF(0:NT-1) * NT = N*( N+1 ) / 2 * * Set N1 and N2 depending on LOWER * IF( LOWER ) THEN N2 = N / 2 N1 = N - N2 ELSE N1 = N / 2 N2 = N - N1 END IF * * If N is odd, set NISODD = .TRUE. * If N is even, set K = N/2 and NISODD = .FALSE. * * set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe) * where noe = 0 if n is even, noe = 1 if n is odd * IF( MOD( N, 2 ).EQ.0 ) THEN K = N / 2 NISODD = .FALSE. LDA = N + 1 ELSE NISODD = .TRUE. LDA = N END IF * * ARF^C has lda rows and n+1-noe cols * IF( .NOT.NORMALTRANSR ) $ LDA = ( N+1 ) / 2 * * start execution: there are eight cases * IF( NISODD ) THEN * * N is odd * IF( NORMALTRANSR ) THEN * * N is odd and TRANSR = 'N' * IF( LOWER ) THEN * * N is odd, TRANSR = 'N', and UPLO = 'L' * IJP = 0 JP = 0 DO J = 0, N2 DO I = J, N - 1 IJ = I + JP ARF( IJ ) = AP( IJP ) IJP = IJP + 1 END DO JP = JP + LDA END DO DO I = 0, N2 - 1 DO J = 1 + I, N2 IJ = I + J*LDA ARF( IJ ) = AP( IJP ) IJP = IJP + 1 END DO END DO * ELSE * * N is odd, TRANSR = 'N', and UPLO = 'U' * IJP = 0 DO J = 0, N1 - 1 IJ = N2 + J DO I = 0, J ARF( IJ ) = AP( IJP ) IJP = IJP + 1 IJ = IJ + LDA END DO END DO JS = 0 DO J = N1, N - 1 IJ = JS DO IJ = JS, JS + J ARF( IJ ) = AP( IJP ) IJP = IJP + 1 END DO JS = JS + LDA END DO * END IF * ELSE * * N is odd and TRANSR = 'T' * IF( LOWER ) THEN * * N is odd, TRANSR = 'T', and UPLO = 'L' * IJP = 0 DO I = 0, N2 DO IJ = I*( LDA+1 ), N*LDA - 1, LDA ARF( IJ ) = AP( IJP ) IJP = IJP + 1 END DO END DO JS = 1 DO J = 0, N2 - 1 DO IJ = JS, JS + N2 - J - 1 ARF( IJ ) = AP( IJP ) IJP = IJP + 1 END DO JS = JS + LDA + 1 END DO * ELSE * * N is odd, TRANSR = 'T', and UPLO = 'U' * IJP = 0 JS = N2*LDA DO J = 0, N1 - 1 DO IJ = JS, JS + J ARF( IJ ) = AP( IJP ) IJP = IJP + 1 END DO JS = JS + LDA END DO DO I = 0, N1 DO IJ = I, I + ( N1+I )*LDA, LDA ARF( IJ ) = AP( IJP ) IJP = IJP + 1 END DO END DO * END IF * END IF * ELSE * * N is even * IF( NORMALTRANSR ) THEN * * N is even and TRANSR = 'N' * IF( LOWER ) THEN * * N is even, TRANSR = 'N', and UPLO = 'L' * IJP = 0 JP = 0 DO J = 0, K - 1 DO I = J, N - 1 IJ = 1 + I + JP ARF( IJ ) = AP( IJP ) IJP = IJP + 1 END DO JP = JP + LDA END DO DO I = 0, K - 1 DO J = I, K - 1 IJ = I + J*LDA ARF( IJ ) = AP( IJP ) IJP = IJP + 1 END DO END DO * ELSE * * N is even, TRANSR = 'N', and UPLO = 'U' * IJP = 0 DO J = 0, K - 1 IJ = K + 1 + J DO I = 0, J ARF( IJ ) = AP( IJP ) IJP = IJP + 1 IJ = IJ + LDA END DO END DO JS = 0 DO J = K, N - 1 IJ = JS DO IJ = JS, JS + J ARF( IJ ) = AP( IJP ) IJP = IJP + 1 END DO JS = JS + LDA END DO * END IF * ELSE * * N is even and TRANSR = 'T' * IF( LOWER ) THEN * * N is even, TRANSR = 'T', and UPLO = 'L' * IJP = 0 DO I = 0, K - 1 DO IJ = I + ( I+1 )*LDA, ( N+1 )*LDA - 1, LDA ARF( IJ ) = AP( IJP ) IJP = IJP + 1 END DO END DO JS = 0 DO J = 0, K - 1 DO IJ = JS, JS + K - J - 1 ARF( IJ ) = AP( IJP ) IJP = IJP + 1 END DO JS = JS + LDA + 1 END DO * ELSE * * N is even, TRANSR = 'T', and UPLO = 'U' * IJP = 0 JS = ( K+1 )*LDA DO J = 0, K - 1 DO IJ = JS, JS + J ARF( IJ ) = AP( IJP ) IJP = IJP + 1 END DO JS = JS + LDA END DO DO I = 0, K - 1 DO IJ = I, I + ( K+I )*LDA, LDA ARF( IJ ) = AP( IJP ) IJP = IJP + 1 END DO END DO * END IF * END IF * END IF * RETURN * * End of DTPTTF * END *> \brief \b DTPTTR copies a triangular matrix from the standard packed format (TP) to the standard full format (TR). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTPTTR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTPTTR( UPLO, N, AP, A, LDA, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N, LDA * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), AP( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTPTTR copies a triangular matrix A from standard packed format (TP) *> to standard full format (TR). *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': A is upper triangular. *> = 'L': A is lower triangular. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), *> On entry, the upper or lower triangular matrix A, packed *> columnwise in a linear array. The j-th column of A is stored *> in the array AP as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. *> \endverbatim *> *> \param[out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension ( LDA, N ) *> On exit, the triangular matrix A. If UPLO = 'U', the leading *> N-by-N upper triangular part of A contains the upper *> triangular part of the matrix A, and the strictly lower *> triangular part of A is not referenced. If UPLO = 'L', the *> leading N-by-N lower triangular part of A contains the lower *> triangular part of the matrix A, and the strictly upper *> triangular part of A is not referenced. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DTPTTR( UPLO, N, AP, A, LDA, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, N, LDA * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), AP( * ) * .. * * ===================================================================== * * .. Parameters .. * .. * .. Local Scalars .. LOGICAL LOWER INTEGER I, J, K * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 LOWER = LSAME( UPLO, 'L' ) IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTPTTR', -INFO ) RETURN END IF * IF( LOWER ) THEN K = 0 DO J = 1, N DO I = J, N K = K + 1 A( I, J ) = AP( K ) END DO END DO ELSE K = 0 DO J = 1, N DO I = 1, J K = K + 1 A( I, J ) = AP( K ) END DO END DO END IF * * RETURN * * End of DTPTTR * END *> \brief \b DTRCON * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTRCON + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, * IWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER DIAG, NORM, UPLO * INTEGER INFO, LDA, N * DOUBLE PRECISION RCOND * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTRCON estimates the reciprocal of the condition number of a *> triangular matrix A, in either the 1-norm or the infinity-norm. *> *> The norm of A is computed and an estimate is obtained for *> norm(inv(A)), then the reciprocal of the condition number is *> computed as *> RCOND = 1 / ( norm(A) * norm(inv(A)) ). *> \endverbatim * * Arguments: * ========== * *> \param[in] NORM *> \verbatim *> NORM is 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. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': A is upper triangular; *> = 'L': A is lower triangular. *> \endverbatim *> *> \param[in] DIAG *> \verbatim *> DIAG is CHARACTER*1 *> = 'N': A is non-unit triangular; *> = 'U': A is unit triangular. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The triangular matrix A. If UPLO = 'U', the leading N-by-N *> upper triangular part of the array A contains the upper *> triangular matrix, and the strictly lower triangular part of *> A is not referenced. If UPLO = 'L', the leading N-by-N lower *> triangular part of the array A contains the lower triangular *> matrix, and the strictly upper triangular part of A is not *> referenced. If DIAG = 'U', the diagonal elements of A are *> also not referenced and are assumed to be 1. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] RCOND *> \verbatim *> RCOND is DOUBLE PRECISION *> The reciprocal of the condition number of the matrix A, *> computed as RCOND = 1/(norm(A) * norm(inv(A))). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, $ IWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO INTEGER INFO, LDA, N DOUBLE PRECISION RCOND * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOUNIT, ONENRM, UPPER CHARACTER NORMIN INTEGER IX, KASE, KASE1 DOUBLE PRECISION AINVNM, ANORM, SCALE, SMLNUM, XNORM * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DLANTR EXTERNAL LSAME, IDAMAX, DLAMCH, DLANTR * .. * .. External Subroutines .. EXTERNAL DLACN2, DLATRS, DRSCL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' ) NOUNIT = LSAME( DIAG, 'N' ) * IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN INFO = -1 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -2 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTRCON', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN RCOND = ONE RETURN END IF * RCOND = ZERO SMLNUM = DLAMCH( 'Safe minimum' )*DBLE( MAX( 1, N ) ) * * Compute the norm of the triangular matrix A. * ANORM = DLANTR( NORM, UPLO, DIAG, N, N, A, LDA, WORK ) * * Continue only if ANORM > 0. * IF( ANORM.GT.ZERO ) THEN * * Estimate the norm of the inverse of 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(A). * CALL DLATRS( UPLO, 'No transpose', DIAG, NORMIN, N, A, $ LDA, WORK, SCALE, WORK( 2*N+1 ), INFO ) ELSE * * Multiply by inv(A**T). * CALL DLATRS( UPLO, 'Transpose', DIAG, NORMIN, N, A, LDA, $ WORK, SCALE, WORK( 2*N+1 ), INFO ) END IF NORMIN = 'Y' * * Multiply by 1/SCALE if doing so will not cause overflow. * IF( SCALE.NE.ONE ) THEN IX = IDAMAX( N, WORK, 1 ) XNORM = ABS( WORK( IX ) ) IF( SCALE.LT.XNORM*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 / ANORM ) / AINVNM END IF * 20 CONTINUE RETURN * * End of DTRCON * END *> \brief \b DTREVC * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTREVC + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, * LDVR, MM, M, WORK, INFO ) * * .. Scalar Arguments .. * CHARACTER HOWMNY, SIDE * INTEGER INFO, LDT, LDVL, LDVR, M, MM, N * .. * .. Array Arguments .. * LOGICAL SELECT( * ) * DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTREVC computes some or all of the right and/or left eigenvectors of *> a real upper quasi-triangular matrix T. *> Matrices of this type are produced by the Schur factorization of *> a real general matrix: A = Q*T*Q**T, as computed by DHSEQR. *> *> The right eigenvector x and the left eigenvector y of T corresponding *> to an eigenvalue w are defined by: *> *> T*x = w*x, (y**H)*T = w*(y**H) *> *> where y**H denotes the conjugate transpose of y. *> The eigenvalues are not input to this routine, but are read directly *> from the diagonal blocks of T. *> *> This routine returns the matrices X and/or Y of right and left *> eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an *> input matrix. If Q is the orthogonal factor that reduces a matrix *> A to Schur form T, then Q*X and Q*Y are the matrices of right and *> left eigenvectors of A. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'R': compute right eigenvectors only; *> = 'L': compute left eigenvectors only; *> = 'B': compute both right and left eigenvectors. *> \endverbatim *> *> \param[in] HOWMNY *> \verbatim *> HOWMNY is CHARACTER*1 *> = 'A': compute all right and/or left eigenvectors; *> = 'B': compute all right and/or left eigenvectors, *> backtransformed by the matrices in VR and/or VL; *> = 'S': compute selected right and/or left eigenvectors, *> as indicated by the logical array SELECT. *> \endverbatim *> *> \param[in,out] SELECT *> \verbatim *> SELECT is LOGICAL array, dimension (N) *> If HOWMNY = 'S', SELECT specifies the eigenvectors to be *> computed. *> If w(j) is a real eigenvalue, the corresponding real *> eigenvector is computed if SELECT(j) is .TRUE.. *> If w(j) and w(j+1) are the real and imaginary parts of a *> complex eigenvalue, the corresponding complex eigenvector is *> computed if either SELECT(j) or SELECT(j+1) is .TRUE., and *> on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to *> .FALSE.. *> Not referenced if HOWMNY = 'A' or 'B'. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix T. N >= 0. *> \endverbatim *> *> \param[in] T *> \verbatim *> T is DOUBLE PRECISION array, dimension (LDT,N) *> The upper quasi-triangular matrix T in Schur canonical form. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= max(1,N). *> \endverbatim *> *> \param[in,out] VL *> \verbatim *> VL is DOUBLE PRECISION array, dimension (LDVL,MM) *> On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must *> contain an N-by-N matrix Q (usually the orthogonal matrix Q *> of Schur vectors returned by DHSEQR). *> On exit, if SIDE = 'L' or 'B', VL contains: *> if HOWMNY = 'A', the matrix Y of left eigenvectors of T; *> if HOWMNY = 'B', the matrix Q*Y; *> if HOWMNY = 'S', the left eigenvectors of T specified by *> SELECT, stored consecutively in the columns *> of VL, in the same order as their *> eigenvalues. *> A complex eigenvector corresponding to a complex eigenvalue *> is stored in two consecutive columns, the first holding the *> real part, and the second the imaginary part. *> Not referenced if SIDE = 'R'. *> \endverbatim *> *> \param[in] LDVL *> \verbatim *> LDVL is INTEGER *> The leading dimension of the array VL. LDVL >= 1, and if *> SIDE = 'L' or 'B', LDVL >= N. *> \endverbatim *> *> \param[in,out] VR *> \verbatim *> VR is DOUBLE PRECISION array, dimension (LDVR,MM) *> On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must *> contain an N-by-N matrix Q (usually the orthogonal matrix Q *> of Schur vectors returned by DHSEQR). *> On exit, if SIDE = 'R' or 'B', VR contains: *> if HOWMNY = 'A', the matrix X of right eigenvectors of T; *> if HOWMNY = 'B', the matrix Q*X; *> if HOWMNY = 'S', the right eigenvectors of T specified by *> SELECT, stored consecutively in the columns *> of VR, in the same order as their *> eigenvalues. *> A complex eigenvector corresponding to a complex eigenvalue *> is stored in two consecutive columns, the first holding the *> real part and the second the imaginary part. *> Not referenced if SIDE = 'L'. *> \endverbatim *> *> \param[in] LDVR *> \verbatim *> LDVR is INTEGER *> The leading dimension of the array VR. LDVR >= 1, and if *> SIDE = 'R' or 'B', LDVR >= N. *> \endverbatim *> *> \param[in] MM *> \verbatim *> MM is INTEGER *> The number of columns in the arrays VL and/or VR. MM >= M. *> \endverbatim *> *> \param[out] M *> \verbatim *> M is INTEGER *> The number of columns in the arrays VL and/or VR actually *> used to store the eigenvectors. *> If HOWMNY = 'A' or 'B', M is set to N. *> Each selected real eigenvector occupies one column and each *> selected complex eigenvector occupies two columns. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date November 2017 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The algorithm used in this program is basically backward (forward) *> substitution, with scaling to make the the code robust against *> possible overflow. *> *> 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|. *> \endverbatim *> * ===================================================================== SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, MM, M, WORK, INFO ) * * -- LAPACK computational routine (version 3.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE INTEGER INFO, LDT, LDVL, LDVR, M, MM, N * .. * .. Array Arguments .. LOGICAL SELECT( * ) DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), $ WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL ALLV, BOTHV, LEFTV, OVER, PAIR, RIGHTV, SOMEV INTEGER I, IERR, II, IP, IS, J, J1, J2, JNXT, K, KI, N2 DOUBLE PRECISION BETA, BIGNUM, EMAX, OVFL, REC, REMAX, SCALE, $ SMIN, SMLNUM, ULP, UNFL, VCRIT, VMAX, WI, WR, $ XNORM * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DDOT, DLAMCH EXTERNAL LSAME, IDAMAX, DDOT, DLAMCH * .. * .. External Subroutines .. EXTERNAL DLABAD, DAXPY, DCOPY, DGEMV, DLALN2, DSCAL, $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Local Arrays .. DOUBLE PRECISION X( 2, 2 ) * .. * .. Executable Statements .. * * Decode and test the input parameters * BOTHV = LSAME( SIDE, 'B' ) RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV * ALLV = LSAME( HOWMNY, 'A' ) OVER = LSAME( HOWMNY, 'B' ) SOMEV = LSAME( HOWMNY, 'S' ) * INFO = 0 IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN INFO = -1 ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN INFO = -8 ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN INFO = -10 ELSE * * Set M to the number of columns required to store the selected * eigenvectors, standardize the array SELECT if necessary, and * test MM. * IF( SOMEV ) THEN M = 0 PAIR = .FALSE. DO 10 J = 1, N IF( PAIR ) THEN PAIR = .FALSE. SELECT( J ) = .FALSE. ELSE IF( J.LT.N ) THEN IF( T( J+1, J ).EQ.ZERO ) THEN IF( SELECT( J ) ) $ M = M + 1 ELSE PAIR = .TRUE. IF( SELECT( J ) .OR. SELECT( J+1 ) ) THEN SELECT( J ) = .TRUE. M = M + 2 END IF END IF ELSE IF( SELECT( N ) ) $ M = M + 1 END IF END IF 10 CONTINUE ELSE M = N END IF * IF( MM.LT.M ) THEN INFO = -11 END IF END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTREVC', -INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * * Set the constants to control overflow. * UNFL = DLAMCH( 'Safe minimum' ) OVFL = ONE / UNFL CALL DLABAD( UNFL, OVFL ) ULP = DLAMCH( 'Precision' ) SMLNUM = UNFL*( N / ULP ) BIGNUM = ( ONE-ULP ) / SMLNUM * * Compute 1-norm of each column of strictly upper triangular * part of T to control overflow in triangular solver. * WORK( 1 ) = ZERO DO 30 J = 2, N WORK( J ) = ZERO DO 20 I = 1, J - 1 WORK( J ) = WORK( J ) + ABS( T( I, J ) ) 20 CONTINUE 30 CONTINUE * * Index IP is used to specify the real or complex eigenvalue: * IP = 0, real eigenvalue, * 1, first of conjugate complex pair: (wr,wi) * -1, second of conjugate complex pair: (wr,wi) * N2 = 2*N * IF( RIGHTV ) THEN * * Compute right eigenvectors. * IP = 0 IS = M DO 140 KI = N, 1, -1 * IF( IP.EQ.1 ) $ GO TO 130 IF( KI.EQ.1 ) $ GO TO 40 IF( T( KI, KI-1 ).EQ.ZERO ) $ GO TO 40 IP = -1 * 40 CONTINUE IF( SOMEV ) THEN IF( IP.EQ.0 ) THEN IF( .NOT.SELECT( KI ) ) $ GO TO 130 ELSE IF( .NOT.SELECT( KI-1 ) ) $ GO TO 130 END IF END IF * * Compute the KI-th eigenvalue (WR,WI). * WR = T( KI, KI ) WI = ZERO IF( IP.NE.0 ) $ WI = SQRT( ABS( T( KI, KI-1 ) ) )* $ SQRT( ABS( T( KI-1, KI ) ) ) SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM ) * IF( IP.EQ.0 ) THEN * * Real right eigenvector * WORK( KI+N ) = ONE * * Form right-hand side * DO 50 K = 1, KI - 1 WORK( K+N ) = -T( K, KI ) 50 CONTINUE * * Solve the upper quasi-triangular system: * (T(1:KI-1,1:KI-1) - WR)*X = SCALE*WORK. * JNXT = KI - 1 DO 60 J = KI - 1, 1, -1 IF( J.GT.JNXT ) $ GO TO 60 J1 = J J2 = J JNXT = J - 1 IF( J.GT.1 ) THEN IF( T( J, J-1 ).NE.ZERO ) THEN J1 = J - 1 JNXT = J - 2 END IF END IF * IF( J1.EQ.J2 ) THEN * * 1-by-1 diagonal block * CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+N ), N, WR, $ ZERO, X, 2, SCALE, XNORM, IERR ) * * Scale X(1,1) to avoid overflow when updating * the right-hand side. * IF( XNORM.GT.ONE ) THEN IF( WORK( J ).GT.BIGNUM / XNORM ) THEN X( 1, 1 ) = X( 1, 1 ) / XNORM SCALE = SCALE / XNORM END IF END IF * * Scale if necessary * IF( SCALE.NE.ONE ) $ CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) WORK( J+N ) = X( 1, 1 ) * * Update right-hand side * CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1, $ WORK( 1+N ), 1 ) * ELSE * * 2-by-2 diagonal block * CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, $ T( J-1, J-1 ), LDT, ONE, ONE, $ WORK( J-1+N ), N, WR, ZERO, X, 2, $ SCALE, XNORM, IERR ) * * Scale X(1,1) and X(2,1) to avoid overflow when * updating the right-hand side. * IF( XNORM.GT.ONE ) THEN BETA = MAX( WORK( J-1 ), WORK( J ) ) IF( BETA.GT.BIGNUM / XNORM ) THEN X( 1, 1 ) = X( 1, 1 ) / XNORM X( 2, 1 ) = X( 2, 1 ) / XNORM SCALE = SCALE / XNORM END IF END IF * * Scale if necessary * IF( SCALE.NE.ONE ) $ CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) WORK( J-1+N ) = X( 1, 1 ) WORK( J+N ) = X( 2, 1 ) * * Update right-hand side * CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, $ WORK( 1+N ), 1 ) CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1, $ WORK( 1+N ), 1 ) END IF 60 CONTINUE * * Copy the vector x or Q*x to VR and normalize. * IF( .NOT.OVER ) THEN CALL DCOPY( KI, WORK( 1+N ), 1, VR( 1, IS ), 1 ) * II = IDAMAX( KI, VR( 1, IS ), 1 ) REMAX = ONE / ABS( VR( II, IS ) ) CALL DSCAL( KI, REMAX, VR( 1, IS ), 1 ) * DO 70 K = KI + 1, N VR( K, IS ) = ZERO 70 CONTINUE ELSE IF( KI.GT.1 ) $ CALL DGEMV( 'N', N, KI-1, ONE, VR, LDVR, $ WORK( 1+N ), 1, WORK( KI+N ), $ VR( 1, KI ), 1 ) * II = IDAMAX( N, VR( 1, KI ), 1 ) REMAX = ONE / ABS( VR( II, KI ) ) CALL DSCAL( N, REMAX, VR( 1, KI ), 1 ) END IF * ELSE * * Complex right eigenvector. * * Initial solve * [ (T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I* WI)]*X = 0. * [ (T(KI,KI-1) T(KI,KI) ) ] * IF( ABS( T( KI-1, KI ) ).GE.ABS( T( KI, KI-1 ) ) ) THEN WORK( KI-1+N ) = ONE WORK( KI+N2 ) = WI / T( KI-1, KI ) ELSE WORK( KI-1+N ) = -WI / T( KI, KI-1 ) WORK( KI+N2 ) = ONE END IF WORK( KI+N ) = ZERO WORK( KI-1+N2 ) = ZERO * * Form right-hand side * DO 80 K = 1, KI - 2 WORK( K+N ) = -WORK( KI-1+N )*T( K, KI-1 ) WORK( K+N2 ) = -WORK( KI+N2 )*T( K, KI ) 80 CONTINUE * * Solve upper quasi-triangular system: * (T(1:KI-2,1:KI-2) - (WR+i*WI))*X = SCALE*(WORK+i*WORK2) * JNXT = KI - 2 DO 90 J = KI - 2, 1, -1 IF( J.GT.JNXT ) $ GO TO 90 J1 = J J2 = J JNXT = J - 1 IF( J.GT.1 ) THEN IF( T( J, J-1 ).NE.ZERO ) THEN J1 = J - 1 JNXT = J - 2 END IF END IF * IF( J1.EQ.J2 ) THEN * * 1-by-1 diagonal block * CALL DLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+N ), N, WR, WI, $ X, 2, SCALE, XNORM, IERR ) * * Scale X(1,1) and X(1,2) to avoid overflow when * updating the right-hand side. * IF( XNORM.GT.ONE ) THEN IF( WORK( J ).GT.BIGNUM / XNORM ) THEN X( 1, 1 ) = X( 1, 1 ) / XNORM X( 1, 2 ) = X( 1, 2 ) / XNORM SCALE = SCALE / XNORM END IF END IF * * Scale if necessary * IF( SCALE.NE.ONE ) THEN CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) CALL DSCAL( KI, SCALE, WORK( 1+N2 ), 1 ) END IF WORK( J+N ) = X( 1, 1 ) WORK( J+N2 ) = X( 1, 2 ) * * Update the right-hand side * CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1, $ WORK( 1+N ), 1 ) CALL DAXPY( J-1, -X( 1, 2 ), T( 1, J ), 1, $ WORK( 1+N2 ), 1 ) * ELSE * * 2-by-2 diagonal block * CALL DLALN2( .FALSE., 2, 2, SMIN, ONE, $ T( J-1, J-1 ), LDT, ONE, ONE, $ WORK( J-1+N ), N, WR, WI, X, 2, SCALE, $ XNORM, IERR ) * * Scale X to avoid overflow when updating * the right-hand side. * IF( XNORM.GT.ONE ) THEN BETA = MAX( WORK( J-1 ), WORK( J ) ) IF( BETA.GT.BIGNUM / XNORM ) THEN REC = ONE / XNORM X( 1, 1 ) = X( 1, 1 )*REC X( 1, 2 ) = X( 1, 2 )*REC X( 2, 1 ) = X( 2, 1 )*REC X( 2, 2 ) = X( 2, 2 )*REC SCALE = SCALE*REC END IF END IF * * Scale if necessary * IF( SCALE.NE.ONE ) THEN CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) CALL DSCAL( KI, SCALE, WORK( 1+N2 ), 1 ) END IF WORK( J-1+N ) = X( 1, 1 ) WORK( J+N ) = X( 2, 1 ) WORK( J-1+N2 ) = X( 1, 2 ) WORK( J+N2 ) = X( 2, 2 ) * * Update the right-hand side * CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, $ WORK( 1+N ), 1 ) CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1, $ WORK( 1+N ), 1 ) CALL DAXPY( J-2, -X( 1, 2 ), T( 1, J-1 ), 1, $ WORK( 1+N2 ), 1 ) CALL DAXPY( J-2, -X( 2, 2 ), T( 1, J ), 1, $ WORK( 1+N2 ), 1 ) END IF 90 CONTINUE * * Copy the vector x or Q*x to VR and normalize. * IF( .NOT.OVER ) THEN CALL DCOPY( KI, WORK( 1+N ), 1, VR( 1, IS-1 ), 1 ) CALL DCOPY( KI, WORK( 1+N2 ), 1, VR( 1, IS ), 1 ) * EMAX = ZERO DO 100 K = 1, KI EMAX = MAX( EMAX, ABS( VR( K, IS-1 ) )+ $ ABS( VR( K, IS ) ) ) 100 CONTINUE * REMAX = ONE / EMAX CALL DSCAL( KI, REMAX, VR( 1, IS-1 ), 1 ) CALL DSCAL( KI, REMAX, VR( 1, IS ), 1 ) * DO 110 K = KI + 1, N VR( K, IS-1 ) = ZERO VR( K, IS ) = ZERO 110 CONTINUE * ELSE * IF( KI.GT.2 ) THEN CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR, $ WORK( 1+N ), 1, WORK( KI-1+N ), $ VR( 1, KI-1 ), 1 ) CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR, $ WORK( 1+N2 ), 1, WORK( KI+N2 ), $ VR( 1, KI ), 1 ) ELSE CALL DSCAL( N, WORK( KI-1+N ), VR( 1, KI-1 ), 1 ) CALL DSCAL( N, WORK( KI+N2 ), VR( 1, KI ), 1 ) END IF * EMAX = ZERO DO 120 K = 1, N EMAX = MAX( EMAX, ABS( VR( K, KI-1 ) )+ $ ABS( VR( K, KI ) ) ) 120 CONTINUE REMAX = ONE / EMAX CALL DSCAL( N, REMAX, VR( 1, KI-1 ), 1 ) CALL DSCAL( N, REMAX, VR( 1, KI ), 1 ) END IF END IF * IS = IS - 1 IF( IP.NE.0 ) $ IS = IS - 1 130 CONTINUE IF( IP.EQ.1 ) $ IP = 0 IF( IP.EQ.-1 ) $ IP = 1 140 CONTINUE END IF * IF( LEFTV ) THEN * * Compute left eigenvectors. * IP = 0 IS = 1 DO 260 KI = 1, N * IF( IP.EQ.-1 ) $ GO TO 250 IF( KI.EQ.N ) $ GO TO 150 IF( T( KI+1, KI ).EQ.ZERO ) $ GO TO 150 IP = 1 * 150 CONTINUE IF( SOMEV ) THEN IF( .NOT.SELECT( KI ) ) $ GO TO 250 END IF * * Compute the KI-th eigenvalue (WR,WI). * WR = T( KI, KI ) WI = ZERO IF( IP.NE.0 ) $ WI = SQRT( ABS( T( KI, KI+1 ) ) )* $ SQRT( ABS( T( KI+1, KI ) ) ) SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM ) * IF( IP.EQ.0 ) THEN * * Real left eigenvector. * WORK( KI+N ) = ONE * * Form right-hand side * DO 160 K = KI + 1, N WORK( K+N ) = -T( KI, K ) 160 CONTINUE * * Solve the quasi-triangular system: * (T(KI+1:N,KI+1:N) - WR)**T*X = SCALE*WORK * VMAX = ONE VCRIT = BIGNUM * JNXT = KI + 1 DO 170 J = KI + 1, N IF( J.LT.JNXT ) $ GO TO 170 J1 = J J2 = J JNXT = J + 1 IF( J.LT.N ) THEN IF( T( J+1, J ).NE.ZERO ) THEN J2 = J + 1 JNXT = J + 2 END IF END IF * IF( J1.EQ.J2 ) THEN * * 1-by-1 diagonal block * * Scale if necessary to avoid overflow when forming * the right-hand side. * IF( WORK( J ).GT.VCRIT ) THEN REC = ONE / VMAX CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) VMAX = ONE VCRIT = BIGNUM END IF * WORK( J+N ) = WORK( J+N ) - $ DDOT( J-KI-1, T( KI+1, J ), 1, $ WORK( KI+1+N ), 1 ) * * Solve (T(J,J)-WR)**T*X = WORK * CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+N ), N, WR, $ ZERO, X, 2, SCALE, XNORM, IERR ) * * Scale if necessary * IF( SCALE.NE.ONE ) $ CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) WORK( J+N ) = X( 1, 1 ) VMAX = MAX( ABS( WORK( J+N ) ), VMAX ) VCRIT = BIGNUM / VMAX * ELSE * * 2-by-2 diagonal block * * Scale if necessary to avoid overflow when forming * the right-hand side. * BETA = MAX( WORK( J ), WORK( J+1 ) ) IF( BETA.GT.VCRIT ) THEN REC = ONE / VMAX CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) VMAX = ONE VCRIT = BIGNUM END IF * WORK( J+N ) = WORK( J+N ) - $ DDOT( J-KI-1, T( KI+1, J ), 1, $ WORK( KI+1+N ), 1 ) * WORK( J+1+N ) = WORK( J+1+N ) - $ DDOT( J-KI-1, T( KI+1, J+1 ), 1, $ WORK( KI+1+N ), 1 ) * * Solve * [T(J,J)-WR T(J,J+1) ]**T * X = SCALE*( WORK1 ) * [T(J+1,J) T(J+1,J+1)-WR] ( WORK2 ) * CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+N ), N, WR, $ ZERO, X, 2, SCALE, XNORM, IERR ) * * Scale if necessary * IF( SCALE.NE.ONE ) $ CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) WORK( J+N ) = X( 1, 1 ) WORK( J+1+N ) = X( 2, 1 ) * VMAX = MAX( ABS( WORK( J+N ) ), $ ABS( WORK( J+1+N ) ), VMAX ) VCRIT = BIGNUM / VMAX * END IF 170 CONTINUE * * Copy the vector x or Q*x to VL and normalize. * IF( .NOT.OVER ) THEN CALL DCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 ) * II = IDAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1 REMAX = ONE / ABS( VL( II, IS ) ) CALL DSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) * DO 180 K = 1, KI - 1 VL( K, IS ) = ZERO 180 CONTINUE * ELSE * IF( KI.LT.N ) $ CALL DGEMV( 'N', N, N-KI, ONE, VL( 1, KI+1 ), LDVL, $ WORK( KI+1+N ), 1, WORK( KI+N ), $ VL( 1, KI ), 1 ) * II = IDAMAX( N, VL( 1, KI ), 1 ) REMAX = ONE / ABS( VL( II, KI ) ) CALL DSCAL( N, REMAX, VL( 1, KI ), 1 ) * END IF * ELSE * * Complex left eigenvector. * * Initial solve: * ((T(KI,KI) T(KI,KI+1) )**T - (WR - I* WI))*X = 0. * ((T(KI+1,KI) T(KI+1,KI+1)) ) * IF( ABS( T( KI, KI+1 ) ).GE.ABS( T( KI+1, KI ) ) ) THEN WORK( KI+N ) = WI / T( KI, KI+1 ) WORK( KI+1+N2 ) = ONE ELSE WORK( KI+N ) = ONE WORK( KI+1+N2 ) = -WI / T( KI+1, KI ) END IF WORK( KI+1+N ) = ZERO WORK( KI+N2 ) = ZERO * * Form right-hand side * DO 190 K = KI + 2, N WORK( K+N ) = -WORK( KI+N )*T( KI, K ) WORK( K+N2 ) = -WORK( KI+1+N2 )*T( KI+1, K ) 190 CONTINUE * * Solve complex quasi-triangular system: * ( T(KI+2,N:KI+2,N) - (WR-i*WI) )*X = WORK1+i*WORK2 * VMAX = ONE VCRIT = BIGNUM * JNXT = KI + 2 DO 200 J = KI + 2, N IF( J.LT.JNXT ) $ GO TO 200 J1 = J J2 = J JNXT = J + 1 IF( J.LT.N ) THEN IF( T( J+1, J ).NE.ZERO ) THEN J2 = J + 1 JNXT = J + 2 END IF END IF * IF( J1.EQ.J2 ) THEN * * 1-by-1 diagonal block * * Scale if necessary to avoid overflow when * forming the right-hand side elements. * IF( WORK( J ).GT.VCRIT ) THEN REC = ONE / VMAX CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) CALL DSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 ) VMAX = ONE VCRIT = BIGNUM END IF * WORK( J+N ) = WORK( J+N ) - $ DDOT( J-KI-2, T( KI+2, J ), 1, $ WORK( KI+2+N ), 1 ) WORK( J+N2 ) = WORK( J+N2 ) - $ DDOT( J-KI-2, T( KI+2, J ), 1, $ WORK( KI+2+N2 ), 1 ) * * Solve (T(J,J)-(WR-i*WI))*(X11+i*X12)= WK+I*WK2 * CALL DLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+N ), N, WR, $ -WI, X, 2, SCALE, XNORM, IERR ) * * Scale if necessary * IF( SCALE.NE.ONE ) THEN CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) CALL DSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 ) END IF WORK( J+N ) = X( 1, 1 ) WORK( J+N2 ) = X( 1, 2 ) VMAX = MAX( ABS( WORK( J+N ) ), $ ABS( WORK( J+N2 ) ), VMAX ) VCRIT = BIGNUM / VMAX * ELSE * * 2-by-2 diagonal block * * Scale if necessary to avoid overflow when forming * the right-hand side elements. * BETA = MAX( WORK( J ), WORK( J+1 ) ) IF( BETA.GT.VCRIT ) THEN REC = ONE / VMAX CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) CALL DSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 ) VMAX = ONE VCRIT = BIGNUM END IF * WORK( J+N ) = WORK( J+N ) - $ DDOT( J-KI-2, T( KI+2, J ), 1, $ WORK( KI+2+N ), 1 ) * WORK( J+N2 ) = WORK( J+N2 ) - $ DDOT( J-KI-2, T( KI+2, J ), 1, $ WORK( KI+2+N2 ), 1 ) * WORK( J+1+N ) = WORK( J+1+N ) - $ DDOT( J-KI-2, T( KI+2, J+1 ), 1, $ WORK( KI+2+N ), 1 ) * WORK( J+1+N2 ) = WORK( J+1+N2 ) - $ DDOT( J-KI-2, T( KI+2, J+1 ), 1, $ WORK( KI+2+N2 ), 1 ) * * Solve 2-by-2 complex linear equation * ([T(j,j) T(j,j+1) ]**T-(wr-i*wi)*I)*X = SCALE*B * ([T(j+1,j) T(j+1,j+1)] ) * CALL DLALN2( .TRUE., 2, 2, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+N ), N, WR, $ -WI, X, 2, SCALE, XNORM, IERR ) * * Scale if necessary * IF( SCALE.NE.ONE ) THEN CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) CALL DSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 ) END IF WORK( J+N ) = X( 1, 1 ) WORK( J+N2 ) = X( 1, 2 ) WORK( J+1+N ) = X( 2, 1 ) WORK( J+1+N2 ) = X( 2, 2 ) VMAX = MAX( ABS( X( 1, 1 ) ), ABS( X( 1, 2 ) ), $ ABS( X( 2, 1 ) ), ABS( X( 2, 2 ) ), VMAX ) VCRIT = BIGNUM / VMAX * END IF 200 CONTINUE * * Copy the vector x or Q*x to VL and normalize. * IF( .NOT.OVER ) THEN CALL DCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 ) CALL DCOPY( N-KI+1, WORK( KI+N2 ), 1, VL( KI, IS+1 ), $ 1 ) * EMAX = ZERO DO 220 K = KI, N EMAX = MAX( EMAX, ABS( VL( K, IS ) )+ $ ABS( VL( K, IS+1 ) ) ) 220 CONTINUE REMAX = ONE / EMAX CALL DSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) CALL DSCAL( N-KI+1, REMAX, VL( KI, IS+1 ), 1 ) * DO 230 K = 1, KI - 1 VL( K, IS ) = ZERO VL( K, IS+1 ) = ZERO 230 CONTINUE ELSE IF( KI.LT.N-1 ) THEN CALL DGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ), $ LDVL, WORK( KI+2+N ), 1, WORK( KI+N ), $ VL( 1, KI ), 1 ) CALL DGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ), $ LDVL, WORK( KI+2+N2 ), 1, $ WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 ) ELSE CALL DSCAL( N, WORK( KI+N ), VL( 1, KI ), 1 ) CALL DSCAL( N, WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 ) END IF * EMAX = ZERO DO 240 K = 1, N EMAX = MAX( EMAX, ABS( VL( K, KI ) )+ $ ABS( VL( K, KI+1 ) ) ) 240 CONTINUE REMAX = ONE / EMAX CALL DSCAL( N, REMAX, VL( 1, KI ), 1 ) CALL DSCAL( N, REMAX, VL( 1, KI+1 ), 1 ) * END IF * END IF * IS = IS + 1 IF( IP.NE.0 ) $ IS = IS + 1 250 CONTINUE IF( IP.EQ.-1 ) $ IP = 0 IF( IP.EQ.1 ) $ IP = -1 * 260 CONTINUE * END IF * RETURN * * End of DTREVC * END *> \brief \b DTREVC3 * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTREVC3 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTREVC3( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, * VR, LDVR, MM, M, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER HOWMNY, SIDE * INTEGER INFO, LDT, LDVL, LDVR, LWORK, M, MM, N * .. * .. Array Arguments .. * LOGICAL SELECT( * ) * DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), * $ WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTREVC3 computes some or all of the right and/or left eigenvectors of *> a real upper quasi-triangular matrix T. *> Matrices of this type are produced by the Schur factorization of *> a real general matrix: A = Q*T*Q**T, as computed by DHSEQR. *> *> The right eigenvector x and the left eigenvector y of T corresponding *> to an eigenvalue w are defined by: *> *> T*x = w*x, (y**H)*T = w*(y**H) *> *> where y**H denotes the conjugate transpose of y. *> The eigenvalues are not input to this routine, but are read directly *> from the diagonal blocks of T. *> *> This routine returns the matrices X and/or Y of right and left *> eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an *> input matrix. If Q is the orthogonal factor that reduces a matrix *> A to Schur form T, then Q*X and Q*Y are the matrices of right and *> left eigenvectors of A. *> *> This uses a Level 3 BLAS version of the back transformation. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'R': compute right eigenvectors only; *> = 'L': compute left eigenvectors only; *> = 'B': compute both right and left eigenvectors. *> \endverbatim *> *> \param[in] HOWMNY *> \verbatim *> HOWMNY is CHARACTER*1 *> = 'A': compute all right and/or left eigenvectors; *> = 'B': compute all right and/or left eigenvectors, *> backtransformed by the matrices in VR and/or VL; *> = 'S': compute selected right and/or left eigenvectors, *> as indicated by the logical array SELECT. *> \endverbatim *> *> \param[in,out] SELECT *> \verbatim *> SELECT is LOGICAL array, dimension (N) *> If HOWMNY = 'S', SELECT specifies the eigenvectors to be *> computed. *> If w(j) is a real eigenvalue, the corresponding real *> eigenvector is computed if SELECT(j) is .TRUE.. *> If w(j) and w(j+1) are the real and imaginary parts of a *> complex eigenvalue, the corresponding complex eigenvector is *> computed if either SELECT(j) or SELECT(j+1) is .TRUE., and *> on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to *> .FALSE.. *> Not referenced if HOWMNY = 'A' or 'B'. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix T. N >= 0. *> \endverbatim *> *> \param[in] T *> \verbatim *> T is DOUBLE PRECISION array, dimension (LDT,N) *> The upper quasi-triangular matrix T in Schur canonical form. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= max(1,N). *> \endverbatim *> *> \param[in,out] VL *> \verbatim *> VL is DOUBLE PRECISION array, dimension (LDVL,MM) *> On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must *> contain an N-by-N matrix Q (usually the orthogonal matrix Q *> of Schur vectors returned by DHSEQR). *> On exit, if SIDE = 'L' or 'B', VL contains: *> if HOWMNY = 'A', the matrix Y of left eigenvectors of T; *> if HOWMNY = 'B', the matrix Q*Y; *> if HOWMNY = 'S', the left eigenvectors of T specified by *> SELECT, stored consecutively in the columns *> of VL, in the same order as their *> eigenvalues. *> A complex eigenvector corresponding to a complex eigenvalue *> is stored in two consecutive columns, the first holding the *> real part, and the second the imaginary part. *> Not referenced if SIDE = 'R'. *> \endverbatim *> *> \param[in] LDVL *> \verbatim *> LDVL is INTEGER *> The leading dimension of the array VL. *> LDVL >= 1, and if SIDE = 'L' or 'B', LDVL >= N. *> \endverbatim *> *> \param[in,out] VR *> \verbatim *> VR is DOUBLE PRECISION array, dimension (LDVR,MM) *> On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must *> contain an N-by-N matrix Q (usually the orthogonal matrix Q *> of Schur vectors returned by DHSEQR). *> On exit, if SIDE = 'R' or 'B', VR contains: *> if HOWMNY = 'A', the matrix X of right eigenvectors of T; *> if HOWMNY = 'B', the matrix Q*X; *> if HOWMNY = 'S', the right eigenvectors of T specified by *> SELECT, stored consecutively in the columns *> of VR, in the same order as their *> eigenvalues. *> A complex eigenvector corresponding to a complex eigenvalue *> is stored in two consecutive columns, the first holding the *> real part and the second the imaginary part. *> Not referenced if SIDE = 'L'. *> \endverbatim *> *> \param[in] LDVR *> \verbatim *> LDVR is INTEGER *> The leading dimension of the array VR. *> LDVR >= 1, and if SIDE = 'R' or 'B', LDVR >= N. *> \endverbatim *> *> \param[in] MM *> \verbatim *> MM is INTEGER *> The number of columns in the arrays VL and/or VR. MM >= M. *> \endverbatim *> *> \param[out] M *> \verbatim *> M is INTEGER *> The number of columns in the arrays VL and/or VR actually *> used to store the eigenvectors. *> If HOWMNY = 'A' or 'B', M is set to N. *> Each selected real eigenvector occupies one column and each *> selected complex eigenvector occupies two columns. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of array WORK. LWORK >= max(1,3*N). *> For optimum performance, LWORK >= N + 2*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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date November 2017 * * @precisions fortran d -> s * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The algorithm used in this program is basically backward (forward) *> substitution, with scaling to make the the code robust against *> possible overflow. *> *> 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|. *> \endverbatim *> * ===================================================================== SUBROUTINE DTREVC3( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, $ VR, LDVR, MM, M, WORK, LWORK, INFO ) IMPLICIT NONE * * -- LAPACK computational routine (version 3.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE INTEGER INFO, LDT, LDVL, LDVR, LWORK, M, MM, N * .. * .. Array Arguments .. LOGICAL SELECT( * ) DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), $ WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) INTEGER NBMIN, NBMAX PARAMETER ( NBMIN = 8, NBMAX = 128 ) * .. * .. Local Scalars .. LOGICAL ALLV, BOTHV, LEFTV, LQUERY, OVER, PAIR, $ RIGHTV, SOMEV INTEGER I, IERR, II, IP, IS, J, J1, J2, JNXT, K, KI, $ IV, MAXWRK, NB, KI2 DOUBLE PRECISION BETA, BIGNUM, EMAX, OVFL, REC, REMAX, SCALE, $ SMIN, SMLNUM, ULP, UNFL, VCRIT, VMAX, WI, WR, $ XNORM * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX, ILAENV DOUBLE PRECISION DDOT, DLAMCH EXTERNAL LSAME, IDAMAX, ILAENV, DDOT, DLAMCH * .. * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMV, DLALN2, DSCAL, XERBLA, $ DGEMM, DLASET, DLABAD, DLACPY * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Local Arrays .. DOUBLE PRECISION X( 2, 2 ) INTEGER ISCOMPLEX( NBMAX ) * .. * .. Executable Statements .. * * Decode and test the input parameters * BOTHV = LSAME( SIDE, 'B' ) RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV * ALLV = LSAME( HOWMNY, 'A' ) OVER = LSAME( HOWMNY, 'B' ) SOMEV = LSAME( HOWMNY, 'S' ) * INFO = 0 NB = ILAENV( 1, 'DTREVC', SIDE // HOWMNY, N, -1, -1, -1 ) MAXWRK = N + 2*N*NB WORK(1) = MAXWRK LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN INFO = -1 ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN INFO = -8 ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN INFO = -10 ELSE IF( LWORK.LT.MAX( 1, 3*N ) .AND. .NOT.LQUERY ) THEN INFO = -14 ELSE * * Set M to the number of columns required to store the selected * eigenvectors, standardize the array SELECT if necessary, and * test MM. * IF( SOMEV ) THEN M = 0 PAIR = .FALSE. DO 10 J = 1, N IF( PAIR ) THEN PAIR = .FALSE. SELECT( J ) = .FALSE. ELSE IF( J.LT.N ) THEN IF( T( J+1, J ).EQ.ZERO ) THEN IF( SELECT( J ) ) $ M = M + 1 ELSE PAIR = .TRUE. IF( SELECT( J ) .OR. SELECT( J+1 ) ) THEN SELECT( J ) = .TRUE. M = M + 2 END IF END IF ELSE IF( SELECT( N ) ) $ M = M + 1 END IF END IF 10 CONTINUE ELSE M = N END IF * IF( MM.LT.M ) THEN INFO = -11 END IF END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTREVC3', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * * Use blocked version of back-transformation if sufficient workspace. * Zero-out the workspace to avoid potential NaN propagation. * IF( OVER .AND. LWORK .GE. N + 2*N*NBMIN ) THEN NB = (LWORK - N) / (2*N) NB = MIN( NB, NBMAX ) CALL DLASET( 'F', N, 1+2*NB, ZERO, ZERO, WORK, N ) ELSE NB = 1 END IF * * Set the constants to control overflow. * UNFL = DLAMCH( 'Safe minimum' ) OVFL = ONE / UNFL CALL DLABAD( UNFL, OVFL ) ULP = DLAMCH( 'Precision' ) SMLNUM = UNFL*( N / ULP ) BIGNUM = ( ONE-ULP ) / SMLNUM * * Compute 1-norm of each column of strictly upper triangular * part of T to control overflow in triangular solver. * WORK( 1 ) = ZERO DO 30 J = 2, N WORK( J ) = ZERO DO 20 I = 1, J - 1 WORK( J ) = WORK( J ) + ABS( T( I, J ) ) 20 CONTINUE 30 CONTINUE * * Index IP is used to specify the real or complex eigenvalue: * IP = 0, real eigenvalue, * 1, first of conjugate complex pair: (wr,wi) * -1, second of conjugate complex pair: (wr,wi) * ISCOMPLEX array stores IP for each column in current block. * IF( RIGHTV ) THEN * * ============================================================ * Compute right eigenvectors. * * IV is index of column in current block. * For complex right vector, uses IV-1 for real part and IV for complex part. * Non-blocked version always uses IV=2; * blocked version starts with IV=NB, goes down to 1 or 2. * (Note the "0-th" column is used for 1-norms computed above.) IV = 2 IF( NB.GT.2 ) THEN IV = NB END IF IP = 0 IS = M DO 140 KI = N, 1, -1 IF( IP.EQ.-1 ) THEN * previous iteration (ki+1) was second of conjugate pair, * so this ki is first of conjugate pair; skip to end of loop IP = 1 GO TO 140 ELSE IF( KI.EQ.1 ) THEN * last column, so this ki must be real eigenvalue IP = 0 ELSE IF( T( KI, KI-1 ).EQ.ZERO ) THEN * zero on sub-diagonal, so this ki is real eigenvalue IP = 0 ELSE * non-zero on sub-diagonal, so this ki is second of conjugate pair IP = -1 END IF IF( SOMEV ) THEN IF( IP.EQ.0 ) THEN IF( .NOT.SELECT( KI ) ) $ GO TO 140 ELSE IF( .NOT.SELECT( KI-1 ) ) $ GO TO 140 END IF END IF * * Compute the KI-th eigenvalue (WR,WI). * WR = T( KI, KI ) WI = ZERO IF( IP.NE.0 ) $ WI = SQRT( ABS( T( KI, KI-1 ) ) )* $ SQRT( ABS( T( KI-1, KI ) ) ) SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM ) * IF( IP.EQ.0 ) THEN * * -------------------------------------------------------- * Real right eigenvector * WORK( KI + IV*N ) = ONE * * Form right-hand side. * DO 50 K = 1, KI - 1 WORK( K + IV*N ) = -T( K, KI ) 50 CONTINUE * * Solve upper quasi-triangular system: * [ T(1:KI-1,1:KI-1) - WR ]*X = SCALE*WORK. * JNXT = KI - 1 DO 60 J = KI - 1, 1, -1 IF( J.GT.JNXT ) $ GO TO 60 J1 = J J2 = J JNXT = J - 1 IF( J.GT.1 ) THEN IF( T( J, J-1 ).NE.ZERO ) THEN J1 = J - 1 JNXT = J - 2 END IF END IF * IF( J1.EQ.J2 ) THEN * * 1-by-1 diagonal block * CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+IV*N ), N, WR, $ ZERO, X, 2, SCALE, XNORM, IERR ) * * Scale X(1,1) to avoid overflow when updating * the right-hand side. * IF( XNORM.GT.ONE ) THEN IF( WORK( J ).GT.BIGNUM / XNORM ) THEN X( 1, 1 ) = X( 1, 1 ) / XNORM SCALE = SCALE / XNORM END IF END IF * * Scale if necessary * IF( SCALE.NE.ONE ) $ CALL DSCAL( KI, SCALE, WORK( 1+IV*N ), 1 ) WORK( J+IV*N ) = X( 1, 1 ) * * Update right-hand side * CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1, $ WORK( 1+IV*N ), 1 ) * ELSE * * 2-by-2 diagonal block * CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, $ T( J-1, J-1 ), LDT, ONE, ONE, $ WORK( J-1+IV*N ), N, WR, ZERO, X, 2, $ SCALE, XNORM, IERR ) * * Scale X(1,1) and X(2,1) to avoid overflow when * updating the right-hand side. * IF( XNORM.GT.ONE ) THEN BETA = MAX( WORK( J-1 ), WORK( J ) ) IF( BETA.GT.BIGNUM / XNORM ) THEN X( 1, 1 ) = X( 1, 1 ) / XNORM X( 2, 1 ) = X( 2, 1 ) / XNORM SCALE = SCALE / XNORM END IF END IF * * Scale if necessary * IF( SCALE.NE.ONE ) $ CALL DSCAL( KI, SCALE, WORK( 1+IV*N ), 1 ) WORK( J-1+IV*N ) = X( 1, 1 ) WORK( J +IV*N ) = X( 2, 1 ) * * Update right-hand side * CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, $ WORK( 1+IV*N ), 1 ) CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1, $ WORK( 1+IV*N ), 1 ) END IF 60 CONTINUE * * Copy the vector x or Q*x to VR and normalize. * IF( .NOT.OVER ) THEN * ------------------------------ * no back-transform: copy x to VR and normalize. CALL DCOPY( KI, WORK( 1 + IV*N ), 1, VR( 1, IS ), 1 ) * II = IDAMAX( KI, VR( 1, IS ), 1 ) REMAX = ONE / ABS( VR( II, IS ) ) CALL DSCAL( KI, REMAX, VR( 1, IS ), 1 ) * DO 70 K = KI + 1, N VR( K, IS ) = ZERO 70 CONTINUE * ELSE IF( NB.EQ.1 ) THEN * ------------------------------ * version 1: back-transform each vector with GEMV, Q*x. IF( KI.GT.1 ) $ CALL DGEMV( 'N', N, KI-1, ONE, VR, LDVR, $ WORK( 1 + IV*N ), 1, WORK( KI + IV*N ), $ VR( 1, KI ), 1 ) * II = IDAMAX( N, VR( 1, KI ), 1 ) REMAX = ONE / ABS( VR( II, KI ) ) CALL DSCAL( N, REMAX, VR( 1, KI ), 1 ) * ELSE * ------------------------------ * version 2: back-transform block of vectors with GEMM * zero out below vector DO K = KI + 1, N WORK( K + IV*N ) = ZERO END DO ISCOMPLEX( IV ) = IP * back-transform and normalization is done below END IF ELSE * * -------------------------------------------------------- * Complex right eigenvector. * * Initial solve * [ ( T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I*WI) ]*X = 0. * [ ( T(KI, KI-1) T(KI, KI) ) ] * IF( ABS( T( KI-1, KI ) ).GE.ABS( T( KI, KI-1 ) ) ) THEN WORK( KI-1 + (IV-1)*N ) = ONE WORK( KI + (IV )*N ) = WI / T( KI-1, KI ) ELSE WORK( KI-1 + (IV-1)*N ) = -WI / T( KI, KI-1 ) WORK( KI + (IV )*N ) = ONE END IF WORK( KI + (IV-1)*N ) = ZERO WORK( KI-1 + (IV )*N ) = ZERO * * Form right-hand side. * DO 80 K = 1, KI - 2 WORK( K+(IV-1)*N ) = -WORK( KI-1+(IV-1)*N )*T(K,KI-1) WORK( K+(IV )*N ) = -WORK( KI +(IV )*N )*T(K,KI ) 80 CONTINUE * * Solve upper quasi-triangular system: * [ T(1:KI-2,1:KI-2) - (WR+i*WI) ]*X = SCALE*(WORK+i*WORK2) * JNXT = KI - 2 DO 90 J = KI - 2, 1, -1 IF( J.GT.JNXT ) $ GO TO 90 J1 = J J2 = J JNXT = J - 1 IF( J.GT.1 ) THEN IF( T( J, J-1 ).NE.ZERO ) THEN J1 = J - 1 JNXT = J - 2 END IF END IF * IF( J1.EQ.J2 ) THEN * * 1-by-1 diagonal block * CALL DLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+(IV-1)*N ), N, $ WR, WI, X, 2, SCALE, XNORM, IERR ) * * Scale X(1,1) and X(1,2) to avoid overflow when * updating the right-hand side. * IF( XNORM.GT.ONE ) THEN IF( WORK( J ).GT.BIGNUM / XNORM ) THEN X( 1, 1 ) = X( 1, 1 ) / XNORM X( 1, 2 ) = X( 1, 2 ) / XNORM SCALE = SCALE / XNORM END IF END IF * * Scale if necessary * IF( SCALE.NE.ONE ) THEN CALL DSCAL( KI, SCALE, WORK( 1+(IV-1)*N ), 1 ) CALL DSCAL( KI, SCALE, WORK( 1+(IV )*N ), 1 ) END IF WORK( J+(IV-1)*N ) = X( 1, 1 ) WORK( J+(IV )*N ) = X( 1, 2 ) * * Update the right-hand side * CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1, $ WORK( 1+(IV-1)*N ), 1 ) CALL DAXPY( J-1, -X( 1, 2 ), T( 1, J ), 1, $ WORK( 1+(IV )*N ), 1 ) * ELSE * * 2-by-2 diagonal block * CALL DLALN2( .FALSE., 2, 2, SMIN, ONE, $ T( J-1, J-1 ), LDT, ONE, ONE, $ WORK( J-1+(IV-1)*N ), N, WR, WI, X, 2, $ SCALE, XNORM, IERR ) * * Scale X to avoid overflow when updating * the right-hand side. * IF( XNORM.GT.ONE ) THEN BETA = MAX( WORK( J-1 ), WORK( J ) ) IF( BETA.GT.BIGNUM / XNORM ) THEN REC = ONE / XNORM X( 1, 1 ) = X( 1, 1 )*REC X( 1, 2 ) = X( 1, 2 )*REC X( 2, 1 ) = X( 2, 1 )*REC X( 2, 2 ) = X( 2, 2 )*REC SCALE = SCALE*REC END IF END IF * * Scale if necessary * IF( SCALE.NE.ONE ) THEN CALL DSCAL( KI, SCALE, WORK( 1+(IV-1)*N ), 1 ) CALL DSCAL( KI, SCALE, WORK( 1+(IV )*N ), 1 ) END IF WORK( J-1+(IV-1)*N ) = X( 1, 1 ) WORK( J +(IV-1)*N ) = X( 2, 1 ) WORK( J-1+(IV )*N ) = X( 1, 2 ) WORK( J +(IV )*N ) = X( 2, 2 ) * * Update the right-hand side * CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, $ WORK( 1+(IV-1)*N ), 1 ) CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1, $ WORK( 1+(IV-1)*N ), 1 ) CALL DAXPY( J-2, -X( 1, 2 ), T( 1, J-1 ), 1, $ WORK( 1+(IV )*N ), 1 ) CALL DAXPY( J-2, -X( 2, 2 ), T( 1, J ), 1, $ WORK( 1+(IV )*N ), 1 ) END IF 90 CONTINUE * * Copy the vector x or Q*x to VR and normalize. * IF( .NOT.OVER ) THEN * ------------------------------ * no back-transform: copy x to VR and normalize. CALL DCOPY( KI, WORK( 1+(IV-1)*N ), 1, VR(1,IS-1), 1 ) CALL DCOPY( KI, WORK( 1+(IV )*N ), 1, VR(1,IS ), 1 ) * EMAX = ZERO DO 100 K = 1, KI EMAX = MAX( EMAX, ABS( VR( K, IS-1 ) )+ $ ABS( VR( K, IS ) ) ) 100 CONTINUE REMAX = ONE / EMAX CALL DSCAL( KI, REMAX, VR( 1, IS-1 ), 1 ) CALL DSCAL( KI, REMAX, VR( 1, IS ), 1 ) * DO 110 K = KI + 1, N VR( K, IS-1 ) = ZERO VR( K, IS ) = ZERO 110 CONTINUE * ELSE IF( NB.EQ.1 ) THEN * ------------------------------ * version 1: back-transform each vector with GEMV, Q*x. IF( KI.GT.2 ) THEN CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR, $ WORK( 1 + (IV-1)*N ), 1, $ WORK( KI-1 + (IV-1)*N ), VR(1,KI-1), 1) CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR, $ WORK( 1 + (IV)*N ), 1, $ WORK( KI + (IV)*N ), VR( 1, KI ), 1 ) ELSE CALL DSCAL( N, WORK(KI-1+(IV-1)*N), VR(1,KI-1), 1) CALL DSCAL( N, WORK(KI +(IV )*N), VR(1,KI ), 1) END IF * EMAX = ZERO DO 120 K = 1, N EMAX = MAX( EMAX, ABS( VR( K, KI-1 ) )+ $ ABS( VR( K, KI ) ) ) 120 CONTINUE REMAX = ONE / EMAX CALL DSCAL( N, REMAX, VR( 1, KI-1 ), 1 ) CALL DSCAL( N, REMAX, VR( 1, KI ), 1 ) * ELSE * ------------------------------ * version 2: back-transform block of vectors with GEMM * zero out below vector DO K = KI + 1, N WORK( K + (IV-1)*N ) = ZERO WORK( K + (IV )*N ) = ZERO END DO ISCOMPLEX( IV-1 ) = -IP ISCOMPLEX( IV ) = IP IV = IV - 1 * back-transform and normalization is done below END IF END IF IF( NB.GT.1 ) THEN * -------------------------------------------------------- * Blocked version of back-transform * For complex case, KI2 includes both vectors (KI-1 and KI) IF( IP.EQ.0 ) THEN KI2 = KI ELSE KI2 = KI - 1 END IF * Columns IV:NB of work are valid vectors. * When the number of vectors stored reaches NB-1 or NB, * or if this was last vector, do the GEMM IF( (IV.LE.2) .OR. (KI2.EQ.1) ) THEN CALL DGEMM( 'N', 'N', N, NB-IV+1, KI2+NB-IV, ONE, $ VR, LDVR, $ WORK( 1 + (IV)*N ), N, $ ZERO, $ WORK( 1 + (NB+IV)*N ), N ) * normalize vectors DO K = IV, NB IF( ISCOMPLEX(K).EQ.0 ) THEN * real eigenvector II = IDAMAX( N, WORK( 1 + (NB+K)*N ), 1 ) REMAX = ONE / ABS( WORK( II + (NB+K)*N ) ) ELSE IF( ISCOMPLEX(K).EQ.1 ) THEN * first eigenvector of conjugate pair EMAX = ZERO DO II = 1, N EMAX = MAX( EMAX, $ ABS( WORK( II + (NB+K )*N ) )+ $ ABS( WORK( II + (NB+K+1)*N ) ) ) END DO REMAX = ONE / EMAX * else if ISCOMPLEX(K).EQ.-1 * second eigenvector of conjugate pair * reuse same REMAX as previous K END IF CALL DSCAL( N, REMAX, WORK( 1 + (NB+K)*N ), 1 ) END DO CALL DLACPY( 'F', N, NB-IV+1, $ WORK( 1 + (NB+IV)*N ), N, $ VR( 1, KI2 ), LDVR ) IV = NB ELSE IV = IV - 1 END IF END IF ! blocked back-transform * IS = IS - 1 IF( IP.NE.0 ) $ IS = IS - 1 140 CONTINUE END IF IF( LEFTV ) THEN * * ============================================================ * Compute left eigenvectors. * * IV is index of column in current block. * For complex left vector, uses IV for real part and IV+1 for complex part. * Non-blocked version always uses IV=1; * blocked version starts with IV=1, goes up to NB-1 or NB. * (Note the "0-th" column is used for 1-norms computed above.) IV = 1 IP = 0 IS = 1 DO 260 KI = 1, N IF( IP.EQ.1 ) THEN * previous iteration (ki-1) was first of conjugate pair, * so this ki is second of conjugate pair; skip to end of loop IP = -1 GO TO 260 ELSE IF( KI.EQ.N ) THEN * last column, so this ki must be real eigenvalue IP = 0 ELSE IF( T( KI+1, KI ).EQ.ZERO ) THEN * zero on sub-diagonal, so this ki is real eigenvalue IP = 0 ELSE * non-zero on sub-diagonal, so this ki is first of conjugate pair IP = 1 END IF * IF( SOMEV ) THEN IF( .NOT.SELECT( KI ) ) $ GO TO 260 END IF * * Compute the KI-th eigenvalue (WR,WI). * WR = T( KI, KI ) WI = ZERO IF( IP.NE.0 ) $ WI = SQRT( ABS( T( KI, KI+1 ) ) )* $ SQRT( ABS( T( KI+1, KI ) ) ) SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM ) * IF( IP.EQ.0 ) THEN * * -------------------------------------------------------- * Real left eigenvector * WORK( KI + IV*N ) = ONE * * Form right-hand side. * DO 160 K = KI + 1, N WORK( K + IV*N ) = -T( KI, K ) 160 CONTINUE * * Solve transposed quasi-triangular system: * [ T(KI+1:N,KI+1:N) - WR ]**T * X = SCALE*WORK * VMAX = ONE VCRIT = BIGNUM * JNXT = KI + 1 DO 170 J = KI + 1, N IF( J.LT.JNXT ) $ GO TO 170 J1 = J J2 = J JNXT = J + 1 IF( J.LT.N ) THEN IF( T( J+1, J ).NE.ZERO ) THEN J2 = J + 1 JNXT = J + 2 END IF END IF * IF( J1.EQ.J2 ) THEN * * 1-by-1 diagonal block * * Scale if necessary to avoid overflow when forming * the right-hand side. * IF( WORK( J ).GT.VCRIT ) THEN REC = ONE / VMAX CALL DSCAL( N-KI+1, REC, WORK( KI+IV*N ), 1 ) VMAX = ONE VCRIT = BIGNUM END IF * WORK( J+IV*N ) = WORK( J+IV*N ) - $ DDOT( J-KI-1, T( KI+1, J ), 1, $ WORK( KI+1+IV*N ), 1 ) * * Solve [ T(J,J) - WR ]**T * X = WORK * CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+IV*N ), N, WR, $ ZERO, X, 2, SCALE, XNORM, IERR ) * * Scale if necessary * IF( SCALE.NE.ONE ) $ CALL DSCAL( N-KI+1, SCALE, WORK( KI+IV*N ), 1 ) WORK( J+IV*N ) = X( 1, 1 ) VMAX = MAX( ABS( WORK( J+IV*N ) ), VMAX ) VCRIT = BIGNUM / VMAX * ELSE * * 2-by-2 diagonal block * * Scale if necessary to avoid overflow when forming * the right-hand side. * BETA = MAX( WORK( J ), WORK( J+1 ) ) IF( BETA.GT.VCRIT ) THEN REC = ONE / VMAX CALL DSCAL( N-KI+1, REC, WORK( KI+IV*N ), 1 ) VMAX = ONE VCRIT = BIGNUM END IF * WORK( J+IV*N ) = WORK( J+IV*N ) - $ DDOT( J-KI-1, T( KI+1, J ), 1, $ WORK( KI+1+IV*N ), 1 ) * WORK( J+1+IV*N ) = WORK( J+1+IV*N ) - $ DDOT( J-KI-1, T( KI+1, J+1 ), 1, $ WORK( KI+1+IV*N ), 1 ) * * Solve * [ T(J,J)-WR T(J,J+1) ]**T * X = SCALE*( WORK1 ) * [ T(J+1,J) T(J+1,J+1)-WR ] ( WORK2 ) * CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+IV*N ), N, WR, $ ZERO, X, 2, SCALE, XNORM, IERR ) * * Scale if necessary * IF( SCALE.NE.ONE ) $ CALL DSCAL( N-KI+1, SCALE, WORK( KI+IV*N ), 1 ) WORK( J +IV*N ) = X( 1, 1 ) WORK( J+1+IV*N ) = X( 2, 1 ) * VMAX = MAX( ABS( WORK( J +IV*N ) ), $ ABS( WORK( J+1+IV*N ) ), VMAX ) VCRIT = BIGNUM / VMAX * END IF 170 CONTINUE * * Copy the vector x or Q*x to VL and normalize. * IF( .NOT.OVER ) THEN * ------------------------------ * no back-transform: copy x to VL and normalize. CALL DCOPY( N-KI+1, WORK( KI + IV*N ), 1, $ VL( KI, IS ), 1 ) * II = IDAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1 REMAX = ONE / ABS( VL( II, IS ) ) CALL DSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) * DO 180 K = 1, KI - 1 VL( K, IS ) = ZERO 180 CONTINUE * ELSE IF( NB.EQ.1 ) THEN * ------------------------------ * version 1: back-transform each vector with GEMV, Q*x. IF( KI.LT.N ) $ CALL DGEMV( 'N', N, N-KI, ONE, $ VL( 1, KI+1 ), LDVL, $ WORK( KI+1 + IV*N ), 1, $ WORK( KI + IV*N ), VL( 1, KI ), 1 ) * II = IDAMAX( N, VL( 1, KI ), 1 ) REMAX = ONE / ABS( VL( II, KI ) ) CALL DSCAL( N, REMAX, VL( 1, KI ), 1 ) * ELSE * ------------------------------ * version 2: back-transform block of vectors with GEMM * zero out above vector * could go from KI-NV+1 to KI-1 DO K = 1, KI - 1 WORK( K + IV*N ) = ZERO END DO ISCOMPLEX( IV ) = IP * back-transform and normalization is done below END IF ELSE * * -------------------------------------------------------- * Complex left eigenvector. * * Initial solve: * [ ( T(KI,KI) T(KI,KI+1) )**T - (WR - I* WI) ]*X = 0. * [ ( T(KI+1,KI) T(KI+1,KI+1) ) ] * IF( ABS( T( KI, KI+1 ) ).GE.ABS( T( KI+1, KI ) ) ) THEN WORK( KI + (IV )*N ) = WI / T( KI, KI+1 ) WORK( KI+1 + (IV+1)*N ) = ONE ELSE WORK( KI + (IV )*N ) = ONE WORK( KI+1 + (IV+1)*N ) = -WI / T( KI+1, KI ) END IF WORK( KI+1 + (IV )*N ) = ZERO WORK( KI + (IV+1)*N ) = ZERO * * Form right-hand side. * DO 190 K = KI + 2, N WORK( K+(IV )*N ) = -WORK( KI +(IV )*N )*T(KI, K) WORK( K+(IV+1)*N ) = -WORK( KI+1+(IV+1)*N )*T(KI+1,K) 190 CONTINUE * * Solve transposed quasi-triangular system: * [ T(KI+2:N,KI+2:N)**T - (WR-i*WI) ]*X = WORK1+i*WORK2 * VMAX = ONE VCRIT = BIGNUM * JNXT = KI + 2 DO 200 J = KI + 2, N IF( J.LT.JNXT ) $ GO TO 200 J1 = J J2 = J JNXT = J + 1 IF( J.LT.N ) THEN IF( T( J+1, J ).NE.ZERO ) THEN J2 = J + 1 JNXT = J + 2 END IF END IF * IF( J1.EQ.J2 ) THEN * * 1-by-1 diagonal block * * Scale if necessary to avoid overflow when * forming the right-hand side elements. * IF( WORK( J ).GT.VCRIT ) THEN REC = ONE / VMAX CALL DSCAL( N-KI+1, REC, WORK(KI+(IV )*N), 1 ) CALL DSCAL( N-KI+1, REC, WORK(KI+(IV+1)*N), 1 ) VMAX = ONE VCRIT = BIGNUM END IF * WORK( J+(IV )*N ) = WORK( J+(IV)*N ) - $ DDOT( J-KI-2, T( KI+2, J ), 1, $ WORK( KI+2+(IV)*N ), 1 ) WORK( J+(IV+1)*N ) = WORK( J+(IV+1)*N ) - $ DDOT( J-KI-2, T( KI+2, J ), 1, $ WORK( KI+2+(IV+1)*N ), 1 ) * * Solve [ T(J,J)-(WR-i*WI) ]*(X11+i*X12)= WK+I*WK2 * CALL DLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+IV*N ), N, WR, $ -WI, X, 2, SCALE, XNORM, IERR ) * * Scale if necessary * IF( SCALE.NE.ONE ) THEN CALL DSCAL( N-KI+1, SCALE, WORK(KI+(IV )*N), 1) CALL DSCAL( N-KI+1, SCALE, WORK(KI+(IV+1)*N), 1) END IF WORK( J+(IV )*N ) = X( 1, 1 ) WORK( J+(IV+1)*N ) = X( 1, 2 ) VMAX = MAX( ABS( WORK( J+(IV )*N ) ), $ ABS( WORK( J+(IV+1)*N ) ), VMAX ) VCRIT = BIGNUM / VMAX * ELSE * * 2-by-2 diagonal block * * Scale if necessary to avoid overflow when forming * the right-hand side elements. * BETA = MAX( WORK( J ), WORK( J+1 ) ) IF( BETA.GT.VCRIT ) THEN REC = ONE / VMAX CALL DSCAL( N-KI+1, REC, WORK(KI+(IV )*N), 1 ) CALL DSCAL( N-KI+1, REC, WORK(KI+(IV+1)*N), 1 ) VMAX = ONE VCRIT = BIGNUM END IF * WORK( J +(IV )*N ) = WORK( J+(IV)*N ) - $ DDOT( J-KI-2, T( KI+2, J ), 1, $ WORK( KI+2+(IV)*N ), 1 ) * WORK( J +(IV+1)*N ) = WORK( J+(IV+1)*N ) - $ DDOT( J-KI-2, T( KI+2, J ), 1, $ WORK( KI+2+(IV+1)*N ), 1 ) * WORK( J+1+(IV )*N ) = WORK( J+1+(IV)*N ) - $ DDOT( J-KI-2, T( KI+2, J+1 ), 1, $ WORK( KI+2+(IV)*N ), 1 ) * WORK( J+1+(IV+1)*N ) = WORK( J+1+(IV+1)*N ) - $ DDOT( J-KI-2, T( KI+2, J+1 ), 1, $ WORK( KI+2+(IV+1)*N ), 1 ) * * Solve 2-by-2 complex linear equation * [ (T(j,j) T(j,j+1) )**T - (wr-i*wi)*I ]*X = SCALE*B * [ (T(j+1,j) T(j+1,j+1)) ] * CALL DLALN2( .TRUE., 2, 2, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+IV*N ), N, WR, $ -WI, X, 2, SCALE, XNORM, IERR ) * * Scale if necessary * IF( SCALE.NE.ONE ) THEN CALL DSCAL( N-KI+1, SCALE, WORK(KI+(IV )*N), 1) CALL DSCAL( N-KI+1, SCALE, WORK(KI+(IV+1)*N), 1) END IF WORK( J +(IV )*N ) = X( 1, 1 ) WORK( J +(IV+1)*N ) = X( 1, 2 ) WORK( J+1+(IV )*N ) = X( 2, 1 ) WORK( J+1+(IV+1)*N ) = X( 2, 2 ) VMAX = MAX( ABS( X( 1, 1 ) ), ABS( X( 1, 2 ) ), $ ABS( X( 2, 1 ) ), ABS( X( 2, 2 ) ), $ VMAX ) VCRIT = BIGNUM / VMAX * END IF 200 CONTINUE * * Copy the vector x or Q*x to VL and normalize. * IF( .NOT.OVER ) THEN * ------------------------------ * no back-transform: copy x to VL and normalize. CALL DCOPY( N-KI+1, WORK( KI + (IV )*N ), 1, $ VL( KI, IS ), 1 ) CALL DCOPY( N-KI+1, WORK( KI + (IV+1)*N ), 1, $ VL( KI, IS+1 ), 1 ) * EMAX = ZERO DO 220 K = KI, N EMAX = MAX( EMAX, ABS( VL( K, IS ) )+ $ ABS( VL( K, IS+1 ) ) ) 220 CONTINUE REMAX = ONE / EMAX CALL DSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) CALL DSCAL( N-KI+1, REMAX, VL( KI, IS+1 ), 1 ) * DO 230 K = 1, KI - 1 VL( K, IS ) = ZERO VL( K, IS+1 ) = ZERO 230 CONTINUE * ELSE IF( NB.EQ.1 ) THEN * ------------------------------ * version 1: back-transform each vector with GEMV, Q*x. IF( KI.LT.N-1 ) THEN CALL DGEMV( 'N', N, N-KI-1, ONE, $ VL( 1, KI+2 ), LDVL, $ WORK( KI+2 + (IV)*N ), 1, $ WORK( KI + (IV)*N ), $ VL( 1, KI ), 1 ) CALL DGEMV( 'N', N, N-KI-1, ONE, $ VL( 1, KI+2 ), LDVL, $ WORK( KI+2 + (IV+1)*N ), 1, $ WORK( KI+1 + (IV+1)*N ), $ VL( 1, KI+1 ), 1 ) ELSE CALL DSCAL( N, WORK(KI+ (IV )*N), VL(1, KI ), 1) CALL DSCAL( N, WORK(KI+1+(IV+1)*N), VL(1, KI+1), 1) END IF * EMAX = ZERO DO 240 K = 1, N EMAX = MAX( EMAX, ABS( VL( K, KI ) )+ $ ABS( VL( K, KI+1 ) ) ) 240 CONTINUE REMAX = ONE / EMAX CALL DSCAL( N, REMAX, VL( 1, KI ), 1 ) CALL DSCAL( N, REMAX, VL( 1, KI+1 ), 1 ) * ELSE * ------------------------------ * version 2: back-transform block of vectors with GEMM * zero out above vector * could go from KI-NV+1 to KI-1 DO K = 1, KI - 1 WORK( K + (IV )*N ) = ZERO WORK( K + (IV+1)*N ) = ZERO END DO ISCOMPLEX( IV ) = IP ISCOMPLEX( IV+1 ) = -IP IV = IV + 1 * back-transform and normalization is done below END IF END IF IF( NB.GT.1 ) THEN * -------------------------------------------------------- * Blocked version of back-transform * For complex case, KI2 includes both vectors (KI and KI+1) IF( IP.EQ.0 ) THEN KI2 = KI ELSE KI2 = KI + 1 END IF * Columns 1:IV of work are valid vectors. * When the number of vectors stored reaches NB-1 or NB, * or if this was last vector, do the GEMM IF( (IV.GE.NB-1) .OR. (KI2.EQ.N) ) THEN CALL DGEMM( 'N', 'N', N, IV, N-KI2+IV, ONE, $ VL( 1, KI2-IV+1 ), LDVL, $ WORK( KI2-IV+1 + (1)*N ), N, $ ZERO, $ WORK( 1 + (NB+1)*N ), N ) * normalize vectors DO K = 1, IV IF( ISCOMPLEX(K).EQ.0) THEN * real eigenvector II = IDAMAX( N, WORK( 1 + (NB+K)*N ), 1 ) REMAX = ONE / ABS( WORK( II + (NB+K)*N ) ) ELSE IF( ISCOMPLEX(K).EQ.1) THEN * first eigenvector of conjugate pair EMAX = ZERO DO II = 1, N EMAX = MAX( EMAX, $ ABS( WORK( II + (NB+K )*N ) )+ $ ABS( WORK( II + (NB+K+1)*N ) ) ) END DO REMAX = ONE / EMAX * else if ISCOMPLEX(K).EQ.-1 * second eigenvector of conjugate pair * reuse same REMAX as previous K END IF CALL DSCAL( N, REMAX, WORK( 1 + (NB+K)*N ), 1 ) END DO CALL DLACPY( 'F', N, IV, $ WORK( 1 + (NB+1)*N ), N, $ VL( 1, KI2-IV+1 ), LDVL ) IV = 1 ELSE IV = IV + 1 END IF END IF ! blocked back-transform * IS = IS + 1 IF( IP.NE.0 ) $ IS = IS + 1 260 CONTINUE END IF * RETURN * * End of DTREVC3 * END *> \brief \b DTREXC * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTREXC + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, * INFO ) * * .. Scalar Arguments .. * CHARACTER COMPQ * INTEGER IFST, ILST, INFO, LDQ, LDT, N * .. * .. Array Arguments .. * DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTREXC reorders the real Schur factorization of a real matrix *> A = Q*T*Q**T, so that the diagonal block of T with row index IFST is *> moved to row ILST. *> *> The real Schur form T is reordered by an orthogonal similarity *> transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors *> is updated by postmultiplying it with Z. *> *> T must be in Schur canonical form (as returned by DHSEQR), that is, *> block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each *> 2-by-2 diagonal block has its diagonal elements equal and its *> off-diagonal elements of opposite sign. *> \endverbatim * * Arguments: * ========== * *> \param[in] COMPQ *> \verbatim *> COMPQ is CHARACTER*1 *> = 'V': update the matrix Q of Schur vectors; *> = 'N': do not update Q. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix T. N >= 0. *> If N == 0 arguments ILST and IFST may be any value. *> \endverbatim *> *> \param[in,out] T *> \verbatim *> T is DOUBLE PRECISION array, dimension (LDT,N) *> On entry, the upper quasi-triangular matrix T, in Schur *> Schur canonical form. *> On exit, the reordered upper quasi-triangular matrix, again *> in Schur canonical form. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= max(1,N). *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is DOUBLE PRECISION array, dimension (LDQ,N) *> On entry, if COMPQ = 'V', the matrix Q of Schur vectors. *> On exit, if COMPQ = 'V', Q has been postmultiplied by the *> orthogonal transformation matrix Z which reorders T. *> If COMPQ = 'N', Q is not referenced. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. LDQ >= 1, and if *> COMPQ = 'V', LDQ >= max(1,N). *> \endverbatim *> *> \param[in,out] IFST *> \verbatim *> IFST is INTEGER *> \endverbatim *> *> \param[in,out] ILST *> \verbatim *> ILST is INTEGER *> *> Specify the reordering of the diagonal blocks of T. *> The block with row index IFST is moved to row ILST, by a *> sequence of transpositions between adjacent blocks. *> On exit, if IFST pointed on entry to the second row of a *> 2-by-2 block, it is changed to point to the first row; ILST *> always points to the first row of the block in its final *> position (which may differ from its input value by +1 or -1). *> 1 <= IFST <= N; 1 <= ILST <= N. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> = 1: two adjacent blocks were too close to swap (the problem *> is very ill-conditioned); T may have been partially *> reordered, and ILST points to the first row of the *> current position of the block being moved. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, $ INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER COMPQ INTEGER IFST, ILST, INFO, LDQ, LDT, N * .. * .. Array Arguments .. DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL WANTQ INTEGER HERE, NBF, NBL, NBNEXT * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLAEXC, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Decode and test the input arguments. * INFO = 0 WANTQ = LSAME( COMPQ, 'V' ) IF( .NOT.WANTQ .AND. .NOT.LSAME( COMPQ, 'N' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) ) THEN INFO = -6 ELSE IF(( IFST.LT.1 .OR. IFST.GT.N ).AND.( N.GT.0 )) THEN INFO = -7 ELSE IF(( ILST.LT.1 .OR. ILST.GT.N ).AND.( N.GT.0 )) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTREXC', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.1 ) $ RETURN * * Determine the first row of specified block * and find out it is 1 by 1 or 2 by 2. * IF( IFST.GT.1 ) THEN IF( T( IFST, IFST-1 ).NE.ZERO ) $ IFST = IFST - 1 END IF NBF = 1 IF( IFST.LT.N ) THEN IF( T( IFST+1, IFST ).NE.ZERO ) $ NBF = 2 END IF * * Determine the first row of the final block * and find out it is 1 by 1 or 2 by 2. * IF( ILST.GT.1 ) THEN IF( T( ILST, ILST-1 ).NE.ZERO ) $ ILST = ILST - 1 END IF NBL = 1 IF( ILST.LT.N ) THEN IF( T( ILST+1, ILST ).NE.ZERO ) $ NBL = 2 END IF * IF( IFST.EQ.ILST ) $ RETURN * IF( IFST.LT.ILST ) THEN * * Update ILST * IF( NBF.EQ.2 .AND. NBL.EQ.1 ) $ ILST = ILST - 1 IF( NBF.EQ.1 .AND. NBL.EQ.2 ) $ ILST = ILST + 1 * HERE = IFST * 10 CONTINUE * * Swap block with next one below * IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN * * Current block either 1 by 1 or 2 by 2 * NBNEXT = 1 IF( HERE+NBF+1.LE.N ) THEN IF( T( HERE+NBF+1, HERE+NBF ).NE.ZERO ) $ NBNEXT = 2 END IF CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, NBF, NBNEXT, $ WORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + NBNEXT * * Test if 2 by 2 block breaks into two 1 by 1 blocks * IF( NBF.EQ.2 ) THEN IF( T( HERE+1, HERE ).EQ.ZERO ) $ NBF = 3 END IF * ELSE * * Current block consists of two 1 by 1 blocks each of which * must be swapped individually * NBNEXT = 1 IF( HERE+3.LE.N ) THEN IF( T( HERE+3, HERE+2 ).NE.ZERO ) $ NBNEXT = 2 END IF CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE+1, 1, NBNEXT, $ WORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF IF( NBNEXT.EQ.1 ) THEN * * Swap two 1 by 1 blocks, no problems possible * CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, NBNEXT, $ WORK, INFO ) HERE = HERE + 1 ELSE * * Recompute NBNEXT in case 2 by 2 split * IF( T( HERE+2, HERE+1 ).EQ.ZERO ) $ NBNEXT = 1 IF( NBNEXT.EQ.2 ) THEN * * 2 by 2 Block did not split * CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, $ NBNEXT, WORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + 2 ELSE * * 2 by 2 Block did split * CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, 1, $ WORK, INFO ) CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE+1, 1, 1, $ WORK, INFO ) HERE = HERE + 2 END IF END IF END IF IF( HERE.LT.ILST ) $ GO TO 10 * ELSE * HERE = IFST 20 CONTINUE * * Swap block with next one above * IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN * * Current block either 1 by 1 or 2 by 2 * NBNEXT = 1 IF( HERE.GE.3 ) THEN IF( T( HERE-1, HERE-2 ).NE.ZERO ) $ NBNEXT = 2 END IF CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-NBNEXT, NBNEXT, $ NBF, WORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - NBNEXT * * Test if 2 by 2 block breaks into two 1 by 1 blocks * IF( NBF.EQ.2 ) THEN IF( T( HERE+1, HERE ).EQ.ZERO ) $ NBF = 3 END IF * ELSE * * Current block consists of two 1 by 1 blocks each of which * must be swapped individually * NBNEXT = 1 IF( HERE.GE.3 ) THEN IF( T( HERE-1, HERE-2 ).NE.ZERO ) $ NBNEXT = 2 END IF CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-NBNEXT, NBNEXT, $ 1, WORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF IF( NBNEXT.EQ.1 ) THEN * * Swap two 1 by 1 blocks, no problems possible * CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, NBNEXT, 1, $ WORK, INFO ) HERE = HERE - 1 ELSE * * Recompute NBNEXT in case 2 by 2 split * IF( T( HERE, HERE-1 ).EQ.ZERO ) $ NBNEXT = 1 IF( NBNEXT.EQ.2 ) THEN * * 2 by 2 Block did not split * CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-1, 2, 1, $ WORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - 2 ELSE * * 2 by 2 Block did split * CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, 1, $ WORK, INFO ) CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-1, 1, 1, $ WORK, INFO ) HERE = HERE - 2 END IF END IF END IF IF( HERE.GT.ILST ) $ GO TO 20 END IF ILST = HERE * RETURN * * End of DTREXC * END *> \brief \b DTRRFS * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTRRFS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, * LDX, FERR, BERR, WORK, IWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, LDA, LDB, LDX, N, NRHS * .. * .. Array Arguments .. * INTEGER IWORK( * ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ), * $ WORK( * ), X( LDX, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTRRFS provides error bounds and backward error estimates for the *> solution to a system of linear equations with a triangular *> coefficient matrix. *> *> The solution matrix X must be computed by DTRTRS or some other *> means before entering this routine. DTRRFS does not do iterative *> refinement because doing so cannot improve the backward error. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': A is upper triangular; *> = 'L': A is lower triangular. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is 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) *> \endverbatim *> *> \param[in] DIAG *> \verbatim *> DIAG is CHARACTER*1 *> = 'N': A is non-unit triangular; *> = 'U': A is unit triangular. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrices B and X. NRHS >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The triangular matrix A. If UPLO = 'U', the leading N-by-N *> upper triangular part of the array A contains the upper *> triangular matrix, and the strictly lower triangular part of *> A is not referenced. If UPLO = 'L', the leading N-by-N lower *> triangular part of the array A contains the lower triangular *> matrix, and the strictly upper triangular part of A is not *> referenced. If DIAG = 'U', the diagonal elements of A are *> also not referenced and are assumed to be 1. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> The right hand side matrix B. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in] X *> \verbatim *> X is DOUBLE PRECISION array, dimension (LDX,NRHS) *> The solution matrix X. *> \endverbatim *> *> \param[in] LDX *> \verbatim *> LDX is INTEGER *> The leading dimension of the array X. LDX >= max(1,N). *> \endverbatim *> *> \param[out] FERR *> \verbatim *> FERR is 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. *> \endverbatim *> *> \param[out] BERR *> \verbatim *> BERR is 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). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (3*N) *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N) *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, $ LDX, FERR, BERR, WORK, IWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO INTEGER INFO, LDA, LDB, LDX, N, NRHS * .. * .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ), $ WORK( * ), X( LDX, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOTRAN, NOUNIT, UPPER CHARACTER TRANST INTEGER I, J, K, KASE, NZ DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) * .. * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DLACN2, DTRMV, DTRSV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL LSAME, DLAMCH * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) NOTRAN = LSAME( TRANS, 'N' ) NOUNIT = LSAME( DIAG, 'N' ) * IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. $ LSAME( TRANS, 'C' ) ) THEN INFO = -2 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( NRHS.LT.0 ) 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( LDX.LT.MAX( 1, N ) ) THEN INFO = -11 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTRRFS', -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 250 J = 1, NRHS * * Compute residual R = B - op(A) * X, * where op(A) = A or A**T, depending on TRANS. * CALL DCOPY( N, X( 1, J ), 1, WORK( N+1 ), 1 ) CALL DTRMV( UPLO, TRANS, DIAG, N, A, LDA, WORK( N+1 ), 1 ) CALL DAXPY( N, -ONE, B( 1, J ), 1, 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 20 I = 1, N WORK( I ) = ABS( B( I, J ) ) 20 CONTINUE * IF( NOTRAN ) THEN * * Compute abs(A)*abs(X) + abs(B). * IF( UPPER ) THEN IF( NOUNIT ) THEN DO 40 K = 1, N XK = ABS( X( K, J ) ) DO 30 I = 1, K WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK 30 CONTINUE 40 CONTINUE ELSE DO 60 K = 1, N XK = ABS( X( K, J ) ) DO 50 I = 1, K - 1 WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK 50 CONTINUE WORK( K ) = WORK( K ) + XK 60 CONTINUE END IF ELSE IF( NOUNIT ) THEN DO 80 K = 1, N XK = ABS( X( K, J ) ) DO 70 I = K, N WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK 70 CONTINUE 80 CONTINUE ELSE DO 100 K = 1, N XK = ABS( X( K, J ) ) DO 90 I = K + 1, N WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK 90 CONTINUE WORK( K ) = WORK( K ) + XK 100 CONTINUE END IF END IF ELSE * * Compute abs(A**T)*abs(X) + abs(B). * IF( UPPER ) THEN IF( NOUNIT ) THEN DO 120 K = 1, N S = ZERO DO 110 I = 1, K S = S + ABS( A( I, K ) )*ABS( X( I, J ) ) 110 CONTINUE WORK( K ) = WORK( K ) + S 120 CONTINUE ELSE DO 140 K = 1, N S = ABS( X( K, J ) ) DO 130 I = 1, K - 1 S = S + ABS( A( I, K ) )*ABS( X( I, J ) ) 130 CONTINUE WORK( K ) = WORK( K ) + S 140 CONTINUE END IF ELSE IF( NOUNIT ) THEN DO 160 K = 1, N S = ZERO DO 150 I = K, N S = S + ABS( A( I, K ) )*ABS( X( I, J ) ) 150 CONTINUE WORK( K ) = WORK( K ) + S 160 CONTINUE ELSE DO 180 K = 1, N S = ABS( X( K, J ) ) DO 170 I = K + 1, N S = S + ABS( A( I, K ) )*ABS( X( I, J ) ) 170 CONTINUE WORK( K ) = WORK( K ) + S 180 CONTINUE END IF END IF END IF S = ZERO DO 190 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 190 CONTINUE BERR( J ) = S * * 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 200 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 200 CONTINUE * KASE = 0 210 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 DTRSV( UPLO, TRANST, DIAG, N, A, LDA, WORK( N+1 ), $ 1 ) DO 220 I = 1, N WORK( N+I ) = WORK( I )*WORK( N+I ) 220 CONTINUE ELSE * * Multiply by inv(op(A))*diag(W). * DO 230 I = 1, N WORK( N+I ) = WORK( I )*WORK( N+I ) 230 CONTINUE CALL DTRSV( UPLO, TRANS, DIAG, N, A, LDA, WORK( N+1 ), $ 1 ) END IF GO TO 210 END IF * * Normalize error. * LSTRES = ZERO DO 240 I = 1, N LSTRES = MAX( LSTRES, ABS( X( I, J ) ) ) 240 CONTINUE IF( LSTRES.NE.ZERO ) $ FERR( J ) = FERR( J ) / LSTRES * 250 CONTINUE * RETURN * * End of DTRRFS * END *> \brief \b DTRSEN * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTRSEN + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, * M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER COMPQ, JOB * INTEGER INFO, LDQ, LDT, LIWORK, LWORK, M, N * DOUBLE PRECISION S, SEP * .. * .. Array Arguments .. * LOGICAL SELECT( * ) * INTEGER IWORK( * ) * DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WI( * ), WORK( * ), * $ WR( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTRSEN reorders the real Schur factorization of a real matrix *> A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in *> the leading diagonal blocks of the upper quasi-triangular matrix T, *> and the leading columns of Q form an orthonormal basis of the *> corresponding right invariant subspace. *> *> Optionally the routine computes the reciprocal condition numbers of *> the cluster of eigenvalues and/or the invariant subspace. *> *> T must be in Schur canonical form (as returned by DHSEQR), that is, *> block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each *> 2-by-2 diagonal block has its diagonal elements equal and its *> off-diagonal elements of opposite sign. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> Specifies whether condition numbers are required for the *> cluster of eigenvalues (S) or the invariant subspace (SEP): *> = 'N': none; *> = 'E': for eigenvalues only (S); *> = 'V': for invariant subspace only (SEP); *> = 'B': for both eigenvalues and invariant subspace (S and *> SEP). *> \endverbatim *> *> \param[in] COMPQ *> \verbatim *> COMPQ is CHARACTER*1 *> = 'V': update the matrix Q of Schur vectors; *> = 'N': do not update Q. *> \endverbatim *> *> \param[in] SELECT *> \verbatim *> SELECT is LOGICAL array, dimension (N) *> SELECT specifies the eigenvalues in the selected cluster. To *> select a real eigenvalue w(j), SELECT(j) must be set to *> .TRUE.. To select a complex conjugate pair of eigenvalues *> w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, *> either SELECT(j) or SELECT(j+1) or both must be set to *> .TRUE.; a complex conjugate pair of eigenvalues must be *> either both included in the cluster or both excluded. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix T. N >= 0. *> \endverbatim *> *> \param[in,out] T *> \verbatim *> T is DOUBLE PRECISION array, dimension (LDT,N) *> On entry, the upper quasi-triangular matrix T, in Schur *> canonical form. *> On exit, T is overwritten by the reordered matrix T, again in *> Schur canonical form, with the selected eigenvalues in the *> leading diagonal blocks. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= max(1,N). *> \endverbatim *> *> \param[in,out] Q *> \verbatim *> Q is DOUBLE PRECISION array, dimension (LDQ,N) *> On entry, if COMPQ = 'V', the matrix Q of Schur vectors. *> On exit, if COMPQ = 'V', Q has been postmultiplied by the *> orthogonal transformation matrix which reorders T; the *> leading M columns of Q form an orthonormal basis for the *> specified invariant subspace. *> If COMPQ = 'N', Q is not referenced. *> \endverbatim *> *> \param[in] LDQ *> \verbatim *> LDQ is INTEGER *> The leading dimension of the array Q. *> LDQ >= 1; and if COMPQ = 'V', LDQ >= N. *> \endverbatim *> *> \param[out] WR *> \verbatim *> WR is DOUBLE PRECISION array, dimension (N) *> \endverbatim *> \param[out] WI *> \verbatim *> WI is DOUBLE PRECISION array, dimension (N) *> *> The real and imaginary parts, respectively, of the reordered *> eigenvalues of T. The eigenvalues are stored in the same *> order as on the diagonal of T, with WR(i) = T(i,i) and, if *> T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and *> WI(i+1) = -WI(i). Note that if a complex eigenvalue is *> sufficiently ill-conditioned, then its value may differ *> significantly from its value before reordering. *> \endverbatim *> *> \param[out] M *> \verbatim *> M is INTEGER *> The dimension of the specified invariant subspace. *> 0 < = M <= N. *> \endverbatim *> *> \param[out] S *> \verbatim *> S is DOUBLE PRECISION *> If JOB = 'E' or 'B', S is a lower bound on the reciprocal *> condition number for the selected cluster of eigenvalues. *> S cannot underestimate the true reciprocal condition number *> by more than a factor of sqrt(N). If M = 0 or N, S = 1. *> If JOB = 'N' or 'V', S is not referenced. *> \endverbatim *> *> \param[out] SEP *> \verbatim *> SEP is DOUBLE PRECISION *> If JOB = 'V' or 'B', SEP is the estimated reciprocal *> condition number of the specified invariant subspace. If *> M = 0 or N, SEP = norm(T). *> If JOB = 'N' or 'E', SEP is not referenced. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. *> If JOB = 'N', LWORK >= max(1,N); *> if JOB = 'E', LWORK >= max(1,M*(N-M)); *> if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)). *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error *> message related to LWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) *> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. *> \endverbatim *> *> \param[in] LIWORK *> \verbatim *> LIWORK is INTEGER *> The dimension of the array IWORK. *> If JOB = 'N' or 'E', LIWORK >= 1; *> if JOB = 'V' or 'B', LIWORK >= max(1,M*(N-M)). *> *> If LIWORK = -1, then a workspace query is assumed; the *> routine only calculates the optimal size of the IWORK array, *> returns this value as the first entry of the IWORK array, and *> no error message related to LIWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> = 1: reordering of T failed because some eigenvalues are too *> close to separate (the problem is very ill-conditioned); *> T may have been partially reordered, and WR and WI *> contain the eigenvalues in the same order as in T; S and *> SEP (if requested) are set to zero. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date April 2012 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> DTRSEN first collects the selected eigenvalues by computing an *> orthogonal transformation Z to move them to the top left corner of T. *> In other words, the selected eigenvalues are the eigenvalues of T11 *> in: *> *> Z**T * T * Z = ( T11 T12 ) n1 *> ( 0 T22 ) n2 *> n1 n2 *> *> where N = n1+n2 and Z**T means the transpose of Z. The first n1 columns *> of Z span the specified invariant subspace of T. *> *> If T has been obtained from the real Schur factorization of a matrix *> A = Q*T*Q**T, then the reordered real Schur factorization of A is given *> by A = (Q*Z)*(Z**T*T*Z)*(Q*Z)**T, and the first n1 columns of Q*Z span *> the corresponding invariant subspace of A. *> *> The reciprocal condition number of the average of the eigenvalues of *> T11 may be returned in S. S lies between 0 (very badly conditioned) *> and 1 (very well conditioned). It is computed as follows. First we *> compute R so that *> *> P = ( I R ) n1 *> ( 0 0 ) n2 *> n1 n2 *> *> is the projector on the invariant subspace associated with T11. *> R is the solution of the Sylvester equation: *> *> T11*R - R*T22 = T12. *> *> Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote *> the two-norm of M. Then S is computed as the lower bound *> *> (1 + F-norm(R)**2)**(-1/2) *> *> on the reciprocal of 2-norm(P), the true reciprocal condition number. *> S cannot underestimate 1 / 2-norm(P) by more than a factor of *> sqrt(N). *> *> An approximate error bound for the computed average of the *> eigenvalues of T11 is *> *> EPS * norm(T) / S *> *> where EPS is the machine precision. *> *> The reciprocal condition number of the right invariant subspace *> spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP. *> SEP is defined as the separation of T11 and T22: *> *> sep( T11, T22 ) = sigma-min( C ) *> *> where sigma-min(C) is the smallest singular value of the *> n1*n2-by-n1*n2 matrix *> *> C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) ) *> *> I(m) is an m by m identity matrix, and kprod denotes the Kronecker *> product. We estimate sigma-min(C) by the reciprocal of an estimate of *> the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C) *> cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2). *> *> When SEP is small, small changes in T can cause large changes in *> the invariant subspace. An approximate bound on the maximum angular *> error in the computed right invariant subspace is *> *> EPS * norm(T) / SEP *> \endverbatim *> * ===================================================================== SUBROUTINE DTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, $ M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * April 2012 * * .. Scalar Arguments .. CHARACTER COMPQ, JOB INTEGER INFO, LDQ, LDT, LIWORK, LWORK, M, N DOUBLE PRECISION S, SEP * .. * .. Array Arguments .. LOGICAL SELECT( * ) INTEGER IWORK( * ) DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WI( * ), WORK( * ), $ WR( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, PAIR, SWAP, WANTBH, WANTQ, WANTS, $ WANTSP INTEGER IERR, K, KASE, KK, KS, LIWMIN, LWMIN, N1, N2, $ NN DOUBLE PRECISION EST, RNORM, SCALE * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLANGE EXTERNAL LSAME, DLANGE * .. * .. External Subroutines .. EXTERNAL DLACN2, DLACPY, DTREXC, DTRSYL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * * Decode and test the input parameters * WANTBH = LSAME( JOB, 'B' ) WANTS = LSAME( JOB, 'E' ) .OR. WANTBH WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH WANTQ = LSAME( COMPQ, 'V' ) * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.WANTS .AND. .NOT.WANTSP ) $ THEN INFO = -1 ELSE IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN INFO = -8 ELSE * * Set M to the dimension of the specified invariant subspace, * and test LWORK and LIWORK. * M = 0 PAIR = .FALSE. DO 10 K = 1, N IF( PAIR ) THEN PAIR = .FALSE. ELSE IF( K.LT.N ) THEN IF( T( K+1, K ).EQ.ZERO ) THEN IF( SELECT( K ) ) $ M = M + 1 ELSE PAIR = .TRUE. IF( SELECT( K ) .OR. SELECT( K+1 ) ) $ M = M + 2 END IF ELSE IF( SELECT( N ) ) $ M = M + 1 END IF END IF 10 CONTINUE * N1 = M N2 = N - M NN = N1*N2 * IF( WANTSP ) THEN LWMIN = MAX( 1, 2*NN ) LIWMIN = MAX( 1, NN ) ELSE IF( LSAME( JOB, 'N' ) ) THEN LWMIN = MAX( 1, N ) LIWMIN = 1 ELSE IF( LSAME( JOB, 'E' ) ) THEN LWMIN = MAX( 1, NN ) LIWMIN = 1 END IF * IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN INFO = -15 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN INFO = -17 END IF END IF * IF( INFO.EQ.0 ) THEN WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTRSEN', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible. * IF( M.EQ.N .OR. M.EQ.0 ) THEN IF( WANTS ) $ S = ONE IF( WANTSP ) $ SEP = DLANGE( '1', N, N, T, LDT, WORK ) GO TO 40 END IF * * Collect the selected blocks at the top-left corner of T. * KS = 0 PAIR = .FALSE. DO 20 K = 1, N IF( PAIR ) THEN PAIR = .FALSE. ELSE SWAP = SELECT( K ) IF( K.LT.N ) THEN IF( T( K+1, K ).NE.ZERO ) THEN PAIR = .TRUE. SWAP = SWAP .OR. SELECT( K+1 ) END IF END IF IF( SWAP ) THEN KS = KS + 1 * * Swap the K-th block to position KS. * IERR = 0 KK = K IF( K.NE.KS ) $ CALL DTREXC( COMPQ, N, T, LDT, Q, LDQ, KK, KS, WORK, $ IERR ) IF( IERR.EQ.1 .OR. IERR.EQ.2 ) THEN * * Blocks too close to swap: exit. * INFO = 1 IF( WANTS ) $ S = ZERO IF( WANTSP ) $ SEP = ZERO GO TO 40 END IF IF( PAIR ) $ KS = KS + 1 END IF END IF 20 CONTINUE * IF( WANTS ) THEN * * Solve Sylvester equation for R: * * T11*R - R*T22 = scale*T12 * CALL DLACPY( 'F', N1, N2, T( 1, N1+1 ), LDT, WORK, N1 ) CALL DTRSYL( 'N', 'N', -1, N1, N2, T, LDT, T( N1+1, N1+1 ), $ LDT, WORK, N1, SCALE, IERR ) * * Estimate the reciprocal of the condition number of the cluster * of eigenvalues. * RNORM = DLANGE( 'F', N1, N2, WORK, N1, WORK ) IF( RNORM.EQ.ZERO ) THEN S = ONE ELSE S = SCALE / ( SQRT( SCALE*SCALE / RNORM+RNORM )* $ SQRT( RNORM ) ) END IF END IF * IF( WANTSP ) THEN * * Estimate sep(T11,T22). * EST = ZERO KASE = 0 30 CONTINUE CALL DLACN2( NN, WORK( NN+1 ), WORK, IWORK, EST, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN * * Solve T11*R - R*T22 = scale*X. * CALL DTRSYL( 'N', 'N', -1, N1, N2, T, LDT, $ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE, $ IERR ) ELSE * * Solve T11**T*R - R*T22**T = scale*X. * CALL DTRSYL( 'T', 'T', -1, N1, N2, T, LDT, $ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE, $ IERR ) END IF GO TO 30 END IF * SEP = SCALE / EST END IF * 40 CONTINUE * * Store the output eigenvalues in WR and WI. * DO 50 K = 1, N WR( K ) = T( K, K ) WI( K ) = ZERO 50 CONTINUE DO 60 K = 1, N - 1 IF( T( K+1, K ).NE.ZERO ) THEN WI( K ) = SQRT( ABS( T( K, K+1 ) ) )* $ SQRT( ABS( T( K+1, K ) ) ) WI( K+1 ) = -WI( K ) END IF 60 CONTINUE * WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN * RETURN * * End of DTRSEN * END *> \brief \b DTRSNA * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTRSNA + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, * LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK, * INFO ) * * .. Scalar Arguments .. * CHARACTER HOWMNY, JOB * INTEGER INFO, LDT, LDVL, LDVR, LDWORK, M, MM, N * .. * .. Array Arguments .. * LOGICAL SELECT( * ) * INTEGER IWORK( * ) * DOUBLE PRECISION S( * ), SEP( * ), T( LDT, * ), VL( LDVL, * ), * $ VR( LDVR, * ), WORK( LDWORK, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTRSNA estimates reciprocal condition numbers for specified *> eigenvalues and/or right eigenvectors of a real upper *> quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q *> orthogonal). *> *> T must be in Schur canonical form (as returned by DHSEQR), that is, *> block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each *> 2-by-2 diagonal block has its diagonal elements equal and its *> off-diagonal elements of opposite sign. *> \endverbatim * * Arguments: * ========== * *> \param[in] JOB *> \verbatim *> JOB is CHARACTER*1 *> Specifies whether condition numbers are required for *> eigenvalues (S) or eigenvectors (SEP): *> = 'E': for eigenvalues only (S); *> = 'V': for eigenvectors only (SEP); *> = 'B': for both eigenvalues and eigenvectors (S and SEP). *> \endverbatim *> *> \param[in] HOWMNY *> \verbatim *> HOWMNY is CHARACTER*1 *> = 'A': compute condition numbers for all eigenpairs; *> = 'S': compute condition numbers for selected eigenpairs *> specified by the array SELECT. *> \endverbatim *> *> \param[in] SELECT *> \verbatim *> SELECT is LOGICAL array, dimension (N) *> If HOWMNY = 'S', SELECT specifies the eigenpairs for which *> condition numbers are required. To select condition numbers *> for the eigenpair corresponding to a real eigenvalue w(j), *> SELECT(j) must be set to .TRUE.. To select condition numbers *> corresponding to a complex conjugate pair of eigenvalues w(j) *> and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be *> set to .TRUE.. *> If HOWMNY = 'A', SELECT is not referenced. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix T. N >= 0. *> \endverbatim *> *> \param[in] T *> \verbatim *> T is DOUBLE PRECISION array, dimension (LDT,N) *> The upper quasi-triangular matrix T, in Schur canonical form. *> \endverbatim *> *> \param[in] LDT *> \verbatim *> LDT is INTEGER *> The leading dimension of the array T. LDT >= max(1,N). *> \endverbatim *> *> \param[in] VL *> \verbatim *> VL is DOUBLE PRECISION array, dimension (LDVL,M) *> If JOB = 'E' or 'B', VL must contain left eigenvectors of T *> (or of any Q*T*Q**T with Q orthogonal), corresponding to the *> eigenpairs specified by HOWMNY and SELECT. The eigenvectors *> must be stored in consecutive columns of VL, as returned by *> DHSEIN or DTREVC. *> If JOB = 'V', VL is not referenced. *> \endverbatim *> *> \param[in] LDVL *> \verbatim *> LDVL is INTEGER *> The leading dimension of the array VL. *> LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N. *> \endverbatim *> *> \param[in] VR *> \verbatim *> VR is DOUBLE PRECISION array, dimension (LDVR,M) *> If JOB = 'E' or 'B', VR must contain right eigenvectors of T *> (or of any Q*T*Q**T with Q orthogonal), corresponding to the *> eigenpairs specified by HOWMNY and SELECT. The eigenvectors *> must be stored in consecutive columns of VR, as returned by *> DHSEIN or DTREVC. *> If JOB = 'V', VR is not referenced. *> \endverbatim *> *> \param[in] LDVR *> \verbatim *> LDVR is INTEGER *> The leading dimension of the array VR. *> LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N. *> \endverbatim *> *> \param[out] S *> \verbatim *> S is DOUBLE PRECISION array, dimension (MM) *> If JOB = 'E' or 'B', the reciprocal condition numbers of the *> selected eigenvalues, stored in consecutive elements of the *> array. For a complex conjugate pair of eigenvalues two *> consecutive elements of S are set to the same value. Thus *> S(j), SEP(j), and the j-th columns of VL and VR all *> correspond to the same eigenpair (but not in general the *> j-th eigenpair, unless all eigenpairs are selected). *> If JOB = 'V', S is not referenced. *> \endverbatim *> *> \param[out] SEP *> \verbatim *> SEP is DOUBLE PRECISION array, dimension (MM) *> If JOB = 'V' or 'B', the estimated reciprocal condition *> numbers of the selected eigenvectors, stored in consecutive *> elements of the array. For a complex eigenvector two *> consecutive elements of SEP are set to the same value. If *> the eigenvalues cannot be reordered to compute SEP(j), SEP(j) *> is set to 0; this can only occur when the true value would be *> very small anyway. *> If JOB = 'E', SEP is not referenced. *> \endverbatim *> *> \param[in] MM *> \verbatim *> MM is INTEGER *> The number of elements in the arrays S (if JOB = 'E' or 'B') *> and/or SEP (if JOB = 'V' or 'B'). MM >= M. *> \endverbatim *> *> \param[out] M *> \verbatim *> M is INTEGER *> The number of elements of the arrays S and/or SEP actually *> used to store the estimated condition numbers. *> If HOWMNY = 'A', M is set to N. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (LDWORK,N+6) *> If JOB = 'E', WORK is not referenced. *> \endverbatim *> *> \param[in] LDWORK *> \verbatim *> LDWORK is INTEGER *> The leading dimension of the array WORK. *> LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N. *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (2*(N-1)) *> If JOB = 'E', IWORK is not referenced. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date November 2017 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> The reciprocal of the condition number of an eigenvalue lambda is *> defined as *> *> S(lambda) = |v**T*u| / (norm(u)*norm(v)) *> *> where u and v are the right and left eigenvectors of T corresponding *> to lambda; v**T denotes the transpose of v, and norm(u) *> denotes the Euclidean norm. These reciprocal condition numbers always *> lie between zero (very badly conditioned) and one (very well *> conditioned). If n = 1, S(lambda) is defined to be 1. *> *> An approximate error bound for a computed eigenvalue W(i) is given by *> *> EPS * norm(T) / S(i) *> *> where EPS is the machine precision. *> *> The reciprocal of the condition number of the right eigenvector u *> corresponding to lambda is defined as follows. Suppose *> *> T = ( lambda c ) *> ( 0 T22 ) *> *> Then the reciprocal condition number is *> *> SEP( lambda, T22 ) = sigma-min( T22 - lambda*I ) *> *> where sigma-min denotes the smallest singular value. We approximate *> the smallest singular value by the reciprocal of an estimate of the *> one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is *> defined to be abs(T(1,1)). *> *> An approximate error bound for a computed right eigenvector VR(i) *> is given by *> *> EPS * norm(T) / SEP(i) *> \endverbatim *> * ===================================================================== SUBROUTINE DTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK, $ INFO ) * * -- LAPACK computational routine (version 3.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. Scalar Arguments .. CHARACTER HOWMNY, JOB INTEGER INFO, LDT, LDVL, LDVR, LDWORK, M, MM, N * .. * .. Array Arguments .. LOGICAL SELECT( * ) INTEGER IWORK( * ) DOUBLE PRECISION S( * ), SEP( * ), T( LDT, * ), VL( LDVL, * ), $ VR( LDVR, * ), WORK( LDWORK, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) * .. * .. Local Scalars .. LOGICAL PAIR, SOMCON, WANTBH, WANTS, WANTSP INTEGER I, IERR, IFST, ILST, J, K, KASE, KS, N2, NN DOUBLE PRECISION BIGNUM, COND, CS, DELTA, DUMM, EPS, EST, LNRM, $ MU, PROD, PROD1, PROD2, RNRM, SCALE, SMLNUM, SN * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) DOUBLE PRECISION DUMMY( 1 ) * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT, DLAMCH, DLAPY2, DNRM2 EXTERNAL LSAME, DDOT, DLAMCH, DLAPY2, DNRM2 * .. * .. External Subroutines .. EXTERNAL DLABAD, DLACN2, DLACPY, DLAQTR, DTREXC, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * * Decode and test the input parameters * WANTBH = LSAME( JOB, 'B' ) WANTS = LSAME( JOB, 'E' ) .OR. WANTBH WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH * SOMCON = LSAME( HOWMNY, 'S' ) * INFO = 0 IF( .NOT.WANTS .AND. .NOT.WANTSP ) THEN INFO = -1 ELSE IF( .NOT.LSAME( HOWMNY, 'A' ) .AND. .NOT.SOMCON ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDVL.LT.1 .OR. ( WANTS .AND. LDVL.LT.N ) ) THEN INFO = -8 ELSE IF( LDVR.LT.1 .OR. ( WANTS .AND. LDVR.LT.N ) ) THEN INFO = -10 ELSE * * Set M to the number of eigenpairs for which condition numbers * are required, and test MM. * IF( SOMCON ) THEN M = 0 PAIR = .FALSE. DO 10 K = 1, N IF( PAIR ) THEN PAIR = .FALSE. ELSE IF( K.LT.N ) THEN IF( T( K+1, K ).EQ.ZERO ) THEN IF( SELECT( K ) ) $ M = M + 1 ELSE PAIR = .TRUE. IF( SELECT( K ) .OR. SELECT( K+1 ) ) $ M = M + 2 END IF ELSE IF( SELECT( N ) ) $ M = M + 1 END IF END IF 10 CONTINUE ELSE M = N END IF * IF( MM.LT.M ) THEN INFO = -13 ELSE IF( LDWORK.LT.1 .OR. ( WANTSP .AND. LDWORK.LT.N ) ) THEN INFO = -16 END IF END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTRSNA', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( N.EQ.1 ) THEN IF( SOMCON ) THEN IF( .NOT.SELECT( 1 ) ) $ RETURN END IF IF( WANTS ) $ S( 1 ) = ONE IF( WANTSP ) $ SEP( 1 ) = ABS( T( 1, 1 ) ) RETURN END IF * * Get machine constants * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) / EPS BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) * KS = 0 PAIR = .FALSE. DO 60 K = 1, N * * Determine whether T(k,k) begins a 1-by-1 or 2-by-2 block. * IF( PAIR ) THEN PAIR = .FALSE. GO TO 60 ELSE IF( K.LT.N ) $ PAIR = T( K+1, K ).NE.ZERO END IF * * Determine whether condition numbers are required for the k-th * eigenpair. * IF( SOMCON ) THEN IF( PAIR ) THEN IF( .NOT.SELECT( K ) .AND. .NOT.SELECT( K+1 ) ) $ GO TO 60 ELSE IF( .NOT.SELECT( K ) ) $ GO TO 60 END IF END IF * KS = KS + 1 * IF( WANTS ) THEN * * Compute the reciprocal condition number of the k-th * eigenvalue. * IF( .NOT.PAIR ) THEN * * Real eigenvalue. * PROD = DDOT( N, VR( 1, KS ), 1, VL( 1, KS ), 1 ) RNRM = DNRM2( N, VR( 1, KS ), 1 ) LNRM = DNRM2( N, VL( 1, KS ), 1 ) S( KS ) = ABS( PROD ) / ( RNRM*LNRM ) ELSE * * Complex eigenvalue. * PROD1 = DDOT( N, VR( 1, KS ), 1, VL( 1, KS ), 1 ) PROD1 = PROD1 + DDOT( N, VR( 1, KS+1 ), 1, VL( 1, KS+1 ), $ 1 ) PROD2 = DDOT( N, VL( 1, KS ), 1, VR( 1, KS+1 ), 1 ) PROD2 = PROD2 - DDOT( N, VL( 1, KS+1 ), 1, VR( 1, KS ), $ 1 ) RNRM = DLAPY2( DNRM2( N, VR( 1, KS ), 1 ), $ DNRM2( N, VR( 1, KS+1 ), 1 ) ) LNRM = DLAPY2( DNRM2( N, VL( 1, KS ), 1 ), $ DNRM2( N, VL( 1, KS+1 ), 1 ) ) COND = DLAPY2( PROD1, PROD2 ) / ( RNRM*LNRM ) S( KS ) = COND S( KS+1 ) = COND END IF END IF * IF( WANTSP ) THEN * * Estimate the reciprocal condition number of the k-th * eigenvector. * * Copy the matrix T to the array WORK and swap the diagonal * block beginning at T(k,k) to the (1,1) position. * CALL DLACPY( 'Full', N, N, T, LDT, WORK, LDWORK ) IFST = K ILST = 1 CALL DTREXC( 'No Q', N, WORK, LDWORK, DUMMY, 1, IFST, ILST, $ WORK( 1, N+1 ), IERR ) * IF( IERR.EQ.1 .OR. IERR.EQ.2 ) THEN * * Could not swap because blocks not well separated * SCALE = ONE EST = BIGNUM ELSE * * Reordering successful * IF( WORK( 2, 1 ).EQ.ZERO ) THEN * * Form C = T22 - lambda*I in WORK(2:N,2:N). * DO 20 I = 2, N WORK( I, I ) = WORK( I, I ) - WORK( 1, 1 ) 20 CONTINUE N2 = 1 NN = N - 1 ELSE * * Triangularize the 2 by 2 block by unitary * transformation U = [ cs i*ss ] * [ i*ss cs ]. * such that the (1,1) position of WORK is complex * eigenvalue lambda with positive imaginary part. (2,2) * position of WORK is the complex eigenvalue lambda * with negative imaginary part. * MU = SQRT( ABS( WORK( 1, 2 ) ) )* $ SQRT( ABS( WORK( 2, 1 ) ) ) DELTA = DLAPY2( MU, WORK( 2, 1 ) ) CS = MU / DELTA SN = -WORK( 2, 1 ) / DELTA * * Form * * C**T = WORK(2:N,2:N) + i*[rwork(1) ..... rwork(n-1) ] * [ mu ] * [ .. ] * [ .. ] * [ mu ] * where C**T is transpose of matrix C, * and RWORK is stored starting in the N+1-st column of * WORK. * DO 30 J = 3, N WORK( 2, J ) = CS*WORK( 2, J ) WORK( J, J ) = WORK( J, J ) - WORK( 1, 1 ) 30 CONTINUE WORK( 2, 2 ) = ZERO * WORK( 1, N+1 ) = TWO*MU DO 40 I = 2, N - 1 WORK( I, N+1 ) = SN*WORK( 1, I+1 ) 40 CONTINUE N2 = 2 NN = 2*( N-1 ) END IF * * Estimate norm(inv(C**T)) * EST = ZERO KASE = 0 50 CONTINUE CALL DLACN2( NN, WORK( 1, N+2 ), WORK( 1, N+4 ), IWORK, $ EST, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN IF( N2.EQ.1 ) THEN * * Real eigenvalue: solve C**T*x = scale*c. * CALL DLAQTR( .TRUE., .TRUE., N-1, WORK( 2, 2 ), $ LDWORK, DUMMY, DUMM, SCALE, $ WORK( 1, N+4 ), WORK( 1, N+6 ), $ IERR ) ELSE * * Complex eigenvalue: solve * C**T*(p+iq) = scale*(c+id) in real arithmetic. * CALL DLAQTR( .TRUE., .FALSE., N-1, WORK( 2, 2 ), $ LDWORK, WORK( 1, N+1 ), MU, SCALE, $ WORK( 1, N+4 ), WORK( 1, N+6 ), $ IERR ) END IF ELSE IF( N2.EQ.1 ) THEN * * Real eigenvalue: solve C*x = scale*c. * CALL DLAQTR( .FALSE., .TRUE., N-1, WORK( 2, 2 ), $ LDWORK, DUMMY, DUMM, SCALE, $ WORK( 1, N+4 ), WORK( 1, N+6 ), $ IERR ) ELSE * * Complex eigenvalue: solve * C*(p+iq) = scale*(c+id) in real arithmetic. * CALL DLAQTR( .FALSE., .FALSE., N-1, $ WORK( 2, 2 ), LDWORK, $ WORK( 1, N+1 ), MU, SCALE, $ WORK( 1, N+4 ), WORK( 1, N+6 ), $ IERR ) * END IF END IF * GO TO 50 END IF END IF * SEP( KS ) = SCALE / MAX( EST, SMLNUM ) IF( PAIR ) $ SEP( KS+1 ) = SEP( KS ) END IF * IF( PAIR ) $ KS = KS + 1 * 60 CONTINUE RETURN * * End of DTRSNA * END *> \brief \b DTRSYL * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTRSYL + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, * LDC, SCALE, INFO ) * * .. Scalar Arguments .. * CHARACTER TRANA, TRANB * INTEGER INFO, ISGN, LDA, LDB, LDC, M, N * DOUBLE PRECISION SCALE * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTRSYL solves the real Sylvester matrix equation: *> *> op(A)*X + X*op(B) = scale*C or *> op(A)*X - X*op(B) = scale*C, *> *> where op(A) = A or A**T, and A and B are both upper quasi- *> triangular. A is M-by-M and B is N-by-N; the right hand side C and *> the solution X are M-by-N; and scale is an output scale factor, set *> <= 1 to avoid overflow in X. *> *> A and B must be in Schur canonical form (as returned by DHSEQR), that *> is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; *> each 2-by-2 diagonal block has its diagonal elements equal and its *> off-diagonal elements of opposite sign. *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANA *> \verbatim *> TRANA is CHARACTER*1 *> Specifies the option op(A): *> = 'N': op(A) = A (No transpose) *> = 'T': op(A) = A**T (Transpose) *> = 'C': op(A) = A**H (Conjugate transpose = Transpose) *> \endverbatim *> *> \param[in] TRANB *> \verbatim *> TRANB is CHARACTER*1 *> Specifies the option op(B): *> = 'N': op(B) = B (No transpose) *> = 'T': op(B) = B**T (Transpose) *> = 'C': op(B) = B**H (Conjugate transpose = Transpose) *> \endverbatim *> *> \param[in] ISGN *> \verbatim *> ISGN is INTEGER *> Specifies the sign in the equation: *> = +1: solve op(A)*X + X*op(B) = scale*C *> = -1: solve op(A)*X - X*op(B) = scale*C *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The order of the matrix A, and the number of rows in the *> matrices X and C. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix B, and the number of columns in the *> matrices X and C. N >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,M) *> The upper quasi-triangular matrix A, in Schur canonical form. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[in] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,N) *> The upper quasi-triangular matrix B, in Schur canonical form. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[in,out] C *> \verbatim *> C is DOUBLE PRECISION array, dimension (LDC,N) *> On entry, the M-by-N right hand side matrix C. *> On exit, C is overwritten by the solution matrix X. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the array C. LDC >= max(1,M) *> \endverbatim *> *> \param[out] SCALE *> \verbatim *> SCALE is DOUBLE PRECISION *> The scale factor, scale, set <= 1 to avoid overflow in X. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> = 1: A and B have common or very close eigenvalues; perturbed *> values were used to solve the equation (but the matrices *> A and B are unchanged). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleSYcomputational * * ===================================================================== SUBROUTINE DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, $ LDC, SCALE, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER TRANA, TRANB INTEGER INFO, ISGN, LDA, LDB, LDC, M, N DOUBLE PRECISION SCALE * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOTRNA, NOTRNB INTEGER IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT DOUBLE PRECISION A11, BIGNUM, DA11, DB, EPS, SCALOC, SGN, SMIN, $ SMLNUM, SUML, SUMR, XNORM * .. * .. Local Arrays .. DOUBLE PRECISION DUM( 1 ), VEC( 2, 2 ), X( 2, 2 ) * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT, DLAMCH, DLANGE EXTERNAL LSAME, DDOT, DLAMCH, DLANGE * .. * .. External Subroutines .. EXTERNAL DLABAD, DLALN2, DLASY2, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN * .. * .. Executable Statements .. * * Decode and Test input parameters * NOTRNA = LSAME( TRANA, 'N' ) NOTRNB = LSAME( TRANB, 'N' ) * INFO = 0 IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. .NOT. $ LSAME( TRANA, 'C' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'T' ) .AND. .NOT. $ LSAME( TRANB, 'C' ) ) THEN INFO = -2 ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -11 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTRSYL', -INFO ) RETURN END IF * * Quick return if possible * SCALE = ONE IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * * Set constants to control overflow * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = SMLNUM*DBLE( M*N ) / EPS BIGNUM = ONE / SMLNUM * SMIN = MAX( SMLNUM, EPS*DLANGE( 'M', M, M, A, LDA, DUM ), $ EPS*DLANGE( 'M', N, N, B, LDB, DUM ) ) * SGN = ISGN * IF( NOTRNA .AND. NOTRNB ) THEN * * Solve A*X + ISGN*X*B = scale*C. * * The (K,L)th block of X is determined starting from * bottom-left corner column by column by * * A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) * * Where * M L-1 * R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)]. * I=K+1 J=1 * * Start column loop (index = L) * L1 (L2) : column index of the first (first) row of X(K,L). * LNEXT = 1 DO 60 L = 1, N IF( L.LT.LNEXT ) $ GO TO 60 IF( L.EQ.N ) THEN L1 = L L2 = L ELSE IF( B( L+1, L ).NE.ZERO ) THEN L1 = L L2 = L + 1 LNEXT = L + 2 ELSE L1 = L L2 = L LNEXT = L + 1 END IF END IF * * Start row loop (index = K) * K1 (K2): row index of the first (last) row of X(K,L). * KNEXT = M DO 50 K = M, 1, -1 IF( K.GT.KNEXT ) $ GO TO 50 IF( K.EQ.1 ) THEN K1 = K K2 = K ELSE IF( A( K, K-1 ).NE.ZERO ) THEN K1 = K - 1 K2 = K KNEXT = K - 2 ELSE K1 = K K2 = K KNEXT = K - 1 END IF END IF * IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, $ C( MIN( K1+1, M ), L1 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) SCALOC = ONE * A11 = A( K1, K1 ) + SGN*B( L1, L1 ) DA11 = ABS( A11 ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( VEC( 1, 1 ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 * IF( SCALOC.NE.ONE ) THEN DO 10 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 10 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) * ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN * SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, A( K1, K1 ), $ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 20 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 20 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K2, L1 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN * SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, $ C( MIN( K1+1, M ), L1 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) ) * SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, $ C( MIN( K1+1, M ), L2 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 ) VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) ) * CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, B( L1, L1 ), $ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 30 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 30 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN * SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L2 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 ) VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L2 ), 1 ) SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L2 ), 1 ) VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR ) * CALL DLASY2( .FALSE., .FALSE., ISGN, 2, 2, $ A( K1, K1 ), LDA, B( L1, L1 ), LDB, VEC, $ 2, SCALOC, X, 2, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 40 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 40 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 1, 2 ) C( K2, L1 ) = X( 2, 1 ) C( K2, L2 ) = X( 2, 2 ) END IF * 50 CONTINUE * 60 CONTINUE * ELSE IF( .NOT.NOTRNA .AND. NOTRNB ) THEN * * Solve A**T *X + ISGN*X*B = scale*C. * * The (K,L)th block of X is determined starting from * upper-left corner column by column by * * A(K,K)**T*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) * * Where * K-1 T L-1 * R(K,L) = SUM [A(I,K)**T*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)] * I=1 J=1 * * Start column loop (index = L) * L1 (L2): column index of the first (last) row of X(K,L) * LNEXT = 1 DO 120 L = 1, N IF( L.LT.LNEXT ) $ GO TO 120 IF( L.EQ.N ) THEN L1 = L L2 = L ELSE IF( B( L+1, L ).NE.ZERO ) THEN L1 = L L2 = L + 1 LNEXT = L + 2 ELSE L1 = L L2 = L LNEXT = L + 1 END IF END IF * * Start row loop (index = K) * K1 (K2): row index of the first (last) row of X(K,L) * KNEXT = 1 DO 110 K = 1, M IF( K.LT.KNEXT ) $ GO TO 110 IF( K.EQ.M ) THEN K1 = K K2 = K ELSE IF( A( K+1, K ).NE.ZERO ) THEN K1 = K K2 = K + 1 KNEXT = K + 2 ELSE K1 = K K2 = K KNEXT = K + 1 END IF END IF * IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) SCALOC = ONE * A11 = A( K1, K1 ) + SGN*B( L1, L1 ) DA11 = ABS( A11 ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( VEC( 1, 1 ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 * IF( SCALOC.NE.ONE ) THEN DO 70 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 70 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) * ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN * SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, A( K1, K1 ), $ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 80 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 80 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K2, L1 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN * SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) ) * SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 ) VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) ) * CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, B( L1, L1 ), $ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 90 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 90 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN * SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 ) VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L2 ), 1 ) VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR ) * CALL DLASY2( .TRUE., .FALSE., ISGN, 2, 2, A( K1, K1 ), $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, $ 2, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 100 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 100 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 1, 2 ) C( K2, L1 ) = X( 2, 1 ) C( K2, L2 ) = X( 2, 2 ) END IF * 110 CONTINUE 120 CONTINUE * ELSE IF( .NOT.NOTRNA .AND. .NOT.NOTRNB ) THEN * * Solve A**T*X + ISGN*X*B**T = scale*C. * * The (K,L)th block of X is determined starting from * top-right corner column by column by * * A(K,K)**T*X(K,L) + ISGN*X(K,L)*B(L,L)**T = C(K,L) - R(K,L) * * Where * K-1 N * R(K,L) = SUM [A(I,K)**T*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)**T]. * I=1 J=L+1 * * Start column loop (index = L) * L1 (L2): column index of the first (last) row of X(K,L) * LNEXT = N DO 180 L = N, 1, -1 IF( L.GT.LNEXT ) $ GO TO 180 IF( L.EQ.1 ) THEN L1 = L L2 = L ELSE IF( B( L, L-1 ).NE.ZERO ) THEN L1 = L - 1 L2 = L LNEXT = L - 2 ELSE L1 = L L2 = L LNEXT = L - 1 END IF END IF * * Start row loop (index = K) * K1 (K2): row index of the first (last) row of X(K,L) * KNEXT = 1 DO 170 K = 1, M IF( K.LT.KNEXT ) $ GO TO 170 IF( K.EQ.M ) THEN K1 = K K2 = K ELSE IF( A( K+1, K ).NE.ZERO ) THEN K1 = K K2 = K + 1 KNEXT = K + 2 ELSE K1 = K K2 = K KNEXT = K + 1 END IF END IF * IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( N-L1, C( K1, MIN( L1+1, N ) ), LDC, $ B( L1, MIN( L1+1, N ) ), LDB ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) SCALOC = ONE * A11 = A( K1, K1 ) + SGN*B( L1, L1 ) DA11 = ABS( A11 ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( VEC( 1, 1 ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 * IF( SCALOC.NE.ONE ) THEN DO 130 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 130 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) * ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN * SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, A( K1, K1 ), $ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 140 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 140 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K2, L1 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN * SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) ) * SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L2, MIN( L2+1, N ) ), LDB ) VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) ) * CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, B( L1, L1 ), $ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 150 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 150 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN * SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L2, MIN( L2+1, N ) ), LDB ) VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, $ B( L2, MIN( L2+1, N ) ), LDB ) VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR ) * CALL DLASY2( .TRUE., .TRUE., ISGN, 2, 2, A( K1, K1 ), $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, $ 2, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 160 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 160 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 1, 2 ) C( K2, L1 ) = X( 2, 1 ) C( K2, L2 ) = X( 2, 2 ) END IF * 170 CONTINUE 180 CONTINUE * ELSE IF( NOTRNA .AND. .NOT.NOTRNB ) THEN * * Solve A*X + ISGN*X*B**T = scale*C. * * The (K,L)th block of X is determined starting from * bottom-right corner column by column by * * A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L)**T = C(K,L) - R(K,L) * * Where * M N * R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)**T]. * I=K+1 J=L+1 * * Start column loop (index = L) * L1 (L2): column index of the first (last) row of X(K,L) * LNEXT = N DO 240 L = N, 1, -1 IF( L.GT.LNEXT ) $ GO TO 240 IF( L.EQ.1 ) THEN L1 = L L2 = L ELSE IF( B( L, L-1 ).NE.ZERO ) THEN L1 = L - 1 L2 = L LNEXT = L - 2 ELSE L1 = L L2 = L LNEXT = L - 1 END IF END IF * * Start row loop (index = K) * K1 (K2): row index of the first (last) row of X(K,L) * KNEXT = M DO 230 K = M, 1, -1 IF( K.GT.KNEXT ) $ GO TO 230 IF( K.EQ.1 ) THEN K1 = K K2 = K ELSE IF( A( K, K-1 ).NE.ZERO ) THEN K1 = K - 1 K2 = K KNEXT = K - 2 ELSE K1 = K K2 = K KNEXT = K - 1 END IF END IF * IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, $ C( MIN( K1+1, M ), L1 ), 1 ) SUMR = DDOT( N-L1, C( K1, MIN( L1+1, N ) ), LDC, $ B( L1, MIN( L1+1, N ) ), LDB ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) SCALOC = ONE * A11 = A( K1, K1 ) + SGN*B( L1, L1 ) DA11 = ABS( A11 ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( VEC( 1, 1 ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 * IF( SCALOC.NE.ONE ) THEN DO 190 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 190 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) * ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN * SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, A( K1, K1 ), $ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 200 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 200 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K2, L1 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN * SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, $ C( MIN( K1+1, M ), L1 ), 1 ) SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) ) * SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, $ C( MIN( K1+1, M ), L2 ), 1 ) SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L2, MIN( L2+1, N ) ), LDB ) VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) ) * CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, B( L1, L1 ), $ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 210 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 210 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN * SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L2 ), 1 ) SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L2, MIN( L2+1, N ) ), LDB ) VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L2 ), 1 ) SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, $ B( L2, MIN( L2+1, N ) ), LDB ) VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR ) * CALL DLASY2( .FALSE., .TRUE., ISGN, 2, 2, A( K1, K1 ), $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, $ 2, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 220 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 220 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 1, 2 ) C( K2, L1 ) = X( 2, 1 ) C( K2, L2 ) = X( 2, 2 ) END IF * 230 CONTINUE 240 CONTINUE * END IF * RETURN * * End of DTRSYL * END *> \brief \b DTRTI2 computes the inverse of a triangular matrix (unblocked algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTRTI2 + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) * * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER INFO, LDA, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTRTI2 computes the inverse of a real upper or lower triangular *> matrix. *> *> This is the Level 2 BLAS version of the algorithm. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> Specifies whether the matrix A is upper or lower triangular. *> = 'U': Upper triangular *> = 'L': Lower triangular *> \endverbatim *> *> \param[in] DIAG *> \verbatim *> DIAG is CHARACTER*1 *> Specifies whether or not the matrix A is unit triangular. *> = 'N': Non-unit triangular *> = 'U': Unit triangular *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the triangular matrix A. If UPLO = 'U', the *> leading n by n upper triangular part of the array A contains *> the upper triangular matrix, and the strictly lower *> triangular part of A is not referenced. If UPLO = 'L', the *> leading n by n lower triangular part of the array A contains *> the lower triangular matrix, and the strictly upper *> triangular part of A is not referenced. If DIAG = 'U', the *> diagonal elements of A are also not referenced and are *> assumed to be 1. *> *> On exit, the (triangular) inverse of the original matrix, in *> the same storage format. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -k, the k-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO INTEGER INFO, LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOUNIT, UPPER INTEGER J DOUBLE PRECISION AJJ * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DSCAL, DTRMV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) NOUNIT = LSAME( DIAG, 'N' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTRTI2', -INFO ) RETURN END IF * IF( UPPER ) THEN * * Compute inverse of upper triangular matrix. * DO 10 J = 1, N IF( NOUNIT ) THEN A( J, J ) = ONE / A( J, J ) AJJ = -A( J, J ) ELSE AJJ = -ONE END IF * * Compute elements 1:j-1 of j-th column. * CALL DTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA, $ A( 1, J ), 1 ) CALL DSCAL( J-1, AJJ, A( 1, J ), 1 ) 10 CONTINUE ELSE * * Compute inverse of lower triangular matrix. * DO 20 J = N, 1, -1 IF( NOUNIT ) THEN A( J, J ) = ONE / A( J, J ) AJJ = -A( J, J ) ELSE AJJ = -ONE END IF IF( J.LT.N ) THEN * * Compute elements j+1:n of j-th column. * CALL DTRMV( 'Lower', 'No transpose', DIAG, N-J, $ A( J+1, J+1 ), LDA, A( J+1, J ), 1 ) CALL DSCAL( N-J, AJJ, A( J+1, J ), 1 ) END IF 20 CONTINUE END IF * RETURN * * End of DTRTI2 * END *> \brief \b DTRTRI * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTRTRI + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO ) * * .. Scalar Arguments .. * CHARACTER DIAG, UPLO * INTEGER INFO, LDA, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTRTRI computes the inverse of a real upper or lower triangular *> matrix A. *> *> This is the Level 3 BLAS version of the algorithm. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': A is upper triangular; *> = 'L': A is lower triangular. *> \endverbatim *> *> \param[in] DIAG *> \verbatim *> DIAG is CHARACTER*1 *> = 'N': A is non-unit triangular; *> = 'U': A is unit triangular. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the triangular matrix A. If UPLO = 'U', the *> leading N-by-N upper triangular part of the array A contains *> the upper triangular matrix, and the strictly lower *> triangular part of A is not referenced. If UPLO = 'L', the *> leading N-by-N lower triangular part of the array A contains *> the lower triangular matrix, and the strictly upper *> triangular part of A is not referenced. If DIAG = 'U', the *> diagonal elements of A are also not referenced and are *> assumed to be 1. *> On exit, the (triangular) inverse of the original matrix, in *> the same storage format. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, A(i,i) is exactly zero. The triangular *> matrix is singular and its inverse can not be computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO INTEGER INFO, LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOUNIT, UPPER INTEGER J, JB, NB, NN * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DTRMM, DTRSM, DTRTI2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) NOUNIT = LSAME( DIAG, 'N' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTRTRI', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Check for singularity if non-unit. * IF( NOUNIT ) THEN DO 10 INFO = 1, N IF( A( INFO, INFO ).EQ.ZERO ) $ RETURN 10 CONTINUE INFO = 0 END IF * * Determine the block size for this environment. * NB = ILAENV( 1, 'DTRTRI', UPLO // DIAG, N, -1, -1, -1 ) IF( NB.LE.1 .OR. NB.GE.N ) THEN * * Use unblocked code * CALL DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) ELSE * * Use blocked code * IF( UPPER ) THEN * * Compute inverse of upper triangular matrix * DO 20 J = 1, N, NB JB = MIN( NB, N-J+1 ) * * Compute rows 1:j-1 of current block column * CALL DTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1, $ JB, ONE, A, LDA, A( 1, J ), LDA ) CALL DTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1, $ JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA ) * * Compute inverse of current diagonal block * CALL DTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO ) 20 CONTINUE ELSE * * Compute inverse of lower triangular matrix * NN = ( ( N-1 ) / NB )*NB + 1 DO 30 J = NN, 1, -NB JB = MIN( NB, N-J+1 ) IF( J+JB.LE.N ) THEN * * Compute rows j+jb:n of current block column * CALL DTRMM( 'Left', 'Lower', 'No transpose', DIAG, $ N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA, $ A( J+JB, J ), LDA ) CALL DTRSM( 'Right', 'Lower', 'No transpose', DIAG, $ N-J-JB+1, JB, -ONE, A( J, J ), LDA, $ A( J+JB, J ), LDA ) END IF * * Compute inverse of current diagonal block * CALL DTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO ) 30 CONTINUE END IF END IF * RETURN * * End of DTRTRI * END *> \brief \b DTRTRS * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTRTRS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, * INFO ) * * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, LDA, LDB, N, NRHS * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTRTRS solves a triangular system of the form *> *> A * X = B or A**T * X = B, *> *> where A is a triangular matrix of order N, and B is an N-by-NRHS *> matrix. A check is made to verify that A is nonsingular. *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': A is upper triangular; *> = 'L': A is lower triangular. *> \endverbatim *> *> \param[in] TRANS *> \verbatim *> TRANS is 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) *> \endverbatim *> *> \param[in] DIAG *> \verbatim *> DIAG is CHARACTER*1 *> = 'N': A is non-unit triangular; *> = 'U': A is unit triangular. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER *> The number of right hand sides, i.e., the number of columns *> of the matrix B. NRHS >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The triangular matrix A. If UPLO = 'U', the leading N-by-N *> upper triangular part of the array A contains the upper *> triangular matrix, and the strictly lower triangular part of *> A is not referenced. If UPLO = 'L', the leading N-by-N lower *> triangular part of the array A contains the lower triangular *> matrix, and the strictly upper triangular part of A is not *> referenced. If DIAG = 'U', the diagonal elements of A are *> also not referenced and are assumed to be 1. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB,NRHS) *> On entry, the right hand side matrix B. *> On exit, if INFO = 0, the solution matrix X. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of the array B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> > 0: if INFO = i, the i-th diagonal element of A is zero, *> indicating that the matrix is singular and the solutions *> X have not been computed. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, $ INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO INTEGER INFO, LDA, LDB, N, NRHS * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOUNIT * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DTRSM, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 NOUNIT = LSAME( DIAG, 'N' ) IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT. $ LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN INFO = -2 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( NRHS.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTRTRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Check for singularity. * IF( NOUNIT ) THEN DO 10 INFO = 1, N IF( A( INFO, INFO ).EQ.ZERO ) $ RETURN 10 CONTINUE END IF INFO = 0 * * Solve A * x = b or A**T * x = b. * CALL DTRSM( 'Left', UPLO, TRANS, DIAG, N, NRHS, ONE, A, LDA, B, $ LDB ) * RETURN * * End of DTRTRS * END *> \brief \b DTRTTF copies a triangular matrix from the standard full format (TR) to the rectangular full packed format (TF). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTRTTF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO ) * * .. Scalar Arguments .. * CHARACTER TRANSR, UPLO * INTEGER INFO, N, LDA * .. * .. Array Arguments .. * DOUBLE PRECISION A( 0: LDA-1, 0: * ), ARF( 0: * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTRTTF copies a triangular matrix A from standard full format (TR) *> to rectangular full packed format (TF) . *> \endverbatim * * Arguments: * ========== * *> \param[in] TRANSR *> \verbatim *> TRANSR is CHARACTER*1 *> = 'N': ARF in Normal form is wanted; *> = 'T': ARF in Transpose form is wanted. *> \endverbatim *> *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': Upper triangle of A is stored; *> = 'L': Lower triangle of A is stored. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrix A. N >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N). *> On entry, the triangular matrix A. If UPLO = 'U', the *> leading N-by-N upper triangular part of the array A contains *> the upper triangular matrix, and the strictly lower *> triangular part of A is not referenced. If UPLO = 'L', the *> leading N-by-N lower triangular part of the array A contains *> the lower triangular matrix, and the strictly upper *> triangular part of A is not referenced. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the matrix A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] ARF *> \verbatim *> ARF is DOUBLE PRECISION array, dimension (NT). *> NT=N*(N+1)/2. On exit, the triangular matrix A in RFP format. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> We first consider Rectangular Full Packed (RFP) Format when N is *> even. We give an example where N = 6. *> *> AP is Upper AP is Lower *> *> 00 01 02 03 04 05 00 *> 11 12 13 14 15 10 11 *> 22 23 24 25 20 21 22 *> 33 34 35 30 31 32 33 *> 44 45 40 41 42 43 44 *> 55 50 51 52 53 54 55 *> *> *> Let TRANSR = 'N'. RFP holds AP as follows: *> For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last *> three columns of AP upper. The lower triangle A(4:6,0:2) consists of *> the transpose of the first three columns of AP upper. *> For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first *> three columns of AP lower. The upper triangle A(0:2,0:2) consists of *> the transpose of the last three columns of AP lower. *> This covers the case N even and TRANSR = 'N'. *> *> RFP A RFP A *> *> 03 04 05 33 43 53 *> 13 14 15 00 44 54 *> 23 24 25 10 11 55 *> 33 34 35 20 21 22 *> 00 44 45 30 31 32 *> 01 11 55 40 41 42 *> 02 12 22 50 51 52 *> *> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the *> transpose of RFP A above. One therefore gets: *> *> *> RFP A RFP A *> *> 03 13 23 33 00 01 02 33 00 10 20 30 40 50 *> 04 14 24 34 44 11 12 43 44 11 21 31 41 51 *> 05 15 25 35 45 55 22 53 54 55 22 32 42 52 *> *> *> We then consider Rectangular Full Packed (RFP) Format when N is *> odd. We give an example where N = 5. *> *> AP is Upper AP is Lower *> *> 00 01 02 03 04 00 *> 11 12 13 14 10 11 *> 22 23 24 20 21 22 *> 33 34 30 31 32 33 *> 44 40 41 42 43 44 *> *> *> Let TRANSR = 'N'. RFP holds AP as follows: *> For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last *> three columns of AP upper. The lower triangle A(3:4,0:1) consists of *> the transpose of the first two columns of AP upper. *> For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first *> three columns of AP lower. The upper triangle A(0:1,1:2) consists of *> the transpose of the last two columns of AP lower. *> This covers the case N odd and TRANSR = 'N'. *> *> RFP A RFP A *> *> 02 03 04 00 33 43 *> 12 13 14 10 11 44 *> 22 23 24 20 21 22 *> 00 33 34 30 31 32 *> 01 11 44 40 41 42 *> *> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the *> transpose of RFP A above. One therefore gets: *> *> RFP A RFP A *> *> 02 12 22 00 01 00 10 20 30 40 50 *> 03 13 23 33 11 33 11 21 31 41 51 *> 04 14 24 34 44 43 44 22 32 42 52 *> \endverbatim * * ===================================================================== SUBROUTINE DTRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER TRANSR, UPLO INTEGER INFO, N, LDA * .. * .. Array Arguments .. DOUBLE PRECISION A( 0: LDA-1, 0: * ), ARF( 0: * ) * .. * * ===================================================================== * * .. * .. Local Scalars .. LOGICAL LOWER, NISODD, NORMALTRANSR INTEGER I, IJ, J, K, L, N1, N2, NT, NX2, NP1X2 * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MOD * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 NORMALTRANSR = LSAME( TRANSR, 'N' ) LOWER = LSAME( UPLO, 'L' ) IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN INFO = -1 ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTRTTF', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.1 ) THEN IF( N.EQ.1 ) THEN ARF( 0 ) = A( 0, 0 ) END IF RETURN END IF * * Size of array ARF(0:nt-1) * NT = N*( N+1 ) / 2 * * Set N1 and N2 depending on LOWER: for N even N1=N2=K * IF( LOWER ) THEN N2 = N / 2 N1 = N - N2 ELSE N1 = N / 2 N2 = N - N1 END IF * * If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2. * If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is * N--by--(N+1)/2. * IF( MOD( N, 2 ).EQ.0 ) THEN K = N / 2 NISODD = .FALSE. IF( .NOT.LOWER ) $ NP1X2 = N + N + 2 ELSE NISODD = .TRUE. IF( .NOT.LOWER ) $ NX2 = N + N END IF * IF( NISODD ) THEN * * N is odd * IF( NORMALTRANSR ) THEN * * N is odd and TRANSR = 'N' * IF( LOWER ) THEN * * N is odd, TRANSR = 'N', and UPLO = 'L' * IJ = 0 DO J = 0, N2 DO I = N1, N2 + J ARF( IJ ) = A( N2+J, I ) IJ = IJ + 1 END DO DO I = J, N - 1 ARF( IJ ) = A( I, J ) IJ = IJ + 1 END DO END DO * ELSE * * N is odd, TRANSR = 'N', and UPLO = 'U' * IJ = NT - N DO J = N - 1, N1, -1 DO I = 0, J ARF( IJ ) = A( I, J ) IJ = IJ + 1 END DO DO L = J - N1, N1 - 1 ARF( IJ ) = A( J-N1, L ) IJ = IJ + 1 END DO IJ = IJ - NX2 END DO * END IF * ELSE * * N is odd and TRANSR = 'T' * IF( LOWER ) THEN * * N is odd, TRANSR = 'T', and UPLO = 'L' * IJ = 0 DO J = 0, N2 - 1 DO I = 0, J ARF( IJ ) = A( J, I ) IJ = IJ + 1 END DO DO I = N1 + J, N - 1 ARF( IJ ) = A( I, N1+J ) IJ = IJ + 1 END DO END DO DO J = N2, N - 1 DO I = 0, N1 - 1 ARF( IJ ) = A( J, I ) IJ = IJ + 1 END DO END DO * ELSE * * N is odd, TRANSR = 'T', and UPLO = 'U' * IJ = 0 DO J = 0, N1 DO I = N1, N - 1 ARF( IJ ) = A( J, I ) IJ = IJ + 1 END DO END DO DO J = 0, N1 - 1 DO I = 0, J ARF( IJ ) = A( I, J ) IJ = IJ + 1 END DO DO L = N2 + J, N - 1 ARF( IJ ) = A( N2+J, L ) IJ = IJ + 1 END DO END DO * END IF * END IF * ELSE * * N is even * IF( NORMALTRANSR ) THEN * * N is even and TRANSR = 'N' * IF( LOWER ) THEN * * N is even, TRANSR = 'N', and UPLO = 'L' * IJ = 0 DO J = 0, K - 1 DO I = K, K + J ARF( IJ ) = A( K+J, I ) IJ = IJ + 1 END DO DO I = J, N - 1 ARF( IJ ) = A( I, J ) IJ = IJ + 1 END DO END DO * ELSE * * N is even, TRANSR = 'N', and UPLO = 'U' * IJ = NT - N - 1 DO J = N - 1, K, -1 DO I = 0, J ARF( IJ ) = A( I, J ) IJ = IJ + 1 END DO DO L = J - K, K - 1 ARF( IJ ) = A( J-K, L ) IJ = IJ + 1 END DO IJ = IJ - NP1X2 END DO * END IF * ELSE * * N is even and TRANSR = 'T' * IF( LOWER ) THEN * * N is even, TRANSR = 'T', and UPLO = 'L' * IJ = 0 J = K DO I = K, N - 1 ARF( IJ ) = A( I, J ) IJ = IJ + 1 END DO DO J = 0, K - 2 DO I = 0, J ARF( IJ ) = A( J, I ) IJ = IJ + 1 END DO DO I = K + 1 + J, N - 1 ARF( IJ ) = A( I, K+1+J ) IJ = IJ + 1 END DO END DO DO J = K - 1, N - 1 DO I = 0, K - 1 ARF( IJ ) = A( J, I ) IJ = IJ + 1 END DO END DO * ELSE * * N is even, TRANSR = 'T', and UPLO = 'U' * IJ = 0 DO J = 0, K DO I = K, N - 1 ARF( IJ ) = A( J, I ) IJ = IJ + 1 END DO END DO DO J = 0, K - 2 DO I = 0, J ARF( IJ ) = A( I, J ) IJ = IJ + 1 END DO DO L = K + 1 + J, N - 1 ARF( IJ ) = A( K+1+J, L ) IJ = IJ + 1 END DO END DO * Note that here, on exit of the loop, J = K-1 DO I = 0, J ARF( IJ ) = A( I, J ) IJ = IJ + 1 END DO * END IF * END IF * END IF * RETURN * * End of DTRTTF * END *> \brief \b DTRTTP copies a triangular matrix from the standard full format (TR) to the standard packed format (TP). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTRTTP + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTRTTP( UPLO, N, A, LDA, AP, INFO ) * * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, N, LDA * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), AP( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTRTTP copies a triangular matrix A from full format (TR) to standard *> packed format (TP). *> \endverbatim * * Arguments: * ========== * *> \param[in] UPLO *> \verbatim *> UPLO is CHARACTER*1 *> = 'U': A is upper triangular. *> = 'L': A is lower triangular. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices AP and A. N >= 0. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On exit, the triangular matrix A. If UPLO = 'U', the leading *> N-by-N upper triangular part of A contains the upper *> triangular part of the matrix A, and the strictly lower *> triangular part of A is not referenced. If UPLO = 'L', the *> leading N-by-N lower triangular part of A contains the lower *> triangular part of the matrix A, and the strictly upper *> triangular part of A is not referenced. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,N). *> \endverbatim *> *> \param[out] AP *> \verbatim *> AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) *> On exit, the upper or lower triangular matrix A, packed *> columnwise in a linear array. The j-th column of A is stored *> in the array AP as follows: *> if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; *> if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DTRTTP( UPLO, N, A, LDA, AP, INFO ) * * -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, N, LDA * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), AP( * ) * .. * * ===================================================================== * * .. Parameters .. * .. * .. Local Scalars .. LOGICAL LOWER INTEGER I, J, K * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 LOWER = LSAME( UPLO, 'L' ) IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) 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( 'DTRTTP', -INFO ) RETURN END IF * IF( LOWER ) THEN K = 0 DO J = 1, N DO I = J, N K = K + 1 AP( K ) = A( I, J ) END DO END DO ELSE K = 0 DO J = 1, N DO I = 1, J K = K + 1 AP( K ) = A( I, J ) END DO END DO END IF * * RETURN * * End of DTRTTP * END *> \brief \b DTZRQF * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTZRQF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTZRQF( M, N, A, LDA, TAU, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> This routine is deprecated and has been replaced by routine DTZRZF. *> *> DTZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A *> to upper triangular form by means of orthogonal transformations. *> *> The upper trapezoidal matrix A is factored as *> *> A = ( R 0 ) * Z, *> *> where Z is an N-by-N orthogonal matrix and R is an M-by-M upper *> triangular matrix. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= M. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is 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 M+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. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (M) *> The scalar factors of the elementary reflectors. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup doubleOTHERcomputational * *> \par Further Details: * ===================== *> *> \verbatim *> *> 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 )**T, u( k ) = ( 1 ), *> ( 0 ) *> ( z( k ) ) *> *> tau is a scalar and z( k ) is an ( n - m ) element vector. *> tau and z( k ) are chosen to annihilate the elements of the kth row *> of X. *> *> The scalar tau is returned in the kth element of TAU and the vector *> u( k ) in the kth row of A, such that the elements of z( k ) are *> in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in *> the upper triangular part of A. *> *> Z is given by *> *> Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). *> \endverbatim *> * ===================================================================== SUBROUTINE DTZRQF( M, N, A, LDA, TAU, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, K, M1 * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMV, DGER, DLARFG, XERBLA * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.M ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTZRQF', -INFO ) RETURN END IF * * Perform the factorization. * IF( M.EQ.0 ) $ RETURN IF( M.EQ.N ) THEN DO 10 I = 1, N TAU( I ) = ZERO 10 CONTINUE ELSE M1 = MIN( M+1, N ) DO 20 K = M, 1, -1 * * Use a Householder reflection to zero the kth row of A. * First set up the reflection. * CALL DLARFG( N-M+1, A( K, K ), A( K, M1 ), LDA, TAU( K ) ) * IF( ( TAU( K ).NE.ZERO ) .AND. ( K.GT.1 ) ) THEN * * We now perform the operation A := A*P( k ). * * Use the first ( k - 1 ) elements of TAU to store a( k ), * where a( k ) consists of the first ( k - 1 ) elements of * the kth column of A. Also let B denote the first * ( k - 1 ) rows of the last ( n - m ) columns of A. * CALL DCOPY( K-1, A( 1, K ), 1, TAU, 1 ) * * Form w = a( k ) + B*z( k ) in TAU. * CALL DGEMV( 'No transpose', K-1, N-M, ONE, A( 1, M1 ), $ LDA, A( K, M1 ), LDA, ONE, TAU, 1 ) * * Now form a( k ) := a( k ) - tau*w * and B := B - tau*w*z( k )**T. * CALL DAXPY( K-1, -TAU( K ), TAU, 1, A( 1, K ), 1 ) CALL DGER( K-1, N-M, -TAU( K ), TAU, 1, A( K, M1 ), LDA, $ A( 1, M1 ), LDA ) END IF 20 CONTINUE END IF * RETURN * * End of DTZRQF * END *> \brief \b DTZRZF * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DTZRZF + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * * .. Scalar Arguments .. * INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> DTZRZF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A *> to upper triangular form by means of orthogonal transformations. *> *> The upper trapezoidal matrix A is factored as *> *> A = ( R 0 ) * Z, *> *> where Z is an N-by-N orthogonal matrix and R is an M-by-M upper *> triangular matrix. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. M >= 0. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. N >= M. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is 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 M+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. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (M) *> The scalar factors of the elementary reflectors. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is 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. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date April 2012 * *> \ingroup doubleOTHERcomputational * *> \par Contributors: * ================== *> *> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA * *> \par Further Details: * ===================== *> *> \verbatim *> *> The N-by-N matrix Z can be computed by *> *> Z = Z(1)*Z(2)* ... *Z(M) *> *> where each N-by-N Z(k) is given by *> *> Z(k) = I - tau(k)*v(k)*v(k)**T *> *> with v(k) is the kth row vector of the M-by-N matrix *> *> V = ( I A(:,M+1:N) ) *> *> I is the M-by-M identity matrix, A(:,M+1:N) *> is the output stored in A on exit from DTZRZF, *> and tau(k) is the kth element of the array TAU. *> *> \endverbatim *> * ===================================================================== SUBROUTINE DTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * April 2012 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IWS, KI, KK, LDWORK, LWKMIN, LWKOPT, $ M1, MU, NB, NBMIN, NX * .. * .. External Subroutines .. EXTERNAL XERBLA, DLARZB, DLARZT, DLATRZ * .. * .. 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.M ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF * IF( INFO.EQ.0 ) THEN IF( M.EQ.0 .OR. M.EQ.N ) THEN LWKOPT = 1 LWKMIN = 1 ELSE * * Determine the block size. * NB = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 ) LWKOPT = M*NB LWKMIN = MAX( 1, M ) END IF WORK( 1 ) = LWKOPT * IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN INFO = -7 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTZRZF', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * 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 * NBMIN = 2 NX = 1 IWS = M IF( NB.GT.1 .AND. NB.LT.M ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'DGERQF', ' ', M, N, -1, -1 ) ) IF( NX.LT.M ) 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.M .AND. NX.LT.M ) THEN * * Use blocked code initially. * The last kk rows are handled by the block method. * M1 = MIN( M+1, N ) KI = ( ( M-NX-1 ) / NB )*NB KK = MIN( M, KI+NB ) * DO 20 I = M - KK + KI + 1, M - KK + 1, -NB IB = MIN( M-I+1, NB ) * * Compute the TZ factorization of the current block * A(i:i+ib-1,i:n) * CALL DLATRZ( IB, N-I+1, N-M, A( I, I ), LDA, TAU( I ), $ WORK ) IF( I.GT.1 ) THEN * * Form the triangular factor of the block reflector * H = H(i+ib-1) . . . H(i+1) H(i) * CALL DLARZT( 'Backward', 'Rowwise', N-M, IB, A( I, M1 ), $ LDA, TAU( I ), WORK, LDWORK ) * * Apply H to A(1:i-1,i:n) from the right * CALL DLARZB( 'Right', 'No transpose', 'Backward', $ 'Rowwise', I-1, N-I+1, IB, N-M, A( I, M1 ), $ LDA, WORK, LDWORK, A( 1, I ), LDA, $ WORK( IB+1 ), LDWORK ) END IF 20 CONTINUE MU = I + NB - 1 ELSE MU = M END IF * * Use unblocked code to factor the last or only block * IF( MU.GT.0 ) $ CALL DLATRZ( MU, N, N-M, A, LDA, TAU, WORK ) * WORK( 1 ) = LWKOPT * RETURN * * End of DTZRZF * END *> \brief \b IEEECK * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download IEEECK + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) * * .. Scalar Arguments .. * INTEGER ISPEC * REAL ONE, ZERO * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> IEEECK is called from the ILAENV to verify that Infinity and *> possibly NaN arithmetic is safe (i.e. will not trap). *> \endverbatim * * Arguments: * ========== * *> \param[in] ISPEC *> \verbatim *> ISPEC is INTEGER *> Specifies whether to test just for inifinity arithmetic *> or whether to test for infinity and NaN arithmetic. *> = 0: Verify infinity arithmetic only. *> = 1: Verify infinity and NaN arithmetic. *> \endverbatim *> *> \param[in] ZERO *> \verbatim *> ZERO is REAL *> Must contain the value 0.0 *> This is passed to prevent the compiler from optimizing *> away this code. *> \endverbatim *> *> \param[in] ONE *> \verbatim *> ONE is REAL *> Must contain the value 1.0 *> This is passed to prevent the compiler from optimizing *> away this code. *> *> RETURN VALUE: INTEGER *> = 0: Arithmetic failed to produce the correct answers *> = 1: Arithmetic produced the correct answers *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER ISPEC REAL ONE, ZERO * .. * * ===================================================================== * * .. Local Scalars .. REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, $ NEGZRO, NEWZRO, POSINF * .. * .. Executable Statements .. IEEECK = 1 * POSINF = ONE / ZERO IF( POSINF.LE.ONE ) THEN IEEECK = 0 RETURN END IF * NEGINF = -ONE / ZERO IF( NEGINF.GE.ZERO ) THEN IEEECK = 0 RETURN END IF * NEGZRO = ONE / ( NEGINF+ONE ) IF( NEGZRO.NE.ZERO ) THEN IEEECK = 0 RETURN END IF * NEGINF = ONE / NEGZRO IF( NEGINF.GE.ZERO ) THEN IEEECK = 0 RETURN END IF * NEWZRO = NEGZRO + ZERO IF( NEWZRO.NE.ZERO ) THEN IEEECK = 0 RETURN END IF * POSINF = ONE / NEWZRO IF( POSINF.LE.ONE ) THEN IEEECK = 0 RETURN END IF * NEGINF = NEGINF*POSINF IF( NEGINF.GE.ZERO ) THEN IEEECK = 0 RETURN END IF * POSINF = POSINF*POSINF IF( POSINF.LE.ONE ) THEN IEEECK = 0 RETURN END IF * * * * * Return if we were only asked to check infinity arithmetic * IF( ISPEC.EQ.0 ) $ RETURN * NAN1 = POSINF + NEGINF * NAN2 = POSINF / NEGINF * NAN3 = POSINF / POSINF * NAN4 = POSINF*ZERO * NAN5 = NEGINF*NEGZRO * NAN6 = NAN5*ZERO * IF( NAN1.EQ.NAN1 ) THEN IEEECK = 0 RETURN END IF * IF( NAN2.EQ.NAN2 ) THEN IEEECK = 0 RETURN END IF * IF( NAN3.EQ.NAN3 ) THEN IEEECK = 0 RETURN END IF * IF( NAN4.EQ.NAN4 ) THEN IEEECK = 0 RETURN END IF * IF( NAN5.EQ.NAN5 ) THEN IEEECK = 0 RETURN END IF * IF( NAN6.EQ.NAN6 ) THEN IEEECK = 0 RETURN END IF * RETURN END *> \brief \b ILADLC scans a matrix for its last non-zero column. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ILADLC + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ILADLC( M, N, A, LDA ) * * .. Scalar Arguments .. * INTEGER M, N, LDA * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ILADLC scans A for its last non-zero column. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The m by n matrix A. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== INTEGER FUNCTION ILADLC( M, N, A, LDA ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER M, N, LDA * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I * .. * .. Executable Statements .. * * Quick test for the common case where one corner is non-zero. IF( N.EQ.0 ) THEN ILADLC = N ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN ILADLC = N ELSE * Now scan each column from the end, returning with the first non-zero. DO ILADLC = N, 1, -1 DO I = 1, M IF( A(I, ILADLC).NE.ZERO ) RETURN END DO END DO END IF RETURN END *> \brief \b ILADLR scans a matrix for its last non-zero row. * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ILADLR + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ILADLR( M, N, A, LDA ) * * .. Scalar Arguments .. * INTEGER M, N, LDA * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ILADLR scans A for its last non-zero row. *> \endverbatim * * Arguments: * ========== * *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix A. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix A. *> \endverbatim *> *> \param[in] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The m by n matrix A. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup OTHERauxiliary * * ===================================================================== INTEGER FUNCTION ILADLR( M, N, A, LDA ) * * -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. INTEGER M, N, LDA * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J * .. * .. Executable Statements .. * * Quick test for the common case where one corner is non-zero. IF( M.EQ.0 ) THEN ILADLR = M ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN ILADLR = M ELSE * Scan up each column tracking the last zero row seen. ILADLR = 0 DO J = 1, N I=M DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1)) I=I-1 ENDDO ILADLR = MAX( ILADLR, I ) END DO END IF RETURN END *> \brief \b ILAENV * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ILAENV + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) * * .. Scalar Arguments .. * CHARACTER*( * ) NAME, OPTS * INTEGER ISPEC, N1, N2, N3, N4 * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> ILAENV is called from the LAPACK routines to choose problem-dependent *> parameters for the local environment. See ISPEC for a description of *> the parameters. *> *> ILAENV returns an INTEGER *> if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC *> if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal value. *> *> This version provides a set of parameters which should give good, *> but not optimal, performance on many of the currently available *> computers. Users are encouraged to modify this subroutine to set *> the tuning parameters for their particular machine using the option *> and problem size information in the arguments. *> *> This routine will not function correctly if it is converted to all *> lower case. Converting it to all upper case is allowed. *> \endverbatim * * Arguments: * ========== * *> \param[in] ISPEC *> \verbatim *> ISPEC is INTEGER *> Specifies the parameter to be returned as the value of *> ILAENV. *> = 1: the optimal blocksize; if this value is 1, an unblocked *> algorithm will give the best performance. *> = 2: the minimum block size for which the block routine *> should be used; if the usable block size is less than *> this value, an unblocked routine should be used. *> = 3: the crossover point (in a block routine, for N less *> than this value, an unblocked routine should be used) *> = 4: the number of shifts, used in the nonsymmetric *> eigenvalue routines (DEPRECATED) *> = 5: the minimum column dimension for blocking to be used; *> rectangular blocks must have dimension at least k by m, *> where k is given by ILAENV(2,...) and m by ILAENV(5,...) *> = 6: the crossover point for the SVD (when reducing an m by n *> matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds *> this value, a QR factorization is used first to reduce *> the matrix to a triangular form.) *> = 7: the number of processors *> = 8: the crossover point for the multishift QR method *> for nonsymmetric eigenvalue problems (DEPRECATED) *> = 9: maximum size of the subproblems at the bottom of the *> computation tree in the divide-and-conquer algorithm *> (used by xGELSD and xGESDD) *> =10: ieee NaN arithmetic can be trusted not to trap *> =11: infinity arithmetic can be trusted not to trap *> 12 <= ISPEC <= 16: *> xHSEQR or related subroutines, *> see IPARMQ for detailed explanation *> \endverbatim *> *> \param[in] NAME *> \verbatim *> NAME is CHARACTER*(*) *> The name of the calling subroutine, in either upper case or *> lower case. *> \endverbatim *> *> \param[in] OPTS *> \verbatim *> OPTS is CHARACTER*(*) *> The character options to the subroutine NAME, concatenated *> into a single character string. For example, UPLO = 'U', *> TRANS = 'T', and DIAG = 'N' for a triangular routine would *> be specified as OPTS = 'UTN'. *> \endverbatim *> *> \param[in] N1 *> \verbatim *> N1 is INTEGER *> \endverbatim *> *> \param[in] N2 *> \verbatim *> N2 is INTEGER *> \endverbatim *> *> \param[in] N3 *> \verbatim *> N3 is INTEGER *> \endverbatim *> *> \param[in] N4 *> \verbatim *> N4 is INTEGER *> Problem dimensions for the subroutine NAME; these may not all *> be required. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date November 2017 * *> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> The following conventions have been used when calling ILAENV from the *> LAPACK routines: *> 1) OPTS is a concatenation of all of the character options to *> subroutine NAME, in the same order that they appear in the *> argument list for NAME, even if they are not used in determining *> the value of the parameter specified by ISPEC. *> 2) The problem dimensions N1, N2, N3, N4 are specified in the order *> that they appear in the argument list for NAME. N1 is used *> first, N2 second, and so on, and unused problem dimensions are *> passed a value of -1. *> 3) The parameter value returned by ILAENV is checked for validity in *> the calling subroutine. For example, ILAENV is used to retrieve *> the optimal blocksize for STRTRI as follows: *> *> NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) *> IF( NB.LE.1 ) NB = MAX( 1, N ) *> \endverbatim *> * ===================================================================== INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) * * -- LAPACK auxiliary routine (version 3.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * November 2017 * * .. Scalar Arguments .. CHARACTER*( * ) NAME, OPTS INTEGER ISPEC, N1, N2, N3, N4 * .. * * ===================================================================== * * .. Local Scalars .. INTEGER I, IC, IZ, NB, NBMIN, NX LOGICAL CNAME, SNAME, TWOSTAGE CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*16 * .. * .. Intrinsic Functions .. INTRINSIC CHAR, ICHAR, INT, MIN, REAL * .. * .. External Functions .. INTEGER IEEECK, IPARMQ, IPARAM2STAGE EXTERNAL IEEECK, IPARMQ, IPARAM2STAGE * .. * .. Executable Statements .. * GO TO ( 10, 10, 10, 80, 90, 100, 110, 120, $ 130, 140, 150, 160, 160, 160, 160, 160)ISPEC * * Invalid value for ISPEC * ILAENV = -1 RETURN * 10 CONTINUE * * Convert NAME to upper case if the first character is lower case. * ILAENV = 1 SUBNAM = NAME IC = ICHAR( SUBNAM( 1: 1 ) ) IZ = ICHAR( 'Z' ) IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN * * ASCII character set * IF( IC.GE.97 .AND. IC.LE.122 ) THEN SUBNAM( 1: 1 ) = CHAR( IC-32 ) DO 20 I = 2, 6 IC = ICHAR( SUBNAM( I: I ) ) IF( IC.GE.97 .AND. IC.LE.122 ) $ SUBNAM( I: I ) = CHAR( IC-32 ) 20 CONTINUE END IF * ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN * * EBCDIC character set * IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN SUBNAM( 1: 1 ) = CHAR( IC+64 ) DO 30 I = 2, 6 IC = ICHAR( SUBNAM( I: I ) ) IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: $ I ) = CHAR( IC+64 ) 30 CONTINUE END IF * ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN * * Prime machines: ASCII+128 * IF( IC.GE.225 .AND. IC.LE.250 ) THEN SUBNAM( 1: 1 ) = CHAR( IC-32 ) DO 40 I = 2, 6 IC = ICHAR( SUBNAM( I: I ) ) IF( IC.GE.225 .AND. IC.LE.250 ) $ SUBNAM( I: I ) = CHAR( IC-32 ) 40 CONTINUE END IF END IF * C1 = SUBNAM( 1: 1 ) SNAME = C1.EQ.'S' .OR. C1.EQ.'D' CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' IF( .NOT.( CNAME .OR. SNAME ) ) $ RETURN C2 = SUBNAM( 2: 3 ) C3 = SUBNAM( 4: 6 ) C4 = C3( 2: 3 ) TWOSTAGE = LEN( SUBNAM ).GE.11 $ .AND. SUBNAM( 11: 11 ).EQ.'2' * GO TO ( 50, 60, 70 )ISPEC * 50 CONTINUE * * ISPEC = 1: block size * * In these examples, separate code is provided for setting NB for * real and complex. We assume that NB will take the same value in * single or double precision. * NB = 1 * IF( C2.EQ.'GE' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. $ C3.EQ.'QLF' ) THEN IF( SNAME ) THEN NB = 32 ELSE NB = 32 END IF ELSE IF( C3.EQ.'QR ') THEN IF( N3 .EQ. 1) THEN IF( SNAME ) THEN * M*N IF ((N1*N2.LE.131072).OR.(N1.LE.8192)) THEN NB = N1 ELSE NB = 32768/N2 END IF ELSE IF ((N1*N2.LE.131072).OR.(N1.LE.8192)) THEN NB = N1 ELSE NB = 32768/N2 END IF END IF ELSE IF( SNAME ) THEN NB = 1 ELSE NB = 1 END IF END IF ELSE IF( C3.EQ.'LQ ') THEN IF( N3 .EQ. 2) THEN IF( SNAME ) THEN * M*N IF ((N1*N2.LE.131072).OR.(N1.LE.8192)) THEN NB = N1 ELSE NB = 32768/N2 END IF ELSE IF ((N1*N2.LE.131072).OR.(N1.LE.8192)) THEN NB = N1 ELSE NB = 32768/N2 END IF END IF ELSE IF( SNAME ) THEN NB = 1 ELSE NB = 1 END IF END IF ELSE IF( C3.EQ.'HRD' ) THEN IF( SNAME ) THEN NB = 32 ELSE NB = 32 END IF ELSE IF( C3.EQ.'BRD' ) THEN IF( SNAME ) THEN NB = 32 ELSE NB = 32 END IF ELSE IF( C3.EQ.'TRI' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( C2.EQ.'PO' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( C2.EQ.'SY' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN IF( TWOSTAGE ) THEN NB = 192 ELSE NB = 64 END IF ELSE IF( TWOSTAGE ) THEN NB = 192 ELSE NB = 64 END IF END IF ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN NB = 32 ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN NB = 64 END IF ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN IF( C3.EQ.'TRF' ) THEN IF( TWOSTAGE ) THEN NB = 192 ELSE NB = 64 END IF ELSE IF( C3.EQ.'TRD' ) THEN NB = 32 ELSE IF( C3.EQ.'GST' ) THEN NB = 64 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN IF( C3( 1: 1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) $ THEN NB = 32 END IF ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) $ THEN NB = 32 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN IF( C3( 1: 1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) $ THEN NB = 32 END IF ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) $ THEN NB = 32 END IF END IF ELSE IF( C2.EQ.'GB' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN IF( N4.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF ELSE IF( N4.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF END IF END IF ELSE IF( C2.EQ.'PB' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN IF( N2.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF ELSE IF( N2.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF END IF END IF ELSE IF( C2.EQ.'TR' ) THEN IF( C3.EQ.'TRI' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF ELSE IF ( C3.EQ.'EVC' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( C2.EQ.'LA' ) THEN IF( C3.EQ.'UUM' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN IF( C3.EQ.'EBZ' ) THEN NB = 1 END IF ELSE IF( C2.EQ.'GG' ) THEN NB = 32 IF( C3.EQ.'HD3' ) THEN IF( SNAME ) THEN NB = 32 ELSE NB = 32 END IF END IF END IF ILAENV = NB RETURN * 60 CONTINUE * * ISPEC = 2: minimum block size * NBMIN = 2 IF( C2.EQ.'GE' ) THEN IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. $ 'QLF' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF ELSE IF( C3.EQ.'HRD' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF ELSE IF( C3.EQ.'BRD' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF ELSE IF( C3.EQ.'TRI' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF END IF ELSE IF( C2.EQ.'SY' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NBMIN = 8 ELSE NBMIN = 8 END IF ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN NBMIN = 2 END IF ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN IF( C3.EQ.'TRD' ) THEN NBMIN = 2 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN IF( C3( 1: 1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) $ THEN NBMIN = 2 END IF ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) $ THEN NBMIN = 2 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN IF( C3( 1: 1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) $ THEN NBMIN = 2 END IF ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) $ THEN NBMIN = 2 END IF END IF ELSE IF( C2.EQ.'GG' ) THEN NBMIN = 2 IF( C3.EQ.'HD3' ) THEN NBMIN = 2 END IF END IF ILAENV = NBMIN RETURN * 70 CONTINUE * * ISPEC = 3: crossover point * NX = 0 IF( C2.EQ.'GE' ) THEN IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. $ 'QLF' ) THEN IF( SNAME ) THEN NX = 128 ELSE NX = 128 END IF ELSE IF( C3.EQ.'HRD' ) THEN IF( SNAME ) THEN NX = 128 ELSE NX = 128 END IF ELSE IF( C3.EQ.'BRD' ) THEN IF( SNAME ) THEN NX = 128 ELSE NX = 128 END IF END IF ELSE IF( C2.EQ.'SY' ) THEN IF( SNAME .AND. C3.EQ.'TRD' ) THEN NX = 32 END IF ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN IF( C3.EQ.'TRD' ) THEN NX = 32 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN IF( C3( 1: 1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) $ THEN NX = 128 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN IF( C3( 1: 1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) $ THEN NX = 128 END IF END IF ELSE IF( C2.EQ.'GG' ) THEN NX = 128 IF( C3.EQ.'HD3' ) THEN NX = 128 END IF END IF ILAENV = NX RETURN * 80 CONTINUE * * ISPEC = 4: number of shifts (used by xHSEQR) * ILAENV = 6 RETURN * 90 CONTINUE * * ISPEC = 5: minimum column dimension (not used) * ILAENV = 2 RETURN * 100 CONTINUE * * ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) * ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) RETURN * 110 CONTINUE * * ISPEC = 7: number of processors (not used) * ILAENV = 1 RETURN * 120 CONTINUE * * ISPEC = 8: crossover point for multishift (used by xHSEQR) * ILAENV = 50 RETURN * 130 CONTINUE * * ISPEC = 9: maximum size of the subproblems at the bottom of the * computation tree in the divide-and-conquer algorithm * (used by xGELSD and xGESDD) * ILAENV = 25 RETURN * 140 CONTINUE * * ISPEC = 10: ieee NaN arithmetic can be trusted not to trap * * ILAENV = 0 ILAENV = 1 IF( ILAENV.EQ.1 ) THEN ILAENV = IEEECK( 1, 0.0, 1.0 ) END IF RETURN * 150 CONTINUE * * ISPEC = 11: infinity arithmetic can be trusted not to trap * * ILAENV = 0 ILAENV = 1 IF( ILAENV.EQ.1 ) THEN ILAENV = IEEECK( 0, 0.0, 1.0 ) END IF RETURN * 160 CONTINUE * * 12 <= ISPEC <= 16: xHSEQR or related subroutines. * ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) RETURN * * End of ILAENV * END *> \brief \b ILAPREC * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ILAPREC + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ILAPREC( PREC ) * * .. Scalar Arguments .. * CHARACTER PREC * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> This subroutine translated from a character string specifying an *> intermediate precision to the relevant BLAST-specified integer *> constant. *> *> ILAPREC returns an INTEGER. If ILAPREC < 0, then the input is not a *> character indicating a supported intermediate precision. Otherwise *> ILAPREC returns the constant value corresponding to PREC. *> \endverbatim * * Arguments: * ========== * * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== INTEGER FUNCTION ILAPREC( PREC ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER PREC * .. * * ===================================================================== * * .. Parameters .. INTEGER BLAS_PREC_SINGLE, BLAS_PREC_DOUBLE, BLAS_PREC_INDIGENOUS, $ BLAS_PREC_EXTRA PARAMETER ( BLAS_PREC_SINGLE = 211, BLAS_PREC_DOUBLE = 212, $ BLAS_PREC_INDIGENOUS = 213, BLAS_PREC_EXTRA = 214 ) * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Executable Statements .. IF( LSAME( PREC, 'S' ) ) THEN ILAPREC = BLAS_PREC_SINGLE ELSE IF( LSAME( PREC, 'D' ) ) THEN ILAPREC = BLAS_PREC_DOUBLE ELSE IF( LSAME( PREC, 'I' ) ) THEN ILAPREC = BLAS_PREC_INDIGENOUS ELSE IF( LSAME( PREC, 'X' ) .OR. LSAME( PREC, 'E' ) ) THEN ILAPREC = BLAS_PREC_EXTRA ELSE ILAPREC = -1 END IF RETURN * * End of ILAPREC * END *> \brief \b ILATRANS * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ILATRANS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION ILATRANS( TRANS ) * * .. Scalar Arguments .. * CHARACTER TRANS * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> This subroutine translates from a character string specifying a *> transposition operation to the relevant BLAST-specified integer *> constant. *> *> ILATRANS returns an INTEGER. If ILATRANS < 0, then the input is not *> a character indicating a transposition operator. Otherwise ILATRANS *> returns the constant value corresponding to TRANS. *> \endverbatim * * Arguments: * ========== * * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date December 2016 * *> \ingroup auxOTHERcomputational * * ===================================================================== INTEGER FUNCTION ILATRANS( TRANS ) * * -- LAPACK computational routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * December 2016 * * .. Scalar Arguments .. CHARACTER TRANS * .. * * ===================================================================== * * .. Parameters .. INTEGER BLAS_NO_TRANS, BLAS_TRANS, BLAS_CONJ_TRANS PARAMETER ( BLAS_NO_TRANS = 111, BLAS_TRANS = 112, $ BLAS_CONJ_TRANS = 113 ) * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Executable Statements .. IF( LSAME( TRANS, 'N' ) ) THEN ILATRANS = BLAS_NO_TRANS ELSE IF( LSAME( TRANS, 'T' ) ) THEN ILATRANS = BLAS_TRANS ELSE IF( LSAME( TRANS, 'C' ) ) THEN ILATRANS = BLAS_CONJ_TRANS ELSE ILATRANS = -1 END IF RETURN * * End of ILATRANS * END *> \brief \b ILAVER returns the LAPACK version. ** * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH ) * * INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH * * *> \par Purpose: * ============= *> *> \verbatim *> *> This subroutine returns the LAPACK version. *> \endverbatim * * Arguments: * ========== * *> \param[out] VERS_MAJOR *> return the lapack major version *> *> \param[out] VERS_MINOR *> return the lapack minor version from the major version *> *> \param[out] VERS_PATCH *> return the lapack patch version from the minor version * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup auxOTHERauxiliary * * ===================================================================== SUBROUTINE ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH ) * * -- LAPACK computational routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * ===================================================================== * INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH * ===================================================================== VERS_MAJOR = 3 VERS_MINOR = 8 VERS_PATCH = 0 * ===================================================================== * RETURN END # 1 "SRC/iparam2stage.F" # 1 "" 1 # 1 "" 3 # 330 "" 3 # 1 "" 1 # 1 "" 2 # 1 "SRC/iparam2stage.F" 2 *> \brief \b IPARAM2STAGE * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download IPARAM2STAGE + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION IPARAM2STAGE( ISPEC, NAME, OPTS, * NI, NBI, IBI, NXI ) * #if defined(_OPENMP) * use omp_lib * #endif * IMPLICIT NONE * * .. Scalar Arguments .. * CHARACTER*( * ) NAME, OPTS * INTEGER ISPEC, NI, NBI, IBI, NXI * *> \par Purpose: * ============= *> *> \verbatim *> *> This program sets problem and machine dependent parameters *> useful for xHETRD_2STAGE, xHETRD_H@2HB, xHETRD_HB2ST, *> xGEBRD_2STAGE, xGEBRD_GE2GB, xGEBRD_GB2BD *> and related subroutines for eigenvalue problems. *> It is called whenever ILAENV is called with 17 <= ISPEC <= 21. *> It is called whenever ILAENV2STAGE is called with 1 <= ISPEC <= 5 *> with a direct conversion ISPEC + 16. *> \endverbatim * * Arguments: * ========== * *> \param[in] ISPEC *> \verbatim *> ISPEC is integer scalar *> ISPEC specifies which tunable parameter IPARAM2STAGE should *> return. *> *> ISPEC=17: the optimal blocksize nb for the reduction to * BAND *> *> ISPEC=18: the optimal blocksize ib for the eigenvectors *> singular vectors update routine *> *> ISPEC=19: The length of the array that store the Housholder *> representation for the second stage *> Band to Tridiagonal or Bidiagonal *> *> ISPEC=20: The workspace needed for the routine in input. *> *> ISPEC=21: For future release. *> \endverbatim *> *> \param[in] NAME *> \verbatim *> NAME is character string *> Name of the calling subroutine *> \endverbatim *> *> \param[in] OPTS *> \verbatim *> OPTS is CHARACTER*(*) *> The character options to the subroutine NAME, concatenated *> into a single character string. For example, UPLO = 'U', *> TRANS = 'T', and DIAG = 'N' for a triangular routine would *> be specified as OPTS = 'UTN'. *> \endverbatim *> *> \param[in] NI *> \verbatim *> NI is INTEGER which is the size of the matrix *> \endverbatim *> *> \param[in] NBI *> \verbatim *> NBI is INTEGER which is the used in the reduciton, * (e.g., the size of the band), needed to compute workspace * and LHOUS2. *> \endverbatim *> *> \param[in] IBI *> \verbatim *> IBI is INTEGER which represent the IB of the reduciton, * needed to compute workspace and LHOUS2. *> \endverbatim *> *> \param[in] NXI *> \verbatim *> NXI is INTEGER needed in the future release. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2016 * *> \ingroup auxOTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> Implemented by Azzam Haidar. *> *> All detail are available on technical report, SC11, SC13 papers. *> *> Azzam Haidar, Hatem Ltaief, and Jack Dongarra. *> Parallel reduction to condensed forms for symmetric eigenvalue problems *> using aggregated fine-grained and memory-aware kernels. In Proceedings *> of 2011 International Conference for High Performance Computing, *> Networking, Storage and Analysis (SC '11), New York, NY, USA, *> Article 8 , 11 pages. *> http://doi.acm.org/10.1145/2063384.2063394 *> *> A. Haidar, J. Kurzak, P. Luszczek, 2013. *> An improved parallel singular value algorithm and its implementation *> for multicore hardware, In Proceedings of 2013 International Conference *> for High Performance Computing, Networking, Storage and Analysis (SC '13). *> Denver, Colorado, USA, 2013. *> Article 90, 12 pages. *> http://doi.acm.org/10.1145/2503210.2503292 *> *> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. *> A novel hybrid CPU-GPU generalized eigensolver for electronic structure *> calculations based on fine-grained memory aware tasks. *> International Journal of High Performance Computing Applications. *> Volume 28 Issue 2, Pages 196-209, May 2014. *> http://hpc.sagepub.com/content/28/2/196 *> *> \endverbatim *> * ===================================================================== INTEGER FUNCTION IPARAM2STAGE( ISPEC, NAME, OPTS, $ NI, NBI, IBI, NXI ) IMPLICIT NONE * * -- LAPACK auxiliary routine (version 3.8.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2016 * * .. Scalar Arguments .. CHARACTER*( * ) NAME, OPTS INTEGER ISPEC, NI, NBI, IBI, NXI * * ================================================================ * .. * .. Local Scalars .. INTEGER I, IC, IZ, KD, IB, LHOUS, LWORK, NTHREADS, $ FACTOPTNB, QROPTNB, LQOPTNB LOGICAL RPREC, CPREC CHARACTER PREC*1, ALGO*3, STAG*5, SUBNAM*12, VECT*1 * .. * .. Intrinsic Functions .. INTRINSIC CHAR, ICHAR, MAX * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Invalid value for ISPEC * IF( (ISPEC.LT.17).OR.(ISPEC.GT.21) ) THEN IPARAM2STAGE = -1 RETURN ENDIF * * Get the number of threads * NTHREADS = 1 * WRITE(*,*) 'IPARAM VOICI NTHREADS ISPEC ',NTHREADS, ISPEC * IF( ISPEC .NE. 19 ) THEN * * Convert NAME to upper case if the first character is lower case. * IPARAM2STAGE = -1 SUBNAM = NAME IC = ICHAR( SUBNAM( 1: 1 ) ) IZ = ICHAR( 'Z' ) IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN * * ASCII character set * IF( IC.GE.97 .AND. IC.LE.122 ) THEN SUBNAM( 1: 1 ) = CHAR( IC-32 ) DO 100 I = 2, 12 IC = ICHAR( SUBNAM( I: I ) ) IF( IC.GE.97 .AND. IC.LE.122 ) $ SUBNAM( I: I ) = CHAR( IC-32 ) 100 CONTINUE END IF * ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN * * EBCDIC character set * IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN SUBNAM( 1: 1 ) = CHAR( IC+64 ) DO 110 I = 2, 12 IC = ICHAR( SUBNAM( I: I ) ) IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: $ I ) = CHAR( IC+64 ) 110 CONTINUE END IF * ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN * * Prime machines: ASCII+128 * IF( IC.GE.225 .AND. IC.LE.250 ) THEN SUBNAM( 1: 1 ) = CHAR( IC-32 ) DO 120 I = 2, 12 IC = ICHAR( SUBNAM( I: I ) ) IF( IC.GE.225 .AND. IC.LE.250 ) $ SUBNAM( I: I ) = CHAR( IC-32 ) 120 CONTINUE END IF END IF * PREC = SUBNAM( 1: 1 ) ALGO = SUBNAM( 4: 6 ) STAG = SUBNAM( 8:12 ) RPREC = PREC.EQ.'S' .OR. PREC.EQ.'D' CPREC = PREC.EQ.'C' .OR. PREC.EQ.'Z' * * Invalid value for PRECISION * IF( .NOT.( RPREC .OR. CPREC ) ) THEN IPARAM2STAGE = -1 RETURN ENDIF ENDIF * WRITE(*,*),'RPREC,CPREC ',RPREC,CPREC, * $ ' ALGO ',ALGO,' STAGE ',STAG * * IF (( ISPEC .EQ. 17 ) .OR. ( ISPEC .EQ. 18 )) THEN * * ISPEC = 17, 18: block size KD, IB * Could be also dependent from N but for now it * depend only on sequential or parallel * IF( NTHREADS.GT.4 ) THEN IF( CPREC ) THEN KD = 128 IB = 32 ELSE KD = 160 IB = 40 ENDIF ELSE IF( NTHREADS.GT.1 ) THEN IF( CPREC ) THEN KD = 64 IB = 32 ELSE KD = 64 IB = 32 ENDIF ELSE IF( CPREC ) THEN KD = 16 IB = 16 ELSE KD = 32 IB = 16 ENDIF ENDIF IF( ISPEC.EQ.17 ) IPARAM2STAGE = KD IF( ISPEC.EQ.18 ) IPARAM2STAGE = IB * ELSE IF ( ISPEC .EQ. 19 ) THEN * * ISPEC = 19: * LHOUS length of the Houselholder representation * matrix (V,T) of the second stage. should be >= 1. * * Will add the VECT OPTION HERE next release VECT = OPTS(1:1) IF( VECT.EQ.'N' ) THEN LHOUS = MAX( 1, 4*NI ) ELSE * This is not correct, it need to call the ALGO and the stage2 LHOUS = MAX( 1, 4*NI ) + IBI ENDIF IF( LHOUS.GE.0 ) THEN IPARAM2STAGE = LHOUS ELSE IPARAM2STAGE = -1 ENDIF * ELSE IF ( ISPEC .EQ. 20 ) THEN * * ISPEC = 20: (21 for future use) * LWORK length of the workspace for * either or both stages for TRD and BRD. should be >= 1. * TRD: * TRD_stage 1: = LT + LW + LS1 + LS2 * = LDT*KD + N*KD + N*MAX(KD,FACTOPTNB) + LDS2*KD * where LDT=LDS2=KD * = N*KD + N*max(KD,FACTOPTNB) + 2*KD*KD * TRD_stage 2: = (2NB+1)*N + KD*NTHREADS * TRD_both : = max(stage1,stage2) + AB ( AB=(KD+1)*N ) * = N*KD + N*max(KD+1,FACTOPTNB) * + max(2*KD*KD, KD*NTHREADS) * + (KD+1)*N LWORK = -1 SUBNAM(1:1) = PREC SUBNAM(2:6) = 'GEQRF' QROPTNB = ILAENV( 1, SUBNAM, ' ', NI, NBI, -1, -1 ) SUBNAM(2:6) = 'GELQF' LQOPTNB = ILAENV( 1, SUBNAM, ' ', NBI, NI, -1, -1 ) * Could be QR or LQ for TRD and the max for BRD FACTOPTNB = MAX(QROPTNB, LQOPTNB) IF( ALGO.EQ.'TRD' ) THEN IF( STAG.EQ.'2STAG' ) THEN LWORK = NI*NBI + NI*MAX(NBI+1,FACTOPTNB) $ + MAX(2*NBI*NBI, NBI*NTHREADS) $ + (NBI+1)*NI ELSE IF( (STAG.EQ.'HE2HB').OR.(STAG.EQ.'SY2SB') ) THEN LWORK = NI*NBI + NI*MAX(NBI,FACTOPTNB) + 2*NBI*NBI ELSE IF( (STAG.EQ.'HB2ST').OR.(STAG.EQ.'SB2ST') ) THEN LWORK = (2*NBI+1)*NI + NBI*NTHREADS ENDIF ELSE IF( ALGO.EQ.'BRD' ) THEN IF( STAG.EQ.'2STAG' ) THEN LWORK = 2*NI*NBI + NI*MAX(NBI+1,FACTOPTNB) $ + MAX(2*NBI*NBI, NBI*NTHREADS) $ + (NBI+1)*NI ELSE IF( STAG.EQ.'GE2GB' ) THEN LWORK = NI*NBI + NI*MAX(NBI,FACTOPTNB) + 2*NBI*NBI ELSE IF( STAG.EQ.'GB2BD' ) THEN LWORK = (3*NBI+1)*NI + NBI*NTHREADS ENDIF ENDIF LWORK = MAX ( 1, LWORK ) IF( LWORK.GT.0 ) THEN IPARAM2STAGE = LWORK ELSE IPARAM2STAGE = -1 ENDIF * ELSE IF ( ISPEC .EQ. 21 ) THEN * * ISPEC = 21 for future use IPARAM2STAGE = NXI ENDIF * * ==== End of IPARAM2STAGE ==== * END *> \brief \b IPARMQ * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download IPARMQ + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) * * .. Scalar Arguments .. * INTEGER IHI, ILO, ISPEC, LWORK, N * CHARACTER NAME*( * ), OPTS*( * ) * * *> \par Purpose: * ============= *> *> \verbatim *> *> This program sets problem and machine dependent parameters *> useful for xHSEQR and related subroutines for eigenvalue *> problems. It is called whenever *> IPARMQ is called with 12 <= ISPEC <= 16 *> \endverbatim * * Arguments: * ========== * *> \param[in] ISPEC *> \verbatim *> ISPEC is INTEGER *> ISPEC specifies which tunable parameter IPARMQ should *> return. *> *> ISPEC=12: (INMIN) Matrices of order nmin or less *> are sent directly to xLAHQR, the implicit *> double shift QR algorithm. NMIN must be *> at least 11. *> *> ISPEC=13: (INWIN) Size of the deflation window. *> This is best set greater than or equal to *> the number of simultaneous shifts NS. *> Larger matrices benefit from larger deflation *> windows. *> *> ISPEC=14: (INIBL) Determines when to stop nibbling and *> invest in an (expensive) multi-shift QR sweep. *> If the aggressive early deflation subroutine *> finds LD converged eigenvalues from an order *> NW deflation window and LD.GT.(NW*NIBBLE)/100, *> then the next QR sweep is skipped and early *> deflation is applied immediately to the *> remaining active diagonal block. Setting *> IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a *> multi-shift QR sweep whenever early deflation *> finds a converged eigenvalue. Setting *> IPARMQ(ISPEC=14) greater than or equal to 100 *> prevents TTQRE from skipping a multi-shift *> QR sweep. *> *> ISPEC=15: (NSHFTS) The number of simultaneous shifts in *> a multi-shift QR iteration. *> *> ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the *> following meanings. *> 0: During the multi-shift QR/QZ sweep, *> blocked eigenvalue reordering, blocked *> Hessenberg-triangular reduction, *> reflections and/or rotations are not *> accumulated when updating the *> far-from-diagonal matrix entries. *> 1: During the multi-shift QR/QZ sweep, *> blocked eigenvalue reordering, blocked *> Hessenberg-triangular reduction, *> reflections and/or rotations are *> accumulated, and matrix-matrix *> multiplication is used to update the *> far-from-diagonal matrix entries. *> 2: During the multi-shift QR/QZ sweep, *> blocked eigenvalue reordering, blocked *> Hessenberg-triangular reduction, *> reflections and/or rotations are *> accumulated, and 2-by-2 block structure *> is exploited during matrix-matrix *> multiplies. *> (If xTRMM is slower than xGEMM, then *> IPARMQ(ISPEC=16)=1 may be more efficient than *> IPARMQ(ISPEC=16)=2 despite the greater level of *> arithmetic work implied by the latter choice.) *> \endverbatim *> *> \param[in] NAME *> \verbatim *> NAME is character string *> Name of the calling subroutine *> \endverbatim *> *> \param[in] OPTS *> \verbatim *> OPTS is character string *> This is a concatenation of the string arguments to *> TTQRE. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> N is the order of the Hessenberg matrix H. *> \endverbatim *> *> \param[in] ILO *> \verbatim *> ILO is INTEGER *> \endverbatim *> *> \param[in] IHI *> \verbatim *> IHI is INTEGER *> It is assumed that H is already upper triangular *> in rows and columns 1:ILO-1 and IHI+1:N. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The amount of workspace available. *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \date June 2017 * *> \ingroup OTHERauxiliary * *> \par Further Details: * ===================== *> *> \verbatim *> *> Little is known about how best to choose these parameters. *> It is possible to use different values of the parameters *> for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR. *> *> It is probably best to choose different parameters for *> different matrices and different parameters at different *> times during the iteration, but this has not been *> implemented --- yet. *> *> *> The best choices of most of the parameters depend *> in an ill-understood way on the relative execution *> rate of xLAQR3 and xLAQR5 and on the nature of each *> particular eigenvalue problem. Experiment may be the *> only practical way to determine which choices are most *> effective. *> *> Following is a list of default values supplied by IPARMQ. *> These defaults may be adjusted in order to attain better *> performance in any particular computational environment. *> *> IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point. *> Default: 75. (Must be at least 11.) *> *> IPARMQ(ISPEC=13) Recommended deflation window size. *> This depends on ILO, IHI and NS, the *> number of simultaneous shifts returned *> by IPARMQ(ISPEC=15). The default for *> (IHI-ILO+1).LE.500 is NS. The default *> for (IHI-ILO+1).GT.500 is 3*NS/2. *> *> IPARMQ(ISPEC=14) Nibble crossover point. Default: 14. *> *> IPARMQ(ISPEC=15) Number of simultaneous shifts, NS. *> a multi-shift QR iteration. *> *> If IHI-ILO+1 is ... *> *> greater than ...but less ... the *> or equal to ... than default is *> *> 0 30 NS = 2+ *> 30 60 NS = 4+ *> 60 150 NS = 10 *> 150 590 NS = ** *> 590 3000 NS = 64 *> 3000 6000 NS = 128 *> 6000 infinity NS = 256 *> *> (+) By default matrices of this order are *> passed to the implicit double shift routine *> xLAHQR. See IPARMQ(ISPEC=12) above. These *> values of NS are used only in case of a rare *> xLAHQR failure. *> *> (**) The asterisks (**) indicate an ad-hoc *> function increasing from 10 to 64. *> *> IPARMQ(ISPEC=16) Select structured matrix multiply. *> (See ISPEC=16 above for details.) *> Default: 3. *> \endverbatim *> * ===================================================================== INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) * * -- LAPACK auxiliary routine (version 3.7.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * June 2017 * * .. Scalar Arguments .. INTEGER IHI, ILO, ISPEC, LWORK, N CHARACTER NAME*( * ), OPTS*( * ) * * ================================================================ * .. Parameters .. INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22 PARAMETER ( INMIN = 12, INWIN = 13, INIBL = 14, $ ISHFTS = 15, IACC22 = 16 ) INTEGER NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP PARAMETER ( NMIN = 75, K22MIN = 14, KACMIN = 14, $ NIBBLE = 14, KNWSWP = 500 ) REAL TWO PARAMETER ( TWO = 2.0 ) * .. * .. Local Scalars .. INTEGER NH, NS INTEGER I, IC, IZ CHARACTER SUBNAM*6 * .. * .. Intrinsic Functions .. INTRINSIC LOG, MAX, MOD, NINT, REAL * .. * .. Executable Statements .. IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR. $ ( ISPEC.EQ.IACC22 ) ) THEN * * ==== Set the number simultaneous shifts ==== * NH = IHI - ILO + 1 NS = 2 IF( NH.GE.30 ) $ NS = 4 IF( NH.GE.60 ) $ NS = 10 IF( NH.GE.150 ) $ NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ) ) IF( NH.GE.590 ) $ NS = 64 IF( NH.GE.3000 ) $ NS = 128 IF( NH.GE.6000 ) $ NS = 256 NS = MAX( 2, NS-MOD( NS, 2 ) ) END IF * IF( ISPEC.EQ.INMIN ) THEN * * * ===== Matrices of order smaller than NMIN get sent * . to xLAHQR, the classic double shift algorithm. * . This must be at least 11. ==== * IPARMQ = NMIN * ELSE IF( ISPEC.EQ.INIBL ) THEN * * ==== INIBL: skip a multi-shift qr iteration and * . whenever aggressive early deflation finds * . at least (NIBBLE*(window size)/100) deflations. ==== * IPARMQ = NIBBLE * ELSE IF( ISPEC.EQ.ISHFTS ) THEN * * ==== NSHFTS: The number of simultaneous shifts ===== * IPARMQ = NS * ELSE IF( ISPEC.EQ.INWIN ) THEN * * ==== NW: deflation window size. ==== * IF( NH.LE.KNWSWP ) THEN IPARMQ = NS ELSE IPARMQ = 3*NS / 2 END IF * ELSE IF( ISPEC.EQ.IACC22 ) THEN * * ==== IACC22: Whether to accumulate reflections * . before updating the far-from-diagonal elements * . and whether to use 2-by-2 block structure while * . doing it. A small amount of work could be saved * . by making this choice dependent also upon the * . NH=IHI-ILO+1. * * * Convert NAME to upper case if the first character is lower case. * IPARMQ = 0 SUBNAM = NAME IC = ICHAR( SUBNAM( 1: 1 ) ) IZ = ICHAR( 'Z' ) IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN * * ASCII character set * IF( IC.GE.97 .AND. IC.LE.122 ) THEN SUBNAM( 1: 1 ) = CHAR( IC-32 ) DO I = 2, 6 IC = ICHAR( SUBNAM( I: I ) ) IF( IC.GE.97 .AND. IC.LE.122 ) $ SUBNAM( I: I ) = CHAR( IC-32 ) END DO END IF * ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN * * EBCDIC character set * IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN SUBNAM( 1: 1 ) = CHAR( IC+64 ) DO I = 2, 6 IC = ICHAR( SUBNAM( I: I ) ) IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: $ I ) = CHAR( IC+64 ) END DO END IF * ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN * * Prime machines: ASCII+128 * IF( IC.GE.225 .AND. IC.LE.250 ) THEN SUBNAM( 1: 1 ) = CHAR( IC-32 ) DO I = 2, 6 IC = ICHAR( SUBNAM( I: I ) ) IF( IC.GE.225 .AND. IC.LE.250 ) $ SUBNAM( I: I ) = CHAR( IC-32 ) END DO END IF END IF * IF( SUBNAM( 2:6 ).EQ.'GGHRD' .OR. $ SUBNAM( 2:6 ).EQ.'GGHD3' ) THEN IPARMQ = 1 IF( NH.GE.K22MIN ) $ IPARMQ = 2 ELSE IF ( SUBNAM( 4:6 ).EQ.'EXC' ) THEN IF( NH.GE.KACMIN ) $ IPARMQ = 1 IF( NH.GE.K22MIN ) $ IPARMQ = 2 ELSE IF ( SUBNAM( 2:6 ).EQ.'HSEQR' .OR. $ SUBNAM( 2:5 ).EQ.'LAQR' ) THEN IF( NS.GE.KACMIN ) $ IPARMQ = 1 IF( NS.GE.K22MIN ) $ IPARMQ = 2 END IF * ELSE * ===== invalid value of ispec ===== IPARMQ = -1 * END IF * * ==== End of IPARMQ ==== * END