/* Subroutine */ int ctrcon_(char *norm, char *uplo, char *diag, integer *n,
complex *a, integer *lda, real *rcond, complex *work, real *rwork,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, 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 doublereal slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern doublereal clantr_(char *, char *, char *, integer *, integer *,
complex *, integer *, real *);
real ainvnm;
extern /* Subroutine */ int clatrs_(char *, char *, char *, char *,
integer *, complex *, integer *, complex *, real *, real *,
integer *), csrscl_(integer *,
real *, complex *, integer *);
logical onenrm;
char normin[1];
real smlnum;
logical nounit;
/* -- LAPACK routine (version 3.1) -- */
/* 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 */
/* ======= */
/* CTRCON estimates the reciprocal of the condition number of a */
/* 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. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The triangular matrix A. If UPLO = 'U', the leading N-by-N */
/* upper triangular part of the array A contains the upper */
/* triangular matrix, and the strictly lower triangular part of */
/* A is not referenced. If UPLO = 'L', the leading N-by-N lower */
/* triangular part of the array A contains the lower triangular */
/* matrix, and the strictly upper triangular part of A is not */
/* referenced. If DIAG = 'U', the diagonal elements of A are */
/* also not referenced and are assumed to be 1. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* 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 .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--work;
--rwork;
/* 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;
} else if (*lda < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTRCON", &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 = clantr_(norm, uplo, diag, n, n, &a[a_offset], lda, &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). */
clatrs_(uplo, "No transpose", diag, normin, n, &a[a_offset],
lda, &work[1], &scale, &rwork[1], info);
} else {
/* Multiply by inv(A'). */
clatrs_(uplo, "Conjugate transpose", diag, normin, n, &a[
a_offset], lda, &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, 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 CTRCON */
} /* ctrcon_ */
/* Subroutine */
int cgesvx_(char *fact, char *trans, integer *n, integer * nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer * ipiv, char *equed, real *r__, real *c__, complex *b, integer *ldb, complex *x, integer *ldx, real *rcond, real *ferr, real *berr, complex *work, real *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2;
complex q__1;
/* Local variables */
integer i__, j;
real amax;
char norm[1];
extern logical lsame_(char *, char *);
real rcmin, rcmax, anorm;
logical equil;
extern real clange_(char *, integer *, integer *, complex *, integer *, real *);
extern /* Subroutine */
int claqge_(integer *, integer *, complex *, integer *, real *, real *, real *, real *, real *, char *) , cgecon_(char *, integer *, complex *, integer *, real *, real *, complex *, real *, integer *);
real colcnd;
extern real slamch_(char *);
extern /* Subroutine */
int cgeequ_(integer *, integer *, complex *, integer *, real *, real *, real *, real *, real *, integer *);
logical nofact;
extern /* Subroutine */
int cgerfs_(char *, integer *, integer *, complex *, integer *, complex *, integer *, integer *, complex *, integer *, complex *, integer *, real *, real *, complex *, real *, integer *), cgetrf_(integer *, integer *, complex *, integer *, integer *, integer *), clacpy_(char *, integer *, integer *, complex *, integer *, complex *, integer *), xerbla_(char *, integer *);
real bignum;
extern real clantr_(char *, char *, char *, integer *, integer *, complex *, integer *, real *);
integer infequ;
logical colequ;
extern /* Subroutine */
int cgetrs_(char *, integer *, integer *, complex *, integer *, integer *, complex *, integer *, integer *);
real rowcnd;
logical notran;
real smlnum;
logical rowequ;
real rpvgrw;
/* -- LAPACK driver routine (version 3.4.1) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* April 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--ipiv;
--r__;
--c__;
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;
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
notran = lsame_(trans, "N");
if (nofact || equil)
{
*(unsigned char *)equed = 'N';
rowequ = FALSE_;
colequ = FALSE_;
}
else
{
rowequ = lsame_(equed, "R") || lsame_(equed, "B");
colequ = lsame_(equed, "C") || lsame_(equed, "B");
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
}
/* Test the input parameters. */
if (! nofact && ! equil && ! lsame_(fact, "F"))
{
*info = -1;
}
else if (! notran && ! lsame_(trans, "T") && ! lsame_(trans, "C"))
{
*info = -2;
}
else if (*n < 0)
{
*info = -3;
}
else if (*nrhs < 0)
{
*info = -4;
}
else if (*lda < max(1,*n))
{
*info = -6;
}
else if (*ldaf < max(1,*n))
{
*info = -8;
}
else if (lsame_(fact, "F") && ! (rowequ || colequ || lsame_(equed, "N")))
{
*info = -10;
}
else
{
if (rowequ)
{
rcmin = bignum;
rcmax = 0.f;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MIN */
r__1 = rcmin;
r__2 = r__[j]; // , expr subst
rcmin = min(r__1,r__2);
/* Computing MAX */
r__1 = rcmax;
r__2 = r__[j]; // , expr subst
rcmax = max(r__1,r__2);
/* L10: */
}
if (rcmin <= 0.f)
{
*info = -11;
}
else if (*n > 0)
{
rowcnd = max(rcmin,smlnum) / min(rcmax,bignum);
}
else
{
rowcnd = 1.f;
}
}
if (colequ && *info == 0)
{
rcmin = bignum;
rcmax = 0.f;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MIN */
r__1 = rcmin;
r__2 = c__[j]; // , expr subst
rcmin = min(r__1,r__2);
/* Computing MAX */
r__1 = rcmax;
r__2 = c__[j]; // , expr subst
rcmax = max(r__1,r__2);
/* L20: */
}
if (rcmin <= 0.f)
{
*info = -12;
}
else if (*n > 0)
{
colcnd = max(rcmin,smlnum) / min(rcmax,bignum);
}
else
{
colcnd = 1.f;
}
}
if (*info == 0)
{
if (*ldb < max(1,*n))
{
*info = -14;
}
else if (*ldx < max(1,*n))
{
*info = -16;
}
}
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CGESVX", &i__1);
return 0;
}
if (equil)
{
/* Compute row and column scalings to equilibrate the matrix A. */
cgeequ_(n, n, &a[a_offset], lda, &r__[1], &c__[1], &rowcnd, &colcnd, & amax, &infequ);
if (infequ == 0)
{
/* Equilibrate the matrix. */
claqge_(n, n, &a[a_offset], lda, &r__[1], &c__[1], &rowcnd, & colcnd, &amax, equed);
rowequ = lsame_(equed, "R") || lsame_(equed, "B");
colequ = lsame_(equed, "C") || lsame_(equed, "B");
}
}
/* Scale the right hand side. */
if (notran)
{
if (rowequ)
{
i__1 = *nrhs;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
i__3 = i__ + j * b_dim1;
i__4 = i__;
i__5 = i__ + j * b_dim1;
q__1.r = r__[i__4] * b[i__5].r;
q__1.i = r__[i__4] * b[ i__5].i; // , expr subst
b[i__3].r = q__1.r;
b[i__3].i = q__1.i; // , expr subst
/* L30: */
}
/* L40: */
}
}
}
else if (colequ)
{
i__1 = *nrhs;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
i__3 = i__ + j * b_dim1;
i__4 = i__;
i__5 = i__ + j * b_dim1;
q__1.r = c__[i__4] * b[i__5].r;
q__1.i = c__[i__4] * b[i__5] .i; // , expr subst
b[i__3].r = q__1.r;
b[i__3].i = q__1.i; // , expr subst
/* L50: */
}
/* L60: */
}
}
if (nofact || equil)
{
/* Compute the LU factorization of A. */
clacpy_("Full", n, n, &a[a_offset], lda, &af[af_offset], ldaf);
cgetrf_(n, n, &af[af_offset], ldaf, &ipiv[1], info);
/* Return if INFO is non-zero. */
if (*info > 0)
{
/* Compute the reciprocal pivot growth factor of the */
/* leading rank-deficient INFO columns of A. */
rpvgrw = clantr_("M", "U", "N", info, info, &af[af_offset], ldaf, &rwork[1]);
if (rpvgrw == 0.f)
{
rpvgrw = 1.f;
}
else
{
rpvgrw = clange_("M", n, info, &a[a_offset], lda, &rwork[1]) / rpvgrw;
}
rwork[1] = rpvgrw;
*rcond = 0.f;
return 0;
}
}
/* Compute the norm of the matrix A and the */
/* reciprocal pivot growth factor RPVGRW. */
if (notran)
{
*(unsigned char *)norm = '1';
}
else
{
*(unsigned char *)norm = 'I';
}
anorm = clange_(norm, n, n, &a[a_offset], lda, &rwork[1]);
rpvgrw = clantr_("M", "U", "N", n, n, &af[af_offset], ldaf, &rwork[1]);
if (rpvgrw == 0.f)
{
rpvgrw = 1.f;
}
else
{
rpvgrw = clange_("M", n, n, &a[a_offset], lda, &rwork[1]) / rpvgrw;
}
/* Compute the reciprocal of the condition number of A. */
cgecon_(norm, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &rwork[1], info);
/* Compute the solution matrix X. */
clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
cgetrs_(trans, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx, info);
/* Use iterative refinement to improve the computed solution and */
/* compute error bounds and backward error estimates for it. */
cgerfs_(trans, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &ipiv[1], &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[ 1], &rwork[1], info);
/* Transform the solution matrix X to a solution of the original */
/* system. */
if (notran)
{
if (colequ)
{
i__1 = *nrhs;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
i__3 = i__ + j * x_dim1;
i__4 = i__;
i__5 = i__ + j * x_dim1;
q__1.r = c__[i__4] * x[i__5].r;
q__1.i = c__[i__4] * x[ i__5].i; // , expr subst
x[i__3].r = q__1.r;
x[i__3].i = q__1.i; // , expr subst
/* L70: */
}
/* L80: */
}
i__1 = *nrhs;
for (j = 1;
j <= i__1;
++j)
{
ferr[j] /= colcnd;
/* L90: */
}
}
}
else if (rowequ)
{
i__1 = *nrhs;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
i__3 = i__ + j * x_dim1;
i__4 = i__;
i__5 = i__ + j * x_dim1;
q__1.r = r__[i__4] * x[i__5].r;
q__1.i = r__[i__4] * x[i__5] .i; // , expr subst
x[i__3].r = q__1.r;
x[i__3].i = q__1.i; // , expr subst
/* L100: */
}
/* L110: */
}
i__1 = *nrhs;
for (j = 1;
j <= i__1;
++j)
{
ferr[j] /= rowcnd;
/* L120: */
}
}
/* Set INFO = N+1 if the matrix is singular to working precision. */
if (*rcond < slamch_("Epsilon"))
{
*info = *n + 1;
}
rwork[1] = rpvgrw;
return 0;
/* End of CGESVX */
}
