int
f2c_cgbmv(char *trans, integer *M, integer *N, integer *KL, integer *KU,
complex *alpha,
complex *A, integer *lda,
complex *X, integer *incX,
complex *beta,
complex *Y, integer *incY)
{
cgbmv_(trans, M, N, KL, KU,
alpha, A, lda, X, incX, beta, Y, incY);
return 0;
}
/* Subroutine */ int cgbrfs_(char *trans, integer *n, integer *kl, integer *
ku, integer *nrhs, complex *ab, integer *ldab, complex *afb, integer *
ldafb, integer *ipiv, complex *b, integer *ldb, complex *x, integer *
ldx, real *ferr, real *berr, complex *work, real *rwork, integer *
info)
{
/* System generated locals */
integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
real r__1, r__2, r__3, r__4;
complex q__1;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
integer i__, j, k;
real s;
integer kk;
real xk;
integer nz;
real eps;
integer kase;
real safe1, safe2;
extern /* Subroutine */ int cgbmv_(char *, integer *, integer *, integer *
, integer *, complex *, complex *, integer *, complex *, integer *
, complex *, complex *, integer *);
extern logical lsame_(char *, char *);
integer isave[3];
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
integer count;
extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
*, integer *, integer *);
extern doublereal slamch_(char *);
real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *), cgbtrs_(
char *, integer *, integer *, integer *, integer *, complex *,
integer *, integer *, complex *, integer *, integer *);
logical notran;
char transn[1], transt[1];
real lstres;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGBRFS improves the computed solution to a system of linear */
/* equations when the coefficient matrix is banded, and provides */
/* error bounds and backward error estimates for the solution. */
/* Arguments */
/* ========= */
/* TRANS (input) CHARACTER*1 */
/* Specifies the form of the system of equations: */
/* = 'N': A * X = B (No transpose) */
/* = 'T': A**T * X = B (Transpose) */
/* = 'C': A**H * X = B (Conjugate transpose) */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* KL (input) INTEGER */
/* The number of subdiagonals within the band of A. KL >= 0. */
/* KU (input) INTEGER */
/* The number of superdiagonals within the band of A. KU >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* AB (input) COMPLEX array, dimension (LDAB,N) */
/* The original band matrix A, stored in rows 1 to KL+KU+1. */
/* The j-th column of A is stored in the j-th column of the */
/* array AB as follows: */
/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
/* AFB (input) COMPLEX array, dimension (LDAFB,N) */
/* Details of the LU factorization of the band matrix A, as */
/* computed by CGBTRF. U is stored as an upper triangular band */
/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */
/* the multipliers used during the factorization are stored in */
/* rows KL+KU+2 to 2*KL+KU+1. */
/* LDAFB (input) INTEGER */
/* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices from CGBTRF; for 1<=i<=N, row i of the */
/* matrix was interchanged with row IPIV(i). */
/* 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 CGBTRS. */
/* 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. */
/* ===================================================================== */
/* .. 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;
afb_dim1 = *ldafb;
afb_offset = 1 + afb_dim1;
afb -= afb_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--rwork;
/* Function Body */
*info = 0;
notran = lsame_(trans, "N");
if (! notran && ! lsame_(trans, "T") && ! lsame_(
trans, "C")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kl < 0) {
*info = -3;
} else if (*ku < 0) {
*info = -4;
} else if (*nrhs < 0) {
*info = -5;
} else if (*ldab < *kl + *ku + 1) {
*info = -7;
} else if (*ldafb < (*kl << 1) + *ku + 1) {
*info = -9;
} else if (*ldb < max(1,*n)) {
*info = -12;
} else if (*ldx < max(1,*n)) {
*info = -14;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGBRFS", &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 */
/* Computing MIN */
i__1 = *kl + *ku + 2, i__2 = *n + 1;
nz = min(i__1,i__2);
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[j * b_dim1 + 1], &c__1, &work[1], &c__1);
q__1.r = -1.f, q__1.i = -0.f;
cgbmv_(trans, n, n, kl, ku, &q__1, &ab[ab_offset], ldab, &x[j *
x_dim1 + 1], &c__1, &c_b1, &work[1], &c__1);
/* Compute componentwise relative backward error from formula */
/* max(i) ( abs(R(i)) / ( abs(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__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[
i__ + j * b_dim1]), dabs(r__2));
/* L30: */
}
/* Compute abs(op(A))*abs(X) + abs(B). */
if (notran) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
kk = *ku + 1 - k;
i__3 = k + j * x_dim1;
xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[k + j
* x_dim1]), dabs(r__2));
/* Computing MAX */
i__3 = 1, i__4 = k - *ku;
/* Computing MIN */
i__6 = *n, i__7 = k + *kl;
i__5 = min(i__6,i__7);
for (i__ = max(i__3,i__4); i__ <= i__5; ++i__) {
i__3 = kk + i__ + k * ab_dim1;
rwork[i__] += ((r__1 = ab[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&ab[kk + i__ + k * ab_dim1]), dabs(r__2)))
* xk;
/* L40: */
}
/* L50: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.f;
kk = *ku + 1 - k;
/* Computing MAX */
i__5 = 1, i__3 = k - *ku;
/* Computing MIN */
i__6 = *n, i__7 = k + *kl;
i__4 = min(i__6,i__7);
for (i__ = max(i__5,i__3); i__ <= i__4; ++i__) {
i__5 = kk + i__ + k * ab_dim1;
i__3 = i__ + j * x_dim1;
s += ((r__1 = ab[i__5].r, dabs(r__1)) + (r__2 = r_imag(&
ab[kk + i__ + k * ab_dim1]), dabs(r__2))) * ((
r__3 = x[i__3].r, dabs(r__3)) + (r__4 = r_imag(&x[
i__ + j * x_dim1]), 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__4 = i__;
r__3 = s, r__4 = ((r__1 = work[i__4].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__4 = i__;
r__3 = s, r__4 = ((r__1 = work[i__4].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. */
cgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &ipiv[1]
, &work[1], n, info);
caxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1);
lstres = berr[j];
++count;
goto L20;
}
/* Bound error from formula */
/* norm(X - XTRUE) / norm(X) .le. FERR = */
/* norm( abs(inv(op(A)))* */
/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
/* where */
/* norm(Z) is the magnitude of the largest component of Z */
/* inv(op(A)) is the inverse of op(A) */
/* abs(Z) is the componentwise absolute value of the matrix or */
/* vector Z */
/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
/* EPS is machine epsilon */
/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
/* is incremented by SAFE1 if the i-th component of */
/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */
/* Use CLACN2 to estimate the infinity-norm of the matrix */
/* inv(op(A)) * diag(W), */
/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
i__4 = i__;
rwork[i__] = (r__1 = work[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
i__];
} else {
i__4 = i__;
rwork[i__] = (r__1 = work[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
i__] + safe1;
}
/* L90: */
}
kase = 0;
L100:
clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(op(A)**H). */
cgbtrs_(transt, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &
ipiv[1], &work[1], n, info);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__4 = i__;
i__5 = i__;
i__3 = i__;
q__1.r = rwork[i__5] * work[i__3].r, q__1.i = rwork[i__5]
* work[i__3].i;
work[i__4].r = q__1.r, work[i__4].i = q__1.i;
/* L110: */
}
} else {
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__4 = i__;
i__5 = i__;
i__3 = i__;
q__1.r = rwork[i__5] * work[i__3].r, q__1.i = rwork[i__5]
* work[i__3].i;
work[i__4].r = q__1.r, work[i__4].i = q__1.i;
/* L120: */
}
cgbtrs_(transn, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &
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__4 = i__ + j * x_dim1;
r__3 = lstres, r__4 = (r__1 = x[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&x[i__ + j * x_dim1]), dabs(r__2));
lstres = dmax(r__3,r__4);
/* L130: */
}
if (lstres != 0.f) {
ferr[j] /= lstres;
}
/* L140: */
}
return 0;
/* End of CGBRFS */
} /* cgbrfs_ */
void
cgbmv(char trans, int m, int n, int kl, int ku, complex *alpha, complex *a, int inca, complex *x, int incx, complex *beta, complex *y, int incy )
{
cgbmv_( &trans, &m, &n, &kl, &ku, alpha, a, &inca, x, &incx, beta, y, &incy );
}
void cblas_cgbmv(const enum CBLAS_ORDER order,
const enum CBLAS_TRANSPOSE TransA, const integer M, const integer N,
const integer KL, const integer KU,
const void *alpha, const void *A, const integer lda,
const void *X, const integer incX, const void *beta,
void *Y, const integer incY)
{
char TA;
#ifdef F77_CHAR
F77_CHAR F77_TA;
#else
#define F77_TA &TA
#endif
#define F77_M M
#define F77_N N
#define F77_lda lda
#define F77_KL KL
#define F77_KU KU
#define F77_incX incx
#define F77_incY incY
integer n=0, i=0, incx=incX;
const float *xx= (float *)X, *alp= (float *)alpha, *bet = (float *)beta;
float ALPHA[2],BETA[2];
integer tincY, tincx;
float *x=(float *)X, *y=(float *)Y, *st=0, *tx=0;
extern integer CBLAS_CallFromC;
extern integer RowMajorStrg;
RowMajorStrg = 0;
CBLAS_CallFromC = 1;
if (order == CblasColMajor)
{
if (TransA == CblasNoTrans) TA = 'N';
else if (TransA == CblasTrans) TA = 'T';
else if (TransA == CblasConjTrans) TA = 'C';
else
{
cblas_xerbla(2, "cblas_cgbmv","Illegal TransA setting, %d\n", TransA);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
#ifdef F77_CHAR
F77_TA = C2F_CHAR(&TA);
#endif
cgbmv_(F77_TA, &F77_M, &F77_N, &F77_KL, &F77_KU, alpha,
A, &F77_lda, X, &F77_incX, beta, Y, &F77_incY);
}
else if (order == CblasRowMajor)
{
RowMajorStrg = 1;
if (TransA == CblasNoTrans) TA = 'T';
else if (TransA == CblasTrans) TA = 'N';
else if (TransA == CblasConjTrans)
{
ALPHA[0]= *alp;
ALPHA[1]= -alp[1];
BETA[0]= *bet;
BETA[1]= -bet[1];
TA = 'N';
if (M > 0)
{
n = M << 1;
x = malloc(n*sizeof(float));
tx = x;
if( incX > 0 ) {
i = incX << 1 ;
tincx = 2;
st= x+n;
} else {
i = incX *(-2);
tincx = -2;
st = x-2;
x +=(n-2);
}
do
{
*x = *xx;
x[1] = -xx[1];
x += tincx ;
xx += i;
}
while (x != st);
x=tx;
incx = 1;
if( incY > 0 )
tincY = incY;
else
tincY = -incY;
y++;
if (N > 0)
{
i = tincY << 1;
n = i * N ;
st = y + n;
do {
*y = -(*y);
y += i;
} while(y != st);
y -= n;
}
}
else x = (float *) X;
}
else
{
cblas_xerbla(2, "cblas_cgbmv","Illegal TransA setting, %d\n", TransA);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
#ifdef F77_CHAR
F77_TA = C2F_CHAR(&TA);
#endif
if (TransA == CblasConjTrans)
cgbmv_(F77_TA, &F77_N, &F77_M, &F77_KU, &F77_KL, ALPHA,
A ,&F77_lda, x,&F77_incX, BETA, Y, &F77_incY);
else
cgbmv_(F77_TA, &F77_N, &F77_M, &F77_KU, &F77_KL, alpha,
A ,&F77_lda, x,&F77_incX, beta, Y, &F77_incY);
if (TransA == CblasConjTrans)
{
if (x != X) free(x);
if (N > 0)
{
do
{
*y = -(*y);
y += i;
}
while (y != st);
}
}
}
else cblas_xerbla(1, "cblas_cgbmv", "Illegal Order setting, %d\n", order);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
}
/* Subroutine */ int cla_gbrfsx_extended__(integer *prec_type__, integer *
trans_type__, integer *n, integer *kl, integer *ku, integer *nrhs,
complex *ab, integer *ldab, complex *afb, integer *ldafb, integer *
ipiv, logical *colequ, real *c__, complex *b, integer *ldb, complex *
y, integer *ldy, real *berr_out__, integer *n_norms__, real *
err_bnds_norm__, real *err_bnds_comp__, complex *res, real *ayb,
complex *dy, complex *y_tail__, real *rcond, integer *ithresh, real *
rthresh, real *dz_ub__, logical *ignore_cwise__, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
y_dim1, y_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3, i__4;
real r__1, r__2;
char ch__1[1];
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
real dxratmax, dzratmax;
integer i__, j, m;
extern /* Subroutine */ int cla_gbamv__(integer *, integer *, integer *,
integer *, integer *, real *, complex *, integer *, complex *,
integer *, real *, real *, integer *);
logical incr_prec__;
real prev_dz_z__, yk, final_dx_x__;
extern /* Subroutine */ int cla_wwaddw__(integer *, complex *, complex *,
complex *);
real final_dz_z__, prevnormdx;
integer cnt;
real dyk, eps, incr_thresh__, dx_x__, dz_z__;
extern /* Subroutine */ int cla_lin_berr__(integer *, integer *, integer *
, complex *, real *, real *);
real ymin;
extern /* Subroutine */ int blas_cgbmv_x__(integer *, integer *, integer *
, integer *, integer *, complex *, complex *, integer *, complex *
, integer *, complex *, complex *, integer *, integer *);
integer y_prec_state__;
extern /* Subroutine */ int blas_cgbmv2_x__(integer *, integer *, integer
*, integer *, integer *, complex *, complex *, integer *, complex
*, complex *, integer *, complex *, complex *, integer *, integer
*), cgbmv_(char *, integer *, integer *, integer *, integer *,
complex *, complex *, integer *, complex *, integer *, complex *,
complex *, integer *), ccopy_(integer *, complex *,
integer *, complex *, integer *);
real dxrat, dzrat;
extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
char trans[1];
real normx, normy;
extern doublereal slamch_(char *);
extern /* Subroutine */ int cgbtrs_(char *, integer *, integer *, integer
*, integer *, complex *, integer *, integer *, complex *, integer
*, integer *);
real normdx;
extern /* Character */ VOID chla_transtype__(char *, ftnlen, integer *);
real hugeval;
integer x_state__, z_state__;
/* -- LAPACK routine (version 3.2.1) -- */
/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
/* -- Jason Riedy of Univ. of California Berkeley. -- */
/* -- April 2009 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley and NAG Ltd. -- */
/* .. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLA_GBRFSX_EXTENDED improves the computed solution to a system of */
/* linear equations by performing extra-precise iterative refinement */
/* and provides error bounds and backward error estimates for the solution. */
/* This subroutine is called by CGBRFSX to perform iterative refinement. */
/* In addition to normwise error bound, the code provides maximum */
/* componentwise error bound if possible. See comments for ERR_BNDS_NORM */
/* and ERR_BNDS_COMP for details of the error bounds. Note that this */
/* subroutine is only resonsible for setting the second fields of */
/* ERR_BNDS_NORM and ERR_BNDS_COMP. */
/* Arguments */
/* ========= */
/* PREC_TYPE (input) INTEGER */
/* Specifies the intermediate precision to be used in refinement. */
/* The value is defined by ILAPREC(P) where P is a CHARACTER and */
/* P = 'S': Single */
/* = 'D': Double */
/* = 'I': Indigenous */
/* = 'X', 'E': Extra */
/* TRANS_TYPE (input) INTEGER */
/* Specifies the transposition operation on A. */
/* The value is defined by ILATRANS(T) where T is a CHARACTER and */
/* T = 'N': No transpose */
/* = 'T': Transpose */
/* = 'C': Conjugate transpose */
/* N (input) INTEGER */
/* The number of linear equations, i.e., the order of the */
/* matrix A. N >= 0. */
/* KL (input) INTEGER */
/* The number of subdiagonals within the band of A. KL >= 0. */
/* KU (input) INTEGER */
/* The number of superdiagonals within the band of A. KU >= 0 */
/* NRHS (input) INTEGER */
/* The number of right-hand-sides, i.e., the number of columns of the */
/* matrix B. */
/* AB (input) COMPLEX array, dimension (LDA,N) */
/* On entry, the N-by-N matrix A. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* AFB (input) COMPLEX array, dimension (LDAF,N) */
/* The factors L and U from the factorization */
/* A = P*L*U as computed by CGBTRF. */
/* LDAFB (input) INTEGER */
/* The leading dimension of the array AF. LDAF >= max(1,N). */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices from the factorization A = P*L*U */
/* as computed by CGBTRF; row i of the matrix was interchanged */
/* with row IPIV(i). */
/* COLEQU (input) LOGICAL */
/* If .TRUE. then column equilibration was done to A before calling */
/* this routine. This is needed to compute the solution and error */
/* bounds correctly. */
/* C (input) REAL array, dimension (N) */
/* The column scale factors for A. If COLEQU = .FALSE., C */
/* is not accessed. If C is input, each element of C should be a power */
/* of the radix to ensure a reliable solution and error estimates. */
/* Scaling by powers of the radix does not cause rounding errors unless */
/* the result underflows or overflows. Rounding errors during scaling */
/* lead to refining with a matrix that is not equivalent to the */
/* input matrix, producing error estimates that may not be */
/* reliable. */
/* B (input) COMPLEX array, dimension (LDB,NRHS) */
/* The right-hand-side matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* Y (input/output) COMPLEX array, dimension (LDY,NRHS) */
/* On entry, the solution matrix X, as computed by CGBTRS. */
/* On exit, the improved solution matrix Y. */
/* LDY (input) INTEGER */
/* The leading dimension of the array Y. LDY >= max(1,N). */
/* BERR_OUT (output) REAL array, dimension (NRHS) */
/* On exit, BERR_OUT(j) contains the componentwise relative backward */
/* error for right-hand-side j from the formula */
/* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
/* where abs(Z) is the componentwise absolute value of the matrix */
/* or vector Z. This is computed by CLA_LIN_BERR. */
/* N_NORMS (input) INTEGER */
/* Determines which error bounds to return (see ERR_BNDS_NORM */
/* and ERR_BNDS_COMP). */
/* If N_NORMS >= 1 return normwise error bounds. */
/* If N_NORMS >= 2 return componentwise error bounds. */
/* ERR_BNDS_NORM (input/output) REAL array, dimension */
/* (NRHS, N_ERR_BNDS) */
/* For each right-hand side, this array contains information about */
/* various error bounds and condition numbers corresponding to the */
/* normwise relative error, which is defined as follows: */
/* Normwise relative error in the ith solution vector: */
/* max_j (abs(XTRUE(j,i) - X(j,i))) */
/* ------------------------------ */
/* max_j abs(X(j,i)) */
/* The array is indexed by the type of error information as described */
/* below. There currently are up to three pieces of information */
/* returned. */
/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
/* right-hand side. */
/* The second index in ERR_BNDS_NORM(:,err) contains the following */
/* three fields: */
/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
/* reciprocal condition number is less than the threshold */
/* sqrt(n) * slamch('Epsilon'). */
/* err = 2 "Guaranteed" error bound: The estimated forward error, */
/* almost certainly within a factor of 10 of the true error */
/* so long as the next entry is greater than the threshold */
/* sqrt(n) * slamch('Epsilon'). This error bound should only */
/* be trusted if the previous boolean is true. */
/* err = 3 Reciprocal condition number: Estimated normwise */
/* reciprocal condition number. Compared with the threshold */
/* sqrt(n) * slamch('Epsilon') to determine if the error */
/* estimate is "guaranteed". These reciprocal condition */
/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
/* appropriately scaled matrix Z. */
/* Let Z = S*A, where S scales each row by a power of the */
/* radix so all absolute row sums of Z are approximately 1. */
/* This subroutine is only responsible for setting the second field */
/* above. */
/* See Lapack Working Note 165 for further details and extra */
/* cautions. */
/* ERR_BNDS_COMP (input/output) REAL array, dimension */
/* (NRHS, N_ERR_BNDS) */
/* For each right-hand side, this array contains information about */
/* various error bounds and condition numbers corresponding to the */
/* componentwise relative error, which is defined as follows: */
/* Componentwise relative error in the ith solution vector: */
/* abs(XTRUE(j,i) - X(j,i)) */
/* max_j ---------------------- */
/* abs(X(j,i)) */
/* The array is indexed by the right-hand side i (on which the */
/* componentwise relative error depends), and the type of error */
/* information as described below. There currently are up to three */
/* pieces of information returned for each right-hand side. If */
/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
/* the first (:,N_ERR_BNDS) entries are returned. */
/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
/* right-hand side. */
/* The second index in ERR_BNDS_COMP(:,err) contains the following */
/* three fields: */
/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
/* reciprocal condition number is less than the threshold */
/* sqrt(n) * slamch('Epsilon'). */
/* err = 2 "Guaranteed" error bound: The estimated forward error, */
/* almost certainly within a factor of 10 of the true error */
/* so long as the next entry is greater than the threshold */
/* sqrt(n) * slamch('Epsilon'). This error bound should only */
/* be trusted if the previous boolean is true. */
/* err = 3 Reciprocal condition number: Estimated componentwise */
/* reciprocal condition number. Compared with the threshold */
/* sqrt(n) * slamch('Epsilon') to determine if the error */
/* estimate is "guaranteed". These reciprocal condition */
/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
/* appropriately scaled matrix Z. */
/* Let Z = S*(A*diag(x)), where x is the solution for the */
/* current right-hand side and S scales each row of */
/* A*diag(x) by a power of the radix so all absolute row */
/* sums of Z are approximately 1. */
/* This subroutine is only responsible for setting the second field */
/* above. */
/* See Lapack Working Note 165 for further details and extra */
/* cautions. */
/* RES (input) COMPLEX array, dimension (N) */
/* Workspace to hold the intermediate residual. */
/* AYB (input) REAL array, dimension (N) */
/* Workspace. */
/* DY (input) COMPLEX array, dimension (N) */
/* Workspace to hold the intermediate solution. */
/* Y_TAIL (input) COMPLEX array, dimension (N) */
/* Workspace to hold the trailing bits of the intermediate solution. */
/* RCOND (input) REAL */
/* Reciprocal scaled condition number. This is an estimate of the */
/* reciprocal Skeel condition number of the matrix A after */
/* equilibration (if done). If this is less than the machine */
/* precision (in particular, if it is zero), the matrix is singular */
/* to working precision. Note that the error may still be small even */
/* if this number is very small and the matrix appears ill- */
/* conditioned. */
/* ITHRESH (input) INTEGER */
/* The maximum number of residual computations allowed for */
/* refinement. The default is 10. For 'aggressive' set to 100 to */
/* permit convergence using approximate factorizations or */
/* factorizations other than LU. If the factorization uses a */
/* technique other than Gaussian elimination, the guarantees in */
/* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. */
/* RTHRESH (input) REAL */
/* Determines when to stop refinement if the error estimate stops */
/* decreasing. Refinement will stop when the next solution no longer */
/* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */
/* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */
/* default value is 0.5. For 'aggressive' set to 0.9 to permit */
/* convergence on extremely ill-conditioned matrices. See LAWN 165 */
/* for more details. */
/* DZ_UB (input) REAL */
/* Determines when to start considering componentwise convergence. */
/* Componentwise convergence is only considered after each component */
/* of the solution Y is stable, which we definte as the relative */
/* change in each component being less than DZ_UB. The default value */
/* is 0.25, requiring the first bit to be stable. See LAWN 165 for */
/* more details. */
/* IGNORE_CWISE (input) LOGICAL */
/* If .TRUE. then ignore componentwise convergence. Default value */
/* is .FALSE.. */
/* INFO (output) INTEGER */
/* = 0: Successful exit. */
/* < 0: if INFO = -i, the ith argument to CGBTRS had an illegal */
/* value */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. Parameters .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions.. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function Definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
err_bnds_comp_dim1 = *nrhs;
err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
err_bnds_comp__ -= err_bnds_comp_offset;
err_bnds_norm_dim1 = *nrhs;
err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
err_bnds_norm__ -= err_bnds_norm_offset;
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
afb_dim1 = *ldafb;
afb_offset = 1 + afb_dim1;
afb -= afb_offset;
--ipiv;
--c__;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
y_dim1 = *ldy;
y_offset = 1 + y_dim1;
y -= y_offset;
--berr_out__;
--res;
--ayb;
--dy;
--y_tail__;
/* Function Body */
if (*info != 0) {
return 0;
}
chla_transtype__(ch__1, (ftnlen)1, trans_type__);
*(unsigned char *)trans = *(unsigned char *)&ch__1[0];
eps = slamch_("Epsilon");
hugeval = slamch_("Overflow");
/* Force HUGEVAL to Inf */
hugeval *= hugeval;
/* Using HUGEVAL may lead to spurious underflows. */
incr_thresh__ = (real) (*n) * eps;
m = *kl + *ku + 1;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
y_prec_state__ = 1;
if (y_prec_state__ == 2) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
y_tail__[i__3].r = 0.f, y_tail__[i__3].i = 0.f;
}
}
dxrat = 0.f;
dxratmax = 0.f;
dzrat = 0.f;
dzratmax = 0.f;
final_dx_x__ = hugeval;
final_dz_z__ = hugeval;
prevnormdx = hugeval;
prev_dz_z__ = hugeval;
dz_z__ = hugeval;
dx_x__ = hugeval;
x_state__ = 1;
z_state__ = 0;
incr_prec__ = FALSE_;
i__2 = *ithresh;
for (cnt = 1; cnt <= i__2; ++cnt) {
/* Compute residual RES = B_s - op(A_s) * Y, */
/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
ccopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
if (y_prec_state__ == 0) {
cgbmv_(trans, &m, n, kl, ku, &c_b6, &ab[ab_offset], ldab, &y[
j * y_dim1 + 1], &c__1, &c_b8, &res[1], &c__1);
} else if (y_prec_state__ == 1) {
blas_cgbmv_x__(trans_type__, n, n, kl, ku, &c_b6, &ab[
ab_offset], ldab, &y[j * y_dim1 + 1], &c__1, &c_b8, &
res[1], &c__1, prec_type__);
} else {
blas_cgbmv2_x__(trans_type__, n, n, kl, ku, &c_b6, &ab[
ab_offset], ldab, &y[j * y_dim1 + 1], &y_tail__[1], &
c__1, &c_b8, &res[1], &c__1, prec_type__);
}
/* XXX: RES is no longer needed. */
ccopy_(n, &res[1], &c__1, &dy[1], &c__1);
cgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &ipiv[1]
, &dy[1], n, info);
/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */
normx = 0.f;
normy = 0.f;
normdx = 0.f;
dz_z__ = 0.f;
ymin = hugeval;
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * y_dim1;
yk = (r__1 = y[i__4].r, dabs(r__1)) + (r__2 = r_imag(&y[i__ +
j * y_dim1]), dabs(r__2));
i__4 = i__;
dyk = (r__1 = dy[i__4].r, dabs(r__1)) + (r__2 = r_imag(&dy[
i__]), dabs(r__2));
if (yk != 0.f) {
/* Computing MAX */
r__1 = dz_z__, r__2 = dyk / yk;
dz_z__ = dmax(r__1,r__2);
} else if (dyk != 0.f) {
dz_z__ = hugeval;
}
ymin = dmin(ymin,yk);
normy = dmax(normy,yk);
if (*colequ) {
/* Computing MAX */
r__1 = normx, r__2 = yk * c__[i__];
normx = dmax(r__1,r__2);
/* Computing MAX */
r__1 = normdx, r__2 = dyk * c__[i__];
normdx = dmax(r__1,r__2);
} else {
normx = normy;
normdx = dmax(normdx,dyk);
}
}
if (normx != 0.f) {
dx_x__ = normdx / normx;
} else if (normdx == 0.f) {
dx_x__ = 0.f;
} else {
dx_x__ = hugeval;
}
dxrat = normdx / prevnormdx;
dzrat = dz_z__ / prev_dz_z__;
/* Check termination criteria. */
if (! (*ignore_cwise__) && ymin * *rcond < incr_thresh__ * normy
&& y_prec_state__ < 2) {
incr_prec__ = TRUE_;
}
if (x_state__ == 3 && dxrat <= *rthresh) {
x_state__ = 1;
}
if (x_state__ == 1) {
if (dx_x__ <= eps) {
x_state__ = 2;
} else if (dxrat > *rthresh) {
if (y_prec_state__ != 2) {
incr_prec__ = TRUE_;
} else {
x_state__ = 3;
}
} else {
if (dxrat > dxratmax) {
dxratmax = dxrat;
}
}
if (x_state__ > 1) {
final_dx_x__ = dx_x__;
}
}
if (z_state__ == 0 && dz_z__ <= *dz_ub__) {
z_state__ = 1;
}
if (z_state__ == 3 && dzrat <= *rthresh) {
z_state__ = 1;
}
if (z_state__ == 1) {
if (dz_z__ <= eps) {
z_state__ = 2;
} else if (dz_z__ > *dz_ub__) {
z_state__ = 0;
dzratmax = 0.f;
final_dz_z__ = hugeval;
} else if (dzrat > *rthresh) {
if (y_prec_state__ != 2) {
incr_prec__ = TRUE_;
} else {
z_state__ = 3;
}
} else {
if (dzrat > dzratmax) {
dzratmax = dzrat;
}
}
if (z_state__ > 1) {
final_dz_z__ = dz_z__;
}
}
/* Exit if both normwise and componentwise stopped working, */
/* but if componentwise is unstable, let it go at least two */
/* iterations. */
if (x_state__ != 1) {
if (*ignore_cwise__) {
goto L666;
}
if (z_state__ == 3 || z_state__ == 2) {
goto L666;
}
if (z_state__ == 0 && cnt > 1) {
goto L666;
}
}
if (incr_prec__) {
incr_prec__ = FALSE_;
++y_prec_state__;
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
y_tail__[i__4].r = 0.f, y_tail__[i__4].i = 0.f;
}
}
prevnormdx = normdx;
prev_dz_z__ = dz_z__;
/* Update soluton. */
if (y_prec_state__ < 2) {
caxpy_(n, &c_b8, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1);
} else {
cla_wwaddw__(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]);
}
}
/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. */
L666:
/* Set final_* when cnt hits ithresh. */
if (x_state__ == 1) {
final_dx_x__ = dx_x__;
}
if (z_state__ == 1) {
final_dz_z__ = dz_z__;
}
/* Compute error bounds. */
if (*n_norms__ >= 1) {
err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = final_dx_x__ / (
1 - dxratmax);
}
if (*n_norms__ >= 2) {
err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = final_dz_z__ / (
1 - dzratmax);
}
/* Compute componentwise relative backward error from formula */
/* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
/* where abs(Z) is the componentwise absolute value of the matrix */
/* or vector Z. */
/* Compute residual RES = B_s - op(A_s) * Y, */
/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
ccopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
cgbmv_(trans, n, n, kl, ku, &c_b6, &ab[ab_offset], ldab, &y[j *
y_dim1 + 1], &c__1, &c_b8, &res[1], &c__1);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * b_dim1;
ayb[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[i__
+ j * b_dim1]), dabs(r__2));
}
/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */
cla_gbamv__(trans_type__, n, n, kl, ku, &c_b31, &ab[ab_offset], ldab,
&y[j * y_dim1 + 1], &c__1, &c_b31, &ayb[1], &c__1);
cla_lin_berr__(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]);
/* End of loop for each RHS. */
}
return 0;
} /* cla_gbrfsx_extended__ */
/* Subroutine */ int clarhs_(char *path, char *xtype, char *uplo, char *trans,
integer *m, integer *n, integer *kl, integer *ku, integer *nrhs,
complex *a, integer *lda, complex *x, integer *ldx, complex *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 cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *), chemm_(char *,
char *, integer *, integer *, complex *, complex *, integer *,
complex *, integer *, complex *, complex *, integer *), cgbmv_(char *, integer *, integer *, integer *, integer *
, complex *, complex *, integer *, complex *, integer *, complex *
, complex *, integer *), chbmv_(char *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *);
extern /* Subroutine */ int csbmv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *), ctbmv_(char *, char *, char *, integer *,
integer *, complex *, integer *, complex *, integer *), chpmv_(char *, integer *, complex *, complex *,
complex *, integer *, complex *, complex *, integer *),
ctrmm_(char *, char *, char *, char *, integer *, integer *,
complex *, complex *, integer *, complex *, integer *), cspmv_(char *, integer *, complex *,
complex *, complex *, integer *, complex *, complex *, integer *), csymm_(char *, char *, integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, complex *,
integer *), ctpmv_(char *, char *, char *,
integer *, complex *, complex *, integer *), clacpy_(char *, integer *, integer *, complex *, integer
*, complex *, integer *), xerbla_(char *, integer *);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int clarnv_(integer *, integer *, integer *,
complex *);
logical notran;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLARHS 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 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 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 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 */
/* CLATMS). 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, "Complex 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_("CLARHS", &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) {
clarnv_(&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 */
cgemm_(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 */
chemm_("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 */
csymm_("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) {
cgbmv_(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) {
chbmv_(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) {
csbmv_(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) {
chpmv_(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) {
cspmv_(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 */
clacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
if (*ku == 2) {
*(unsigned char *)diag = 'U';
} else {
*(unsigned char *)diag = 'N';
}
ctrmm_("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 */
clacpy_("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) {
ctpmv_(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 */
clacpy_("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) {
ctbmv_(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_("CLARHS", &i__1);
}
return 0;
/* End of CLARHS */
} /* clarhs_ */
/* Subroutine */ int cgbt02_(char *trans, integer *m, integer *n, integer *kl,
integer *ku, integer *nrhs, complex *a, integer *lda, complex *x,
integer *ldx, complex *b, integer *ldb, real *resid)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2,
i__3;
real r__1, r__2;
complex q__1;
/* Local variables */
integer j, i1, i2, n1, kd;
real eps;
real anorm, bnorm, xnorm;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGBT02 computes the residual for a solution of a banded system of */
/* equations A*x = b or A'*x = b: */
/* RESID = norm( B - A*X ) / ( norm(A) * norm(X) * EPS). */
/* where EPS is the machine precision. */
/* Arguments */
/* ========= */
/* TRANS (input) CHARACTER*1 */
/* Specifies the form of the system of equations: */
/* = 'N': A *x = b */
/* = 'T': A'*x = b, where A' is the transpose of A */
/* = 'C': A'*x = b, where A' is the transpose of A */
/* 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 */
/* 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 B. NRHS >= 0. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The original matrix A in band storage, stored in rows 1 to */
/* KL+KU+1. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,KL+KU+1). */
/* X (input) COMPLEX array, dimension (LDX,NRHS) */
/* The computed solution vectors for the system of linear */
/* equations. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. If TRANS = 'N', */
/* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M). */
/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
/* On entry, the right hand side vectors for the system of */
/* linear equations. */
/* On exit, B is overwritten with the difference B - A*X. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. IF TRANS = 'N', */
/* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N). */
/* RESID (output) REAL */
/* The maximum over the number of right hand sides of */
/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if N = 0 pr NRHS = 0 */
/* 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;
/* Function Body */
if (*m <= 0 || *n <= 0 || *nrhs <= 0) {
*resid = 0.f;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = slamch_("Epsilon");
kd = *ku + 1;
anorm = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = kd + 1 - j;
i1 = max(i__2,1);
/* Computing MIN */
i__2 = kd + *m - j, i__3 = *kl + kd;
i2 = min(i__2,i__3);
/* Computing MAX */
i__2 = i2 - i1 + 1;
r__1 = anorm, r__2 = scasum_(&i__2, &a[i1 + j * a_dim1], &c__1);
anorm = dmax(r__1,r__2);
/* L10: */
}
if (anorm <= 0.f) {
*resid = 1.f / eps;
return 0;
}
if (lsame_(trans, "T") || lsame_(trans, "C")) {
n1 = *n;
} else {
n1 = *m;
}
/* Compute B - A*X (or B - A'*X ) */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
q__1.r = -1.f, q__1.i = -0.f;
cgbmv_(trans, m, n, kl, ku, &q__1, &a[a_offset], lda, &x[j * x_dim1 +
1], &c__1, &c_b1, &b[j * b_dim1 + 1], &c__1);
/* L20: */
}
/* Compute the maximum over the number of right hand sides of */
/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
*resid = 0.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
bnorm = scasum_(&n1, &b[j * b_dim1 + 1], &c__1);
xnorm = scasum_(&n1, &x[j * x_dim1 + 1], &c__1);
if (xnorm <= 0.f) {
*resid = 1.f / eps;
} else {
/* Computing MAX */
r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
*resid = dmax(r__1,r__2);
}
/* L30: */
}
return 0;
/* End of CGBT02 */
} /* cgbt02_ */
