/* Subroutine */ int ztrsen_(char *job, char *compq, logical *select, integer
*n, doublecomplex *t, integer *ldt, doublecomplex *q, integer *ldq,
doublecomplex *w, integer *m, doublereal *s, doublereal *sep,
doublecomplex *work, integer *lwork, integer *info, ftnlen job_len,
ftnlen compq_len)
{
/* System generated locals */
integer q_dim1, q_offset, t_dim1, t_offset, i__1, i__2, i__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer k, n1, n2, nn, ks;
static doublereal est;
static integer kase, ierr;
static doublereal scale;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static integer lwmin;
static logical wantq, wants;
static doublereal rnorm, rwork[1];
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *, ftnlen);
static logical wantbh;
extern /* Subroutine */ int zlacon_(integer *, doublecomplex *,
doublecomplex *, doublereal *, integer *), zlacpy_(char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *, ftnlen);
static logical wantsp;
extern /* Subroutine */ int ztrexc_(char *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, integer *, integer *,
integer *, ftnlen);
static logical lquery;
extern /* Subroutine */ int ztrsyl_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, integer *, ftnlen,
ftnlen);
/* -- 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 .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZTRSEN reorders the Schur factorization of a complex matrix */
/* A = Q*T*Q**H, so that a selected cluster of eigenvalues appears in */
/* the leading positions on the diagonal of the upper triangular matrix */
/* T, and the leading columns of Q form an orthonormal basis of the */
/* corresponding right invariant subspace. */
/* Optionally the routine computes the reciprocal condition numbers of */
/* the cluster of eigenvalues and/or the invariant subspace. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* Specifies whether condition numbers are required for the */
/* cluster of eigenvalues (S) or the invariant subspace (SEP): */
/* = 'N': none; */
/* = 'E': for eigenvalues only (S); */
/* = 'V': for invariant subspace only (SEP); */
/* = 'B': for both eigenvalues and invariant subspace (S and */
/* SEP). */
/* COMPQ (input) CHARACTER*1 */
/* = 'V': update the matrix Q of Schur vectors; */
/* = 'N': do not update Q. */
/* SELECT (input) LOGICAL array, dimension (N) */
/* SELECT specifies the eigenvalues in the selected cluster. To */
/* select the j-th eigenvalue, SELECT(j) must be set to .TRUE.. */
/* N (input) INTEGER */
/* The order of the matrix T. N >= 0. */
/* T (input/output) COMPLEX*16 array, dimension (LDT,N) */
/* On entry, the upper triangular matrix T. */
/* On exit, T is overwritten by the reordered matrix T, with the */
/* selected eigenvalues as the leading diagonal elements. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= max(1,N). */
/* Q (input/output) COMPLEX*16 array, dimension (LDQ,N) */
/* On entry, if COMPQ = 'V', the matrix Q of Schur vectors. */
/* On exit, if COMPQ = 'V', Q has been postmultiplied by the */
/* unitary transformation matrix which reorders T; the leading M */
/* columns of Q form an orthonormal basis for the specified */
/* invariant subspace. */
/* If COMPQ = 'N', Q is not referenced. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. */
/* LDQ >= 1; and if COMPQ = 'V', LDQ >= N. */
/* W (output) COMPLEX*16 array, dimension (N) */
/* The reordered eigenvalues of T, in the same order as they */
/* appear on the diagonal of T. */
/* M (output) INTEGER */
/* The dimension of the specified invariant subspace. */
/* 0 <= M <= N. */
/* S (output) DOUBLE PRECISION */
/* If JOB = 'E' or 'B', S is a lower bound on the reciprocal */
/* condition number for the selected cluster of eigenvalues. */
/* S cannot underestimate the true reciprocal condition number */
/* by more than a factor of sqrt(N). If M = 0 or N, S = 1. */
/* If JOB = 'N' or 'V', S is not referenced. */
/* SEP (output) DOUBLE PRECISION */
/* If JOB = 'V' or 'B', SEP is the estimated reciprocal */
/* condition number of the specified invariant subspace. If */
/* M = 0 or N, SEP = norm(T). */
/* If JOB = 'N' or 'E', SEP is not referenced. */
/* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) */
/* If JOB = 'N', 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. */
/* If JOB = 'N', LWORK >= 1; */
/* if JOB = 'E', LWORK = M*(N-M); */
/* if JOB = 'V' or 'B', LWORK >= 2*M*(N-M). */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* ZTRSEN first collects the selected eigenvalues by computing a unitary */
/* transformation Z to move them to the top left corner of T. In other */
/* words, the selected eigenvalues are the eigenvalues of T11 in: */
/* Z'*T*Z = ( T11 T12 ) n1 */
/* ( 0 T22 ) n2 */
/* n1 n2 */
/* where N = n1+n2 and Z' means the conjugate transpose of Z. The first */
/* n1 columns of Z span the specified invariant subspace of T. */
/* If T has been obtained from the Schur factorization of a matrix */
/* A = Q*T*Q', then the reordered Schur factorization of A is given by */
/* A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span the */
/* corresponding invariant subspace of A. */
/* The reciprocal condition number of the average of the eigenvalues of */
/* T11 may be returned in S. S lies between 0 (very badly conditioned) */
/* and 1 (very well conditioned). It is computed as follows. First we */
/* compute R so that */
/* P = ( I R ) n1 */
/* ( 0 0 ) n2 */
/* n1 n2 */
/* is the projector on the invariant subspace associated with T11. */
/* R is the solution of the Sylvester equation: */
/* T11*R - R*T22 = T12. */
/* Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote */
/* the two-norm of M. Then S is computed as the lower bound */
/* (1 + F-norm(R)**2)**(-1/2) */
/* on the reciprocal of 2-norm(P), the true reciprocal condition number. */
/* S cannot underestimate 1 / 2-norm(P) by more than a factor of */
/* sqrt(N). */
/* An approximate error bound for the computed average of the */
/* eigenvalues of T11 is */
/* EPS * norm(T) / S */
/* where EPS is the machine precision. */
/* The reciprocal condition number of the right invariant subspace */
/* spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP. */
/* SEP is defined as the separation of T11 and T22: */
/* sep( T11, T22 ) = sigma-min( C ) */
/* where sigma-min(C) is the smallest singular value of the */
/* n1*n2-by-n1*n2 matrix */
/* C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) ) */
/* I(m) is an m by m identity matrix, and kprod denotes the Kronecker */
/* product. We estimate sigma-min(C) by the reciprocal of an estimate of */
/* the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C) */
/* cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2). */
/* When SEP is small, small changes in T can cause large changes in */
/* the invariant subspace. An approximate bound on the maximum angular */
/* error in the computed right invariant subspace is */
/* EPS * norm(T) / SEP */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and test the input parameters. */
/* Parameter adjustments */
--select;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--w;
--work;
/* Function Body */
wantbh = lsame_(job, "B", (ftnlen)1, (ftnlen)1);
wants = lsame_(job, "E", (ftnlen)1, (ftnlen)1) || wantbh;
wantsp = lsame_(job, "V", (ftnlen)1, (ftnlen)1) || wantbh;
wantq = lsame_(compq, "V", (ftnlen)1, (ftnlen)1);
/* Set M to the number of selected eigenvalues. */
*m = 0;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (select[k]) {
++(*m);
}
/* L10: */
}
n1 = *m;
n2 = *n - *m;
nn = n1 * n2;
*info = 0;
lquery = *lwork == -1;
if (wantsp) {
/* Computing MAX */
i__1 = 1, i__2 = nn << 1;
lwmin = max(i__1,i__2);
} else if (lsame_(job, "N", (ftnlen)1, (ftnlen)1)) {
lwmin = 1;
} else if (lsame_(job, "E", (ftnlen)1, (ftnlen)1)) {
lwmin = max(1,nn);
}
if (! lsame_(job, "N", (ftnlen)1, (ftnlen)1) && ! wants && ! wantsp) {
*info = -1;
} else if (! lsame_(compq, "N", (ftnlen)1, (ftnlen)1) && ! wantq) {
*info = -2;
} else if (*n < 0) {
*info = -4;
} else if (*ldt < max(1,*n)) {
*info = -6;
} else if (*ldq < 1 || wantq && *ldq < *n) {
*info = -8;
} else if (*lwork < lwmin && ! lquery) {
*info = -14;
}
if (*info == 0) {
work[1].r = (doublereal) lwmin, work[1].i = 0.;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZTRSEN", &i__1, (ftnlen)6);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*m == *n || *m == 0) {
if (wants) {
*s = 1.;
}
if (wantsp) {
*sep = zlange_("1", n, n, &t[t_offset], ldt, rwork, (ftnlen)1);
}
goto L40;
}
/* Collect the selected eigenvalues at the top left corner of T. */
ks = 0;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (select[k]) {
++ks;
/* Swap the K-th eigenvalue to position KS. */
if (k != ks) {
ztrexc_(compq, n, &t[t_offset], ldt, &q[q_offset], ldq, &k, &
ks, &ierr, (ftnlen)1);
}
}
/* L20: */
}
if (wants) {
/* Solve the Sylvester equation for R: */
/* T11*R - R*T22 = scale*T12 */
zlacpy_("F", &n1, &n2, &t[(n1 + 1) * t_dim1 + 1], ldt, &work[1], &n1,
(ftnlen)1);
ztrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + 1 + (n1
+ 1) * t_dim1], ldt, &work[1], &n1, &scale, &ierr, (ftnlen)1,
(ftnlen)1);
/* Estimate the reciprocal of the condition number of the cluster */
/* of eigenvalues. */
rnorm = zlange_("F", &n1, &n2, &work[1], &n1, rwork, (ftnlen)1);
if (rnorm == 0.) {
*s = 1.;
} else {
*s = scale / (sqrt(scale * scale / rnorm + rnorm) * sqrt(rnorm));
}
}
if (wantsp) {
/* Estimate sep(T11,T22). */
est = 0.;
kase = 0;
L30:
zlacon_(&nn, &work[nn + 1], &work[1], &est, &kase);
if (kase != 0) {
if (kase == 1) {
/* Solve T11*R - R*T22 = scale*X. */
ztrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 +
1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, &
ierr, (ftnlen)1, (ftnlen)1);
} else {
/* Solve T11'*R - R*T22' = scale*X. */
ztrsyl_("C", "C", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 +
1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, &
ierr, (ftnlen)1, (ftnlen)1);
}
goto L30;
}
*sep = scale / est;
}
L40:
/* Copy reordered eigenvalues to W. */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
i__2 = k;
i__3 = k + k * t_dim1;
w[i__2].r = t[i__3].r, w[i__2].i = t[i__3].i;
/* L50: */
}
work[1].r = (doublereal) lwmin, work[1].i = 0.;
return 0;
/* End of ZTRSEN */
} /* ztrsen_ */
/* Subroutine */ int zhpcon_(char *uplo, integer *n, doublecomplex *ap,
integer *ipiv, doublereal *anorm, doublereal *rcond, doublecomplex *
work, 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
=======
ZHPCON estimates the reciprocal of the condition number of a complex
Hermitian packed matrix A using the factorization A = U*D*U**H or
A = L*D*L**H computed by ZHPTRF.
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
Specifies whether the details of the factorization are stored
as an upper or lower triangular matrix.
= 'U': Upper triangular, form is A = U*D*U**H;
= 'L': Lower triangular, form is A = L*D*L**H.
N (input) INTEGER
The order of the matrix A. N >= 0.
AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
The block diagonal matrix D and the multipliers used to
obtain the factor U or L as computed by ZHPTRF, 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 ZHPTRF.
ANORM (input) DOUBLE PRECISION
The 1-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) COMPLEX*16 array, dimension (2*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, i__2;
/* Local variables */
static integer kase, i__;
extern logical lsame_(char *, char *);
static logical upper;
static integer ip;
extern /* Subroutine */ int xerbla_(char *, integer *), zlacon_(
integer *, doublecomplex *, doublecomplex *, doublereal *,
integer *);
static doublereal ainvnm;
extern /* Subroutine */ int zhptrs_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *);
--work;
--ipiv;
--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 = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHPCON", &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 the diagonal matrix D is nonsingular. */
if (upper) {
/* Upper triangular storage: examine D from bottom to top */
ip = *n * (*n + 1) / 2;
for (i__ = *n; i__ >= 1; --i__) {
i__1 = ip;
if (ipiv[i__] > 0 && (ap[i__1].r == 0. && ap[i__1].i == 0.)) {
return 0;
}
ip -= i__;
/* L10: */
}
} else {
/* Lower triangular storage: examine D from top to bottom. */
ip = 1;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = ip;
if (ipiv[i__] > 0 && (ap[i__2].r == 0. && ap[i__2].i == 0.)) {
return 0;
}
ip = ip + *n - i__ + 1;
/* L20: */
}
}
/* Estimate the 1-norm of the inverse. */
kase = 0;
L30:
zlacon_(n, &work[*n + 1], &work[1], &ainvnm, &kase);
if (kase != 0) {
/* Multiply by inv(L*D*L') or inv(U*D*U'). */
zhptrs_(uplo, n, &c__1, &ap[1], &ipiv[1], &work[1], n, info);
goto L30;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.) {
*rcond = 1. / ainvnm / *anorm;
}
return 0;
/* End of ZHPCON */
} /* zhpcon_ */
/* Subroutine */ int zgbrfs_(char *trans, integer *n, integer *kl, integer *
ku, integer *nrhs, doublecomplex *ab, integer *ldab, doublecomplex *
afb, integer *ldafb, integer *ipiv, doublecomplex *b, integer *ldb,
doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr,
doublecomplex *work, doublereal *rwork, integer *info, ftnlen
trans_len)
{
/* System generated locals */
integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static integer i__, j, k;
static doublereal s;
static integer kk;
static doublereal xk;
static integer nz;
static doublereal eps;
static integer kase;
static doublereal safe1, safe2;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int zgbmv_(char *, integer *, integer *, integer *
, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, ftnlen);
static integer count;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal dlamch_(char *, ftnlen);
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zlacon_(
integer *, doublecomplex *, doublecomplex *, doublereal *,
integer *);
static logical notran;
static char transn[1], transt[1];
static doublereal lstres;
extern /* Subroutine */ int zgbtrs_(char *, integer *, integer *, integer
*, integer *, doublecomplex *, integer *, integer *,
doublecomplex *, integer *, integer *, ftnlen);
/* -- 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 */
/* ======= */
/* ZGBRFS improves the computed solution to a system of linear */
/* equations when the coefficient matrix is banded, and provides */
/* error bounds and backward error estimates for the solution. */
/* Arguments */
/* ========= */
/* TRANS (input) CHARACTER*1 */
/* Specifies the form of the system of equations: */
/* = 'N': A * X = B (No transpose) */
/* = 'T': A**T * X = B (Transpose) */
/* = 'C': A**H * X = B (Conjugate transpose) */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* KL (input) INTEGER */
/* The number of subdiagonals within the band of A. KL >= 0. */
/* KU (input) INTEGER */
/* The number of superdiagonals within the band of A. KU >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* AB (input) COMPLEX*16 array, dimension (LDAB,N) */
/* The original band matrix A, stored in rows 1 to KL+KU+1. */
/* The j-th column of A is stored in the j-th column of the */
/* array AB as follows: */
/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
/* AFB (input) COMPLEX*16 array, dimension (LDAFB,N) */
/* Details of the LU factorization of the band matrix A, as */
/* computed by ZGBTRF. U is stored as an upper triangular band */
/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */
/* the multipliers used during the factorization are stored in */
/* rows KL+KU+2 to 2*KL+KU+1. */
/* LDAFB (input) INTEGER */
/* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices from ZGBTRF; for 1<=i<=N, row i of the */
/* matrix was interchanged with row IPIV(i). */
/* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS) */
/* On entry, the solution matrix X, as computed by ZGBTRS. */
/* 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) COMPLEX*16 array, dimension (2*N) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Internal Parameters */
/* =================== */
/* ITMAX is the maximum number of steps of iterative refinement. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
afb_dim1 = *ldafb;
afb_offset = 1 + afb_dim1;
afb -= afb_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--rwork;
/* Function Body */
*info = 0;
notran = lsame_(trans, "N", (ftnlen)1, (ftnlen)1);
if (! notran && ! lsame_(trans, "T", (ftnlen)1, (ftnlen)1) && ! lsame_(
trans, "C", (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 (*nrhs < 0) {
*info = -5;
} else if (*ldab < *kl + *ku + 1) {
*info = -7;
} else if (*ldafb < (*kl << 1) + *ku + 1) {
*info = -9;
} else if (*ldb < max(1,*n)) {
*info = -12;
} else if (*ldx < max(1,*n)) {
*info = -14;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGBRFS", &i__1, (ftnlen)6);
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 *)transn = 'N';
*(unsigned char *)transt = 'C';
} else {
*(unsigned char *)transn = 'C';
*(unsigned char *)transt = 'N';
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
/* Computing MIN */
i__1 = *kl + *ku + 2, i__2 = *n + 1;
nz = min(i__1,i__2);
eps = dlamch_("Epsilon", (ftnlen)7);
safmin = dlamch_("Safe minimum", (ftnlen)12);
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. */
zcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
z__1.r = -1., z__1.i = -0.;
zgbmv_(trans, n, n, kl, ku, &z__1, &ab[ab_offset], ldab, &x[j *
x_dim1 + 1], &c__1, &c_b1, &work[1], &c__1, (ftnlen)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__) {
i__3 = i__ + j * b_dim1;
rwork[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[
i__ + j * b_dim1]), abs(d__2));
/* L30: */
}
/* Compute abs(op(A))*abs(X) + abs(B). */
if (notran) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
kk = *ku + 1 - k;
i__3 = k + j * x_dim1;
xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[k + j *
x_dim1]), abs(d__2));
/* Computing MAX */
i__3 = 1, i__4 = k - *ku;
/* Computing MIN */
i__6 = *n, i__7 = k + *kl;
i__5 = min(i__6,i__7);
for (i__ = max(i__3,i__4); i__ <= i__5; ++i__) {
i__3 = kk + i__ + k * ab_dim1;
rwork[i__] += ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 =
d_imag(&ab[kk + i__ + k * ab_dim1]), abs(d__2))) *
xk;
/* L40: */
}
/* L50: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.;
kk = *ku + 1 - k;
/* Computing MAX */
i__5 = 1, i__3 = k - *ku;
/* Computing MIN */
i__6 = *n, i__7 = k + *kl;
i__4 = min(i__6,i__7);
for (i__ = max(i__5,i__3); i__ <= i__4; ++i__) {
i__5 = kk + i__ + k * ab_dim1;
i__3 = i__ + j * x_dim1;
s += ((d__1 = ab[i__5].r, abs(d__1)) + (d__2 = d_imag(&ab[
kk + i__ + k * ab_dim1]), abs(d__2))) * ((d__3 =
x[i__3].r, abs(d__3)) + (d__4 = d_imag(&x[i__ + j
* x_dim1]), abs(d__4)));
/* L60: */
}
rwork[k] += s;
/* L70: */
}
}
s = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
/* Computing MAX */
i__4 = i__;
d__3 = s, d__4 = ((d__1 = work[i__4].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2))) / rwork[i__];
s = max(d__3,d__4);
} else {
/* Computing MAX */
i__4 = i__;
d__3 = s, d__4 = ((d__1 = work[i__4].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + safe1) / (rwork[i__]
+ safe1);
s = max(d__3,d__4);
}
/* 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. */
zgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &ipiv[1]
, &work[1], n, info, (ftnlen)1);
zaxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &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 ZLACON 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 (rwork[i__] > safe2) {
i__4 = i__;
rwork[i__] = (d__1 = work[i__4].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
;
} else {
i__4 = i__;
rwork[i__] = (d__1 = work[i__4].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ safe1;
}
/* L90: */
}
kase = 0;
L100:
zlacon_(n, &work[*n + 1], &work[1], &ferr[j], &kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(op(A)**H). */
zgbtrs_(transt, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &
ipiv[1], &work[1], n, info, (ftnlen)1);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__4 = i__;
i__5 = i__;
i__3 = i__;
z__1.r = rwork[i__5] * work[i__3].r, z__1.i = rwork[i__5]
* work[i__3].i;
work[i__4].r = z__1.r, work[i__4].i = z__1.i;
/* L110: */
}
} else {
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__4 = i__;
i__5 = i__;
i__3 = i__;
z__1.r = rwork[i__5] * work[i__3].r, z__1.i = rwork[i__5]
* work[i__3].i;
work[i__4].r = z__1.r, work[i__4].i = z__1.i;
/* L120: */
}
zgbtrs_(transn, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &
ipiv[1], &work[1], n, info, (ftnlen)1);
}
goto L100;
}
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__4 = i__ + j * x_dim1;
d__3 = lstres, d__4 = (d__1 = x[i__4].r, abs(d__1)) + (d__2 =
d_imag(&x[i__ + j * x_dim1]), abs(d__2));
lstres = max(d__3,d__4);
/* L130: */
}
if (lstres != 0.) {
ferr[j] /= lstres;
}
/* L140: */
}
return 0;
/* End of ZGBRFS */
} /* zgbrfs_ */
/* Subroutine */ int ztpcon_(char *norm, char *uplo, char *diag, integer *n,
doublecomplex *ap, doublereal *rcond, doublecomplex *work, doublereal
*rwork, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
ZTPCON estimates the reciprocal of the condition number of a packed
triangular matrix A, in either the 1-norm or the infinity-norm.
The norm of A is computed and an estimate is obtained for
norm(inv(A)), then the reciprocal of the condition number is
computed as
RCOND = 1 / ( norm(A) * norm(inv(A)) ).
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.
AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
The upper or lower triangular matrix A, packed columnwise in
a linear array. The j-th column of A is stored in the array
AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
If DIAG = 'U', the diagonal elements of A are not referenced
and are assumed to be 1.
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) COMPLEX*16 array, dimension (2*N)
RWORK (workspace) DOUBLE PRECISION 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
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static integer kase, kase1;
static doublereal scale;
extern logical lsame_(char *, char *);
static doublereal anorm;
static logical upper;
static doublereal xnorm;
extern doublereal dlamch_(char *);
static integer ix;
extern /* Subroutine */ int xerbla_(char *, integer *), zlacon_(
integer *, doublecomplex *, doublecomplex *, doublereal *,
integer *);
static doublereal ainvnm;
extern integer izamax_(integer *, doublecomplex *, integer *);
static logical onenrm;
extern /* Subroutine */ int zdrscl_(integer *, doublereal *,
doublecomplex *, integer *);
static char normin[1];
extern doublereal zlantp_(char *, char *, char *, integer *,
doublecomplex *, doublereal *);
static doublereal smlnum;
static logical nounit;
extern /* Subroutine */ int zlatps_(char *, char *, char *, char *,
integer *, doublecomplex *, doublecomplex *, doublereal *,
doublereal *, integer *);
#define RWORK(I) rwork[(I)-1]
#define WORK(I) work[(I)-1]
#define AP(I) ap[(I)-1]
*info = 0;
upper = lsame_(uplo, "U");
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
nounit = lsame_(diag, "N");
if (! onenrm && ! lsame_(norm, "I")) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (*n < 0) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZTPCON", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*rcond = 1.;
return 0;
}
*rcond = 0.;
smlnum = dlamch_("Safe minimum") * (doublereal) max(1,*n);
/* Compute the norm of the triangular matrix A. */
anorm = zlantp_(norm, uplo, diag, n, &AP(1), &RWORK(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:
zlacon_(n, &WORK(*n + 1), &WORK(1), &ainvnm, &kase);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(A). */
zlatps_(uplo, "No transpose", diag, normin, n, &AP(1), &WORK(
1), &scale, &RWORK(1), info);
} else {
/* Multiply by inv(A'). */
zlatps_(uplo, "Conjugate transpose", diag, normin, n, &AP(1),
&WORK(1), &scale, &RWORK(1), info);
}
*(unsigned char *)normin = 'Y';
/* Multiply by 1/SCALE if doing so will not cause overfl
ow. */
if (scale != 1.) {
ix = izamax_(n, &WORK(1), &c__1);
i__1 = ix;
xnorm = (d__1 = WORK(ix).r, abs(d__1)) + (d__2 = d_imag(&
WORK(ix)), abs(d__2));
if (scale < xnorm * smlnum || scale == 0.) {
goto L20;
}
zdrscl_(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 ZTPCON */
} /* ztpcon_ */
/* Subroutine */ int zgbcon_(char *norm, integer *n, integer *kl, integer *ku,
doublecomplex *ab, integer *ldab, integer *ipiv, doublereal *anorm,
doublereal *rcond, doublecomplex *work, doublereal *rwork, integer *
info, ftnlen norm_len)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3;
doublereal d__1, d__2;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static integer j;
static doublecomplex t;
static integer kd, lm, jp, ix, kase, kase1;
static doublereal scale;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static logical lnoti;
extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal dlamch_(char *, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zlacon_(
integer *, doublecomplex *, doublecomplex *, doublereal *,
integer *);
static doublereal ainvnm;
extern integer izamax_(integer *, doublecomplex *, integer *);
static logical onenrm;
extern /* Subroutine */ int zlatbs_(char *, char *, char *, char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublereal *, doublereal *, integer *, ftnlen, ftnlen, ftnlen,
ftnlen), zdrscl_(integer *, doublereal *, doublecomplex *,
integer *);
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 */
/* ======= */
/* ZGBCON estimates the reciprocal of the condition number of a complex */
/* general band matrix A, in either the 1-norm or the infinity-norm, */
/* using the LU factorization computed by ZGBTRF. */
/* 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) COMPLEX*16 array, dimension (LDAB,N) */
/* Details of the LU factorization of the band matrix A, as */
/* computed by ZGBTRF. 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) COMPLEX*16 array, dimension (2*N) */
/* RWORK (workspace) DOUBLE PRECISION 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 .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--ipiv;
--work;
--rwork;
/* 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_("ZGBCON", &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:
zlacon_(n, &work[*n + 1], &work[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];
i__2 = jp;
t.r = work[i__2].r, t.i = work[i__2].i;
if (jp != j) {
i__2 = jp;
i__3 = j;
work[i__2].r = work[i__3].r, work[i__2].i = work[i__3]
.i;
i__2 = j;
work[i__2].r = t.r, work[i__2].i = t.i;
}
z__1.r = -t.r, z__1.i = -t.i;
zaxpy_(&lm, &z__1, &ab[kd + 1 + j * ab_dim1], &c__1, &
work[j + 1], &c__1);
/* L20: */
}
}
/* Multiply by inv(U). */
i__1 = *kl + *ku;
zlatbs_("Upper", "No transpose", "Non-unit", normin, n, &i__1, &
ab[ab_offset], ldab, &work[1], &scale, &rwork[1], info, (
ftnlen)5, (ftnlen)12, (ftnlen)8, (ftnlen)1);
} else {
/* Multiply by inv(U'). */
i__1 = *kl + *ku;
zlatbs_("Upper", "Conjugate transpose", "Non-unit", normin, n, &
i__1, &ab[ab_offset], ldab, &work[1], &scale, &rwork[1],
info, (ftnlen)5, (ftnlen)19, (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);
i__1 = j;
i__2 = j;
zdotc_(&z__2, &lm, &ab[kd + 1 + j * ab_dim1], &c__1, &
work[j + 1], &c__1);
z__1.r = work[i__2].r - z__2.r, z__1.i = work[i__2].i -
z__2.i;
work[i__1].r = z__1.r, work[i__1].i = z__1.i;
jp = ipiv[j];
if (jp != j) {
i__1 = jp;
t.r = work[i__1].r, t.i = work[i__1].i;
i__1 = jp;
i__2 = j;
work[i__1].r = work[i__2].r, work[i__1].i = work[i__2]
.i;
i__1 = j;
work[i__1].r = t.r, work[i__1].i = t.i;
}
/* L30: */
}
}
}
/* Divide X by 1/SCALE if doing so will not cause overflow. */
*(unsigned char *)normin = 'Y';
if (scale != 1.) {
ix = izamax_(n, &work[1], &c__1);
i__1 = ix;
if (scale < ((d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag(&
work[ix]), abs(d__2))) * smlnum || scale == 0.) {
goto L40;
}
zdrscl_(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 ZGBCON */
} /* zgbcon_ */
/* Subroutine */ int zppcon_(char *uplo, integer *n, doublecomplex *ap,
doublereal *anorm, doublereal *rcond, doublecomplex *work, doublereal
*rwork, 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
=======
ZPPCON estimates the reciprocal of the condition number (in the
1-norm) of a complex Hermitian positive definite packed matrix using
the Cholesky factorization A = U**H*U or A = L*L**H computed by
ZPPTRF.
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) COMPLEX*16 array, dimension (N*(N+1)/2)
The triangular factor U or L from the Cholesky factorization
A = U**H*U or A = L*L**H, 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 Hermitian 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) COMPLEX*16 array, dimension (2*N)
RWORK (workspace) DOUBLE PRECISION 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, d__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static integer kase;
static doublereal scale;
extern logical lsame_(char *, char *);
static logical upper;
extern doublereal dlamch_(char *);
static integer ix;
static doublereal scalel, scaleu;
extern /* Subroutine */ int xerbla_(char *, integer *), zlacon_(
integer *, doublecomplex *, doublecomplex *, doublereal *,
integer *);
static doublereal ainvnm;
extern integer izamax_(integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zdrscl_(integer *, doublereal *,
doublecomplex *, integer *);
static char normin[1];
static doublereal smlnum;
extern /* Subroutine */ int zlatps_(char *, char *, char *, char *,
integer *, doublecomplex *, doublecomplex *, doublereal *,
doublereal *, integer *);
--rwork;
--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_("ZPPCON", &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:
zlacon_(n, &work[*n + 1], &work[1], &ainvnm, &kase);
if (kase != 0) {
if (upper) {
/* Multiply by inv(U'). */
zlatps_("Upper", "Conjugate transpose", "Non-unit", normin, n, &
ap[1], &work[1], &scalel, &rwork[1], info);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(U). */
zlatps_("Upper", "No transpose", "Non-unit", normin, n, &ap[1], &
work[1], &scaleu, &rwork[1], info);
} else {
/* Multiply by inv(L). */
zlatps_("Lower", "No transpose", "Non-unit", normin, n, &ap[1], &
work[1], &scalel, &rwork[1], info);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(L'). */
zlatps_("Lower", "Conjugate transpose", "Non-unit", normin, n, &
ap[1], &work[1], &scaleu, &rwork[1], info);
}
/* Multiply by 1/SCALE if doing so will not cause overflow. */
scale = scalel * scaleu;
if (scale != 1.) {
ix = izamax_(n, &work[1], &c__1);
i__1 = ix;
if (scale < ((d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag(&
work[ix]), abs(d__2))) * smlnum || scale == 0.) {
goto L20;
}
zdrscl_(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 ZPPCON */
} /* zppcon_ */
/* Subroutine */ int ztbcon_(char *norm, char *uplo, char *diag, integer *n,
integer *kd, doublecomplex *ab, integer *ldab, doublereal *rcond,
doublecomplex *work, doublereal *rwork, 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
=======
ZTBCON estimates the reciprocal of the condition number of a
triangular band matrix A, in either the 1-norm or the infinity-norm.
The norm of A is computed and an estimate is obtained for
norm(inv(A)), then the reciprocal of the condition number is
computed as
RCOND = 1 / ( norm(A) * norm(inv(A)) ).
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.
KD (input) INTEGER
The number of superdiagonals or subdiagonals of the
triangular band matrix A. KD >= 0.
AB (input) COMPLEX*16 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.
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) COMPLEX*16 array, dimension (2*N)
RWORK (workspace) DOUBLE PRECISION 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 ab_dim1, ab_offset, i__1;
doublereal d__1, d__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static integer kase, kase1;
static doublereal scale;
extern logical lsame_(char *, char *);
static doublereal anorm;
static logical upper;
static doublereal xnorm;
extern doublereal dlamch_(char *);
static integer ix;
extern /* Subroutine */ int xerbla_(char *, integer *), zlacon_(
integer *, doublecomplex *, doublecomplex *, doublereal *,
integer *);
static doublereal ainvnm;
extern integer izamax_(integer *, doublecomplex *, integer *);
extern doublereal zlantb_(char *, char *, char *, integer *, integer *,
doublecomplex *, integer *, doublereal *);
static logical onenrm;
extern /* Subroutine */ int zlatbs_(char *, char *, char *, char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublereal *, doublereal *, integer *), zdrscl_(integer *, doublereal *, doublecomplex *,
integer *);
static char normin[1];
static doublereal smlnum;
static logical nounit;
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
--work;
--rwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
nounit = lsame_(diag, "N");
if (! onenrm && ! lsame_(norm, "I")) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*kd < 0) {
*info = -5;
} else if (*ldab < *kd + 1) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZTBCON", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*rcond = 1.;
return 0;
}
*rcond = 0.;
smlnum = dlamch_("Safe minimum") * (doublereal) max(*n,1);
/* Compute the 1-norm of the triangular matrix A or A'. */
anorm = zlantb_(norm, uplo, diag, n, kd, &ab[ab_offset], ldab, &rwork[1]);
/* Continue only if ANORM > 0. */
if (anorm > 0.) {
/* Estimate the 1-norm of the inverse of A. */
ainvnm = 0.;
*(unsigned char *)normin = 'N';
if (onenrm) {
kase1 = 1;
} else {
kase1 = 2;
}
kase = 0;
L10:
zlacon_(n, &work[*n + 1], &work[1], &ainvnm, &kase);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(A). */
zlatbs_(uplo, "No transpose", diag, normin, n, kd, &ab[
ab_offset], ldab, &work[1], &scale, &rwork[1], info);
} else {
/* Multiply by inv(A'). */
zlatbs_(uplo, "Conjugate transpose", diag, normin, n, kd, &ab[
ab_offset], ldab, &work[1], &scale, &rwork[1], info);
}
*(unsigned char *)normin = 'Y';
/* Multiply by 1/SCALE if doing so will not cause overflow. */
if (scale != 1.) {
ix = izamax_(n, &work[1], &c__1);
i__1 = ix;
xnorm = (d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag(&
work[ix]), abs(d__2));
if (scale < xnorm * smlnum || scale == 0.) {
goto L20;
}
zdrscl_(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 ZTBCON */
} /* ztbcon_ */
/* Subroutine */ int ztrsna_(char *job, char *howmny, logical *select,
integer *n, doublecomplex *t, integer *ldt, doublecomplex *vl,
integer *ldvl, doublecomplex *vr, integer *ldvr, doublereal *s,
doublereal *sep, integer *mm, integer *m, doublecomplex *work,
integer *ldwork, doublereal *rwork, 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
=======
ZTRSNA estimates reciprocal condition numbers for specified
eigenvalues and/or right eigenvectors of a complex upper triangular
matrix T (or of any matrix Q*T*Q**H with Q unitary).
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 j-th eigenpair, SELECT(j) 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) COMPLEX*16 array, dimension (LDT,N)
The upper triangular matrix T.
LDT (input) INTEGER
The leading dimension of the array T. LDT >= max(1,N).
VL (input) COMPLEX*16 array, dimension (LDVL,M)
If JOB = 'E' or 'B', VL must contain left eigenvectors of T
(or of any Q*T*Q**H with Q unitary), corresponding to the
eigenpairs specified by HOWMNY and SELECT. The eigenvectors
must be stored in consecutive columns of VL, as returned by
ZHSEIN or ZTREVC.
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) COMPLEX*16 array, dimension (LDVR,M)
If JOB = 'E' or 'B', VR must contain right eigenvectors of T
(or of any Q*T*Q**H with Q unitary), corresponding to the
eigenpairs specified by HOWMNY and SELECT. The eigenvectors
must be stored in consecutive columns of VR, as returned by
ZHSEIN or ZTREVC.
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. 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.
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) COMPLEX*16 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.
RWORK (workspace) DOUBLE PRECISION array, dimension (N)
If JOB = 'E', RWORK 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 */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset,
work_dim1, work_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2;
doublecomplex z__1;
/* Builtin functions */
double z_abs(doublecomplex *), d_imag(doublecomplex *);
/* Local variables */
static integer kase, ierr;
static doublecomplex prod;
static doublereal lnrm, rnrm;
static integer i__, j, k;
static doublereal scale;
extern logical lsame_(char *, char *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static doublecomplex dummy[1];
static logical wants;
static doublereal xnorm;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_(
char *);
static integer ks, ix;
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal bignum;
static logical wantbh;
extern /* Subroutine */ int zlacon_(integer *, doublecomplex *,
doublecomplex *, doublereal *, integer *);
extern integer izamax_(integer *, doublecomplex *, integer *);
static logical somcon;
extern /* Subroutine */ int zdrscl_(integer *, doublereal *,
doublecomplex *, integer *);
static char normin[1];
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static doublereal smlnum;
static logical wantsp;
extern /* Subroutine */ int zlatrs_(char *, char *, char *, char *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublereal *, doublereal *, integer *), ztrexc_(char *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, integer *, integer *);
static doublereal eps, est;
#define work_subscr(a_1,a_2) (a_2)*work_dim1 + a_1
#define work_ref(a_1,a_2) work[work_subscr(a_1,a_2)]
#define t_subscr(a_1,a_2) (a_2)*t_dim1 + a_1
#define t_ref(a_1,a_2) t[t_subscr(a_1,a_2)]
#define vl_subscr(a_1,a_2) (a_2)*vl_dim1 + a_1
#define vl_ref(a_1,a_2) vl[vl_subscr(a_1,a_2)]
#define vr_subscr(a_1,a_2) (a_2)*vr_dim1 + a_1
#define vr_ref(a_1,a_2) vr[vr_subscr(a_1,a_2)]
--select;
t_dim1 = *ldt;
t_offset = 1 + t_dim1 * 1;
t -= t_offset;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1 * 1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1 * 1;
vr -= vr_offset;
--s;
--sep;
work_dim1 = *ldwork;
work_offset = 1 + work_dim1 * 1;
work -= work_offset;
--rwork;
/* Function Body */
wantbh = lsame_(job, "B");
wants = lsame_(job, "E") || wantbh;
wantsp = lsame_(job, "V") || wantbh;
somcon = lsame_(howmny, "S");
/* Set M to the number of eigenpairs for which condition numbers are
to be computed. */
if (somcon) {
*m = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (select[j]) {
++(*m);
}
/* L10: */
}
} else {
*m = *n;
}
*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 if (*mm < *m) {
*info = -13;
} else if (*ldwork < 1 || wantsp && *ldwork < *n) {
*info = -16;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZTRSNA", &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] = z_abs(&t_ref(1, 1));
}
return 0;
}
/* Get machine constants */
eps = dlamch_("P");
smlnum = dlamch_("S") / eps;
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
ks = 1;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (somcon) {
if (! select[k]) {
goto L50;
}
}
if (wants) {
/* Compute the reciprocal condition number of the k-th
eigenvalue. */
zdotc_(&z__1, n, &vr_ref(1, ks), &c__1, &vl_ref(1, ks), &c__1);
prod.r = z__1.r, prod.i = z__1.i;
rnrm = dznrm2_(n, &vr_ref(1, ks), &c__1);
lnrm = dznrm2_(n, &vl_ref(1, ks), &c__1);
s[ks] = z_abs(&prod) / (rnrm * lnrm);
}
if (wantsp) {
/* Estimate the reciprocal condition number of the k-th
eigenvector.
Copy the matrix T to the array WORK and swap the k-th
diagonal element to the (1,1) position. */
zlacpy_("Full", n, n, &t[t_offset], ldt, &work[work_offset],
ldwork);
ztrexc_("No Q", n, &work[work_offset], ldwork, dummy, &c__1, &k, &
c__1, &ierr);
/* Form C = T22 - lambda*I in WORK(2:N,2:N). */
i__2 = *n;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = work_subscr(i__, i__);
i__4 = work_subscr(i__, i__);
i__5 = work_subscr(1, 1);
z__1.r = work[i__4].r - work[i__5].r, z__1.i = work[i__4].i -
work[i__5].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L20: */
}
/* Estimate a lower bound for the 1-norm of inv(C'). The 1st
and (N+1)th columns of WORK are used to store work vectors. */
sep[ks] = 0.;
est = 0.;
kase = 0;
*(unsigned char *)normin = 'N';
L30:
i__2 = *n - 1;
zlacon_(&i__2, &work_ref(1, *n + 1), &work[work_offset], &est, &
kase);
if (kase != 0) {
if (kase == 1) {
/* Solve C'*x = scale*b */
i__2 = *n - 1;
zlatrs_("Upper", "Conjugate transpose", "Nonunit", normin,
&i__2, &work_ref(2, 2), ldwork, &work[
work_offset], &scale, &rwork[1], &ierr);
} else {
/* Solve C*x = scale*b */
i__2 = *n - 1;
zlatrs_("Upper", "No transpose", "Nonunit", normin, &i__2,
&work_ref(2, 2), ldwork, &work[work_offset], &
scale, &rwork[1], &ierr);
}
*(unsigned char *)normin = 'Y';
if (scale != 1.) {
/* Multiply by 1/SCALE if doing so will not cause
overflow. */
i__2 = *n - 1;
ix = izamax_(&i__2, &work[work_offset], &c__1);
i__2 = work_subscr(ix, 1);
xnorm = (d__1 = work[i__2].r, abs(d__1)) + (d__2 = d_imag(
&work_ref(ix, 1)), abs(d__2));
if (scale < xnorm * smlnum || scale == 0.) {
goto L40;
}
zdrscl_(n, &scale, &work[work_offset], &c__1);
}
goto L30;
}
sep[ks] = 1. / max(est,smlnum);
}
L40:
++ks;
L50:
;
}
return 0;
/* End of ZTRSNA */
} /* ztrsna_ */
/* Subroutine */ int zgerfs_(char *trans, integer *n, integer *nrhs,
doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf,
integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x,
integer *ldx, doublereal *ferr, doublereal *berr, doublecomplex *work,
doublereal *rwork, 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
=======
ZGERFS 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)
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) COMPLEX*16 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) COMPLEX*16 array, dimension (LDAF,N)
The factors L and U from the factorization A = P*L*U
as computed by ZGETRF.
LDAF (input) INTEGER
The leading dimension of the array AF. LDAF >= max(1,N).
IPIV (input) INTEGER array, dimension (N)
The pivot indices from ZGETRF; for 1<=i<=N, row i of the
matrix was interchanged with row IPIV(i).
B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)
On entry, the solution matrix X, as computed by ZGETRS.
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) COMPLEX*16 array, dimension (2*N)
RWORK (workspace) DOUBLE PRECISION 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 doublecomplex c_b1 = {1.,0.};
static integer c__1 = 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, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static integer kase;
static doublereal safe1, safe2;
static integer i__, j, k;
static doublereal s;
extern logical lsame_(char *, char *);
static integer count;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *),
zcopy_(integer *, doublecomplex *, integer *, doublecomplex *,
integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *);
extern doublereal dlamch_(char *);
static doublereal xk;
static integer nz;
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *), zlacon_(
integer *, doublecomplex *, doublecomplex *, doublereal *,
integer *);
static logical notran;
static char transn[1], transt[1];
static doublereal lstres;
extern /* Subroutine */ int zgetrs_(char *, integer *, integer *,
doublecomplex *, integer *, integer *, doublecomplex *, integer *,
integer *);
static doublereal eps;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define x_subscr(a_1,a_2) (a_2)*x_dim1 + a_1
#define x_ref(a_1,a_2) x[x_subscr(a_1,a_2)]
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;
--rwork;
/* 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_("ZGERFS", &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 *)transn = 'N';
*(unsigned char *)transt = 'C';
} else {
*(unsigned char *)transn = 'C';
*(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. */
zcopy_(n, &b_ref(1, j), &c__1, &work[1], &c__1);
z__1.r = -1., z__1.i = 0.;
zgemv_(trans, n, n, &z__1, &a[a_offset], lda, &x_ref(1, j), &c__1, &
c_b1, &work[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__) {
i__3 = b_subscr(i__, j);
rwork[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&
b_ref(i__, j)), abs(d__2));
/* L30: */
}
/* Compute abs(op(A))*abs(X) + abs(B). */
if (notran) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = x_subscr(k, j);
xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x_ref(k,
j)), abs(d__2));
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = a_subscr(i__, k);
rwork[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
d_imag(&a_ref(i__, k)), abs(d__2))) * 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__) {
i__4 = a_subscr(i__, k);
i__5 = x_subscr(i__, j);
s += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&
a_ref(i__, k)), abs(d__2))) * ((d__3 = x[i__5].r,
abs(d__3)) + (d__4 = d_imag(&x_ref(i__, j)), abs(
d__4)));
/* L60: */
}
rwork[k] += s;
/* L70: */
}
}
s = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
/* Computing MAX */
i__3 = i__;
d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2))) / rwork[i__];
s = max(d__3,d__4);
} else {
/* Computing MAX */
i__3 = i__;
d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + safe1) / (rwork[i__]
+ safe1);
s = max(d__3,d__4);
}
/* 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. */
zgetrs_(trans, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[1],
n, info);
zaxpy_(n, &c_b1, &work[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 ZLACON 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 (rwork[i__] > safe2) {
i__3 = i__;
rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
;
} else {
i__3 = i__;
rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ safe1;
}
/* L90: */
}
kase = 0;
L100:
zlacon_(n, &work[*n + 1], &work[1], &ferr[j], &kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(op(A)**H). */
zgetrs_(transt, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &
work[1], n, info);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__;
z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L110: */
}
} else {
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__;
z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L120: */
}
zgetrs_(transn, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &
work[1], n, info);
}
goto L100;
}
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = x_subscr(i__, j);
d__3 = lstres, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
d_imag(&x_ref(i__, j)), abs(d__2));
lstres = max(d__3,d__4);
/* L130: */
}
if (lstres != 0.) {
ferr[j] /= lstres;
}
/* L140: */
}
return 0;
/* End of ZGERFS */
} /* zgerfs_ */
/* Subroutine */ int zsyrfs_(char *uplo, integer *n, integer *nrhs,
doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf,
integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x,
integer *ldx, doublereal *ferr, doublereal *berr, doublecomplex *work,
doublereal *rwork, integer *info, ftnlen uplo_len)
{
/* 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, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static integer i__, j, k;
static doublereal s, xk;
static integer nz;
static doublereal eps;
static integer kase;
static doublereal safe1, safe2;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static integer count;
static logical upper;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *), zsymv_(
char *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, ftnlen);
extern doublereal dlamch_(char *, ftnlen);
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zlacon_(
integer *, doublecomplex *, doublecomplex *, doublereal *,
integer *);
static doublereal lstres;
extern /* Subroutine */ int zsytrs_(char *, integer *, integer *,
doublecomplex *, integer *, integer *, doublecomplex *, integer *,
integer *, ftnlen);
/* -- 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 */
/* ======= */
/* ZSYRFS 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) COMPLEX*16 array, dimension (LDA,N) */
/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */
/* upper triangular part of A contains the upper triangular part */
/* of the matrix A, and the strictly lower triangular part of A */
/* is not referenced. If UPLO = 'L', the leading N-by-N lower */
/* triangular part of A contains the lower triangular part of */
/* the matrix A, and the strictly upper triangular part of A is */
/* not referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* AF (input) COMPLEX*16 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 ZSYTRF. */
/* 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 ZSYTRF. */
/* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS) */
/* On entry, the solution matrix X, as computed by ZSYTRS. */
/* 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) COMPLEX*16 array, dimension (2*N) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Internal Parameters */
/* =================== */
/* ITMAX is the maximum number of steps of iterative refinement. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--rwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
*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_("ZSYRFS", &i__1, (ftnlen)6);
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", (ftnlen)7);
safmin = dlamch_("Safe minimum", (ftnlen)12);
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 */
zcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
z__1.r = -1., z__1.i = -0.;
zsymv_(uplo, n, &z__1, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1, &
c_b1, &work[1], &c__1, (ftnlen)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__) {
i__3 = i__ + j * b_dim1;
rwork[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[
i__ + j * b_dim1]), abs(d__2));
/* L30: */
}
/* Compute abs(A)*abs(X) + abs(B). */
if (upper) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.;
i__3 = k + j * x_dim1;
xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[k + j *
x_dim1]), abs(d__2));
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + k * a_dim1;
rwork[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
d_imag(&a[i__ + k * a_dim1]), abs(d__2))) * xk;
i__4 = i__ + k * a_dim1;
i__5 = i__ + j * x_dim1;
s += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a[
i__ + k * a_dim1]), abs(d__2))) * ((d__3 = x[i__5]
.r, abs(d__3)) + (d__4 = d_imag(&x[i__ + j *
x_dim1]), abs(d__4)));
/* L40: */
}
i__3 = k + k * a_dim1;
rwork[k] = rwork[k] + ((d__1 = a[i__3].r, abs(d__1)) + (d__2 =
d_imag(&a[k + k * a_dim1]), abs(d__2))) * xk + s;
/* L50: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.;
i__3 = k + j * x_dim1;
xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[k + j *
x_dim1]), abs(d__2));
i__3 = k + k * a_dim1;
rwork[k] += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&
a[k + k * a_dim1]), abs(d__2))) * xk;
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
i__4 = i__ + k * a_dim1;
rwork[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
d_imag(&a[i__ + k * a_dim1]), abs(d__2))) * xk;
i__4 = i__ + k * a_dim1;
i__5 = i__ + j * x_dim1;
s += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a[
i__ + k * a_dim1]), abs(d__2))) * ((d__3 = x[i__5]
.r, abs(d__3)) + (d__4 = d_imag(&x[i__ + j *
x_dim1]), abs(d__4)));
/* L60: */
}
rwork[k] += s;
/* L70: */
}
}
s = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
/* Computing MAX */
i__3 = i__;
d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2))) / rwork[i__];
s = max(d__3,d__4);
} else {
/* Computing MAX */
i__3 = i__;
d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + safe1) / (rwork[i__]
+ safe1);
s = max(d__3,d__4);
}
/* 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. */
zsytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[1],
n, info, (ftnlen)1);
zaxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &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 ZLACON 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 (rwork[i__] > safe2) {
i__3 = i__;
rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
;
} else {
i__3 = i__;
rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ safe1;
}
/* L90: */
}
kase = 0;
L100:
zlacon_(n, &work[*n + 1], &work[1], &ferr[j], &kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(A'). */
zsytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
1], n, info, (ftnlen)1);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__;
z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L110: */
}
} else if (kase == 2) {
/* Multiply by inv(A)*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__;
z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L120: */
}
zsytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
1], n, info, (ftnlen)1);
}
goto L100;
}
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = i__ + j * x_dim1;
d__3 = lstres, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
d_imag(&x[i__ + j * x_dim1]), abs(d__2));
lstres = max(d__3,d__4);
/* L130: */
}
if (lstres != 0.) {
ferr[j] /= lstres;
}
/* L140: */
}
return 0;
/* End of ZSYRFS */
} /* zsyrfs_ */
/* Subroutine */ int zgecon_(char *norm, integer *n, doublecomplex *a,
integer *lda, doublereal *anorm, doublereal *rcond, doublecomplex *
work, doublereal *rwork, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
ZGECON estimates the reciprocal of the condition number of a general
complex matrix A, in either the 1-norm or the infinity-norm, using
the LU factorization computed by ZGETRF.
An estimate is obtained for norm(inv(A)), and the reciprocal of the
condition number is computed as
RCOND = 1 / ( norm(A) * norm(inv(A)) ).
Arguments
=========
NORM (input) CHARACTER*1
Specifies whether the 1-norm condition number or the
infinity-norm condition number is required:
= '1' or 'O': 1-norm;
= 'I': Infinity-norm.
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input) COMPLEX*16 array, dimension (LDA,N)
The factors L and U from the factorization A = P*L*U
as computed by ZGETRF.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
ANORM (input) DOUBLE PRECISION
If NORM = '1' or 'O', the 1-norm of the original matrix A.
If NORM = 'I', the infinity-norm of the original matrix A.
RCOND (output) DOUBLE PRECISION
The reciprocal of the condition number of the matrix A,
computed as RCOND = 1/(norm(A) * norm(inv(A))).
WORK (workspace) COMPLEX*16 array, dimension (2*N)
RWORK (workspace) DOUBLE PRECISION array, dimension (2*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
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1;
doublereal d__1, d__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static integer kase, kase1;
static doublereal scale;
extern logical lsame_(char *, char *);
extern doublereal dlamch_(char *);
static doublereal sl;
static integer ix;
static doublereal su;
extern /* Subroutine */ int xerbla_(char *, integer *), zlacon_(
integer *, doublecomplex *, doublecomplex *, doublereal *,
integer *);
static doublereal ainvnm;
extern integer izamax_(integer *, doublecomplex *, integer *);
static logical onenrm;
extern /* Subroutine */ int zdrscl_(integer *, doublereal *,
doublecomplex *, integer *);
static char normin[1];
static doublereal smlnum;
extern /* Subroutine */ int zlatrs_(char *, char *, char *, char *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublereal *, doublereal *, integer *);
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
*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 (*lda < max(1,*n)) {
*info = -4;
} else if (*anorm < 0.) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGECON", &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 norm of inv(A). */
ainvnm = 0.;
*(unsigned char *)normin = 'N';
if (onenrm) {
kase1 = 1;
} else {
kase1 = 2;
}
kase = 0;
L10:
zlacon_(n, &WORK(*n + 1), &WORK(1), &ainvnm, &kase);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(L). */
zlatrs_("Lower", "No transpose", "Unit", normin, n, &A(1,1),
lda, &WORK(1), &sl, &RWORK(1), info);
/* Multiply by inv(U). */
zlatrs_("Upper", "No transpose", "Non-unit", normin, n, &A(1,1), lda, &WORK(1), &su, &RWORK(*n + 1), info);
} else {
/* Multiply by inv(U'). */
zlatrs_("Upper", "Conjugate transpose", "Non-unit", normin, n, &A(1,1), lda, &WORK(1), &su, &RWORK(*n + 1), info);
/* Multiply by inv(L'). */
zlatrs_("Lower", "Conjugate transpose", "Unit", normin, n, &A(1,1), lda, &WORK(1), &sl, &RWORK(1), info);
}
/* Divide X by 1/(SL*SU) if doing so will not cause overflow.
*/
scale = sl * su;
*(unsigned char *)normin = 'Y';
if (scale != 1.) {
ix = izamax_(n, &WORK(1), &c__1);
i__1 = ix;
if (scale < ((d__1 = WORK(ix).r, abs(d__1)) + (d__2 = d_imag(&
WORK(ix)), abs(d__2))) * smlnum || scale == 0.) {
goto L20;
}
zdrscl_(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 ZGECON */
} /* zgecon_ */
void
zgsrfs(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
* =======
*
* ZGSRFS 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 = _Z, 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 = _Z, Mtype = TRLU.
*
* U (input) SuperMatrix*
* The factor U from the factorization Pr*A*Pc=L*U as computed by
* zgstrf(). Use column-wise storage scheme,
* i.e., U has types: Stype = NC, Dtype = _Z, 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 = _Z, 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 = _Z, Mtype = GE.
* On entry, the solution matrix X, as computed by zgstrs().
* 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;
doublecomplex ndone = {-1., 0.};
doublecomplex done = {1., 0.};
/* Local variables */
NCformat *Astore;
doublecomplex *Aval;
SuperMatrix Bjcol;
DNformat *Bstore, *Xstore, *Bjcol_store;
doublecomplex *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];
doublecomplex *work;
double *rwork;
int *iwork;
extern double dlamch_(char *);
extern int zlacon_(int *, doublecomplex *, doublecomplex *, double *, int *);
#ifdef _CRAY
extern int CCOPY(int *, doublecomplex *, int *, doublecomplex *, int *);
extern int CSAXPY(int *, doublecomplex *, doublecomplex *, int *, doublecomplex *, int *);
#else
extern int zcopy_(int *, doublecomplex *, int *, doublecomplex *, int *);
extern int zaxpy_(int *, doublecomplex *, doublecomplex *, int *, doublecomplex *, 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 != _Z || A->Mtype != GE )
*info = -2;
else if ( L->nrow != L->ncol || L->nrow < 0 ||
L->Stype != SC || L->Dtype != _Z || L->Mtype != TRLU )
*info = -3;
else if ( U->nrow != U->ncol || U->nrow < 0 ||
U->Stype != NC || U->Dtype != _Z || U->Mtype != TRU )
*info = -4;
else if ( ldb < MAX(0, A->nrow) ||
B->Stype != DN || B->Dtype != _Z || B->Mtype != GE )
*info = -10;
else if ( ldx < MAX(0, A->nrow) ||
X->Stype != DN || X->Dtype != _Z || X->Mtype != GE )
*info = -11;
if (*info != 0) {
i = -(*info);
xerbla_("zgsrfs", &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 = doublecomplexMalloc(2*A->nrow);
rwork = (double *) SUPERLU_MALLOC( A->nrow * sizeof(double) );
iwork = intMalloc(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
CCOPY(&A->nrow, Bptr, &ione, work, &ione);
#else
zcopy_(&A->nrow, Bptr, &ione, work, &ione);
#endif
sp_zgemv(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] = z_abs1( &Bptr[i] );
/* Compute abs(op(A))*abs(X) + abs(B). */
if (notran) {
for (k = 0; k < A->ncol; ++k) {
xk = z_abs1( &Xptr[k] );
for (i = Astore->colptr[k]; i < Astore->colptr[k+1]; ++i)
rwork[Astore->rowind[i]] += z_abs1(&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 += z_abs1(&Aval[i]) * z_abs1(&Xptr[irow]);
}
rwork[k] += s;
}
}
s = 0.;
for (i = 0; i < A->nrow; ++i) {
if (rwork[i] > safe2)
s = MAX( s, z_abs1(&work[i]) / rwork[i] );
else
s = MAX( s, (z_abs1(&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. */
zgstrs (trans, L, U, perm_r, perm_c, &Bjcol, info);
#ifdef _CRAY
CAXPY(&A->nrow, &done, work, &ione,
&Xmat[j*ldx], &ione);
#else
zaxpy_(&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 ZLACON 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] = z_abs1( &Bptr[i] );
/* Compute abs(op(A))*abs(X) + abs(B). */
if ( notran ) {
for (k = 0; k < A->ncol; ++k) {
xk = z_abs1( &Xptr[k] );
for (i = Astore->colptr[k]; i < Astore->colptr[k+1]; ++i)
rwork[Astore->rowind[i]] += z_abs1(&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 = z_abs1( &Xptr[irow] );
s += z_abs1(&Aval[i]) * xk;
}
rwork[k] += s;
}
}
for (i = 0; i < A->nrow; ++i)
if (rwork[i] > safe2)
rwork[i] = z_abs(&work[i]) + (iwork[i]+1)*eps*rwork[i];
else
rwork[i] = z_abs(&work[i])+(iwork[i]+1)*eps*rwork[i]+safe1;
kase = 0;
do {
zlacon_(&A->nrow, &work[A->nrow], work,
&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) {
zd_mult(&work[i], &work[i], C[i]);
}
else if ( !notran && rowequ )
for (i = 0; i < A->nrow; ++i) {
zd_mult(&work[i], &work[i], R[i]);
}
zgstrs (transt, L, U, perm_r, perm_c, &Bjcol, info);
for (i = 0; i < A->nrow; ++i) {
zd_mult(&work[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) {
zd_mult(&work[i], &work[i], rwork[i]);
}
zgstrs (trans, L, U, perm_r, perm_c, &Bjcol, info);
if ( notran && colequ )
for (i = 0; i < A->ncol; ++i) {
zd_mult(&work[i], &work[i], C[i]);
}
else if ( !notran && rowequ )
for (i = 0; i < A->ncol; ++i) {
zd_mult(&work[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] * z_abs1( &Xptr[i]) );
} else if ( !notran && rowequ ) {
for (i = 0; i < A->nrow; ++i)
lstres = MAX( lstres, R[i] * z_abs1( &Xptr[i]) );
} else {
for (i = 0; i < A->nrow; ++i)
lstres = MAX( lstres, z_abs1( &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;
} /* zgsrfs */
void
zgscon(char *norm, SuperMatrix *L, SuperMatrix *U,
double anorm, double *rcond, SuperLUStat_t *stat, int *info)
{
/* Local variables */
int kase, kase1, onenrm, i;
double ainvnm;
doublecomplex *work;
extern int zrscl_(int *, doublecomplex *, doublecomplex *, int *);
extern int zlacon_(int *, doublecomplex *, doublecomplex *, 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 != SLU_SC || L->Dtype != SLU_Z || L->Mtype != SLU_TRLU)
*info = -2;
else if (U->nrow < 0 || U->nrow != U->ncol ||
U->Stype != SLU_NC || U->Dtype != SLU_Z || U->Mtype != SLU_TRU)
*info = -3;
if (*info != 0) {
i = -(*info);
xerbla_("zgscon", &i);
return;
}
/* Quick return if possible */
*rcond = 0.;
if ( L->nrow == 0 || U->nrow == 0) {
*rcond = 1.;
return;
}
work = doublecomplexCalloc( 3*L->nrow );
if ( !work )
ABORT("Malloc fails for work arrays in zgscon.");
/* Estimate the norm of inv(A). */
ainvnm = 0.;
if ( onenrm ) kase1 = 1;
else kase1 = 2;
kase = 0;
do {
zlacon_(&L->nrow, &work[L->nrow], &work[0], &ainvnm, &kase);
if (kase == 0) break;
if (kase == kase1) {
/* Multiply by inv(L). */
sp_ztrsv("L", "No trans", "Unit", L, U, &work[0], stat, info);
/* Multiply by inv(U). */
sp_ztrsv("U", "No trans", "Non-unit", L, U, &work[0], stat, info);
} else {
/* Multiply by inv(U'). */
sp_ztrsv("U", "Transpose", "Non-unit", L, U, &work[0], stat, info);
/* Multiply by inv(L'). */
sp_ztrsv("L", "Transpose", "Unit", L, U, &work[0], stat, info);
}
} while ( kase != 0 );
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.) *rcond = (1. / ainvnm) / anorm;
SUPERLU_FREE (work);
return;
} /* zgscon */
/* Subroutine */ int zhecon_(char *uplo, integer *n, doublecomplex *a,
integer *lda, integer *ipiv, doublereal *anorm, doublereal *rcond,
doublecomplex *work, integer *info, ftnlen uplo_len)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
/* Local variables */
static integer i__, kase;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static logical upper;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zlacon_(
integer *, doublecomplex *, doublecomplex *, doublereal *,
integer *);
static doublereal ainvnm;
extern /* Subroutine */ int zhetrs_(char *, integer *, integer *,
doublecomplex *, integer *, integer *, doublecomplex *, integer *,
integer *, ftnlen);
/* -- 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 */
/* ======= */
/* ZHECON estimates the reciprocal of the condition number of a complex */
/* Hermitian matrix A using the factorization A = U*D*U**H or */
/* A = L*D*L**H computed by ZHETRF. */
/* 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 */
/* Specifies whether the details of the factorization are stored */
/* as an upper or lower triangular matrix. */
/* = 'U': Upper triangular, form is A = U*D*U**H; */
/* = 'L': Lower triangular, form is A = L*D*L**H. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The block diagonal matrix D and the multipliers used to */
/* obtain the factor U or L as computed by ZHETRF. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* IPIV (input) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D */
/* as determined by ZHETRF. */
/* ANORM (input) DOUBLE PRECISION */
/* The 1-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) COMPLEX*16 array, dimension (2*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;
--ipiv;
--work;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
} else if (*anorm < 0.) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHECON", &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;
}
/* Check that the diagonal matrix D is nonsingular. */
if (upper) {
/* Upper triangular storage: examine D from bottom to top */
for (i__ = *n; i__ >= 1; --i__) {
i__1 = i__ + i__ * a_dim1;
if (ipiv[i__] > 0 && (a[i__1].r == 0. && a[i__1].i == 0.)) {
return 0;
}
/* L10: */
}
} else {
/* Lower triangular storage: examine D from top to bottom. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + i__ * a_dim1;
if (ipiv[i__] > 0 && (a[i__2].r == 0. && a[i__2].i == 0.)) {
return 0;
}
/* L20: */
}
}
/* Estimate the 1-norm of the inverse. */
kase = 0;
L30:
zlacon_(n, &work[*n + 1], &work[1], &ainvnm, &kase);
if (kase != 0) {
/* Multiply by inv(L*D*L') or inv(U*D*U'). */
zhetrs_(uplo, n, &c__1, &a[a_offset], lda, &ipiv[1], &work[1], n,
info, (ftnlen)1);
goto L30;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.) {
*rcond = 1. / ainvnm / *anorm;
}
return 0;
/* End of ZHECON */
} /* zhecon_ */
/* Subroutine */ int ztrcon_(char *norm, char *uplo, char *diag, integer *n,
doublecomplex *a, integer *lda, doublereal *rcond, doublecomplex *
work, doublereal *rwork, integer *info, ftnlen norm_len, ftnlen
uplo_len, ftnlen diag_len)
{
/* System generated locals */
integer a_dim1, a_offset, i__1;
doublereal d__1, d__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static integer ix, kase, kase1;
static doublereal scale;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static doublereal anorm;
static logical upper;
static doublereal xnorm;
extern doublereal dlamch_(char *, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zlacon_(
integer *, doublecomplex *, doublecomplex *, doublereal *,
integer *);
static doublereal ainvnm;
extern integer izamax_(integer *, doublecomplex *, integer *);
static logical onenrm;
extern /* Subroutine */ int zdrscl_(integer *, doublereal *,
doublecomplex *, integer *);
static char normin[1];
extern doublereal zlantr_(char *, char *, char *, integer *, integer *,
doublecomplex *, integer *, doublereal *, ftnlen, ftnlen, ftnlen);
static doublereal smlnum;
static logical nounit;
extern /* Subroutine */ int zlatrs_(char *, char *, char *, char *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublereal *, doublereal *, integer *, ftnlen, ftnlen, ftnlen,
ftnlen);
/* -- 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 */
/* ======= */
/* ZTRCON 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) COMPLEX*16 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) COMPLEX*16 array, dimension (2*N) */
/* RWORK (workspace) DOUBLE PRECISION 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 .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--work;
--rwork;
/* 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_("ZTRCON", &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 = zlantr_(norm, uplo, diag, n, n, &a[a_offset], lda, &rwork[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:
zlacon_(n, &work[*n + 1], &work[1], &ainvnm, &kase);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(A). */
zlatrs_(uplo, "No transpose", diag, normin, n, &a[a_offset],
lda, &work[1], &scale, &rwork[1], info, (ftnlen)1, (
ftnlen)12, (ftnlen)1, (ftnlen)1);
} else {
/* Multiply by inv(A'). */
zlatrs_(uplo, "Conjugate transpose", diag, normin, n, &a[
a_offset], lda, &work[1], &scale, &rwork[1], info, (
ftnlen)1, (ftnlen)19, (ftnlen)1, (ftnlen)1);
}
*(unsigned char *)normin = 'Y';
/* Multiply by 1/SCALE if doing so will not cause overflow. */
if (scale != 1.) {
ix = izamax_(n, &work[1], &c__1);
i__1 = ix;
xnorm = (d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag(&
work[ix]), abs(d__2));
if (scale < xnorm * smlnum || scale == 0.) {
goto L20;
}
zdrscl_(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 ZTRCON */
} /* ztrcon_ */
/*! \brief
*
* <pre>
* Purpose
* =======
*
* ZGSRFS 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_Z, 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_Z, Mtype = SLU_TRLU.
*
* U (input) SuperMatrix*
* The factor U from the factorization Pr*A*Pc=L*U as computed by
* zgstrf(). Use column-wise storage scheme,
* i.e., U has types: Stype = SLU_NC, Dtype = SLU_Z, 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_Z, 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_Z, Mtype = SLU_GE.
* On entry, the solution matrix X, as computed by zgstrs().
* 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
zgsrfs(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;
doublecomplex ndone = {-1., 0.};
doublecomplex done = {1., 0.};
/* Local variables */
NCformat *Astore;
doublecomplex *Aval;
SuperMatrix Bjcol;
DNformat *Bstore, *Xstore, *Bjcol_store;
doublecomplex *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;
doublecomplex *work;
double *rwork;
int *iwork;
extern double dlamch_(char *);
extern int zlacon_(int *, doublecomplex *, doublecomplex *, double *, int *);
#ifdef _CRAY
extern int CCOPY(int *, doublecomplex *, int *, doublecomplex *, int *);
extern int CSAXPY(int *, doublecomplex *, doublecomplex *, int *, doublecomplex *, int *);
#else
extern int zcopy_(int *, doublecomplex *, int *, doublecomplex *, int *);
extern int zaxpy_(int *, doublecomplex *, doublecomplex *, int *, doublecomplex *, 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_Z || A->Mtype != SLU_GE )
*info = -2;
else if ( L->nrow != L->ncol || L->nrow < 0 ||
L->Stype != SLU_SC || L->Dtype != SLU_Z || L->Mtype != SLU_TRLU )
*info = -3;
else if ( U->nrow != U->ncol || U->nrow < 0 ||
U->Stype != SLU_NC || U->Dtype != SLU_Z || U->Mtype != SLU_TRU )
*info = -4;
else if ( ldb < SUPERLU_MAX(0, A->nrow) ||
B->Stype != SLU_DN || B->Dtype != SLU_Z || B->Mtype != SLU_GE )
*info = -10;
else if ( ldx < SUPERLU_MAX(0, A->nrow) ||
X->Stype != SLU_DN || X->Dtype != SLU_Z || X->Mtype != SLU_GE )
*info = -11;
if (*info != 0) {
i = -(*info);
xerbla_("zgsrfs", &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 = doublecomplexMalloc(2*A->nrow);
rwork = (double *) SUPERLU_MALLOC( A->nrow * sizeof(double) );
iwork = intMalloc(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
CCOPY(&A->nrow, Bptr, &ione, work, &ione);
#else
zcopy_(&A->nrow, Bptr, &ione, work, &ione);
#endif
sp_zgemv(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] = z_abs1( &Bptr[i] );
/* Compute abs(op(A))*abs(X) + abs(B). */
if (notran) {
for (k = 0; k < A->ncol; ++k) {
xk = z_abs1( &Xptr[k] );
for (i = Astore->colptr[k]; i < Astore->colptr[k+1]; ++i)
rwork[Astore->rowind[i]] += z_abs1(&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 += z_abs1(&Aval[i]) * z_abs1(&Xptr[irow]);
}
rwork[k] += s;
}
}
s = 0.;
for (i = 0; i < A->nrow; ++i) {
if (rwork[i] > safe2) {
s = SUPERLU_MAX( s, z_abs1(&work[i]) / rwork[i] );
} else if ( rwork[i] != 0.0 ) {
s = SUPERLU_MAX( s, (z_abs1(&work[i]) + safe1) / 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. */
zgstrs (trans, L, U, perm_c, perm_r, &Bjcol, stat, info);
#ifdef _CRAY
CAXPY(&A->nrow, &done, work, &ione,
&Xmat[j*ldx], &ione);
#else
zaxpy_(&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 ZLACON 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] = z_abs1( &Bptr[i] );
/* Compute abs(op(A))*abs(X) + abs(B). */
if ( notran ) {
for (k = 0; k < A->ncol; ++k) {
xk = z_abs1( &Xptr[k] );
for (i = Astore->colptr[k]; i < Astore->colptr[k+1]; ++i)
rwork[Astore->rowind[i]] += z_abs1(&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 = z_abs1( &Xptr[irow] );
s += z_abs1(&Aval[i]) * xk;
}
rwork[k] += s;
}
}
for (i = 0; i < A->nrow; ++i)
if (rwork[i] > safe2)
rwork[i] = z_abs(&work[i]) + (iwork[i]+1)*eps*rwork[i];
else
rwork[i] = z_abs(&work[i])+(iwork[i]+1)*eps*rwork[i]+safe1;
kase = 0;
do {
zlacon_(&A->nrow, &work[A->nrow], work,
&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) {
zd_mult(&work[i], &work[i], C[i]);
}
else if ( !notran && rowequ )
for (i = 0; i < A->nrow; ++i) {
zd_mult(&work[i], &work[i], R[i]);
}
zgstrs (transt, L, U, perm_c, perm_r, &Bjcol, stat, info);
for (i = 0; i < A->nrow; ++i) {
zd_mult(&work[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) {
zd_mult(&work[i], &work[i], rwork[i]);
}
zgstrs (trans, L, U, perm_c, perm_r, &Bjcol, stat, info);
if ( notran && colequ )
for (i = 0; i < A->ncol; ++i) {
zd_mult(&work[i], &work[i], C[i]);
}
else if ( !notran && rowequ )
for (i = 0; i < A->ncol; ++i) {
zd_mult(&work[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] * z_abs1( &Xptr[i]) );
} else if ( !notran && rowequ ) {
for (i = 0; i < A->nrow; ++i)
lstres = SUPERLU_MAX( lstres, R[i] * z_abs1( &Xptr[i]) );
} else {
for (i = 0; i < A->nrow; ++i)
lstres = SUPERLU_MAX( lstres, z_abs1( &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;
} /* zgsrfs */
/* Subroutine */ int zgtrfs_(char *trans, integer *n, integer *nrhs,
doublecomplex *dl, doublecomplex *d__, doublecomplex *du,
doublecomplex *dlf, doublecomplex *df, doublecomplex *duf,
doublecomplex *du2, integer *ipiv, doublecomplex *b, integer *ldb,
doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr,
doublecomplex *work, doublereal *rwork, integer *info, ftnlen
trans_len)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5,
i__6, i__7, i__8, i__9;
doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10,
d__11, d__12, d__13, d__14;
doublecomplex z__1;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static integer i__, j;
static doublereal s;
static integer nz;
static doublereal eps;
static integer kase;
static doublereal safe1, safe2;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static integer count;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal dlamch_(char *, ftnlen);
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zlacon_(
integer *, doublecomplex *, doublecomplex *, doublereal *,
integer *), zlagtm_(char *, integer *, integer *, doublereal *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, integer *, doublereal *, doublecomplex *, integer *, ftnlen);
static logical notran;
static char transn[1], transt[1];
static doublereal lstres;
extern /* Subroutine */ int zgttrs_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, integer *, doublecomplex *, integer *, integer *, ftnlen);
/* -- 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 */
/* ======= */
/* ZGTRFS 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) */
/* 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) COMPLEX*16 array, dimension (N-1) */
/* The (n-1) subdiagonal elements of A. */
/* D (input) COMPLEX*16 array, dimension (N) */
/* The diagonal elements of A. */
/* DU (input) COMPLEX*16 array, dimension (N-1) */
/* The (n-1) superdiagonal elements of A. */
/* DLF (input) COMPLEX*16 array, dimension (N-1) */
/* The (n-1) multipliers that define the matrix L from the */
/* LU factorization of A as computed by ZGTTRF. */
/* DF (input) COMPLEX*16 array, dimension (N) */
/* The n diagonal elements of the upper triangular matrix U from */
/* the LU factorization of A. */
/* DUF (input) COMPLEX*16 array, dimension (N-1) */
/* The (n-1) elements of the first superdiagonal of U. */
/* DU2 (input) COMPLEX*16 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) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS) */
/* On entry, the solution matrix X, as computed by ZGTTRS. */
/* 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) COMPLEX*16 array, dimension (2*N) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Internal Parameters */
/* =================== */
/* ITMAX is the maximum number of steps of iterative refinement. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--dl;
--d__;
--du;
--dlf;
--df;
--duf;
--du2;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--rwork;
/* Function Body */
*info = 0;
notran = lsame_(trans, "N", (ftnlen)1, (ftnlen)1);
if (! notran && ! lsame_(trans, "T", (ftnlen)1, (ftnlen)1) && ! lsame_(
trans, "C", (ftnlen)1, (ftnlen)1)) {
*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_("ZGTRFS", &i__1, (ftnlen)6);
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 *)transn = 'N';
*(unsigned char *)transt = 'C';
} else {
*(unsigned char *)transn = 'C';
*(unsigned char *)transt = 'N';
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = 4;
eps = dlamch_("Epsilon", (ftnlen)7);
safmin = dlamch_("Safe minimum", (ftnlen)12);
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. */
zcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
zlagtm_(trans, n, &c__1, &c_b18, &dl[1], &d__[1], &du[1], &x[j *
x_dim1 + 1], ldx, &c_b19, &work[1], n, (ftnlen)1);
/* Compute abs(op(A))*abs(x) + abs(b) for use in the backward */
/* error bound. */
if (notran) {
if (*n == 1) {
i__2 = j * b_dim1 + 1;
i__3 = j * x_dim1 + 1;
rwork[1] = (d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b[
j * b_dim1 + 1]), abs(d__2)) + ((d__3 = d__[1].r, abs(
d__3)) + (d__4 = d_imag(&d__[1]), abs(d__4))) * ((
d__5 = x[i__3].r, abs(d__5)) + (d__6 = d_imag(&x[j *
x_dim1 + 1]), abs(d__6)));
} else {
i__2 = j * b_dim1 + 1;
i__3 = j * x_dim1 + 1;
i__4 = j * x_dim1 + 2;
rwork[1] = (d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b[
j * b_dim1 + 1]), abs(d__2)) + ((d__3 = d__[1].r, abs(
d__3)) + (d__4 = d_imag(&d__[1]), abs(d__4))) * ((
d__5 = x[i__3].r, abs(d__5)) + (d__6 = d_imag(&x[j *
x_dim1 + 1]), abs(d__6))) + ((d__7 = du[1].r, abs(
d__7)) + (d__8 = d_imag(&du[1]), abs(d__8))) * ((d__9
= x[i__4].r, abs(d__9)) + (d__10 = d_imag(&x[j *
x_dim1 + 2]), abs(d__10)));
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = i__ + j * b_dim1;
i__4 = i__ - 1;
i__5 = i__ - 1 + j * x_dim1;
i__6 = i__;
i__7 = i__ + j * x_dim1;
i__8 = i__;
i__9 = i__ + 1 + j * x_dim1;
rwork[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 =
d_imag(&b[i__ + j * b_dim1]), abs(d__2)) + ((d__3
= dl[i__4].r, abs(d__3)) + (d__4 = d_imag(&dl[i__
- 1]), abs(d__4))) * ((d__5 = x[i__5].r, abs(d__5)
) + (d__6 = d_imag(&x[i__ - 1 + j * x_dim1]), abs(
d__6))) + ((d__7 = d__[i__6].r, abs(d__7)) + (
d__8 = d_imag(&d__[i__]), abs(d__8))) * ((d__9 =
x[i__7].r, abs(d__9)) + (d__10 = d_imag(&x[i__ +
j * x_dim1]), abs(d__10))) + ((d__11 = du[i__8].r,
abs(d__11)) + (d__12 = d_imag(&du[i__]), abs(
d__12))) * ((d__13 = x[i__9].r, abs(d__13)) + (
d__14 = d_imag(&x[i__ + 1 + j * x_dim1]), abs(
d__14)));
/* L30: */
}
i__2 = *n + j * b_dim1;
i__3 = *n - 1;
i__4 = *n - 1 + j * x_dim1;
i__5 = *n;
i__6 = *n + j * x_dim1;
rwork[*n] = (d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b[
*n + j * b_dim1]), abs(d__2)) + ((d__3 = dl[i__3].r,
abs(d__3)) + (d__4 = d_imag(&dl[*n - 1]), abs(d__4)))
* ((d__5 = x[i__4].r, abs(d__5)) + (d__6 = d_imag(&x[*
n - 1 + j * x_dim1]), abs(d__6))) + ((d__7 = d__[i__5]
.r, abs(d__7)) + (d__8 = d_imag(&d__[*n]), abs(d__8)))
* ((d__9 = x[i__6].r, abs(d__9)) + (d__10 = d_imag(&
x[*n + j * x_dim1]), abs(d__10)));
}
} else {
if (*n == 1) {
i__2 = j * b_dim1 + 1;
i__3 = j * x_dim1 + 1;
rwork[1] = (d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b[
j * b_dim1 + 1]), abs(d__2)) + ((d__3 = d__[1].r, abs(
d__3)) + (d__4 = d_imag(&d__[1]), abs(d__4))) * ((
d__5 = x[i__3].r, abs(d__5)) + (d__6 = d_imag(&x[j *
x_dim1 + 1]), abs(d__6)));
} else {
i__2 = j * b_dim1 + 1;
i__3 = j * x_dim1 + 1;
i__4 = j * x_dim1 + 2;
rwork[1] = (d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b[
j * b_dim1 + 1]), abs(d__2)) + ((d__3 = d__[1].r, abs(
d__3)) + (d__4 = d_imag(&d__[1]), abs(d__4))) * ((
d__5 = x[i__3].r, abs(d__5)) + (d__6 = d_imag(&x[j *
x_dim1 + 1]), abs(d__6))) + ((d__7 = dl[1].r, abs(
d__7)) + (d__8 = d_imag(&dl[1]), abs(d__8))) * ((d__9
= x[i__4].r, abs(d__9)) + (d__10 = d_imag(&x[j *
x_dim1 + 2]), abs(d__10)));
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = i__ + j * b_dim1;
i__4 = i__ - 1;
i__5 = i__ - 1 + j * x_dim1;
i__6 = i__;
i__7 = i__ + j * x_dim1;
i__8 = i__;
i__9 = i__ + 1 + j * x_dim1;
rwork[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 =
d_imag(&b[i__ + j * b_dim1]), abs(d__2)) + ((d__3
= du[i__4].r, abs(d__3)) + (d__4 = d_imag(&du[i__
- 1]), abs(d__4))) * ((d__5 = x[i__5].r, abs(d__5)
) + (d__6 = d_imag(&x[i__ - 1 + j * x_dim1]), abs(
d__6))) + ((d__7 = d__[i__6].r, abs(d__7)) + (
d__8 = d_imag(&d__[i__]), abs(d__8))) * ((d__9 =
x[i__7].r, abs(d__9)) + (d__10 = d_imag(&x[i__ +
j * x_dim1]), abs(d__10))) + ((d__11 = dl[i__8].r,
abs(d__11)) + (d__12 = d_imag(&dl[i__]), abs(
d__12))) * ((d__13 = x[i__9].r, abs(d__13)) + (
d__14 = d_imag(&x[i__ + 1 + j * x_dim1]), abs(
d__14)));
/* L40: */
}
i__2 = *n + j * b_dim1;
i__3 = *n - 1;
i__4 = *n - 1 + j * x_dim1;
i__5 = *n;
i__6 = *n + j * x_dim1;
rwork[*n] = (d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b[
*n + j * b_dim1]), abs(d__2)) + ((d__3 = du[i__3].r,
abs(d__3)) + (d__4 = d_imag(&du[*n - 1]), abs(d__4)))
* ((d__5 = x[i__4].r, abs(d__5)) + (d__6 = d_imag(&x[*
n - 1 + j * x_dim1]), abs(d__6))) + ((d__7 = d__[i__5]
.r, abs(d__7)) + (d__8 = d_imag(&d__[*n]), abs(d__8)))
* ((d__9 = x[i__6].r, abs(d__9)) + (d__10 = d_imag(&
x[*n + j * x_dim1]), abs(d__10)));
}
}
/* Compute componentwise relative backward error from formula */
/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */
/* where abs(Z) is the componentwise absolute value of the matrix */
/* or vector Z. If the i-th component of the denominator is less */
/* than SAFE2, then SAFE1 is added to the i-th components of the */
/* numerator and denominator before dividing. */
s = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
/* Computing MAX */
i__3 = i__;
d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2))) / rwork[i__];
s = max(d__3,d__4);
} else {
/* Computing MAX */
i__3 = i__;
d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + safe1) / (rwork[i__]
+ safe1);
s = max(d__3,d__4);
}
/* L50: */
}
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. */
zgttrs_(trans, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[
1], &work[1], n, info, (ftnlen)1);
zaxpy_(n, &c_b26, &work[1], &c__1, &x[j * x_dim1 + 1], &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 ZLACON 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 (rwork[i__] > safe2) {
i__3 = i__;
rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
;
} else {
i__3 = i__;
rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ safe1;
}
/* L60: */
}
kase = 0;
L70:
zlacon_(n, &work[*n + 1], &work[1], &ferr[j], &kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(op(A)**H). */
zgttrs_(transt, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], &
ipiv[1], &work[1], n, info, (ftnlen)1);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__;
z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L80: */
}
} else {
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__;
z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L90: */
}
zgttrs_(transn, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], &
ipiv[1], &work[1], n, info, (ftnlen)1);
}
goto L70;
}
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = i__ + j * x_dim1;
d__3 = lstres, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
d_imag(&x[i__ + j * x_dim1]), abs(d__2));
lstres = max(d__3,d__4);
/* L100: */
}
if (lstres != 0.) {
ferr[j] /= lstres;
}
/* L110: */
}
return 0;
/* End of ZGTRFS */
} /* zgtrfs_ */
/* Subroutine */ int ztbrfs_(char *uplo, char *trans, char *diag, integer *n,
integer *kd, integer *nrhs, doublecomplex *ab, integer *ldab,
doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *
rwork, 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
=======
ZTBRFS 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 ZTBTRS or some other
means before entering this routine. ZTBRFS 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)
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) COMPLEX*16 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) COMPLEX*16 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) COMPLEX*16 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) COMPLEX*16 array, dimension (2*N)
RWORK (workspace) DOUBLE PRECISION 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
Function Body */
/* Table of constant values */
static integer c__1 = 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, d__4;
doublecomplex z__1;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static integer kase;
static doublereal safe1, safe2;
static integer i, j, k;
static doublereal s;
extern logical lsame_(char *, char *);
static logical upper;
extern /* Subroutine */ int ztbmv_(char *, char *, char *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *), zcopy_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *), ztbsv_(char *, char *,
char *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zaxpy_(
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *);
static doublereal xk;
static integer nz;
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *), zlacon_(
integer *, doublecomplex *, doublecomplex *, doublereal *,
integer *);
static logical notran;
static char transn[1], transt[1];
static logical nounit;
static doublereal lstres, eps;
#define FERR(I) ferr[(I)-1]
#define BERR(I) berr[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]
#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");
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_("ZTBRFS", &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 = 'C';
} else {
*(unsigned char *)transn = 'C';
*(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 <= *nrhs; ++j) {
/* Compute residual R = B - op(A) * X,
where op(A) = A, A**T, or A**H, depending on TRANS. */
zcopy_(n, &X(1,j), &c__1, &WORK(1), &c__1);
ztbmv_(uplo, trans, diag, n, kd, &AB(1,1), ldab, &WORK(1), &
c__1);
z__1.r = -1., z__1.i = 0.;
zaxpy_(n, &z__1, &B(1,j), &c__1, &WORK(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 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) {
i__3 = i + j * b_dim1;
RWORK(i) = (d__1 = B(i,j).r, abs(d__1)) + (d__2 = d_imag(&B(i,j)), abs(d__2));
/* L20: */
}
if (notran) {
/* Compute abs(A)*abs(X) + abs(B). */
if (upper) {
if (nounit) {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
i__3 = k + j * x_dim1;
xk = (d__1 = X(k,j).r, abs(d__1)) + (d__2 = d_imag(&
X(k,j)), abs(d__2));
/* Computing MAX */
i__3 = 1, i__4 = k - *kd;
i__5 = k;
for (i = max(1,k-*kd); i <= k; ++i) {
i__3 = *kd + 1 + i - k + k * ab_dim1;
RWORK(i) += ((d__1 = AB(*kd+1+i-k,k).r, abs(d__1)) + (
d__2 = d_imag(&AB(*kd+1+i-k,k)), abs(d__2))) * xk;
/* L30: */
}
/* L40: */
}
} else {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
i__5 = k + j * x_dim1;
xk = (d__1 = X(k,j).r, abs(d__1)) + (d__2 = d_imag(&
X(k,j)), abs(d__2));
/* Computing MAX */
i__5 = 1, i__3 = k - *kd;
i__4 = k - 1;
for (i = max(1,k-*kd); i <= k-1; ++i) {
i__5 = *kd + 1 + i - k + k * ab_dim1;
RWORK(i) += ((d__1 = AB(*kd+1+i-k,k).r, abs(d__1)) + (
d__2 = d_imag(&AB(*kd+1+i-k,k)), abs(d__2))) * xk;
/* L50: */
}
RWORK(k) += xk;
/* L60: */
}
}
} else {
if (nounit) {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
i__4 = k + j * x_dim1;
xk = (d__1 = X(k,j).r, abs(d__1)) + (d__2 = d_imag(&
X(k,j)), abs(d__2));
/* Computing MIN */
i__5 = *n, i__3 = k + *kd;
i__4 = min(i__5,i__3);
for (i = k; i <= min(*n,k+*kd); ++i) {
i__5 = i + 1 - k + k * ab_dim1;
RWORK(i) += ((d__1 = AB(i+1-k,k).r, abs(d__1)) + (
d__2 = d_imag(&AB(i+1-k,k)
), abs(d__2))) * xk;
/* L70: */
}
/* L80: */
}
} else {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
i__4 = k + j * x_dim1;
xk = (d__1 = X(k,j).r, abs(d__1)) + (d__2 = d_imag(&
X(k,j)), abs(d__2));
/* Computing MIN */
i__5 = *n, i__3 = k + *kd;
i__4 = min(i__5,i__3);
for (i = k + 1; i <= min(*n,k+*kd); ++i) {
i__5 = i + 1 - k + k * ab_dim1;
RWORK(i) += ((d__1 = AB(i+1-k,k).r, abs(d__1)) + (
d__2 = d_imag(&AB(i+1-k,k)
), abs(d__2))) * xk;
/* L90: */
}
RWORK(k) += xk;
/* L100: */
}
}
}
} else {
/* Compute abs(A**H)*abs(X) + abs(B). */
if (upper) {
if (nounit) {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
s = 0.;
/* Computing MAX */
i__4 = 1, i__5 = k - *kd;
i__3 = k;
for (i = max(1,k-*kd); i <= k; ++i) {
i__4 = *kd + 1 + i - k + k * ab_dim1;
i__5 = i + j * x_dim1;
s += ((d__1 = AB(*kd+1+i-k,k).r, abs(d__1)) + (d__2 =
d_imag(&AB(*kd+1+i-k,k))
, abs(d__2))) * ((d__3 = X(i,j).r, abs(
d__3)) + (d__4 = d_imag(&X(i,j)
), abs(d__4)));
/* L110: */
}
RWORK(k) += s;
/* L120: */
}
} else {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
i__3 = k + j * x_dim1;
s = (d__1 = X(k,j).r, abs(d__1)) + (d__2 = d_imag(&X(k,j)), abs(d__2));
/* Computing MAX */
i__3 = 1, i__4 = k - *kd;
i__5 = k - 1;
for (i = max(1,k-*kd); i <= k-1; ++i) {
i__3 = *kd + 1 + i - k + k * ab_dim1;
i__4 = i + j * x_dim1;
s += ((d__1 = AB(*kd+1+i-k,k).r, abs(d__1)) + (d__2 =
d_imag(&AB(*kd+1+i-k,k))
, abs(d__2))) * ((d__3 = X(i,j).r, abs(
d__3)) + (d__4 = d_imag(&X(i,j)
), abs(d__4)));
/* L130: */
}
RWORK(k) += s;
/* L140: */
}
}
} else {
if (nounit) {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
s = 0.;
/* Computing MIN */
i__3 = *n, i__4 = k + *kd;
i__5 = min(i__3,i__4);
for (i = k; i <= min(*n,k+*kd); ++i) {
i__3 = i + 1 - k + k * ab_dim1;
i__4 = i + j * x_dim1;
s += ((d__1 = AB(i+1-k,k).r, abs(d__1)) + (d__2 =
d_imag(&AB(i+1-k,k)), abs(
d__2))) * ((d__3 = X(i,j).r, abs(d__3))
+ (d__4 = d_imag(&X(i,j)), abs(
d__4)));
/* L150: */
}
RWORK(k) += s;
/* L160: */
}
} else {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
i__5 = k + j * x_dim1;
s = (d__1 = X(k,j).r, abs(d__1)) + (d__2 = d_imag(&X(k,j)), abs(d__2));
/* Computing MIN */
i__3 = *n, i__4 = k + *kd;
i__5 = min(i__3,i__4);
for (i = k + 1; i <= min(*n,k+*kd); ++i) {
i__3 = i + 1 - k + k * ab_dim1;
i__4 = i + j * x_dim1;
s += ((d__1 = AB(i+1-k,k).r, abs(d__1)) + (d__2 =
d_imag(&AB(i+1-k,k)), abs(
d__2))) * ((d__3 = X(i,j).r, abs(d__3))
+ (d__4 = d_imag(&X(i,j)), abs(
d__4)));
/* L170: */
}
RWORK(k) += s;
/* L180: */
}
}
}
}
s = 0.;
i__2 = *n;
for (i = 1; i <= *n; ++i) {
if (RWORK(i) > safe2) {
/* Computing MAX */
i__5 = i;
d__3 = s, d__4 = ((d__1 = WORK(i).r, abs(d__1)) + (d__2 =
d_imag(&WORK(i)), abs(d__2))) / RWORK(i);
s = max(d__3,d__4);
} else {
/* Computing MAX */
i__5 = i;
d__3 = s, d__4 = ((d__1 = WORK(i).r, abs(d__1)) + (d__2 =
d_imag(&WORK(i)), abs(d__2)) + safe1) / (RWORK(i) +
safe1);
s = max(d__3,d__4);
}
/* 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 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 ZLACON 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 (RWORK(i) > safe2) {
i__5 = i;
RWORK(i) = (d__1 = WORK(i).r, abs(d__1)) + (d__2 = d_imag(&
WORK(i)), abs(d__2)) + nz * eps * RWORK(i);
} else {
i__5 = i;
RWORK(i) = (d__1 = WORK(i).r, abs(d__1)) + (d__2 = d_imag(&
WORK(i)), abs(d__2)) + nz * eps * RWORK(i) + safe1;
}
/* L200: */
}
kase = 0;
L210:
zlacon_(n, &WORK(*n + 1), &WORK(1), &FERR(j), &kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(op(A)**H). */
ztbsv_(uplo, transt, diag, n, kd, &AB(1,1), ldab, &WORK(
1), &c__1);
i__2 = *n;
for (i = 1; i <= *n; ++i) {
i__5 = i;
i__3 = i;
i__4 = i;
z__1.r = RWORK(i) * WORK(i).r, z__1.i = RWORK(i)
* WORK(i).i;
WORK(i).r = z__1.r, WORK(i).i = z__1.i;
/* L220: */
}
} else {
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
i__5 = i;
i__3 = i;
i__4 = i;
z__1.r = RWORK(i) * WORK(i).r, z__1.i = RWORK(i)
* WORK(i).i;
WORK(i).r = z__1.r, WORK(i).i = z__1.i;
/* L230: */
}
ztbsv_(uplo, transn, diag, n, kd, &AB(1,1), ldab, &WORK(
1), &c__1);
}
goto L210;
}
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i = 1; i <= *n; ++i) {
/* Computing MAX */
i__5 = i + j * x_dim1;
d__3 = lstres, d__4 = (d__1 = X(i,j).r, abs(d__1)) + (d__2 =
d_imag(&X(i,j)), abs(d__2));
lstres = max(d__3,d__4);
/* L240: */
}
if (lstres != 0.) {
FERR(j) /= lstres;
}
/* L250: */
}
return 0;
/* End of ZTBRFS */
} /* ztbrfs_ */
/* Subroutine */ int zpbrfs_(char *uplo, integer *n, integer *kd, integer *
nrhs, doublecomplex *ab, integer *ldab, doublecomplex *afb, integer *
ldafb, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *
rwork, 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
=======
ZPBRFS improves the computed solution to a system of linear
equations when the coefficient matrix is Hermitian positive definite
and banded, 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.
KD (input) INTEGER
The number of superdiagonals of the matrix A if UPLO = 'U',
or the number of subdiagonals if UPLO = 'L'. 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 triangle of the Hermitian band matrix A,
stored in the first KD+1 rows of the array. The j-th column
of A is stored in the j-th column of the array AB as follows:
if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD+1.
AFB (input) COMPLEX*16 array, dimension (LDAFB,N)
The triangular factor U or L from the Cholesky factorization
A = U**H*U or A = L*L**H of the band matrix A as computed by
ZPBTRF, in the same storage format as A (see AB).
LDAFB (input) INTEGER
The leading dimension of the array AFB. LDAFB >= KD+1.
B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)
On entry, the solution matrix X, as computed by ZPBTRS.
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) COMPLEX*16 array, dimension (2*N)
RWORK (workspace) DOUBLE PRECISION 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 doublecomplex c_b1 = {1.,0.};
static integer c__1 = 1;
/* System generated locals */
integer ab_dim1, ab_offset, afb_dim1, afb_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, d__4;
doublecomplex z__1;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static integer kase;
static doublereal safe1, safe2;
static integer i, j, k, l;
static doublereal s;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zhbmv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static integer count;
static logical upper;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal dlamch_(char *);
static doublereal xk;
static integer nz;
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *), zlacon_(
integer *, doublecomplex *, doublecomplex *, doublereal *,
integer *);
static doublereal lstres;
extern /* Subroutine */ int zpbtrs_(char *, integer *, integer *, integer
*, doublecomplex *, integer *, doublecomplex *, integer *,
integer *);
static doublereal eps;
#define FERR(I) ferr[(I)-1]
#define BERR(I) berr[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]
#define AFB(I,J) afb[(I)-1 + ((J)-1)* ( *ldafb)]
#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 (*kd < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (*ldab < *kd + 1) {
*info = -6;
} else if (*ldafb < *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_("ZPBRFS", &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
Computing MIN */
i__1 = *n + 1, i__2 = (*kd << 1) + 2;
nz = min(i__1,i__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 <= *nrhs; ++j) {
count = 1;
lstres = 3.;
L20:
/* Loop until stopping criterion is satisfied.
Compute residual R = B - A * X */
zcopy_(n, &B(1,j), &c__1, &WORK(1), &c__1);
z__1.r = -1., z__1.i = 0.;
zhbmv_(uplo, n, kd, &z__1, &AB(1,1), ldab, &X(1,j), &
c__1, &c_b1, &WORK(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) {
i__3 = i + j * b_dim1;
RWORK(i) = (d__1 = B(i,j).r, abs(d__1)) + (d__2 = d_imag(&B(i,j)), abs(d__2));
/* L30: */
}
/* Compute abs(A)*abs(X) + abs(B). */
if (upper) {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
s = 0.;
i__3 = k + j * x_dim1;
xk = (d__1 = X(k,j).r, abs(d__1)) + (d__2 = d_imag(&X(k,j)), abs(d__2));
l = *kd + 1 - k;
/* Computing MAX */
i__3 = 1, i__4 = k - *kd;
i__5 = k - 1;
for (i = max(1,k-*kd); i <= k-1; ++i) {
i__3 = l + i + k * ab_dim1;
RWORK(i) += ((d__1 = AB(l+i,k).r, abs(d__1)) + (d__2 =
d_imag(&AB(l+i,k)), abs(d__2))) *
xk;
i__3 = l + i + k * ab_dim1;
i__4 = i + j * x_dim1;
s += ((d__1 = AB(l+i,k).r, abs(d__1)) + (d__2 = d_imag(&AB(l+i,k)), abs(d__2))) * ((d__3 = X(i,j).r, abs(d__3)) + (d__4 = d_imag(&X(i,j)), abs(d__4)));
/* L40: */
}
i__5 = *kd + 1 + k * ab_dim1;
RWORK(k) = RWORK(k) + (d__1 = AB(*kd+1,k).r, abs(d__1)) * xk + s;
/* L50: */
}
} else {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
s = 0.;
i__5 = k + j * x_dim1;
xk = (d__1 = X(k,j).r, abs(d__1)) + (d__2 = d_imag(&X(k,j)), abs(d__2));
i__5 = k * ab_dim1 + 1;
RWORK(k) += (d__1 = AB(1,k).r, abs(d__1)) * xk;
l = 1 - k;
/* Computing MIN */
i__3 = *n, i__4 = k + *kd;
i__5 = min(i__3,i__4);
for (i = k + 1; i <= min(*n,k+*kd); ++i) {
i__3 = l + i + k * ab_dim1;
RWORK(i) += ((d__1 = AB(l+i,k).r, abs(d__1)) + (d__2 =
d_imag(&AB(l+i,k)), abs(d__2))) *
xk;
i__3 = l + i + k * ab_dim1;
i__4 = i + j * x_dim1;
s += ((d__1 = AB(l+i,k).r, abs(d__1)) + (d__2 = d_imag(&AB(l+i,k)), abs(d__2))) * ((d__3 = X(i,j).r, abs(d__3)) + (d__4 = d_imag(&X(i,j)), abs(d__4)));
/* L60: */
}
RWORK(k) += s;
/* L70: */
}
}
s = 0.;
i__2 = *n;
for (i = 1; i <= *n; ++i) {
if (RWORK(i) > safe2) {
/* Computing MAX */
i__5 = i;
d__3 = s, d__4 = ((d__1 = WORK(i).r, abs(d__1)) + (d__2 =
d_imag(&WORK(i)), abs(d__2))) / RWORK(i);
s = max(d__3,d__4);
} else {
/* Computing MAX */
i__5 = i;
d__3 = s, d__4 = ((d__1 = WORK(i).r, abs(d__1)) + (d__2 =
d_imag(&WORK(i)), abs(d__2)) + safe1) / (RWORK(i) +
safe1);
s = max(d__3,d__4);
}
/* 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. */
zpbtrs_(uplo, n, kd, &c__1, &AFB(1,1), ldafb, &WORK(1), n,
info);
zaxpy_(n, &c_b1, &WORK(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 ZLACON 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 (RWORK(i) > safe2) {
i__5 = i;
RWORK(i) = (d__1 = WORK(i).r, abs(d__1)) + (d__2 = d_imag(&
WORK(i)), abs(d__2)) + nz * eps * RWORK(i);
} else {
i__5 = i;
RWORK(i) = (d__1 = WORK(i).r, abs(d__1)) + (d__2 = d_imag(&
WORK(i)), abs(d__2)) + nz * eps * RWORK(i) + safe1;
}
/* L90: */
}
kase = 0;
L100:
zlacon_(n, &WORK(*n + 1), &WORK(1), &FERR(j), &kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(A'). */
zpbtrs_(uplo, n, kd, &c__1, &AFB(1,1), ldafb, &WORK(1),
n, info);
i__2 = *n;
for (i = 1; i <= *n; ++i) {
i__5 = i;
i__3 = i;
i__4 = i;
z__1.r = RWORK(i) * WORK(i).r, z__1.i = RWORK(i)
* WORK(i).i;
WORK(i).r = z__1.r, WORK(i).i = z__1.i;
/* L110: */
}
} else if (kase == 2) {
/* Multiply by inv(A)*diag(W). */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
i__5 = i;
i__3 = i;
i__4 = i;
z__1.r = RWORK(i) * WORK(i).r, z__1.i = RWORK(i)
* WORK(i).i;
WORK(i).r = z__1.r, WORK(i).i = z__1.i;
/* L120: */
}
zpbtrs_(uplo, n, kd, &c__1, &AFB(1,1), ldafb, &WORK(1),
n, info);
}
goto L100;
}
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i = 1; i <= *n; ++i) {
/* Computing MAX */
i__5 = i + j * x_dim1;
d__3 = lstres, d__4 = (d__1 = X(i,j).r, abs(d__1)) + (d__2 =
d_imag(&X(i,j)), abs(d__2));
lstres = max(d__3,d__4);
/* L130: */
}
if (lstres != 0.) {
FERR(j) /= lstres;
}
/* L140: */
}
return 0;
/* End of ZPBRFS */
} /* zpbrfs_ */
/* Subroutine */ int ztgsen_(integer *ijob, logical *wantq, logical *wantz,
logical *select, integer *n, doublecomplex *a, integer *lda,
doublecomplex *b, integer *ldb, doublecomplex *alpha, doublecomplex *
beta, doublecomplex *q, integer *ldq, doublecomplex *z__, integer *
ldz, integer *m, doublereal *pl, doublereal *pr, doublereal *dif,
doublecomplex *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
=======
ZTGSEN reorders the generalized Schur decomposition of a complex
matrix pair (A, B) (in terms of an unitary equivalence trans-
formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues
appears in the leading diagonal blocks of the pair (A,B). The leading
columns of Q and Z form unitary bases of the corresponding left and
right eigenspaces (deflating subspaces). (A, B) must be in
generalized Schur canonical form, that is, A and B are both upper
triangular.
ZTGSEN also computes the generalized eigenvalues
w(j)= ALPHA(j) / BETA(j)
of the reordered matrix pair (A, B).
Optionally, the routine computes 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 an eigenvalue w(j), SELECT(j) must be set to
.TRUE..
N (input) INTEGER
The order of the matrices A and B. N >= 0.
A (input/output) COMPLEX*16 array, dimension(LDA,N)
On entry, the upper triangular matrix A, in generalized
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) COMPLEX*16 array, dimension(LDB,N)
On entry, the upper triangular matrix B, in generalized
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).
ALPHA (output) COMPLEX*16 array, dimension (N)
BETA (output) COMPLEX*16 array, dimension (N)
The diagonal elements of A and B, respectively,
when the pair (A,B) has been reduced to generalized Schur
form. ALPHA(i)/BETA(i) i=1,...,N are the generalized
eigenvalues.
Q (input/output) COMPLEX*16 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 unitary
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.
If WANTQ = .TRUE., LDQ >= N.
Z (input/output) COMPLEX*16 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 unitary
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
eigenspaces, (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
eigenspace 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, 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, computed using reversed
communication with ZLACON.
If M = 0 or N, DIF(1:2) = F-norm([A, B]).
If IJOB = 0 or 1, DIF is not referenced.
WORK (workspace/output) COMPLEX*16 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 >= 1
If IJOB = 1, 2 or 4, LWORK >= 2*M*(N-M)
If IJOB = 3 or 5, LWORK >= 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, 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+2;
If IJOB = 3 or 5, LIWORK >= MAX(N+2, 2*M*(N-M));
If LIWORK = -1, then a workspace query is assumed; the
routine only calculates the optimal size of the IWORK array,
returns this value as the first entry of the IWORK array, and
no error message related to LIWORK is issued by XERBLA.
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
===============
ZTGSEN first collects the selected eigenvalues by computing unitary
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 conjugate 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 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 ZLATDF), then the parameter
IDIFJB (see below) should be changed from 3 to 4 (routine ZLATDF
(IJOB = 2 will be used)). See ZTGSYL 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;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
z_offset, i__1, i__2, i__3;
doublecomplex z__1, z__2;
/* Builtin functions */
double sqrt(doublereal), z_abs(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static integer kase, ierr;
static doublereal dsum;
static logical swap;
static integer i__, k;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
static logical wantd;
static integer lwmin;
static logical wantp;
static integer n1, n2;
static logical wantd1, wantd2;
extern doublereal dlamch_(char *);
static doublereal dscale;
static integer ks;
static doublereal rdscal, safmin;
extern /* Subroutine */ int xerbla_(char *, integer *), zlacon_(
integer *, doublecomplex *, doublecomplex *, doublereal *,
integer *);
static integer liwmin;
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
ztgexc_(logical *, logical *, integer *, doublecomplex *, integer
*, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, integer *, integer *);
static integer mn2;
extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
doublereal *, doublereal *);
static logical lquery;
extern /* Subroutine */ int ztgsyl_(char *, integer *, integer *, integer
*, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublecomplex *, integer *, integer *,
integer *);
static integer ijb;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1
#define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)]
--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;
--alpha;
--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 = -13;
} else if (*ldz < 1 || *wantz && *ldz < *n) {
*info = -15;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZTGSEN", &i__1);
return 0;
}
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;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
i__2 = k;
i__3 = a_subscr(k, k);
alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i;
i__2 = k;
i__3 = b_subscr(k, k);
beta[i__2].r = b[i__3].r, beta[i__2].i = b[i__3].i;
if (k < *n) {
if (select[k]) {
++(*m);
}
} else {
if (select[*n]) {
++(*m);
}
}
/* L10: */
}
if (*ijob == 1 || *ijob == 2 || *ijob == 4) {
/* Computing MAX */
i__1 = 1, i__2 = (*m << 1) * (*n - *m);
lwmin = max(i__1,i__2);
/* Computing MAX */
i__1 = 1, i__2 = *n + 2;
liwmin = max(i__1,i__2);
} else if (*ijob == 3 || *ijob == 5) {
/* Computing MAX */
i__1 = 1, 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 + 2;
liwmin = max(i__1,i__2);
} else {
lwmin = 1;
liwmin = 1;
}
work[1].r = (doublereal) lwmin, work[1].i = 0.;
iwork[1] = liwmin;
if (*lwork < lwmin && ! lquery) {
*info = -21;
} else if (*liwork < liwmin && ! lquery) {
*info = -23;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZTGSEN", &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__) {
zlassq_(n, &a_ref(1, i__), &c__1, &dscale, &dsum);
zlassq_(n, &b_ref(1, i__), &c__1, &dscale, &dsum);
/* L20: */
}
dif[1] = dscale * sqrt(dsum);
dif[2] = dif[1];
}
goto L70;
}
/* Get machine constant */
safmin = dlamch_("S");
/* Collect the selected blocks at the top-left corner of (A, B). */
ks = 0;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
swap = select[k];
if (swap) {
++ks;
/* Swap the K-th block to position KS. Compute unitary Q
and Z that will swap adjacent diagonal blocks in (A, B). */
if (k != ks) {
ztgexc_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb,
&q[q_offset], ldq, &z__[z_offset], ldz, &k, &ks, &
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 L70;
}
}
/* L30: */
}
if (wantp) {
/* Solve generalized Sylvester equation for R and L:
A11 * R - L * A22 = A12
B11 * R - L * B22 = B12 */
n1 = *m;
n2 = *n - *m;
i__ = n1 + 1;
zlacpy_("Full", &n1, &n2, &a_ref(1, i__), lda, &work[1], &n1);
zlacpy_("Full", &n1, &n2, &b_ref(1, i__), ldb, &work[n1 * n2 + 1], &
n1);
ijb = 0;
i__1 = *lwork - (n1 << 1) * n2;
ztgsyl_("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;
zlassq_(&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;
zlassq_(&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 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;
ztgsyl_("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);
/* Frobenius norm-based Difl estimate. */
i__1 = *lwork - (n1 << 1) * n2;
ztgsyl_("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
* n2 << 1) + 1], &i__1, &iwork[1], &ierr);
} else {
/* Compute 1-norm-based estimates of Difu and Difl using
reversed communication with ZLACON. 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:
zlacon_(&mn2, &work[mn2 + 1], &work[1], &dif[1], &kase);
if (kase != 0) {
if (kase == 1) {
/* Solve generalized Sylvester equation */
i__1 = *lwork - (n1 << 1) * n2;
ztgsyl_("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);
} else {
/* Solve the transposed variant. */
i__1 = *lwork - (n1 << 1) * n2;
ztgsyl_("C", &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);
}
goto L40;
}
dif[1] = dscale / dif[1];
/* 1-norm-based estimate of Difl. */
L50:
zlacon_(&mn2, &work[mn2 + 1], &work[1], &dif[2], &kase);
if (kase != 0) {
if (kase == 1) {
/* Solve generalized Sylvester equation */
i__1 = *lwork - (n1 << 1) * n2;
ztgsyl_("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 * n2 << 1) + 1], &i__1,
&iwork[1], &ierr);
} else {
/* Solve the transposed variant. */
i__1 = *lwork - (n1 << 1) * n2;
ztgsyl_("C", &ijb, &n2, &n1, &a_ref(i__, i__), lda, &a[
a_offset], lda, &work[1], &n2, &b[b_offset], ldb,
&b_ref(i__, i__), ldb, &work[n1 * n2 + 1], &n2, &
dscale, &dif[2], &work[(n1 * n2 << 1) + 1], &i__1,
&iwork[1], &ierr);
}
goto L50;
}
dif[2] = dscale / dif[2];
}
}
/* If B(K,K) is complex, make it real and positive (normalization
of the generalized Schur form) and Store the generalized
eigenvalues of reordered pair (A, B) */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
dscale = z_abs(&b_ref(k, k));
if (dscale > safmin) {
i__2 = b_subscr(k, k);
z__2.r = b[i__2].r / dscale, z__2.i = b[i__2].i / dscale;
d_cnjg(&z__1, &z__2);
work[1].r = z__1.r, work[1].i = z__1.i;
i__2 = b_subscr(k, k);
z__1.r = b[i__2].r / dscale, z__1.i = b[i__2].i / dscale;
work[2].r = z__1.r, work[2].i = z__1.i;
i__2 = b_subscr(k, k);
b[i__2].r = dscale, b[i__2].i = 0.;
i__2 = *n - k;
zscal_(&i__2, &work[1], &b_ref(k, k + 1), ldb);
i__2 = *n - k + 1;
zscal_(&i__2, &work[1], &a_ref(k, k), lda);
if (*wantq) {
zscal_(n, &work[2], &q_ref(1, k), &c__1);
}
} else {
i__2 = b_subscr(k, k);
b[i__2].r = 0., b[i__2].i = 0.;
}
i__2 = k;
i__3 = a_subscr(k, k);
alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i;
i__2 = k;
i__3 = b_subscr(k, k);
beta[i__2].r = b[i__3].r, beta[i__2].i = b[i__3].i;
/* L60: */
}
L70:
work[1].r = (doublereal) lwmin, work[1].i = 0.;
iwork[1] = liwmin;
return 0;
/* End of ZTGSEN */
} /* ztgsen_ */
void
zgscon(char *norm, SuperMatrix *L, SuperMatrix *U,
double anorm, double *rcond, int *info)
{
/*
Purpose
=======
ZGSCON 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 ZGETRF.
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
zgstrf(). Use compressed row subscripts storage for supernodes,
i.e., L has types: Stype = SC, Dtype = _Z, Mtype = TRLU.
U (input) SuperMatrix*
The factor U from the factorization Pr*A*Pc=L*U as computed by
zgstrf(). Use column-wise storage scheme, i.e., U has types:
Stype = NC, Dtype = _Z, 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;
doublecomplex *work;
extern int zrscl_(int *, doublecomplex *, doublecomplex *, int *);
extern int zlacon_(int *, doublecomplex *, doublecomplex *, 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 != _Z || L->Mtype != TRLU)
*info = -2;
else if (U->nrow < 0 || U->nrow != U->ncol ||
U->Stype != NC || U->Dtype != _Z || U->Mtype != TRU)
*info = -3;
if (*info != 0) {
i = -(*info);
xerbla_("zgscon", &i);
return;
}
/* Quick return if possible */
*rcond = 0.;
if ( L->nrow == 0 || U->nrow == 0) {
*rcond = 1.;
return;
}
work = doublecomplexCalloc( 3*L->nrow );
if ( !work )
ABORT("Malloc fails for work arrays in zgscon.");
/* Estimate the norm of inv(A). */
ainvnm = 0.;
if ( onenrm ) kase1 = 1;
else kase1 = 2;
kase = 0;
do {
zlacon_(&L->nrow, &work[L->nrow], &work[0], &ainvnm, &kase);
if (kase == 0) break;
if (kase == kase1) {
/* Multiply by inv(L). */
sp_ztrsv("Lower", "No transpose", "Unit", L, U, &work[0], info);
/* Multiply by inv(U). */
sp_ztrsv("Upper", "No transpose", "Non-unit", L, U, &work[0],info);
} else {
/* Multiply by inv(U'). */
sp_ztrsv("Upper", "Transpose", "Non-unit", L, U, &work[0], info);
/* Multiply by inv(L'). */
sp_ztrsv("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);
return;
} /* zgscon */
/* Subroutine */ int zpbcon_(char *uplo, integer *n, integer *kd,
doublecomplex *ab, integer *ldab, doublereal *anorm, doublereal *
rcond, doublecomplex *work, doublereal *rwork, 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
=======
ZPBCON estimates the reciprocal of the condition number (in the
1-norm) of a complex Hermitian positive definite band matrix using
the Cholesky factorization A = U**H*U or A = L*L**H computed by
ZPBTRF.
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 triangular factor stored in AB;
= 'L': Lower triangular factor stored in AB.
N (input) INTEGER
The order of the matrix A. N >= 0.
KD (input) INTEGER
The number of superdiagonals of the matrix A if UPLO = 'U',
or the number of sub-diagonals if UPLO = 'L'. KD >= 0.
AB (input) COMPLEX*16 array, dimension (LDAB,N)
The triangular factor U or L from the Cholesky factorization
A = U**H*U or A = L*L**H of the band matrix A, stored in the
first KD+1 rows of the array. The j-th column of U or L is
stored in the j-th column of the array AB as follows:
if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD+1.
ANORM (input) DOUBLE PRECISION
The 1-norm (or infinity-norm) of the Hermitian band 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) COMPLEX*16 array, dimension (2*N)
RWORK (workspace) DOUBLE PRECISION 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
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer ab_dim1, ab_offset, i__1;
doublereal d__1, d__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static integer kase;
static doublereal scale;
extern logical lsame_(char *, char *);
static logical upper;
extern doublereal dlamch_(char *);
static integer ix;
static doublereal scalel, scaleu;
extern /* Subroutine */ int xerbla_(char *, integer *), zlacon_(
integer *, doublecomplex *, doublecomplex *, doublereal *,
integer *);
static doublereal ainvnm;
extern integer izamax_(integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zlatbs_(char *, char *, char *, char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublereal *, doublereal *, integer *), zdrscl_(integer *, doublereal *, doublecomplex *,
integer *);
static char normin[1];
static doublereal smlnum;
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kd < 0) {
*info = -3;
} else if (*ldab < *kd + 1) {
*info = -5;
} else if (*anorm < 0.) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZPBCON", &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:
zlacon_(n, &WORK(*n + 1), &WORK(1), &ainvnm, &kase);
if (kase != 0) {
if (upper) {
/* Multiply by inv(U'). */
zlatbs_("Upper", "Conjugate transpose", "Non-unit", normin, n, kd,
&AB(1,1), ldab, &WORK(1), &scalel, &RWORK(1), info);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(U). */
zlatbs_("Upper", "No transpose", "Non-unit", normin, n, kd, &AB(1,1), ldab, &WORK(1), &scaleu, &RWORK(1), info);
} else {
/* Multiply by inv(L). */
zlatbs_("Lower", "No transpose", "Non-unit", normin, n, kd, &AB(1,1), ldab, &WORK(1), &scalel, &RWORK(1), info);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(L'). */
zlatbs_("Lower", "Conjugate transpose", "Non-unit", normin, n, kd,
&AB(1,1), ldab, &WORK(1), &scaleu, &RWORK(1), info);
}
/* Multiply by 1/SCALE if doing so will not cause overflow. */
scale = scalel * scaleu;
if (scale != 1.) {
ix = izamax_(n, &WORK(1), &c__1);
i__1 = ix;
if (scale < ((d__1 = WORK(ix).r, abs(d__1)) + (d__2 = d_imag(&
WORK(ix)), abs(d__2))) * smlnum || scale == 0.) {
goto L20;
}
zdrscl_(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 ZPBCON */
} /* zpbcon_ */