/* 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)
{
/* 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 */
integer i__, j, k;
doublereal s, xk;
integer nz;
doublereal eps;
integer kase;
doublereal safe1, safe2;
extern logical lsame_(char *, char *);
integer isave[3], count;
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 *), zlacn2_(integer *, doublecomplex *,
doublecomplex *, doublereal *, integer *, integer *);
extern doublereal dlamch_(char *);
doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
doublereal lstres;
extern /* Subroutine */ int zsytrs_(char *, integer *, integer *,
doublecomplex *, integer *, integer *, doublecomplex *, integer *,
integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
/* .. 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 .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. 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");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldaf < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -10;
} else if (*ldx < max(1,*n)) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZSYRFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] = 0.;
berr[j] = 0.;
/* L10: */
}
return 0;
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
eps = dlamch_("Epsilon");
safmin = dlamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
count = 1;
lstres = 3.;
L20:
/* Loop until stopping criterion is satisfied. */
/* Compute residual R = B - A * X */
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);
/* 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);
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 ZLACN2 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:
zlacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
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);
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);
}
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 zsytri_(char *uplo, integer *n, doublecomplex *a,
integer *lda, integer *ipiv, 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
September 30, 1994
Purpose
=======
ZSYTRI computes the inverse of a complex symmetric indefinite matrix
A using the factorization A = U*D*U**T or A = L*D*L**T computed by
ZSYTRF.
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**T;
= 'L': Lower triangular, form is A = L*D*L**T.
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) COMPLEX*16 array, dimension (LDA,N)
On entry, the block diagonal matrix D and the multipliers
used to obtain the factor U or L as computed by ZSYTRF.
On exit, if INFO = 0, the (symmetric) inverse of the original
matrix. If UPLO = 'U', the upper triangular part of the
inverse is formed and the part of A below the diagonal is not
referenced; if UPLO = 'L' the lower triangular part of the
inverse is formed and the part of A above the diagonal is
not referenced.
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 ZSYTRF.
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
> 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
inverse could not be computed.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b1 = {1.,0.};
static doublecomplex c_b2 = {0.,0.};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
/* Local variables */
static doublecomplex temp, akkp1, d__;
static integer k;
static doublecomplex t;
extern logical lsame_(char *, char *);
static integer kstep;
static logical upper;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
extern /* Double Complex */ VOID zdotu_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zsymv_(char *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static doublecomplex ak;
static integer kp;
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublecomplex akp1;
#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)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--ipiv;
--work;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZSYTRI", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Check that the diagonal matrix D is nonsingular. */
if (upper) {
/* Upper triangular storage: examine D from bottom to top */
for (*info = *n; *info >= 1; --(*info)) {
i__1 = a_subscr(*info, *info);
if (ipiv[*info] > 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 (*info = 1; *info <= i__1; ++(*info)) {
i__2 = a_subscr(*info, *info);
if (ipiv[*info] > 0 && (a[i__2].r == 0. && a[i__2].i == 0.)) {
return 0;
}
/* L20: */
}
}
*info = 0;
if (upper) {
/* Compute inv(A) from the factorization A = U*D*U'.
K is the main loop index, increasing from 1 to N in steps of
1 or 2, depending on the size of the diagonal blocks. */
k = 1;
L30:
/* If K > N, exit from loop. */
if (k > *n) {
goto L40;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block
Invert the diagonal block. */
i__1 = a_subscr(k, k);
z_div(&z__1, &c_b1, &a_ref(k, k));
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
/* Compute column K of the inverse. */
if (k > 1) {
i__1 = k - 1;
zcopy_(&i__1, &a_ref(1, k), &c__1, &work[1], &c__1);
i__1 = k - 1;
z__1.r = -1., z__1.i = 0.;
zsymv_(uplo, &i__1, &z__1, &a[a_offset], lda, &work[1], &c__1,
&c_b2, &a_ref(1, k), &c__1);
i__1 = a_subscr(k, k);
i__2 = a_subscr(k, k);
i__3 = k - 1;
zdotu_(&z__2, &i__3, &work[1], &c__1, &a_ref(1, k), &c__1);
z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
}
kstep = 1;
} else {
/* 2 x 2 diagonal block
Invert the diagonal block. */
i__1 = a_subscr(k, k + 1);
t.r = a[i__1].r, t.i = a[i__1].i;
z_div(&z__1, &a_ref(k, k), &t);
ak.r = z__1.r, ak.i = z__1.i;
z_div(&z__1, &a_ref(k + 1, k + 1), &t);
akp1.r = z__1.r, akp1.i = z__1.i;
z_div(&z__1, &a_ref(k, k + 1), &t);
akkp1.r = z__1.r, akkp1.i = z__1.i;
z__3.r = ak.r * akp1.r - ak.i * akp1.i, z__3.i = ak.r * akp1.i +
ak.i * akp1.r;
z__2.r = z__3.r - 1., z__2.i = z__3.i + 0.;
z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * z__2.i + t.i
* z__2.r;
d__.r = z__1.r, d__.i = z__1.i;
i__1 = a_subscr(k, k);
z_div(&z__1, &akp1, &d__);
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = a_subscr(k + 1, k + 1);
z_div(&z__1, &ak, &d__);
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = a_subscr(k, k + 1);
z__2.r = -akkp1.r, z__2.i = -akkp1.i;
z_div(&z__1, &z__2, &d__);
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
/* Compute columns K and K+1 of the inverse. */
if (k > 1) {
i__1 = k - 1;
zcopy_(&i__1, &a_ref(1, k), &c__1, &work[1], &c__1);
i__1 = k - 1;
z__1.r = -1., z__1.i = 0.;
zsymv_(uplo, &i__1, &z__1, &a[a_offset], lda, &work[1], &c__1,
&c_b2, &a_ref(1, k), &c__1);
i__1 = a_subscr(k, k);
i__2 = a_subscr(k, k);
i__3 = k - 1;
zdotu_(&z__2, &i__3, &work[1], &c__1, &a_ref(1, k), &c__1);
z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = a_subscr(k, k + 1);
i__2 = a_subscr(k, k + 1);
i__3 = k - 1;
zdotu_(&z__2, &i__3, &a_ref(1, k), &c__1, &a_ref(1, k + 1), &
c__1);
z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = k - 1;
zcopy_(&i__1, &a_ref(1, k + 1), &c__1, &work[1], &c__1);
i__1 = k - 1;
z__1.r = -1., z__1.i = 0.;
zsymv_(uplo, &i__1, &z__1, &a[a_offset], lda, &work[1], &c__1,
&c_b2, &a_ref(1, k + 1), &c__1);
i__1 = a_subscr(k + 1, k + 1);
i__2 = a_subscr(k + 1, k + 1);
i__3 = k - 1;
zdotu_(&z__2, &i__3, &work[1], &c__1, &a_ref(1, k + 1), &c__1)
;
z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
}
kstep = 2;
}
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k) {
/* Interchange rows and columns K and KP in the leading
submatrix A(1:k+1,1:k+1) */
i__1 = kp - 1;
zswap_(&i__1, &a_ref(1, k), &c__1, &a_ref(1, kp), &c__1);
i__1 = k - kp - 1;
zswap_(&i__1, &a_ref(kp + 1, k), &c__1, &a_ref(kp, kp + 1), lda);
i__1 = a_subscr(k, k);
temp.r = a[i__1].r, temp.i = a[i__1].i;
i__1 = a_subscr(k, k);
i__2 = a_subscr(kp, kp);
a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
i__1 = a_subscr(kp, kp);
a[i__1].r = temp.r, a[i__1].i = temp.i;
if (kstep == 2) {
i__1 = a_subscr(k, k + 1);
temp.r = a[i__1].r, temp.i = a[i__1].i;
i__1 = a_subscr(k, k + 1);
i__2 = a_subscr(kp, k + 1);
a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
i__1 = a_subscr(kp, k + 1);
a[i__1].r = temp.r, a[i__1].i = temp.i;
}
}
k += kstep;
goto L30;
L40:
;
} else {
/* Compute inv(A) from the factorization A = L*D*L'.
K is the main loop index, increasing from 1 to N in steps of
1 or 2, depending on the size of the diagonal blocks. */
k = *n;
L50:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L60;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block
Invert the diagonal block. */
i__1 = a_subscr(k, k);
z_div(&z__1, &c_b1, &a_ref(k, k));
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
/* Compute column K of the inverse. */
if (k < *n) {
i__1 = *n - k;
zcopy_(&i__1, &a_ref(k + 1, k), &c__1, &work[1], &c__1);
i__1 = *n - k;
z__1.r = -1., z__1.i = 0.;
zsymv_(uplo, &i__1, &z__1, &a_ref(k + 1, k + 1), lda, &work[1]
, &c__1, &c_b2, &a_ref(k + 1, k), &c__1);
i__1 = a_subscr(k, k);
i__2 = a_subscr(k, k);
i__3 = *n - k;
zdotu_(&z__2, &i__3, &work[1], &c__1, &a_ref(k + 1, k), &c__1)
;
z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
}
kstep = 1;
} else {
/* 2 x 2 diagonal block
Invert the diagonal block. */
i__1 = a_subscr(k, k - 1);
t.r = a[i__1].r, t.i = a[i__1].i;
z_div(&z__1, &a_ref(k - 1, k - 1), &t);
ak.r = z__1.r, ak.i = z__1.i;
z_div(&z__1, &a_ref(k, k), &t);
akp1.r = z__1.r, akp1.i = z__1.i;
z_div(&z__1, &a_ref(k, k - 1), &t);
akkp1.r = z__1.r, akkp1.i = z__1.i;
z__3.r = ak.r * akp1.r - ak.i * akp1.i, z__3.i = ak.r * akp1.i +
ak.i * akp1.r;
z__2.r = z__3.r - 1., z__2.i = z__3.i + 0.;
z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * z__2.i + t.i
* z__2.r;
d__.r = z__1.r, d__.i = z__1.i;
i__1 = a_subscr(k - 1, k - 1);
z_div(&z__1, &akp1, &d__);
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = a_subscr(k, k);
z_div(&z__1, &ak, &d__);
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = a_subscr(k, k - 1);
z__2.r = -akkp1.r, z__2.i = -akkp1.i;
z_div(&z__1, &z__2, &d__);
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
/* Compute columns K-1 and K of the inverse. */
if (k < *n) {
i__1 = *n - k;
zcopy_(&i__1, &a_ref(k + 1, k), &c__1, &work[1], &c__1);
i__1 = *n - k;
z__1.r = -1., z__1.i = 0.;
zsymv_(uplo, &i__1, &z__1, &a_ref(k + 1, k + 1), lda, &work[1]
, &c__1, &c_b2, &a_ref(k + 1, k), &c__1);
i__1 = a_subscr(k, k);
i__2 = a_subscr(k, k);
i__3 = *n - k;
zdotu_(&z__2, &i__3, &work[1], &c__1, &a_ref(k + 1, k), &c__1)
;
z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = a_subscr(k, k - 1);
i__2 = a_subscr(k, k - 1);
i__3 = *n - k;
zdotu_(&z__2, &i__3, &a_ref(k + 1, k), &c__1, &a_ref(k + 1, k
- 1), &c__1);
z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = *n - k;
zcopy_(&i__1, &a_ref(k + 1, k - 1), &c__1, &work[1], &c__1);
i__1 = *n - k;
z__1.r = -1., z__1.i = 0.;
zsymv_(uplo, &i__1, &z__1, &a_ref(k + 1, k + 1), lda, &work[1]
, &c__1, &c_b2, &a_ref(k + 1, k - 1), &c__1);
i__1 = a_subscr(k - 1, k - 1);
i__2 = a_subscr(k - 1, k - 1);
i__3 = *n - k;
zdotu_(&z__2, &i__3, &work[1], &c__1, &a_ref(k + 1, k - 1), &
c__1);
z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
}
kstep = 2;
}
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k) {
/* Interchange rows and columns K and KP in the trailing
submatrix A(k-1:n,k-1:n) */
if (kp < *n) {
i__1 = *n - kp;
zswap_(&i__1, &a_ref(kp + 1, k), &c__1, &a_ref(kp + 1, kp), &
c__1);
}
i__1 = kp - k - 1;
zswap_(&i__1, &a_ref(k + 1, k), &c__1, &a_ref(kp, k + 1), lda);
i__1 = a_subscr(k, k);
temp.r = a[i__1].r, temp.i = a[i__1].i;
i__1 = a_subscr(k, k);
i__2 = a_subscr(kp, kp);
a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
i__1 = a_subscr(kp, kp);
a[i__1].r = temp.r, a[i__1].i = temp.i;
if (kstep == 2) {
i__1 = a_subscr(k, k - 1);
temp.r = a[i__1].r, temp.i = a[i__1].i;
i__1 = a_subscr(k, k - 1);
i__2 = a_subscr(kp, k - 1);
a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
i__1 = a_subscr(kp, k - 1);
a[i__1].r = temp.r, a[i__1].i = temp.i;
}
}
k -= kstep;
goto L50;
L60:
;
}
return 0;
/* End of ZSYTRI */
} /* zsytri_ */
/* 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)
{
/* 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 */
integer i__, j, k;
doublereal s, xk;
integer nz;
doublereal eps;
integer kase;
doublereal safe1, safe2;
extern logical lsame_(char *, char *);
integer isave[3], count;
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 *), zlacn2_(integer *, doublecomplex *, doublecomplex *, doublereal *, integer *, integer *);
extern doublereal dlamch_(char *);
doublereal safmin;
extern /* Subroutine */
int xerbla_(char *, integer *);
doublereal lstres;
extern /* Subroutine */
int zsytrs_(char *, integer *, integer *, doublecomplex *, integer *, integer *, doublecomplex *, integer *, integer *);
/* -- LAPACK computational routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. 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");
if (! upper && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*nrhs < 0)
{
*info = -3;
}
else if (*lda < max(1,*n))
{
*info = -5;
}
else if (*ldaf < max(1,*n))
{
*info = -7;
}
else if (*ldb < max(1,*n))
{
*info = -10;
}
else if (*ldx < max(1,*n))
{
*info = -12;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("ZSYRFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0)
{
i__1 = *nrhs;
for (j = 1;
j <= i__1;
++j)
{
ferr[j] = 0.;
berr[j] = 0.;
/* L10: */
}
return 0;
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
eps = dlamch_("Epsilon");
safmin = dlamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1;
j <= i__1;
++j)
{
count = 1;
lstres = 3.;
L20: /* Loop until stopping criterion is satisfied. */
/* Compute residual R = B - A * X */
zcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zsymv_(uplo, n, &z__1, &a[a_offset], lda, &x[j * x_dim1 + 1], &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 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__]; // , expr subst
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); // , expr subst
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);
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 ZLACN2 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:
zlacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
if (kase != 0)
{
if (kase == 1)
{
/* Multiply by diag(W)*inv(A**T). */
zsytrs_(uplo, 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; // , expr subst
work[i__3].r = z__1.r;
work[i__3].i = z__1.i; // , expr subst
/* 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; // , expr subst
work[i__3].r = z__1.r;
work[i__3].i = z__1.i; // , expr subst
/* L120: */
}
zsytrs_(uplo, 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 = 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)); // , expr subst
lstres = max(d__3,d__4);
/* L130: */
}
if (lstres != 0.)
{
ferr[j] /= lstres;
}
/* L140: */
}
return 0;
/* End of ZSYRFS */
}
/* Subroutine */ int zla_syrfsx_extended__(integer *prec_type__, char *uplo,
integer *n, integer *nrhs, doublecomplex *a, integer *lda,
doublecomplex *af, integer *ldaf, integer *ipiv, logical *colequ,
doublereal *c__, doublecomplex *b, integer *ldb, doublecomplex *y,
integer *ldy, doublereal *berr_out__, integer *n_norms__, doublereal *
err_bnds_norm__, doublereal *err_bnds_comp__, doublecomplex *res,
doublereal *ayb, doublecomplex *dy, doublecomplex *y_tail__,
doublereal *rcond, integer *ithresh, doublereal *rthresh, doublereal *
dz_ub__, logical *ignore_cwise__, integer *info, ftnlen uplo_len)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, y_dim1,
y_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
doublereal dxratmax, dzratmax;
integer i__, j;
logical incr_prec__;
doublereal prev_dz_z__;
extern /* Subroutine */ int zla_syamv__(integer *, integer *, doublereal *
, doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, integer *);
doublereal yk, final_dx_x__, final_dz_z__;
extern /* Subroutine */ int zla_wwaddw__(integer *, doublecomplex *,
doublecomplex *, doublecomplex *);
doublereal prevnormdx;
integer cnt;
doublereal dyk, eps, incr_thresh__, dx_x__, dz_z__, ymin;
extern /* Subroutine */ int zla_lin_berr__(integer *, integer *, integer *
, doublecomplex *, doublereal *, doublereal *);
integer y_prec_state__, uplo2;
extern /* Subroutine */ int blas_zsymv_x__(integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, integer *)
;
extern logical lsame_(char *, char *);
doublereal dxrat, dzrat;
extern /* Subroutine */ int blas_zsymv2_x__(integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *);
doublereal normx, normy;
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 *);
extern doublereal dlamch_(char *);
doublereal normdx;
extern /* Subroutine */ int zsytrs_(char *, integer *, integer *,
doublecomplex *, integer *, integer *, doublecomplex *, integer *,
integer *);
doublereal hugeval;
extern integer ilauplo_(char *);
integer x_state__, z_state__;
/* -- LAPACK routine (version 3.2.1) -- */
/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
/* -- Jason Riedy of Univ. of California Berkeley. -- */
/* -- April 2009 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley and NAG Ltd. -- */
/* .. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLA_SYRFSX_EXTENDED improves the computed solution to a system of */
/* linear equations by performing extra-precise iterative refinement */
/* and provides error bounds and backward error estimates for the solution. */
/* This subroutine is called by ZSYRFSX to perform iterative refinement. */
/* In addition to normwise error bound, the code provides maximum */
/* componentwise error bound if possible. See comments for ERR_BNDS_NORM */
/* and ERR_BNDS_COMP for details of the error bounds. Note that this */
/* subroutine is only resonsible for setting the second fields of */
/* ERR_BNDS_NORM and ERR_BNDS_COMP. */
/* Arguments */
/* ========= */
/* PREC_TYPE (input) INTEGER */
/* Specifies the intermediate precision to be used in refinement. */
/* The value is defined by ILAPREC(P) where P is a CHARACTER and */
/* P = 'S': Single */
/* = 'D': Double */
/* = 'I': Indigenous */
/* = 'X', 'E': Extra */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The number of linear equations, i.e., the order of the */
/* matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right-hand-sides, i.e., the number of columns of the */
/* matrix B. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the 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 block diagonal matrix D and the multipliers used to */
/* obtain the factor U or L 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. */
/* COLEQU (input) LOGICAL */
/* If .TRUE. then column equilibration was done to A before calling */
/* this routine. This is needed to compute the solution and error */
/* bounds correctly. */
/* C (input) DOUBLE PRECISION array, dimension (N) */
/* The column scale factors for A. If COLEQU = .FALSE., C */
/* is not accessed. If C is input, each element of C should be a power */
/* of the radix to ensure a reliable solution and error estimates. */
/* Scaling by powers of the radix does not cause rounding errors unless */
/* the result underflows or overflows. Rounding errors during scaling */
/* lead to refining with a matrix that is not equivalent to the */
/* input matrix, producing error estimates that may not be */
/* reliable. */
/* 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). */
/* Y (input/output) COMPLEX*16 array, dimension */
/* (LDY,NRHS) */
/* On entry, the solution matrix X, as computed by ZSYTRS. */
/* On exit, the improved solution matrix Y. */
/* LDY (input) INTEGER */
/* The leading dimension of the array Y. LDY >= max(1,N). */
/* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS) */
/* On exit, BERR_OUT(j) contains the componentwise relative backward */
/* error for right-hand-side j from the formula */
/* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
/* where abs(Z) is the componentwise absolute value of the matrix */
/* or vector Z. This is computed by ZLA_LIN_BERR. */
/* N_NORMS (input) INTEGER */
/* Determines which error bounds to return (see ERR_BNDS_NORM */
/* and ERR_BNDS_COMP). */
/* If N_NORMS >= 1 return normwise error bounds. */
/* If N_NORMS >= 2 return componentwise error bounds. */
/* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension */
/* (NRHS, N_ERR_BNDS) */
/* For each right-hand side, this array contains information about */
/* various error bounds and condition numbers corresponding to the */
/* normwise relative error, which is defined as follows: */
/* Normwise relative error in the ith solution vector: */
/* max_j (abs(XTRUE(j,i) - X(j,i))) */
/* ------------------------------ */
/* max_j abs(X(j,i)) */
/* The array is indexed by the type of error information as described */
/* below. There currently are up to three pieces of information */
/* returned. */
/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
/* right-hand side. */
/* The second index in ERR_BNDS_NORM(:,err) contains the following */
/* three fields: */
/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
/* reciprocal condition number is less than the threshold */
/* sqrt(n) * slamch('Epsilon'). */
/* err = 2 "Guaranteed" error bound: The estimated forward error, */
/* almost certainly within a factor of 10 of the true error */
/* so long as the next entry is greater than the threshold */
/* sqrt(n) * slamch('Epsilon'). This error bound should only */
/* be trusted if the previous boolean is true. */
/* err = 3 Reciprocal condition number: Estimated normwise */
/* reciprocal condition number. Compared with the threshold */
/* sqrt(n) * slamch('Epsilon') to determine if the error */
/* estimate is "guaranteed". These reciprocal condition */
/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
/* appropriately scaled matrix Z. */
/* Let Z = S*A, where S scales each row by a power of the */
/* radix so all absolute row sums of Z are approximately 1. */
/* This subroutine is only responsible for setting the second field */
/* above. */
/* See Lapack Working Note 165 for further details and extra */
/* cautions. */
/* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension */
/* (NRHS, N_ERR_BNDS) */
/* For each right-hand side, this array contains information about */
/* various error bounds and condition numbers corresponding to the */
/* componentwise relative error, which is defined as follows: */
/* Componentwise relative error in the ith solution vector: */
/* abs(XTRUE(j,i) - X(j,i)) */
/* max_j ---------------------- */
/* abs(X(j,i)) */
/* The array is indexed by the right-hand side i (on which the */
/* componentwise relative error depends), and the type of error */
/* information as described below. There currently are up to three */
/* pieces of information returned for each right-hand side. If */
/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
/* the first (:,N_ERR_BNDS) entries are returned. */
/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
/* right-hand side. */
/* The second index in ERR_BNDS_COMP(:,err) contains the following */
/* three fields: */
/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
/* reciprocal condition number is less than the threshold */
/* sqrt(n) * slamch('Epsilon'). */
/* err = 2 "Guaranteed" error bound: The estimated forward error, */
/* almost certainly within a factor of 10 of the true error */
/* so long as the next entry is greater than the threshold */
/* sqrt(n) * slamch('Epsilon'). This error bound should only */
/* be trusted if the previous boolean is true. */
/* err = 3 Reciprocal condition number: Estimated componentwise */
/* reciprocal condition number. Compared with the threshold */
/* sqrt(n) * slamch('Epsilon') to determine if the error */
/* estimate is "guaranteed". These reciprocal condition */
/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
/* appropriately scaled matrix Z. */
/* Let Z = S*(A*diag(x)), where x is the solution for the */
/* current right-hand side and S scales each row of */
/* A*diag(x) by a power of the radix so all absolute row */
/* sums of Z are approximately 1. */
/* This subroutine is only responsible for setting the second field */
/* above. */
/* See Lapack Working Note 165 for further details and extra */
/* cautions. */
/* RES (input) COMPLEX*16 array, dimension (N) */
/* Workspace to hold the intermediate residual. */
/* AYB (input) DOUBLE PRECISION array, dimension (N) */
/* Workspace. */
/* DY (input) COMPLEX*16 array, dimension (N) */
/* Workspace to hold the intermediate solution. */
/* Y_TAIL (input) COMPLEX*16 array, dimension (N) */
/* Workspace to hold the trailing bits of the intermediate solution. */
/* RCOND (input) DOUBLE PRECISION */
/* Reciprocal scaled condition number. This is an estimate of the */
/* reciprocal Skeel condition number of the matrix A after */
/* equilibration (if done). If this is less than the machine */
/* precision (in particular, if it is zero), the matrix is singular */
/* to working precision. Note that the error may still be small even */
/* if this number is very small and the matrix appears ill- */
/* conditioned. */
/* ITHRESH (input) INTEGER */
/* The maximum number of residual computations allowed for */
/* refinement. The default is 10. For 'aggressive' set to 100 to */
/* permit convergence using approximate factorizations or */
/* factorizations other than LU. If the factorization uses a */
/* technique other than Gaussian elimination, the guarantees in */
/* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. */
/* RTHRESH (input) DOUBLE PRECISION */
/* Determines when to stop refinement if the error estimate stops */
/* decreasing. Refinement will stop when the next solution no longer */
/* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */
/* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */
/* default value is 0.5. For 'aggressive' set to 0.9 to permit */
/* convergence on extremely ill-conditioned matrices. See LAWN 165 */
/* for more details. */
/* DZ_UB (input) DOUBLE PRECISION */
/* Determines when to start considering componentwise convergence. */
/* Componentwise convergence is only considered after each component */
/* of the solution Y is stable, which we definte as the relative */
/* change in each component being less than DZ_UB. The default value */
/* is 0.25, requiring the first bit to be stable. See LAWN 165 for */
/* more details. */
/* IGNORE_CWISE (input) LOGICAL */
/* If .TRUE. then ignore componentwise convergence. Default value */
/* is .FALSE.. */
/* INFO (output) INTEGER */
/* = 0: Successful exit. */
/* < 0: if INFO = -i, the ith argument to ZSYTRS had an illegal */
/* value */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. Parameters .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function Definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
err_bnds_comp_dim1 = *nrhs;
err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
err_bnds_comp__ -= err_bnds_comp_offset;
err_bnds_norm_dim1 = *nrhs;
err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
err_bnds_norm__ -= err_bnds_norm_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--ipiv;
--c__;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
y_dim1 = *ldy;
y_offset = 1 + y_dim1;
y -= y_offset;
--berr_out__;
--res;
--ayb;
--dy;
--y_tail__;
/* Function Body */
if (*info != 0) {
return 0;
}
eps = dlamch_("Epsilon");
hugeval = dlamch_("Overflow");
/* Force HUGEVAL to Inf */
hugeval *= hugeval;
/* Using HUGEVAL may lead to spurious underflows. */
incr_thresh__ = (doublereal) (*n) * eps;
if (lsame_(uplo, "L")) {
uplo2 = ilauplo_("L");
} else {
uplo2 = ilauplo_("U");
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
y_prec_state__ = 1;
if (y_prec_state__ == 2) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
y_tail__[i__3].r = 0., y_tail__[i__3].i = 0.;
}
}
dxrat = 0.;
dxratmax = 0.;
dzrat = 0.;
dzratmax = 0.;
final_dx_x__ = hugeval;
final_dz_z__ = hugeval;
prevnormdx = hugeval;
prev_dz_z__ = hugeval;
dz_z__ = hugeval;
dx_x__ = hugeval;
x_state__ = 1;
z_state__ = 0;
incr_prec__ = FALSE_;
i__2 = *ithresh;
for (cnt = 1; cnt <= i__2; ++cnt) {
/* Compute residual RES = B_s - op(A_s) * Y, */
/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
zcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
if (y_prec_state__ == 0) {
zsymv_(uplo, n, &c_b11, &a[a_offset], lda, &y[j * y_dim1 + 1],
&c__1, &c_b12, &res[1], &c__1);
} else if (y_prec_state__ == 1) {
blas_zsymv_x__(&uplo2, n, &c_b11, &a[a_offset], lda, &y[j *
y_dim1 + 1], &c__1, &c_b12, &res[1], &c__1,
prec_type__);
} else {
blas_zsymv2_x__(&uplo2, n, &c_b11, &a[a_offset], lda, &y[j *
y_dim1 + 1], &y_tail__[1], &c__1, &c_b12, &res[1], &
c__1, prec_type__);
}
/* XXX: RES is no longer needed. */
zcopy_(n, &res[1], &c__1, &dy[1], &c__1);
zsytrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &dy[1], n,
info);
/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */
normx = 0.;
normy = 0.;
normdx = 0.;
dz_z__ = 0.;
ymin = hugeval;
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * y_dim1;
yk = (d__1 = y[i__4].r, abs(d__1)) + (d__2 = d_imag(&y[i__ +
j * y_dim1]), abs(d__2));
i__4 = i__;
dyk = (d__1 = dy[i__4].r, abs(d__1)) + (d__2 = d_imag(&dy[i__]
), abs(d__2));
if (yk != 0.) {
/* Computing MAX */
d__1 = dz_z__, d__2 = dyk / yk;
dz_z__ = max(d__1,d__2);
} else if (dyk != 0.) {
dz_z__ = hugeval;
}
ymin = min(ymin,yk);
normy = max(normy,yk);
if (*colequ) {
/* Computing MAX */
d__1 = normx, d__2 = yk * c__[i__];
normx = max(d__1,d__2);
/* Computing MAX */
d__1 = normdx, d__2 = dyk * c__[i__];
normdx = max(d__1,d__2);
} else {
normx = normy;
normdx = max(normdx,dyk);
}
}
if (normx != 0.) {
dx_x__ = normdx / normx;
} else if (normdx == 0.) {
dx_x__ = 0.;
} else {
dx_x__ = hugeval;
}
dxrat = normdx / prevnormdx;
dzrat = dz_z__ / prev_dz_z__;
/* Check termination criteria. */
if (ymin * *rcond < incr_thresh__ * normy && y_prec_state__ < 2) {
incr_prec__ = TRUE_;
}
if (x_state__ == 3 && dxrat <= *rthresh) {
x_state__ = 1;
}
if (x_state__ == 1) {
if (dx_x__ <= eps) {
x_state__ = 2;
} else if (dxrat > *rthresh) {
if (y_prec_state__ != 2) {
incr_prec__ = TRUE_;
} else {
x_state__ = 3;
}
} else {
if (dxrat > dxratmax) {
dxratmax = dxrat;
}
}
if (x_state__ > 1) {
final_dx_x__ = dx_x__;
}
}
if (z_state__ == 0 && dz_z__ <= *dz_ub__) {
z_state__ = 1;
}
if (z_state__ == 3 && dzrat <= *rthresh) {
z_state__ = 1;
}
if (z_state__ == 1) {
if (dz_z__ <= eps) {
z_state__ = 2;
} else if (dz_z__ > *dz_ub__) {
z_state__ = 0;
dzratmax = 0.;
final_dz_z__ = hugeval;
} else if (dzrat > *rthresh) {
if (y_prec_state__ != 2) {
incr_prec__ = TRUE_;
} else {
z_state__ = 3;
}
} else {
if (dzrat > dzratmax) {
dzratmax = dzrat;
}
}
if (z_state__ > 1) {
final_dz_z__ = dz_z__;
}
}
if (x_state__ != 1 && (*ignore_cwise__ || z_state__ != 1)) {
goto L666;
}
if (incr_prec__) {
incr_prec__ = FALSE_;
++y_prec_state__;
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
y_tail__[i__4].r = 0., y_tail__[i__4].i = 0.;
}
}
prevnormdx = normdx;
prev_dz_z__ = dz_z__;
/* Update soluton. */
if (y_prec_state__ < 2) {
zaxpy_(n, &c_b12, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1);
} else {
zla_wwaddw__(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]);
}
}
/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. */
L666:
/* Set final_* when cnt hits ithresh. */
if (x_state__ == 1) {
final_dx_x__ = dx_x__;
}
if (z_state__ == 1) {
final_dz_z__ = dz_z__;
}
/* Compute error bounds. */
if (*n_norms__ >= 1) {
err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = final_dx_x__ / (
1 - dxratmax);
}
if (*n_norms__ >= 2) {
err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = final_dz_z__ / (
1 - dzratmax);
}
/* Compute componentwise relative backward error from formula */
/* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
/* where abs(Z) is the componentwise absolute value of the matrix */
/* or vector Z. */
/* Compute residual RES = B_s - op(A_s) * Y, */
/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
zcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
zsymv_(uplo, n, &c_b11, &a[a_offset], lda, &y[j * y_dim1 + 1], &c__1,
&c_b12, &res[1], &c__1);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * b_dim1;
ayb[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[i__
+ j * b_dim1]), abs(d__2));
}
/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */
zla_syamv__(&uplo2, n, &c_b33, &a[a_offset], lda, &y[j * y_dim1 + 1],
&c__1, &c_b33, &ayb[1], &c__1);
zla_lin_berr__(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]);
/* End of loop for each RHS. */
}
return 0;
} /* zla_syrfsx_extended__ */
