/* Subroutine */ int dgerfs_(char *trans, integer *n, integer *nrhs,
doublereal *a, integer *lda, doublereal *af, integer *ldaf, integer *
ipiv, doublereal *b, integer *ldb, doublereal *x, integer *ldx,
doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork,
integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
DGERFS improves the computed solution to a system of linear
equations and provides error bounds and backward error estimates for
the solution.
Arguments
=========
TRANS (input) CHARACTER*1
Specifies the form of the system of equations:
= 'N': A * X = B (No transpose)
= 'T': A**T * X = B (Transpose)
= 'C': A**H * X = B (Conjugate transpose = Transpose)
N (input) INTEGER
The order of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrices B and X. NRHS >= 0.
A (input) DOUBLE PRECISION array, dimension (LDA,N)
The original N-by-N matrix A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
AF (input) DOUBLE PRECISION array, dimension (LDAF,N)
The factors L and U from the factorization A = P*L*U
as computed by DGETRF.
LDAF (input) INTEGER
The leading dimension of the array AF. LDAF >= max(1,N).
IPIV (input) INTEGER array, dimension (N)
The pivot indices from DGETRF; for 1<=i<=N, row i of the
matrix was interchanged with row IPIV(i).
B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
The right hand side matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
On entry, the solution matrix X, as computed by DGETRS.
On exit, the improved solution matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
FERR (output) DOUBLE PRECISION array, dimension (NRHS)
The estimated forward error bound for each solution vector
X(j) (the j-th column of the solution matrix X).
If XTRUE is the true solution corresponding to X(j), FERR(j)
is an estimated upper bound for the magnitude of the largest
element in (X(j) - XTRUE) divided by the magnitude of the
largest element in X(j). The estimate is as reliable as
the estimate for RCOND, and is almost always a slight
overestimate of the true error.
BERR (output) DOUBLE PRECISION array, dimension (NRHS)
The componentwise relative backward error of each solution
vector X(j) (i.e., the smallest relative change in
any element of A or B that makes X(j) an exact solution).
WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
IWORK (workspace) INTEGER array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Internal Parameters
===================
ITMAX is the maximum number of steps of iterative refinement.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b15 = -1.;
static doublereal c_b17 = 1.;
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
x_offset, i__1, i__2, i__3;
doublereal d__1, d__2, d__3;
/* Local variables */
static integer kase;
static doublereal safe1, safe2;
static integer i__, j, k;
static doublereal s;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), dcopy_(integer *,
doublereal *, integer *, doublereal *, integer *), daxpy_(integer
*, doublereal *, doublereal *, integer *, doublereal *, integer *)
;
static integer count;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlacon_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static doublereal xk;
static integer nz;
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *), dgetrs_(
char *, integer *, integer *, doublereal *, integer *, integer *,
doublereal *, integer *, integer *);
static logical notran;
static char transt[1];
static doublereal lstres, eps;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define x_ref(a_1,a_2) x[(a_2)*x_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1 * 1;
af -= af_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
--ferr;
--berr;
--work;
--iwork;
/* Function Body */
*info = 0;
notran = lsame_(trans, "N");
if (! notran && ! lsame_(trans, "T") && ! lsame_(
trans, "C")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldaf < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -10;
} else if (*ldx < max(1,*n)) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGERFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] = 0.;
berr[j] = 0.;
/* L10: */
}
return 0;
}
if (notran) {
*(unsigned char *)transt = 'T';
} else {
*(unsigned char *)transt = 'N';
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
eps = dlamch_("Epsilon");
safmin = dlamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
count = 1;
lstres = 3.;
L20:
/* Loop until stopping criterion is satisfied.
Compute residual R = B - op(A) * X,
where op(A) = A, A**T, or A**H, depending on TRANS. */
dcopy_(n, &b_ref(1, j), &c__1, &work[*n + 1], &c__1);
dgemv_(trans, n, n, &c_b15, &a[a_offset], lda, &x_ref(1, j), &c__1, &
c_b17, &work[*n + 1], &c__1);
/* Compute componentwise relative backward error from formula
max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
where abs(Z) is the componentwise absolute value of the matrix
or vector Z. If the i-th component of the denominator is less
than SAFE2, then SAFE1 is added to the i-th components of the
numerator and denominator before dividing. */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] = (d__1 = b_ref(i__, j), abs(d__1));
/* L30: */
}
/* Compute abs(op(A))*abs(X) + abs(B). */
if (notran) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
xk = (d__1 = x_ref(k, j), abs(d__1));
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
work[i__] += (d__1 = a_ref(i__, k), abs(d__1)) * xk;
/* L40: */
}
/* L50: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.;
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
s += (d__1 = a_ref(i__, k), abs(d__1)) * (d__2 = x_ref(
i__, j), abs(d__2));
/* L60: */
}
work[k] += s;
/* L70: */
}
}
s = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (work[i__] > safe2) {
/* Computing MAX */
d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[
i__];
s = max(d__2,d__3);
} else {
/* Computing MAX */
d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1)
/ (work[i__] + safe1);
s = max(d__2,d__3);
}
/* L80: */
}
berr[j] = s;
/* Test stopping criterion. Continue iterating if
1) The residual BERR(J) is larger than machine epsilon, and
2) BERR(J) decreased by at least a factor of 2 during the
last iteration, and
3) At most ITMAX iterations tried. */
if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {
/* Update solution and try again. */
dgetrs_(trans, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[*n
+ 1], n, info);
daxpy_(n, &c_b17, &work[*n + 1], &c__1, &x_ref(1, j), &c__1);
lstres = berr[j];
++count;
goto L20;
}
/* Bound error from formula
norm(X - XTRUE) / norm(X) .le. FERR =
norm( abs(inv(op(A)))*
( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
where
norm(Z) is the magnitude of the largest component of Z
inv(op(A)) is the inverse of op(A)
abs(Z) is the componentwise absolute value of the matrix or
vector Z
NZ is the maximum number of nonzeros in any row of A, plus 1
EPS is machine epsilon
The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
is incremented by SAFE1 if the i-th component of
abs(op(A))*abs(X) + abs(B) is less than SAFE2.
Use DLACON to estimate the infinity-norm of the matrix
inv(op(A)) * diag(W),
where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (work[i__] > safe2) {
work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
work[i__];
} else {
work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
work[i__] + safe1;
}
/* L90: */
}
kase = 0;
L100:
dlacon_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(op(A)**T). */
dgetrs_(transt, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &
work[*n + 1], n, info);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*n + i__] = work[i__] * work[*n + i__];
/* L110: */
}
} else {
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*n + i__] = work[i__] * work[*n + i__];
/* L120: */
}
dgetrs_(trans, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &
work[*n + 1], n, info);
}
goto L100;
}
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = lstres, d__3 = (d__1 = x_ref(i__, j), abs(d__1));
lstres = max(d__2,d__3);
/* L130: */
}
if (lstres != 0.) {
ferr[j] /= lstres;
}
/* L140: */
}
return 0;
/* End of DGERFS */
} /* dgerfs_ */
/* Subroutine */ int dsyrfs_(char *uplo, integer *n, integer *nrhs,
doublereal *a, integer *lda, doublereal *af, integer *ldaf, integer *
ipiv, doublereal *b, integer *ldb, doublereal *x, integer *ldx,
doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork,
integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
DSYRFS improves the computed solution to a system of linear
equations when the coefficient matrix is symmetric indefinite, and
provides error bounds and backward error estimates for the solution.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrices B and X. NRHS >= 0.
A (input) DOUBLE PRECISION array, dimension (LDA,N)
The symmetric matrix A. If UPLO = 'U', the leading N-by-N
upper triangular part of A contains the upper triangular part
of the matrix A, and the strictly lower triangular part of A
is not referenced. If UPLO = 'L', the leading N-by-N lower
triangular part of A contains the lower triangular part of
the matrix A, and the strictly upper triangular part of A is
not referenced.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
AF (input) DOUBLE PRECISION array, dimension (LDAF,N)
The factored form of the matrix A. AF contains the block
diagonal matrix D and the multipliers used to obtain the
factor U or L from the factorization A = U*D*U**T or
A = L*D*L**T as computed by DSYTRF.
LDAF (input) INTEGER
The leading dimension of the array AF. LDAF >= max(1,N).
IPIV (input) INTEGER array, dimension (N)
Details of the interchanges and the block structure of D
as determined by DSYTRF.
B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
The right hand side matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
On entry, the solution matrix X, as computed by DSYTRS.
On exit, the improved solution matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
FERR (output) DOUBLE PRECISION array, dimension (NRHS)
The estimated forward error bound for each solution vector
X(j) (the j-th column of the solution matrix X).
If XTRUE is the true solution corresponding to X(j), FERR(j)
is an estimated upper bound for the magnitude of the largest
element in (X(j) - XTRUE) divided by the magnitude of the
largest element in X(j). The estimate is as reliable as
the estimate for RCOND, and is almost always a slight
overestimate of the true error.
BERR (output) DOUBLE PRECISION array, dimension (NRHS)
The componentwise relative backward error of each solution
vector X(j) (i.e., the smallest relative change in
any element of A or B that makes X(j) an exact solution).
WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
IWORK (workspace) INTEGER array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Internal Parameters
===================
ITMAX is the maximum number of steps of iterative refinement.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b12 = -1.;
static doublereal c_b14 = 1.;
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
x_offset, i__1, i__2, i__3;
doublereal d__1, d__2, d__3;
/* Local variables */
static integer kase;
static doublereal safe1, safe2;
static integer i, j, k;
static doublereal s;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), daxpy_(integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *);
static integer count;
static logical upper;
extern /* Subroutine */ int dsymv_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *);
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlacon_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static doublereal xk;
static integer nz;
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal lstres;
extern /* Subroutine */ int dsytrs_(char *, integer *, integer *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *);
static doublereal eps;
#define IPIV(I) ipiv[(I)-1]
#define FERR(I) ferr[(I)-1]
#define BERR(I) berr[(I)-1]
#define WORK(I) work[(I)-1]
#define IWORK(I) iwork[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define AF(I,J) af[(I)-1 + ((J)-1)* ( *ldaf)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define X(I,J) x[(I)-1 + ((J)-1)* ( *ldx)]
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldaf < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -10;
} else if (*ldx < max(1,*n)) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYRFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= *nrhs; ++j) {
FERR(j) = 0.;
BERR(j) = 0.;
/* L10: */
}
return 0;
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
eps = dlamch_("Epsilon");
safmin = dlamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= *nrhs; ++j) {
count = 1;
lstres = 3.;
L20:
/* Loop until stopping criterion is satisfied.
Compute residual R = B - A * X */
dcopy_(n, &B(1,j), &c__1, &WORK(*n + 1), &c__1);
dsymv_(uplo, n, &c_b12, &A(1,1), lda, &X(1,j), &c__1,
&c_b14, &WORK(*n + 1), &c__1);
/* Compute componentwise relative backward error from formula
max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
where abs(Z) is the componentwise absolute value of the matr
ix
or vector Z. If the i-th component of the denominator is le
ss
than SAFE2, then SAFE1 is added to the i-th components of th
e
numerator and denominator before dividing. */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
WORK(i) = (d__1 = B(i,j), abs(d__1));
/* L30: */
}
/* Compute abs(A)*abs(X) + abs(B). */
if (upper) {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
s = 0.;
xk = (d__1 = X(k,j), abs(d__1));
i__3 = k - 1;
for (i = 1; i <= k-1; ++i) {
WORK(i) += (d__1 = A(i,k), abs(d__1)) * xk;
s += (d__1 = A(i,k), abs(d__1)) * (d__2 = X(i,j), abs(d__2));
/* L40: */
}
WORK(k) = WORK(k) + (d__1 = A(k,k), abs(d__1)) *
xk + s;
/* L50: */
}
} else {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
s = 0.;
xk = (d__1 = X(k,j), abs(d__1));
WORK(k) += (d__1 = A(k,k), abs(d__1)) * xk;
i__3 = *n;
for (i = k + 1; i <= *n; ++i) {
WORK(i) += (d__1 = A(i,k), abs(d__1)) * xk;
s += (d__1 = A(i,k), abs(d__1)) * (d__2 = X(i,j), abs(d__2));
/* L60: */
}
WORK(k) += s;
/* L70: */
}
}
s = 0.;
i__2 = *n;
for (i = 1; i <= *n; ++i) {
if (WORK(i) > safe2) {
/* Computing MAX */
d__2 = s, d__3 = (d__1 = WORK(*n + i), abs(d__1)) / WORK(i);
s = max(d__2,d__3);
} else {
/* Computing MAX */
d__2 = s, d__3 = ((d__1 = WORK(*n + i), abs(d__1)) + safe1) /
(WORK(i) + safe1);
s = max(d__2,d__3);
}
/* L80: */
}
BERR(j) = s;
/* Test stopping criterion. Continue iterating if
1) The residual BERR(J) is larger than machine epsilon, a
nd
2) BERR(J) decreased by at least a factor of 2 during the
last iteration, and
3) At most ITMAX iterations tried. */
if (BERR(j) > eps && BERR(j) * 2. <= lstres && count <= 5) {
/* Update solution and try again. */
dsytrs_(uplo, n, &c__1, &AF(1,1), ldaf, &IPIV(1), &WORK(*n
+ 1), n, info);
daxpy_(n, &c_b14, &WORK(*n + 1), &c__1, &X(1,j), &c__1)
;
lstres = BERR(j);
++count;
goto L20;
}
/* Bound error from formula
norm(X - XTRUE) / norm(X) .le. FERR =
norm( abs(inv(A))*
( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
where
norm(Z) is the magnitude of the largest component of Z
inv(A) is the inverse of A
abs(Z) is the componentwise absolute value of the matrix o
r
vector Z
NZ is the maximum number of nonzeros in any row of A, plus
1
EPS is machine epsilon
The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
is incremented by SAFE1 if the i-th component of
abs(A)*abs(X) + abs(B) is less than SAFE2.
Use DLACON to estimate the infinity-norm of the matrix
inv(A) * diag(W),
where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
if (WORK(i) > safe2) {
WORK(i) = (d__1 = WORK(*n + i), abs(d__1)) + nz * eps * WORK(
i);
} else {
WORK(i) = (d__1 = WORK(*n + i), abs(d__1)) + nz * eps * WORK(
i) + safe1;
}
/* L90: */
}
kase = 0;
L100:
dlacon_(n, &WORK((*n << 1) + 1), &WORK(*n + 1), &IWORK(1), &FERR(j), &
kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(A'). */
dsytrs_(uplo, n, &c__1, &AF(1,1), ldaf, &IPIV(1), &WORK(
*n + 1), n, info);
i__2 = *n;
for (i = 1; i <= *n; ++i) {
WORK(*n + i) = WORK(i) * WORK(*n + i);
/* L110: */
}
} else if (kase == 2) {
/* Multiply by inv(A)*diag(W). */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
WORK(*n + i) = WORK(i) * WORK(*n + i);
/* L120: */
}
dsytrs_(uplo, n, &c__1, &AF(1,1), ldaf, &IPIV(1), &WORK(
*n + 1), n, info);
}
goto L100;
}
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i = 1; i <= *n; ++i) {
/* Computing MAX */
d__2 = lstres, d__3 = (d__1 = X(i,j), abs(d__1));
lstres = max(d__2,d__3);
/* L130: */
}
if (lstres != 0.) {
FERR(j) /= lstres;
}
/* L140: */
}
return 0;
/* End of DSYRFS */
} /* dsyrfs_ */
/* Subroutine */ int dtbrfs_(char *uplo, char *trans, char *diag, integer *n,
integer *kd, integer *nrhs, doublereal *ab, integer *ldab, doublereal
*b, integer *ldb, doublereal *x, integer *ldx, doublereal *ferr,
doublereal *berr, doublereal *work, integer *iwork, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
DTBRFS provides error bounds and backward error estimates for the
solution to a system of linear equations with a triangular band
coefficient matrix.
The solution matrix X must be computed by DTBTRS or some other
means before entering this routine. DTBRFS does not do iterative
refinement because doing so cannot improve the backward error.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': A is upper triangular;
= 'L': A is lower triangular.
TRANS (input) CHARACTER*1
Specifies the form of the system of equations:
= 'N': A * X = B (No transpose)
= 'T': A**T * X = B (Transpose)
= 'C': A**H * X = B (Conjugate transpose = Transpose)
DIAG (input) CHARACTER*1
= 'N': A is non-unit triangular;
= 'U': A is unit triangular.
N (input) INTEGER
The order of the matrix A. N >= 0.
KD (input) INTEGER
The number of superdiagonals or subdiagonals of the
triangular band matrix A. KD >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrices B and X. NRHS >= 0.
AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
The upper or lower triangular band matrix A, stored in the
first kd+1 rows of the array. The j-th column of A is stored
in the j-th column of the array AB as follows:
if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
If DIAG = 'U', the diagonal elements of A are not referenced
and are assumed to be 1.
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD+1.
B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
The right hand side matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
The solution matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
FERR (output) DOUBLE PRECISION array, dimension (NRHS)
The estimated forward error bound for each solution vector
X(j) (the j-th column of the solution matrix X).
If XTRUE is the true solution corresponding to X(j), FERR(j)
is an estimated upper bound for the magnitude of the largest
element in (X(j) - XTRUE) divided by the magnitude of the
largest element in X(j). The estimate is as reliable as
the estimate for RCOND, and is almost always a slight
overestimate of the true error.
BERR (output) DOUBLE PRECISION array, dimension (NRHS)
The componentwise relative backward error of each solution
vector X(j) (i.e., the smallest relative change in
any element of A or B that makes X(j) an exact solution).
WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
IWORK (workspace) INTEGER array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b19 = -1.;
/* System generated locals */
integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, i__1,
i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3;
/* Local variables */
static integer kase;
static doublereal safe1, safe2;
static integer i__, j, k;
static doublereal s;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dtbmv_(char *, char *, char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *), dcopy_(integer *, doublereal *, integer *
, doublereal *, integer *), dtbsv_(char *, char *, char *,
integer *, integer *, doublereal *, integer *, doublereal *,
integer *), daxpy_(integer *, doublereal *
, doublereal *, integer *, doublereal *, integer *);
static logical upper;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlacon_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static doublereal xk;
static integer nz;
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static logical notran;
static char transt[1];
static logical nounit;
static doublereal lstres, eps;
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define x_ref(a_1,a_2) x[(a_2)*x_dim1 + a_1]
#define ab_ref(a_1,a_2) ab[(a_2)*ab_dim1 + a_1]
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
--ferr;
--berr;
--work;
--iwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && !
lsame_(trans, "C")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*kd < 0) {
*info = -5;
} else if (*nrhs < 0) {
*info = -6;
} else if (*ldab < *kd + 1) {
*info = -8;
} else if (*ldb < max(1,*n)) {
*info = -10;
} else if (*ldx < max(1,*n)) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DTBRFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] = 0.;
berr[j] = 0.;
/* L10: */
}
return 0;
}
if (notran) {
*(unsigned char *)transt = 'T';
} else {
*(unsigned char *)transt = 'N';
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *kd + 2;
eps = dlamch_("Epsilon");
safmin = dlamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
/* Compute residual R = B - op(A) * X,
where op(A) = A or A', depending on TRANS. */
dcopy_(n, &x_ref(1, j), &c__1, &work[*n + 1], &c__1);
dtbmv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[*n + 1],
&c__1);
daxpy_(n, &c_b19, &b_ref(1, j), &c__1, &work[*n + 1], &c__1);
/* Compute componentwise relative backward error from formula
max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
where abs(Z) is the componentwise absolute value of the matrix
or vector Z. If the i-th component of the denominator is less
than SAFE2, then SAFE1 is added to the i-th components of the
numerator and denominator before dividing. */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] = (d__1 = b_ref(i__, j), abs(d__1));
/* L20: */
}
if (notran) {
/* Compute abs(A)*abs(X) + abs(B). */
if (upper) {
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
xk = (d__1 = x_ref(k, j), abs(d__1));
/* Computing MAX */
i__3 = 1, i__4 = k - *kd;
i__5 = k;
for (i__ = max(i__3,i__4); i__ <= i__5; ++i__) {
work[i__] += (d__1 = ab_ref(*kd + 1 + i__ - k, k),
abs(d__1)) * xk;
/* L30: */
}
/* L40: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
xk = (d__1 = x_ref(k, j), abs(d__1));
/* Computing MAX */
i__5 = 1, i__3 = k - *kd;
i__4 = k - 1;
for (i__ = max(i__5,i__3); i__ <= i__4; ++i__) {
work[i__] += (d__1 = ab_ref(*kd + 1 + i__ - k, k),
abs(d__1)) * xk;
/* L50: */
}
work[k] += xk;
/* L60: */
}
}
} else {
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
xk = (d__1 = x_ref(k, j), abs(d__1));
/* Computing MIN */
i__5 = *n, i__3 = k + *kd;
i__4 = min(i__5,i__3);
for (i__ = k; i__ <= i__4; ++i__) {
work[i__] += (d__1 = ab_ref(i__ + 1 - k, k), abs(
d__1)) * xk;
/* L70: */
}
/* L80: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
xk = (d__1 = x_ref(k, j), abs(d__1));
/* Computing MIN */
i__5 = *n, i__3 = k + *kd;
i__4 = min(i__5,i__3);
for (i__ = k + 1; i__ <= i__4; ++i__) {
work[i__] += (d__1 = ab_ref(i__ + 1 - k, k), abs(
d__1)) * xk;
/* L90: */
}
work[k] += xk;
/* L100: */
}
}
}
} else {
/* Compute abs(A')*abs(X) + abs(B). */
if (upper) {
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.;
/* Computing MAX */
i__4 = 1, i__5 = k - *kd;
i__3 = k;
for (i__ = max(i__4,i__5); i__ <= i__3; ++i__) {
s += (d__1 = ab_ref(*kd + 1 + i__ - k, k), abs(
d__1)) * (d__2 = x_ref(i__, j), abs(d__2))
;
/* L110: */
}
work[k] += s;
/* L120: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = (d__1 = x_ref(k, j), abs(d__1));
/* Computing MAX */
i__3 = 1, i__4 = k - *kd;
i__5 = k - 1;
for (i__ = max(i__3,i__4); i__ <= i__5; ++i__) {
s += (d__1 = ab_ref(*kd + 1 + i__ - k, k), abs(
d__1)) * (d__2 = x_ref(i__, j), abs(d__2))
;
/* L130: */
}
work[k] += s;
/* L140: */
}
}
} else {
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.;
/* Computing MIN */
i__3 = *n, i__4 = k + *kd;
i__5 = min(i__3,i__4);
for (i__ = k; i__ <= i__5; ++i__) {
s += (d__1 = ab_ref(i__ + 1 - k, k), abs(d__1)) *
(d__2 = x_ref(i__, j), abs(d__2));
/* L150: */
}
work[k] += s;
/* L160: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = (d__1 = x_ref(k, j), abs(d__1));
/* Computing MIN */
i__3 = *n, i__4 = k + *kd;
i__5 = min(i__3,i__4);
for (i__ = k + 1; i__ <= i__5; ++i__) {
s += (d__1 = ab_ref(i__ + 1 - k, k), abs(d__1)) *
(d__2 = x_ref(i__, j), abs(d__2));
/* L170: */
}
work[k] += s;
/* L180: */
}
}
}
}
s = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (work[i__] > safe2) {
/* Computing MAX */
d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[
i__];
s = max(d__2,d__3);
} else {
/* Computing MAX */
d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1)
/ (work[i__] + safe1);
s = max(d__2,d__3);
}
/* L190: */
}
berr[j] = s;
/* Bound error from formula
norm(X - XTRUE) / norm(X) .le. FERR =
norm( abs(inv(op(A)))*
( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
where
norm(Z) is the magnitude of the largest component of Z
inv(op(A)) is the inverse of op(A)
abs(Z) is the componentwise absolute value of the matrix or
vector Z
NZ is the maximum number of nonzeros in any row of A, plus 1
EPS is machine epsilon
The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
is incremented by SAFE1 if the i-th component of
abs(op(A))*abs(X) + abs(B) is less than SAFE2.
Use DLACON to estimate the infinity-norm of the matrix
inv(op(A)) * diag(W),
where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (work[i__] > safe2) {
work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
work[i__];
} else {
work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
work[i__] + safe1;
}
/* L200: */
}
kase = 0;
L210:
dlacon_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(op(A)'). */
dtbsv_(uplo, transt, diag, n, kd, &ab[ab_offset], ldab, &work[
*n + 1], &c__1);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*n + i__] = work[i__] * work[*n + i__];
/* L220: */
}
} else {
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*n + i__] = work[i__] * work[*n + i__];
/* L230: */
}
dtbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[*
n + 1], &c__1);
}
goto L210;
}
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = lstres, d__3 = (d__1 = x_ref(i__, j), abs(d__1));
lstres = max(d__2,d__3);
/* L240: */
}
if (lstres != 0.) {
ferr[j] /= lstres;
}
/* L250: */
}
return 0;
/* End of DTBRFS */
} /* dtbrfs_ */
/* Subroutine */ int dgbcon_(char *norm, integer *n, integer *kl, integer *ku,
doublereal *ab, integer *ldab, integer *ipiv, doublereal *anorm,
doublereal *rcond, doublereal *work, integer *iwork, integer *info,
ftnlen norm_len)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3;
doublereal d__1;
/* Local variables */
static integer j;
static doublereal t;
static integer kd, lm, jp, ix, kase;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static integer kase1;
static doublereal scale;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int drscl_(integer *, doublereal *, doublereal *,
integer *);
static logical lnoti;
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
extern doublereal dlamch_(char *, ftnlen);
extern /* Subroutine */ int dlacon_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dlatbs_(char *, char *, char *, char *,
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, integer *, ftnlen, ftnlen, ftnlen,
ftnlen), xerbla_(char *, integer *, ftnlen);
static doublereal ainvnm;
static logical onenrm;
static char normin[1];
static doublereal smlnum;
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGBCON estimates the reciprocal of the condition number of a real */
/* general band matrix A, in either the 1-norm or the infinity-norm, */
/* using the LU factorization computed by DGBTRF. */
/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
/* condition number is computed as */
/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies whether the 1-norm condition number or the */
/* infinity-norm condition number is required: */
/* = '1' or 'O': 1-norm; */
/* = 'I': Infinity-norm. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* KL (input) INTEGER */
/* The number of subdiagonals within the band of A. KL >= 0. */
/* KU (input) INTEGER */
/* The number of superdiagonals within the band of A. KU >= 0. */
/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
/* Details of the LU factorization of the band matrix A, as */
/* computed by DGBTRF. U is stored as an upper triangular band */
/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */
/* the multipliers used during the factorization are stored in */
/* rows KL+KU+2 to 2*KL+KU+1. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices; for 1 <= i <= N, row i of the matrix was */
/* interchanged with row IPIV(i). */
/* ANORM (input) DOUBLE PRECISION */
/* If NORM = '1' or 'O', the 1-norm of the original matrix A. */
/* If NORM = 'I', the infinity-norm of the original matrix A. */
/* RCOND (output) DOUBLE PRECISION */
/* The reciprocal of the condition number of the matrix A, */
/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
/* IWORK (workspace) INTEGER array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--ipiv;
--work;
--iwork;
/* Function Body */
*info = 0;
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O", (ftnlen)1, (
ftnlen)1);
if (! onenrm && ! lsame_(norm, "I", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kl < 0) {
*info = -3;
} else if (*ku < 0) {
*info = -4;
} else if (*ldab < (*kl << 1) + *ku + 1) {
*info = -6;
} else if (*anorm < 0.) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGBCON", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
*rcond = 0.;
if (*n == 0) {
*rcond = 1.;
return 0;
} else if (*anorm == 0.) {
return 0;
}
smlnum = dlamch_("Safe minimum", (ftnlen)12);
/* Estimate the norm of inv(A). */
ainvnm = 0.;
*(unsigned char *)normin = 'N';
if (onenrm) {
kase1 = 1;
} else {
kase1 = 2;
}
kd = *kl + *ku + 1;
lnoti = *kl > 0;
kase = 0;
L10:
dlacon_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(L). */
if (lnoti) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__2 = *kl, i__3 = *n - j;
lm = min(i__2,i__3);
jp = ipiv[j];
t = work[jp];
if (jp != j) {
work[jp] = work[j];
work[j] = t;
}
d__1 = -t;
daxpy_(&lm, &d__1, &ab[kd + 1 + j * ab_dim1], &c__1, &
work[j + 1], &c__1);
/* L20: */
}
}
/* Multiply by inv(U). */
i__1 = *kl + *ku;
dlatbs_("Upper", "No transpose", "Non-unit", normin, n, &i__1, &
ab[ab_offset], ldab, &work[1], &scale, &work[(*n << 1) +
1], info, (ftnlen)5, (ftnlen)12, (ftnlen)8, (ftnlen)1);
} else {
/* Multiply by inv(U'). */
i__1 = *kl + *ku;
dlatbs_("Upper", "Transpose", "Non-unit", normin, n, &i__1, &ab[
ab_offset], ldab, &work[1], &scale, &work[(*n << 1) + 1],
info, (ftnlen)5, (ftnlen)9, (ftnlen)8, (ftnlen)1);
/* Multiply by inv(L'). */
if (lnoti) {
for (j = *n - 1; j >= 1; --j) {
/* Computing MIN */
i__1 = *kl, i__2 = *n - j;
lm = min(i__1,i__2);
work[j] -= ddot_(&lm, &ab[kd + 1 + j * ab_dim1], &c__1, &
work[j + 1], &c__1);
jp = ipiv[j];
if (jp != j) {
t = work[jp];
work[jp] = work[j];
work[j] = t;
}
/* L30: */
}
}
}
/* Divide X by 1/SCALE if doing so will not cause overflow. */
*(unsigned char *)normin = 'Y';
if (scale != 1.) {
ix = idamax_(n, &work[1], &c__1);
if (scale < (d__1 = work[ix], abs(d__1)) * smlnum || scale == 0.)
{
goto L40;
}
drscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.) {
*rcond = 1. / ainvnm / *anorm;
}
L40:
return 0;
/* End of DGBCON */
} /* dgbcon_ */
/* Subroutine */ int dtrcon_(char *norm, char *uplo, char *diag, integer *n,
doublereal *a, integer *lda, doublereal *rcond, doublereal *work,
integer *iwork, integer *info, ftnlen norm_len, ftnlen uplo_len,
ftnlen diag_len)
{
/* System generated locals */
integer a_dim1, a_offset, i__1;
doublereal d__1;
/* Local variables */
static integer ix, kase, kase1;
static doublereal scale;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int drscl_(integer *, doublereal *, doublereal *,
integer *);
static doublereal anorm;
static logical upper;
static doublereal xnorm;
extern doublereal dlamch_(char *, ftnlen);
extern /* Subroutine */ int dlacon_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
extern doublereal dlantr_(char *, char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *, ftnlen, ftnlen, ftnlen);
static doublereal ainvnm;
extern /* Subroutine */ int dlatrs_(char *, char *, char *, char *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen);
static logical onenrm;
static char normin[1];
static doublereal smlnum;
static logical nounit;
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* March 31, 1993 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DTRCON estimates the reciprocal of the condition number of a */
/* triangular matrix A, in either the 1-norm or the infinity-norm. */
/* The norm of A is computed and an estimate is obtained for */
/* norm(inv(A)), then the reciprocal of the condition number is */
/* computed as */
/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies whether the 1-norm condition number or the */
/* infinity-norm condition number is required: */
/* = '1' or 'O': 1-norm; */
/* = 'I': Infinity-norm. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': A is upper triangular; */
/* = 'L': A is lower triangular. */
/* DIAG (input) CHARACTER*1 */
/* = 'N': A is non-unit triangular; */
/* = 'U': A is unit triangular. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The triangular matrix A. If UPLO = 'U', the leading N-by-N */
/* upper triangular part of the array A contains the upper */
/* triangular matrix, and the strictly lower triangular part of */
/* A is not referenced. If UPLO = 'L', the leading N-by-N lower */
/* triangular part of the array A contains the lower triangular */
/* matrix, and the strictly upper triangular part of A is not */
/* referenced. If DIAG = 'U', the diagonal elements of A are */
/* also not referenced and are assumed to be 1. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* RCOND (output) DOUBLE PRECISION */
/* The reciprocal of the condition number of the matrix A, */
/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
/* IWORK (workspace) INTEGER array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--work;
--iwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O", (ftnlen)1, (
ftnlen)1);
nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
if (! onenrm && ! lsame_(norm, "I", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DTRCON", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*rcond = 1.;
return 0;
}
*rcond = 0.;
smlnum = dlamch_("Safe minimum", (ftnlen)12) * (doublereal) max(1,*n);
/* Compute the norm of the triangular matrix A. */
anorm = dlantr_(norm, uplo, diag, n, n, &a[a_offset], lda, &work[1], (
ftnlen)1, (ftnlen)1, (ftnlen)1);
/* Continue only if ANORM > 0. */
if (anorm > 0.) {
/* Estimate the norm of the inverse of A. */
ainvnm = 0.;
*(unsigned char *)normin = 'N';
if (onenrm) {
kase1 = 1;
} else {
kase1 = 2;
}
kase = 0;
L10:
dlacon_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(A). */
dlatrs_(uplo, "No transpose", diag, normin, n, &a[a_offset],
lda, &work[1], &scale, &work[(*n << 1) + 1], info, (
ftnlen)1, (ftnlen)12, (ftnlen)1, (ftnlen)1);
} else {
/* Multiply by inv(A'). */
dlatrs_(uplo, "Transpose", diag, normin, n, &a[a_offset], lda,
&work[1], &scale, &work[(*n << 1) + 1], info, (
ftnlen)1, (ftnlen)9, (ftnlen)1, (ftnlen)1);
}
*(unsigned char *)normin = 'Y';
/* Multiply by 1/SCALE if doing so will not cause overflow. */
if (scale != 1.) {
ix = idamax_(n, &work[1], &c__1);
xnorm = (d__1 = work[ix], abs(d__1));
if (scale < xnorm * smlnum || scale == 0.) {
goto L20;
}
drscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.) {
*rcond = 1. / anorm / ainvnm;
}
}
L20:
return 0;
/* End of DTRCON */
} /* dtrcon_ */
void
dgscon(char *norm, SuperMatrix *L, SuperMatrix *U,
double anorm, double *rcond, int *info)
{
/*
Purpose
=======
DGSCON estimates the reciprocal of the condition number of a general
real matrix A, in either the 1-norm or the infinity-norm, using
the LU factorization computed by DGETRF.
An estimate is obtained for norm(inv(A)), and the reciprocal of the
condition number is computed as
RCOND = 1 / ( norm(A) * norm(inv(A)) ).
See supermatrix.h for the definition of 'SuperMatrix' structure.
Arguments
=========
NORM (input) char*
Specifies whether the 1-norm condition number or the
infinity-norm condition number is required:
= '1' or 'O': 1-norm;
= 'I': Infinity-norm.
L (input) SuperMatrix*
The factor L from the factorization Pr*A*Pc=L*U as computed by
dgstrf(). Use compressed row subscripts storage for supernodes,
i.e., L has types: Stype = SC, Dtype = D_, Mtype = TRLU.
U (input) SuperMatrix*
The factor U from the factorization Pr*A*Pc=L*U as computed by
dgstrf(). Use column-wise storage scheme, i.e., U has types:
Stype = NC, Dtype = D_, Mtype = TRU.
ANORM (input) double
If NORM = '1' or 'O', the 1-norm of the original matrix A.
If NORM = 'I', the infinity-norm of the original matrix A.
RCOND (output) double*
The reciprocal of the condition number of the matrix A,
computed as RCOND = 1/(norm(A) * norm(inv(A))).
INFO (output) int*
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
*/
/* Local variables */
int kase, kase1, onenrm, i;
double ainvnm;
double *work;
int *iwork;
extern int drscl_(int *, double *, double *, int *);
extern int dlacon_(int *, double *, double *, int *, double *, int *);
/* Test the input parameters. */
*info = 0;
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
if (! onenrm && ! lsame_(norm, "I")) *info = -1;
else if (L->nrow < 0 || L->nrow != L->ncol ||
L->Stype != SC || L->Dtype != D_ || L->Mtype != TRLU)
*info = -2;
else if (U->nrow < 0 || U->nrow != U->ncol ||
U->Stype != NC || U->Dtype != D_ || U->Mtype != TRU)
*info = -3;
if (*info != 0) {
i = -(*info);
xerbla_("dgscon", &i);
return;
}
/* Quick return if possible */
*rcond = 0.;
if ( L->nrow == 0 || U->nrow == 0) {
*rcond = 1.;
return;
}
work = doubleCalloc( 3*L->nrow );
iwork = intMalloc( L->nrow );
if ( !work || !iwork )
ABORT("Malloc fails for work arrays in dgscon.");
/* Estimate the norm of inv(A). */
ainvnm = 0.;
if ( onenrm ) kase1 = 1;
else kase1 = 2;
kase = 0;
do {
dlacon_(&L->nrow, &work[L->nrow], &work[0], &iwork[0], &ainvnm, &kase);
if (kase == 0) break;
if (kase == kase1) {
/* Multiply by inv(L). */
sp_dtrsv("Lower", "No transpose", "Unit", L, U, &work[0], info);
/* Multiply by inv(U). */
sp_dtrsv("Upper", "No transpose", "Non-unit", L, U, &work[0],info);
} else {
/* Multiply by inv(U'). */
sp_dtrsv("Upper", "Transpose", "Non-unit", L, U, &work[0], info);
/* Multiply by inv(L'). */
sp_dtrsv("Lower", "Transpose", "Unit", L, U, &work[0], info);
}
} while ( kase != 0 );
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.) *rcond = (1. / ainvnm) / anorm;
SUPERLU_FREE (work);
SUPERLU_FREE (iwork);
return;
} /* dgscon */
/* Subroutine */ int dgtcon_(char *norm, integer *n, doublereal *dl,
doublereal *d__, doublereal *du, doublereal *du2, integer *ipiv,
doublereal *anorm, doublereal *rcond, doublereal *work, integer *
iwork, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
DGTCON estimates the reciprocal of the condition number of a real
tridiagonal matrix A using the LU factorization as computed by
DGTTRF.
An estimate is obtained for norm(inv(A)), and the reciprocal of the
condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
Arguments
=========
NORM (input) CHARACTER*1
Specifies whether the 1-norm condition number or the
infinity-norm condition number is required:
= '1' or 'O': 1-norm;
= 'I': Infinity-norm.
N (input) INTEGER
The order of the matrix A. N >= 0.
DL (input) DOUBLE PRECISION array, dimension (N-1)
The (n-1) multipliers that define the matrix L from the
LU factorization of A as computed by DGTTRF.
D (input) DOUBLE PRECISION array, dimension (N)
The n diagonal elements of the upper triangular matrix U from
the LU factorization of A.
DU (input) DOUBLE PRECISION array, dimension (N-1)
The (n-1) elements of the first superdiagonal of U.
DU2 (input) DOUBLE PRECISION array, dimension (N-2)
The (n-2) elements of the second superdiagonal of U.
IPIV (input) INTEGER array, dimension (N)
The pivot indices; for 1 <= i <= n, row i of the matrix was
interchanged with row IPIV(i). IPIV(i) will always be either
i or i+1; IPIV(i) = i indicates a row interchange was not
required.
ANORM (input) DOUBLE PRECISION
If NORM = '1' or 'O', the 1-norm of the original matrix A.
If NORM = 'I', the infinity-norm of the original matrix A.
RCOND (output) DOUBLE PRECISION
The reciprocal of the condition number of the matrix A,
computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
estimate of the 1-norm of inv(A) computed in this routine.
WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
IWORK (workspace) INTEGER array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input arguments.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer i__1;
/* Local variables */
static integer kase, kase1, i__;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dlacon_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *), xerbla_(char *, integer *);
static doublereal ainvnm;
static logical onenrm;
extern /* Subroutine */ int dgttrs_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *, integer *);
--iwork;
--work;
--ipiv;
--du2;
--du;
--d__;
--dl;
/* Function Body */
*info = 0;
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
if (! onenrm && ! lsame_(norm, "I")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*anorm < 0.) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGTCON", &i__1);
return 0;
}
/* Quick return if possible */
*rcond = 0.;
if (*n == 0) {
*rcond = 1.;
return 0;
} else if (*anorm == 0.) {
return 0;
}
/* Check that D(1:N) is non-zero. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (d__[i__] == 0.) {
return 0;
}
/* L10: */
}
ainvnm = 0.;
if (onenrm) {
kase1 = 1;
} else {
kase1 = 2;
}
kase = 0;
L20:
dlacon_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(U)*inv(L). */
dgttrs_("No transpose", n, &c__1, &dl[1], &d__[1], &du[1], &du2[1]
, &ipiv[1], &work[1], n, info);
} else {
/* Multiply by inv(L')*inv(U'). */
dgttrs_("Transpose", n, &c__1, &dl[1], &d__[1], &du[1], &du2[1], &
ipiv[1], &work[1], n, info);
}
goto L20;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.) {
*rcond = 1. / ainvnm / *anorm;
}
return 0;
/* End of DGTCON */
} /* dgtcon_ */
void
dgsrfs(char *trans, SuperMatrix *A, SuperMatrix *L, SuperMatrix *U,
int *perm_r, int *perm_c, char *equed, double *R, double *C,
SuperMatrix *B, SuperMatrix *X,
double *ferr, double *berr, int *info)
{
/*
* Purpose
* =======
*
* DGSRFS improves the computed solution to a system of linear
* equations and provides error bounds and backward error estimates for
* the solution.
*
* If equilibration was performed, the system becomes:
* (diag(R)*A_original*diag(C)) * X = diag(R)*B_original.
*
* See supermatrix.h for the definition of 'SuperMatrix' structure.
*
* Arguments
* =========
*
* trans (input) char*
* Specifies the form of the system of equations:
* = 'N': A * X = B (No transpose)
* = 'T': A**T * X = B (Transpose)
* = 'C': A**H * X = B (Conjugate transpose = Transpose)
*
* A (input) SuperMatrix*
* The original matrix A in the system, or the scaled A if
* equilibration was done. The type of A can be:
* Stype = NC, Dtype = _D, Mtype = GE.
*
* L (input) SuperMatrix*
* The factor L from the factorization Pr*A*Pc=L*U. Use
* compressed row subscripts storage for supernodes,
* i.e., L has types: Stype = SC, Dtype = _D, Mtype = TRLU.
*
* U (input) SuperMatrix*
* The factor U from the factorization Pr*A*Pc=L*U as computed by
* dgstrf(). Use column-wise storage scheme,
* i.e., U has types: Stype = NC, Dtype = _D, Mtype = TRU.
*
* perm_r (input) int*, dimension (A->nrow)
* Row permutation vector, which defines the permutation matrix Pr;
* perm_r[i] = j means row i of A is in position j in Pr*A.
*
* perm_c (input) int*, dimension (A->ncol)
* Column permutation vector, which defines the
* permutation matrix Pc; perm_c[i] = j means column i of A is
* in position j in A*Pc.
*
* equed (input) Specifies the form of equilibration that was done.
* = 'N': No equilibration.
* = 'R': Row equilibration, i.e., A was premultiplied by diag(R).
* = 'C': Column equilibration, i.e., A was postmultiplied by
* diag(C).
* = 'B': Both row and column equilibration, i.e., A was replaced
* by diag(R)*A*diag(C).
*
* R (input) double*, dimension (A->nrow)
* The row scale factors for A.
* If equed = 'R' or 'B', A is premultiplied by diag(R).
* If equed = 'N' or 'C', R is not accessed.
*
* C (input) double*, dimension (A->ncol)
* The column scale factors for A.
* If equed = 'C' or 'B', A is postmultiplied by diag(C).
* If equed = 'N' or 'R', C is not accessed.
*
* B (input) SuperMatrix*
* B has types: Stype = DN, Dtype = _D, Mtype = GE.
* The right hand side matrix B.
* if equed = 'R' or 'B', B is premultiplied by diag(R).
*
* X (input/output) SuperMatrix*
* X has types: Stype = DN, Dtype = _D, Mtype = GE.
* On entry, the solution matrix X, as computed by dgstrs().
* On exit, the improved solution matrix X.
* if *equed = 'C' or 'B', X should be premultiplied by diag(C)
* in order to obtain the solution to the original system.
*
* FERR (output) double*, dimension (B->ncol)
* 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*, dimension (B->ncol)
* 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).
*
* info (output) int*
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Internal Parameters
* ===================
*
* ITMAX is the maximum number of steps of iterative refinement.
*
*/
#define ITMAX 5
/* Table of constant values */
int ione = 1;
double ndone = -1.;
double done = 1.;
/* Local variables */
NCformat *Astore;
double *Aval;
SuperMatrix Bjcol;
DNformat *Bstore, *Xstore, *Bjcol_store;
double *Bmat, *Xmat, *Bptr, *Xptr;
int kase;
double safe1, safe2;
int i, j, k, irow, nz, count, notran, rowequ, colequ;
int ldb, ldx, nrhs;
double s, xk, lstres, eps, safmin;
char transt[1];
double *work;
double *rwork;
int *iwork;
extern double dlamch_(char *);
extern int dlacon_(int *, double *, double *, int *, double *, int *);
#ifdef _CRAY
extern int SCOPY(int *, double *, int *, double *, int *);
extern int SSAXPY(int *, double *, double *, int *, double *, int *);
#else
extern int dcopy_(int *, double *, int *, double *, int *);
extern int daxpy_(int *, double *, double *, int *, double *, int *);
#endif
Astore = A->Store;
Aval = Astore->nzval;
Bstore = B->Store;
Xstore = X->Store;
Bmat = Bstore->nzval;
Xmat = Xstore->nzval;
ldb = Bstore->lda;
ldx = Xstore->lda;
nrhs = B->ncol;
/* Test the input parameters */
*info = 0;
notran = lsame_(trans, "N");
if ( !notran && !lsame_(trans, "T") && !lsame_(trans, "C")) *info = -1;
else if ( A->nrow != A->ncol || A->nrow < 0 ||
A->Stype != NC || A->Dtype != _D || A->Mtype != GE )
*info = -2;
else if ( L->nrow != L->ncol || L->nrow < 0 ||
L->Stype != SC || L->Dtype != _D || L->Mtype != TRLU )
*info = -3;
else if ( U->nrow != U->ncol || U->nrow < 0 ||
U->Stype != NC || U->Dtype != _D || U->Mtype != TRU )
*info = -4;
else if ( ldb < MAX(0, A->nrow) ||
B->Stype != DN || B->Dtype != _D || B->Mtype != GE )
*info = -10;
else if ( ldx < MAX(0, A->nrow) ||
X->Stype != DN || X->Dtype != _D || X->Mtype != GE )
*info = -11;
if (*info != 0) {
i = -(*info);
xerbla_("dgsrfs", &i);
return;
}
/* Quick return if possible */
if ( A->nrow == 0 || nrhs == 0) {
for (j = 0; j < nrhs; ++j) {
ferr[j] = 0.;
berr[j] = 0.;
}
return;
}
rowequ = lsame_(equed, "R") || lsame_(equed, "B");
colequ = lsame_(equed, "C") || lsame_(equed, "B");
/* Allocate working space */
work = doubleMalloc(2*A->nrow);
rwork = (double *) SUPERLU_MALLOC( A->nrow * sizeof(double) );
iwork = intMalloc(2*A->nrow);
if ( !work || !rwork || !iwork )
ABORT("Malloc fails for work/rwork/iwork.");
if ( notran ) {
*(unsigned char *)transt = 'T';
} else {
*(unsigned char *)transt = 'N';
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = A->ncol + 1;
eps = dlamch_("Epsilon");
safmin = dlamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Compute the number of nonzeros in each row (or column) of A */
for (i = 0; i < A->nrow; ++i) iwork[i] = 0;
if ( notran ) {
for (k = 0; k < A->ncol; ++k)
for (i = Astore->colptr[k]; i < Astore->colptr[k+1]; ++i)
++iwork[Astore->rowind[i]];
} else {
for (k = 0; k < A->ncol; ++k)
iwork[k] = Astore->colptr[k+1] - Astore->colptr[k];
}
/* Copy one column of RHS B into Bjcol. */
Bjcol.Stype = B->Stype;
Bjcol.Dtype = B->Dtype;
Bjcol.Mtype = B->Mtype;
Bjcol.nrow = B->nrow;
Bjcol.ncol = 1;
Bjcol.Store = (void *) SUPERLU_MALLOC( sizeof(DNformat) );
if ( !Bjcol.Store ) ABORT("SUPERLU_MALLOC fails for Bjcol.Store");
Bjcol_store = Bjcol.Store;
Bjcol_store->lda = ldb;
Bjcol_store->nzval = work; /* address aliasing */
/* Do for each right hand side ... */
for (j = 0; j < nrhs; ++j) {
count = 0;
lstres = 3.;
Bptr = &Bmat[j*ldb];
Xptr = &Xmat[j*ldx];
while (1) { /* Loop until stopping criterion is satisfied. */
/* Compute residual R = B - op(A) * X,
where op(A) = A, A**T, or A**H, depending on TRANS. */
#ifdef _CRAY
SCOPY(&A->nrow, Bptr, &ione, work, &ione);
#else
dcopy_(&A->nrow, Bptr, &ione, work, &ione);
#endif
sp_dgemv(trans, ndone, A, Xptr, ione, done, work, ione);
/* Compute componentwise relative backward error from formula
max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
where abs(Z) is the componentwise absolute value of the matrix
or vector Z. If the i-th component of the denominator is less
than SAFE2, then SAFE1 is added to the i-th component of the
numerator and denominator before dividing. */
for (i = 0; i < A->nrow; ++i) rwork[i] = fabs( Bptr[i] );
/* Compute abs(op(A))*abs(X) + abs(B). */
if (notran) {
for (k = 0; k < A->ncol; ++k) {
xk = fabs( Xptr[k] );
for (i = Astore->colptr[k]; i < Astore->colptr[k+1]; ++i)
rwork[Astore->rowind[i]] += fabs(Aval[i]) * xk;
}
} else {
for (k = 0; k < A->ncol; ++k) {
s = 0.;
for (i = Astore->colptr[k]; i < Astore->colptr[k+1]; ++i) {
irow = Astore->rowind[i];
s += fabs(Aval[i]) * fabs(Xptr[irow]);
}
rwork[k] += s;
}
}
s = 0.;
for (i = 0; i < A->nrow; ++i) {
if (rwork[i] > safe2)
s = MAX( s, fabs(work[i]) / rwork[i] );
else
s = MAX( s, (fabs(work[i]) + safe1) /
(rwork[i] + safe1) );
}
berr[j] = s;
/* Test stopping criterion. Continue iterating if
1) The residual BERR(J) is larger than machine epsilon, and
2) BERR(J) decreased by at least a factor of 2 during the
last iteration, and
3) At most ITMAX iterations tried. */
if (berr[j] > eps && berr[j] * 2. <= lstres && count < ITMAX) {
/* Update solution and try again. */
dgstrs (trans, L, U, perm_r, perm_c, &Bjcol, info);
#ifdef _CRAY
SAXPY(&A->nrow, &done, work, &ione,
&Xmat[j*ldx], &ione);
#else
daxpy_(&A->nrow, &done, work, &ione,
&Xmat[j*ldx], &ione);
#endif
lstres = berr[j];
++count;
} else {
break;
}
} /* end while */
/* Bound error from formula:
norm(X - XTRUE) / norm(X) .le. FERR = norm( abs(inv(op(A)))*
( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
where
norm(Z) is the magnitude of the largest component of Z
inv(op(A)) is the inverse of op(A)
abs(Z) is the componentwise absolute value of the matrix or
vector Z
NZ is the maximum number of nonzeros in any row of A, plus 1
EPS is machine epsilon
The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
is incremented by SAFE1 if the i-th component of
abs(op(A))*abs(X) + abs(B) is less than SAFE2.
Use DLACON to estimate the infinity-norm of the matrix
inv(op(A)) * diag(W),
where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
for (i = 0; i < A->nrow; ++i) rwork[i] = fabs( Bptr[i] );
/* Compute abs(op(A))*abs(X) + abs(B). */
if ( notran ) {
for (k = 0; k < A->ncol; ++k) {
xk = fabs( Xptr[k] );
for (i = Astore->colptr[k]; i < Astore->colptr[k+1]; ++i)
rwork[Astore->rowind[i]] += fabs(Aval[i]) * xk;
}
} else {
for (k = 0; k < A->ncol; ++k) {
s = 0.;
for (i = Astore->colptr[k]; i < Astore->colptr[k+1]; ++i) {
irow = Astore->rowind[i];
xk = fabs( Xptr[irow] );
s += fabs(Aval[i]) * xk;
}
rwork[k] += s;
}
}
for (i = 0; i < A->nrow; ++i)
if (rwork[i] > safe2)
rwork[i] = fabs(work[i]) + (iwork[i]+1)*eps*rwork[i];
else
rwork[i] = fabs(work[i])+(iwork[i]+1)*eps*rwork[i]+safe1;
kase = 0;
do {
dlacon_(&A->nrow, &work[A->nrow], work,
&iwork[A->nrow], &ferr[j], &kase);
if (kase == 0) break;
if (kase == 1) {
/* Multiply by diag(W)*inv(op(A)**T)*(diag(C) or diag(R)). */
if ( notran && colequ )
for (i = 0; i < A->ncol; ++i) work[i] *= C[i];
else if ( !notran && rowequ )
for (i = 0; i < A->nrow; ++i) work[i] *= R[i];
dgstrs (transt, L, U, perm_r, perm_c, &Bjcol, info);
for (i = 0; i < A->nrow; ++i) work[i] *= rwork[i];
} else {
/* Multiply by (diag(C) or diag(R))*inv(op(A))*diag(W). */
for (i = 0; i < A->nrow; ++i) work[i] *= rwork[i];
dgstrs (trans, L, U, perm_r, perm_c, &Bjcol, info);
if ( notran && colequ )
for (i = 0; i < A->ncol; ++i) work[i] *= C[i];
else if ( !notran && rowequ )
for (i = 0; i < A->ncol; ++i) work[i] *= R[i];
}
} while ( kase != 0 );
/* Normalize error. */
lstres = 0.;
if ( notran && colequ ) {
for (i = 0; i < A->nrow; ++i)
lstres = MAX( lstres, C[i] * fabs( Xptr[i]) );
} else if ( !notran && rowequ ) {
for (i = 0; i < A->nrow; ++i)
lstres = MAX( lstres, R[i] * fabs( Xptr[i]) );
} else {
for (i = 0; i < A->nrow; ++i)
lstres = MAX( lstres, fabs( Xptr[i]) );
}
if ( lstres != 0. )
ferr[j] /= lstres;
} /* for each RHS j ... */
SUPERLU_FREE(work);
SUPERLU_FREE(rwork);
SUPERLU_FREE(iwork);
SUPERLU_FREE(Bjcol.Store);
return;
} /* dgsrfs */
/* Subroutine */ int dgtrfs_(char *trans, integer *n, integer *nrhs,
doublereal *dl, doublereal *d, doublereal *du, doublereal *dlf,
doublereal *df, doublereal *duf, doublereal *du2, integer *ipiv,
doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *
ferr, doublereal *berr, doublereal *work, integer *iwork, integer *
info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
DGTRFS improves the computed solution to a system of linear
equations when the coefficient matrix is tridiagonal, and provides
error bounds and backward error estimates for the solution.
Arguments
=========
TRANS (input) CHARACTER*1
Specifies the form of the system of equations:
= 'N': A * X = B (No transpose)
= 'T': A**T * X = B (Transpose)
= 'C': A**H * X = B (Conjugate transpose = Transpose)
N (input) INTEGER
The order of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrix B. NRHS >= 0.
DL (input) DOUBLE PRECISION array, dimension (N-1)
The (n-1) subdiagonal elements of A.
D (input) DOUBLE PRECISION array, dimension (N)
The diagonal elements of A.
DU (input) DOUBLE PRECISION array, dimension (N-1)
The (n-1) superdiagonal elements of A.
DLF (input) DOUBLE PRECISION array, dimension (N-1)
The (n-1) multipliers that define the matrix L from the
LU factorization of A as computed by DGTTRF.
DF (input) DOUBLE PRECISION array, dimension (N)
The n diagonal elements of the upper triangular matrix U from
the LU factorization of A.
DUF (input) DOUBLE PRECISION array, dimension (N-1)
The (n-1) elements of the first superdiagonal of U.
DU2 (input) DOUBLE PRECISION array, dimension (N-2)
The (n-2) elements of the second superdiagonal of U.
IPIV (input) INTEGER array, dimension (N)
The pivot indices; for 1 <= i <= n, row i of the matrix was
interchanged with row IPIV(i). IPIV(i) will always be either
i or i+1; IPIV(i) = i indicates a row interchange was not
required.
B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
The right hand side matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
On entry, the solution matrix X, as computed by DGTTRS.
On exit, the improved solution matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
FERR (output) DOUBLE PRECISION array, dimension (NRHS)
The estimated forward error bound for each solution vector
X(j) (the j-th column of the solution matrix X).
If XTRUE is the true solution corresponding to X(j), FERR(j)
is an estimated upper bound for the magnitude of the largest
element in (X(j) - XTRUE) divided by the magnitude of the
largest element in X(j). The estimate is as reliable as
the estimate for RCOND, and is almost always a slight
overestimate of the true error.
BERR (output) DOUBLE PRECISION array, dimension (NRHS)
The componentwise relative backward error of each solution
vector X(j) (i.e., the smallest relative change in
any element of A or B that makes X(j) an exact solution).
WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
IWORK (workspace) INTEGER array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Internal Parameters
===================
ITMAX is the maximum number of steps of iterative refinement.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b18 = -1.;
static doublereal c_b19 = 1.;
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2;
doublereal d__1, d__2, d__3, d__4;
/* Local variables */
static integer kase;
static doublereal safe1, safe2;
static integer i, j;
static doublereal s;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), daxpy_(integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *);
static integer count;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlacon_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static integer nz;
extern /* Subroutine */ int dlagtm_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, doublereal *, integer *);
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static logical notran;
static char transn[1];
extern /* Subroutine */ int dgttrs_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *, integer *);
static char transt[1];
static doublereal lstres, eps;
#define DL(I) dl[(I)-1]
#define D(I) d[(I)-1]
#define DU(I) du[(I)-1]
#define DLF(I) dlf[(I)-1]
#define DF(I) df[(I)-1]
#define DUF(I) duf[(I)-1]
#define DU2(I) du2[(I)-1]
#define IPIV(I) ipiv[(I)-1]
#define FERR(I) ferr[(I)-1]
#define BERR(I) berr[(I)-1]
#define WORK(I) work[(I)-1]
#define IWORK(I) iwork[(I)-1]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define X(I,J) x[(I)-1 + ((J)-1)* ( *ldx)]
*info = 0;
notran = lsame_(trans, "N");
if (! notran && ! lsame_(trans, "T") && ! lsame_(trans, "C")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*ldb < max(1,*n)) {
*info = -13;
} else if (*ldx < max(1,*n)) {
*info = -15;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGTRFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= *nrhs; ++j) {
FERR(j) = 0.;
BERR(j) = 0.;
/* L10: */
}
return 0;
}
if (notran) {
*(unsigned char *)transn = 'N';
*(unsigned char *)transt = 'T';
} else {
*(unsigned char *)transn = 'T';
*(unsigned char *)transt = 'N';
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = 4;
eps = dlamch_("Epsilon");
safmin = dlamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= *nrhs; ++j) {
count = 1;
lstres = 3.;
L20:
/* Loop until stopping criterion is satisfied.
Compute residual R = B - op(A) * X,
where op(A) = A, A**T, or A**H, depending on TRANS. */
dcopy_(n, &B(1,j), &c__1, &WORK(*n + 1), &c__1);
dlagtm_(trans, n, &c__1, &c_b18, &DL(1), &D(1), &DU(1), &X(1,j), ldx, &c_b19, &WORK(*n + 1), n);
/* Compute abs(op(A))*abs(x) + abs(b) for use in the backward
error bound. */
if (notran) {
if (*n == 1) {
WORK(1) = (d__1 = B(1,j), abs(d__1)) + (d__2 = D(1)
* X(1,j), abs(d__2));
} else {
WORK(1) = (d__1 = B(1,j), abs(d__1)) + (d__2 = D(1)
* X(1,j), abs(d__2)) + (d__3 = DU(1) * X(2,j), abs(d__3));
i__2 = *n - 1;
for (i = 2; i <= *n-1; ++i) {
WORK(i) = (d__1 = B(i,j), abs(d__1)) + (d__2 =
DL(i - 1) * X(i-1,j), abs(d__2)) + (
d__3 = D(i) * X(i,j), abs(d__3)) + (
d__4 = DU(i) * X(i+1,j), abs(d__4));
/* L30: */
}
WORK(*n) = (d__1 = B(*n,j), abs(d__1)) + (d__2 =
DL(*n - 1) * X(*n-1,j), abs(d__2)) + (
d__3 = D(*n) * X(*n,j), abs(d__3));
}
} else {
if (*n == 1) {
WORK(1) = (d__1 = B(1,j), abs(d__1)) + (d__2 = D(1)
* X(1,j), abs(d__2));
} else {
WORK(1) = (d__1 = B(1,j), abs(d__1)) + (d__2 = D(1)
* X(1,j), abs(d__2)) + (d__3 = DL(1) * X(2,j), abs(d__3));
i__2 = *n - 1;
for (i = 2; i <= *n-1; ++i) {
WORK(i) = (d__1 = B(i,j), abs(d__1)) + (d__2 =
DU(i - 1) * X(i-1,j), abs(d__2)) + (
d__3 = D(i) * X(i,j), abs(d__3)) + (
d__4 = DL(i) * X(i+1,j), abs(d__4));
/* L40: */
}
WORK(*n) = (d__1 = B(*n,j), abs(d__1)) + (d__2 =
DU(*n - 1) * X(*n-1,j), abs(d__2)) + (
d__3 = D(*n) * X(*n,j), abs(d__3));
}
}
/* Compute componentwise relative backward error from formula
max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
where abs(Z) is the componentwise absolute value of the matr
ix
or vector Z. If the i-th component of the denominator is le
ss
than SAFE2, then SAFE1 is added to the i-th components of th
e
numerator and denominator before dividing. */
s = 0.;
i__2 = *n;
for (i = 1; i <= *n; ++i) {
if (WORK(i) > safe2) {
/* Computing MAX */
d__2 = s, d__3 = (d__1 = WORK(*n + i), abs(d__1)) / WORK(i);
s = max(d__2,d__3);
} else {
/* Computing MAX */
d__2 = s, d__3 = ((d__1 = WORK(*n + i), abs(d__1)) + safe1) /
(WORK(i) + safe1);
s = max(d__2,d__3);
}
/* L50: */
}
BERR(j) = s;
/* Test stopping criterion. Continue iterating if
1) The residual BERR(J) is larger than machine epsilon, a
nd
2) BERR(J) decreased by at least a factor of 2 during the
last iteration, and
3) At most ITMAX iterations tried. */
if (BERR(j) > eps && BERR(j) * 2. <= lstres && count <= 5) {
/* Update solution and try again. */
dgttrs_(trans, n, &c__1, &DLF(1), &DF(1), &DUF(1), &DU2(1), &IPIV(
1), &WORK(*n + 1), n, info);
daxpy_(n, &c_b19, &WORK(*n + 1), &c__1, &X(1,j), &c__1)
;
lstres = BERR(j);
++count;
goto L20;
}
/* Bound error from formula
norm(X - XTRUE) / norm(X) .le. FERR =
norm( abs(inv(op(A)))*
( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X
)
where
norm(Z) is the magnitude of the largest component of Z
inv(op(A)) is the inverse of op(A)
abs(Z) is the componentwise absolute value of the matrix o
r
vector Z
NZ is the maximum number of nonzeros in any row of A, plus
1
EPS is machine epsilon
The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B
))
is incremented by SAFE1 if the i-th component of
abs(op(A))*abs(X) + abs(B) is less than SAFE2.
Use DLACON to estimate the infinity-norm of the matrix
inv(op(A)) * diag(W),
where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
if (WORK(i) > safe2) {
WORK(i) = (d__1 = WORK(*n + i), abs(d__1)) + nz * eps * WORK(
i);
} else {
WORK(i) = (d__1 = WORK(*n + i), abs(d__1)) + nz * eps * WORK(
i) + safe1;
}
/* L60: */
}
kase = 0;
L70:
dlacon_(n, &WORK((*n << 1) + 1), &WORK(*n + 1), &IWORK(1), &FERR(j), &
kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(op(A)**T). */
dgttrs_(transt, n, &c__1, &DLF(1), &DF(1), &DUF(1), &DU2(1), &
IPIV(1), &WORK(*n + 1), n, info);
i__2 = *n;
for (i = 1; i <= *n; ++i) {
WORK(*n + i) = WORK(i) * WORK(*n + i);
/* L80: */
}
} else {
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
WORK(*n + i) = WORK(i) * WORK(*n + i);
/* L90: */
}
dgttrs_(transn, n, &c__1, &DLF(1), &DF(1), &DUF(1), &DU2(1), &
IPIV(1), &WORK(*n + 1), n, info);
}
goto L70;
}
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i = 1; i <= *n; ++i) {
/* Computing MAX */
d__2 = lstres, d__3 = (d__1 = X(i,j), abs(d__1));
lstres = max(d__2,d__3);
/* L100: */
}
if (lstres != 0.) {
FERR(j) /= lstres;
}
/* L110: */
}
return 0;
/* End of DGTRFS */
} /* dgtrfs_ */
/* Subroutine */ int dppcon_(char *uplo, integer *n, doublereal *ap,
doublereal *anorm, doublereal *rcond, doublereal *work, integer *
iwork, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
DPPCON estimates the reciprocal of the condition number (in the
1-norm) of a real symmetric positive definite packed matrix using
the Cholesky factorization A = U**T*U or A = L*L**T computed by
DPPTRF.
An estimate is obtained for norm(inv(A)), and the reciprocal of the
condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
The triangular factor U or L from the Cholesky factorization
A = U**T*U or A = L*L**T, packed columnwise in a linear
array. The j-th column of U or L is stored in the array AP
as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
ANORM (input) DOUBLE PRECISION
The 1-norm (or infinity-norm) of the symmetric matrix A.
RCOND (output) DOUBLE PRECISION
The reciprocal of the condition number of the matrix A,
computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
estimate of the 1-norm of inv(A) computed in this routine.
WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
IWORK (workspace) INTEGER array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer i__1;
doublereal d__1;
/* Local variables */
static integer kase;
static doublereal scale;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int drscl_(integer *, doublereal *, doublereal *,
integer *);
static logical upper;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlacon_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static integer ix;
static doublereal scalel;
extern integer idamax_(integer *, doublereal *, integer *);
static doublereal scaleu;
extern /* Subroutine */ int xerbla_(char *, integer *), dlatps_(
char *, char *, char *, char *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *);
static doublereal ainvnm;
static char normin[1];
static doublereal smlnum;
--iwork;
--work;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*anorm < 0.) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DPPCON", &i__1);
return 0;
}
/* Quick return if possible */
*rcond = 0.;
if (*n == 0) {
*rcond = 1.;
return 0;
} else if (*anorm == 0.) {
return 0;
}
smlnum = dlamch_("Safe minimum");
/* Estimate the 1-norm of the inverse. */
kase = 0;
*(unsigned char *)normin = 'N';
L10:
dlacon_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase);
if (kase != 0) {
if (upper) {
/* Multiply by inv(U'). */
dlatps_("Upper", "Transpose", "Non-unit", normin, n, &ap[1], &
work[1], &scalel, &work[(*n << 1) + 1], info);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(U). */
dlatps_("Upper", "No transpose", "Non-unit", normin, n, &ap[1], &
work[1], &scaleu, &work[(*n << 1) + 1], info);
} else {
/* Multiply by inv(L). */
dlatps_("Lower", "No transpose", "Non-unit", normin, n, &ap[1], &
work[1], &scalel, &work[(*n << 1) + 1], info);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(L'). */
dlatps_("Lower", "Transpose", "Non-unit", normin, n, &ap[1], &
work[1], &scaleu, &work[(*n << 1) + 1], info);
}
/* Multiply by 1/SCALE if doing so will not cause overflow. */
scale = scalel * scaleu;
if (scale != 1.) {
ix = idamax_(n, &work[1], &c__1);
if (scale < (d__1 = work[ix], abs(d__1)) * smlnum || scale == 0.)
{
goto L20;
}
drscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.) {
*rcond = 1. / ainvnm / *anorm;
}
L20:
return 0;
/* End of DPPCON */
} /* dppcon_ */
/*! \brief
*
* <pre>
* Purpose
* =======
*
* DGSRFS improves the computed solution to a system of linear
* equations and provides error bounds and backward error estimates for
* the solution.
*
* If equilibration was performed, the system becomes:
* (diag(R)*A_original*diag(C)) * X = diag(R)*B_original.
*
* See supermatrix.h for the definition of 'SuperMatrix' structure.
*
* Arguments
* =========
*
* trans (input) trans_t
* Specifies the form of the system of equations:
* = NOTRANS: A * X = B (No transpose)
* = TRANS: A'* X = B (Transpose)
* = CONJ: A**H * X = B (Conjugate transpose)
*
* A (input) SuperMatrix*
* The original matrix A in the system, or the scaled A if
* equilibration was done. The type of A can be:
* Stype = SLU_NC, Dtype = SLU_D, Mtype = SLU_GE.
*
* L (input) SuperMatrix*
* The factor L from the factorization Pr*A*Pc=L*U. Use
* compressed row subscripts storage for supernodes,
* i.e., L has types: Stype = SLU_SC, Dtype = SLU_D, Mtype = SLU_TRLU.
*
* U (input) SuperMatrix*
* The factor U from the factorization Pr*A*Pc=L*U as computed by
* dgstrf(). Use column-wise storage scheme,
* i.e., U has types: Stype = SLU_NC, Dtype = SLU_D, Mtype = SLU_TRU.
*
* perm_c (input) int*, dimension (A->ncol)
* Column permutation vector, which defines the
* permutation matrix Pc; perm_c[i] = j means column i of A is
* in position j in A*Pc.
*
* perm_r (input) int*, dimension (A->nrow)
* Row permutation vector, which defines the permutation matrix Pr;
* perm_r[i] = j means row i of A is in position j in Pr*A.
*
* equed (input) Specifies the form of equilibration that was done.
* = 'N': No equilibration.
* = 'R': Row equilibration, i.e., A was premultiplied by diag(R).
* = 'C': Column equilibration, i.e., A was postmultiplied by
* diag(C).
* = 'B': Both row and column equilibration, i.e., A was replaced
* by diag(R)*A*diag(C).
*
* R (input) double*, dimension (A->nrow)
* The row scale factors for A.
* If equed = 'R' or 'B', A is premultiplied by diag(R).
* If equed = 'N' or 'C', R is not accessed.
*
* C (input) double*, dimension (A->ncol)
* The column scale factors for A.
* If equed = 'C' or 'B', A is postmultiplied by diag(C).
* If equed = 'N' or 'R', C is not accessed.
*
* B (input) SuperMatrix*
* B has types: Stype = SLU_DN, Dtype = SLU_D, Mtype = SLU_GE.
* The right hand side matrix B.
* if equed = 'R' or 'B', B is premultiplied by diag(R).
*
* X (input/output) SuperMatrix*
* X has types: Stype = SLU_DN, Dtype = SLU_D, Mtype = SLU_GE.
* On entry, the solution matrix X, as computed by dgstrs().
* On exit, the improved solution matrix X.
* if *equed = 'C' or 'B', X should be premultiplied by diag(C)
* in order to obtain the solution to the original system.
*
* FERR (output) double*, dimension (B->ncol)
* 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*, dimension (B->ncol)
* 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).
*
* stat (output) SuperLUStat_t*
* Record the statistics on runtime and floating-point operation count.
* See util.h for the definition of 'SuperLUStat_t'.
*
* info (output) int*
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Internal Parameters
* ===================
*
* ITMAX is the maximum number of steps of iterative refinement.
*
* </pre>
*/
void
dgsrfs(trans_t trans, SuperMatrix *A, SuperMatrix *L, SuperMatrix *U,
int *perm_c, int *perm_r, char *equed, double *R, double *C,
SuperMatrix *B, SuperMatrix *X, double *ferr, double *berr,
SuperLUStat_t *stat, int *info)
{
#define ITMAX 5
/* Table of constant values */
int ione = 1;
double ndone = -1.;
double done = 1.;
/* Local variables */
NCformat *Astore;
double *Aval;
SuperMatrix Bjcol;
DNformat *Bstore, *Xstore, *Bjcol_store;
double *Bmat, *Xmat, *Bptr, *Xptr;
int kase;
double safe1, safe2;
int i, j, k, irow, nz, count, notran, rowequ, colequ;
int ldb, ldx, nrhs;
double s, xk, lstres, eps, safmin;
char transc[1];
trans_t transt;
double *work;
double *rwork;
int *iwork;
extern double dlamch_(char *);
extern int dlacon_(int *, double *, double *, int *, double *, int *);
#ifdef _CRAY
extern int SCOPY(int *, double *, int *, double *, int *);
extern int SSAXPY(int *, double *, double *, int *, double *, int *);
#else
extern int dcopy_(int *, double *, int *, double *, int *);
extern int daxpy_(int *, double *, double *, int *, double *, int *);
#endif
Astore = A->Store;
Aval = Astore->nzval;
Bstore = B->Store;
Xstore = X->Store;
Bmat = Bstore->nzval;
Xmat = Xstore->nzval;
ldb = Bstore->lda;
ldx = Xstore->lda;
nrhs = B->ncol;
/* Test the input parameters */
*info = 0;
notran = (trans == NOTRANS);
if ( !notran && trans != TRANS && trans != CONJ ) *info = -1;
else if ( A->nrow != A->ncol || A->nrow < 0 ||
A->Stype != SLU_NC || A->Dtype != SLU_D || A->Mtype != SLU_GE )
*info = -2;
else if ( L->nrow != L->ncol || L->nrow < 0 ||
L->Stype != SLU_SC || L->Dtype != SLU_D || L->Mtype != SLU_TRLU )
*info = -3;
else if ( U->nrow != U->ncol || U->nrow < 0 ||
U->Stype != SLU_NC || U->Dtype != SLU_D || U->Mtype != SLU_TRU )
*info = -4;
else if ( ldb < SUPERLU_MAX(0, A->nrow) ||
B->Stype != SLU_DN || B->Dtype != SLU_D || B->Mtype != SLU_GE )
*info = -10;
else if ( ldx < SUPERLU_MAX(0, A->nrow) ||
X->Stype != SLU_DN || X->Dtype != SLU_D || X->Mtype != SLU_GE )
*info = -11;
if (*info != 0) {
i = -(*info);
xerbla_("dgsrfs", &i);
return;
}
/* Quick return if possible */
if ( A->nrow == 0 || nrhs == 0) {
for (j = 0; j < nrhs; ++j) {
ferr[j] = 0.;
berr[j] = 0.;
}
return;
}
rowequ = lsame_(equed, "R") || lsame_(equed, "B");
colequ = lsame_(equed, "C") || lsame_(equed, "B");
/* Allocate working space */
work = doubleMalloc(2*A->nrow);
rwork = (double *) SUPERLU_MALLOC( A->nrow * sizeof(double) );
iwork = intMalloc(2*A->nrow);
if ( !work || !rwork || !iwork )
ABORT("Malloc fails for work/rwork/iwork.");
if ( notran ) {
*(unsigned char *)transc = 'N';
transt = TRANS;
} else {
*(unsigned char *)transc = 'T';
transt = NOTRANS;
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = A->ncol + 1;
eps = dlamch_("Epsilon");
safmin = dlamch_("Safe minimum");
/* Set SAFE1 essentially to be the underflow threshold times the
number of additions in each row. */
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Compute the number of nonzeros in each row (or column) of A */
for (i = 0; i < A->nrow; ++i) iwork[i] = 0;
if ( notran ) {
for (k = 0; k < A->ncol; ++k)
for (i = Astore->colptr[k]; i < Astore->colptr[k+1]; ++i)
++iwork[Astore->rowind[i]];
} else {
for (k = 0; k < A->ncol; ++k)
iwork[k] = Astore->colptr[k+1] - Astore->colptr[k];
}
/* Copy one column of RHS B into Bjcol. */
Bjcol.Stype = B->Stype;
Bjcol.Dtype = B->Dtype;
Bjcol.Mtype = B->Mtype;
Bjcol.nrow = B->nrow;
Bjcol.ncol = 1;
Bjcol.Store = (void *) SUPERLU_MALLOC( sizeof(DNformat) );
if ( !Bjcol.Store ) ABORT("SUPERLU_MALLOC fails for Bjcol.Store");
Bjcol_store = Bjcol.Store;
Bjcol_store->lda = ldb;
Bjcol_store->nzval = work; /* address aliasing */
/* Do for each right hand side ... */
for (j = 0; j < nrhs; ++j) {
count = 0;
lstres = 3.;
Bptr = &Bmat[j*ldb];
Xptr = &Xmat[j*ldx];
while (1) { /* Loop until stopping criterion is satisfied. */
/* Compute residual R = B - op(A) * X,
where op(A) = A, A**T, or A**H, depending on TRANS. */
#ifdef _CRAY
SCOPY(&A->nrow, Bptr, &ione, work, &ione);
#else
dcopy_(&A->nrow, Bptr, &ione, work, &ione);
#endif
sp_dgemv(transc, ndone, A, Xptr, ione, done, work, ione);
/* Compute componentwise relative backward error from formula
max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
where abs(Z) is the componentwise absolute value of the matrix
or vector Z. If the i-th component of the denominator is less
than SAFE2, then SAFE1 is added to the i-th component of the
numerator before dividing. */
for (i = 0; i < A->nrow; ++i) rwork[i] = fabs( Bptr[i] );
/* Compute abs(op(A))*abs(X) + abs(B). */
if (notran) {
for (k = 0; k < A->ncol; ++k) {
xk = fabs( Xptr[k] );
for (i = Astore->colptr[k]; i < Astore->colptr[k+1]; ++i)
rwork[Astore->rowind[i]] += fabs(Aval[i]) * xk;
}
} else {
for (k = 0; k < A->ncol; ++k) {
s = 0.;
for (i = Astore->colptr[k]; i < Astore->colptr[k+1]; ++i) {
irow = Astore->rowind[i];
s += fabs(Aval[i]) * fabs(Xptr[irow]);
}
rwork[k] += s;
}
}
s = 0.;
for (i = 0; i < A->nrow; ++i) {
if (rwork[i] > safe2) {
s = SUPERLU_MAX( s, fabs(work[i]) / rwork[i] );
} else if ( rwork[i] != 0.0 ) {
/* Adding SAFE1 to the numerator guards against
spuriously zero residuals (underflow). */
s = SUPERLU_MAX( s, (safe1 + fabs(work[i])) / rwork[i] );
}
/* If rwork[i] is exactly 0.0, then we know the true
residual also must be exactly 0.0. */
}
berr[j] = s;
/* Test stopping criterion. Continue iterating if
1) The residual BERR(J) is larger than machine epsilon, and
2) BERR(J) decreased by at least a factor of 2 during the
last iteration, and
3) At most ITMAX iterations tried. */
if (berr[j] > eps && berr[j] * 2. <= lstres && count < ITMAX) {
/* Update solution and try again. */
dgstrs (trans, L, U, perm_c, perm_r, &Bjcol, stat, info);
#ifdef _CRAY
SAXPY(&A->nrow, &done, work, &ione,
&Xmat[j*ldx], &ione);
#else
daxpy_(&A->nrow, &done, work, &ione,
&Xmat[j*ldx], &ione);
#endif
lstres = berr[j];
++count;
} else {
break;
}
} /* end while */
stat->RefineSteps = count;
/* Bound error from formula:
norm(X - XTRUE) / norm(X) .le. FERR = norm( abs(inv(op(A)))*
( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
where
norm(Z) is the magnitude of the largest component of Z
inv(op(A)) is the inverse of op(A)
abs(Z) is the componentwise absolute value of the matrix or
vector Z
NZ is the maximum number of nonzeros in any row of A, plus 1
EPS is machine epsilon
The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
is incremented by SAFE1 if the i-th component of
abs(op(A))*abs(X) + abs(B) is less than SAFE2.
Use DLACON to estimate the infinity-norm of the matrix
inv(op(A)) * diag(W),
where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
for (i = 0; i < A->nrow; ++i) rwork[i] = fabs( Bptr[i] );
/* Compute abs(op(A))*abs(X) + abs(B). */
if ( notran ) {
for (k = 0; k < A->ncol; ++k) {
xk = fabs( Xptr[k] );
for (i = Astore->colptr[k]; i < Astore->colptr[k+1]; ++i)
rwork[Astore->rowind[i]] += fabs(Aval[i]) * xk;
}
} else {
for (k = 0; k < A->ncol; ++k) {
s = 0.;
for (i = Astore->colptr[k]; i < Astore->colptr[k+1]; ++i) {
irow = Astore->rowind[i];
xk = fabs( Xptr[irow] );
s += fabs(Aval[i]) * xk;
}
rwork[k] += s;
}
}
for (i = 0; i < A->nrow; ++i)
if (rwork[i] > safe2)
rwork[i] = fabs(work[i]) + (iwork[i]+1)*eps*rwork[i];
else
rwork[i] = fabs(work[i])+(iwork[i]+1)*eps*rwork[i]+safe1;
kase = 0;
do {
dlacon_(&A->nrow, &work[A->nrow], work,
&iwork[A->nrow], &ferr[j], &kase);
if (kase == 0) break;
if (kase == 1) {
/* Multiply by diag(W)*inv(op(A)**T)*(diag(C) or diag(R)). */
if ( notran && colequ )
for (i = 0; i < A->ncol; ++i) work[i] *= C[i];
else if ( !notran && rowequ )
for (i = 0; i < A->nrow; ++i) work[i] *= R[i];
dgstrs (transt, L, U, perm_c, perm_r, &Bjcol, stat, info);
for (i = 0; i < A->nrow; ++i) work[i] *= rwork[i];
} else {
/* Multiply by (diag(C) or diag(R))*inv(op(A))*diag(W). */
for (i = 0; i < A->nrow; ++i) work[i] *= rwork[i];
dgstrs (trans, L, U, perm_c, perm_r, &Bjcol, stat, info);
if ( notran && colequ )
for (i = 0; i < A->ncol; ++i) work[i] *= C[i];
else if ( !notran && rowequ )
for (i = 0; i < A->ncol; ++i) work[i] *= R[i];
}
} while ( kase != 0 );
/* Normalize error. */
lstres = 0.;
if ( notran && colequ ) {
for (i = 0; i < A->nrow; ++i)
lstres = SUPERLU_MAX( lstres, C[i] * fabs( Xptr[i]) );
} else if ( !notran && rowequ ) {
for (i = 0; i < A->nrow; ++i)
lstres = SUPERLU_MAX( lstres, R[i] * fabs( Xptr[i]) );
} else {
for (i = 0; i < A->nrow; ++i)
lstres = SUPERLU_MAX( lstres, fabs( Xptr[i]) );
}
if ( lstres != 0. )
ferr[j] /= lstres;
} /* for each RHS j ... */
SUPERLU_FREE(work);
SUPERLU_FREE(rwork);
SUPERLU_FREE(iwork);
SUPERLU_FREE(Bjcol.Store);
return;
} /* dgsrfs */
/*< >*/
/* Subroutine */ int dtgsen_(integer *ijob, logical *wantq, logical *wantz,
logical *select, integer *n, doublereal *a, integer *lda, doublereal *
b, integer *ldb, doublereal *alphar, doublereal *alphai, doublereal *
beta, doublereal *q, integer *ldq, doublereal *z__, integer *ldz,
integer *m, doublereal *pl, doublereal *pr, doublereal *dif,
doublereal *work, integer *lwork, integer *iwork, integer *liwork,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
z_offset, i__1, i__2;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
integer i__, k, n1, n2, kk, ks, mn2, ijb;
doublereal eps;
integer kase;
logical pair;
integer ierr;
doublereal dsum;
logical swap;
extern /* Subroutine */ int dlag2_(doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *);
logical wantd;
integer lwmin;
logical wantp, wantd1, wantd2;
extern doublereal dlamch_(char *, ftnlen);
doublereal dscale;
extern /* Subroutine */ int dlacon_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
doublereal rdscal;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, ftnlen),
xerbla_(char *, integer *, ftnlen), dtgexc_(logical *, logical *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *, doublereal *, integer *, integer *), dlassq_(integer *,
doublereal *, integer *, doublereal *, doublereal *);
integer liwmin;
extern /* Subroutine */ int dtgsyl_(char *, integer *, integer *, integer
*, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, integer *, integer *, ftnlen);
doublereal smlnum;
logical lquery;
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* June 30, 1999 */
/* .. Scalar Arguments .. */
/*< LOGICAL WANTQ, WANTZ >*/
/*< >*/
/*< DOUBLE PRECISION PL, PR >*/
/* .. */
/* .. Array Arguments .. */
/*< LOGICAL SELECT( * ) >*/
/*< INTEGER IWORK( * ) >*/
/*< >*/
/* .. */
/* Purpose */
/* ======= */
/* DTGSEN reorders the generalized real Schur decomposition of a real */
/* matrix pair (A, B) (in terms of an orthonormal equivalence trans- */
/* formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues */
/* appears in the leading diagonal blocks of the upper quasi-triangular */
/* matrix A and the upper triangular B. The leading columns of Q and */
/* Z form orthonormal bases of the corresponding left and right eigen- */
/* spaces (deflating subspaces). (A, B) must be in generalized real */
/* Schur canonical form (as returned by DGGES), i.e. A is block upper */
/* triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper */
/* triangular. */
/* DTGSEN also computes the generalized eigenvalues */
/* w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j) */
/* of the reordered matrix pair (A, B). */
/* Optionally, DTGSEN computes the estimates of reciprocal condition */
/* numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11), */
/* (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s) */
/* between the matrix pairs (A11, B11) and (A22,B22) that correspond to */
/* the selected cluster and the eigenvalues outside the cluster, resp., */
/* and norms of "projections" onto left and right eigenspaces w.r.t. */
/* the selected cluster in the (1,1)-block. */
/* Arguments */
/* ========= */
/* IJOB (input) INTEGER */
/* Specifies whether condition numbers are required for the */
/* cluster of eigenvalues (PL and PR) or the deflating subspaces */
/* (Difu and Difl): */
/* =0: Only reorder w.r.t. SELECT. No extras. */
/* =1: Reciprocal of norms of "projections" onto left and right */
/* eigenspaces w.r.t. the selected cluster (PL and PR). */
/* =2: Upper bounds on Difu and Difl. F-norm-based estimate */
/* (DIF(1:2)). */
/* =3: Estimate of Difu and Difl. 1-norm-based estimate */
/* (DIF(1:2)). */
/* About 5 times as expensive as IJOB = 2. */
/* =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic */
/* version to get it all. */
/* =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above) */
/* WANTQ (input) LOGICAL */
/* .TRUE. : update the left transformation matrix Q; */
/* .FALSE.: do not update Q. */
/* WANTZ (input) LOGICAL */
/* .TRUE. : update the right transformation matrix Z; */
/* .FALSE.: do not update Z. */
/* SELECT (input) LOGICAL array, dimension (N) */
/* SELECT specifies the eigenvalues in the selected cluster. */
/* To select a real eigenvalue w(j), SELECT(j) must be set to */
/* .TRUE.. To select a complex conjugate pair of eigenvalues */
/* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, */
/* either SELECT(j) or SELECT(j+1) or both must be set to */
/* .TRUE.; a complex conjugate pair of eigenvalues must be */
/* either both included in the cluster or both excluded. */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension(LDA,N) */
/* On entry, the upper quasi-triangular matrix A, with (A, B) in */
/* generalized real Schur canonical form. */
/* On exit, A is overwritten by the reordered matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input/output) DOUBLE PRECISION array, dimension(LDB,N) */
/* On entry, the upper triangular matrix B, with (A, B) in */
/* generalized real Schur canonical form. */
/* On exit, B is overwritten by the reordered matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array 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. ALPHAR(j) + ALPHAI(j)*i */
/* and BETA(j),j=1,...,N are the diagonals of the complex Schur */
/* form (S,T) that would result if the 2-by-2 diagonal blocks of */
/* the real generalized Schur form of (A,B) were further reduced */
/* to triangular form using complex unitary transformations. */
/* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if */
/* positive, then the j-th and (j+1)-st eigenvalues are a */
/* complex conjugate pair, with ALPHAI(j+1) negative. */
/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */
/* On entry, if WANTQ = .TRUE., Q is an N-by-N matrix. */
/* On exit, Q has been postmultiplied by the left orthogonal */
/* transformation matrix which reorder (A, B); The leading M */
/* columns of Q form orthonormal bases for the specified pair of */
/* left eigenspaces (deflating subspaces). */
/* If WANTQ = .FALSE., Q is not referenced. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= 1; */
/* and if WANTQ = .TRUE., LDQ >= N. */
/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */
/* On entry, if WANTZ = .TRUE., Z is an N-by-N matrix. */
/* On exit, Z has been postmultiplied by the left orthogonal */
/* transformation matrix which reorder (A, B); The leading M */
/* columns of Z form orthonormal bases for the specified pair of */
/* left eigenspaces (deflating subspaces). */
/* If WANTZ = .FALSE., Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1; */
/* If WANTZ = .TRUE., LDZ >= N. */
/* M (output) INTEGER */
/* The dimension of the specified pair of left and right eigen- */
/* spaces (deflating subspaces). 0 <= M <= N. */
/* PL, PR (output) DOUBLE PRECISION */
/* If IJOB = 1, 4 or 5, PL, PR are lower bounds on the */
/* reciprocal of the norm of "projections" onto left and right */
/* eigenspaces with respect to the selected cluster. */
/* 0 < PL, PR <= 1. */
/* If M = 0 or M = N, PL = PR = 1. */
/* If IJOB = 0, 2 or 3, PL and PR are not referenced. */
/* DIF (output) DOUBLE PRECISION array, dimension (2). */
/* If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl. */
/* If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on */
/* Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based */
/* estimates of Difu and Difl. */
/* If M = 0 or N, DIF(1:2) = F-norm([A, B]). */
/* If IJOB = 0 or 1, DIF is not referenced. */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) */
/* IF IJOB = 0, WORK is not referenced. Otherwise, */
/* on exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= 4*N+16. */
/* If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)). */
/* If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)). */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* IWORK (workspace/output) INTEGER array, dimension (LIWORK) */
/* IF IJOB = 0, IWORK is not referenced. Otherwise, */
/* on exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
/* LIWORK (input) INTEGER */
/* The dimension of the array IWORK. LIWORK >= 1. */
/* If IJOB = 1, 2 or 4, LIWORK >= N+6. */
/* If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6). */
/* If LIWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the optimal size of the IWORK array, */
/* returns this value as the first entry of the IWORK array, and */
/* no error message related to LIWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* =0: Successful exit. */
/* <0: If INFO = -i, the i-th argument had an illegal value. */
/* =1: Reordering of (A, B) failed because the transformed */
/* matrix pair (A, B) would be too far from generalized */
/* Schur form; the problem is very ill-conditioned. */
/* (A, B) may have been partially reordered. */
/* If requested, 0 is returned in DIF(*), PL and PR. */
/* Further Details */
/* =============== */
/* DTGSEN first collects the selected eigenvalues by computing */
/* orthogonal U and W that move them to the top left corner of (A, B). */
/* In other words, the selected eigenvalues are the eigenvalues of */
/* (A11, B11) in: */
/* U'*(A, B)*W = (A11 A12) (B11 B12) n1 */
/* ( 0 A22),( 0 B22) n2 */
/* n1 n2 n1 n2 */
/* where N = n1+n2 and U' means the transpose of U. The first n1 columns */
/* of U and W span the specified pair of left and right eigenspaces */
/* (deflating subspaces) of (A, B). */
/* If (A, B) has been obtained from the generalized real Schur */
/* decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the */
/* reordered generalized real Schur form of (C, D) is given by */
/* (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)', */
/* and the first n1 columns of Q*U and Z*W span the corresponding */
/* deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.). */
/* Note that if the selected eigenvalue is sufficiently ill-conditioned, */
/* then its value may differ significantly from its value before */
/* reordering. */
/* The reciprocal condition numbers of the left and right eigenspaces */
/* spanned by the first n1 columns of U and W (or Q*U and Z*W) may */
/* be returned in DIF(1:2), corresponding to Difu and Difl, resp. */
/* The Difu and Difl are defined as: */
/* Difu[(A11, B11), (A22, B22)] = sigma-min( Zu ) */
/* and */
/* Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)], */
/* where sigma-min(Zu) is the smallest singular value of the */
/* (2*n1*n2)-by-(2*n1*n2) matrix */
/* Zu = [ kron(In2, A11) -kron(A22', In1) ] */
/* [ kron(In2, B11) -kron(B22', In1) ]. */
/* Here, Inx is the identity matrix of size nx and A22' is the */
/* transpose of A22. kron(X, Y) is the Kronecker product between */
/* the matrices X and Y. */
/* When DIF(2) is small, small changes in (A, B) can cause large changes */
/* in the deflating subspace. An approximate (asymptotic) bound on the */
/* maximum angular error in the computed deflating subspaces is */
/* EPS * norm((A, B)) / DIF(2), */
/* where EPS is the machine precision. */
/* The reciprocal norm of the projectors on the left and right */
/* eigenspaces associated with (A11, B11) may be returned in PL and PR. */
/* They are computed as follows. First we compute L and R so that */
/* P*(A, B)*Q is block diagonal, where */
/* P = ( I -L ) n1 Q = ( I R ) n1 */
/* ( 0 I ) n2 and ( 0 I ) n2 */
/* n1 n2 n1 n2 */
/* and (L, R) is the solution to the generalized Sylvester equation */
/* A11*R - L*A22 = -A12 */
/* B11*R - L*B22 = -B12 */
/* Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2). */
/* An approximate (asymptotic) bound on the average absolute error of */
/* the selected eigenvalues is */
/* EPS * norm((A, B)) / PL. */
/* There are also global error bounds which valid for perturbations up */
/* to a certain restriction: A lower bound (x) on the smallest */
/* F-norm(E,F) for which an eigenvalue of (A11, B11) may move and */
/* coalesce with an eigenvalue of (A22, B22) under perturbation (E,F), */
/* (i.e. (A + E, B + F), is */
/* x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)). */
/* An approximate bound on x can be computed from DIF(1:2), PL and PR. */
/* If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed */
/* (L', R') and unperturbed (L, R) left and right deflating subspaces */
/* associated with the selected cluster in the (1,1)-blocks can be */
/* bounded as */
/* max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2)) */
/* max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2)) */
/* See LAPACK User's Guide section 4.11 or the following references */
/* for more information. */
/* Note that if the default method for computing the Frobenius-norm- */
/* based estimate DIF is not wanted (see DLATDF), then the parameter */
/* IDIFJB (see below) should be changed from 3 to 4 (routine DLATDF */
/* (IJOB = 2 will be used)). See DTGSYL for more details. */
/* Based on contributions by */
/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
/* Umea University, S-901 87 Umea, Sweden. */
/* References */
/* ========== */
/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */
/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */
/* Estimation: Theory, Algorithms and Software, */
/* Report UMINF - 94.04, Department of Computing Science, Umea */
/* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working */
/* Note 87. To appear in Numerical Algorithms, 1996. */
/* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */
/* for Solving the Generalized Sylvester Equation and Estimating the */
/* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */
/* Department of Computing Science, Umea University, S-901 87 Umea, */
/* Sweden, December 1993, Revised April 1994, Also as LAPACK Working */
/* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, */
/* 1996. */
/* ===================================================================== */
/* .. Parameters .. */
/*< INTEGER IDIFJB >*/
/*< PARAMETER ( IDIFJB = 3 ) >*/
/*< DOUBLE PRECISION ZERO, ONE >*/
/*< PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) >*/
/* .. */
/* .. Local Scalars .. */
/*< >*/
/*< >*/
/*< DOUBLE PRECISION DSCALE, DSUM, EPS, RDSCAL, SMLNUM >*/
/* .. */
/* .. External Subroutines .. */
/*< >*/
/* .. */
/* .. External Functions .. */
/*< DOUBLE PRECISION DLAMCH >*/
/*< EXTERNAL DLAMCH >*/
/* .. */
/* .. Intrinsic Functions .. */
/*< INTRINSIC MAX, SIGN, SQRT >*/
/* .. */
/* .. Executable Statements .. */
/* Decode and test the input parameters */
/*< INFO = 0 >*/
/* Parameter adjustments */
--select;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--alphar;
--alphai;
--beta;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--dif;
--work;
--iwork;
/* Function Body */
*info = 0;
/*< LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) >*/
lquery = *lwork == -1 || *liwork == -1;
/*< IF( IJOB.LT.0 .OR. IJOB.GT.5 ) THEN >*/
if (*ijob < 0 || *ijob > 5) {
/*< INFO = -1 >*/
*info = -1;
/*< ELSE IF( N.LT.0 ) THEN >*/
} else if (*n < 0) {
/*< INFO = -5 >*/
*info = -5;
/*< ELSE IF( LDA.LT.MAX( 1, N ) ) THEN >*/
} else if (*lda < max(1,*n)) {
/*< INFO = -7 >*/
*info = -7;
/*< ELSE IF( LDB.LT.MAX( 1, N ) ) THEN >*/
} else if (*ldb < max(1,*n)) {
/*< INFO = -9 >*/
*info = -9;
/*< ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN >*/
} else if (*ldq < 1 || (*wantq && *ldq < *n)) {
/*< INFO = -14 >*/
*info = -14;
/*< ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN >*/
} else if (*ldz < 1 || (*wantz && *ldz < *n)) {
/*< INFO = -16 >*/
*info = -16;
/*< END IF >*/
}
/*< IF( INFO.NE.0 ) THEN >*/
if (*info != 0) {
/*< CALL XERBLA( 'DTGSEN', -INFO ) >*/
i__1 = -(*info);
xerbla_("DTGSEN", &i__1, (ftnlen)6);
/*< RETURN >*/
return 0;
/*< END IF >*/
}
/* Get machine constants */
/*< EPS = DLAMCH( 'P' ) >*/
eps = dlamch_("P", (ftnlen)1);
/*< SMLNUM = DLAMCH( 'S' ) / EPS >*/
smlnum = dlamch_("S", (ftnlen)1) / eps;
/*< IERR = 0 >*/
ierr = 0;
/*< WANTP = IJOB.EQ.1 .OR. IJOB.GE.4 >*/
wantp = *ijob == 1 || *ijob >= 4;
/*< WANTD1 = IJOB.EQ.2 .OR. IJOB.EQ.4 >*/
wantd1 = *ijob == 2 || *ijob == 4;
/*< WANTD2 = IJOB.EQ.3 .OR. IJOB.EQ.5 >*/
wantd2 = *ijob == 3 || *ijob == 5;
/*< WANTD = WANTD1 .OR. WANTD2 >*/
wantd = wantd1 || wantd2;
/* Set M to the dimension of the specified pair of deflating */
/* subspaces. */
/*< M = 0 >*/
*m = 0;
/*< PAIR = .FALSE. >*/
pair = FALSE_;
/*< DO 10 K = 1, N >*/
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/*< IF( PAIR ) THEN >*/
if (pair) {
/*< PAIR = .FALSE. >*/
pair = FALSE_;
/*< ELSE >*/
} else {
/*< IF( K.LT.N ) THEN >*/
if (k < *n) {
/*< IF( A( K+1, K ).EQ.ZERO ) THEN >*/
if (a[k + 1 + k * a_dim1] == 0.) {
/*< >*/
if (select[k]) {
++(*m);
}
/*< ELSE >*/
} else {
/*< PAIR = .TRUE. >*/
pair = TRUE_;
/*< >*/
if (select[k] || select[k + 1]) {
*m += 2;
}
/*< END IF >*/
}
/*< ELSE >*/
} else {
/*< >*/
if (select[*n]) {
++(*m);
}
/*< END IF >*/
}
/*< END IF >*/
}
/*< 10 CONTINUE >*/
/* L10: */
}
/*< IF( IJOB.EQ.1 .OR. IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN >*/
if (*ijob == 1 || *ijob == 2 || *ijob == 4) {
/*< LWMIN = MAX( 1, 4*N+16, 2*M*( N-M ) ) >*/
/* Computing MAX */
i__1 = 1, i__2 = (*n << 2) + 16, i__1 = max(i__1,i__2), i__2 = (*m <<
1) * (*n - *m);
lwmin = max(i__1,i__2);
/*< LIWMIN = MAX( 1, N+6 ) >*/
/* Computing MAX */
i__1 = 1, i__2 = *n + 6;
liwmin = max(i__1,i__2);
/*< ELSE IF( IJOB.EQ.3 .OR. IJOB.EQ.5 ) THEN >*/
} else if (*ijob == 3 || *ijob == 5) {
/*< LWMIN = MAX( 1, 4*N+16, 4*M*( N-M ) ) >*/
/* Computing MAX */
i__1 = 1, i__2 = (*n << 2) + 16, i__1 = max(i__1,i__2), i__2 = (*m <<
2) * (*n - *m);
lwmin = max(i__1,i__2);
/*< LIWMIN = MAX( 1, 2*M*( N-M ), N+6 ) >*/
/* Computing MAX */
i__1 = 1, i__2 = (*m << 1) * (*n - *m), i__1 = max(i__1,i__2), i__2 =
*n + 6;
liwmin = max(i__1,i__2);
/*< ELSE >*/
} else {
/*< LWMIN = MAX( 1, 4*N+16 ) >*/
/* Computing MAX */
i__1 = 1, i__2 = (*n << 2) + 16;
lwmin = max(i__1,i__2);
/*< LIWMIN = 1 >*/
liwmin = 1;
/*< END IF >*/
}
/*< WORK( 1 ) = LWMIN >*/
work[1] = (doublereal) lwmin;
/*< IWORK( 1 ) = LIWMIN >*/
iwork[1] = liwmin;
/*< IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN >*/
if (*lwork < lwmin && ! lquery) {
/*< INFO = -22 >*/
*info = -22;
/*< ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN >*/
} else if (*liwork < liwmin && ! lquery) {
/*< INFO = -24 >*/
*info = -24;
/*< END IF >*/
}
/*< IF( INFO.NE.0 ) THEN >*/
if (*info != 0) {
/*< CALL XERBLA( 'DTGSEN', -INFO ) >*/
i__1 = -(*info);
xerbla_("DTGSEN", &i__1, (ftnlen)6);
/*< RETURN >*/
return 0;
/*< ELSE IF( LQUERY ) THEN >*/
} else if (lquery) {
/*< RETURN >*/
return 0;
/*< END IF >*/
}
/* Quick return if possible. */
/*< IF( M.EQ.N .OR. M.EQ.0 ) THEN >*/
if (*m == *n || *m == 0) {
/*< IF( WANTP ) THEN >*/
if (wantp) {
/*< PL = ONE >*/
*pl = 1.;
/*< PR = ONE >*/
*pr = 1.;
/*< END IF >*/
}
/*< IF( WANTD ) THEN >*/
if (wantd) {
/*< DSCALE = ZERO >*/
dscale = 0.;
/*< DSUM = ONE >*/
dsum = 1.;
/*< DO 20 I = 1, N >*/
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< CALL DLASSQ( N, A( 1, I ), 1, DSCALE, DSUM ) >*/
dlassq_(n, &a[i__ * a_dim1 + 1], &c__1, &dscale, &dsum);
/*< CALL DLASSQ( N, B( 1, I ), 1, DSCALE, DSUM ) >*/
dlassq_(n, &b[i__ * b_dim1 + 1], &c__1, &dscale, &dsum);
/*< 20 CONTINUE >*/
/* L20: */
}
/*< DIF( 1 ) = DSCALE*SQRT( DSUM ) >*/
dif[1] = dscale * sqrt(dsum);
/*< DIF( 2 ) = DIF( 1 ) >*/
dif[2] = dif[1];
/*< END IF >*/
}
/*< GO TO 60 >*/
goto L60;
/*< END IF >*/
}
/* Collect the selected blocks at the top-left corner of (A, B). */
/*< KS = 0 >*/
ks = 0;
/*< PAIR = .FALSE. >*/
pair = FALSE_;
/*< DO 30 K = 1, N >*/
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/*< IF( PAIR ) THEN >*/
if (pair) {
/*< PAIR = .FALSE. >*/
pair = FALSE_;
/*< ELSE >*/
} else {
/*< SWAP = SELECT( K ) >*/
swap = select[k];
/*< IF( K.LT.N ) THEN >*/
if (k < *n) {
/*< IF( A( K+1, K ).NE.ZERO ) THEN >*/
if (a[k + 1 + k * a_dim1] != 0.) {
/*< PAIR = .TRUE. >*/
pair = TRUE_;
/*< SWAP = SWAP .OR. SELECT( K+1 ) >*/
swap = swap || select[k + 1];
/*< END IF >*/
}
/*< END IF >*/
}
/*< IF( SWAP ) THEN >*/
if (swap) {
/*< KS = KS + 1 >*/
++ks;
/* Swap the K-th block to position KS. */
/* Perform the reordering of diagonal blocks in (A, B) */
/* by orthogonal transformation matrices and update */
/* Q and Z accordingly (if requested): */
/*< KK = K >*/
kk = k;
/*< >*/
if (k != ks) {
dtgexc_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset],
ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &kk,
&ks, &work[1], lwork, &ierr);
}
/*< IF( IERR.GT.0 ) THEN >*/
if (ierr > 0) {
/* Swap is rejected: exit. */
/*< INFO = 1 >*/
*info = 1;
/*< IF( WANTP ) THEN >*/
if (wantp) {
/*< PL = ZERO >*/
*pl = 0.;
/*< PR = ZERO >*/
*pr = 0.;
/*< END IF >*/
}
/*< IF( WANTD ) THEN >*/
if (wantd) {
/*< DIF( 1 ) = ZERO >*/
dif[1] = 0.;
/*< DIF( 2 ) = ZERO >*/
dif[2] = 0.;
/*< END IF >*/
}
/*< GO TO 60 >*/
goto L60;
/*< END IF >*/
}
/*< >*/
if (pair) {
++ks;
}
/*< END IF >*/
}
/*< END IF >*/
}
/*< 30 CONTINUE >*/
/* L30: */
}
/*< IF( WANTP ) THEN >*/
if (wantp) {
/* Solve generalized Sylvester equation for R and L */
/* and compute PL and PR. */
/*< N1 = M >*/
n1 = *m;
/*< N2 = N - M >*/
n2 = *n - *m;
/*< I = N1 + 1 >*/
i__ = n1 + 1;
/*< IJB = 0 >*/
ijb = 0;
/*< CALL DLACPY( 'Full', N1, N2, A( 1, I ), LDA, WORK, N1 ) >*/
dlacpy_("Full", &n1, &n2, &a[i__ * a_dim1 + 1], lda, &work[1], &n1, (
ftnlen)4);
/*< >*/
dlacpy_("Full", &n1, &n2, &b[i__ * b_dim1 + 1], ldb, &work[n1 * n2 +
1], &n1, (ftnlen)4);
/*< >*/
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + i__ * a_dim1]
, lda, &work[1], &n1, &b[b_offset], ldb, &b[i__ + i__ *
b_dim1], ldb, &work[n1 * n2 + 1], &n1, &dscale, &dif[1], &
work[(n1 * n2 << 1) + 1], &i__1, &iwork[1], &ierr, (ftnlen)1);
/* Estimate the reciprocal of norms of "projections" onto left */
/* and right eigenspaces. */
/*< RDSCAL = ZERO >*/
rdscal = 0.;
/*< DSUM = ONE >*/
dsum = 1.;
/*< CALL DLASSQ( N1*N2, WORK, 1, RDSCAL, DSUM ) >*/
i__1 = n1 * n2;
dlassq_(&i__1, &work[1], &c__1, &rdscal, &dsum);
/*< PL = RDSCAL*SQRT( DSUM ) >*/
*pl = rdscal * sqrt(dsum);
/*< IF( PL.EQ.ZERO ) THEN >*/
if (*pl == 0.) {
/*< PL = ONE >*/
*pl = 1.;
/*< ELSE >*/
} else {
/*< PL = DSCALE / ( SQRT( DSCALE*DSCALE / PL+PL )*SQRT( PL ) ) >*/
*pl = dscale / (sqrt(dscale * dscale / *pl + *pl) * sqrt(*pl));
/*< END IF >*/
}
/*< RDSCAL = ZERO >*/
rdscal = 0.;
/*< DSUM = ONE >*/
dsum = 1.;
/*< CALL DLASSQ( N1*N2, WORK( N1*N2+1 ), 1, RDSCAL, DSUM ) >*/
i__1 = n1 * n2;
dlassq_(&i__1, &work[n1 * n2 + 1], &c__1, &rdscal, &dsum);
/*< PR = RDSCAL*SQRT( DSUM ) >*/
*pr = rdscal * sqrt(dsum);
/*< IF( PR.EQ.ZERO ) THEN >*/
if (*pr == 0.) {
/*< PR = ONE >*/
*pr = 1.;
/*< ELSE >*/
} else {
/*< PR = DSCALE / ( SQRT( DSCALE*DSCALE / PR+PR )*SQRT( PR ) ) >*/
*pr = dscale / (sqrt(dscale * dscale / *pr + *pr) * sqrt(*pr));
/*< END IF >*/
}
/*< END IF >*/
}
/*< IF( WANTD ) THEN >*/
if (wantd) {
/* Compute estimates of Difu and Difl. */
/*< IF( WANTD1 ) THEN >*/
if (wantd1) {
/*< N1 = M >*/
n1 = *m;
/*< N2 = N - M >*/
n2 = *n - *m;
/*< I = N1 + 1 >*/
i__ = n1 + 1;
/*< IJB = IDIFJB >*/
ijb = 3;
/* Frobenius norm-based Difu-estimate. */
/*< >*/
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + i__ *
a_dim1], lda, &work[1], &n1, &b[b_offset], ldb, &b[i__ +
i__ * b_dim1], ldb, &work[n1 * n2 + 1], &n1, &dscale, &
dif[1], &work[(n1 << 1) * n2 + 1], &i__1, &iwork[1], &
ierr, (ftnlen)1);
/* Frobenius norm-based Difl-estimate. */
/*< >*/
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("N", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda, &a[
a_offset], lda, &work[1], &n2, &b[i__ + i__ * b_dim1],
ldb, &b[b_offset], ldb, &work[n1 * n2 + 1], &n2, &dscale,
&dif[2], &work[(n1 << 1) * n2 + 1], &i__1, &iwork[1], &
ierr, (ftnlen)1);
/*< ELSE >*/
} else {
/* Compute 1-norm-based estimates of Difu and Difl using */
/* reversed communication with DLACON. In each step a */
/* generalized Sylvester equation or a transposed variant */
/* is solved. */
/*< KASE = 0 >*/
kase = 0;
/*< N1 = M >*/
n1 = *m;
/*< N2 = N - M >*/
n2 = *n - *m;
/*< I = N1 + 1 >*/
i__ = n1 + 1;
/*< IJB = 0 >*/
ijb = 0;
/*< MN2 = 2*N1*N2 >*/
mn2 = (n1 << 1) * n2;
/* 1-norm-based estimate of Difu. */
/*< 40 CONTINUE >*/
L40:
/*< >*/
dlacon_(&mn2, &work[mn2 + 1], &work[1], &iwork[1], &dif[1], &kase)
;
/*< IF( KASE.NE.0 ) THEN >*/
if (kase != 0) {
/*< IF( KASE.EQ.1 ) THEN >*/
if (kase == 1) {
/* Solve generalized Sylvester equation. */
/*< >*/
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ +
i__ * a_dim1], lda, &work[1], &n1, &b[b_offset],
ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 +
1], &n1, &dscale, &dif[1], &work[(n1 << 1) * n2 +
1], &i__1, &iwork[1], &ierr, (ftnlen)1);
/*< ELSE >*/
} else {
/* Solve the transposed variant. */
/*< >*/
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("T", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ +
i__ * a_dim1], lda, &work[1], &n1, &b[b_offset],
ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 +
1], &n1, &dscale, &dif[1], &work[(n1 << 1) * n2 +
1], &i__1, &iwork[1], &ierr, (ftnlen)1);
/*< END IF >*/
}
/*< GO TO 40 >*/
goto L40;
/*< END IF >*/
}
/*< DIF( 1 ) = DSCALE / DIF( 1 ) >*/
dif[1] = dscale / dif[1];
/* 1-norm-based estimate of Difl. */
/*< 50 CONTINUE >*/
L50:
/*< >*/
dlacon_(&mn2, &work[mn2 + 1], &work[1], &iwork[1], &dif[2], &kase)
;
/*< IF( KASE.NE.0 ) THEN >*/
if (kase != 0) {
/*< IF( KASE.EQ.1 ) THEN >*/
if (kase == 1) {
/* Solve generalized Sylvester equation. */
/*< >*/
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("N", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda,
&a[a_offset], lda, &work[1], &n2, &b[i__ + i__ *
b_dim1], ldb, &b[b_offset], ldb, &work[n1 * n2 +
1], &n2, &dscale, &dif[2], &work[(n1 << 1) * n2 +
1], &i__1, &iwork[1], &ierr, (ftnlen)1);
/*< ELSE >*/
} else {
/* Solve the transposed variant. */
/*< >*/
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("T", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda,
&a[a_offset], lda, &work[1], &n2, &b[i__ + i__ *
b_dim1], ldb, &b[b_offset], ldb, &work[n1 * n2 +
1], &n2, &dscale, &dif[2], &work[(n1 << 1) * n2 +
1], &i__1, &iwork[1], &ierr, (ftnlen)1);
/*< END IF >*/
}
/*< GO TO 50 >*/
goto L50;
/*< END IF >*/
}
/*< DIF( 2 ) = DSCALE / DIF( 2 ) >*/
dif[2] = dscale / dif[2];
/*< END IF >*/
}
/*< END IF >*/
}
/*< 60 CONTINUE >*/
L60:
/* Compute generalized eigenvalues of reordered pair (A, B) and */
/* normalize the generalized Schur form. */
/*< PAIR = .FALSE. >*/
pair = FALSE_;
/*< DO 80 K = 1, N >*/
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/*< IF( PAIR ) THEN >*/
if (pair) {
/*< PAIR = .FALSE. >*/
pair = FALSE_;
/*< ELSE >*/
} else {
/*< IF( K.LT.N ) THEN >*/
if (k < *n) {
/*< IF( A( K+1, K ).NE.ZERO ) THEN >*/
if (a[k + 1 + k * a_dim1] != 0.) {
/*< PAIR = .TRUE. >*/
pair = TRUE_;
/*< END IF >*/
}
/*< END IF >*/
}
/*< IF( PAIR ) THEN >*/
if (pair) {
/* Compute the eigenvalue(s) at position K. */
/*< WORK( 1 ) = A( K, K ) >*/
work[1] = a[k + k * a_dim1];
/*< WORK( 2 ) = A( K+1, K ) >*/
work[2] = a[k + 1 + k * a_dim1];
/*< WORK( 3 ) = A( K, K+1 ) >*/
work[3] = a[k + (k + 1) * a_dim1];
/*< WORK( 4 ) = A( K+1, K+1 ) >*/
work[4] = a[k + 1 + (k + 1) * a_dim1];
/*< WORK( 5 ) = B( K, K ) >*/
work[5] = b[k + k * b_dim1];
/*< WORK( 6 ) = B( K+1, K ) >*/
work[6] = b[k + 1 + k * b_dim1];
/*< WORK( 7 ) = B( K, K+1 ) >*/
work[7] = b[k + (k + 1) * b_dim1];
/*< WORK( 8 ) = B( K+1, K+1 ) >*/
work[8] = b[k + 1 + (k + 1) * b_dim1];
/*< >*/
d__1 = smlnum * eps;
dlag2_(&work[1], &c__2, &work[5], &c__2, &d__1, &beta[k], &
beta[k + 1], &alphar[k], &alphar[k + 1], &alphai[k]);
/*< ALPHAI( K+1 ) = -ALPHAI( K ) >*/
alphai[k + 1] = -alphai[k];
/*< ELSE >*/
} else {
/*< IF( SIGN( ONE, B( K, K ) ).LT.ZERO ) THEN >*/
if (d_sign(&c_b28, &b[k + k * b_dim1]) < 0.) {
/* If B(K,K) is negative, make it positive */
/*< DO 70 I = 1, N >*/
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/*< A( K, I ) = -A( K, I ) >*/
a[k + i__ * a_dim1] = -a[k + i__ * a_dim1];
/*< B( K, I ) = -B( K, I ) >*/
b[k + i__ * b_dim1] = -b[k + i__ * b_dim1];
/*< Q( I, K ) = -Q( I, K ) >*/
q[i__ + k * q_dim1] = -q[i__ + k * q_dim1];
/*< 70 CONTINUE >*/
/* L70: */
}
/*< END IF >*/
}
/*< ALPHAR( K ) = A( K, K ) >*/
alphar[k] = a[k + k * a_dim1];
/*< ALPHAI( K ) = ZERO >*/
alphai[k] = 0.;
/*< BETA( K ) = B( K, K ) >*/
beta[k] = b[k + k * b_dim1];
/*< END IF >*/
}
/*< END IF >*/
}
/*< 80 CONTINUE >*/
/* L80: */
}
/*< WORK( 1 ) = LWMIN >*/
work[1] = (doublereal) lwmin;
/*< IWORK( 1 ) = LIWMIN >*/
iwork[1] = liwmin;
/*< RETURN >*/
return 0;
/* End of DTGSEN */
/*< END >*/
} /* dtgsen_ */
/* Subroutine */ int dtgsen_(integer *ijob, logical *wantq, logical *wantz,
logical *select, integer *n, doublereal *a, integer *lda, doublereal *
b, integer *ldb, doublereal *alphar, doublereal *alphai, doublereal *
beta, doublereal *q, integer *ldq, doublereal *z__, integer *ldz,
integer *m, doublereal *pl, doublereal *pr, doublereal *dif,
doublereal *work, integer *lwork, integer *iwork, integer *liwork,
integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
DTGSEN reorders the generalized real Schur decomposition of a real
matrix pair (A, B) (in terms of an orthonormal equivalence trans-
formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues
appears in the leading diagonal blocks of the upper quasi-triangular
matrix A and the upper triangular B. The leading columns of Q and
Z form orthonormal bases of the corresponding left and right eigen-
spaces (deflating subspaces). (A, B) must be in generalized real
Schur canonical form (as returned by DGGES), i.e. A is block upper
triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper
triangular.
DTGSEN also computes the generalized eigenvalues
w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j)
of the reordered matrix pair (A, B).
Optionally, DTGSEN computes the estimates of reciprocal condition
numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),
(A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)
between the matrix pairs (A11, B11) and (A22,B22) that correspond to
the selected cluster and the eigenvalues outside the cluster, resp.,
and norms of "projections" onto left and right eigenspaces w.r.t.
the selected cluster in the (1,1)-block.
Arguments
=========
IJOB (input) INTEGER
Specifies whether condition numbers are required for the
cluster of eigenvalues (PL and PR) or the deflating subspaces
(Difu and Difl):
=0: Only reorder w.r.t. SELECT. No extras.
=1: Reciprocal of norms of "projections" onto left and right
eigenspaces w.r.t. the selected cluster (PL and PR).
=2: Upper bounds on Difu and Difl. F-norm-based estimate
(DIF(1:2)).
=3: Estimate of Difu and Difl. 1-norm-based estimate
(DIF(1:2)).
About 5 times as expensive as IJOB = 2.
=4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic
version to get it all.
=5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)
WANTQ (input) LOGICAL
.TRUE. : update the left transformation matrix Q;
.FALSE.: do not update Q.
WANTZ (input) LOGICAL
.TRUE. : update the right transformation matrix Z;
.FALSE.: do not update Z.
SELECT (input) LOGICAL array, dimension (N)
SELECT specifies the eigenvalues in the selected cluster.
To select a real eigenvalue w(j), SELECT(j) must be set to
.TRUE.. To select a complex conjugate pair of eigenvalues
w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,
either SELECT(j) or SELECT(j+1) or both must be set to
.TRUE.; a complex conjugate pair of eigenvalues must be
either both included in the cluster or both excluded.
N (input) INTEGER
The order of the matrices A and B. N >= 0.
A (input/output) DOUBLE PRECISION array, dimension(LDA,N)
On entry, the upper quasi-triangular matrix A, with (A, B) in
generalized real Schur canonical form.
On exit, A is overwritten by the reordered matrix A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
B (input/output) DOUBLE PRECISION array, dimension(LDB,N)
On entry, the upper triangular matrix B, with (A, B) in
generalized real Schur canonical form.
On exit, B is overwritten by the reordered matrix B.
LDB (input) INTEGER
The leading dimension of the array 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. ALPHAR(j) + ALPHAI(j)*i
and BETA(j),j=1,...,N are the diagonals of the complex Schur
form (S,T) that would result if the 2-by-2 diagonal blocks of
the real generalized Schur form of (A,B) were further reduced
to triangular form using complex unitary transformations.
If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
positive, then the j-th and (j+1)-st eigenvalues are a
complex conjugate pair, with ALPHAI(j+1) negative.
Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.
On exit, Q has been postmultiplied by the left orthogonal
transformation matrix which reorder (A, B); The leading M
columns of Q form orthonormal bases for the specified pair of
left eigenspaces (deflating subspaces).
If WANTQ = .FALSE., Q is not referenced.
LDQ (input) INTEGER
The leading dimension of the array Q. LDQ >= 1;
and if WANTQ = .TRUE., LDQ >= N.
Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.
On exit, Z has been postmultiplied by the left orthogonal
transformation matrix which reorder (A, B); The leading M
columns of Z form orthonormal bases for the specified pair of
left eigenspaces (deflating subspaces).
If WANTZ = .FALSE., Z is not referenced.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1;
If WANTZ = .TRUE., LDZ >= N.
M (output) INTEGER
The dimension of the specified pair of left and right eigen-
spaces (deflating subspaces). 0 <= M <= N.
PL, PR (output) DOUBLE PRECISION
If IJOB = 1, 4 or 5, PL, PR are lower bounds on the
reciprocal of the norm of "projections" onto left and right
eigenspaces with respect to the selected cluster.
0 < PL, PR <= 1.
If M = 0 or M = N, PL = PR = 1.
If IJOB = 0, 2 or 3, PL and PR are not referenced.
DIF (output) DOUBLE PRECISION array, dimension (2).
If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.
If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on
Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based
estimates of Difu and Difl.
If M = 0 or N, DIF(1:2) = F-norm([A, B]).
If IJOB = 0 or 1, DIF is not referenced.
WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
IF IJOB = 0, WORK is not referenced. Otherwise,
on exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= 4*N+16.
If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)).
If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)).
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
IWORK (workspace/output) INTEGER array, dimension (LIWORK)
IF IJOB = 0, IWORK is not referenced. Otherwise,
on exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
LIWORK (input) INTEGER
The dimension of the array IWORK. LIWORK >= 1.
If IJOB = 1, 2 or 4, LIWORK >= N+6.
If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6).
If LIWORK = -1, then a workspace query is assumed; the
routine only calculates the optimal size of the IWORK array,
returns this value as the first entry of the IWORK array, and
no error message related to LIWORK is issued by XERBLA.
INFO (output) INTEGER
=0: Successful exit.
<0: If INFO = -i, the i-th argument had an illegal value.
=1: Reordering of (A, B) failed because the transformed
matrix pair (A, B) would be too far from generalized
Schur form; the problem is very ill-conditioned.
(A, B) may have been partially reordered.
If requested, 0 is returned in DIF(*), PL and PR.
Further Details
===============
DTGSEN first collects the selected eigenvalues by computing
orthogonal U and W that move them to the top left corner of (A, B).
In other words, the selected eigenvalues are the eigenvalues of
(A11, B11) in:
U'*(A, B)*W = (A11 A12) (B11 B12) n1
( 0 A22),( 0 B22) n2
n1 n2 n1 n2
where N = n1+n2 and U' means the transpose of U. The first n1 columns
of U and W span the specified pair of left and right eigenspaces
(deflating subspaces) of (A, B).
If (A, B) has been obtained from the generalized real Schur
decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the
reordered generalized real Schur form of (C, D) is given by
(C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',
and the first n1 columns of Q*U and Z*W span the corresponding
deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).
Note that if the selected eigenvalue is sufficiently ill-conditioned,
then its value may differ significantly from its value before
reordering.
The reciprocal condition numbers of the left and right eigenspaces
spanned by the first n1 columns of U and W (or Q*U and Z*W) may
be returned in DIF(1:2), corresponding to Difu and Difl, resp.
The Difu and Difl are defined as:
Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )
and
Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],
where sigma-min(Zu) is the smallest singular value of the
(2*n1*n2)-by-(2*n1*n2) matrix
Zu = [ kron(In2, A11) -kron(A22', In1) ]
[ kron(In2, B11) -kron(B22', In1) ].
Here, Inx is the identity matrix of size nx and A22' is the
transpose of A22. kron(X, Y) is the Kronecker product between
the matrices X and Y.
When DIF(2) is small, small changes in (A, B) can cause large changes
in the deflating subspace. An approximate (asymptotic) bound on the
maximum angular error in the computed deflating subspaces is
EPS * norm((A, B)) / DIF(2),
where EPS is the machine precision.
The reciprocal norm of the projectors on the left and right
eigenspaces associated with (A11, B11) may be returned in PL and PR.
They are computed as follows. First we compute L and R so that
P*(A, B)*Q is block diagonal, where
P = ( I -L ) n1 Q = ( I R ) n1
( 0 I ) n2 and ( 0 I ) n2
n1 n2 n1 n2
and (L, R) is the solution to the generalized Sylvester equation
A11*R - L*A22 = -A12
B11*R - L*B22 = -B12
Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).
An approximate (asymptotic) bound on the average absolute error of
the selected eigenvalues is
EPS * norm((A, B)) / PL.
There are also global error bounds which valid for perturbations up
to a certain restriction: A lower bound (x) on the smallest
F-norm(E,F) for which an eigenvalue of (A11, B11) may move and
coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),
(i.e. (A + E, B + F), is
x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).
An approximate bound on x can be computed from DIF(1:2), PL and PR.
If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed
(L', R') and unperturbed (L, R) left and right deflating subspaces
associated with the selected cluster in the (1,1)-blocks can be
bounded as
max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))
max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))
See LAPACK User's Guide section 4.11 or the following references
for more information.
Note that if the default method for computing the Frobenius-norm-
based estimate DIF is not wanted (see DLATDF), then the parameter
IDIFJB (see below) should be changed from 3 to 4 (routine DLATDF
(IJOB = 2 will be used)). See DTGSYL for more details.
Based on contributions by
Bo Kagstrom and Peter Poromaa, Department of Computing Science,
Umea University, S-901 87 Umea, Sweden.
References
==========
[1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
M.S. Moonen et al (eds), Linear Algebra for Large Scale and
Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
[2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
Eigenvalues of a Regular Matrix Pair (A, B) and Condition
Estimation: Theory, Algorithms and Software,
Report UMINF - 94.04, Department of Computing Science, Umea
University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working
Note 87. To appear in Numerical Algorithms, 1996.
[3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
for Solving the Generalized Sylvester Equation and Estimating the
Separation between Regular Matrix Pairs, Report UMINF - 93.23,
Department of Computing Science, Umea University, S-901 87 Umea,
Sweden, December 1993, Revised April 1994, Also as LAPACK Working
Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,
1996.
=====================================================================
Decode and test the input parameters
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static integer c__2 = 2;
static doublereal c_b28 = 1.;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
z_offset, i__1, i__2;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
static integer kase;
static logical pair;
static integer ierr;
static doublereal dsum;
static logical swap;
extern /* Subroutine */ int dlag2_(doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *);
static integer i__, k;
static logical wantd;
static integer lwmin;
static logical wantp;
static integer n1, n2;
static logical wantd1, wantd2;
static integer kk;
extern doublereal dlamch_(char *);
static doublereal dscale;
static integer ks;
extern /* Subroutine */ int dlacon_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static doublereal rdscal;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
xerbla_(char *, integer *), dtgexc_(logical *, logical *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *, doublereal *, integer *, integer *), dlassq_(integer *,
doublereal *, integer *, doublereal *, doublereal *);
static integer liwmin;
extern /* Subroutine */ int dtgsyl_(char *, integer *, integer *, integer
*, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, integer *, integer *);
static doublereal smlnum;
static integer mn2;
static logical lquery;
static integer ijb;
static doublereal eps;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1]
--select;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--alphar;
--alphai;
--beta;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--dif;
--work;
--iwork;
/* Function Body */
*info = 0;
lquery = *lwork == -1 || *liwork == -1;
if (*ijob < 0 || *ijob > 5) {
*info = -1;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldq < 1 || *wantq && *ldq < *n) {
*info = -14;
} else if (*ldz < 1 || *wantz && *ldz < *n) {
*info = -16;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DTGSEN", &i__1);
return 0;
}
/* Get machine constants */
eps = dlamch_("P");
smlnum = dlamch_("S") / eps;
ierr = 0;
wantp = *ijob == 1 || *ijob >= 4;
wantd1 = *ijob == 2 || *ijob == 4;
wantd2 = *ijob == 3 || *ijob == 5;
wantd = wantd1 || wantd2;
/* Set M to the dimension of the specified pair of deflating
subspaces. */
*m = 0;
pair = FALSE_;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (pair) {
pair = FALSE_;
} else {
if (k < *n) {
if (a_ref(k + 1, k) == 0.) {
if (select[k]) {
++(*m);
}
} else {
pair = TRUE_;
if (select[k] || select[k + 1]) {
*m += 2;
}
}
} else {
if (select[*n]) {
++(*m);
}
}
}
/* L10: */
}
if (*ijob == 1 || *ijob == 2 || *ijob == 4) {
/* Computing MAX */
i__1 = 1, i__2 = (*n << 2) + 16, i__1 = max(i__1,i__2), i__2 = (*m <<
1) * (*n - *m);
lwmin = max(i__1,i__2);
/* Computing MAX */
i__1 = 1, i__2 = *n + 6;
liwmin = max(i__1,i__2);
} else if (*ijob == 3 || *ijob == 5) {
/* Computing MAX */
i__1 = 1, i__2 = (*n << 2) + 16, i__1 = max(i__1,i__2), i__2 = (*m <<
2) * (*n - *m);
lwmin = max(i__1,i__2);
/* Computing MAX */
i__1 = 1, i__2 = (*m << 1) * (*n - *m), i__1 = max(i__1,i__2), i__2 =
*n + 6;
liwmin = max(i__1,i__2);
} else {
/* Computing MAX */
i__1 = 1, i__2 = (*n << 2) + 16;
lwmin = max(i__1,i__2);
liwmin = 1;
}
work[1] = (doublereal) lwmin;
iwork[1] = liwmin;
if (*lwork < lwmin && ! lquery) {
*info = -22;
} else if (*liwork < liwmin && ! lquery) {
*info = -24;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DTGSEN", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible. */
if (*m == *n || *m == 0) {
if (wantp) {
*pl = 1.;
*pr = 1.;
}
if (wantd) {
dscale = 0.;
dsum = 1.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
dlassq_(n, &a_ref(1, i__), &c__1, &dscale, &dsum);
dlassq_(n, &b_ref(1, i__), &c__1, &dscale, &dsum);
/* L20: */
}
dif[1] = dscale * sqrt(dsum);
dif[2] = dif[1];
}
goto L60;
}
/* Collect the selected blocks at the top-left corner of (A, B). */
ks = 0;
pair = FALSE_;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (pair) {
pair = FALSE_;
} else {
swap = select[k];
if (k < *n) {
if (a_ref(k + 1, k) != 0.) {
pair = TRUE_;
swap = swap || select[k + 1];
}
}
if (swap) {
++ks;
/* Swap the K-th block to position KS.
Perform the reordering of diagonal blocks in (A, B)
by orthogonal transformation matrices and update
Q and Z accordingly (if requested): */
kk = k;
if (k != ks) {
dtgexc_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset],
ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &kk,
&ks, &work[1], lwork, &ierr);
}
if (ierr > 0) {
/* Swap is rejected: exit. */
*info = 1;
if (wantp) {
*pl = 0.;
*pr = 0.;
}
if (wantd) {
dif[1] = 0.;
dif[2] = 0.;
}
goto L60;
}
if (pair) {
++ks;
}
}
}
/* L30: */
}
if (wantp) {
/* Solve generalized Sylvester equation for R and L
and compute PL and PR. */
n1 = *m;
n2 = *n - *m;
i__ = n1 + 1;
ijb = 0;
dlacpy_("Full", &n1, &n2, &a_ref(1, i__), lda, &work[1], &n1);
dlacpy_("Full", &n1, &n2, &b_ref(1, i__), ldb, &work[n1 * n2 + 1], &
n1);
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a_ref(i__, i__), lda,
&work[1], &n1, &b[b_offset], ldb, &b_ref(i__, i__), ldb, &
work[n1 * n2 + 1], &n1, &dscale, &dif[1], &work[(n1 * n2 << 1)
+ 1], &i__1, &iwork[1], &ierr);
/* Estimate the reciprocal of norms of "projections" onto left
and right eigenspaces. */
rdscal = 0.;
dsum = 1.;
i__1 = n1 * n2;
dlassq_(&i__1, &work[1], &c__1, &rdscal, &dsum);
*pl = rdscal * sqrt(dsum);
if (*pl == 0.) {
*pl = 1.;
} else {
*pl = dscale / (sqrt(dscale * dscale / *pl + *pl) * sqrt(*pl));
}
rdscal = 0.;
dsum = 1.;
i__1 = n1 * n2;
dlassq_(&i__1, &work[n1 * n2 + 1], &c__1, &rdscal, &dsum);
*pr = rdscal * sqrt(dsum);
if (*pr == 0.) {
*pr = 1.;
} else {
*pr = dscale / (sqrt(dscale * dscale / *pr + *pr) * sqrt(*pr));
}
}
if (wantd) {
/* Compute estimates of Difu and Difl. */
if (wantd1) {
n1 = *m;
n2 = *n - *m;
i__ = n1 + 1;
ijb = 3;
/* Frobenius norm-based Difu-estimate. */
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a_ref(i__, i__),
lda, &work[1], &n1, &b[b_offset], ldb, &b_ref(i__, i__),
ldb, &work[n1 * n2 + 1], &n1, &dscale, &dif[1], &work[(n1
<< 1) * n2 + 1], &i__1, &iwork[1], &ierr);
/* Frobenius norm-based Difl-estimate. */
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("N", &ijb, &n2, &n1, &a_ref(i__, i__), lda, &a[a_offset],
lda, &work[1], &n2, &b_ref(i__, i__), ldb, &b[b_offset],
ldb, &work[n1 * n2 + 1], &n2, &dscale, &dif[2], &work[(n1
<< 1) * n2 + 1], &i__1, &iwork[1], &ierr);
} else {
/* Compute 1-norm-based estimates of Difu and Difl using
reversed communication with DLACON. In each step a
generalized Sylvester equation or a transposed variant
is solved. */
kase = 0;
n1 = *m;
n2 = *n - *m;
i__ = n1 + 1;
ijb = 0;
mn2 = (n1 << 1) * n2;
/* 1-norm-based estimate of Difu. */
L40:
dlacon_(&mn2, &work[mn2 + 1], &work[1], &iwork[1], &dif[1], &kase)
;
if (kase != 0) {
if (kase == 1) {
/* Solve generalized Sylvester equation. */
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a_ref(
i__, i__), lda, &work[1], &n1, &b[b_offset], ldb,
&b_ref(i__, i__), ldb, &work[n1 * n2 + 1], &n1, &
dscale, &dif[1], &work[(n1 << 1) * n2 + 1], &i__1,
&iwork[1], &ierr);
} else {
/* Solve the transposed variant. */
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("T", &ijb, &n1, &n2, &a[a_offset], lda, &a_ref(
i__, i__), lda, &work[1], &n1, &b[b_offset], ldb,
&b_ref(i__, i__), ldb, &work[n1 * n2 + 1], &n1, &
dscale, &dif[1], &work[(n1 << 1) * n2 + 1], &i__1,
&iwork[1], &ierr);
}
goto L40;
}
dif[1] = dscale / dif[1];
/* 1-norm-based estimate of Difl. */
L50:
dlacon_(&mn2, &work[mn2 + 1], &work[1], &iwork[1], &dif[2], &kase)
;
if (kase != 0) {
if (kase == 1) {
/* Solve generalized Sylvester equation. */
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("N", &ijb, &n2, &n1, &a_ref(i__, i__), lda, &a[
a_offset], lda, &work[1], &n2, &b_ref(i__, i__),
ldb, &b[b_offset], ldb, &work[n1 * n2 + 1], &n2, &
dscale, &dif[2], &work[(n1 << 1) * n2 + 1], &i__1,
&iwork[1], &ierr);
} else {
/* Solve the transposed variant. */
i__1 = *lwork - (n1 << 1) * n2;
dtgsyl_("T", &ijb, &n2, &n1, &a_ref(i__, i__), lda, &a[
a_offset], lda, &work[1], &n2, &b_ref(i__, i__),
ldb, &b[b_offset], ldb, &work[n1 * n2 + 1], &n2, &
dscale, &dif[2], &work[(n1 << 1) * n2 + 1], &i__1,
&iwork[1], &ierr);
}
goto L50;
}
dif[2] = dscale / dif[2];
}
}
L60:
/* Compute generalized eigenvalues of reordered pair (A, B) and
normalize the generalized Schur form. */
pair = FALSE_;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (pair) {
pair = FALSE_;
} else {
if (k < *n) {
if (a_ref(k + 1, k) != 0.) {
pair = TRUE_;
}
}
if (pair) {
/* Compute the eigenvalue(s) at position K. */
work[1] = a_ref(k, k);
work[2] = a_ref(k + 1, k);
work[3] = a_ref(k, k + 1);
work[4] = a_ref(k + 1, k + 1);
work[5] = b_ref(k, k);
work[6] = b_ref(k + 1, k);
work[7] = b_ref(k, k + 1);
work[8] = b_ref(k + 1, k + 1);
d__1 = smlnum * eps;
dlag2_(&work[1], &c__2, &work[5], &c__2, &d__1, &beta[k], &
beta[k + 1], &alphar[k], &alphar[k + 1], &alphai[k]);
alphai[k + 1] = -alphai[k];
} else {
if (d_sign(&c_b28, &b_ref(k, k)) < 0.) {
/* If B(K,K) is negative, make it positive */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
a_ref(k, i__) = -a_ref(k, i__);
b_ref(k, i__) = -b_ref(k, i__);
q_ref(i__, k) = -q_ref(i__, k);
/* L70: */
}
}
alphar[k] = a_ref(k, k);
alphai[k] = 0.;
beta[k] = b_ref(k, k);
}
}
/* L80: */
}
work[1] = (doublereal) lwmin;
iwork[1] = liwmin;
return 0;
/* End of DTGSEN */
} /* dtgsen_ */
/* Subroutine */ int dsprfs_(char *uplo, integer *n, integer *nrhs,
doublereal *ap, doublereal *afp, integer *ipiv, doublereal *b,
integer *ldb, doublereal *x, integer *ldx, doublereal *ferr,
doublereal *berr, doublereal *work, integer *iwork, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
DSPRFS improves the computed solution to a system of linear
equations when the coefficient matrix is symmetric indefinite
and packed, and provides error bounds and backward error estimates
for the solution.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrices B and X. NRHS >= 0.
AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
The upper or lower triangle of the symmetric matrix A, packed
columnwise in a linear array. The j-th column of A is stored
in the array AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
AFP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
The factored form of the matrix A. AFP contains the block
diagonal matrix D and the multipliers used to obtain the
factor U or L from the factorization A = U*D*U**T or
A = L*D*L**T as computed by DSPTRF, stored as a packed
triangular matrix.
IPIV (input) INTEGER array, dimension (N)
Details of the interchanges and the block structure of D
as determined by DSPTRF.
B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
The right hand side matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
On entry, the solution matrix X, as computed by DSPTRS.
On exit, the improved solution matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
FERR (output) DOUBLE PRECISION array, dimension (NRHS)
The estimated forward error bound for each solution vector
X(j) (the j-th column of the solution matrix X).
If XTRUE is the true solution corresponding to X(j), FERR(j)
is an estimated upper bound for the magnitude of the largest
element in (X(j) - XTRUE) divided by the magnitude of the
largest element in X(j). The estimate is as reliable as
the estimate for RCOND, and is almost always a slight
overestimate of the true error.
BERR (output) DOUBLE PRECISION array, dimension (NRHS)
The componentwise relative backward error of each solution
vector X(j) (i.e., the smallest relative change in
any element of A or B that makes X(j) an exact solution).
WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
IWORK (workspace) INTEGER array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Internal Parameters
===================
ITMAX is the maximum number of steps of iterative refinement.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b12 = -1.;
static doublereal c_b14 = 1.;
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3;
doublereal d__1, d__2, d__3;
/* Local variables */
static integer kase;
static doublereal safe1, safe2;
static integer i__, j, k;
static doublereal s;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), daxpy_(integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *);
static integer count;
extern /* Subroutine */ int dspmv_(char *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
integer *);
static logical upper;
static integer ik, kk;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlacon_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static doublereal xk;
static integer nz;
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal lstres;
extern /* Subroutine */ int dsptrs_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *);
static doublereal eps;
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define x_ref(a_1,a_2) x[(a_2)*x_dim1 + a_1]
--ap;
--afp;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
--ferr;
--berr;
--work;
--iwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*ldb < max(1,*n)) {
*info = -8;
} else if (*ldx < max(1,*n)) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSPRFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] = 0.;
berr[j] = 0.;
/* L10: */
}
return 0;
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
eps = dlamch_("Epsilon");
safmin = dlamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
count = 1;
lstres = 3.;
L20:
/* Loop until stopping criterion is satisfied.
Compute residual R = B - A * X */
dcopy_(n, &b_ref(1, j), &c__1, &work[*n + 1], &c__1);
dspmv_(uplo, n, &c_b12, &ap[1], &x_ref(1, j), &c__1, &c_b14, &work[*n
+ 1], &c__1);
/* Compute componentwise relative backward error from formula
max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
where abs(Z) is the componentwise absolute value of the matrix
or vector Z. If the i-th component of the denominator is less
than SAFE2, then SAFE1 is added to the i-th components of the
numerator and denominator before dividing. */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] = (d__1 = b_ref(i__, j), abs(d__1));
/* L30: */
}
/* Compute abs(A)*abs(X) + abs(B). */
kk = 1;
if (upper) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.;
xk = (d__1 = x_ref(k, j), abs(d__1));
ik = kk;
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
work[i__] += (d__1 = ap[ik], abs(d__1)) * xk;
s += (d__1 = ap[ik], abs(d__1)) * (d__2 = x_ref(i__, j),
abs(d__2));
++ik;
/* L40: */
}
work[k] = work[k] + (d__1 = ap[kk + k - 1], abs(d__1)) * xk +
s;
kk += k;
/* L50: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.;
xk = (d__1 = x_ref(k, j), abs(d__1));
work[k] += (d__1 = ap[kk], abs(d__1)) * xk;
ik = kk + 1;
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
work[i__] += (d__1 = ap[ik], abs(d__1)) * xk;
s += (d__1 = ap[ik], abs(d__1)) * (d__2 = x_ref(i__, j),
abs(d__2));
++ik;
/* L60: */
}
work[k] += s;
kk += *n - k + 1;
/* L70: */
}
}
s = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (work[i__] > safe2) {
/* Computing MAX */
d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[
i__];
s = max(d__2,d__3);
} else {
/* Computing MAX */
d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1)
/ (work[i__] + safe1);
s = max(d__2,d__3);
}
/* L80: */
}
berr[j] = s;
/* Test stopping criterion. Continue iterating if
1) The residual BERR(J) is larger than machine epsilon, and
2) BERR(J) decreased by at least a factor of 2 during the
last iteration, and
3) At most ITMAX iterations tried. */
if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {
/* Update solution and try again. */
dsptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[*n + 1], n, info);
daxpy_(n, &c_b14, &work[*n + 1], &c__1, &x_ref(1, j), &c__1);
lstres = berr[j];
++count;
goto L20;
}
/* Bound error from formula
norm(X - XTRUE) / norm(X) .le. FERR =
norm( abs(inv(A))*
( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
where
norm(Z) is the magnitude of the largest component of Z
inv(A) is the inverse of A
abs(Z) is the componentwise absolute value of the matrix or
vector Z
NZ is the maximum number of nonzeros in any row of A, plus 1
EPS is machine epsilon
The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
is incremented by SAFE1 if the i-th component of
abs(A)*abs(X) + abs(B) is less than SAFE2.
Use DLACON to estimate the infinity-norm of the matrix
inv(A) * diag(W),
where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (work[i__] > safe2) {
work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
work[i__];
} else {
work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
work[i__] + safe1;
}
/* L90: */
}
kase = 0;
L100:
dlacon_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(A'). */
dsptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[*n + 1], n,
info);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*n + i__] = work[i__] * work[*n + i__];
/* L110: */
}
} else if (kase == 2) {
/* Multiply by inv(A)*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*n + i__] = work[i__] * work[*n + i__];
/* L120: */
}
dsptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[*n + 1], n,
info);
}
goto L100;
}
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = lstres, d__3 = (d__1 = x_ref(i__, j), abs(d__1));
lstres = max(d__2,d__3);
/* L130: */
}
if (lstres != 0.) {
ferr[j] /= lstres;
}
/* L140: */
}
return 0;
/* End of DSPRFS */
} /* dsprfs_ */
/* Subroutine */ int dtrsna_(char *job, char *howmny, logical *select,
integer *n, doublereal *t, integer *ldt, doublereal *vl, integer *
ldvl, doublereal *vr, integer *ldvr, doublereal *s, doublereal *sep,
integer *mm, integer *m, doublereal *work, integer *ldwork, integer *
iwork, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
DTRSNA estimates reciprocal condition numbers for specified
eigenvalues and/or right eigenvectors of a real upper
quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q
orthogonal).
T must be in Schur canonical form (as returned by DHSEQR), that is,
block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
2-by-2 diagonal block has its diagonal elements equal and its
off-diagonal elements of opposite sign.
Arguments
=========
JOB (input) CHARACTER*1
Specifies whether condition numbers are required for
eigenvalues (S) or eigenvectors (SEP):
= 'E': for eigenvalues only (S);
= 'V': for eigenvectors only (SEP);
= 'B': for both eigenvalues and eigenvectors (S and SEP).
HOWMNY (input) CHARACTER*1
= 'A': compute condition numbers for all eigenpairs;
= 'S': compute condition numbers for selected eigenpairs
specified by the array SELECT.
SELECT (input) LOGICAL array, dimension (N)
If HOWMNY = 'S', SELECT specifies the eigenpairs for which
condition numbers are required. To select condition numbers
for the eigenpair corresponding to a real eigenvalue w(j),
SELECT(j) must be set to .TRUE.. To select condition numbers
corresponding to a complex conjugate pair of eigenvalues w(j)
and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be
set to .TRUE..
If HOWMNY = 'A', SELECT is not referenced.
N (input) INTEGER
The order of the matrix T. N >= 0.
T (input) DOUBLE PRECISION array, dimension (LDT,N)
The upper quasi-triangular matrix T, in Schur canonical form.
LDT (input) INTEGER
The leading dimension of the array T. LDT >= max(1,N).
VL (input) DOUBLE PRECISION array, dimension (LDVL,M)
If JOB = 'E' or 'B', VL must contain left eigenvectors of T
(or of any Q*T*Q**T with Q orthogonal), corresponding to the
eigenpairs specified by HOWMNY and SELECT. The eigenvectors
must be stored in consecutive columns of VL, as returned by
DHSEIN or DTREVC.
If JOB = 'V', VL is not referenced.
LDVL (input) INTEGER
The leading dimension of the array VL.
LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.
VR (input) DOUBLE PRECISION array, dimension (LDVR,M)
If JOB = 'E' or 'B', VR must contain right eigenvectors of T
(or of any Q*T*Q**T with Q orthogonal), corresponding to the
eigenpairs specified by HOWMNY and SELECT. The eigenvectors
must be stored in consecutive columns of VR, as returned by
DHSEIN or DTREVC.
If JOB = 'V', VR is not referenced.
LDVR (input) INTEGER
The leading dimension of the array VR.
LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.
S (output) DOUBLE PRECISION array, dimension (MM)
If JOB = 'E' or 'B', the reciprocal condition numbers of the
selected eigenvalues, stored in consecutive elements of the
array. For a complex conjugate pair of eigenvalues two
consecutive elements of S are set to the same value. Thus
S(j), SEP(j), and the j-th columns of VL and VR all
correspond to the same eigenpair (but not in general the
j-th eigenpair, unless all eigenpairs are selected).
If JOB = 'V', S is not referenced.
SEP (output) DOUBLE PRECISION array, dimension (MM)
If JOB = 'V' or 'B', the estimated reciprocal condition
numbers of the selected eigenvectors, stored in consecutive
elements of the array. For a complex eigenvector two
consecutive elements of SEP are set to the same value. If
the eigenvalues cannot be reordered to compute SEP(j), SEP(j)
is set to 0; this can only occur when the true value would be
very small anyway.
If JOB = 'E', SEP is not referenced.
MM (input) INTEGER
The number of elements in the arrays S (if JOB = 'E' or 'B')
and/or SEP (if JOB = 'V' or 'B'). MM >= M.
M (output) INTEGER
The number of elements of the arrays S and/or SEP actually
used to store the estimated condition numbers.
If HOWMNY = 'A', M is set to N.
WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,N+1)
If JOB = 'E', WORK is not referenced.
LDWORK (input) INTEGER
The leading dimension of the array WORK.
LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.
IWORK (workspace) INTEGER array, dimension (N)
If JOB = 'E', IWORK is not referenced.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Further Details
===============
The reciprocal of the condition number of an eigenvalue lambda is
defined as
S(lambda) = |v'*u| / (norm(u)*norm(v))
where u and v are the right and left eigenvectors of T corresponding
to lambda; v' denotes the conjugate-transpose of v, and norm(u)
denotes the Euclidean norm. These reciprocal condition numbers always
lie between zero (very badly conditioned) and one (very well
conditioned). If n = 1, S(lambda) is defined to be 1.
An approximate error bound for a computed eigenvalue W(i) is given by
EPS * norm(T) / S(i)
where EPS is the machine precision.
The reciprocal of the condition number of the right eigenvector u
corresponding to lambda is defined as follows. Suppose
T = ( lambda c )
( 0 T22 )
Then the reciprocal condition number is
SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )
where sigma-min denotes the smallest singular value. We approximate
the smallest singular value by the reciprocal of an estimate of the
one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is
defined to be abs(T(1,1)).
An approximate error bound for a computed right eigenvector VR(i)
is given by
EPS * norm(T) / SEP(i)
=====================================================================
Decode and test the input parameters
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
static logical c_true = TRUE_;
static logical c_false = FALSE_;
/* System generated locals */
integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset,
work_dim1, work_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer kase;
static doublereal cond;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static logical pair;
static integer ierr;
static doublereal dumm, prod;
static integer ifst;
static doublereal lnrm;
static integer ilst;
static doublereal rnrm;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static doublereal prod1, prod2;
static integer i, j, k;
static doublereal scale, delta;
extern logical lsame_(char *, char *);
static logical wants;
static doublereal dummy[1];
static integer n2;
extern doublereal dlapy2_(doublereal *, doublereal *);
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
static doublereal cs;
extern doublereal dlamch_(char *);
static integer nn, ks;
extern /* Subroutine */ int dlacon_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static doublereal sn, mu;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
xerbla_(char *, integer *);
static doublereal bignum;
static logical wantbh;
extern /* Subroutine */ int dlaqtr_(logical *, logical *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *), dtrexc_(char *, integer *
, doublereal *, integer *, doublereal *, integer *, integer *,
integer *, doublereal *, integer *);
static logical somcon;
static doublereal smlnum;
static logical wantsp;
static doublereal eps, est;
#define DUMMY(I) dummy[(I)]
#define SELECT(I) select[(I)-1]
#define S(I) s[(I)-1]
#define SEP(I) sep[(I)-1]
#define IWORK(I) iwork[(I)-1]
#define T(I,J) t[(I)-1 + ((J)-1)* ( *ldt)]
#define VL(I,J) vl[(I)-1 + ((J)-1)* ( *ldvl)]
#define VR(I,J) vr[(I)-1 + ((J)-1)* ( *ldvr)]
#define WORK(I,J) work[(I)-1 + ((J)-1)* ( *ldwork)]
wantbh = lsame_(job, "B");
wants = lsame_(job, "E") || wantbh;
wantsp = lsame_(job, "V") || wantbh;
somcon = lsame_(howmny, "S");
*info = 0;
if (! wants && ! wantsp) {
*info = -1;
} else if (! lsame_(howmny, "A") && ! somcon) {
*info = -2;
} else if (*n < 0) {
*info = -4;
} else if (*ldt < max(1,*n)) {
*info = -6;
} else if (*ldvl < 1 || wants && *ldvl < *n) {
*info = -8;
} else if (*ldvr < 1 || wants && *ldvr < *n) {
*info = -10;
} else {
/* Set M to the number of eigenpairs for which condition number
s
are required, and test MM. */
if (somcon) {
*m = 0;
pair = FALSE_;
i__1 = *n;
for (k = 1; k <= *n; ++k) {
if (pair) {
pair = FALSE_;
} else {
if (k < *n) {
if (T(k+1,k) == 0.) {
if (SELECT(k)) {
++(*m);
}
} else {
pair = TRUE_;
if (SELECT(k) || SELECT(k + 1)) {
*m += 2;
}
}
} else {
if (SELECT(*n)) {
++(*m);
}
}
}
/* L10: */
}
} else {
*m = *n;
}
if (*mm < *m) {
*info = -13;
} else if (*ldwork < 1 || wantsp && *ldwork < *n) {
*info = -16;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DTRSNA", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (somcon) {
if (! SELECT(1)) {
return 0;
}
}
if (wants) {
S(1) = 1.;
}
if (wantsp) {
SEP(1) = (d__1 = T(1,1), abs(d__1));
}
return 0;
}
/* Get machine constants */
eps = dlamch_("P");
smlnum = dlamch_("S") / eps;
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
ks = 0;
pair = FALSE_;
i__1 = *n;
for (k = 1; k <= *n; ++k) {
/* Determine whether T(k,k) begins a 1-by-1 or 2-by-2 block. */
if (pair) {
pair = FALSE_;
goto L60;
} else {
if (k < *n) {
pair = T(k+1,k) != 0.;
}
}
/* Determine whether condition numbers are required for the k-t
h
eigenpair. */
if (somcon) {
if (pair) {
if (! SELECT(k) && ! SELECT(k + 1)) {
goto L60;
}
} else {
if (! SELECT(k)) {
goto L60;
}
}
}
++ks;
if (wants) {
/* Compute the reciprocal condition number of the k-th
eigenvalue. */
if (! pair) {
/* Real eigenvalue. */
prod = ddot_(n, &VR(1,ks), &c__1, &VL(1,ks), &c__1);
rnrm = dnrm2_(n, &VR(1,ks), &c__1);
lnrm = dnrm2_(n, &VL(1,ks), &c__1);
S(ks) = abs(prod) / (rnrm * lnrm);
} else {
/* Complex eigenvalue. */
prod1 = ddot_(n, &VR(1,ks), &c__1, &VL(1,ks), &c__1);
prod1 += ddot_(n, &VR(1,ks+1), &c__1, &VL(1,ks+1), &c__1);
prod2 = ddot_(n, &VL(1,ks), &c__1, &VR(1,ks+1), &c__1);
prod2 -= ddot_(n, &VL(1,ks+1), &c__1, &VR(1,ks), &c__1);
d__1 = dnrm2_(n, &VR(1,ks), &c__1);
d__2 = dnrm2_(n, &VR(1,ks+1), &c__1);
rnrm = dlapy2_(&d__1, &d__2);
d__1 = dnrm2_(n, &VL(1,ks), &c__1);
d__2 = dnrm2_(n, &VL(1,ks+1), &c__1);
lnrm = dlapy2_(&d__1, &d__2);
cond = dlapy2_(&prod1, &prod2) / (rnrm * lnrm);
S(ks) = cond;
S(ks + 1) = cond;
}
}
if (wantsp) {
/* Estimate the reciprocal condition number of the k-th
eigenvector.
Copy the matrix T to the array WORK and swap the diag
onal
block beginning at T(k,k) to the (1,1) position. */
dlacpy_("Full", n, n, &T(1,1), ldt, &WORK(1,1),
ldwork);
ifst = k;
ilst = 1;
dtrexc_("No Q", n, &WORK(1,1), ldwork, dummy, &c__1, &
ifst, &ilst, &WORK(1,*n+1), &ierr);
if (ierr == 1 || ierr == 2) {
/* Could not swap because blocks not well separat
ed */
scale = 1.;
est = bignum;
} else {
/* Reordering successful */
if (WORK(2,1) == 0.) {
/* Form C = T22 - lambda*I in WORK(2:N,2:N
). */
i__2 = *n;
for (i = 2; i <= *n; ++i) {
WORK(i,i) -= WORK(1,1);
/* L20: */
}
n2 = 1;
nn = *n - 1;
} else {
/* Triangularize the 2 by 2 block by unita
ry
transformation U = [ cs i*ss ]
[ i*ss cs ].
such that the (1,1) position of WORK is
complex
eigenvalue lambda with positive imagina
ry part. (2,2)
position of WORK is the complex eigenva
lue lambda
with negative imaginary part. */
mu = sqrt((d__1 = WORK(1,2), abs(d__1)))
* sqrt((d__2 = WORK(2,1), abs(d__2)));
delta = dlapy2_(&mu, &WORK(2,1));
cs = mu / delta;
sn = -WORK(2,1) / delta;
/* Form
C' = WORK(2:N,2:N) + i*[rwork(1) .....
rwork(n-1) ]
[ mu
]
[ ..
]
[ ..
]
[
mu ]
where C' is conjugate transpose of comp
lex matrix C,
and RWORK is stored starting in the N+1
-st column of
WORK. */
i__2 = *n;
for (j = 3; j <= *n; ++j) {
WORK(2,j) = cs * WORK(2,j)
;
WORK(j,j) -= WORK(1,1);
/* L30: */
}
WORK(2,2) = 0.;
WORK(1,*n+1) = mu * 2.;
i__2 = *n - 1;
for (i = 2; i <= *n-1; ++i) {
WORK(i,*n+1) = sn * WORK(1,i+1);
/* L40: */
}
n2 = 2;
nn = *n - 1 << 1;
}
/* Estimate norm(inv(C')) */
est = 0.;
kase = 0;
L50:
dlacon_(&nn, &WORK(1,*n+2), &WORK(1,*n+4), &IWORK(1), &est, &kase);
if (kase != 0) {
if (kase == 1) {
if (n2 == 1) {
/* Real eigenvalue: solve C'
*x = scale*c. */
i__2 = *n - 1;
dlaqtr_(&c_true, &c_true, &i__2, &WORK(2,2), ldwork, dummy, &dumm, &scale,
&WORK(1,*n+4), &WORK(1,*n+6), &ierr);
} else {
/* Complex eigenvalue: solve
C'*(p+iq) = scale*(c+id)
in real arithmetic. */
i__2 = *n - 1;
dlaqtr_(&c_true, &c_false, &i__2, &WORK(2,2), ldwork, &WORK(1,*n+1), &mu, &scale, &WORK(1,*n+4), &WORK(1,*n+6), &ierr);
}
} else {
if (n2 == 1) {
/* Real eigenvalue: solve C*
x = scale*c. */
i__2 = *n - 1;
dlaqtr_(&c_false, &c_true, &i__2, &WORK(2,2), ldwork, dummy, &
dumm, &scale, &WORK(1,*n+4), &WORK(1,*n+6), &
ierr);
} else {
/* Complex eigenvalue: solve
C*(p+iq) = scale*(c+id) i
n real arithmetic. */
i__2 = *n - 1;
dlaqtr_(&c_false, &c_false, &i__2, &WORK(2,2), ldwork, &WORK(1,*n+1), &mu, &scale, &WORK(1,*n+4), &WORK(1,*n+6), &ierr);
}
}
goto L50;
}
}
SEP(ks) = scale / max(est,smlnum);
if (pair) {
SEP(ks + 1) = SEP(ks);
}
}
if (pair) {
++ks;
}
L60:
;
}
return 0;
/* End of DTRSNA */
} /* dtrsna_ */
