int
f2c_ztbmv(char* uplo, char* trans, char* diag, integer* N, integer* K,
doublecomplex* A, integer* lda,
doublecomplex* X, integer* incX)
{
ztbmv_(uplo, trans, diag,
N, K, A, lda, X, incX);
return 0;
}
void
ztbmv(char uplo, char trans, char diag, int n, int k, doublecomplex *a, int lda, doublecomplex *x, int incx )
{
ztbmv_( &uplo, &trans, &diag, &n, &k, a, &lda, x, &incx );
}
/* Subroutine */
int ztbrfs_(char *uplo, char *trans, char *diag, integer *n, integer *kd, integer *nrhs, doublecomplex *ab, integer *ldab, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal * rwork, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
integer i__, j, k;
doublereal s, xk;
integer nz;
doublereal eps;
integer kase;
doublereal safe1, safe2;
extern logical lsame_(char *, char *);
integer isave[3];
logical upper;
extern /* Subroutine */
int ztbmv_(char *, char *, char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *), zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), ztbsv_(char *, char *, char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *), zaxpy_( integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), zlacn2_(integer *, doublecomplex *, doublecomplex *, doublereal *, integer *, integer *);
extern doublereal dlamch_(char *);
doublereal safmin;
extern /* Subroutine */
int xerbla_(char *, integer *);
logical notran;
char transn[1], transt[1];
logical nounit;
doublereal lstres;
/* -- LAPACK computational routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--rwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (! notran && ! lsame_(trans, "T") && ! lsame_(trans, "C"))
{
*info = -2;
}
else if (! nounit && ! lsame_(diag, "U"))
{
*info = -3;
}
else if (*n < 0)
{
*info = -4;
}
else if (*kd < 0)
{
*info = -5;
}
else if (*nrhs < 0)
{
*info = -6;
}
else if (*ldab < *kd + 1)
{
*info = -8;
}
else if (*ldb < max(1,*n))
{
*info = -10;
}
else if (*ldx < max(1,*n))
{
*info = -12;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("ZTBRFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0)
{
i__1 = *nrhs;
for (j = 1;
j <= 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 = *kd + 2;
eps = dlamch_("Epsilon");
safmin = dlamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1;
j <= i__1;
++j)
{
/* Compute residual R = B - op(A) * X, */
/* where op(A) = A, A**T, or A**H, depending on TRANS. */
zcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
ztbmv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[1], & c__1);
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zaxpy_(n, &z__1, &b[j * b_dim1 + 1], &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 = i__ + j * b_dim1;
rwork[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[ i__ + j * b_dim1]), abs(d__2));
/* 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 = k + j * x_dim1;
xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(& x[k + j * x_dim1]), abs(d__2));
/* Computing MAX */
i__3 = 1;
i__4 = k - *kd; // , expr subst
i__5 = k;
for (i__ = max(i__3,i__4);
i__ <= i__5;
++i__)
{
i__3 = *kd + 1 + i__ - k + k * ab_dim1;
rwork[i__] += ((d__1 = ab[i__3].r, abs(d__1)) + ( d__2 = d_imag(&ab[*kd + 1 + i__ - k + k * ab_dim1]), abs(d__2))) * xk;
/* L30: */
}
/* L40: */
}
}
else
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
i__5 = k + j * x_dim1;
xk = (d__1 = x[i__5].r, abs(d__1)) + (d__2 = d_imag(& x[k + j * x_dim1]), abs(d__2));
/* Computing MAX */
i__5 = 1;
i__3 = k - *kd; // , expr subst
i__4 = k - 1;
for (i__ = max(i__5,i__3);
i__ <= i__4;
++i__)
{
i__5 = *kd + 1 + i__ - k + k * ab_dim1;
rwork[i__] += ((d__1 = ab[i__5].r, abs(d__1)) + ( d__2 = d_imag(&ab[*kd + 1 + i__ - k + k * ab_dim1]), abs(d__2))) * xk;
/* L50: */
}
rwork[k] += xk;
/* L60: */
}
}
}
else
{
if (nounit)
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
i__4 = k + j * x_dim1;
xk = (d__1 = x[i__4].r, abs(d__1)) + (d__2 = d_imag(& x[k + j * x_dim1]), abs(d__2));
/* Computing MIN */
i__5 = *n;
i__3 = k + *kd; // , expr subst
i__4 = min(i__5,i__3);
for (i__ = k;
i__ <= i__4;
++i__)
{
i__5 = i__ + 1 - k + k * ab_dim1;
rwork[i__] += ((d__1 = ab[i__5].r, abs(d__1)) + ( d__2 = d_imag(&ab[i__ + 1 - k + k * ab_dim1]), abs(d__2))) * xk;
/* L70: */
}
/* L80: */
}
}
else
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
i__4 = k + j * x_dim1;
xk = (d__1 = x[i__4].r, abs(d__1)) + (d__2 = d_imag(& x[k + j * x_dim1]), abs(d__2));
/* Computing MIN */
i__5 = *n;
i__3 = k + *kd; // , expr subst
i__4 = min(i__5,i__3);
for (i__ = k + 1;
i__ <= i__4;
++i__)
{
i__5 = i__ + 1 - k + k * ab_dim1;
rwork[i__] += ((d__1 = ab[i__5].r, abs(d__1)) + ( d__2 = d_imag(&ab[i__ + 1 - k + k * ab_dim1]), abs(d__2))) * xk;
/* L90: */
}
rwork[k] += xk;
/* L100: */
}
}
}
}
else
{
/* Compute abs(A**H)*abs(X) + abs(B). */
if (upper)
{
if (nounit)
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
s = 0.;
/* Computing MAX */
i__4 = 1;
i__5 = k - *kd; // , expr subst
i__3 = k;
for (i__ = max(i__4,i__5);
i__ <= i__3;
++i__)
{
i__4 = *kd + 1 + i__ - k + k * ab_dim1;
i__5 = i__ + j * x_dim1;
s += ((d__1 = ab[i__4].r, abs(d__1)) + (d__2 = d_imag(&ab[*kd + 1 + i__ - k + k * ab_dim1]), abs(d__2))) * ((d__3 = x[i__5] .r, abs(d__3)) + (d__4 = d_imag(&x[i__ + j * x_dim1]), abs(d__4)));
/* L110: */
}
rwork[k] += s;
/* L120: */
}
}
else
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
i__3 = k + j * x_dim1;
s = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[ k + j * x_dim1]), abs(d__2));
/* Computing MAX */
i__3 = 1;
i__4 = k - *kd; // , expr subst
i__5 = k - 1;
for (i__ = max(i__3,i__4);
i__ <= i__5;
++i__)
{
i__3 = *kd + 1 + i__ - k + k * ab_dim1;
i__4 = i__ + j * x_dim1;
s += ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 = d_imag(&ab[*kd + 1 + i__ - k + k * ab_dim1]), abs(d__2))) * ((d__3 = x[i__4] .r, abs(d__3)) + (d__4 = d_imag(&x[i__ + j * x_dim1]), abs(d__4)));
/* L130: */
}
rwork[k] += s;
/* L140: */
}
}
}
else
{
if (nounit)
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
s = 0.;
/* Computing MIN */
i__3 = *n;
i__4 = k + *kd; // , expr subst
i__5 = min(i__3,i__4);
for (i__ = k;
i__ <= i__5;
++i__)
{
i__3 = i__ + 1 - k + k * ab_dim1;
i__4 = i__ + j * x_dim1;
s += ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 = d_imag(&ab[i__ + 1 - k + k * ab_dim1]), abs(d__2))) * ((d__3 = x[i__4].r, abs( d__3)) + (d__4 = d_imag(&x[i__ + j * x_dim1]), abs(d__4)));
/* L150: */
}
rwork[k] += s;
/* L160: */
}
}
else
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
i__5 = k + j * x_dim1;
s = (d__1 = x[i__5].r, abs(d__1)) + (d__2 = d_imag(&x[ k + j * x_dim1]), abs(d__2));
/* Computing MIN */
i__3 = *n;
i__4 = k + *kd; // , expr subst
i__5 = min(i__3,i__4);
for (i__ = k + 1;
i__ <= i__5;
++i__)
{
i__3 = i__ + 1 - k + k * ab_dim1;
i__4 = i__ + j * x_dim1;
s += ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 = d_imag(&ab[i__ + 1 - k + k * ab_dim1]), abs(d__2))) * ((d__3 = x[i__4].r, abs( d__3)) + (d__4 = d_imag(&x[i__ + j * x_dim1]), abs(d__4)));
/* L170: */
}
rwork[k] += s;
/* L180: */
}
}
}
}
s = 0.;
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
if (rwork[i__] > safe2)
{
/* Computing MAX */
i__5 = i__;
d__3 = s;
d__4 = ((d__1 = work[i__5].r, abs(d__1)) + (d__2 = d_imag(&work[i__]), abs(d__2))) / rwork[i__]; // , expr subst
s = max(d__3,d__4);
}
else
{
/* Computing MAX */
i__5 = i__;
d__3 = s;
d__4 = ((d__1 = work[i__5].r, abs(d__1)) + (d__2 = d_imag(&work[i__]), abs(d__2)) + safe1) / (rwork[i__] + safe1); // , expr subst
s = max(d__3,d__4);
}
/* 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 ZLACN2 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__5 = i__;
rwork[i__] = (d__1 = work[i__5].r, abs(d__1)) + (d__2 = d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__] ;
}
else
{
i__5 = i__;
rwork[i__] = (d__1 = work[i__5].r, abs(d__1)) + (d__2 = d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__] + safe1;
}
/* L200: */
}
kase = 0;
L210:
zlacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
if (kase != 0)
{
if (kase == 1)
{
/* Multiply by diag(W)*inv(op(A)**H). */
ztbsv_(uplo, transt, diag, n, kd, &ab[ab_offset], ldab, &work[ 1], &c__1);
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
i__5 = i__;
i__3 = i__;
i__4 = i__;
z__1.r = rwork[i__3] * work[i__4].r;
z__1.i = rwork[i__3] * work[i__4].i; // , expr subst
work[i__5].r = z__1.r;
work[i__5].i = z__1.i; // , expr subst
/* L220: */
}
}
else
{
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
i__5 = i__;
i__3 = i__;
i__4 = i__;
z__1.r = rwork[i__3] * work[i__4].r;
z__1.i = rwork[i__3] * work[i__4].i; // , expr subst
work[i__5].r = z__1.r;
work[i__5].i = z__1.i; // , expr subst
/* L230: */
}
ztbsv_(uplo, transn, diag, n, kd, &ab[ab_offset], ldab, &work[ 1], &c__1);
}
goto L210;
}
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
/* Computing MAX */
i__5 = i__ + j * x_dim1;
d__3 = lstres;
d__4 = (d__1 = x[i__5].r, abs(d__1)) + (d__2 = d_imag(&x[i__ + j * x_dim1]), abs(d__2)); // , expr subst
lstres = max(d__3,d__4);
/* L240: */
}
if (lstres != 0.)
{
ferr[j] /= lstres;
}
/* L250: */
}
return 0;
/* End of ZTBRFS */
}
/* Subroutine */ int zlarhs_(char *path, char *xtype, char *uplo, char *trans,
integer *m, integer *n, integer *kl, integer *ku, integer *nrhs,
doublecomplex *a, integer *lda, doublecomplex *x, integer *ldx,
doublecomplex *b, integer *ldb, integer *iseed, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
/* Local variables */
integer j;
char c1[1], c2[2];
integer mb, nx;
logical gen, tri, qrs, sym, band;
char diag[1];
logical tran;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zhemm_(char *, char *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zgbmv_(char *, integer *, integer *,
integer *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zhbmv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *),
zsbmv_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *), ztbmv_(char
*, char *, char *, integer *, integer *, doublecomplex *, integer
*, doublecomplex *, integer *), zhpmv_(
char *, integer *, doublecomplex *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), ztrmm_(char *, char *, char *, char *,
integer *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *),
zspmv_(char *, integer *, doublecomplex *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zsymm_(char *, char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *), ztpmv_(char *, char *, char *, integer *, doublecomplex *
, doublecomplex *, integer *), xerbla_(
char *, integer *);
extern logical lsamen_(integer *, char *, char *);
logical notran;
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlarnv_(integer *, integer *, integer *, doublecomplex *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLARHS chooses a set of NRHS random solution vectors and sets */
/* up the right hand sides for the linear system */
/* op( A ) * X = B, */
/* where op( A ) may be A, A**T (transpose of A), or A**H (conjugate */
/* transpose of A). */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The type of the complex matrix A. PATH may be given in any */
/* combination of upper and lower case. Valid paths include */
/* xGE: General m x n matrix */
/* xGB: General banded matrix */
/* xPO: Hermitian positive definite, 2-D storage */
/* xPP: Hermitian positive definite packed */
/* xPB: Hermitian positive definite banded */
/* xHE: Hermitian indefinite, 2-D storage */
/* xHP: Hermitian indefinite packed */
/* xHB: Hermitian indefinite banded */
/* xSY: Symmetric indefinite, 2-D storage */
/* xSP: Symmetric indefinite packed */
/* xSB: Symmetric indefinite banded */
/* xTR: Triangular */
/* xTP: Triangular packed */
/* xTB: Triangular banded */
/* xQR: General m x n matrix */
/* xLQ: General m x n matrix */
/* xQL: General m x n matrix */
/* xRQ: General m x n matrix */
/* where the leading character indicates the precision. */
/* XTYPE (input) CHARACTER*1 */
/* Specifies how the exact solution X will be determined: */
/* = 'N': New solution; generate a random X. */
/* = 'C': Computed; use value of X on entry. */
/* UPLO (input) CHARACTER*1 */
/* Used only if A is symmetric or triangular; specifies whether */
/* the upper or lower triangular part of the matrix A is stored. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* TRANS (input) CHARACTER*1 */
/* Used only if A is nonsymmetric; specifies the operation */
/* applied to the matrix A. */
/* = 'N': B := A * X */
/* = 'T': B := A**T * X */
/* = 'C': B := A**H * X */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* KL (input) INTEGER */
/* Used only if A is a band matrix; specifies the number of */
/* subdiagonals of A if A is a general band matrix or if A is */
/* symmetric or triangular and UPLO = 'L'; specifies the number */
/* of superdiagonals of A if A is symmetric or triangular and */
/* UPLO = 'U'. 0 <= KL <= M-1. */
/* KU (input) INTEGER */
/* Used only if A is a general band matrix or if A is */
/* triangular. */
/* If PATH = xGB, specifies the number of superdiagonals of A, */
/* and 0 <= KU <= N-1. */
/* If PATH = xTR, xTP, or xTB, specifies whether or not the */
/* matrix has unit diagonal: */
/* = 1: matrix has non-unit diagonal (default) */
/* = 2: matrix has unit diagonal */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors in the system A*X = B. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The test matrix whose type is given by PATH. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. */
/* If PATH = xGB, LDA >= KL+KU+1. */
/* If PATH = xPB, xSB, xHB, or xTB, LDA >= KL+1. */
/* Otherwise, LDA >= max(1,M). */
/* X (input or output) COMPLEX*16 array, dimension (LDX,NRHS) */
/* On entry, if XTYPE = 'C' (for 'Computed'), then X contains */
/* the exact solution to the system of linear equations. */
/* On exit, if XTYPE = 'N' (for 'New'), then X is initialized */
/* with random values. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. If TRANS = 'N', */
/* LDX >= max(1,N); if TRANS = 'T', LDX >= max(1,M). */
/* B (output) COMPLEX*16 array, dimension (LDB,NRHS) */
/* The right hand side vector(s) for the system of equations, */
/* computed from B = op(A) * X, where op(A) is determined by */
/* TRANS. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. If TRANS = 'N', */
/* LDB >= max(1,M); if TRANS = 'T', LDB >= max(1,N). */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* The seed vector for the random number generator (used in */
/* ZLATMS). Modified on exit. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--iseed;
/* Function Body */
*info = 0;
*(unsigned char *)c1 = *(unsigned char *)path;
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
tran = lsame_(trans, "T") || lsame_(trans, "C");
notran = ! tran;
gen = lsame_(path + 1, "G");
qrs = lsame_(path + 1, "Q") || lsame_(path + 2,
"Q");
sym = lsame_(path + 1, "P") || lsame_(path + 1,
"S") || lsame_(path + 1, "H");
tri = lsame_(path + 1, "T");
band = lsame_(path + 2, "B");
if (! lsame_(c1, "Zomplex precision")) {
*info = -1;
} else if (! (lsame_(xtype, "N") || lsame_(xtype,
"C"))) {
*info = -2;
} else if ((sym || tri) && ! (lsame_(uplo, "U") ||
lsame_(uplo, "L"))) {
*info = -3;
} else if ((gen || qrs) && ! (tran || lsame_(trans, "N"))) {
*info = -4;
} else if (*m < 0) {
*info = -5;
} else if (*n < 0) {
*info = -6;
} else if (band && *kl < 0) {
*info = -7;
} else if (band && *ku < 0) {
*info = -8;
} else if (*nrhs < 0) {
*info = -9;
} else if (! band && *lda < max(1,*m) || band && (sym || tri) && *lda < *
kl + 1 || band && gen && *lda < *kl + *ku + 1) {
*info = -11;
} else if (notran && *ldx < max(1,*n) || tran && *ldx < max(1,*m)) {
*info = -13;
} else if (notran && *ldb < max(1,*m) || tran && *ldb < max(1,*n)) {
*info = -15;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZLARHS", &i__1);
return 0;
}
/* Initialize X to NRHS random vectors unless XTYPE = 'C'. */
if (tran) {
nx = *m;
mb = *n;
} else {
nx = *n;
mb = *m;
}
if (! lsame_(xtype, "C")) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
zlarnv_(&c__2, &iseed[1], n, &x[j * x_dim1 + 1]);
/* L10: */
}
}
/* Multiply X by op( A ) using an appropriate */
/* matrix multiply routine. */
if (lsamen_(&c__2, c2, "GE") || lsamen_(&c__2, c2,
"QR") || lsamen_(&c__2, c2, "LQ") || lsamen_(&c__2, c2, "QL") ||
lsamen_(&c__2, c2, "RQ")) {
/* General matrix */
zgemm_(trans, "N", &mb, nrhs, &nx, &c_b1, &a[a_offset], lda, &x[
x_offset], ldx, &c_b2, &b[b_offset], ldb);
} else if (lsamen_(&c__2, c2, "PO") || lsamen_(&
c__2, c2, "HE")) {
/* Hermitian matrix, 2-D storage */
zhemm_("Left", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset],
ldx, &c_b2, &b[b_offset], ldb);
} else if (lsamen_(&c__2, c2, "SY")) {
/* Symmetric matrix, 2-D storage */
zsymm_("Left", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset],
ldx, &c_b2, &b[b_offset], ldb);
} else if (lsamen_(&c__2, c2, "GB")) {
/* General matrix, band storage */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
zgbmv_(trans, m, n, kl, ku, &c_b1, &a[a_offset], lda, &x[j *
x_dim1 + 1], &c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
/* L20: */
}
} else if (lsamen_(&c__2, c2, "PB") || lsamen_(&
c__2, c2, "HB")) {
/* Hermitian matrix, band storage */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
zhbmv_(uplo, n, kl, &c_b1, &a[a_offset], lda, &x[j * x_dim1 + 1],
&c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
/* L30: */
}
} else if (lsamen_(&c__2, c2, "SB")) {
/* Symmetric matrix, band storage */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
zsbmv_(uplo, n, kl, &c_b1, &a[a_offset], lda, &x[j * x_dim1 + 1],
&c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
/* L40: */
}
} else if (lsamen_(&c__2, c2, "PP") || lsamen_(&
c__2, c2, "HP")) {
/* Hermitian matrix, packed storage */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
zhpmv_(uplo, n, &c_b1, &a[a_offset], &x[j * x_dim1 + 1], &c__1, &
c_b2, &b[j * b_dim1 + 1], &c__1);
/* L50: */
}
} else if (lsamen_(&c__2, c2, "SP")) {
/* Symmetric matrix, packed storage */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
zspmv_(uplo, n, &c_b1, &a[a_offset], &x[j * x_dim1 + 1], &c__1, &
c_b2, &b[j * b_dim1 + 1], &c__1);
/* L60: */
}
} else if (lsamen_(&c__2, c2, "TR")) {
/* Triangular matrix. Note that for triangular matrices, */
/* KU = 1 => non-unit triangular */
/* KU = 2 => unit triangular */
zlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
if (*ku == 2) {
*(unsigned char *)diag = 'U';
} else {
*(unsigned char *)diag = 'N';
}
ztrmm_("Left", uplo, trans, diag, n, nrhs, &c_b1, &a[a_offset], lda, &
b[b_offset], ldb);
} else if (lsamen_(&c__2, c2, "TP")) {
/* Triangular matrix, packed storage */
zlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
if (*ku == 2) {
*(unsigned char *)diag = 'U';
} else {
*(unsigned char *)diag = 'N';
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ztpmv_(uplo, trans, diag, n, &a[a_offset], &b[j * b_dim1 + 1], &
c__1);
/* L70: */
}
} else if (lsamen_(&c__2, c2, "TB")) {
/* Triangular matrix, banded storage */
zlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
if (*ku == 2) {
*(unsigned char *)diag = 'U';
} else {
*(unsigned char *)diag = 'N';
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ztbmv_(uplo, trans, diag, n, kl, &a[a_offset], lda, &b[j * b_dim1
+ 1], &c__1);
/* L80: */
}
} else {
/* If none of the above, set INFO = -1 and return */
*info = -1;
i__1 = -(*info);
xerbla_("ZLARHS", &i__1);
}
return 0;
/* End of ZLARHS */
} /* zlarhs_ */
/* Subroutine */ int ztbrfs_(char *uplo, char *trans, char *diag, integer *n,
integer *kd, integer *nrhs, doublecomplex *ab, integer *ldab,
doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *
rwork, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZTBRFS provides error bounds and backward error estimates for the
solution to a system of linear equations with a triangular band
coefficient matrix.
The solution matrix X must be computed by ZTBTRS or some other
means before entering this routine. ZTBRFS does not do iterative
refinement because doing so cannot improve the backward error.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': A is upper triangular;
= 'L': A is lower triangular.
TRANS (input) CHARACTER*1
Specifies the form of the system of equations:
= 'N': A * X = B (No transpose)
= 'T': A**T * X = B (Transpose)
= 'C': A**H * X = B (Conjugate transpose)
DIAG (input) CHARACTER*1
= 'N': A is non-unit triangular;
= 'U': A is unit triangular.
N (input) INTEGER
The order of the matrix A. N >= 0.
KD (input) INTEGER
The number of superdiagonals or subdiagonals of the
triangular band matrix A. KD >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrices B and X. NRHS >= 0.
AB (input) COMPLEX*16 array, dimension (LDAB,N)
The upper or lower triangular band matrix A, stored in the
first kd+1 rows of the array. The j-th column of A is stored
in the j-th column of the array AB as follows:
if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
If DIAG = 'U', the diagonal elements of A are not referenced
and are assumed to be 1.
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD+1.
B (input) COMPLEX*16 array, dimension (LDB,NRHS)
The right hand side matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (input) COMPLEX*16 array, dimension (LDX,NRHS)
The solution matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
FERR (output) DOUBLE PRECISION array, dimension (NRHS)
The estimated forward error bound for each solution vector
X(j) (the j-th column of the solution matrix X).
If XTRUE is the true solution corresponding to X(j), FERR(j)
is an estimated upper bound for the magnitude of the largest
element in (X(j) - XTRUE) divided by the magnitude of the
largest element in X(j). The estimate is as reliable as
the estimate for RCOND, and is almost always a slight
overestimate of the true error.
BERR (output) DOUBLE PRECISION array, dimension (NRHS)
The componentwise relative backward error of each solution
vector X(j) (i.e., the smallest relative change in
any element of A or B that makes X(j) an exact solution).
WORK (workspace) COMPLEX*16 array, dimension (2*N)
RWORK (workspace) DOUBLE PRECISION array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, i__1,
i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static integer kase;
static doublereal safe1, safe2;
static integer i, j, k;
static doublereal s;
extern logical lsame_(char *, char *);
static logical upper;
extern /* Subroutine */ int ztbmv_(char *, char *, char *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *), zcopy_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *), ztbsv_(char *, char *,
char *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zaxpy_(
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *);
static doublereal xk;
static integer nz;
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *), zlacon_(
integer *, doublecomplex *, doublecomplex *, doublereal *,
integer *);
static logical notran;
static char transn[1], transt[1];
static logical nounit;
static doublereal lstres, eps;
#define FERR(I) ferr[(I)-1]
#define BERR(I) berr[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define X(I,J) x[(I)-1 + ((J)-1)* ( *ldx)]
*info = 0;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && ! lsame_(trans,
"C")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*kd < 0) {
*info = -5;
} else if (*nrhs < 0) {
*info = -6;
} else if (*ldab < *kd + 1) {
*info = -8;
} else if (*ldb < max(1,*n)) {
*info = -10;
} else if (*ldx < max(1,*n)) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZTBRFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= *nrhs; ++j) {
FERR(j) = 0.;
BERR(j) = 0.;
/* L10: */
}
return 0;
}
if (notran) {
*(unsigned char *)transn = 'N';
*(unsigned char *)transt = 'C';
} else {
*(unsigned char *)transn = 'C';
*(unsigned char *)transt = 'N';
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *kd + 2;
eps = dlamch_("Epsilon");
safmin = dlamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= *nrhs; ++j) {
/* Compute residual R = B - op(A) * X,
where op(A) = A, A**T, or A**H, depending on TRANS. */
zcopy_(n, &X(1,j), &c__1, &WORK(1), &c__1);
ztbmv_(uplo, trans, diag, n, kd, &AB(1,1), ldab, &WORK(1), &
c__1);
z__1.r = -1., z__1.i = 0.;
zaxpy_(n, &z__1, &B(1,j), &c__1, &WORK(1), &c__1);
/* Compute componentwise relative backward error from formula
max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
where abs(Z) is the componentwise absolute value of the matr
ix
or vector Z. If the i-th component of the denominator is le
ss
than SAFE2, then SAFE1 is added to the i-th components of th
e
numerator and denominator before dividing. */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
i__3 = i + j * b_dim1;
RWORK(i) = (d__1 = B(i,j).r, abs(d__1)) + (d__2 = d_imag(&B(i,j)), abs(d__2));
/* L20: */
}
if (notran) {
/* Compute abs(A)*abs(X) + abs(B). */
if (upper) {
if (nounit) {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
i__3 = k + j * x_dim1;
xk = (d__1 = X(k,j).r, abs(d__1)) + (d__2 = d_imag(&
X(k,j)), abs(d__2));
/* Computing MAX */
i__3 = 1, i__4 = k - *kd;
i__5 = k;
for (i = max(1,k-*kd); i <= k; ++i) {
i__3 = *kd + 1 + i - k + k * ab_dim1;
RWORK(i) += ((d__1 = AB(*kd+1+i-k,k).r, abs(d__1)) + (
d__2 = d_imag(&AB(*kd+1+i-k,k)), abs(d__2))) * xk;
/* L30: */
}
/* L40: */
}
} else {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
i__5 = k + j * x_dim1;
xk = (d__1 = X(k,j).r, abs(d__1)) + (d__2 = d_imag(&
X(k,j)), abs(d__2));
/* Computing MAX */
i__5 = 1, i__3 = k - *kd;
i__4 = k - 1;
for (i = max(1,k-*kd); i <= k-1; ++i) {
i__5 = *kd + 1 + i - k + k * ab_dim1;
RWORK(i) += ((d__1 = AB(*kd+1+i-k,k).r, abs(d__1)) + (
d__2 = d_imag(&AB(*kd+1+i-k,k)), abs(d__2))) * xk;
/* L50: */
}
RWORK(k) += xk;
/* L60: */
}
}
} else {
if (nounit) {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
i__4 = k + j * x_dim1;
xk = (d__1 = X(k,j).r, abs(d__1)) + (d__2 = d_imag(&
X(k,j)), abs(d__2));
/* Computing MIN */
i__5 = *n, i__3 = k + *kd;
i__4 = min(i__5,i__3);
for (i = k; i <= min(*n,k+*kd); ++i) {
i__5 = i + 1 - k + k * ab_dim1;
RWORK(i) += ((d__1 = AB(i+1-k,k).r, abs(d__1)) + (
d__2 = d_imag(&AB(i+1-k,k)
), abs(d__2))) * xk;
/* L70: */
}
/* L80: */
}
} else {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
i__4 = k + j * x_dim1;
xk = (d__1 = X(k,j).r, abs(d__1)) + (d__2 = d_imag(&
X(k,j)), abs(d__2));
/* Computing MIN */
i__5 = *n, i__3 = k + *kd;
i__4 = min(i__5,i__3);
for (i = k + 1; i <= min(*n,k+*kd); ++i) {
i__5 = i + 1 - k + k * ab_dim1;
RWORK(i) += ((d__1 = AB(i+1-k,k).r, abs(d__1)) + (
d__2 = d_imag(&AB(i+1-k,k)
), abs(d__2))) * xk;
/* L90: */
}
RWORK(k) += xk;
/* L100: */
}
}
}
} else {
/* Compute abs(A**H)*abs(X) + abs(B). */
if (upper) {
if (nounit) {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
s = 0.;
/* Computing MAX */
i__4 = 1, i__5 = k - *kd;
i__3 = k;
for (i = max(1,k-*kd); i <= k; ++i) {
i__4 = *kd + 1 + i - k + k * ab_dim1;
i__5 = i + j * x_dim1;
s += ((d__1 = AB(*kd+1+i-k,k).r, abs(d__1)) + (d__2 =
d_imag(&AB(*kd+1+i-k,k))
, abs(d__2))) * ((d__3 = X(i,j).r, abs(
d__3)) + (d__4 = d_imag(&X(i,j)
), abs(d__4)));
/* L110: */
}
RWORK(k) += s;
/* L120: */
}
} else {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
i__3 = k + j * x_dim1;
s = (d__1 = X(k,j).r, abs(d__1)) + (d__2 = d_imag(&X(k,j)), abs(d__2));
/* Computing MAX */
i__3 = 1, i__4 = k - *kd;
i__5 = k - 1;
for (i = max(1,k-*kd); i <= k-1; ++i) {
i__3 = *kd + 1 + i - k + k * ab_dim1;
i__4 = i + j * x_dim1;
s += ((d__1 = AB(*kd+1+i-k,k).r, abs(d__1)) + (d__2 =
d_imag(&AB(*kd+1+i-k,k))
, abs(d__2))) * ((d__3 = X(i,j).r, abs(
d__3)) + (d__4 = d_imag(&X(i,j)
), abs(d__4)));
/* L130: */
}
RWORK(k) += s;
/* L140: */
}
}
} else {
if (nounit) {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
s = 0.;
/* Computing MIN */
i__3 = *n, i__4 = k + *kd;
i__5 = min(i__3,i__4);
for (i = k; i <= min(*n,k+*kd); ++i) {
i__3 = i + 1 - k + k * ab_dim1;
i__4 = i + j * x_dim1;
s += ((d__1 = AB(i+1-k,k).r, abs(d__1)) + (d__2 =
d_imag(&AB(i+1-k,k)), abs(
d__2))) * ((d__3 = X(i,j).r, abs(d__3))
+ (d__4 = d_imag(&X(i,j)), abs(
d__4)));
/* L150: */
}
RWORK(k) += s;
/* L160: */
}
} else {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
i__5 = k + j * x_dim1;
s = (d__1 = X(k,j).r, abs(d__1)) + (d__2 = d_imag(&X(k,j)), abs(d__2));
/* Computing MIN */
i__3 = *n, i__4 = k + *kd;
i__5 = min(i__3,i__4);
for (i = k + 1; i <= min(*n,k+*kd); ++i) {
i__3 = i + 1 - k + k * ab_dim1;
i__4 = i + j * x_dim1;
s += ((d__1 = AB(i+1-k,k).r, abs(d__1)) + (d__2 =
d_imag(&AB(i+1-k,k)), abs(
d__2))) * ((d__3 = X(i,j).r, abs(d__3))
+ (d__4 = d_imag(&X(i,j)), abs(
d__4)));
/* L170: */
}
RWORK(k) += s;
/* L180: */
}
}
}
}
s = 0.;
i__2 = *n;
for (i = 1; i <= *n; ++i) {
if (RWORK(i) > safe2) {
/* Computing MAX */
i__5 = i;
d__3 = s, d__4 = ((d__1 = WORK(i).r, abs(d__1)) + (d__2 =
d_imag(&WORK(i)), abs(d__2))) / RWORK(i);
s = max(d__3,d__4);
} else {
/* Computing MAX */
i__5 = i;
d__3 = s, d__4 = ((d__1 = WORK(i).r, abs(d__1)) + (d__2 =
d_imag(&WORK(i)), abs(d__2)) + safe1) / (RWORK(i) +
safe1);
s = max(d__3,d__4);
}
/* L190: */
}
BERR(j) = s;
/* Bound error from formula
norm(X - XTRUE) / norm(X) .le. FERR =
norm( abs(inv(op(A)))*
( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X
)
where
norm(Z) is the magnitude of the largest component of Z
inv(op(A)) is the inverse of op(A)
abs(Z) is the componentwise absolute value of the matrix o
r
vector Z
NZ is the maximum number of nonzeros in any row of A, plus
1
EPS is machine epsilon
The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B
))
is incremented by SAFE1 if the i-th component of
abs(op(A))*abs(X) + abs(B) is less than SAFE2.
Use ZLACON to estimate the infinity-norm of the matrix
inv(op(A)) * diag(W),
where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
if (RWORK(i) > safe2) {
i__5 = i;
RWORK(i) = (d__1 = WORK(i).r, abs(d__1)) + (d__2 = d_imag(&
WORK(i)), abs(d__2)) + nz * eps * RWORK(i);
} else {
i__5 = i;
RWORK(i) = (d__1 = WORK(i).r, abs(d__1)) + (d__2 = d_imag(&
WORK(i)), abs(d__2)) + nz * eps * RWORK(i) + safe1;
}
/* L200: */
}
kase = 0;
L210:
zlacon_(n, &WORK(*n + 1), &WORK(1), &FERR(j), &kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(op(A)**H). */
ztbsv_(uplo, transt, diag, n, kd, &AB(1,1), ldab, &WORK(
1), &c__1);
i__2 = *n;
for (i = 1; i <= *n; ++i) {
i__5 = i;
i__3 = i;
i__4 = i;
z__1.r = RWORK(i) * WORK(i).r, z__1.i = RWORK(i)
* WORK(i).i;
WORK(i).r = z__1.r, WORK(i).i = z__1.i;
/* L220: */
}
} else {
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
i__5 = i;
i__3 = i;
i__4 = i;
z__1.r = RWORK(i) * WORK(i).r, z__1.i = RWORK(i)
* WORK(i).i;
WORK(i).r = z__1.r, WORK(i).i = z__1.i;
/* L230: */
}
ztbsv_(uplo, transn, diag, n, kd, &AB(1,1), ldab, &WORK(
1), &c__1);
}
goto L210;
}
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i = 1; i <= *n; ++i) {
/* Computing MAX */
i__5 = i + j * x_dim1;
d__3 = lstres, d__4 = (d__1 = X(i,j).r, abs(d__1)) + (d__2 =
d_imag(&X(i,j)), abs(d__2));
lstres = max(d__3,d__4);
/* L240: */
}
if (lstres != 0.) {
FERR(j) /= lstres;
}
/* L250: */
}
return 0;
/* End of ZTBRFS */
} /* ztbrfs_ */
