/R-2.15.1/src/modules/lapack/dlapack1.f
FORTRAN Legacy | 13729 lines | 5545 code | 1 blank | 8183 comment | 0 complexity | 2debfe568d485e45100b760897a8738e MD5 | raw file
Possible License(s): LGPL-2.1, LGPL-3.0, CC-BY-SA-4.0, BSD-3-Clause, AGPL-3.0, GPL-2.0, GPL-3.0, LGPL-2.0
- SUBROUTINE DGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )
- *
- * -- LAPACK driver routine (version 3.1) --
- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
- * November 2006
- *
- * .. Scalar Arguments ..
- INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS
- * ..
- * .. Array Arguments ..
- INTEGER IPIV( * )
- DOUBLE PRECISION AB( LDAB, * ), B( LDB, * )
- * ..
- *
- * Purpose
- * =======
- *
- * 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.
- *
- * Arguments
- * =========
- *
- * N (input) INTEGER
- * The number of linear equations, i.e., the order of the
- * matrix A. N >= 0.
- *
- * KL (input) INTEGER
- * The number of subdiagonals within the band of A. KL >= 0.
- *
- * KU (input) INTEGER
- * The number of superdiagonals within the band of A. KU >= 0.
- *
- * NRHS (input) INTEGER
- * The number of right hand sides, i.e., the number of columns
- * of the matrix B. NRHS >= 0.
- *
- * AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
- * On entry, the matrix A in band storage, in rows KL+1 to
- * 2*KL+KU+1; rows 1 to KL of the array need not be set.
- * The j-th column of A is stored in the j-th column of the
- * array AB as follows:
- * AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(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.
- *
- * LDAB (input) INTEGER
- * The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
- *
- * IPIV (output) INTEGER array, dimension (N)
- * The pivot indices that define the permutation matrix P;
- * row i of the matrix was interchanged with row IPIV(i).
- *
- * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
- * On entry, the N-by-NRHS right hand side matrix B.
- * On exit, if INFO = 0, the N-by-NRHS solution matrix X.
- *
- * LDB (input) INTEGER
- * The leading dimension of the array B. LDB >= max(1,N).
- *
- * INFO (output) INTEGER
- * = 0: successful exit
- * < 0: if INFO = -i, the i-th argument had an illegal value
- * > 0: if INFO = i, U(i,i) is exactly zero. The factorization
- * has been completed, but the factor U is exactly
- * singular, and the solution has not been computed.
- *
- * Further Details
- * ===============
- *
- * The band storage scheme is illustrated by the following example, when
- * M = N = 6, KL = 2, KU = 1:
- *
- * On entry: On exit:
- *
- * * * * + + + * * * u14 u25 u36
- * * * + + + + * * u13 u24 u35 u46
- * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
- * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
- * a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
- * a31 a42 a53 a64 * * m31 m42 m53 m64 * *
- *
- * Array elements marked * are not used by the routine; elements marked
- * + need not be set on entry, but are required by the routine to store
- * elements of U because of fill-in resulting from the row interchanges.
- *
- * =====================================================================
- *
- * .. 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
- 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.1) --
- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
- * November 2006
- *
- * .. 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, * )
- * ..
- *
- * Purpose
- * =======
- *
- * 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.
- *
- * Description
- * ===========
- *
- * 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.
- *
- * Arguments
- * =========
- *
- * FACT (input) 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.
- *
- * TRANS (input) CHARACTER*1
- * Specifies the form of the system of equations.
- * = 'N': A * X = B (No transpose)
- * = 'T': A**T * X = B (Transpose)
- * = 'C': A**H * X = B (Transpose)
- *
- * N (input) INTEGER
- * The number of linear equations, i.e., the order of the
- * matrix A. N >= 0.
- *
- * KL (input) INTEGER
- * The number of subdiagonals within the band of A. KL >= 0.
- *
- * KU (input) INTEGER
- * The number of superdiagonals within the band of A. KU >= 0.
- *
- * NRHS (input) INTEGER
- * The number of right hand sides, i.e., the number of columns
- * of the matrices B and X. NRHS >= 0.
- *
- * AB (input/output) 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).
- *
- * LDAB (input) INTEGER
- * The leading dimension of the array AB. LDAB >= KL+KU+1.
- *
- * AFB (input or output) 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).
- *
- * LDAFB (input) INTEGER
- * The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.
- *
- * IPIV (input or output) INTEGER array, dimension (N)
- * If FACT = 'F', then IPIV is an input argument and on entry
- * contains the pivot indices from the 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.
- *
- * EQUED (input or output) 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.
- *
- * R (input or output) 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.
- *
- * C (input or output) 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.
- *
- * B (input/output) 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.
- *
- * LDB (input) INTEGER
- * The leading dimension of the array B. LDB >= max(1,N).
- *
- * X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
- * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X
- * 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'.
- *
- * LDX (input) INTEGER
- * The leading dimension of the array X. LDX >= max(1,N).
- *
- * RCOND (output) DOUBLE PRECISION
- * The estimate of the reciprocal condition number of the matrix
- * A 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.
- *
- * FERR (output) DOUBLE PRECISION array, dimension (NRHS)
- * The estimated forward error bound for each solution vector
- * X(j) (the j-th column of the solution matrix X).
- * If XTRUE is the true solution corresponding to X(j), FERR(j)
- * is an estimated upper bound for the magnitude of the largest
- * element in (X(j) - XTRUE) divided by the magnitude of the
- * largest element in X(j). The estimate is as reliable as
- * the estimate for RCOND, and is almost always a slight
- * overestimate of the true error.
- *
- * BERR (output) DOUBLE PRECISION array, dimension (NRHS)
- * The componentwise relative backward error of each solution
- * vector X(j) (i.e., the smallest relative change in
- * any element of A or B that makes X(j) an exact solution).
- *
- * WORK (workspace/output) 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<INFO<=N, then
- * WORK(1) contains the reciprocal pivot growth factor for the
- * leading INFO columns of A.
- *
- * IWORK (workspace) INTEGER array, dimension (N)
- *
- * INFO (output) INTEGER
- * = 0: successful exit
- * < 0: if INFO = -i, the i-th argument had an illegal value
- * > 0: if INFO = i, and i is
- * <= N: U(i,i) is exactly zero. The factorization
- * has 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.
- *
- * =====================================================================
- *
- * .. 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
- SUBROUTINE DGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI,
- $ VS, LDVS, WORK, LWORK, BWORK, INFO )
- *
- * -- LAPACK driver routine (version 3.1) --
- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
- * November 2006
- *
- * .. 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
- * ..
- *
- * Purpose
- * =======
- *
- * 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).
- *
- * Arguments
- * =========
- *
- * JOBVS (input) CHARACTER*1
- * = 'N': Schur vectors are not computed;
- * = 'V': Schur vectors are computed.
- *
- * SORT (input) 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).
- *
- * SELECT (external procedure) 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).
- *
- * N (input) INTEGER
- * The order of the matrix A. N >= 0.
- *
- * A (input/output) 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.
- *
- * LDA (input) INTEGER
- * The leading dimension of the array A. LDA >= max(1,N).
- *
- * SDIM (output) 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.)
- *
- * WR (output) DOUBLE PRECISION array, dimension (N)
- * WI (output) 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.
- *
- * VS (output) 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.
- *
- * LDVS (input) INTEGER
- * The leading dimension of the array VS. LDVS >= 1; if
- * JOBVS = 'V', LDVS >= N.
- *
- * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
- * On exit, if INFO = 0, WORK(1) contains the optimal LWORK.
- *
- * LWORK (input) 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.
- *
- * BWORK (workspace) LOGICAL array, dimension (N)
- * Not referenced if SORT = 'N'.
- *
- * INFO (output) INTEGER
- * = 0: successful exit
- * < 0: if INFO = -i, the i-th argument had an illegal value.
- * > 0: if INFO = i, and i is
- * <= N: 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.
- *
- * =====================================================================
- *
- * .. 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
- 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.1) --
- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
- * November 2006
- *
- * .. 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
- * ..
- *
- * Purpose
- * =======
- *
- * 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).
- *
- * Arguments
- * =========
- *
- * JOBVS (input) CHARACTER*1
- * = 'N': Schur vectors are not computed;
- * = 'V': Schur vectors are computed.
- *
- * SORT (input) 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).
- *
- * SELECT (external procedure) 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).
- *
- * SENSE (input) 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'.
- *
- * N (input) INTEGER
- * The order of the matrix A. N >= 0.
- *
- * A (input/output) 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.
- *
- * LDA (input) INTEGER
- * The leading dimension of the array A. LDA >= max(1,N).
- *
- * SDIM (output) 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.)
- *
- * WR (output) DOUBLE PRECISION array, dimension (N)
- * WI (output) 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.
- *
- * VS (output) 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.
- *
- * LDVS (input) INTEGER
- * The leading dimension of the array VS. LDVS >= 1, and if
- * JOBVS = 'V', LDVS >= N.
- *
- * RCONDE (output) 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'.
- *
- * RCONDV (output) 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'.
- *
- * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
- * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
- *
- * LWORK (input) INTEGER
- * The dimension of the array WORK. LWORK >= max(1,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.
- *
- * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
- * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
- *
- * LIWORK (input) INTEGER
- * The dimension of the array IWORK.
- * 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.
- *
- * BWORK (workspace) LOGICAL array, dimension (N)
- * Not referenced if SORT = 'N'.
- *
- * INFO (output) INTEGER
- * = 0: successful exit
- * < 0: if INFO = -i, the i-th argument had an illegal value.
- * > 0: if INFO = i, and i is
- * <= N: 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.
- *
- * =====================================================================
- *
- * .. 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
- 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
- SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR,
- $ LDVR, WORK, LWORK, INFO )
- *
- * -- LAPACK driver routine (version 3.1) --
- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
- * November 2006
- *
- * .. 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( * )
- * ..
- *
- * Purpose
- * =======
- *
- * 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.
- *
- * Arguments
- * =========
- *
- * JOBVL (input) CHARACTER*1
- * = 'N': left eigenvectors of A are not computed;
- * = 'V': left eigenvectors of A are computed.
- *
- * JOBVR (input) CHARACTER*1
- * = 'N': right eigenvectors of A are not computed;
- * = 'V': right eigenvectors of A are computed.
- *
- * N (input) INTEGER
- * The order of the matrix A. N >= 0.
- *
- * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
- * On entry, the N-by-N matrix A.
- * On exit, A has been overwritten.
- *
- * LDA (input) INTEGER
- * The leading dimension of the array A. LDA >= max(1,N).
- *
- * WR (output) DOUBLE PRECISION array, dimension (N)
- * WI (output) 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.
- *
- * VL (output) 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).
- *
- * LDVL (input) INTEGER
- * The leading dimension of the array VL. LDVL >= 1; if
- * JOBVL = 'V', LDVL >= N.
- *
- * VR (output) 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).
- *
- * LDVR (input) INTEGER
- * The leading dimension of the array VR. LDVR >= 1; if
- * JOBVR = 'V', LDVR >= N.
- *
- * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
- * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
- *
- * LWORK (input) INTEGER
- * The dimension of the array WORK. LWORK >= max(1,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.
- *
- * INFO (output) 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.
- *
- * =====================================================================
- *
- * .. 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,
- $ 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, DTREVC,
- $ 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 = WORK( 1 )
- MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK )
- 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 = WORK( 1 )
- MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK )
- 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 = 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 > 0 from DHSEQR, then quit
- *
- IF( INFO.GT.0 )
- $ GO TO 50
- *
- IF( WANTVL .OR. WANTVR ) THEN
- *
- * Compute left and/or right eigenvectors
- * (Workspace: need 4*N)
- *
- CALL DTREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR,
- $ N, NOUT, WORK( IWRK ), 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
- 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 )
- *
- * -- LAPACK driver routine (version 3.1) --
- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
- * November 2006
- *
- * .. 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( * )
- * ..
- *
- * Purpose
- * =======
- *
- * 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.
- *
- * Arguments
- * =========
- *
- * BALANC (input) 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.
- *
- * JOBVL (input) 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'.
- *
- * JOBVR (input) 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'.
- *
- * SENSE (input) 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').
- *
- * N (input) INTEGER
- * The order of the matrix A. N >= 0.
- *
- * A (input/output) 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.
- *
- * LDA (input) INTEGER
- * The leading dimension of the array A. LDA >= max(1,N).
- *
- * WR (output) DOUBLE PRECISION array, dimension (N)
- * WI (output) 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.
- *
- * VL (output) 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).
- *
- * LDVL (input) INTEGER
- * The leading dimension of the array VL. LDVL >= 1; if
- * JOBVL = 'V', LDVL >= N.
- *
- * VR (output) 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).
- *
- * LDVR (input) INTEGER
- * The leading dimension of the array VR. LDVR >= 1, and if
- * JOBVR = 'V', LDVR >= N.
- *
- * ILO (output) INTEGER
- * IHI (output) 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.
- *
- * SCALE (output) 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.
- *
- * ABNRM (output) DOUBLE PRECISION
- * The one-norm of the balanced matrix (the maximum
- * of the sum of absolute values of elements of any column).
- *
- * RCONDE (output) DOUBLE PRECISION array, dimension (N)
- * RCONDE(j) is the reciprocal condition number of the j-th
- * eigenvalue.
- *
- * RCONDV (output) DOUBLE PRECISION array, dimension (N)
- * RCONDV(j) is the reciprocal condition number of the j-th
- * right eigenvector.
- *
- * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
- * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
- *
- * LWORK (input) INTEGER
- * The dimension of the array WORK. If 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.
- *
- * IWORK (workspace) INTEGER array, dimension (2*N-2)
- * If SENSE = 'N' or 'E', not referenced.
- *
- * INFO (output) 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.
- *
- * =====================================================================
- *
- * .. 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, 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, DTREVC,
- $ 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 DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VL, LDVL,
- $ WORK, -1, INFO )
- ELSE IF( WANTVR ) THEN
- 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 = 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 > 0 from DHSEQR, then quit
- *
- IF( INFO.GT.0 )
- $ GO TO 50
- *
- IF( WANTVL .OR. WANTVR ) THEN
- *
- * Compute left and/or right eigenvectors
- * (Workspace: need 3*N)
- *
- CALL DTREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR,
- $ N, NOUT, WORK( IWRK ), 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
- SUBROUTINE DGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR,
- $ ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK,
- $ LWORK, INFO )
- *
- * -- LAPACK driver routine (version 3.1) --
- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
- * November 2006
- *
- * .. 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( * )
- * ..
- *
- * Purpose
- * =======
- *
- * 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).
- *
- * Arguments
- * =========
- *
- * JOBVSL (input) CHARACTER*1
- * = 'N': do not compute the left Schur vectors;
- * = 'V': compute the left Schur vectors (returned in VSL).
- *
- * JOBVSR (input) CHARACTER*1
- * = 'N': do not compute the right Schur vectors;
- * = 'V': compute the right Schur vectors (returned in VSR).
- *
- * N (input) INTEGER
- * The order of the matrices A, B, VSL, and VSR. N >= 0.
- *
- * A (input/output) 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.
- *
- * LDA (input) INTEGER
- * The leading dimension of A. LDA >= max(1,N).
- *
- * B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
- * On entry, the matrix B.
- * On exit, the upper triangular matrix T from the generalized
- * real Schur factorization.
- *
- * LDB (input) INTEGER
- * The leading dimension of B. LDB >= max(1,N).
- *
- * ALPHAR (output) DOUBLE PRECISION array, dimension (N)
- * The real parts of each scalar alpha defining an eigenvalue
- * of GNEP.
- *
- * ALPHAI (output) DOUBLE PRECISION array, dimension (N)
- * The imaginary parts of each scalar alpha defining an
- * eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th
- * eigenvalue is real; if positive, then the j-th and (j+1)-st
- * eigenvalues are a complex conjugate pair, with
- * ALPHAI(j+1) = -ALPHAI(j).
- *
- * BETA (output) DOUBLE PRECISION array, dimension (N)
- * The scalars beta that define the eigenvalues of GNEP.
- * Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
- * beta = BETA(j) represent the j-th eigenvalue of the matrix
- * pair (A,B), in one of the forms lambda = alpha/beta or
- * mu = beta/alpha. Since either lambda or mu may overflow,
- * they should not, in general, be computed.
- *
- * VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N)
- * If JOBVSL = 'V', the matrix of left Schur vectors Q.
- * Not referenced if JOBVSL = 'N'.
- *
- * LDVSL (input) INTEGER
- * The leading dimension of the matrix VSL. LDVSL >=1, and
- * if JOBVSL = 'V', LDVSL >= N.
- *
- * VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N)
- * If JOBVSR = 'V', the matrix of right Schur vectors Z.
- * Not referenced if JOBVSR = 'N'.
- *
- * LDVSR (input) INTEGER
- * The leading dimension of the matrix VSR. LDVSR >= 1, and
- * if JOBVSR = 'V', LDVSR >= N.
- *
- * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
- * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
- *
- * LWORK (input) INTEGER
- * The dimension of the array WORK. LWORK >= max(1,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.
- *
- * INFO (output) 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)
- *
- * =====================================================================
- *
- * .. 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
- SUBROUTINE DGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI,
- $ BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )
- *
- * -- LAPACK driver routine (version 3.1) --
- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
- * November 2006
- *
- * .. 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( * )
- * ..
- *
- * Purpose
- * =======
- *
- * 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 -- see
- * "Further Details", below.
- *
- * Arguments
- * =========
- *
- * JOBVL (input) CHARACTER*1
- * = 'N': do not compute the left generalized eigenvectors;
- * = 'V': compute the left generalized eigenvectors (returned
- * in VL).
- *
- * JOBVR (input) CHARACTER*1
- * = 'N': do not compute the right generalized eigenvectors;
- * = 'V': compute the right generalized eigenvectors (returned
- * in VR).
- *
- * N (input) INTEGER
- * The order of the matrices A, B, VL, and VR. N >= 0.
- *
- * A (input/output) 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.
- *
- * LDA (input) INTEGER
- * The leading dimension of A. LDA >= max(1,N).
- *
- * B (input/output) 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.
- *
- * LDB (input) INTEGER
- * The leading dimension of B. LDB >= max(1,N).
- *
- * ALPHAR (output) DOUBLE PRECISION array, dimension (N)
- * The real parts of each scalar alpha defining an eigenvalue of
- * GNEP.
- *
- * ALPHAI (output) DOUBLE PRECISION array, dimension (N)
- * The imaginary parts of each scalar alpha defining an
- * eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th
- * eigenvalue is real; if positive, then the j-th and
- * (j+1)-st eigenvalues are a complex conjugate pair, with
- * ALPHAI(j+1) = -ALPHAI(j).
- *
- * BETA (output) DOUBLE PRECISION array, dimension (N)
- * The scalars beta that define the eigenvalues of GNEP.
- *
- * Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
- * beta = BETA(j) represent the j-th eigenvalue of the matrix
- * pair (A,B), in one of the forms lambda = alpha/beta or
- * mu = beta/alpha. Since either lambda or mu may overflow,
- * they should not, in general, be computed.
- *
- * VL (output) 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'.
- *
- * LDVL (input) INTEGER
- * The leading dimension of the matrix VL. LDVL >= 1, and
- * if JOBVL = 'V', LDVL >= N.
- *
- * VR (output) 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'.
- *
- * LDVR (input) INTEGER
- * The leading dimension of the matrix VR. LDVR >= 1, and
- * if JOBVR = 'V', LDVR >= N.
- *
- * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
- * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
- *
- * LWORK (input) INTEGER
- * The dimension of the array WORK. LWORK >= max(1,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.
- *
- * INFO (output) 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)
- *
- * Further Details
- * ===============
- *
- * 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.
- *
- * =====================================================================
- *
- * .. 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
- SUBROUTINE DGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK,
- $ INFO )
- *
- * -- LAPACK driver routine (version 3.1) --
- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
- * November 2006
- *
- * .. Scalar Arguments ..
- CHARACTER TRANS
- INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
- * ..
- * .. Array Arguments ..
- DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * )
- * ..
- *
- * Purpose
- * =======
- *
- * 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 undetermined 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.
- *
- * Arguments
- * =========
- *
- * TRANS (input) CHARACTER*1
- * = 'N': the linear system involves A;
- * = 'T': the linear system involves A**T.
- *
- * M (input) INTEGER
- * The number of rows of the matrix A. M >= 0.
- *
- * N (input) INTEGER
- * The number of columns of the matrix A. N >= 0.
- *
- * NRHS (input) INTEGER
- * The number of right hand sides, i.e., the number of
- * columns of the matrices B and X. NRHS >=0.
- *
- * A (input/output) 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.
- *
- * LDA (input) INTEGER
- * The leading dimension of the array A. LDA >= max(1,M).
- *
- * B (input/output) 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.
- *
- * LDB (input) INTEGER
- * The leading dimension of the array B. LDB >= MAX(1,M,N).
- *
- * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
- * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
- *
- * LWORK (input) INTEGER
- * The dimension of the array WORK.
- * LWORK >= max( 1, 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.
- *
- * INFO (output) 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.
- *
- * =====================================================================
- *
- * .. 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' * 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
- *
- * Overdetermined system of equations A' * X = B
- *
- * B(1:N,1:NRHS) := inv(R') * 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,:)' * 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' * 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') * 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
- SUBROUTINE DGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK,
- $ WORK, LWORK, IWORK, INFO )
- *
- * -- LAPACK driver routine (version 3.1) --
- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
- * November 2006
- *
- * .. Scalar Arguments ..
- INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
- DOUBLE PRECISION RCOND
- * ..
- * .. Array Arguments ..
- INTEGER IWORK( * )
- DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( * )
- * ..
- *
- * Purpose
- * =======
- *
- * 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 tranformations 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.
- *
- * Arguments
- * =========
- *
- * M (input) INTEGER
- * The number of rows of A. M >= 0.
- *
- * N (input) INTEGER
- * The number of columns of A. N >= 0.
- *
- * NRHS (input) INTEGER
- * The number of right hand sides, i.e., the number of columns
- * of the matrices B and X. NRHS >= 0.
- *
- * A (input) DOUBLE PRECISION array, dimension (LDA,N)
- * On entry, the M-by-N matrix A.
- * On exit, A has been destroyed.
- *
- * LDA (input) INTEGER
- * The leading dimension of the array A. LDA >= max(1,M).
- *
- * B (input/output) 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.
- *
- * LDB (input) INTEGER
- * The leading dimension of the array B. LDB >= max(1,max(M,N)).
- *
- * S (output) 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)).
- *
- * RCOND (input) 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.
- *
- * RANK (output) INTEGER
- * The effective rank of A, i.e., the number of singular values
- * which are greater than RCOND*S(1).
- *
- * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
- * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
- *
- * LWORK (input) INTEGER
- * The dimension of the array WORK. LWORK 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.
- *
- * IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))
- * LIWORK >= 3 * MINMN * NLVL + 11 * MINMN,
- * where MINMN = MIN( M,N ).
- *
- * INFO (output) 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.
- *
- * Further Details
- * ===============
- *
- * Based on contributions by
- * Ming Gu and Ren-Cang Li, Computer Science Division, University of
- * California at Berkeley, USA
- * Osni Marques, LBNL/NERSC, USA
- *
- * =====================================================================
- *
- * .. Parameters ..
- DOUBLE PRECISION ZERO, ONE, TWO
- PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
- * ..
- * .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER IASCL, IBSCL, IE, IL, ITAU, ITAUP, ITAUQ,
- $ LDWORK, 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
- MINMN = MAX( 1, MINMN )
- NLVL = MAX( INT( LOG( DBLE( MINMN ) / DBLE( SMLSIZ+1 ) ) /
- $ LOG( TWO ) ) + 1, 0 )
- *
- IF( INFO.EQ.0 ) THEN
- MAXWRK = 0
- 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 )
- 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
- 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
- RETURN
- *
- * End of DGELSD
- *
- END
- SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK,
- $ WORK, LWORK, INFO )
- *
- * -- LAPACK driver routine (version 3.1) --
- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
- * November 2006
- *
- * .. Scalar Arguments ..
- INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
- DOUBLE PRECISION RCOND
- * ..
- * .. Array Arguments ..
- DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( * )
- * ..
- *
- * Purpose
- * =======
- *
- * 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.
- *
- * Arguments
- * =========
- *
- * M (input) INTEGER
- * The number of rows of the matrix A. M >= 0.
- *
- * N (input) INTEGER
- * The number of columns of the matrix A. N >= 0.
- *
- * NRHS (input) INTEGER
- * The number of right hand sides, i.e., the number of columns
- * of the matrices B and X. NRHS >= 0.
- *
- * A (input/output) 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.
- *
- * LDA (input) INTEGER
- * The leading dimension of the array A. LDA >= max(1,M).
- *
- * B (input/output) 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.
- *
- * LDB (input) INTEGER
- * The leading dimension of the array B. LDB >= max(1,max(M,N)).
- *
- * S (output) 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)).
- *
- * RCOND (input) 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.
- *
- * RANK (output) INTEGER
- * The effective rank of A, i.e., the number of singular values
- * which are greater than RCOND*S(1).
- *
- * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
- * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
- *
- * LWORK (input) INTEGER
- * The dimension of the array WORK. LWORK >= 1, 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.
- *
- * INFO (output) 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.
- *
- * =====================================================================
- *
- * .. 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
- DOUBLE PRECISION ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM, THR
- * ..
- * .. Local Arrays ..
- DOUBLE PRECISION VDUM( 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
- *
- 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
- *
- * Compute workspace needed for DBDSQR
- *
- BDSPAC = MAX( 1, 5*N )
- 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,
- $ 'DORGBR', 'P', N, N, N, -1 ) )
- 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
- *
- 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, 'DORGBR', 'P', M,
- $ M, M, -1 ) )
- 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 + NRHS*ILAENV( 1, 'DORMLQ',
- $ 'LT', N, NRHS, M, -1 ) )
- ELSE
- *
- * Path 2 - underdetermined
- *
- MAXWRK = 3*M + ( N + M )*ILAENV( 1, 'DGEBRD', ' ', M,
- $ N, -1, -1 )
- MAXWRK = MAX( MAXWRK, 3*M + NRHS*ILAENV( 1, 'DORMBR',
- $ 'QLT', M, NRHS, M, -1 ) )
- MAXWRK = MAX( MAXWRK, 3*M + M*ILAENV( 1, 'DORGBR',
- $ 'P', M, N, M, -1 ) )
- 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, 1 )
- 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, VDUM,
- $ 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, VDUM,
- $ 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
- SUBROUTINE DGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK,
- $ WORK, INFO )
- *
- * -- LAPACK driver routine (version 3.1) --
- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
- * November 2006
- *
- * .. Scalar Arguments ..
- INTEGER INFO, LDA, LDB, M, N, NRHS, RANK
- DOUBLE PRECISION RCOND
- * ..
- * .. Array Arguments ..
- INTEGER JPVT( * )
- DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * )
- * ..
- *
- * Purpose
- * =======
- *
- * 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' [ inv(T11)*Q1'*B ]
- * [ 0 ]
- * where Q1 consists of the first RANK columns of Q.
- *
- * Arguments
- * =========
- *
- * M (input) INTEGER
- * The number of rows of the matrix A. M >= 0.
- *
- * N (input) INTEGER
- * The number of columns of the matrix A. N >= 0.
- *
- * NRHS (input) INTEGER
- * The number of right hand sides, i.e., the number of
- * columns of matrices B and X. NRHS >= 0.
- *
- * A (input/output) 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.
- *
- * LDA (input) INTEGER
- * The leading dimension of the array A. LDA >= max(1,M).
- *
- * B (input/output) 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.
- *
- * LDB (input) INTEGER
- * The leading dimension of the array B. LDB >= max(1,M,N).
- *
- * JPVT (input/output) 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.
- *
- * RCOND (input) 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.
- *
- * RANK (output) 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.
- *
- * WORK (workspace) DOUBLE PRECISION array, dimension
- * (max( min(M,N)+3*N, 2*min(M,N)+NRHS )),
- *
- * INFO (output) INTEGER
- * = 0: successful exit
- * < 0: if INFO = -i, the i-th argument had an illegal value
- *
- * =====================================================================
- *
- * .. 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' * 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' * 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
- SUBROUTINE DGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK,
- $ WORK, LWORK, INFO )
- *
- * -- LAPACK driver routine (version 3.1) --
- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
- * November 2006
- *
- * .. Scalar Arguments ..
- INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
- DOUBLE PRECISION RCOND
- * ..
- * .. Array Arguments ..
- INTEGER JPVT( * )
- DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * )
- * ..
- *
- * Purpose
- * =======
- *
- * 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' [ inv(T11)*Q1'*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.
- *
- * Arguments
- * =========
- *
- * M (input) INTEGER
- * The number of rows of the matrix A. M >= 0.
- *
- * N (input) INTEGER
- * The number of columns of the matrix A. N >= 0.
- *
- * NRHS (input) INTEGER
- * The number of right hand sides, i.e., the number of
- * columns of matrices B and X. NRHS >= 0.
- *
- * A (input/output) 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.
- *
- * LDA (input) INTEGER
- * The leading dimension of the array A. LDA >= max(1,M).
- *
- * B (input/output) 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.
- *
- * LDB (input) INTEGER
- * The leading dimension of the array B. LDB >= max(1,M,N).
- *
- * JPVT (input/output) INTEGER array, dimension (N)
- * On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
- * to the front of 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.
- *
- * RCOND (input) 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.
- *
- * RANK (output) 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.
- *
- * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
- * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
- *
- * LWORK (input) INTEGER
- * The dimension of the array WORK.
- * 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.
- *
- * INFO (output) INTEGER
- * = 0: successful exit
- * < 0: If INFO = -i, the i-th argument had an illegal value.
- *
- * Further Details
- * ===============
- *
- * Based on contributions by
- * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
- * E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
- * G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
- *
- * =====================================================================
- *
- * .. 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' * 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' * 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
- SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK,
- $ LWORK, IWORK, INFO )
- *
- * -- LAPACK driver routine (version 3.1) --
- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
- * November 2006
- *
- * .. 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( * )
- * ..
- *
- * Purpose
- * =======
- *
- * 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.
- *
- * Arguments
- * =========
- *
- * JOBZ (input) 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.
- *
- * M (input) INTEGER
- * The number of rows of the input matrix A. M >= 0.
- *
- * N (input) INTEGER
- * The number of columns of the input matrix A. N >= 0.
- *
- * A (input/output) 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.
- *
- * LDA (input) INTEGER
- * The leading dimension of the array A. LDA >= max(1,M).
- *
- * S (output) DOUBLE PRECISION array, dimension (min(M,N))
- * The singular values of A, sorted so that S(i) >= S(i+1).
- *
- * U (output) 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.
- *
- * LDU (input) INTEGER
- * The leading dimension of the array U. LDU >= 1; if
- * JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.
- *
- * VT (output) 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.
- *
- * LDVT (input) 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).
- *
- * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
- * On exit, if INFO = 0, WORK(1) returns the optimal LWORK;
- *
- * LWORK (input) INTEGER
- * The dimension of the array WORK. LWORK >= 1.
- * If JOBZ = 'N',
- * LWORK >= 3*min(M,N) + max(max(M,N),7*min(M,N)).
- * If JOBZ = 'O',
- * LWORK >= 3*min(M,N)*min(M,N) +
- * max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)).
- * If JOBZ = 'S' or 'A'
- * LWORK >= 3*min(M,N)*min(M,N) +
- * max(max(M,N),4*min(M,N)*min(M,N)+4*min(M,N)).
- * For good performance, LWORK should generally be larger.
- * If LWORK = -1 but other input arguments are legal, WORK(1)
- * returns the optimal LWORK.
- *
- * IWORK (workspace) INTEGER array, dimension (8*min(M,N))
- *
- * INFO (output) INTEGER
- * = 0: successful exit.
- * < 0: if INFO = -i, the i-th argument had an illegal value.
- * > 0: DBDSDC did not converge, updating process failed.
- *
- * Further Details
- * ===============
- *
- * Based on contributions by
- * Ming Gu and Huan Ren, Computer Science Division, University of
- * California at Berkeley, USA
- *
- * =====================================================================
- *
- * .. 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
- 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
- INTEGER ILAENV
- DOUBLE PRECISION DLAMCH, DLANGE
- EXTERNAL DLAMCH, DLANGE, ILAENV, 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 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 DBDSDC
- *
- MNTHR = INT( MINMN*11.0D0 / 6.0D0 )
- IF( WNTQN ) THEN
- BDSPAC = 7*N
- ELSE
- BDSPAC = 3*N*N + 4*N
- END IF
- IF( M.GE.MNTHR ) THEN
- IF( WNTQN ) THEN
- *
- * Path 1 (M much larger than N, JOBZ='N')
- *
- WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1,
- $ -1 )
- WRKBL = MAX( WRKBL, 3*N+2*N*
- $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
- MAXWRK = MAX( WRKBL, BDSPAC+N )
- MINWRK = BDSPAC + N
- ELSE IF( WNTQO ) THEN
- *
- * Path 2 (M much larger than N, JOBZ='O')
- *
- WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
- WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
- $ N, N, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+2*N*
- $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+N*
- $ ILAENV( 1, 'DORMBR', 'QLN', N, N, N, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+N*
- $ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
- WRKBL = MAX( WRKBL, BDSPAC+3*N )
- MAXWRK = WRKBL + 2*N*N
- MINWRK = BDSPAC + 2*N*N + 3*N
- ELSE IF( WNTQS ) THEN
- *
- * Path 3 (M much larger than N, JOBZ='S')
- *
- WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
- WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
- $ N, N, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+2*N*
- $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+N*
- $ ILAENV( 1, 'DORMBR', 'QLN', N, N, N, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+N*
- $ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
- WRKBL = MAX( WRKBL, BDSPAC+3*N )
- MAXWRK = WRKBL + N*N
- MINWRK = BDSPAC + N*N + 3*N
- ELSE IF( WNTQA ) THEN
- *
- * Path 4 (M much larger than N, JOBZ='A')
- *
- WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
- WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'DORGQR', ' ', M,
- $ M, N, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+2*N*
- $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+N*
- $ ILAENV( 1, 'DORMBR', 'QLN', N, N, N, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+N*
- $ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
- WRKBL = MAX( WRKBL, BDSPAC+3*N )
- MAXWRK = WRKBL + N*N
- MINWRK = BDSPAC + N*N + 3*N
- END IF
- ELSE
- *
- * Path 5 (M at least N, but not much larger)
- *
- WRKBL = 3*N + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N, -1,
- $ -1 )
- IF( WNTQN ) THEN
- MAXWRK = MAX( WRKBL, BDSPAC+3*N )
- MINWRK = 3*N + MAX( M, BDSPAC )
- ELSE IF( WNTQO ) THEN
- WRKBL = MAX( WRKBL, 3*N+N*
- $ ILAENV( 1, 'DORMBR', 'QLN', M, N, N, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+N*
- $ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
- WRKBL = MAX( WRKBL, BDSPAC+3*N )
- MAXWRK = WRKBL + M*N
- MINWRK = 3*N + MAX( M, N*N+BDSPAC )
- ELSE IF( WNTQS ) THEN
- WRKBL = MAX( WRKBL, 3*N+N*
- $ ILAENV( 1, 'DORMBR', 'QLN', M, N, N, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+N*
- $ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
- MAXWRK = MAX( WRKBL, BDSPAC+3*N )
- MINWRK = 3*N + MAX( M, BDSPAC )
- ELSE IF( WNTQA ) THEN
- WRKBL = MAX( WRKBL, 3*N+M*
- $ ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+N*
- $ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
- MAXWRK = MAX( MAXWRK, BDSPAC+3*N )
- MINWRK = 3*N + MAX( M, BDSPAC )
- END IF
- END IF
- ELSE IF( MINMN.GT.0 ) THEN
- *
- * Compute space needed for DBDSDC
- *
- MNTHR = INT( MINMN*11.0D0 / 6.0D0 )
- IF( WNTQN ) THEN
- BDSPAC = 7*M
- ELSE
- BDSPAC = 3*M*M + 4*M
- END IF
- IF( N.GE.MNTHR ) THEN
- IF( WNTQN ) THEN
- *
- * Path 1t (N much larger than M, JOBZ='N')
- *
- WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1,
- $ -1 )
- WRKBL = MAX( WRKBL, 3*M+2*M*
- $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
- MAXWRK = MAX( WRKBL, BDSPAC+M )
- MINWRK = BDSPAC + M
- ELSE IF( WNTQO ) THEN
- *
- * Path 2t (N much larger than M, JOBZ='O')
- *
- WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
- WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
- $ N, M, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+2*M*
- $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+M*
- $ ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+M*
- $ ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 ) )
- WRKBL = MAX( WRKBL, BDSPAC+3*M )
- MAXWRK = WRKBL + 2*M*M
- MINWRK = BDSPAC + 2*M*M + 3*M
- ELSE IF( WNTQS ) THEN
- *
- * Path 3t (N much larger than M, JOBZ='S')
- *
- WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
- WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
- $ N, M, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+2*M*
- $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+M*
- $ ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+M*
- $ ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 ) )
- WRKBL = MAX( WRKBL, BDSPAC+3*M )
- MAXWRK = WRKBL + M*M
- MINWRK = BDSPAC + M*M + 3*M
- ELSE IF( WNTQA ) THEN
- *
- * Path 4t (N much larger than M, JOBZ='A')
- *
- WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
- WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'DORGLQ', ' ', N,
- $ N, M, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+2*M*
- $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+M*
- $ ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+M*
- $ ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 ) )
- WRKBL = MAX( WRKBL, BDSPAC+3*M )
- MAXWRK = WRKBL + M*M
- MINWRK = BDSPAC + M*M + 3*M
- END IF
- ELSE
- *
- * Path 5t (N greater than M, but not much larger)
- *
- WRKBL = 3*M + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N, -1,
- $ -1 )
- IF( WNTQN ) THEN
- MAXWRK = MAX( WRKBL, BDSPAC+3*M )
- MINWRK = 3*M + MAX( N, BDSPAC )
- ELSE IF( WNTQO ) THEN
- WRKBL = MAX( WRKBL, 3*M+M*
- $ ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+M*
- $ ILAENV( 1, 'DORMBR', 'PRT', M, N, M, -1 ) )
- WRKBL = MAX( WRKBL, BDSPAC+3*M )
- MAXWRK = WRKBL + M*N
- MINWRK = 3*M + MAX( N, M*M+BDSPAC )
- ELSE IF( WNTQS ) THEN
- WRKBL = MAX( WRKBL, 3*M+M*
- $ ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+M*
- $ ILAENV( 1, 'DORMBR', 'PRT', M, N, M, -1 ) )
- MAXWRK = MAX( WRKBL, BDSPAC+3*M )
- MINWRK = 3*M + MAX( N, BDSPAC )
- ELSE IF( WNTQA ) THEN
- WRKBL = MAX( WRKBL, 3*M+M*
- $ ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+M*
- $ ILAENV( 1, 'DORMBR', 'PRT', N, N, M, -1 ) )
- MAXWRK = MAX( WRKBL, BDSPAC+3*M )
- 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 much larger than N, JOBZ='N')
- * No singular vectors to be computed
- *
- 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, 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 4*N, prefer 3*N+2*N*NB)
- *
- 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+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 much larger than 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+2*N, prefer N*N+N+N*NB)
- *
- 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+2*N, prefer N*N+N+N*NB)
- *
- 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 VT, copying result to 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( 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*N+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 2*N*N+3*N, prefer 2*N*N+2*N+N*NB)
- *
- 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 2*N*N, prefer N*N+M*N)
- *
- 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 much larger than 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+2*N, prefer N*N+N+N*NB)
- *
- 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+2*N, prefer N*N+N+N*NB)
- *
- 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+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( 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+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+3*N, prefer N*N+2*N+N*NB)
- *
- 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)
- *
- 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 much larger than 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+2*N, prefer N*N+N+N*NB)
- *
- 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+2*N, prefer N*N+N+N*NB)
- 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+4*N, prefer N*N+3*N+2*N*NB)
- *
- 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*N+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+3*N, prefer N*N+2*N+N*NB)
- *
- 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)
- *
- 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 at least 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+M, prefer 3*N+(M+N)*NB)
- *
- CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
- $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
- $ IERR )
- IF( WNTQN ) THEN
- *
- * Perform bidiagonal SVD, only computing singular values
- * (Workspace: need N+BDSPAC)
- *
- CALL DBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1,
- $ DUM, IDUM, WORK( NWORK ), IWORK, INFO )
- ELSE IF( WNTQO ) THEN
- 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 )
- 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 N+N*N+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 N*N+2*N, prefer N*N+N+N*NB)
- *
- 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
- *
- * Overwrite WORK(IU) by left singular vectors of A
- * (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
- *
- 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
- *
- * Generate Q in A
- * (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
- *
- 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 2*N*N, prefer N*N+M*N)
- *
- 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
- *
- * Perform bidiagonal SVD, computing left singular vectors
- * of bidiagonal matrix in U and computing right singular
- * vectors of bidiagonal matrix in VT
- * (Workspace: need N+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, prefer 2*N+N*NB)
- *
- 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
- *
- * Perform bidiagonal SVD, computing left singular vectors
- * of bidiagonal matrix in U and computing right singular
- * vectors of bidiagonal matrix in VT
- * (Workspace: need N+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 N*N+2*N+M, prefer N*N+2*N+M*NB)
- *
- 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 much larger than M, JOBZ='N')
- * No singular vectors to be computed
- *
- ITAU = 1
- NWORK = ITAU + M
- *
- * 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, 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 4*M, prefer 3*M+2*M*NB)
- *
- 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+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 much larger than M, JOBZ='O')
- * M right singular vectors to be overwritten on A and
- * M left singular vectors to be computed in U
- *
- IVT = 1
- *
- * IVT is M by M
- *
- IL = IVT + M*M
- IF( LWORK.GE.M*N+M*M+3*M+BDSPAC ) THEN
- *
- * WORK(IL) is M by N
- *
- 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+2*M, prefer M*M+M+M*NB)
- *
- 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+2*M, prefer M*M+M+M*NB)
- *
- 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+4*M, prefer M*M+3*M+2*M*NB)
- *
- 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*M+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 2*M*M+3*M, prefer 2*M*M+2*M+M*NB)
- *
- 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 2*M*M, prefer M*M+M*N)
- *
- 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 much larger than 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+2*M, prefer M*M+M+M*NB)
- *
- 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+2*M, prefer M*M+M+M*NB)
- *
- 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), copying result to U
- * (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
- *
- 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+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+3*M, prefer M*M+2*M+M*NB)
- *
- 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)
- *
- 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 much larger than 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+2*M, prefer M*M+M+M*NB)
- *
- 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+2*M, prefer M*M+M+M*NB)
- *
- 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+4*M, prefer M*M+3*M+2*M*NB)
- *
- 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*M+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+3*M, prefer M*M+2*M+M*NB)
- *
- 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)
- *
- 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 greater than 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+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,
- $ IERR )
- IF( WNTQN ) THEN
- *
- * Perform bidiagonal SVD, only computing singular values
- * (Workspace: need M+BDSPAC)
- *
- CALL DBDSDC( 'L', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1,
- $ DUM, IDUM, WORK( NWORK ), IWORK, INFO )
- ELSE IF( WNTQO ) THEN
- 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
- 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 M*M+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 M*M+2*M, prefer M*M+M+M*NB)
- *
- 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
- *
- * Overwrite WORK(IVT) by left singular vectors of A
- * (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
- *
- 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
- *
- * Generate P**T in A
- * (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
- *
- 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 2*M*M, prefer M*M+M*N)
- *
- 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
- *
- * 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+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, prefer 2*M+M*NB)
- *
- 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
- *
- * 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+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 2*M+N, prefer 2*M+N*NB)
- *
- 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
- SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
- *
- * -- LAPACK driver routine (version 3.1) --
- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
- * November 2006
- *
- * .. Scalar Arguments ..
- INTEGER INFO, LDA, LDB, N, NRHS
- * ..
- * .. Array Arguments ..
- INTEGER IPIV( * )
- DOUBLE PRECISION A( LDA, * ), B( LDB, * )
- * ..
- *
- * Purpose
- * =======
- *
- * DGESV computes the solution to a real system of linear equations
- * A * X = B,
- * where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
- *
- * The LU decomposition with partial pivoting and row interchanges is
- * used to factor A as
- * A = P * L * U,
- * where P is a permutation matrix, L is unit lower triangular, and U is
- * upper triangular. The factored form of A is then used to solve the
- * system of equations A * X = B.
- *
- * Arguments
- * =========
- *
- * N (input) INTEGER
- * The number of linear equations, i.e., the order of the
- * matrix A. N >= 0.
- *
- * NRHS (input) INTEGER
- * The number of right hand sides, i.e., the number of columns
- * of the matrix B. NRHS >= 0.
- *
- * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
- * On entry, the N-by-N coefficient matrix A.
- * On exit, the factors L and U from the factorization
- * A = P*L*U; the unit diagonal elements of L are not stored.
- *
- * LDA (input) INTEGER
- * The leading dimension of the array A. LDA >= max(1,N).
- *
- * IPIV (output) INTEGER array, dimension (N)
- * The pivot indices that define the permutation matrix P;
- * row i of the matrix was interchanged with row IPIV(i).
- *
- * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
- * On entry, the N-by-NRHS matrix of right hand side matrix B.
- * On exit, if INFO = 0, the N-by-NRHS solution matrix X.
- *
- * LDB (input) INTEGER
- * The leading dimension of the array B. LDB >= max(1,N).
- *
- * INFO (output) INTEGER
- * = 0: successful exit
- * < 0: if INFO = -i, the i-th argument had an illegal value
- * > 0: if INFO = i, U(i,i) is exactly zero. The factorization
- * has been completed, but the factor U is exactly
- * singular, so the solution could not be computed.
- *
- * =====================================================================
- *
- * .. External Subroutines ..
- EXTERNAL DGETRF, DGETRS, XERBLA
- * ..
- * .. Intrinsic Functions ..
- INTRINSIC MAX
- * ..
- * .. Executable Statements ..
- *
- * Test the input parameters.
- *
- INFO = 0
- IF( N.LT.0 ) THEN
- INFO = -1
- ELSE IF( NRHS.LT.0 ) THEN
- INFO = -2
- ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
- INFO = -4
- ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
- INFO = -7
- END IF
- IF( INFO.NE.0 ) THEN
- CALL XERBLA( 'DGESV ', -INFO )
- RETURN
- END IF
- *
- * Compute the LU factorization of A.
- *
- CALL DGETRF( N, N, A, LDA, IPIV, INFO )
- IF( INFO.EQ.0 ) THEN
- *
- * Solve the system A*X = B, overwriting B with X.
- *
- CALL DGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB,
- $ INFO )
- END IF
- RETURN
- *
- * End of DGESV
- *
- END
- SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT,
- $ WORK, LWORK, INFO )
- *
- * -- LAPACK driver routine (version 3.1) --
- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
- * November 2006
- *
- * .. 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( * )
- * ..
- *
- * Purpose
- * =======
- *
- * 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.
- *
- * Arguments
- * =========
- *
- * JOBU (input) 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.
- *
- * JOBVT (input) 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'.
- *
- * M (input) INTEGER
- * The number of rows of the input matrix A. M >= 0.
- *
- * N (input) INTEGER
- * The number of columns of the input matrix A. N >= 0.
- *
- * A (input/output) 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.
- *
- * LDA (input) INTEGER
- * The leading dimension of the array A. LDA >= max(1,M).
- *
- * S (output) DOUBLE PRECISION array, dimension (min(M,N))
- * The singular values of A, sorted so that S(i) >= S(i+1).
- *
- * U (output) 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.
- *
- * LDU (input) INTEGER
- * The leading dimension of the array U. LDU >= 1; if
- * JOBU = 'S' or 'A', LDU >= M.
- *
- * VT (output) 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.
- *
- * LDVT (input) INTEGER
- * The leading dimension of the array VT. LDVT >= 1; if
- * JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).
- *
- * WORK (workspace/output) 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.
- *
- * LWORK (input) INTEGER
- * The dimension of the array WORK.
- * LWORK >= MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,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.
- *
- * INFO (output) 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.
- *
- * =====================================================================
- *
- * .. 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
- 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
- IF( M.GE.MNTHR ) THEN
- IF( WNTUN ) THEN
- *
- * Path 1 (M much larger than N, JOBU='N')
- *
- MAXWRK = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1,
- $ -1 )
- MAXWRK = MAX( MAXWRK, 3*N+2*N*
- $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
- IF( WNTVO .OR. WNTVAS )
- $ MAXWRK = MAX( MAXWRK, 3*N+( N-1 )*
- $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
- 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 + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
- WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
- $ N, N, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+2*N*
- $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+N*
- $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
- 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 + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
- WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
- $ N, N, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+2*N*
- $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+N*
- $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+( N-1 )*
- $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
- 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 + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
- WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
- $ N, N, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+2*N*
- $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+N*
- $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
- 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 + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
- WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
- $ N, N, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+2*N*
- $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+N*
- $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+( N-1 )*
- $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
- 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 + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
- WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
- $ N, N, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+2*N*
- $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+N*
- $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+( N-1 )*
- $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
- 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 + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
- WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'DORGQR', ' ', M,
- $ M, N, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+2*N*
- $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+N*
- $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
- 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 + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
- WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'DORGQR', ' ', M,
- $ M, N, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+2*N*
- $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+N*
- $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+( N-1 )*
- $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
- 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 + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
- WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'DORGQR', ' ', M,
- $ M, N, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+2*N*
- $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+N*
- $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
- WRKBL = MAX( WRKBL, 3*N+( N-1 )*
- $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
- 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)
- *
- MAXWRK = 3*N + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N,
- $ -1, -1 )
- IF( WNTUS .OR. WNTUO )
- $ MAXWRK = MAX( MAXWRK, 3*N+N*
- $ ILAENV( 1, 'DORGBR', 'Q', M, N, N, -1 ) )
- IF( WNTUA )
- $ MAXWRK = MAX( MAXWRK, 3*N+M*
- $ ILAENV( 1, 'DORGBR', 'Q', M, M, N, -1 ) )
- IF( .NOT.WNTVN )
- $ MAXWRK = MAX( MAXWRK, 3*N+( N-1 )*
- $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
- 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
- IF( N.GE.MNTHR ) THEN
- IF( WNTVN ) THEN
- *
- * Path 1t(N much larger than M, JOBVT='N')
- *
- MAXWRK = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1,
- $ -1 )
- MAXWRK = MAX( MAXWRK, 3*M+2*M*
- $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
- IF( WNTUO .OR. WNTUAS )
- $ MAXWRK = MAX( MAXWRK, 3*M+M*
- $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
- 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 + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
- WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
- $ N, M, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+2*M*
- $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+( M-1 )*
- $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
- 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 + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
- WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
- $ N, M, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+2*M*
- $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+( M-1 )*
- $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+M*
- $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
- 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 + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
- WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
- $ N, M, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+2*M*
- $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+( M-1 )*
- $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
- 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 + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
- WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
- $ N, M, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+2*M*
- $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+( M-1 )*
- $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+M*
- $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
- 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 + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
- WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
- $ N, M, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+2*M*
- $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+( M-1 )*
- $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+M*
- $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
- 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 + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
- WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'DORGLQ', ' ', N,
- $ N, M, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+2*M*
- $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+( M-1 )*
- $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
- 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 + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
- WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'DORGLQ', ' ', N,
- $ N, M, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+2*M*
- $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+( M-1 )*
- $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+M*
- $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
- 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 + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
- WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'DORGLQ', ' ', N,
- $ N, M, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+2*M*
- $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+( M-1 )*
- $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
- WRKBL = MAX( WRKBL, 3*M+M*
- $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
- 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)
- *
- MAXWRK = 3*M + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N,
- $ -1, -1 )
- IF( WNTVS .OR. WNTVO )
- $ MAXWRK = MAX( MAXWRK, 3*M+M*
- $ ILAENV( 1, 'DORGBR', 'P', M, N, M, -1 ) )
- IF( WNTVA )
- $ MAXWRK = MAX( MAXWRK, 3*M+N*
- $ ILAENV( 1, 'DORGBR', 'P', N, N, M, -1 ) )
- IF( .NOT.WNTUN )
- $ MAXWRK = MAX( MAXWRK, 3*M+( M-1 )*
- $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
- 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
- *
- CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
- 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
- *
- CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
- $ LDA )
- *
- * 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
- *
- CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
- $ LDA )
- *
- * 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
- *
- CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
- $ LDA )
- *
- * 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
- *
- CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
- $ LDA )
- *
- * 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
- 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.1) --
- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
- * November 2006
- *
- * .. 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, * )
- * ..
- *
- * Purpose
- * =======
- *
- * 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.
- *
- * Description
- * ===========
- *
- * 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.
- *
- * Arguments
- * =========
- *
- * FACT (input) 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.
- *
- * TRANS (input) CHARACTER*1
- * Specifies the form of the system of equations:
- * = 'N': A * X = B (No transpose)
- * = 'T': A**T * X = B (Transpose)
- * = 'C': A**H * X = B (Transpose)
- *
- * N (input) INTEGER
- * The number of linear equations, i.e., the order of the
- * matrix A. N >= 0.
- *
- * NRHS (input) INTEGER
- * The number of right hand sides, i.e., the number of columns
- * of the matrices B and X. NRHS >= 0.
- *
- * A (input/output) 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).
- *
- * LDA (input) INTEGER
- * The leading dimension of the array A. LDA >= max(1,N).
- *
- * AF (input or output) 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).
- *
- * LDAF (input) INTEGER
- * The leading dimension of the array AF. LDAF >= max(1,N).
- *
- * IPIV (input or output) INTEGER array, dimension (N)
- * If FACT = 'F', then IPIV is an input argument and on entry
- * contains the pivot indices from the 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.
- *
- * EQUED (input or output) 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.
- *
- * R (input or output) 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.
- *
- * C (input or output) 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.
- *
- * B (input/output) 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.
- *
- * LDB (input) INTEGER
- * The leading dimension of the array B. LDB >= max(1,N).
- *
- * X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
- * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X
- * 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'.
- *
- * LDX (input) INTEGER
- * The leading dimension of the array X. LDX >= max(1,N).
- *
- * RCOND (output) DOUBLE PRECISION
- * The estimate of the reciprocal condition number of the matrix
- * A 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.
- *
- * FERR (output) DOUBLE PRECISION array, dimension (NRHS)
- * The estimated forward error bound for each solution vector
- * X(j) (the j-th column of the solution matrix X).
- * If XTRUE is the true solution corresponding to X(j), FERR(j)
- * is an estimated upper bound for the magnitude of the largest
- * element in (X(j) - XTRUE) divided by the magnitude of the
- * largest element in X(j). The estimate is as reliable as
- * the estimate for RCOND, and is almost always a slight
- * overestimate of the true error.
- *
- * BERR (output) DOUBLE PRECISION array, dimension (NRHS)
- * The componentwise relative backward error of each solution
- * vector X(j) (i.e., the smallest relative change in
- * any element of A or B that makes X(j) an exact solution).
- *
- * WORK (workspace/output) 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<INFO<=N, then
- * WORK(1) contains the reciprocal pivot growth factor for the
- * leading INFO columns of A.
- *
- * IWORK (workspace) INTEGER array, dimension (N)
- *
- * INFO (output) INTEGER
- * = 0: successful exit
- * < 0: if INFO = -i, the i-th argument had an illegal value
- * > 0: if INFO = i, and i is
- * <= N: U(i,i) is exactly zero. The factorization has
- * 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.
- *
- * =====================================================================
- *
- * .. 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
- 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.1) --
- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
- * November 2006
- *
- * .. 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
- * ..
- *
- * Purpose
- * =======
- *
- * 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.
- *
- *
- * Arguments
- * =========
- *
- * JOBVSL (input) CHARACTER*1
- * = 'N': do not compute the left Schur vectors;
- * = 'V': compute the left Schur vectors.
- *
- * JOBVSR (input) CHARACTER*1
- * = 'N': do not compute the right Schur vectors;
- * = 'V': compute the right Schur vectors.
- *
- * SORT (input) 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);
- *
- * SELCTG (external procedure) 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.
- *
- * N (input) INTEGER
- * The order of the matrices A, B, VSL, and VSR. N >= 0.
- *
- * A (input/output) 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.
- *
- * LDA (input) INTEGER
- * The leading dimension of A. LDA >= max(1,N).
- *
- * B (input/output) 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.
- *
- * LDB (input) INTEGER
- * The leading dimension of B. LDB >= max(1,N).
- *
- * SDIM (output) 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.)
- *
- * ALPHAR (output) DOUBLE PRECISION array, dimension (N)
- * ALPHAI (output) DOUBLE PRECISION array, dimension (N)
- * BETA (output) 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).
- *
- * VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N)
- * If JOBVSL = 'V', VSL will contain the left Schur vectors.
- * Not referenced if JOBVSL = 'N'.
- *
- * LDVSL (input) INTEGER
- * The leading dimension of the matrix VSL. LDVSL >=1, and
- * if JOBVSL = 'V', LDVSL >= N.
- *
- * VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N)
- * If JOBVSR = 'V', VSR will contain the right Schur vectors.
- * Not referenced if JOBVSR = 'N'.
- *
- * LDVSR (input) INTEGER
- * The leading dimension of the matrix VSR. LDVSR >= 1, and
- * if JOBVSR = 'V', LDVSR >= N.
- *
- * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
- * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
- *
- * LWORK (input) INTEGER
- * The dimension of the array WORK.
- * 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.
- *
- * BWORK (workspace) LOGICAL array, dimension (N)
- * Not referenced if SORT = 'N'.
- *
- * INFO (output) 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.
- *
- * =====================================================================
- *
- * .. 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
- 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.1) --
- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
- * November 2006
- *
- * .. 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
- * ..
- *
- * Purpose
- * =======
- *
- * 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.
- *
- *
- * Arguments
- * =========
- *
- * JOBVSL (input) CHARACTER*1
- * = 'N': do not compute the left Schur vectors;
- * = 'V': compute the left Schur vectors.
- *
- * JOBVSR (input) CHARACTER*1
- * = 'N': do not compute the right Schur vectors;
- * = 'V': compute the right Schur vectors.
- *
- * SORT (input) 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).
- *
- * SELCTG (external procedure) 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.
- *
- * SENSE (input) 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'.
- *
- * N (input) INTEGER
- * The order of the matrices A, B, VSL, and VSR. N >= 0.
- *
- * A (input/output) 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.
- *
- * LDA (input) INTEGER
- * The leading dimension of A. LDA >= max(1,N).
- *
- * B (input/output) 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.
- *
- * LDB (input) INTEGER
- * The leading dimension of B. LDB >= max(1,N).
- *
- * SDIM (output) 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.)
- *
- * ALPHAR (output) DOUBLE PRECISION array, dimension (N)
- * ALPHAI (output) DOUBLE PRECISION array, dimension (N)
- * BETA (output) 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).
- *
- * VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N)
- * If JOBVSL = 'V', VSL will contain the left Schur vectors.
- * Not referenced if JOBVSL = 'N'.
- *
- * LDVSL (input) INTEGER
- * The leading dimension of the matrix VSL. LDVSL >=1, and
- * if JOBVSL = 'V', LDVSL >= N.
- *
- * VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N)
- * If JOBVSR = 'V', VSR will contain the right Schur vectors.
- * Not referenced if JOBVSR = 'N'.
- *
- * LDVSR (input) INTEGER
- * The leading dimension of the matrix VSR. LDVSR >= 1, and
- * if JOBVSR = 'V', LDVSR >= N.
- *
- * RCONDE (output) 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'.
- *
- * RCONDV (output) 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'.
- *
- * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
- * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
- *
- * LWORK (input) INTEGER
- * The dimension of the array WORK.
- * If 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.
- *
- * IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))
- * On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.
- *
- * LIWORK (input) 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.
- *
- * BWORK (workspace) LOGICAL array, dimension (N)
- * Not referenced if SORT = 'N'.
- *
- * INFO (output) 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.
- *
- * Further details
- * ===============
- *
- * 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.
- *
- * =====================================================================
- *
- * .. 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
- SUBROUTINE DGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI,
- $ BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )
- *
- * -- LAPACK driver routine (version 3.1) --
- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
- * November 2006
- *
- * .. 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( * )
- * ..
- *
- * Purpose
- * =======
- *
- * 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).
- *
- *
- * Arguments
- * =========
- *
- * JOBVL (input) CHARACTER*1
- * = 'N': do not compute the left generalized eigenvectors;
- * = 'V': compute the left generalized eigenvectors.
- *
- * JOBVR (input) CHARACTER*1
- * = 'N': do not compute the right generalized eigenvectors;
- * = 'V': compute the right generalized eigenvectors.
- *
- * N (input) INTEGER
- * The order of the matrices A, B, VL, and VR. N >= 0.
- *
- * A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
- * On entry, the matrix A in the pair (A,B).
- * On exit, A has been overwritten.
- *
- * LDA (input) INTEGER
- * The leading dimension of A. LDA >= max(1,N).
- *
- * B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
- * On entry, the matrix B in the pair (A,B).
- * On exit, B has been overwritten.
- *
- * LDB (input) INTEGER
- * The leading dimension of B. LDB >= max(1,N).
- *
- * ALPHAR (output) DOUBLE PRECISION array, dimension (N)
- * ALPHAI (output) DOUBLE PRECISION array, dimension (N)
- * BETA (output) 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).
- *
- * VL (output) 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'.
- *
- * LDVL (input) INTEGER
- * The leading dimension of the matrix VL. LDVL >= 1, and
- * if JOBVL = 'V', LDVL >= N.
- *
- * VR (output) 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'.
- *
- * LDVR (input) INTEGER
- * The leading dimension of the matrix VR. LDVR >= 1, and
- * if JOBVR = 'V', LDVR >= N.
- *
- * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
- * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
- *
- * LWORK (input) INTEGER
- * The dimension of the array WORK. LWORK >= max(1,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.
- *
- * INFO (output) 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.
- *
- * =====================================================================
- *
- * .. 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
- *
- 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
- *
- 110 CONTINUE
- *
- WORK( 1 ) = MAXWRK
- *
- RETURN
- *
- * End of DGGEV
- *
- END
- 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.1) --
- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
- * November 2006
- *
- * .. 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( * )
- * ..
- *
- * Purpose
- * =======
- *
- * 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).
- *
- *
- * Arguments
- * =========
- *
- * BALANC (input) 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.
- *
- * JOBVL (input) CHARACTER*1
- * = 'N': do not compute the left generalized eigenvectors;
- * = 'V': compute the left generalized eigenvectors.
- *
- * JOBVR (input) CHARACTER*1
- * = 'N': do not compute the right generalized eigenvectors;
- * = 'V': compute the right generalized eigenvectors.
- *
- * SENSE (input) 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.
- *
- * N (input) INTEGER
- * The order of the matrices A, B, VL, and VR. N >= 0.
- *
- * A (input/output) 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.
- *
- * LDA (input) INTEGER
- * The leading dimension of A. LDA >= max(1,N).
- *
- * B (input/output) 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.
- *
- * LDB (input) INTEGER
- * The leading dimension of B. LDB >= max(1,N).
- *
- * ALPHAR (output) DOUBLE PRECISION array, dimension (N)
- * ALPHAI (output) DOUBLE PRECISION array, dimension (N)
- * BETA (output) 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).
- *
- * VL (output) 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'.
- *
- * LDVL (input) INTEGER
- * The leading dimension of the matrix VL. LDVL >= 1, and
- * if JOBVL = 'V', LDVL >= N.
- *
- * VR (output) 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'.
- *
- * LDVR (input) INTEGER
- * The leading dimension of the matrix VR. LDVR >= 1, and
- * if JOBVR = 'V', LDVR >= N.
- *
- * ILO (output) INTEGER
- * IHI (output) 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.
- *
- * LSCALE (output) 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.
- *
- * RSCALE (output) 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.
- *
- * ABNRM (output) DOUBLE PRECISION
- * The one-norm of the balanced matrix A.
- *
- * BBNRM (output) DOUBLE PRECISION
- * The one-norm of the balanced matrix B.
- *
- * RCONDE (output) 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.
- *
- * RCONDV (output) 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.
- *
- * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
- * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
- *
- * LWORK (input) INTEGER
- * The dimension of the array WORK. LWORK >= max(1,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.
- *
- * IWORK (workspace) INTEGER array, dimension (N+6)
- * If SENSE = 'E', IWORK is not referenced.
- *
- * BWORK (workspace) LOGICAL array, dimension (N)
- * If SENSE = 'N', BWORK is not referenced.
- *
- * INFO (output) 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.
- *
- * Further Details
- * ===============
- *
- * 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.
- *
- * =====================================================================
- *
- * .. 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
-