/* Subroutine */
int ctpcon_(char *norm, char *uplo, char *diag, integer *n, complex *ap, real *rcond, complex *work, real *rwork, integer *info)
{
/* System generated locals */
integer i__1;
real r__1, r__2;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
integer ix, kase, kase1;
real scale;
extern logical lsame_(char *, char *);
integer isave[3];
real anorm;
logical upper;
extern /* Subroutine */
int clacn2_(integer *, complex *, complex *, real *, integer *, integer *);
real xnorm;
extern integer icamax_(integer *, complex *, integer *);
extern real slamch_(char *);
extern /* Subroutine */
int xerbla_(char *, integer *);
extern real clantp_(char *, char *, char *, integer *, complex *, real *);
extern /* Subroutine */
int clatps_(char *, char *, char *, char *, integer *, complex *, complex *, real *, real *, integer *);
real ainvnm;
extern /* Subroutine */
int csrscl_(integer *, real *, complex *, integer *);
logical onenrm;
char normin[1];
real smlnum;
logical nounit;
/* -- 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 Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--rwork;
--work;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
nounit = lsame_(diag, "N");
if (! onenrm && ! lsame_(norm, "I"))
{
*info = -1;
}
else if (! upper && ! lsame_(uplo, "L"))
{
*info = -2;
}
else if (! nounit && ! lsame_(diag, "U"))
{
*info = -3;
}
else if (*n < 0)
{
*info = -4;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CTPCON", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
*rcond = 1.f;
return 0;
}
*rcond = 0.f;
smlnum = slamch_("Safe minimum") * (real) max(1,*n);
/* Compute the norm of the triangular matrix A. */
anorm = clantp_(norm, uplo, diag, n, &ap[1], &rwork[1]);
/* Continue only if ANORM > 0. */
if (anorm > 0.f)
{
/* Estimate the norm of the inverse of A. */
ainvnm = 0.f;
*(unsigned char *)normin = 'N';
if (onenrm)
{
kase1 = 1;
}
else
{
kase1 = 2;
}
kase = 0;
L10:
clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
if (kase != 0)
{
if (kase == kase1)
{
/* Multiply by inv(A). */
clatps_(uplo, "No transpose", diag, normin, n, &ap[1], &work[ 1], &scale, &rwork[1], info);
}
else
{
/* Multiply by inv(A**H). */
clatps_(uplo, "Conjugate transpose", diag, normin, n, &ap[1], &work[1], &scale, &rwork[1], info);
}
*(unsigned char *)normin = 'Y';
/* Multiply by 1/SCALE if doing so will not cause overflow. */
if (scale != 1.f)
{
ix = icamax_(n, &work[1], &c__1);
i__1 = ix;
xnorm = (r__1 = work[i__1].r, abs(r__1)) + (r__2 = r_imag(& work[ix]), abs(r__2));
if (scale < xnorm * smlnum || scale == 0.f)
{
goto L20;
}
csrscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.f)
{
*rcond = 1.f / anorm / ainvnm;
}
}
L20:
return 0;
/* End of CTPCON */
}
/* Subroutine */ int ctpt02_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, complex *ap, complex *x, integer *ldx, complex *b,
integer *ldb, complex *work, real *rwork, real *resid)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1;
real r__1, r__2;
/* Local variables */
static integer j;
extern logical lsame_(char *, char *);
static real anorm, bnorm;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *), ctpmv_(char *, char *, char *,
integer *, complex *, complex *, integer *);
static real xnorm;
extern doublereal slamch_(char *), clantp_(char *, char *, char *,
integer *, complex *, real *), scasum_(
integer *, complex *, integer *);
static real 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)]
/* -- 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
=======
CTPT02 computes the residual for the computed solution to a
triangular system of linear equations A*x = b, A**T *x = b, or
A**H *x = b, when the triangular matrix A is stored in packed format.
Here A**T denotes the transpose of A, A**H denotes the conjugate
transpose of A, and x and b are N by NRHS matrices. The test ratio
is the maximum over the number of right hand sides of
the maximum over the number of right hand sides of
norm(b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ),
where op(A) denotes A, A**T, or A**H, and EPS is the machine epsilon.
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 operation applied to A.
= 'N': A *x = b (No transpose)
= 'T': A**T *x = b (Transpose)
= 'C': A**H *x = b (Conjugate 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 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. NRHS >= 0.
AP (input) COMPLEX 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((j-1)*j/2 + i) = A(i,j) for 1<=i<=j;
if UPLO = 'L',
AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n.
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. LDX >= max(1,N).
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).
WORK (workspace) COMPLEX array, dimension (N)
RWORK (workspace) REAL array, dimension (N)
RESID (output) REAL
The maximum over the number of right hand sides of
norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ).
=====================================================================
Quick exit if N = 0 or NRHS = 0
Parameter adjustments */
--ap;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--work;
--rwork;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
*resid = 0.f;
return 0;
}
/* Compute the 1-norm of A or A**H. */
if (lsame_(trans, "N")) {
anorm = clantp_("1", uplo, diag, n, &ap[1], &rwork[1]);
} else {
anorm = clantp_("I", uplo, diag, n, &ap[1], &rwork[1]);
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = slamch_("Epsilon");
if (anorm <= 0.f) {
*resid = 1.f / eps;
return 0;
}
/* Compute the maximum over the number of right hand sides of
norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). */
*resid = 0.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ccopy_(n, &x_ref(1, j), &c__1, &work[1], &c__1);
ctpmv_(uplo, trans, diag, n, &ap[1], &work[1], &c__1);
caxpy_(n, &c_b12, &b_ref(1, j), &c__1, &work[1], &c__1);
bnorm = scasum_(n, &work[1], &c__1);
xnorm = scasum_(n, &x_ref(1, j), &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);
}
/* L10: */
}
return 0;
/* End of CTPT02 */
} /* ctpt02_ */
/* Subroutine */ int ctpcon_(char *norm, char *uplo, char *diag, integer *n,
complex *ap, real *rcond, complex *work, real *rwork, integer *info,
ftnlen norm_len, ftnlen uplo_len, ftnlen diag_len)
{
/* System generated locals */
integer i__1;
real r__1, r__2;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static integer ix, kase, kase1;
static real scale;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static real anorm;
static logical upper;
static real xnorm;
extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real
*, integer *);
extern integer icamax_(integer *, complex *, integer *);
extern doublereal slamch_(char *, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
extern doublereal clantp_(char *, char *, char *, integer *, complex *,
real *, ftnlen, ftnlen, ftnlen);
extern /* Subroutine */ int clatps_(char *, char *, char *, char *,
integer *, complex *, complex *, real *, real *, integer *,
ftnlen, ftnlen, ftnlen, ftnlen);
static real ainvnm;
extern /* Subroutine */ int csrscl_(integer *, real *, complex *, integer
*);
static logical onenrm;
static char normin[1];
static real smlnum;
static logical nounit;
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* March 31, 1993 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CTPCON estimates the reciprocal of the condition number of a packed */
/* triangular matrix A, in either the 1-norm or the infinity-norm. */
/* The norm of A is computed and an estimate is obtained for */
/* norm(inv(A)), then the reciprocal of the condition number is */
/* computed as */
/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies whether the 1-norm condition number or the */
/* infinity-norm condition number is required: */
/* = '1' or 'O': 1-norm; */
/* = 'I': Infinity-norm. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': A is upper triangular; */
/* = 'L': A is lower triangular. */
/* DIAG (input) CHARACTER*1 */
/* = 'N': A is non-unit triangular; */
/* = 'U': A is unit triangular. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
/* The upper or lower triangular matrix A, packed columnwise in */
/* a linear array. The j-th column of A is stored in the array */
/* AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
/* If DIAG = 'U', the diagonal elements of A are not referenced */
/* and are assumed to be 1. */
/* RCOND (output) REAL */
/* The reciprocal of the condition number of the matrix A, */
/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
/* 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 */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--rwork;
--work;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O", (ftnlen)1, (
ftnlen)1);
nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
if (! onenrm && ! lsame_(norm, "I", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) {
*info = -3;
} else if (*n < 0) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTPCON", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*rcond = 1.f;
return 0;
}
*rcond = 0.f;
smlnum = slamch_("Safe minimum", (ftnlen)12) * (real) max(1,*n);
/* Compute the norm of the triangular matrix A. */
anorm = clantp_(norm, uplo, diag, n, &ap[1], &rwork[1], (ftnlen)1, (
ftnlen)1, (ftnlen)1);
/* Continue only if ANORM > 0. */
if (anorm > 0.f) {
/* Estimate the norm of the inverse of A. */
ainvnm = 0.f;
*(unsigned char *)normin = 'N';
if (onenrm) {
kase1 = 1;
} else {
kase1 = 2;
}
kase = 0;
L10:
clacon_(n, &work[*n + 1], &work[1], &ainvnm, &kase);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(A). */
clatps_(uplo, "No transpose", diag, normin, n, &ap[1], &work[
1], &scale, &rwork[1], info, (ftnlen)1, (ftnlen)12, (
ftnlen)1, (ftnlen)1);
} else {
/* Multiply by inv(A'). */
clatps_(uplo, "Conjugate transpose", diag, normin, n, &ap[1],
&work[1], &scale, &rwork[1], info, (ftnlen)1, (ftnlen)
19, (ftnlen)1, (ftnlen)1);
}
*(unsigned char *)normin = 'Y';
/* Multiply by 1/SCALE if doing so will not cause overflow. */
if (scale != 1.f) {
ix = icamax_(n, &work[1], &c__1);
i__1 = ix;
xnorm = (r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(&
work[ix]), dabs(r__2));
if (scale < xnorm * smlnum || scale == 0.f) {
goto L20;
}
csrscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.f) {
*rcond = 1.f / anorm / ainvnm;
}
}
L20:
return 0;
/* End of CTPCON */
} /* ctpcon_ */
/* Subroutine */ int ctpt01_(char *uplo, char *diag, integer *n, complex *ap,
complex *ainvp, real *rcond, real *rwork, real *resid)
{
/* System generated locals */
integer i__1, i__2, i__3;
complex q__1;
/* Local variables */
integer j, jc;
real eps;
extern logical lsame_(char *, char *);
real anorm;
logical unitd;
extern /* Subroutine */ int ctpmv_(char *, char *, char *, integer *,
complex *, complex *, integer *);
extern doublereal slamch_(char *), clantp_(char *, char *, char *,
integer *, complex *, real *);
real ainvnm;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CTPT01 computes the residual for a triangular matrix A times its */
/* inverse when A is stored in packed format: */
/* RESID = norm(A*AINV - I) / ( N * norm(A) * norm(AINV) * EPS ), */
/* where EPS is the machine epsilon. */
/* Arguments */
/* ========== */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A is upper or lower triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* 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 order of the matrix A. N >= 0. */
/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
/* The original 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((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', */
/* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. */
/* AINVP (input) COMPLEX array, dimension (N*(N+1)/2) */
/* On entry, the (triangular) inverse of the matrix A, packed */
/* columnwise in a linear array as in AP. */
/* On exit, the contents of AINVP are destroyed. */
/* RCOND (output) REAL */
/* The reciprocal condition number of A, computed as */
/* 1/(norm(A) * norm(AINV)). */
/* RWORK (workspace) REAL array, dimension (N) */
/* RESID (output) REAL */
/* norm(A*AINV - I) / ( N * norm(A) * norm(AINV) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0. */
/* Parameter adjustments */
--rwork;
--ainvp;
--ap;
/* Function Body */
if (*n <= 0) {
*rcond = 1.f;
*resid = 0.f;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
eps = slamch_("Epsilon");
anorm = clantp_("1", uplo, diag, n, &ap[1], &rwork[1]);
ainvnm = clantp_("1", uplo, diag, n, &ainvp[1], &rwork[1]);
if (anorm <= 0.f || ainvnm <= 0.f) {
*rcond = 0.f;
*resid = 1.f / eps;
return 0;
}
*rcond = 1.f / anorm / ainvnm;
/* Compute A * AINV, overwriting AINV. */
unitd = lsame_(diag, "U");
if (lsame_(uplo, "U")) {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (unitd) {
i__2 = jc + j - 1;
ainvp[i__2].r = 1.f, ainvp[i__2].i = 0.f;
}
/* Form the j-th column of A*AINV. */
ctpmv_("Upper", "No transpose", diag, &j, &ap[1], &ainvp[jc], &
c__1);
/* Subtract 1 from the diagonal to form A*AINV - I. */
i__2 = jc + j - 1;
i__3 = jc + j - 1;
q__1.r = ainvp[i__3].r - 1.f, q__1.i = ainvp[i__3].i;
ainvp[i__2].r = q__1.r, ainvp[i__2].i = q__1.i;
jc += j;
/* L10: */
}
} else {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (unitd) {
i__2 = jc;
ainvp[i__2].r = 1.f, ainvp[i__2].i = 0.f;
}
/* Form the j-th column of A*AINV. */
i__2 = *n - j + 1;
ctpmv_("Lower", "No transpose", diag, &i__2, &ap[jc], &ainvp[jc],
&c__1);
/* Subtract 1 from the diagonal to form A*AINV - I. */
i__2 = jc;
i__3 = jc;
q__1.r = ainvp[i__3].r - 1.f, q__1.i = ainvp[i__3].i;
ainvp[i__2].r = q__1.r, ainvp[i__2].i = q__1.i;
jc = jc + *n - j + 1;
/* L20: */
}
}
/* Compute norm(A*AINV - I) / (N * norm(A) * norm(AINV) * EPS) */
*resid = clantp_("1", uplo, "Non-unit", n, &ainvp[1], &rwork[1]);
*resid = *resid * *rcond / (real) (*n) / eps;
return 0;
/* End of CTPT01 */
} /* ctpt01_ */
/* Subroutine */ int ctpt06_(real *rcond, real *rcondc, char *uplo, char *
diag, integer *n, complex *ap, real *rwork, real *rat)
{
/* System generated locals */
real r__1, r__2;
/* Local variables */
static real rmin, rmax, anorm;
extern doublereal slamch_(char *);
static real bignum;
extern doublereal clantp_(char *, char *, char *, integer *, complex *,
real *);
static real eps;
/* -- 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
=======
CTPT06 computes a test ratio comparing RCOND (the reciprocal
condition number of the triangular matrix A) and RCONDC, the estimate
computed by CTPCON. Information about the triangular matrix is used
if one estimate is zero and the other is non-zero to decide if
underflow in the estimate is justified.
Arguments
=========
RCOND (input) REAL
The estimate of the reciprocal condition number obtained by
forming the explicit inverse of the matrix A and computing
RCOND = 1/( norm(A) * norm(inv(A)) ).
RCONDC (input) REAL
The estimate of the reciprocal condition number computed by
CTPCON.
UPLO (input) CHARACTER
Specifies whether the matrix A is upper or lower triangular.
= 'U': Upper triangular
= 'L': Lower triangular
DIAG (input) CHARACTER
Specifies whether or not the matrix A is unit triangular.
= 'N': Non-unit triangular
= 'U': Unit triangular
N (input) INTEGER
The order of the matrix A. N >= 0.
AP (input) COMPLEX 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((j-1)*j/2 + i) = A(i,j) for 1<=i<=j;
if UPLO = 'L',
AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n.
RWORK (workspace) REAL array, dimension (N)
RAT (output) REAL
The test ratio. If both RCOND and RCONDC are nonzero,
RAT = MAX( RCOND, RCONDC )/MIN( RCOND, RCONDC ) - 1.
If RAT = 0, the two estimates are exactly the same.
=====================================================================
Parameter adjustments */
--rwork;
--ap;
/* Function Body */
eps = slamch_("Epsilon");
rmax = dmax(*rcond,*rcondc);
rmin = dmin(*rcond,*rcondc);
/* Do the easy cases first. */
if (rmin < 0.f) {
/* Invalid value for RCOND or RCONDC, return 1/EPS. */
*rat = 1.f / eps;
} else if (rmin > 0.f) {
/* Both estimates are positive, return RMAX/RMIN - 1. */
*rat = rmax / rmin - 1.f;
} else if (rmax == 0.f) {
/* Both estimates zero. */
*rat = 0.f;
} else {
/* One estimate is zero, the other is non-zero. If the matrix is
ill-conditioned, return the nonzero estimate multiplied by
1/EPS; if the matrix is badly scaled, return the nonzero
estimate multiplied by BIGNUM/TMAX, where TMAX is the maximum
element in absolute value in A. */
bignum = 1.f / slamch_("Safe minimum");
anorm = clantp_("M", uplo, diag, n, &ap[1], &rwork[1]);
/* Computing MIN */
r__1 = bignum / dmax(1.f,anorm), r__2 = 1.f / eps;
*rat = rmax * dmin(r__1,r__2);
}
return 0;
/* End of CTPT06 */
} /* ctpt06_ */
/* Subroutine */ int ctpt02_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, complex *ap, complex *x, integer *ldx, complex *b,
integer *ldb, complex *work, real *rwork, real *resid)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1;
real r__1, r__2;
/* Local variables */
integer j;
real eps;
extern logical lsame_(char *, char *);
real anorm, bnorm;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *), ctpmv_(char *, char *, char *,
integer *, complex *, complex *, integer *);
real xnorm;
extern doublereal slamch_(char *), clantp_(char *, char *, char *,
integer *, complex *, real *), scasum_(
integer *, complex *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CTPT02 computes the residual for the computed solution to a */
/* triangular system of linear equations A*x = b, A**T *x = b, or */
/* A**H *x = b, when the triangular matrix A is stored in packed format. */
/* Here A**T denotes the transpose of A, A**H denotes the conjugate */
/* transpose of A, and x and b are N by NRHS matrices. The test ratio */
/* is the maximum over the number of right hand sides of */
/* the maximum over the number of right hand sides of */
/* norm(b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
/* where op(A) denotes A, A**T, or A**H, and EPS is the machine epsilon. */
/* 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 operation applied to A. */
/* = 'N': A *x = b (No transpose) */
/* = 'T': A**T *x = b (Transpose) */
/* = 'C': A**H *x = b (Conjugate 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 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. NRHS >= 0. */
/* AP (input) COMPLEX 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((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', */
/* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. */
/* 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. LDX >= max(1,N). */
/* 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). */
/* WORK (workspace) COMPLEX array, dimension (N) */
/* RWORK (workspace) REAL array, dimension (N) */
/* RESID (output) REAL */
/* The maximum over the number of right hand sides of */
/* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0 or NRHS = 0 */
/* Parameter adjustments */
--ap;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--work;
--rwork;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
*resid = 0.f;
return 0;
}
/* Compute the 1-norm of A or A**H. */
if (lsame_(trans, "N")) {
anorm = clantp_("1", uplo, diag, n, &ap[1], &rwork[1]);
} else {
anorm = clantp_("I", uplo, diag, n, &ap[1], &rwork[1]);
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = slamch_("Epsilon");
if (anorm <= 0.f) {
*resid = 1.f / eps;
return 0;
}
/* Compute the maximum over the number of right hand sides of */
/* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). */
*resid = 0.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ccopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
ctpmv_(uplo, trans, diag, n, &ap[1], &work[1], &c__1);
caxpy_(n, &c_b12, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
bnorm = scasum_(n, &work[1], &c__1);
xnorm = scasum_(n, &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);
}
/* L10: */
}
return 0;
/* End of CTPT02 */
} /* ctpt02_ */
