/* Subroutine */ int cherfs_(char *uplo, integer *n, integer *nrhs, complex *
a, integer *lda, complex *af, integer *ldaf, integer *ipiv, complex *
b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr,
complex *work, real *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
=======
CHERFS improves the computed solution to a system of linear
equations when the coefficient matrix is Hermitian 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 array, dimension (LDA,N)
The Hermitian 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 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**H or
A = L*D*L**H as computed by CHETRF.
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 CHETRF.
B (input) COMPLEX 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 array, dimension (LDX,NRHS)
On entry, the solution matrix X, as computed by CHETRS.
On exit, the improved solution matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
FERR (output) REAL 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) REAL 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 array, dimension (2*N)
RWORK (workspace) REAL 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 complex c_b1 = {1.f,0.f};
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;
real r__1, r__2, r__3, r__4;
complex q__1;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static integer kase;
static real safe1, safe2;
static integer i__, j, k;
static real s;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int chemv_(char *, integer *, complex *, complex *
, integer *, complex *, integer *, complex *, complex *, integer *
), ccopy_(integer *, complex *, integer *, complex *,
integer *), caxpy_(integer *, complex *, complex *, integer *,
complex *, integer *);
static integer count;
static logical upper;
extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real
*, integer *);
static real xk;
extern doublereal slamch_(char *);
static integer nz;
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *), chetrs_(
char *, integer *, integer *, complex *, integer *, integer *,
complex *, integer *, integer *);
static real lstres, 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;
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_("CHERFS", &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.f;
berr[j] = 0.f;
/* L10: */
}
return 0;
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
eps = slamch_("Epsilon");
safmin = slamch_("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.f;
L20:
/* Loop until stopping criterion is satisfied.
Compute residual R = B - A * X */
ccopy_(n, &b_ref(1, j), &c__1, &work[1], &c__1);
q__1.r = -1.f, q__1.i = 0.f;
chemv_(uplo, n, &q__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(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__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
b_ref(i__, j)), dabs(r__2));
/* L30: */
}
/* Compute abs(A)*abs(X) + abs(B). */
if (upper) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.f;
i__3 = x_subscr(k, j);
xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x_ref(k,
j)), dabs(r__2));
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = a_subscr(i__, k);
rwork[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&a_ref(i__, k)), dabs(r__2))) * xk;
i__4 = a_subscr(i__, k);
i__5 = x_subscr(i__, j);
s += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
a_ref(i__, k)), dabs(r__2))) * ((r__3 = x[i__5].r,
dabs(r__3)) + (r__4 = r_imag(&x_ref(i__, j)),
dabs(r__4)));
/* L40: */
}
i__3 = a_subscr(k, k);
rwork[k] = rwork[k] + (r__1 = a[i__3].r, dabs(r__1)) * xk + s;
/* L50: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.f;
i__3 = x_subscr(k, j);
xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x_ref(k,
j)), dabs(r__2));
i__3 = a_subscr(k, k);
rwork[k] += (r__1 = a[i__3].r, dabs(r__1)) * xk;
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
i__4 = a_subscr(i__, k);
rwork[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&a_ref(i__, k)), dabs(r__2))) * xk;
i__4 = a_subscr(i__, k);
i__5 = x_subscr(i__, j);
s += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
a_ref(i__, k)), dabs(r__2))) * ((r__3 = x[i__5].r,
dabs(r__3)) + (r__4 = r_imag(&x_ref(i__, j)),
dabs(r__4)));
/* L60: */
}
rwork[k] += s;
/* L70: */
}
}
s = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
/* Computing MAX */
i__3 = i__;
r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2))) / rwork[i__];
s = dmax(r__3,r__4);
} else {
/* Computing MAX */
i__3 = i__;
r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + safe1) / (rwork[i__]
+ safe1);
s = dmax(r__3,r__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.f <= lstres && count <= 5) {
/* Update solution and try again. */
chetrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[1],
n, info);
caxpy_(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(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 CLACON 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__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
i__];
} else {
i__3 = i__;
rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
i__] + safe1;
}
/* L90: */
}
kase = 0;
L100:
clacon_(n, &work[*n + 1], &work[1], &ferr[j], &kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(A'). */
chetrs_(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__;
q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = q__1.r, work[i__3].i = q__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__;
q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L120: */
}
chetrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
1], n, info);
}
goto L100;
}
/* Normalize error. */
lstres = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = x_subscr(i__, j);
r__3 = lstres, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x_ref(i__, j)), dabs(r__2));
lstres = dmax(r__3,r__4);
/* L130: */
}
if (lstres != 0.f) {
ferr[j] /= lstres;
}
/* L140: */
}
return 0;
/* End of CHERFS */
} /* cherfs_ */
/* Subroutine */ int cgbt05_(char *trans, integer *n, integer *kl, integer *
ku, integer *nrhs, complex *ab, integer *ldab, complex *b, integer *
ldb, complex *x, integer *ldx, complex *xact, integer *ldxact, real *
ferr, real *berr, real *reslts)
{
/* System generated locals */
integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
xact_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
complex q__1, q__2;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static real diff, axbi;
static integer imax;
static real unfl, ovfl;
static integer i__, j, k;
extern logical lsame_(char *, char *);
static real xnorm;
extern integer icamax_(integer *, complex *, integer *);
extern doublereal slamch_(char *);
static integer nz;
static real errbnd;
static logical notran;
static real eps, tmp;
#define xact_subscr(a_1,a_2) (a_2)*xact_dim1 + a_1
#define xact_ref(a_1,a_2) xact[xact_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)]
#define ab_subscr(a_1,a_2) (a_2)*ab_dim1 + a_1
#define ab_ref(a_1,a_2) ab[ab_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
CGBT05 tests the error bounds from iterative refinement for the
computed solution to a system of equations op(A)*X = B, where A is a
general band matrix of order n with kl subdiagonals and ku
superdiagonals and op(A) = A or A**T, depending on TRANS.
RESLTS(1) = test of the error bound
= norm(X - XACT) / ( norm(X) * FERR )
A large value is returned if this ratio is not less than one.
RESLTS(2) = residual from the iterative refinement routine
= the maximum of BERR / ( NZ*EPS + (*) ), where
(*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i )
and NZ = max. number of nonzeros in any row of A, plus 1
Arguments
=========
TRANS (input) CHARACTER*1
Specifies the form of the system of equations.
= 'N': A * X = B (No transpose)
= 'T': A**T * X = B (Transpose)
= 'C': A**H * X = B (Conjugate transpose = Transpose)
N (input) INTEGER
The number of rows of the matrices X, B, and XACT, and 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 columns of the matrices X, B, and XACT.
NRHS >= 0.
AB (input) COMPLEX 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.
B (input) COMPLEX array, dimension (LDB,NRHS)
The right hand side vectors for the system of linear
equations.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (input) COMPLEX array, dimension (LDX,NRHS)
The computed solution vectors. Each vector is stored as a
column of the matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
XACT (input) COMPLEX array, dimension (LDX,NRHS)
The exact solution vectors. Each vector is stored as a
column of the matrix XACT.
LDXACT (input) INTEGER
The leading dimension of the array XACT. LDXACT >= max(1,N).
FERR (input) REAL array, dimension (NRHS)
The estimated forward error bounds for each solution vector
X. If XTRUE is the true solution, FERR bounds the magnitude
of the largest entry in (X - XTRUE) divided by the magnitude
of the largest entry in X.
BERR (input) REAL array, dimension (NRHS)
The componentwise relative backward error of each solution
vector (i.e., the smallest relative change in any entry of A
or B that makes X an exact solution).
RESLTS (output) REAL array, dimension (2)
The maximum over the NRHS solution vectors of the ratios:
RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
RESLTS(2) = BERR / ( NZ*EPS + (*) )
=====================================================================
Quick exit if N = 0 or NRHS = 0.
Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
xact_dim1 = *ldxact;
xact_offset = 1 + xact_dim1 * 1;
xact -= xact_offset;
--ferr;
--berr;
--reslts;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
reslts[1] = 0.f;
reslts[2] = 0.f;
return 0;
}
eps = slamch_("Epsilon");
unfl = slamch_("Safe minimum");
ovfl = 1.f / unfl;
notran = lsame_(trans, "N");
/* Computing MIN */
i__1 = *kl + *ku + 2, i__2 = *n + 1;
nz = min(i__1,i__2);
/* Test 1: Compute the maximum of
norm(X - XACT) / ( norm(X) * FERR )
over all the vectors X and XACT using the infinity-norm. */
errbnd = 0.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
imax = icamax_(n, &x_ref(1, j), &c__1);
/* Computing MAX */
i__2 = x_subscr(imax, j);
r__3 = (r__1 = x[i__2].r, dabs(r__1)) + (r__2 = r_imag(&x_ref(imax, j)
), dabs(r__2));
xnorm = dmax(r__3,unfl);
diff = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = x_subscr(i__, j);
i__4 = xact_subscr(i__, j);
q__2.r = x[i__3].r - xact[i__4].r, q__2.i = x[i__3].i - xact[i__4]
.i;
q__1.r = q__2.r, q__1.i = q__2.i;
/* Computing MAX */
r__3 = diff, r__4 = (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&
q__1), dabs(r__2));
diff = dmax(r__3,r__4);
/* L10: */
}
if (xnorm > 1.f) {
goto L20;
} else if (diff <= ovfl * xnorm) {
goto L20;
} else {
errbnd = 1.f / eps;
goto L30;
}
L20:
if (diff / xnorm <= ferr[j]) {
/* Computing MAX */
r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
errbnd = dmax(r__1,r__2);
} else {
errbnd = 1.f / eps;
}
L30:
;
}
reslts[1] = errbnd;
/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where
(*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
i__1 = *nrhs;
for (k = 1; k <= i__1; ++k) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, k);
tmp = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(i__,
k)), dabs(r__2));
if (notran) {
/* Computing MAX */
i__3 = i__ - *kl;
/* Computing MIN */
i__5 = i__ + *ku;
i__4 = min(i__5,*n);
for (j = max(i__3,1); j <= i__4; ++j) {
i__3 = ab_subscr(*ku + 1 + i__ - j, j);
i__5 = x_subscr(j, k);
tmp += ((r__1 = ab[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
ab_ref(*ku + 1 + i__ - j, j)), dabs(r__2))) * ((
r__3 = x[i__5].r, dabs(r__3)) + (r__4 = r_imag(&
x_ref(j, k)), dabs(r__4)));
/* L40: */
}
} else {
/* Computing MAX */
i__4 = i__ - *ku;
/* Computing MIN */
i__5 = i__ + *kl;
i__3 = min(i__5,*n);
for (j = max(i__4,1); j <= i__3; ++j) {
i__4 = ab_subscr(*ku + 1 + j - i__, i__);
i__5 = x_subscr(j, k);
tmp += ((r__1 = ab[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
ab_ref(*ku + 1 + j - i__, i__)), dabs(r__2))) * ((
r__3 = x[i__5].r, dabs(r__3)) + (r__4 = r_imag(&
x_ref(j, k)), dabs(r__4)));
/* L50: */
}
}
if (i__ == 1) {
axbi = tmp;
} else {
axbi = dmin(axbi,tmp);
}
/* L60: */
}
/* Computing MAX */
r__1 = axbi, r__2 = nz * unfl;
tmp = berr[k] / (nz * eps + nz * unfl / dmax(r__1,r__2));
if (k == 1) {
reslts[2] = tmp;
} else {
reslts[2] = dmax(reslts[2],tmp);
}
/* L70: */
}
return 0;
/* End of CGBT05 */
} /* cgbt05_ */
/* Subroutine */ int zlaptm_(char *uplo, integer *n, integer *nrhs,
doublereal *alpha, doublereal *d__, doublecomplex *e, doublecomplex *
x, integer *ldx, doublereal *beta, doublecomplex *b, integer *ldb)
{
/* 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;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static integer i__, j;
extern logical lsame_(char *, char *);
#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)]
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
ZLAPTM multiplies an N by NRHS matrix X by a Hermitian tridiagonal
matrix A and stores the result in a matrix B. The operation has the
form
B := alpha * A * X + beta * B
where alpha may be either 1. or -1. and beta may be 0., 1., or -1.
Arguments
=========
UPLO (input) CHARACTER
Specifies whether the superdiagonal or the subdiagonal of the
tridiagonal matrix A is stored.
= 'U': Upper, E is the superdiagonal of A.
= 'L': Lower, E is the subdiagonal of A.
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 X and B.
ALPHA (input) DOUBLE PRECISION
The scalar alpha. ALPHA must be 1. or -1.; otherwise,
it is assumed to be 0.
D (input) DOUBLE PRECISION array, dimension (N)
The n diagonal elements of the tridiagonal matrix A.
E (input) COMPLEX*16 array, dimension (N-1)
The (n-1) subdiagonal or superdiagonal elements of A.
X (input) COMPLEX*16 array, dimension (LDX,NRHS)
The N by NRHS matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(N,1).
BETA (input) DOUBLE PRECISION
The scalar beta. BETA must be 0., 1., or -1.; otherwise,
it is assumed to be 1.
B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
On entry, the N by NRHS matrix B.
On exit, B is overwritten by the matrix expression
B := alpha * A * X + beta * B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(N,1).
=====================================================================
Parameter adjustments */
--d__;
--e;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
/* Function Body */
if (*n == 0) {
return 0;
}
if (*beta == 0.) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
b[i__3].r = 0., b[i__3].i = 0.;
/* L10: */
}
/* L20: */
}
} else if (*beta == -1.) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = b_subscr(i__, j);
z__1.r = -b[i__4].r, z__1.i = -b[i__4].i;
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
/* L30: */
}
/* L40: */
}
}
if (*alpha == 1.) {
if (lsame_(uplo, "U")) {
/* Compute B := B + A*X, where E is the superdiagonal of A. */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
if (*n == 1) {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
i__4 = x_subscr(1, j);
z__2.r = d__[1] * x[i__4].r, z__2.i = d__[1] * x[i__4].i;
z__1.r = b[i__3].r + z__2.r, z__1.i = b[i__3].i + z__2.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
} else {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
i__4 = x_subscr(1, j);
z__3.r = d__[1] * x[i__4].r, z__3.i = d__[1] * x[i__4].i;
z__2.r = b[i__3].r + z__3.r, z__2.i = b[i__3].i + z__3.i;
i__5 = x_subscr(2, j);
z__4.r = e[1].r * x[i__5].r - e[1].i * x[i__5].i, z__4.i =
e[1].r * x[i__5].i + e[1].i * x[i__5].r;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
i__2 = b_subscr(*n, j);
i__3 = b_subscr(*n, j);
d_cnjg(&z__4, &e[*n - 1]);
i__4 = x_subscr(*n - 1, j);
z__3.r = z__4.r * x[i__4].r - z__4.i * x[i__4].i, z__3.i =
z__4.r * x[i__4].i + z__4.i * x[i__4].r;
z__2.r = b[i__3].r + z__3.r, z__2.i = b[i__3].i + z__3.i;
i__5 = *n;
i__6 = x_subscr(*n, j);
z__5.r = d__[i__5] * x[i__6].r, z__5.i = d__[i__5] * x[
i__6].i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = b_subscr(i__, j);
d_cnjg(&z__5, &e[i__ - 1]);
i__5 = x_subscr(i__ - 1, j);
z__4.r = z__5.r * x[i__5].r - z__5.i * x[i__5].i,
z__4.i = z__5.r * x[i__5].i + z__5.i * x[i__5]
.r;
z__3.r = b[i__4].r + z__4.r, z__3.i = b[i__4].i +
z__4.i;
i__6 = i__;
i__7 = x_subscr(i__, j);
z__6.r = d__[i__6] * x[i__7].r, z__6.i = d__[i__6] *
x[i__7].i;
z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i;
i__8 = i__;
i__9 = x_subscr(i__ + 1, j);
z__7.r = e[i__8].r * x[i__9].r - e[i__8].i * x[i__9]
.i, z__7.i = e[i__8].r * x[i__9].i + e[i__8]
.i * x[i__9].r;
z__1.r = z__2.r + z__7.r, z__1.i = z__2.i + z__7.i;
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
/* L50: */
}
}
/* L60: */
}
} else {
/* Compute B := B + A*X, where E is the subdiagonal of A. */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
if (*n == 1) {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
i__4 = x_subscr(1, j);
z__2.r = d__[1] * x[i__4].r, z__2.i = d__[1] * x[i__4].i;
z__1.r = b[i__3].r + z__2.r, z__1.i = b[i__3].i + z__2.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
} else {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
i__4 = x_subscr(1, j);
z__3.r = d__[1] * x[i__4].r, z__3.i = d__[1] * x[i__4].i;
z__2.r = b[i__3].r + z__3.r, z__2.i = b[i__3].i + z__3.i;
d_cnjg(&z__5, &e[1]);
i__5 = x_subscr(2, j);
z__4.r = z__5.r * x[i__5].r - z__5.i * x[i__5].i, z__4.i =
z__5.r * x[i__5].i + z__5.i * x[i__5].r;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
i__2 = b_subscr(*n, j);
i__3 = b_subscr(*n, j);
i__4 = *n - 1;
i__5 = x_subscr(*n - 1, j);
z__3.r = e[i__4].r * x[i__5].r - e[i__4].i * x[i__5].i,
z__3.i = e[i__4].r * x[i__5].i + e[i__4].i * x[
i__5].r;
z__2.r = b[i__3].r + z__3.r, z__2.i = b[i__3].i + z__3.i;
i__6 = *n;
i__7 = x_subscr(*n, j);
z__4.r = d__[i__6] * x[i__7].r, z__4.i = d__[i__6] * x[
i__7].i;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = b_subscr(i__, j);
i__5 = i__ - 1;
i__6 = x_subscr(i__ - 1, j);
z__4.r = e[i__5].r * x[i__6].r - e[i__5].i * x[i__6]
.i, z__4.i = e[i__5].r * x[i__6].i + e[i__5]
.i * x[i__6].r;
z__3.r = b[i__4].r + z__4.r, z__3.i = b[i__4].i +
z__4.i;
i__7 = i__;
i__8 = x_subscr(i__, j);
z__5.r = d__[i__7] * x[i__8].r, z__5.i = d__[i__7] *
x[i__8].i;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
d_cnjg(&z__7, &e[i__]);
i__9 = x_subscr(i__ + 1, j);
z__6.r = z__7.r * x[i__9].r - z__7.i * x[i__9].i,
z__6.i = z__7.r * x[i__9].i + z__7.i * x[i__9]
.r;
z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
/* L70: */
}
}
/* L80: */
}
}
} else if (*alpha == -1.) {
if (lsame_(uplo, "U")) {
/* Compute B := B - A*X, where E is the superdiagonal of A. */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
if (*n == 1) {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
i__4 = x_subscr(1, j);
z__2.r = d__[1] * x[i__4].r, z__2.i = d__[1] * x[i__4].i;
z__1.r = b[i__3].r - z__2.r, z__1.i = b[i__3].i - z__2.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
} else {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
i__4 = x_subscr(1, j);
z__3.r = d__[1] * x[i__4].r, z__3.i = d__[1] * x[i__4].i;
z__2.r = b[i__3].r - z__3.r, z__2.i = b[i__3].i - z__3.i;
i__5 = x_subscr(2, j);
z__4.r = e[1].r * x[i__5].r - e[1].i * x[i__5].i, z__4.i =
e[1].r * x[i__5].i + e[1].i * x[i__5].r;
z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - z__4.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
i__2 = b_subscr(*n, j);
i__3 = b_subscr(*n, j);
d_cnjg(&z__4, &e[*n - 1]);
i__4 = x_subscr(*n - 1, j);
z__3.r = z__4.r * x[i__4].r - z__4.i * x[i__4].i, z__3.i =
z__4.r * x[i__4].i + z__4.i * x[i__4].r;
z__2.r = b[i__3].r - z__3.r, z__2.i = b[i__3].i - z__3.i;
i__5 = *n;
i__6 = x_subscr(*n, j);
z__5.r = d__[i__5] * x[i__6].r, z__5.i = d__[i__5] * x[
i__6].i;
z__1.r = z__2.r - z__5.r, z__1.i = z__2.i - z__5.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = b_subscr(i__, j);
d_cnjg(&z__5, &e[i__ - 1]);
i__5 = x_subscr(i__ - 1, j);
z__4.r = z__5.r * x[i__5].r - z__5.i * x[i__5].i,
z__4.i = z__5.r * x[i__5].i + z__5.i * x[i__5]
.r;
z__3.r = b[i__4].r - z__4.r, z__3.i = b[i__4].i -
z__4.i;
i__6 = i__;
i__7 = x_subscr(i__, j);
z__6.r = d__[i__6] * x[i__7].r, z__6.i = d__[i__6] *
x[i__7].i;
z__2.r = z__3.r - z__6.r, z__2.i = z__3.i - z__6.i;
i__8 = i__;
i__9 = x_subscr(i__ + 1, j);
z__7.r = e[i__8].r * x[i__9].r - e[i__8].i * x[i__9]
.i, z__7.i = e[i__8].r * x[i__9].i + e[i__8]
.i * x[i__9].r;
z__1.r = z__2.r - z__7.r, z__1.i = z__2.i - z__7.i;
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
/* L90: */
}
}
/* L100: */
}
} else {
/* Compute B := B - A*X, where E is the subdiagonal of A. */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
if (*n == 1) {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
i__4 = x_subscr(1, j);
z__2.r = d__[1] * x[i__4].r, z__2.i = d__[1] * x[i__4].i;
z__1.r = b[i__3].r - z__2.r, z__1.i = b[i__3].i - z__2.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
} else {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
i__4 = x_subscr(1, j);
z__3.r = d__[1] * x[i__4].r, z__3.i = d__[1] * x[i__4].i;
z__2.r = b[i__3].r - z__3.r, z__2.i = b[i__3].i - z__3.i;
d_cnjg(&z__5, &e[1]);
i__5 = x_subscr(2, j);
z__4.r = z__5.r * x[i__5].r - z__5.i * x[i__5].i, z__4.i =
z__5.r * x[i__5].i + z__5.i * x[i__5].r;
z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - z__4.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
i__2 = b_subscr(*n, j);
i__3 = b_subscr(*n, j);
i__4 = *n - 1;
i__5 = x_subscr(*n - 1, j);
z__3.r = e[i__4].r * x[i__5].r - e[i__4].i * x[i__5].i,
z__3.i = e[i__4].r * x[i__5].i + e[i__4].i * x[
i__5].r;
z__2.r = b[i__3].r - z__3.r, z__2.i = b[i__3].i - z__3.i;
i__6 = *n;
i__7 = x_subscr(*n, j);
z__4.r = d__[i__6] * x[i__7].r, z__4.i = d__[i__6] * x[
i__7].i;
z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - z__4.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = b_subscr(i__, j);
i__5 = i__ - 1;
i__6 = x_subscr(i__ - 1, j);
z__4.r = e[i__5].r * x[i__6].r - e[i__5].i * x[i__6]
.i, z__4.i = e[i__5].r * x[i__6].i + e[i__5]
.i * x[i__6].r;
z__3.r = b[i__4].r - z__4.r, z__3.i = b[i__4].i -
z__4.i;
i__7 = i__;
i__8 = x_subscr(i__, j);
z__5.r = d__[i__7] * x[i__8].r, z__5.i = d__[i__7] *
x[i__8].i;
z__2.r = z__3.r - z__5.r, z__2.i = z__3.i - z__5.i;
d_cnjg(&z__7, &e[i__]);
i__9 = x_subscr(i__ + 1, j);
z__6.r = z__7.r * x[i__9].r - z__7.i * x[i__9].i,
z__6.i = z__7.r * x[i__9].i + z__7.i * x[i__9]
.r;
z__1.r = z__2.r - z__6.r, z__1.i = z__2.i - z__6.i;
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
/* L110: */
}
}
/* L120: */
}
}
}
return 0;
/* End of ZLAPTM */
} /* zlaptm_ */
/* Subroutine */ int ztpt05_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, doublecomplex *ap, doublecomplex *b, integer *ldb,
doublecomplex *x, integer *ldx, doublecomplex *xact, integer *ldxact,
doublereal *ferr, doublereal *berr, doublereal *reslts)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, xact_dim1, xact_offset, i__1,
i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static doublereal diff, axbi;
static integer imax;
static doublereal unfl, ovfl;
static logical unit;
static integer i__, j, k;
extern logical lsame_(char *, char *);
static logical upper;
static doublereal xnorm;
static integer jc;
extern doublereal dlamch_(char *);
static doublereal errbnd;
extern integer izamax_(integer *, doublecomplex *, integer *);
static logical notran;
static integer ifu;
static doublereal eps, tmp;
#define xact_subscr(a_1,a_2) (a_2)*xact_dim1 + a_1
#define xact_ref(a_1,a_2) xact[xact_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)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
ZTPT05 tests the error bounds from iterative refinement for the
computed solution to a system of equations A*X = B, where A is a
triangular matrix in packed storage format.
RESLTS(1) = test of the error bound
= norm(X - XACT) / ( norm(X) * FERR )
A large value is returned if this ratio is not less than one.
RESLTS(2) = residual from the iterative refinement routine
= the maximum of BERR / ( (n+1)*EPS + (*) ), where
(*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the matrix A is upper or lower triangular.
= 'U': Upper triangular
= 'L': Lower triangular
TRANS (input) CHARACTER*1
Specifies the form of the system of equations.
= 'N': A * X = B (No transpose)
= 'T': A'* X = B (Transpose)
= 'C': A'* X = B (Conjugate transpose = Transpose)
DIAG (input) CHARACTER*1
Specifies whether or not the matrix A is unit triangular.
= 'N': Non-unit triangular
= 'U': Unit triangular
N (input) INTEGER
The number of rows of the matrices X, B, and XACT, and the
order of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of columns of the matrices X, B, and XACT.
NRHS >= 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.
B (input) COMPLEX*16 array, dimension (LDB,NRHS)
The right hand side vectors for the system of linear
equations.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (input) COMPLEX*16 array, dimension (LDX,NRHS)
The computed solution vectors. Each vector is stored as a
column of the matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
XACT (input) COMPLEX*16 array, dimension (LDX,NRHS)
The exact solution vectors. Each vector is stored as a
column of the matrix XACT.
LDXACT (input) INTEGER
The leading dimension of the array XACT. LDXACT >= max(1,N).
FERR (input) DOUBLE PRECISION array, dimension (NRHS)
The estimated forward error bounds for each solution vector
X. If XTRUE is the true solution, FERR bounds the magnitude
of the largest entry in (X - XTRUE) divided by the magnitude
of the largest entry in X.
BERR (input) DOUBLE PRECISION array, dimension (NRHS)
The componentwise relative backward error of each solution
vector (i.e., the smallest relative change in any entry of A
or B that makes X an exact solution).
RESLTS (output) DOUBLE PRECISION array, dimension (2)
The maximum over the NRHS solution vectors of the ratios:
RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
RESLTS(2) = BERR / ( (n+1)*EPS + (*) )
=====================================================================
Quick exit if N = 0 or NRHS = 0.
Parameter adjustments */
--ap;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
xact_dim1 = *ldxact;
xact_offset = 1 + xact_dim1 * 1;
xact -= xact_offset;
--ferr;
--berr;
--reslts;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
reslts[1] = 0.;
reslts[2] = 0.;
return 0;
}
eps = dlamch_("Epsilon");
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
unit = lsame_(diag, "U");
/* Test 1: Compute the maximum of
norm(X - XACT) / ( norm(X) * FERR )
over all the vectors X and XACT using the infinity-norm. */
errbnd = 0.;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
imax = izamax_(n, &x_ref(1, j), &c__1);
/* Computing MAX */
i__2 = x_subscr(imax, j);
d__3 = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x_ref(imax, j))
, abs(d__2));
xnorm = max(d__3,unfl);
diff = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = x_subscr(i__, j);
i__4 = xact_subscr(i__, j);
z__2.r = x[i__3].r - xact[i__4].r, z__2.i = x[i__3].i - xact[i__4]
.i;
z__1.r = z__2.r, z__1.i = z__2.i;
/* Computing MAX */
d__3 = diff, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
z__1), abs(d__2));
diff = max(d__3,d__4);
/* L10: */
}
if (xnorm > 1.) {
goto L20;
} else if (diff <= ovfl * xnorm) {
goto L20;
} else {
errbnd = 1. / eps;
goto L30;
}
L20:
if (diff / xnorm <= ferr[j]) {
/* Computing MAX */
d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
errbnd = max(d__1,d__2);
} else {
errbnd = 1. / eps;
}
L30:
;
}
reslts[1] = errbnd;
/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where
(*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
ifu = 0;
if (unit) {
ifu = 1;
}
i__1 = *nrhs;
for (k = 1; k <= i__1; ++k) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, k);
tmp = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b_ref(i__,
k)), abs(d__2));
if (upper) {
jc = (i__ - 1) * i__ / 2;
if (! notran) {
i__3 = i__ - ifu;
for (j = 1; j <= i__3; ++j) {
i__4 = jc + j;
i__5 = x_subscr(j, k);
tmp += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 =
d_imag(&ap[jc + j]), abs(d__2))) * ((d__3 = x[
i__5].r, abs(d__3)) + (d__4 = d_imag(&x_ref(j,
k)), abs(d__4)));
/* L40: */
}
if (unit) {
i__3 = x_subscr(i__, k);
tmp += (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
&x_ref(i__, k)), abs(d__2));
}
} else {
jc += i__;
if (unit) {
i__3 = x_subscr(i__, k);
tmp += (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
&x_ref(i__, k)), abs(d__2));
jc += i__;
}
i__3 = *n;
for (j = i__ + ifu; j <= i__3; ++j) {
i__4 = jc;
i__5 = x_subscr(j, k);
tmp += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 =
d_imag(&ap[jc]), abs(d__2))) * ((d__3 = x[
i__5].r, abs(d__3)) + (d__4 = d_imag(&x_ref(j,
k)), abs(d__4)));
jc += j;
/* L50: */
}
}
} else {
if (notran) {
jc = i__;
i__3 = i__ - ifu;
for (j = 1; j <= i__3; ++j) {
i__4 = jc;
i__5 = x_subscr(j, k);
tmp += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 =
d_imag(&ap[jc]), abs(d__2))) * ((d__3 = x[
i__5].r, abs(d__3)) + (d__4 = d_imag(&x_ref(j,
k)), abs(d__4)));
jc = jc + *n - j;
/* L60: */
}
if (unit) {
i__3 = x_subscr(i__, k);
tmp += (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
&x_ref(i__, k)), abs(d__2));
}
} else {
jc = (i__ - 1) * (*n - i__) + i__ * (i__ + 1) / 2;
if (unit) {
i__3 = x_subscr(i__, k);
tmp += (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
&x_ref(i__, k)), abs(d__2));
}
i__3 = *n;
for (j = i__ + ifu; j <= i__3; ++j) {
i__4 = jc + j - i__;
i__5 = x_subscr(j, k);
tmp += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 =
d_imag(&ap[jc + j - i__]), abs(d__2))) * ((
d__3 = x[i__5].r, abs(d__3)) + (d__4 = d_imag(
&x_ref(j, k)), abs(d__4)));
/* L70: */
}
}
}
if (i__ == 1) {
axbi = tmp;
} else {
axbi = min(axbi,tmp);
}
/* L80: */
}
/* Computing MAX */
d__1 = axbi, d__2 = (*n + 1) * unfl;
tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / max(d__1,d__2));
if (k == 1) {
reslts[2] = tmp;
} else {
reslts[2] = max(reslts[2],tmp);
}
/* L90: */
}
return 0;
/* End of ZTPT05 */
} /* ztpt05_ */
/* Subroutine */ int zlapmt_(logical *forwrd, integer *m, integer *n,
doublecomplex *x, integer *ldx, integer *k)
{
/* -- LAPACK auxiliary 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
=======
ZLAPMT rearranges the columns of the M by N matrix X as specified
by the permutation K(1),K(2),...,K(N) of the integers 1,...,N.
If FORWRD = .TRUE., forward permutation:
X(*,K(J)) is moved X(*,J) for J = 1,2,...,N.
If FORWRD = .FALSE., backward permutation:
X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N.
Arguments
=========
FORWRD (input) LOGICAL
= .TRUE., forward permutation
= .FALSE., backward permutation
M (input) INTEGER
The number of rows of the matrix X. M >= 0.
N (input) INTEGER
The number of columns of the matrix X. N >= 0.
X (input/output) COMPLEX*16 array, dimension (LDX,N)
On entry, the M by N matrix X.
On exit, X contains the permuted matrix X.
LDX (input) INTEGER
The leading dimension of the array X, LDX >= MAX(1,M).
K (input) INTEGER array, dimension (N)
On entry, K contains the permutation vector.
=====================================================================
Parameter adjustments */
/* System generated locals */
integer x_dim1, x_offset, i__1, i__2, i__3, i__4;
/* Local variables */
static doublecomplex temp;
static integer i__, j, ii, in;
#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)]
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
--k;
/* Function Body */
if (*n <= 1) {
return 0;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
k[i__] = -k[i__];
/* L10: */
}
if (*forwrd) {
/* Forward permutation */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (k[i__] > 0) {
goto L40;
}
j = i__;
k[j] = -k[j];
in = k[j];
L20:
if (k[in] > 0) {
goto L40;
}
i__2 = *m;
for (ii = 1; ii <= i__2; ++ii) {
i__3 = x_subscr(ii, j);
temp.r = x[i__3].r, temp.i = x[i__3].i;
i__3 = x_subscr(ii, j);
i__4 = x_subscr(ii, in);
x[i__3].r = x[i__4].r, x[i__3].i = x[i__4].i;
i__3 = x_subscr(ii, in);
x[i__3].r = temp.r, x[i__3].i = temp.i;
/* L30: */
}
k[in] = -k[in];
j = in;
in = k[in];
goto L20;
L40:
/* L50: */
;
}
} else {
/* Backward permutation */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (k[i__] > 0) {
goto L80;
}
k[i__] = -k[i__];
j = k[i__];
L60:
if (j == i__) {
goto L80;
}
i__2 = *m;
for (ii = 1; ii <= i__2; ++ii) {
i__3 = x_subscr(ii, i__);
temp.r = x[i__3].r, temp.i = x[i__3].i;
i__3 = x_subscr(ii, i__);
i__4 = x_subscr(ii, j);
x[i__3].r = x[i__4].r, x[i__3].i = x[i__4].i;
i__3 = x_subscr(ii, j);
x[i__3].r = temp.r, x[i__3].i = temp.i;
/* L70: */
}
k[j] = -k[j];
j = k[j];
goto L60;
L80:
/* L90: */
;
}
}
return 0;
/* End of ZLAPMT */
} /* zlapmt_ */
/* Subroutine */ int cposvx_(char *fact, char *uplo, integer *n, integer *
nrhs, complex *a, integer *lda, complex *af, integer *ldaf, char *
equed, real *s, complex *b, integer *ldb, complex *x, integer *ldx,
real *rcond, real *ferr, real *berr, complex *work, real *rwork,
integer *info)
{
/* -- LAPACK driver 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
=======
CPOSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to
compute the solution to a complex system of linear equations
A * X = B,
where A is an N-by-N Hermitian positive definite matrix and X and B
are N-by-NRHS matrices.
Error bounds on the solution and a condition estimate are also
provided.
Description
===========
The following steps are performed:
1. If FACT = 'E', real scaling factors are computed to equilibrate
the system:
diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
Whether or not the system will be equilibrated depends on the
scaling of the matrix A, but if equilibration is used, A is
overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
factor the matrix A (after equilibration if FACT = 'E') as
A = U**H* U, if UPLO = 'U', or
A = L * L**H, if UPLO = 'L',
where U is an upper triangular matrix and L is a lower triangular
matrix.
3. If the leading i-by-i principal minor is not positive definite,
then the routine returns with INFO = i. Otherwise, the factored
form of A is used to estimate the condition number of the matrix
A. If the reciprocal of the condition number is less than machine
precision, INFO = N+1 is returned as a warning, but the routine
still goes on to solve for X and compute error bounds as
described below.
4. The system of equations is solved for X using the factored form
of A.
5. Iterative refinement is applied to improve the computed solution
matrix and calculate error bounds and backward error estimates
for it.
6. If equilibration was used, the matrix X is premultiplied by
diag(S) so that it solves the original system before
equilibration.
Arguments
=========
FACT (input) CHARACTER*1
Specifies whether or not the factored form of the matrix A is
supplied on entry, and if not, whether the matrix A should be
equilibrated before it is factored.
= 'F': On entry, AF contains the factored form of A.
If EQUED = 'Y', the matrix A has been equilibrated
with scaling factors given by S. A and AF will not
be modified.
= 'N': The matrix A will be copied to AF and factored.
= 'E': The matrix A will be equilibrated if necessary, then
copied to AF and factored.
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 matrices B and X. NRHS >= 0.
A (input/output) COMPLEX array, dimension (LDA,N)
On entry, the Hermitian matrix A, except if FACT = 'F' and
EQUED = 'Y', then A must contain the equilibrated matrix
diag(S)*A*diag(S). If UPLO = 'U', the leading
N-by-N upper triangular part of A contains the upper
triangular part of the matrix A, and the strictly lower
triangular part of A is not referenced. If UPLO = 'L', the
leading N-by-N lower triangular part of A contains the lower
triangular part of the matrix A, and the strictly upper
triangular part of A is not referenced. A is not modified if
FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.
On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
diag(S)*A*diag(S).
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
AF (input or output) COMPLEX array, dimension (LDAF,N)
If FACT = 'F', then AF is an input argument and on entry
contains the triangular factor U or L from the Cholesky
factorization A = U**H*U or A = L*L**H, in the same storage
format as A. If EQUED .ne. 'N', then AF is the factored form
of the equilibrated matrix diag(S)*A*diag(S).
If FACT = 'N', then AF is an output argument and on exit
returns the triangular factor U or L from the Cholesky
factorization A = U**H*U or A = L*L**H of the original
matrix A.
If FACT = 'E', then AF is an output argument and on exit
returns the triangular factor U or L from the Cholesky
factorization A = U**H*U or A = L*L**H of the equilibrated
matrix A (see the description of A for the form of the
equilibrated matrix).
LDAF (input) INTEGER
The leading dimension of the array AF. LDAF >= max(1,N).
EQUED (input or output) CHARACTER*1
Specifies the form of equilibration that was done.
= 'N': No equilibration (always true if FACT = 'N').
= 'Y': Equilibration was done, i.e., A has been replaced by
diag(S) * A * diag(S).
EQUED is an input argument if FACT = 'F'; otherwise, it is an
output argument.
S (input or output) REAL array, dimension (N)
The scale factors for A; not accessed if EQUED = 'N'. S is
an input argument if FACT = 'F'; otherwise, S is an output
argument. If FACT = 'F' and EQUED = 'Y', each element of S
must be positive.
B (input/output) COMPLEX array, dimension (LDB,NRHS)
On entry, the N-by-NRHS righthand side matrix B.
On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
B is overwritten by diag(S) * B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (output) COMPLEX array, dimension (LDX,NRHS)
If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
the original system of equations. Note that if EQUED = 'Y',
A and B are modified on exit, and the solution to the
equilibrated system is inv(diag(S))*X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
RCOND (output) REAL
The estimate of the reciprocal condition number of the matrix
A after equilibration (if done). If RCOND is less than the
machine precision (in particular, if RCOND = 0), the matrix
is singular to working precision. This condition is
indicated by a return code of INFO > 0.
FERR (output) REAL 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) REAL 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 array, dimension (2*N)
RWORK (workspace) REAL array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, and i is
<= N: the leading minor of order i of A is
not positive definite, so the factorization
could not be completed, and the solution has not
been computed. RCOND = 0 is returned.
= N+1: U is nonsingular, but RCOND is less than machine
precision, meaning that the matrix is singular
to working precision. Nevertheless, the
solution and error bounds are computed because
there are a number of situations where the
computed solution can be more accurate than the
value of RCOND would suggest.
=====================================================================
Parameter adjustments */
/* 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;
real r__1, r__2;
complex q__1;
/* Local variables */
static real amax, smin, smax;
static integer i__, j;
extern logical lsame_(char *, char *);
static real scond, anorm;
static logical equil, rcequ;
extern doublereal clanhe_(char *, char *, integer *, complex *, integer *,
real *);
extern /* Subroutine */ int claqhe_(char *, integer *, complex *, integer
*, real *, real *, real *, char *);
extern doublereal slamch_(char *);
static logical nofact;
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), xerbla_(char *,
integer *);
static real bignum;
extern /* Subroutine */ int cpocon_(char *, integer *, complex *, integer
*, real *, real *, complex *, real *, integer *);
static integer infequ;
extern /* Subroutine */ int cpoequ_(integer *, complex *, integer *, real
*, real *, real *, integer *), cporfs_(char *, integer *, integer
*, complex *, integer *, complex *, integer *, complex *, integer
*, complex *, integer *, real *, real *, complex *, real *,
integer *), cpotrf_(char *, integer *, complex *, integer
*, integer *), cpotrs_(char *, integer *, integer *,
complex *, integer *, complex *, integer *, integer *);
static real smlnum;
#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;
--s;
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;
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
if (nofact || equil) {
*(unsigned char *)equed = 'N';
rcequ = FALSE_;
} else {
rcequ = lsame_(equed, "Y");
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
}
/* Test the input parameters. */
if (! nofact && ! equil && ! lsame_(fact, "F")) {
*info = -1;
} else if (! lsame_(uplo, "U") && ! lsame_(uplo,
"L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldaf < max(1,*n)) {
*info = -8;
} else if (lsame_(fact, "F") && ! (rcequ || lsame_(
equed, "N"))) {
*info = -9;
} else {
if (rcequ) {
smin = bignum;
smax = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
r__1 = smin, r__2 = s[j];
smin = dmin(r__1,r__2);
/* Computing MAX */
r__1 = smax, r__2 = s[j];
smax = dmax(r__1,r__2);
/* L10: */
}
if (smin <= 0.f) {
*info = -10;
} else if (*n > 0) {
scond = dmax(smin,smlnum) / dmin(smax,bignum);
} else {
scond = 1.f;
}
}
if (*info == 0) {
if (*ldb < max(1,*n)) {
*info = -12;
} else if (*ldx < max(1,*n)) {
*info = -14;
}
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CPOSVX", &i__1);
return 0;
}
if (equil) {
/* Compute row and column scalings to equilibrate the matrix A. */
cpoequ_(n, &a[a_offset], lda, &s[1], &scond, &amax, &infequ);
if (infequ == 0) {
/* Equilibrate the matrix. */
claqhe_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, equed);
rcequ = lsame_(equed, "Y");
}
}
/* Scale the right hand side. */
if (rcequ) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = i__;
i__5 = b_subscr(i__, j);
q__1.r = s[i__4] * b[i__5].r, q__1.i = s[i__4] * b[i__5].i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L20: */
}
/* L30: */
}
}
if (nofact || equil) {
/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
clacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
cpotrf_(uplo, n, &af[af_offset], ldaf, info);
/* Return if INFO is non-zero. */
if (*info != 0) {
if (*info > 0) {
*rcond = 0.f;
}
return 0;
}
}
/* Compute the norm of the matrix A. */
anorm = clanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
/* Compute the reciprocal of the condition number of A. */
cpocon_(uplo, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &rwork[1],
info);
/* Set INFO = N+1 if the matrix is singular to working precision. */
if (*rcond < slamch_("Epsilon")) {
*info = *n + 1;
}
/* Compute the solution matrix X. */
clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
cpotrs_(uplo, n, nrhs, &af[af_offset], ldaf, &x[x_offset], ldx, info);
/* Use iterative refinement to improve the computed solution and
compute error bounds and backward error estimates for it. */
cporfs_(uplo, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &b[
b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1], &
rwork[1], info);
/* Transform the solution matrix X to a solution of the original
system. */
if (rcequ) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = x_subscr(i__, j);
i__4 = i__;
i__5 = x_subscr(i__, j);
q__1.r = s[i__4] * x[i__5].r, q__1.i = s[i__4] * x[i__5].i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
/* L40: */
}
/* L50: */
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] /= scond;
/* L60: */
}
}
return 0;
/* End of CPOSVX */
} /* cposvx_ */
/* Subroutine */ int ctrrfs_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, complex *a, integer *lda, complex *b, integer *ldb,
complex *x, integer *ldx, real *ferr, real *berr, complex *work, real
*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
=======
CTRRFS provides error bounds and backward error estimates for the
solution to a system of linear equations with a triangular
coefficient matrix.
The solution matrix X must be computed by CTRTRS or some other
means before entering this routine. CTRRFS 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.
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 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).
B (input) COMPLEX 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 array, dimension (LDX,NRHS)
The solution matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
FERR (output) REAL 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) REAL 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 array, dimension (2*N)
RWORK (workspace) REAL 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 a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2,
i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
complex q__1;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static integer kase;
static real safe1, safe2;
static integer i__, j, k;
static real s;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
static logical upper;
extern /* Subroutine */ int ctrmv_(char *, char *, char *, integer *,
complex *, integer *, complex *, integer *), ctrsv_(char *, char *, char *, integer *, complex *,
integer *, complex *, integer *), clacon_(
integer *, complex *, complex *, real *, integer *);
static real xk;
extern doublereal slamch_(char *);
static integer nz;
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static logical notran;
static char transn[1], transt[1];
static logical nounit;
static real lstres, 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;
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;
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 (*nrhs < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldx < max(1,*n)) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTRRFS", &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.f;
berr[j] = 0.f;
/* 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 = slamch_("Epsilon");
safmin = slamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
/* Compute residual R = B - op(A) * X,
where op(A) = A, A**T, or A**H, depending on TRANS. */
ccopy_(n, &x_ref(1, j), &c__1, &work[1], &c__1);
ctrmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[1], &c__1);
q__1.r = -1.f, q__1.i = 0.f;
caxpy_(n, &q__1, &b_ref(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 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__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
b_ref(i__, j)), dabs(r__2));
/* L20: */
}
if (notran) {
/* Compute abs(A)*abs(X) + abs(B). */
if (upper) {
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = x_subscr(k, j);
xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
x_ref(k, j)), dabs(r__2));
i__3 = k;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = a_subscr(i__, k);
rwork[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (
r__2 = r_imag(&a_ref(i__, k)), dabs(r__2))
) * xk;
/* L30: */
}
/* L40: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = x_subscr(k, j);
xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
x_ref(k, j)), dabs(r__2));
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = a_subscr(i__, k);
rwork[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (
r__2 = r_imag(&a_ref(i__, k)), dabs(r__2))
) * xk;
/* L50: */
}
rwork[k] += xk;
/* L60: */
}
}
} else {
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = x_subscr(k, j);
xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
x_ref(k, j)), dabs(r__2));
i__3 = *n;
for (i__ = k; i__ <= i__3; ++i__) {
i__4 = a_subscr(i__, k);
rwork[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (
r__2 = r_imag(&a_ref(i__, k)), dabs(r__2))
) * xk;
/* L70: */
}
/* L80: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = x_subscr(k, j);
xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
x_ref(k, j)), dabs(r__2));
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
i__4 = a_subscr(i__, k);
rwork[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (
r__2 = r_imag(&a_ref(i__, k)), dabs(r__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 <= i__2; ++k) {
s = 0.f;
i__3 = k;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = a_subscr(i__, k);
i__5 = x_subscr(i__, j);
s += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&a_ref(i__, k)), dabs(r__2))) * ((
r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
r_imag(&x_ref(i__, j)), dabs(r__4)));
/* L110: */
}
rwork[k] += s;
/* L120: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = x_subscr(k, j);
s = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
x_ref(k, j)), dabs(r__2));
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = a_subscr(i__, k);
i__5 = x_subscr(i__, j);
s += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&a_ref(i__, k)), dabs(r__2))) * ((
r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
r_imag(&x_ref(i__, j)), dabs(r__4)));
/* L130: */
}
rwork[k] += s;
/* L140: */
}
}
} else {
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.f;
i__3 = *n;
for (i__ = k; i__ <= i__3; ++i__) {
i__4 = a_subscr(i__, k);
i__5 = x_subscr(i__, j);
s += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&a_ref(i__, k)), dabs(r__2))) * ((
r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
r_imag(&x_ref(i__, j)), dabs(r__4)));
/* L150: */
}
rwork[k] += s;
/* L160: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = x_subscr(k, j);
s = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
x_ref(k, j)), dabs(r__2));
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
i__4 = a_subscr(i__, k);
i__5 = x_subscr(i__, j);
s += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&a_ref(i__, k)), dabs(r__2))) * ((
r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
r_imag(&x_ref(i__, j)), dabs(r__4)));
/* L170: */
}
rwork[k] += s;
/* L180: */
}
}
}
}
s = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
/* Computing MAX */
i__3 = i__;
r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2))) / rwork[i__];
s = dmax(r__3,r__4);
} else {
/* Computing MAX */
i__3 = i__;
r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + safe1) / (rwork[i__]
+ safe1);
s = dmax(r__3,r__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 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 CLACON 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__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
i__];
} else {
i__3 = i__;
rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
i__] + safe1;
}
/* L200: */
}
kase = 0;
L210:
clacon_(n, &work[*n + 1], &work[1], &ferr[j], &kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(op(A)**H). */
ctrsv_(uplo, transt, diag, n, &a[a_offset], lda, &work[1], &
c__1);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__;
q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L220: */
}
} 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__;
q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L230: */
}
ctrsv_(uplo, transn, diag, n, &a[a_offset], lda, &work[1], &
c__1);
}
goto L210;
}
/* Normalize error. */
lstres = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = x_subscr(i__, j);
r__3 = lstres, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x_ref(i__, j)), dabs(r__2));
lstres = dmax(r__3,r__4);
/* L240: */
}
if (lstres != 0.f) {
ferr[j] /= lstres;
}
/* L250: */
}
return 0;
/* End of CTRRFS */
} /* ctrrfs_ */
/* 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 zptt05_(integer *n, integer *nrhs, doublereal *d__,
doublecomplex *e, doublecomplex *b, integer *ldb, doublecomplex *x,
integer *ldx, doublecomplex *xact, integer *ldxact, doublereal *ferr,
doublereal *berr, doublereal *reslts)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, xact_dim1, xact_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;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static doublereal diff, axbi;
static integer imax;
static doublereal unfl, ovfl;
static integer i__, j, k;
static doublereal xnorm;
extern doublereal dlamch_(char *);
static integer nz;
static doublereal errbnd;
extern integer izamax_(integer *, doublecomplex *, integer *);
static doublereal eps, tmp;
#define xact_subscr(a_1,a_2) (a_2)*xact_dim1 + a_1
#define xact_ref(a_1,a_2) xact[xact_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)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
ZPTT05 tests the error bounds from iterative refinement for the
computed solution to a system of equations A*X = B, where A is a
Hermitian tridiagonal matrix of order n.
RESLTS(1) = test of the error bound
= norm(X - XACT) / ( norm(X) * FERR )
A large value is returned if this ratio is not less than one.
RESLTS(2) = residual from the iterative refinement routine
= the maximum of BERR / ( NZ*EPS + (*) ), where
(*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
and NZ = max. number of nonzeros in any row of A, plus 1
Arguments
=========
N (input) INTEGER
The number of rows of the matrices X, B, and XACT, and the
order of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of columns of the matrices X, B, and XACT.
NRHS >= 0.
D (input) DOUBLE PRECISION array, dimension (N)
The n diagonal elements of the tridiagonal matrix A.
E (input) COMPLEX*16 array, dimension (N-1)
The (n-1) subdiagonal elements of the tridiagonal matrix A.
B (input) COMPLEX*16 array, dimension (LDB,NRHS)
The right hand side vectors for the system of linear
equations.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (input) COMPLEX*16 array, dimension (LDX,NRHS)
The computed solution vectors. Each vector is stored as a
column of the matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
XACT (input) COMPLEX*16 array, dimension (LDX,NRHS)
The exact solution vectors. Each vector is stored as a
column of the matrix XACT.
LDXACT (input) INTEGER
The leading dimension of the array XACT. LDXACT >= max(1,N).
FERR (input) DOUBLE PRECISION array, dimension (NRHS)
The estimated forward error bounds for each solution vector
X. If XTRUE is the true solution, FERR bounds the magnitude
of the largest entry in (X - XTRUE) divided by the magnitude
of the largest entry in X.
BERR (input) DOUBLE PRECISION array, dimension (NRHS)
The componentwise relative backward error of each solution
vector (i.e., the smallest relative change in any entry of A
or B that makes X an exact solution).
RESLTS (output) DOUBLE PRECISION array, dimension (2)
The maximum over the NRHS solution vectors of the ratios:
RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
RESLTS(2) = BERR / ( NZ*EPS + (*) )
=====================================================================
Quick exit if N = 0 or NRHS = 0.
Parameter adjustments */
--d__;
--e;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
xact_dim1 = *ldxact;
xact_offset = 1 + xact_dim1 * 1;
xact -= xact_offset;
--ferr;
--berr;
--reslts;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
reslts[1] = 0.;
reslts[2] = 0.;
return 0;
}
eps = dlamch_("Epsilon");
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
nz = 4;
/* Test 1: Compute the maximum of
norm(X - XACT) / ( norm(X) * FERR )
over all the vectors X and XACT using the infinity-norm. */
errbnd = 0.;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
imax = izamax_(n, &x_ref(1, j), &c__1);
/* Computing MAX */
i__2 = x_subscr(imax, j);
d__3 = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x_ref(imax, j))
, abs(d__2));
xnorm = max(d__3,unfl);
diff = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = x_subscr(i__, j);
i__4 = xact_subscr(i__, j);
z__2.r = x[i__3].r - xact[i__4].r, z__2.i = x[i__3].i - xact[i__4]
.i;
z__1.r = z__2.r, z__1.i = z__2.i;
/* Computing MAX */
d__3 = diff, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
z__1), abs(d__2));
diff = max(d__3,d__4);
/* L10: */
}
if (xnorm > 1.) {
goto L20;
} else if (diff <= ovfl * xnorm) {
goto L20;
} else {
errbnd = 1. / eps;
goto L30;
}
L20:
if (diff / xnorm <= ferr[j]) {
/* Computing MAX */
d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
errbnd = max(d__1,d__2);
} else {
errbnd = 1. / eps;
}
L30:
;
}
reslts[1] = errbnd;
/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where
(*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
i__1 = *nrhs;
for (k = 1; k <= i__1; ++k) {
if (*n == 1) {
i__2 = x_subscr(1, k);
z__2.r = d__[1] * x[i__2].r, z__2.i = d__[1] * x[i__2].i;
z__1.r = z__2.r, z__1.i = z__2.i;
i__3 = b_subscr(1, k);
axbi = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b_ref(1, k)
), abs(d__2)) + ((d__3 = z__1.r, abs(d__3)) + (d__4 =
d_imag(&z__1), abs(d__4)));
} else {
i__2 = x_subscr(1, k);
z__2.r = d__[1] * x[i__2].r, z__2.i = d__[1] * x[i__2].i;
z__1.r = z__2.r, z__1.i = z__2.i;
i__3 = b_subscr(1, k);
i__4 = x_subscr(2, k);
axbi = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b_ref(1, k)
), abs(d__2)) + ((d__3 = z__1.r, abs(d__3)) + (d__4 =
d_imag(&z__1), abs(d__4))) + ((d__5 = e[1].r, abs(d__5))
+ (d__6 = d_imag(&e[1]), abs(d__6))) * ((d__7 = x[i__4].r,
abs(d__7)) + (d__8 = d_imag(&x_ref(2, k)), abs(d__8)));
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = x_subscr(i__, k);
z__2.r = d__[i__3] * x[i__4].r, z__2.i = d__[i__3] * x[i__4]
.i;
z__1.r = z__2.r, z__1.i = z__2.i;
i__5 = b_subscr(i__, k);
i__6 = i__ - 1;
i__7 = x_subscr(i__ - 1, k);
i__8 = i__;
i__9 = x_subscr(i__ + 1, k);
tmp = (d__1 = b[i__5].r, abs(d__1)) + (d__2 = d_imag(&b_ref(
i__, k)), abs(d__2)) + ((d__3 = e[i__6].r, abs(d__3))
+ (d__4 = d_imag(&e[i__ - 1]), abs(d__4))) * ((d__5 =
x[i__7].r, abs(d__5)) + (d__6 = d_imag(&x_ref(i__ - 1,
k)), abs(d__6))) + ((d__7 = z__1.r, abs(d__7)) + (
d__8 = d_imag(&z__1), abs(d__8))) + ((d__9 = e[i__8]
.r, abs(d__9)) + (d__10 = d_imag(&e[i__]), abs(d__10))
) * ((d__11 = x[i__9].r, abs(d__11)) + (d__12 =
d_imag(&x_ref(i__ + 1, k)), abs(d__12)));
axbi = min(axbi,tmp);
/* L40: */
}
i__2 = *n;
i__3 = x_subscr(*n, k);
z__2.r = d__[i__2] * x[i__3].r, z__2.i = d__[i__2] * x[i__3].i;
z__1.r = z__2.r, z__1.i = z__2.i;
i__4 = b_subscr(*n, k);
i__5 = *n - 1;
i__6 = x_subscr(*n - 1, k);
tmp = (d__1 = b[i__4].r, abs(d__1)) + (d__2 = d_imag(&b_ref(*n, k)
), abs(d__2)) + ((d__3 = e[i__5].r, abs(d__3)) + (d__4 =
d_imag(&e[*n - 1]), abs(d__4))) * ((d__5 = x[i__6].r, abs(
d__5)) + (d__6 = d_imag(&x_ref(*n - 1, k)), abs(d__6))) +
((d__7 = z__1.r, abs(d__7)) + (d__8 = d_imag(&z__1), abs(
d__8)));
axbi = min(axbi,tmp);
}
/* Computing MAX */
d__1 = axbi, d__2 = nz * unfl;
tmp = berr[k] / (nz * eps + nz * unfl / max(d__1,d__2));
if (k == 1) {
reslts[2] = tmp;
} else {
reslts[2] = max(reslts[2],tmp);
}
/* L50: */
}
return 0;
/* End of ZPTT05 */
} /* zptt05_ */
/* Subroutine */ int clagtm_(char *trans, integer *n, integer *nrhs, real *
alpha, complex *dl, complex *d__, complex *du, complex *x, integer *
ldx, real *beta, complex *b, integer *ldb)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
CLAGTM performs a matrix-vector product of the form
B := alpha * A * X + beta * B
where A is a tridiagonal matrix of order N, B and X are N by NRHS
matrices, and alpha and beta are real scalars, each of which may be
0., 1., or -1.
Arguments
=========
TRANS (input) CHARACTER
Specifies the operation applied to A.
= 'N': No transpose, B := alpha * A * X + beta * B
= 'T': Transpose, B := alpha * A**T * X + beta * B
= 'C': Conjugate transpose, B := alpha * A**H * X + beta * B
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 X and B.
ALPHA (input) REAL
The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise,
it is assumed to be 0.
DL (input) COMPLEX array, dimension (N-1)
The (n-1) sub-diagonal elements of T.
D (input) COMPLEX array, dimension (N)
The diagonal elements of T.
DU (input) COMPLEX array, dimension (N-1)
The (n-1) super-diagonal elements of T.
X (input) COMPLEX array, dimension (LDX,NRHS)
The N by NRHS matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(N,1).
BETA (input) REAL
The scalar beta. BETA must be 0., 1., or -1.; otherwise,
it is assumed to be 1.
B (input/output) COMPLEX array, dimension (LDB,NRHS)
On entry, the N by NRHS matrix B.
On exit, B is overwritten by the matrix expression
B := alpha * A * X + beta * B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(N,1).
=====================================================================
Parameter adjustments */
/* 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, i__10;
complex q__1, q__2, q__3, q__4, q__5, q__6, q__7, q__8, q__9;
/* Builtin functions */
void r_cnjg(complex *, complex *);
/* Local variables */
static integer i__, j;
extern logical lsame_(char *, char *);
#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)]
--dl;
--d__;
--du;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
/* Function Body */
if (*n == 0) {
return 0;
}
/* Multiply B by BETA if BETA.NE.1. */
if (*beta == 0.f) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
b[i__3].r = 0.f, b[i__3].i = 0.f;
/* L10: */
}
/* L20: */
}
} else if (*beta == -1.f) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = b_subscr(i__, j);
q__1.r = -b[i__4].r, q__1.i = -b[i__4].i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L30: */
}
/* L40: */
}
}
if (*alpha == 1.f) {
if (lsame_(trans, "N")) {
/* Compute B := B + A*X */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
if (*n == 1) {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
i__4 = x_subscr(1, j);
q__2.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i,
q__2.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4]
.r;
q__1.r = b[i__3].r + q__2.r, q__1.i = b[i__3].i + q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
} else {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
i__4 = x_subscr(1, j);
q__3.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i,
q__3.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4]
.r;
q__2.r = b[i__3].r + q__3.r, q__2.i = b[i__3].i + q__3.i;
i__5 = x_subscr(2, j);
q__4.r = du[1].r * x[i__5].r - du[1].i * x[i__5].i,
q__4.i = du[1].r * x[i__5].i + du[1].i * x[i__5]
.r;
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = b_subscr(*n, j);
i__3 = b_subscr(*n, j);
i__4 = *n - 1;
i__5 = x_subscr(*n - 1, j);
q__3.r = dl[i__4].r * x[i__5].r - dl[i__4].i * x[i__5].i,
q__3.i = dl[i__4].r * x[i__5].i + dl[i__4].i * x[
i__5].r;
q__2.r = b[i__3].r + q__3.r, q__2.i = b[i__3].i + q__3.i;
i__6 = *n;
i__7 = x_subscr(*n, j);
q__4.r = d__[i__6].r * x[i__7].r - d__[i__6].i * x[i__7]
.i, q__4.i = d__[i__6].r * x[i__7].i + d__[i__6]
.i * x[i__7].r;
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = b_subscr(i__, j);
i__5 = i__ - 1;
i__6 = x_subscr(i__ - 1, j);
q__4.r = dl[i__5].r * x[i__6].r - dl[i__5].i * x[i__6]
.i, q__4.i = dl[i__5].r * x[i__6].i + dl[i__5]
.i * x[i__6].r;
q__3.r = b[i__4].r + q__4.r, q__3.i = b[i__4].i +
q__4.i;
i__7 = i__;
i__8 = x_subscr(i__, j);
q__5.r = d__[i__7].r * x[i__8].r - d__[i__7].i * x[
i__8].i, q__5.i = d__[i__7].r * x[i__8].i +
d__[i__7].i * x[i__8].r;
q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
i__9 = i__;
i__10 = x_subscr(i__ + 1, j);
q__6.r = du[i__9].r * x[i__10].r - du[i__9].i * x[
i__10].i, q__6.i = du[i__9].r * x[i__10].i +
du[i__9].i * x[i__10].r;
q__1.r = q__2.r + q__6.r, q__1.i = q__2.i + q__6.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L50: */
}
}
/* L60: */
}
} else if (lsame_(trans, "T")) {
/* Compute B := B + A**T * X */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
if (*n == 1) {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
i__4 = x_subscr(1, j);
q__2.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i,
q__2.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4]
.r;
q__1.r = b[i__3].r + q__2.r, q__1.i = b[i__3].i + q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
} else {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
i__4 = x_subscr(1, j);
q__3.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i,
q__3.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4]
.r;
q__2.r = b[i__3].r + q__3.r, q__2.i = b[i__3].i + q__3.i;
i__5 = x_subscr(2, j);
q__4.r = dl[1].r * x[i__5].r - dl[1].i * x[i__5].i,
q__4.i = dl[1].r * x[i__5].i + dl[1].i * x[i__5]
.r;
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = b_subscr(*n, j);
i__3 = b_subscr(*n, j);
i__4 = *n - 1;
i__5 = x_subscr(*n - 1, j);
q__3.r = du[i__4].r * x[i__5].r - du[i__4].i * x[i__5].i,
q__3.i = du[i__4].r * x[i__5].i + du[i__4].i * x[
i__5].r;
q__2.r = b[i__3].r + q__3.r, q__2.i = b[i__3].i + q__3.i;
i__6 = *n;
i__7 = x_subscr(*n, j);
q__4.r = d__[i__6].r * x[i__7].r - d__[i__6].i * x[i__7]
.i, q__4.i = d__[i__6].r * x[i__7].i + d__[i__6]
.i * x[i__7].r;
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = b_subscr(i__, j);
i__5 = i__ - 1;
i__6 = x_subscr(i__ - 1, j);
q__4.r = du[i__5].r * x[i__6].r - du[i__5].i * x[i__6]
.i, q__4.i = du[i__5].r * x[i__6].i + du[i__5]
.i * x[i__6].r;
q__3.r = b[i__4].r + q__4.r, q__3.i = b[i__4].i +
q__4.i;
i__7 = i__;
i__8 = x_subscr(i__, j);
q__5.r = d__[i__7].r * x[i__8].r - d__[i__7].i * x[
i__8].i, q__5.i = d__[i__7].r * x[i__8].i +
d__[i__7].i * x[i__8].r;
q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
i__9 = i__;
i__10 = x_subscr(i__ + 1, j);
q__6.r = dl[i__9].r * x[i__10].r - dl[i__9].i * x[
i__10].i, q__6.i = dl[i__9].r * x[i__10].i +
dl[i__9].i * x[i__10].r;
q__1.r = q__2.r + q__6.r, q__1.i = q__2.i + q__6.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L70: */
}
}
/* L80: */
}
} else if (lsame_(trans, "C")) {
/* Compute B := B + A**H * X */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
if (*n == 1) {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
r_cnjg(&q__3, &d__[1]);
i__4 = x_subscr(1, j);
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.i =
q__3.r * x[i__4].i + q__3.i * x[i__4].r;
q__1.r = b[i__3].r + q__2.r, q__1.i = b[i__3].i + q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
} else {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
r_cnjg(&q__4, &d__[1]);
i__4 = x_subscr(1, j);
q__3.r = q__4.r * x[i__4].r - q__4.i * x[i__4].i, q__3.i =
q__4.r * x[i__4].i + q__4.i * x[i__4].r;
q__2.r = b[i__3].r + q__3.r, q__2.i = b[i__3].i + q__3.i;
r_cnjg(&q__6, &dl[1]);
i__5 = x_subscr(2, j);
q__5.r = q__6.r * x[i__5].r - q__6.i * x[i__5].i, q__5.i =
q__6.r * x[i__5].i + q__6.i * x[i__5].r;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = b_subscr(*n, j);
i__3 = b_subscr(*n, j);
r_cnjg(&q__4, &du[*n - 1]);
i__4 = x_subscr(*n - 1, j);
q__3.r = q__4.r * x[i__4].r - q__4.i * x[i__4].i, q__3.i =
q__4.r * x[i__4].i + q__4.i * x[i__4].r;
q__2.r = b[i__3].r + q__3.r, q__2.i = b[i__3].i + q__3.i;
r_cnjg(&q__6, &d__[*n]);
i__5 = x_subscr(*n, j);
q__5.r = q__6.r * x[i__5].r - q__6.i * x[i__5].i, q__5.i =
q__6.r * x[i__5].i + q__6.i * x[i__5].r;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = b_subscr(i__, j);
r_cnjg(&q__5, &du[i__ - 1]);
i__5 = x_subscr(i__ - 1, j);
q__4.r = q__5.r * x[i__5].r - q__5.i * x[i__5].i,
q__4.i = q__5.r * x[i__5].i + q__5.i * x[i__5]
.r;
q__3.r = b[i__4].r + q__4.r, q__3.i = b[i__4].i +
q__4.i;
r_cnjg(&q__7, &d__[i__]);
i__6 = x_subscr(i__, j);
q__6.r = q__7.r * x[i__6].r - q__7.i * x[i__6].i,
q__6.i = q__7.r * x[i__6].i + q__7.i * x[i__6]
.r;
q__2.r = q__3.r + q__6.r, q__2.i = q__3.i + q__6.i;
r_cnjg(&q__9, &dl[i__]);
i__7 = x_subscr(i__ + 1, j);
q__8.r = q__9.r * x[i__7].r - q__9.i * x[i__7].i,
q__8.i = q__9.r * x[i__7].i + q__9.i * x[i__7]
.r;
q__1.r = q__2.r + q__8.r, q__1.i = q__2.i + q__8.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L90: */
}
}
/* L100: */
}
}
} else if (*alpha == -1.f) {
if (lsame_(trans, "N")) {
/* Compute B := B - A*X */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
if (*n == 1) {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
i__4 = x_subscr(1, j);
q__2.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i,
q__2.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4]
.r;
q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
} else {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
i__4 = x_subscr(1, j);
q__3.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i,
q__3.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4]
.r;
q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i;
i__5 = x_subscr(2, j);
q__4.r = du[1].r * x[i__5].r - du[1].i * x[i__5].i,
q__4.i = du[1].r * x[i__5].i + du[1].i * x[i__5]
.r;
q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = b_subscr(*n, j);
i__3 = b_subscr(*n, j);
i__4 = *n - 1;
i__5 = x_subscr(*n - 1, j);
q__3.r = dl[i__4].r * x[i__5].r - dl[i__4].i * x[i__5].i,
q__3.i = dl[i__4].r * x[i__5].i + dl[i__4].i * x[
i__5].r;
q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i;
i__6 = *n;
i__7 = x_subscr(*n, j);
q__4.r = d__[i__6].r * x[i__7].r - d__[i__6].i * x[i__7]
.i, q__4.i = d__[i__6].r * x[i__7].i + d__[i__6]
.i * x[i__7].r;
q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = b_subscr(i__, j);
i__5 = i__ - 1;
i__6 = x_subscr(i__ - 1, j);
q__4.r = dl[i__5].r * x[i__6].r - dl[i__5].i * x[i__6]
.i, q__4.i = dl[i__5].r * x[i__6].i + dl[i__5]
.i * x[i__6].r;
q__3.r = b[i__4].r - q__4.r, q__3.i = b[i__4].i -
q__4.i;
i__7 = i__;
i__8 = x_subscr(i__, j);
q__5.r = d__[i__7].r * x[i__8].r - d__[i__7].i * x[
i__8].i, q__5.i = d__[i__7].r * x[i__8].i +
d__[i__7].i * x[i__8].r;
q__2.r = q__3.r - q__5.r, q__2.i = q__3.i - q__5.i;
i__9 = i__;
i__10 = x_subscr(i__ + 1, j);
q__6.r = du[i__9].r * x[i__10].r - du[i__9].i * x[
i__10].i, q__6.i = du[i__9].r * x[i__10].i +
du[i__9].i * x[i__10].r;
q__1.r = q__2.r - q__6.r, q__1.i = q__2.i - q__6.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L110: */
}
}
/* L120: */
}
} else if (lsame_(trans, "T")) {
/* Compute B := B - A'*X */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
if (*n == 1) {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
i__4 = x_subscr(1, j);
q__2.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i,
q__2.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4]
.r;
q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
} else {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
i__4 = x_subscr(1, j);
q__3.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i,
q__3.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4]
.r;
q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i;
i__5 = x_subscr(2, j);
q__4.r = dl[1].r * x[i__5].r - dl[1].i * x[i__5].i,
q__4.i = dl[1].r * x[i__5].i + dl[1].i * x[i__5]
.r;
q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = b_subscr(*n, j);
i__3 = b_subscr(*n, j);
i__4 = *n - 1;
i__5 = x_subscr(*n - 1, j);
q__3.r = du[i__4].r * x[i__5].r - du[i__4].i * x[i__5].i,
q__3.i = du[i__4].r * x[i__5].i + du[i__4].i * x[
i__5].r;
q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i;
i__6 = *n;
i__7 = x_subscr(*n, j);
q__4.r = d__[i__6].r * x[i__7].r - d__[i__6].i * x[i__7]
.i, q__4.i = d__[i__6].r * x[i__7].i + d__[i__6]
.i * x[i__7].r;
q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = b_subscr(i__, j);
i__5 = i__ - 1;
i__6 = x_subscr(i__ - 1, j);
q__4.r = du[i__5].r * x[i__6].r - du[i__5].i * x[i__6]
.i, q__4.i = du[i__5].r * x[i__6].i + du[i__5]
.i * x[i__6].r;
q__3.r = b[i__4].r - q__4.r, q__3.i = b[i__4].i -
q__4.i;
i__7 = i__;
i__8 = x_subscr(i__, j);
q__5.r = d__[i__7].r * x[i__8].r - d__[i__7].i * x[
i__8].i, q__5.i = d__[i__7].r * x[i__8].i +
d__[i__7].i * x[i__8].r;
q__2.r = q__3.r - q__5.r, q__2.i = q__3.i - q__5.i;
i__9 = i__;
i__10 = x_subscr(i__ + 1, j);
q__6.r = dl[i__9].r * x[i__10].r - dl[i__9].i * x[
i__10].i, q__6.i = dl[i__9].r * x[i__10].i +
dl[i__9].i * x[i__10].r;
q__1.r = q__2.r - q__6.r, q__1.i = q__2.i - q__6.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L130: */
}
}
/* L140: */
}
} else if (lsame_(trans, "C")) {
/* Compute B := B - A'*X */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
if (*n == 1) {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
r_cnjg(&q__3, &d__[1]);
i__4 = x_subscr(1, j);
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.i =
q__3.r * x[i__4].i + q__3.i * x[i__4].r;
q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
} else {
i__2 = b_subscr(1, j);
i__3 = b_subscr(1, j);
r_cnjg(&q__4, &d__[1]);
i__4 = x_subscr(1, j);
q__3.r = q__4.r * x[i__4].r - q__4.i * x[i__4].i, q__3.i =
q__4.r * x[i__4].i + q__4.i * x[i__4].r;
q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i;
r_cnjg(&q__6, &dl[1]);
i__5 = x_subscr(2, j);
q__5.r = q__6.r * x[i__5].r - q__6.i * x[i__5].i, q__5.i =
q__6.r * x[i__5].i + q__6.i * x[i__5].r;
q__1.r = q__2.r - q__5.r, q__1.i = q__2.i - q__5.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = b_subscr(*n, j);
i__3 = b_subscr(*n, j);
r_cnjg(&q__4, &du[*n - 1]);
i__4 = x_subscr(*n - 1, j);
q__3.r = q__4.r * x[i__4].r - q__4.i * x[i__4].i, q__3.i =
q__4.r * x[i__4].i + q__4.i * x[i__4].r;
q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i;
r_cnjg(&q__6, &d__[*n]);
i__5 = x_subscr(*n, j);
q__5.r = q__6.r * x[i__5].r - q__6.i * x[i__5].i, q__5.i =
q__6.r * x[i__5].i + q__6.i * x[i__5].r;
q__1.r = q__2.r - q__5.r, q__1.i = q__2.i - q__5.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = b_subscr(i__, j);
r_cnjg(&q__5, &du[i__ - 1]);
i__5 = x_subscr(i__ - 1, j);
q__4.r = q__5.r * x[i__5].r - q__5.i * x[i__5].i,
q__4.i = q__5.r * x[i__5].i + q__5.i * x[i__5]
.r;
q__3.r = b[i__4].r - q__4.r, q__3.i = b[i__4].i -
q__4.i;
r_cnjg(&q__7, &d__[i__]);
i__6 = x_subscr(i__, j);
q__6.r = q__7.r * x[i__6].r - q__7.i * x[i__6].i,
q__6.i = q__7.r * x[i__6].i + q__7.i * x[i__6]
.r;
q__2.r = q__3.r - q__6.r, q__2.i = q__3.i - q__6.i;
r_cnjg(&q__9, &dl[i__]);
i__7 = x_subscr(i__ + 1, j);
q__8.r = q__9.r * x[i__7].r - q__9.i * x[i__7].i,
q__8.i = q__9.r * x[i__7].i + q__9.i * x[i__7]
.r;
q__1.r = q__2.r - q__8.r, q__1.i = q__2.i - q__8.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L150: */
}
}
/* L160: */
}
}
}
return 0;
/* End of CLAGTM */
} /* clagtm_ */
/* Subroutine */ int cgtrfs_(char *trans, integer *n, integer *nrhs, complex *
dl, complex *d__, complex *du, complex *dlf, complex *df, complex *
duf, complex *du2, integer *ipiv, complex *b, integer *ldb, complex *
x, integer *ldx, real *ferr, real *berr, complex *work, real *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
=======
CGTRFS 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 array, dimension (N-1)
The (n-1) subdiagonal elements of A.
D (input) COMPLEX array, dimension (N)
The diagonal elements of A.
DU (input) COMPLEX array, dimension (N-1)
The (n-1) superdiagonal elements of A.
DLF (input) COMPLEX array, dimension (N-1)
The (n-1) multipliers that define the matrix L from the
LU factorization of A as computed by CGTTRF.
DF (input) COMPLEX array, dimension (N)
The n diagonal elements of the upper triangular matrix U from
the LU factorization of A.
DUF (input) COMPLEX array, dimension (N-1)
The (n-1) elements of the first superdiagonal of U.
DU2 (input) COMPLEX 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 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 array, dimension (LDX,NRHS)
On entry, the solution matrix X, as computed by CGTTRS.
On exit, the improved solution matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
FERR (output) REAL 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) REAL 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 array, dimension (2*N)
RWORK (workspace) REAL array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Internal Parameters
===================
ITMAX is the maximum number of steps of iterative refinement.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static real c_b18 = -1.f;
static real c_b19 = 1.f;
static complex c_b26 = {1.f,0.f};
/* 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;
real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10, r__11,
r__12, r__13, r__14;
complex q__1;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static integer kase;
static real safe1, safe2;
static integer i__, j;
static real s;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
static integer count;
extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real
*, integer *), clagtm_(char *, integer *, integer *, real *,
complex *, complex *, complex *, complex *, integer *, real *,
complex *, integer *);
static integer nz;
extern doublereal slamch_(char *);
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static logical notran;
static char transn[1];
extern /* Subroutine */ int cgttrs_(char *, integer *, integer *, complex
*, complex *, complex *, complex *, integer *, complex *, integer
*, integer *);
static char transt[1];
static real lstres, eps;
#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)]
--dl;
--d__;
--du;
--dlf;
--df;
--duf;
--du2;
--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 (*ldb < max(1,*n)) {
*info = -13;
} else if (*ldx < max(1,*n)) {
*info = -15;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGTRFS", &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.f;
berr[j] = 0.f;
/* 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 = slamch_("Epsilon");
safmin = slamch_("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.f;
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. */
ccopy_(n, &b_ref(1, j), &c__1, &work[1], &c__1);
clagtm_(trans, n, &c__1, &c_b18, &dl[1], &d__[1], &du[1], &x_ref(1, j)
, ldx, &c_b19, &work[1], n);
/* Compute abs(op(A))*abs(x) + abs(b) for use in the backward
error bound. */
if (notran) {
if (*n == 1) {
i__2 = b_subscr(1, j);
i__3 = x_subscr(1, j);
rwork[1] = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
b_ref(1, j)), dabs(r__2)) + ((r__3 = d__[1].r, dabs(
r__3)) + (r__4 = r_imag(&d__[1]), dabs(r__4))) * ((
r__5 = x[i__3].r, dabs(r__5)) + (r__6 = r_imag(&x_ref(
1, j)), dabs(r__6)));
} else {
i__2 = b_subscr(1, j);
i__3 = x_subscr(1, j);
i__4 = x_subscr(2, j);
rwork[1] = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
b_ref(1, j)), dabs(r__2)) + ((r__3 = d__[1].r, dabs(
r__3)) + (r__4 = r_imag(&d__[1]), dabs(r__4))) * ((
r__5 = x[i__3].r, dabs(r__5)) + (r__6 = r_imag(&x_ref(
1, j)), dabs(r__6))) + ((r__7 = du[1].r, dabs(r__7))
+ (r__8 = r_imag(&du[1]), dabs(r__8))) * ((r__9 = x[
i__4].r, dabs(r__9)) + (r__10 = r_imag(&x_ref(2, j)),
dabs(r__10)));
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = i__ - 1;
i__5 = x_subscr(i__ - 1, j);
i__6 = i__;
i__7 = x_subscr(i__, j);
i__8 = i__;
i__9 = x_subscr(i__ + 1, j);
rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&b_ref(i__, j)), dabs(r__2)) + ((r__3 = dl[
i__4].r, dabs(r__3)) + (r__4 = r_imag(&dl[i__ - 1]
), dabs(r__4))) * ((r__5 = x[i__5].r, dabs(r__5))
+ (r__6 = r_imag(&x_ref(i__ - 1, j)), dabs(r__6)))
+ ((r__7 = d__[i__6].r, dabs(r__7)) + (r__8 =
r_imag(&d__[i__]), dabs(r__8))) * ((r__9 = x[i__7]
.r, dabs(r__9)) + (r__10 = r_imag(&x_ref(i__, j)),
dabs(r__10))) + ((r__11 = du[i__8].r, dabs(r__11)
) + (r__12 = r_imag(&du[i__]), dabs(r__12))) * ((
r__13 = x[i__9].r, dabs(r__13)) + (r__14 = r_imag(
&x_ref(i__ + 1, j)), dabs(r__14)));
/* L30: */
}
i__2 = b_subscr(*n, j);
i__3 = *n - 1;
i__4 = x_subscr(*n - 1, j);
i__5 = *n;
i__6 = x_subscr(*n, j);
rwork[*n] = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
b_ref(*n, j)), dabs(r__2)) + ((r__3 = dl[i__3].r,
dabs(r__3)) + (r__4 = r_imag(&dl[*n - 1]), dabs(r__4))
) * ((r__5 = x[i__4].r, dabs(r__5)) + (r__6 = r_imag(&
x_ref(*n - 1, j)), dabs(r__6))) + ((r__7 = d__[i__5]
.r, dabs(r__7)) + (r__8 = r_imag(&d__[*n]), dabs(r__8)
)) * ((r__9 = x[i__6].r, dabs(r__9)) + (r__10 =
r_imag(&x_ref(*n, j)), dabs(r__10)));
}
} else {
if (*n == 1) {
i__2 = b_subscr(1, j);
i__3 = x_subscr(1, j);
rwork[1] = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
b_ref(1, j)), dabs(r__2)) + ((r__3 = d__[1].r, dabs(
r__3)) + (r__4 = r_imag(&d__[1]), dabs(r__4))) * ((
r__5 = x[i__3].r, dabs(r__5)) + (r__6 = r_imag(&x_ref(
1, j)), dabs(r__6)));
} else {
i__2 = b_subscr(1, j);
i__3 = x_subscr(1, j);
i__4 = x_subscr(2, j);
rwork[1] = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
b_ref(1, j)), dabs(r__2)) + ((r__3 = d__[1].r, dabs(
r__3)) + (r__4 = r_imag(&d__[1]), dabs(r__4))) * ((
r__5 = x[i__3].r, dabs(r__5)) + (r__6 = r_imag(&x_ref(
1, j)), dabs(r__6))) + ((r__7 = dl[1].r, dabs(r__7))
+ (r__8 = r_imag(&dl[1]), dabs(r__8))) * ((r__9 = x[
i__4].r, dabs(r__9)) + (r__10 = r_imag(&x_ref(2, j)),
dabs(r__10)));
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = i__ - 1;
i__5 = x_subscr(i__ - 1, j);
i__6 = i__;
i__7 = x_subscr(i__, j);
i__8 = i__;
i__9 = x_subscr(i__ + 1, j);
rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&b_ref(i__, j)), dabs(r__2)) + ((r__3 = du[
i__4].r, dabs(r__3)) + (r__4 = r_imag(&du[i__ - 1]
), dabs(r__4))) * ((r__5 = x[i__5].r, dabs(r__5))
+ (r__6 = r_imag(&x_ref(i__ - 1, j)), dabs(r__6)))
+ ((r__7 = d__[i__6].r, dabs(r__7)) + (r__8 =
r_imag(&d__[i__]), dabs(r__8))) * ((r__9 = x[i__7]
.r, dabs(r__9)) + (r__10 = r_imag(&x_ref(i__, j)),
dabs(r__10))) + ((r__11 = dl[i__8].r, dabs(r__11)
) + (r__12 = r_imag(&dl[i__]), dabs(r__12))) * ((
r__13 = x[i__9].r, dabs(r__13)) + (r__14 = r_imag(
&x_ref(i__ + 1, j)), dabs(r__14)));
/* L40: */
}
i__2 = b_subscr(*n, j);
i__3 = *n - 1;
i__4 = x_subscr(*n - 1, j);
i__5 = *n;
i__6 = x_subscr(*n, j);
rwork[*n] = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
b_ref(*n, j)), dabs(r__2)) + ((r__3 = du[i__3].r,
dabs(r__3)) + (r__4 = r_imag(&du[*n - 1]), dabs(r__4))
) * ((r__5 = x[i__4].r, dabs(r__5)) + (r__6 = r_imag(&
x_ref(*n - 1, j)), dabs(r__6))) + ((r__7 = d__[i__5]
.r, dabs(r__7)) + (r__8 = r_imag(&d__[*n]), dabs(r__8)
)) * ((r__9 = x[i__6].r, dabs(r__9)) + (r__10 =
r_imag(&x_ref(*n, j)), dabs(r__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.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
/* Computing MAX */
i__3 = i__;
r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2))) / rwork[i__];
s = dmax(r__3,r__4);
} else {
/* Computing MAX */
i__3 = i__;
r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + safe1) / (rwork[i__]
+ safe1);
s = dmax(r__3,r__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.f <= lstres && count <= 5) {
/* Update solution and try again. */
cgttrs_(trans, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[
1], &work[1], n, info);
caxpy_(n, &c_b26, &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 CLACON 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__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
i__];
} else {
i__3 = i__;
rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
i__] + safe1;
}
/* L60: */
}
kase = 0;
L70:
clacon_(n, &work[*n + 1], &work[1], &ferr[j], &kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(op(A)**H). */
cgttrs_(transt, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], &
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__;
q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = q__1.r, work[i__3].i = q__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__;
q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L90: */
}
cgttrs_(transn, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], &
ipiv[1], &work[1], n, info);
}
goto L70;
}
/* Normalize error. */
lstres = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = x_subscr(i__, j);
r__3 = lstres, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x_ref(i__, j)), dabs(r__2));
lstres = dmax(r__3,r__4);
/* L100: */
}
if (lstres != 0.f) {
ferr[j] /= lstres;
}
/* L110: */
}
return 0;
/* End of CGTRFS */
} /* cgtrfs_ */
/* Subroutine */ int cget04_(integer *n, integer *nrhs, complex *x, integer *
ldx, complex *xact, integer *ldxact, real *rcond, real *resid)
{
/* System generated locals */
integer x_dim1, x_offset, xact_dim1, xact_offset, i__1, i__2, i__3, i__4;
real r__1, r__2, r__3, r__4;
complex q__1, q__2;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static integer i__, j;
static real xnorm;
static integer ix;
extern integer icamax_(integer *, complex *, integer *);
static real diffnm;
extern doublereal slamch_(char *);
static real eps;
#define xact_subscr(a_1,a_2) (a_2)*xact_dim1 + a_1
#define xact_ref(a_1,a_2) xact[xact_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)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
CGET04 computes the difference between a computed solution and the
true solution to a system of linear equations.
RESID = ( norm(X-XACT) * RCOND ) / ( norm(XACT) * EPS ),
where RCOND is the reciprocal of the condition number and EPS is the
machine epsilon.
Arguments
=========
N (input) INTEGER
The number of rows of the matrices X and XACT. N >= 0.
NRHS (input) INTEGER
The number of columns of the matrices X and XACT. NRHS >= 0.
X (input) COMPLEX array, dimension (LDX,NRHS)
The computed solution vectors. Each vector is stored as a
column of the matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
XACT (input) COMPLEX array, dimension (LDX,NRHS)
The exact solution vectors. Each vector is stored as a
column of the matrix XACT.
LDXACT (input) INTEGER
The leading dimension of the array XACT. LDXACT >= max(1,N).
RCOND (input) REAL
The reciprocal of the condition number of the coefficient
matrix in the system of equations.
RESID (output) REAL
The maximum over the NRHS solution vectors of
( norm(X-XACT) * RCOND ) / ( norm(XACT) * EPS )
=====================================================================
Quick exit if N = 0 or NRHS = 0.
Parameter adjustments */
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
xact_dim1 = *ldxact;
xact_offset = 1 + xact_dim1 * 1;
xact -= xact_offset;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
*resid = 0.f;
return 0;
}
/* Exit with RESID = 1/EPS if RCOND is invalid. */
eps = slamch_("Epsilon");
if (*rcond < 0.f) {
*resid = 1.f / eps;
return 0;
}
/* Compute the maximum of
norm(X - XACT) / ( norm(XACT) * EPS )
over all the vectors X and XACT . */
*resid = 0.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ix = icamax_(n, &xact_ref(1, j), &c__1);
i__2 = xact_subscr(ix, j);
xnorm = (r__1 = xact[i__2].r, dabs(r__1)) + (r__2 = r_imag(&xact_ref(
ix, j)), dabs(r__2));
diffnm = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = x_subscr(i__, j);
i__4 = xact_subscr(i__, j);
q__2.r = x[i__3].r - xact[i__4].r, q__2.i = x[i__3].i - xact[i__4]
.i;
q__1.r = q__2.r, q__1.i = q__2.i;
/* Computing MAX */
r__3 = diffnm, r__4 = (r__1 = q__1.r, dabs(r__1)) + (r__2 =
r_imag(&q__1), dabs(r__2));
diffnm = dmax(r__3,r__4);
/* L10: */
}
if (xnorm <= 0.f) {
if (diffnm > 0.f) {
*resid = 1.f / eps;
}
} else {
/* Computing MAX */
r__1 = *resid, r__2 = diffnm / xnorm * *rcond;
*resid = dmax(r__1,r__2);
}
/* L20: */
}
if (*resid * eps < 1.f) {
*resid /= eps;
}
return 0;
/* End of CGET04 */
} /* cget04_ */
