/* Subroutine */ int cgecon_(char *norm, integer *n, complex *a, integer *lda,
real *anorm, real *rcond, complex *work, real *rwork, integer *info,
ftnlen norm_len)
{
/* System generated locals */
integer a_dim1, a_offset, i__1;
real r__1, r__2;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static real sl;
static integer ix;
static real su;
static integer kase, kase1;
static real scale;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
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);
static real ainvnm;
extern /* Subroutine */ int clatrs_(char *, char *, char *, char *,
integer *, complex *, integer *, complex *, real *, real *,
integer *, ftnlen, ftnlen, ftnlen, ftnlen), csrscl_(integer *,
real *, complex *, integer *);
static logical onenrm;
static char normin[1];
static real smlnum;
/* -- 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 */
/* ======= */
/* CGECON estimates the reciprocal of the condition number of a general */
/* complex matrix A, in either the 1-norm or the infinity-norm, using */
/* the LU factorization computed by CGETRF. */
/* An estimate is obtained for norm(inv(A)), and 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. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The factors L and U from the factorization A = P*L*U */
/* as computed by CGETRF. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* ANORM (input) REAL */
/* If NORM = '1' or 'O', the 1-norm of the original matrix A. */
/* If NORM = 'I', the infinity-norm of the original matrix A. */
/* 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 (2*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 */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--work;
--rwork;
/* Function Body */
*info = 0;
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O", (ftnlen)1, (
ftnlen)1);
if (! onenrm && ! lsame_(norm, "I", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
} else if (*anorm < 0.f) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGECON", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
*rcond = 0.f;
if (*n == 0) {
*rcond = 1.f;
return 0;
} else if (*anorm == 0.f) {
return 0;
}
smlnum = slamch_("Safe minimum", (ftnlen)12);
/* Estimate the norm of inv(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(L). */
clatrs_("Lower", "No transpose", "Unit", normin, n, &a[a_offset],
lda, &work[1], &sl, &rwork[1], info, (ftnlen)5, (ftnlen)
12, (ftnlen)4, (ftnlen)1);
/* Multiply by inv(U). */
clatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[
a_offset], lda, &work[1], &su, &rwork[*n + 1], info, (
ftnlen)5, (ftnlen)12, (ftnlen)8, (ftnlen)1);
} else {
/* Multiply by inv(U'). */
clatrs_("Upper", "Conjugate transpose", "Non-unit", normin, n, &a[
a_offset], lda, &work[1], &su, &rwork[*n + 1], info, (
ftnlen)5, (ftnlen)19, (ftnlen)8, (ftnlen)1);
/* Multiply by inv(L'). */
clatrs_("Lower", "Conjugate transpose", "Unit", normin, n, &a[
a_offset], lda, &work[1], &sl, &rwork[1], info, (ftnlen)5,
(ftnlen)19, (ftnlen)4, (ftnlen)1);
}
/* Divide X by 1/(SL*SU) if doing so will not cause overflow. */
scale = sl * su;
*(unsigned char *)normin = 'Y';
if (scale != 1.f) {
ix = icamax_(n, &work[1], &c__1);
i__1 = ix;
if (scale < ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(&
work[ix]), dabs(r__2))) * 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 / ainvnm / *anorm;
}
L20:
return 0;
/* End of CGECON */
} /* cgecon_ */
/* Subroutine */ int ctrevc_(char *side, char *howmny, logical *select,
integer *n, complex *t, integer *ldt, complex *vl, integer *ldvl,
complex *vr, integer *ldvr, integer *mm, integer *m, complex *work,
real *rwork, integer *info)
{
/* System generated locals */
integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3, i__4, i__5;
real r__1, r__2, r__3;
complex q__1, q__2;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
integer i__, j, k, ii, ki, is;
real ulp;
logical allv;
real unfl, ovfl, smin;
logical over;
real scale;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *);
real remax;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *);
logical leftv, bothv, somev;
extern /* Subroutine */ int slabad_(real *, real *);
extern integer icamax_(integer *, complex *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), xerbla_(char *, integer *), clatrs_(char *, char *,
char *, char *, integer *, complex *, integer *, complex *, real *
, real *, integer *);
extern doublereal scasum_(integer *, complex *, integer *);
logical rightv;
real smlnum;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CTREVC computes some or all of the right and/or left eigenvectors of */
/* a complex upper triangular matrix T. */
/* Matrices of this type are produced by the Schur factorization of */
/* a complex general matrix: A = Q*T*Q**H, as computed by CHSEQR. */
/* The right eigenvector x and the left eigenvector y of T corresponding */
/* to an eigenvalue w are defined by: */
/* T*x = w*x, (y**H)*T = w*(y**H) */
/* where y**H denotes the conjugate transpose of the vector y. */
/* The eigenvalues are not input to this routine, but are read directly */
/* from the diagonal of T. */
/* This routine returns the matrices X and/or Y of right and left */
/* eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an */
/* input matrix. If Q is the unitary factor that reduces a matrix A to */
/* Schur form T, then Q*X and Q*Y are the matrices of right and left */
/* eigenvectors of A. */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* = 'R': compute right eigenvectors only; */
/* = 'L': compute left eigenvectors only; */
/* = 'B': compute both right and left eigenvectors. */
/* HOWMNY (input) CHARACTER*1 */
/* = 'A': compute all right and/or left eigenvectors; */
/* = 'B': compute all right and/or left eigenvectors, */
/* backtransformed using the matrices supplied in */
/* VR and/or VL; */
/* = 'S': compute selected right and/or left eigenvectors, */
/* as indicated by the logical array SELECT. */
/* SELECT (input) LOGICAL array, dimension (N) */
/* If HOWMNY = 'S', SELECT specifies the eigenvectors to be */
/* computed. */
/* The eigenvector corresponding to the j-th eigenvalue is */
/* computed if SELECT(j) = .TRUE.. */
/* Not referenced if HOWMNY = 'A' or 'B'. */
/* N (input) INTEGER */
/* The order of the matrix T. N >= 0. */
/* T (input/output) COMPLEX array, dimension (LDT,N) */
/* The upper triangular matrix T. T is modified, but restored */
/* on exit. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= max(1,N). */
/* VL (input/output) COMPLEX array, dimension (LDVL,MM) */
/* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */
/* contain an N-by-N matrix Q (usually the unitary matrix Q of */
/* Schur vectors returned by CHSEQR). */
/* On exit, if SIDE = 'L' or 'B', VL contains: */
/* if HOWMNY = 'A', the matrix Y of left eigenvectors of T; */
/* if HOWMNY = 'B', the matrix Q*Y; */
/* if HOWMNY = 'S', the left eigenvectors of T specified by */
/* SELECT, stored consecutively in the columns */
/* of VL, in the same order as their */
/* eigenvalues. */
/* Not referenced if SIDE = 'R'. */
/* LDVL (input) INTEGER */
/* The leading dimension of the array VL. LDVL >= 1, and if */
/* SIDE = 'L' or 'B', LDVL >= N. */
/* VR (input/output) COMPLEX array, dimension (LDVR,MM) */
/* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */
/* contain an N-by-N matrix Q (usually the unitary matrix Q of */
/* Schur vectors returned by CHSEQR). */
/* On exit, if SIDE = 'R' or 'B', VR contains: */
/* if HOWMNY = 'A', the matrix X of right eigenvectors of T; */
/* if HOWMNY = 'B', the matrix Q*X; */
/* if HOWMNY = 'S', the right eigenvectors of T specified by */
/* SELECT, stored consecutively in the columns */
/* of VR, in the same order as their */
/* eigenvalues. */
/* Not referenced if SIDE = 'L'. */
/* LDVR (input) INTEGER */
/* The leading dimension of the array VR. LDVR >= 1, and if */
/* SIDE = 'R' or 'B'; LDVR >= N. */
/* MM (input) INTEGER */
/* The number of columns in the arrays VL and/or VR. MM >= M. */
/* M (output) INTEGER */
/* The number of columns in the arrays VL and/or VR actually */
/* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M */
/* is set to N. Each selected eigenvector occupies one */
/* column. */
/* 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 */
/* Further Details */
/* =============== */
/* The algorithm used in this program is basically backward (forward) */
/* substitution, with scaling to make the the code robust against */
/* possible overflow. */
/* Each eigenvector is normalized so that the element of largest */
/* magnitude has magnitude 1; here the magnitude of a complex number */
/* (x,y) is taken to be |x| + |y|. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and test the input parameters */
/* Parameter adjustments */
--select;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--work;
--rwork;
/* Function Body */
bothv = lsame_(side, "B");
rightv = lsame_(side, "R") || bothv;
leftv = lsame_(side, "L") || bothv;
allv = lsame_(howmny, "A");
over = lsame_(howmny, "B");
somev = lsame_(howmny, "S");
/* Set M to the number of columns required to store the selected */
/* eigenvectors. */
if (somev) {
*m = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (select[j]) {
++(*m);
}
/* L10: */
}
} else {
*m = *n;
}
*info = 0;
if (! rightv && ! leftv) {
*info = -1;
} else if (! allv && ! over && ! somev) {
*info = -2;
} else if (*n < 0) {
*info = -4;
} else if (*ldt < max(1,*n)) {
*info = -6;
} else if (*ldvl < 1 || leftv && *ldvl < *n) {
*info = -8;
} else if (*ldvr < 1 || rightv && *ldvr < *n) {
*info = -10;
} else if (*mm < *m) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTREVC", &i__1);
return 0;
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
/* Set the constants to control overflow. */
unfl = slamch_("Safe minimum");
ovfl = 1.f / unfl;
slabad_(&unfl, &ovfl);
ulp = slamch_("Precision");
smlnum = unfl * (*n / ulp);
/* Store the diagonal elements of T in working array WORK. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + *n;
i__3 = i__ + i__ * t_dim1;
work[i__2].r = t[i__3].r, work[i__2].i = t[i__3].i;
/* L20: */
}
/* Compute 1-norm of each column of strictly upper triangular */
/* part of T to control overflow in triangular solver. */
rwork[1] = 0.f;
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
i__2 = j - 1;
rwork[j] = scasum_(&i__2, &t[j * t_dim1 + 1], &c__1);
/* L30: */
}
if (rightv) {
/* Compute right eigenvectors. */
is = *m;
for (ki = *n; ki >= 1; --ki) {
if (somev) {
if (! select[ki]) {
goto L80;
}
}
/* Computing MAX */
i__1 = ki + ki * t_dim1;
r__3 = ulp * ((r__1 = t[i__1].r, dabs(r__1)) + (r__2 = r_imag(&t[
ki + ki * t_dim1]), dabs(r__2)));
smin = dmax(r__3,smlnum);
work[1].r = 1.f, work[1].i = 0.f;
/* Form right-hand side. */
i__1 = ki - 1;
for (k = 1; k <= i__1; ++k) {
i__2 = k;
i__3 = k + ki * t_dim1;
q__1.r = -t[i__3].r, q__1.i = -t[i__3].i;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L40: */
}
/* Solve the triangular system: */
/* (T(1:KI-1,1:KI-1) - T(KI,KI))*X = SCALE*WORK. */
i__1 = ki - 1;
for (k = 1; k <= i__1; ++k) {
i__2 = k + k * t_dim1;
i__3 = k + k * t_dim1;
i__4 = ki + ki * t_dim1;
q__1.r = t[i__3].r - t[i__4].r, q__1.i = t[i__3].i - t[i__4]
.i;
t[i__2].r = q__1.r, t[i__2].i = q__1.i;
i__2 = k + k * t_dim1;
if ((r__1 = t[i__2].r, dabs(r__1)) + (r__2 = r_imag(&t[k + k *
t_dim1]), dabs(r__2)) < smin) {
i__3 = k + k * t_dim1;
t[i__3].r = smin, t[i__3].i = 0.f;
}
/* L50: */
}
if (ki > 1) {
i__1 = ki - 1;
clatrs_("Upper", "No transpose", "Non-unit", "Y", &i__1, &t[
t_offset], ldt, &work[1], &scale, &rwork[1], info);
i__1 = ki;
work[i__1].r = scale, work[i__1].i = 0.f;
}
/* Copy the vector x or Q*x to VR and normalize. */
if (! over) {
ccopy_(&ki, &work[1], &c__1, &vr[is * vr_dim1 + 1], &c__1);
ii = icamax_(&ki, &vr[is * vr_dim1 + 1], &c__1);
i__1 = ii + is * vr_dim1;
remax = 1.f / ((r__1 = vr[i__1].r, dabs(r__1)) + (r__2 =
r_imag(&vr[ii + is * vr_dim1]), dabs(r__2)));
csscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1);
i__1 = *n;
for (k = ki + 1; k <= i__1; ++k) {
i__2 = k + is * vr_dim1;
vr[i__2].r = 0.f, vr[i__2].i = 0.f;
/* L60: */
}
} else {
if (ki > 1) {
i__1 = ki - 1;
q__1.r = scale, q__1.i = 0.f;
cgemv_("N", n, &i__1, &c_b2, &vr[vr_offset], ldvr, &work[
1], &c__1, &q__1, &vr[ki * vr_dim1 + 1], &c__1);
}
ii = icamax_(n, &vr[ki * vr_dim1 + 1], &c__1);
i__1 = ii + ki * vr_dim1;
remax = 1.f / ((r__1 = vr[i__1].r, dabs(r__1)) + (r__2 =
r_imag(&vr[ii + ki * vr_dim1]), dabs(r__2)));
csscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1);
}
/* Set back the original diagonal elements of T. */
i__1 = ki - 1;
for (k = 1; k <= i__1; ++k) {
i__2 = k + k * t_dim1;
i__3 = k + *n;
t[i__2].r = work[i__3].r, t[i__2].i = work[i__3].i;
/* L70: */
}
--is;
L80:
;
}
}
if (leftv) {
/* Compute left eigenvectors. */
is = 1;
i__1 = *n;
for (ki = 1; ki <= i__1; ++ki) {
if (somev) {
if (! select[ki]) {
goto L130;
}
}
/* Computing MAX */
i__2 = ki + ki * t_dim1;
r__3 = ulp * ((r__1 = t[i__2].r, dabs(r__1)) + (r__2 = r_imag(&t[
ki + ki * t_dim1]), dabs(r__2)));
smin = dmax(r__3,smlnum);
i__2 = *n;
work[i__2].r = 1.f, work[i__2].i = 0.f;
/* Form right-hand side. */
i__2 = *n;
for (k = ki + 1; k <= i__2; ++k) {
i__3 = k;
r_cnjg(&q__2, &t[ki + k * t_dim1]);
q__1.r = -q__2.r, q__1.i = -q__2.i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L90: */
}
/* Solve the triangular system: */
/* (T(KI+1:N,KI+1:N) - T(KI,KI))'*X = SCALE*WORK. */
i__2 = *n;
for (k = ki + 1; k <= i__2; ++k) {
i__3 = k + k * t_dim1;
i__4 = k + k * t_dim1;
i__5 = ki + ki * t_dim1;
q__1.r = t[i__4].r - t[i__5].r, q__1.i = t[i__4].i - t[i__5]
.i;
t[i__3].r = q__1.r, t[i__3].i = q__1.i;
i__3 = k + k * t_dim1;
if ((r__1 = t[i__3].r, dabs(r__1)) + (r__2 = r_imag(&t[k + k *
t_dim1]), dabs(r__2)) < smin) {
i__4 = k + k * t_dim1;
t[i__4].r = smin, t[i__4].i = 0.f;
}
/* L100: */
}
if (ki < *n) {
i__2 = *n - ki;
clatrs_("Upper", "Conjugate transpose", "Non-unit", "Y", &
i__2, &t[ki + 1 + (ki + 1) * t_dim1], ldt, &work[ki +
1], &scale, &rwork[1], info);
i__2 = ki;
work[i__2].r = scale, work[i__2].i = 0.f;
}
/* Copy the vector x or Q*x to VL and normalize. */
if (! over) {
i__2 = *n - ki + 1;
ccopy_(&i__2, &work[ki], &c__1, &vl[ki + is * vl_dim1], &c__1)
;
i__2 = *n - ki + 1;
ii = icamax_(&i__2, &vl[ki + is * vl_dim1], &c__1) + ki - 1;
i__2 = ii + is * vl_dim1;
remax = 1.f / ((r__1 = vl[i__2].r, dabs(r__1)) + (r__2 =
r_imag(&vl[ii + is * vl_dim1]), dabs(r__2)));
i__2 = *n - ki + 1;
csscal_(&i__2, &remax, &vl[ki + is * vl_dim1], &c__1);
i__2 = ki - 1;
for (k = 1; k <= i__2; ++k) {
i__3 = k + is * vl_dim1;
vl[i__3].r = 0.f, vl[i__3].i = 0.f;
/* L110: */
}
} else {
if (ki < *n) {
i__2 = *n - ki;
q__1.r = scale, q__1.i = 0.f;
cgemv_("N", n, &i__2, &c_b2, &vl[(ki + 1) * vl_dim1 + 1],
ldvl, &work[ki + 1], &c__1, &q__1, &vl[ki *
vl_dim1 + 1], &c__1);
}
ii = icamax_(n, &vl[ki * vl_dim1 + 1], &c__1);
i__2 = ii + ki * vl_dim1;
remax = 1.f / ((r__1 = vl[i__2].r, dabs(r__1)) + (r__2 =
r_imag(&vl[ii + ki * vl_dim1]), dabs(r__2)));
csscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1);
}
/* Set back the original diagonal elements of T. */
i__2 = *n;
for (k = ki + 1; k <= i__2; ++k) {
i__3 = k + k * t_dim1;
i__4 = k + *n;
t[i__3].r = work[i__4].r, t[i__3].i = work[i__4].i;
/* L120: */
}
++is;
L130:
;
}
}
return 0;
/* End of CTREVC */
} /* ctrevc_ */
/* Subroutine */ int claein_(logical *rightv, logical *noinit, integer *n,
complex *h__, integer *ldh, complex *w, complex *v, complex *b,
integer *ldb, real *rwork, real *eps3, real *smlnum, integer *info)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CLAEIN uses inverse iteration to find a right or left eigenvector
corresponding to the eigenvalue W of a complex upper Hessenberg
matrix H.
Arguments
=========
RIGHTV (input) LOGICAL
= .TRUE. : compute right eigenvector;
= .FALSE.: compute left eigenvector.
NOINIT (input) LOGICAL
= .TRUE. : no initial vector supplied in V
= .FALSE.: initial vector supplied in V.
N (input) INTEGER
The order of the matrix H. N >= 0.
H (input) COMPLEX array, dimension (LDH,N)
The upper Hessenberg matrix H.
LDH (input) INTEGER
The leading dimension of the array H. LDH >= max(1,N).
W (input) COMPLEX
The eigenvalue of H whose corresponding right or left
eigenvector is to be computed.
V (input/output) COMPLEX array, dimension (N)
On entry, if NOINIT = .FALSE., V must contain a starting
vector for inverse iteration; otherwise V need not be set.
On exit, V contains the computed eigenvector, normalized so
that the component of largest magnitude has magnitude 1; here
the magnitude of a complex number (x,y) is taken to be
|x| + |y|.
B (workspace) COMPLEX array, dimension (LDB,N)
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
RWORK (workspace) REAL array, dimension (N)
EPS3 (input) REAL
A small machine-dependent value which is used to perturb
close eigenvalues, and to replace zero pivots.
SMLNUM (input) REAL
A machine-dependent value close to the underflow threshold.
INFO (output) INTEGER
= 0: successful exit
= 1: inverse iteration did not converge; V is set to the
last iterate.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer b_dim1, b_offset, h_dim1, h_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
complex q__1, q__2;
/* Builtin functions */
double sqrt(doublereal), r_imag(complex *);
/* Local variables */
static integer ierr;
static complex temp;
static integer i__, j;
static real scale;
static complex x;
static char trans[1];
static real rtemp, rootn, vnorm;
extern doublereal scnrm2_(integer *, complex *, integer *);
static complex ei, ej;
extern integer icamax_(integer *, complex *, integer *);
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), clatrs_(char *, char *, char *, char *, integer *, complex *,
integer *, complex *, real *, real *, integer *);
extern doublereal scasum_(integer *, complex *, integer *);
static char normin[1];
static real nrmsml, growto;
static integer its;
#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 h___subscr(a_1,a_2) (a_2)*h_dim1 + a_1
#define h___ref(a_1,a_2) h__[h___subscr(a_1,a_2)]
h_dim1 = *ldh;
h_offset = 1 + h_dim1 * 1;
h__ -= h_offset;
--v;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--rwork;
/* Function Body */
*info = 0;
/* GROWTO is the threshold used in the acceptance test for an
eigenvector. */
rootn = sqrt((real) (*n));
growto = .1f / rootn;
/* Computing MAX */
r__1 = 1.f, r__2 = *eps3 * rootn;
nrmsml = dmax(r__1,r__2) * *smlnum;
/* Form B = H - W*I (except that the subdiagonal elements are not
stored). */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = h___subscr(i__, j);
b[i__3].r = h__[i__4].r, b[i__3].i = h__[i__4].i;
/* L10: */
}
i__2 = b_subscr(j, j);
i__3 = h___subscr(j, j);
q__1.r = h__[i__3].r - w->r, q__1.i = h__[i__3].i - w->i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L20: */
}
if (*noinit) {
/* Initialize V. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
v[i__2].r = *eps3, v[i__2].i = 0.f;
/* L30: */
}
} else {
/* Scale supplied initial vector. */
vnorm = scnrm2_(n, &v[1], &c__1);
r__1 = *eps3 * rootn / dmax(vnorm,nrmsml);
csscal_(n, &r__1, &v[1], &c__1);
}
if (*rightv) {
/* LU decomposition with partial pivoting of B, replacing zero
pivots by EPS3. */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = h___subscr(i__ + 1, i__);
ei.r = h__[i__2].r, ei.i = h__[i__2].i;
i__2 = b_subscr(i__, i__);
if ((r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(i__,
i__)), dabs(r__2)) < (r__3 = ei.r, dabs(r__3)) + (r__4 =
r_imag(&ei), dabs(r__4))) {
/* Interchange rows and eliminate. */
cladiv_(&q__1, &b_ref(i__, i__), &ei);
x.r = q__1.r, x.i = q__1.i;
i__2 = b_subscr(i__, i__);
b[i__2].r = ei.r, b[i__2].i = ei.i;
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = b_subscr(i__ + 1, j);
temp.r = b[i__3].r, temp.i = b[i__3].i;
i__3 = b_subscr(i__ + 1, j);
i__4 = b_subscr(i__, j);
q__2.r = x.r * temp.r - x.i * temp.i, q__2.i = x.r *
temp.i + x.i * temp.r;
q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i - q__2.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
i__3 = b_subscr(i__, j);
b[i__3].r = temp.r, b[i__3].i = temp.i;
/* L40: */
}
} else {
/* Eliminate without interchange. */
i__2 = b_subscr(i__, i__);
if (b[i__2].r == 0.f && b[i__2].i == 0.f) {
i__3 = b_subscr(i__, i__);
b[i__3].r = *eps3, b[i__3].i = 0.f;
}
cladiv_(&q__1, &ei, &b_ref(i__, i__));
x.r = q__1.r, x.i = q__1.i;
if (x.r != 0.f || x.i != 0.f) {
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = b_subscr(i__ + 1, j);
i__4 = b_subscr(i__ + 1, j);
i__5 = b_subscr(i__, j);
q__2.r = x.r * b[i__5].r - x.i * b[i__5].i, q__2.i =
x.r * b[i__5].i + x.i * b[i__5].r;
q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i -
q__2.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L50: */
}
}
}
/* L60: */
}
i__1 = b_subscr(*n, *n);
if (b[i__1].r == 0.f && b[i__1].i == 0.f) {
i__2 = b_subscr(*n, *n);
b[i__2].r = *eps3, b[i__2].i = 0.f;
}
*(unsigned char *)trans = 'N';
} else {
/* UL decomposition with partial pivoting of B, replacing zero
pivots by EPS3. */
for (j = *n; j >= 2; --j) {
i__1 = h___subscr(j, j - 1);
ej.r = h__[i__1].r, ej.i = h__[i__1].i;
i__1 = b_subscr(j, j);
if ((r__1 = b[i__1].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(j, j)),
dabs(r__2)) < (r__3 = ej.r, dabs(r__3)) + (r__4 = r_imag(
&ej), dabs(r__4))) {
/* Interchange columns and eliminate. */
cladiv_(&q__1, &b_ref(j, j), &ej);
x.r = q__1.r, x.i = q__1.i;
i__1 = b_subscr(j, j);
b[i__1].r = ej.r, b[i__1].i = ej.i;
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = b_subscr(i__, j - 1);
temp.r = b[i__2].r, temp.i = b[i__2].i;
i__2 = b_subscr(i__, j - 1);
i__3 = b_subscr(i__, j);
q__2.r = x.r * temp.r - x.i * temp.i, q__2.i = x.r *
temp.i + x.i * temp.r;
q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = b_subscr(i__, j);
b[i__2].r = temp.r, b[i__2].i = temp.i;
/* L70: */
}
} else {
/* Eliminate without interchange. */
i__1 = b_subscr(j, j);
if (b[i__1].r == 0.f && b[i__1].i == 0.f) {
i__2 = b_subscr(j, j);
b[i__2].r = *eps3, b[i__2].i = 0.f;
}
cladiv_(&q__1, &ej, &b_ref(j, j));
x.r = q__1.r, x.i = q__1.i;
if (x.r != 0.f || x.i != 0.f) {
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = b_subscr(i__, j - 1);
i__3 = b_subscr(i__, j - 1);
i__4 = b_subscr(i__, j);
q__2.r = x.r * b[i__4].r - x.i * b[i__4].i, q__2.i =
x.r * b[i__4].i + x.i * b[i__4].r;
q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i -
q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L80: */
}
}
}
/* L90: */
}
i__1 = b_subscr(1, 1);
if (b[i__1].r == 0.f && b[i__1].i == 0.f) {
i__2 = b_subscr(1, 1);
b[i__2].r = *eps3, b[i__2].i = 0.f;
}
*(unsigned char *)trans = 'C';
}
*(unsigned char *)normin = 'N';
i__1 = *n;
for (its = 1; its <= i__1; ++its) {
/* Solve U*x = scale*v for a right eigenvector
or U'*x = scale*v for a left eigenvector,
overwriting x on v. */
clatrs_("Upper", trans, "Nonunit", normin, n, &b[b_offset], ldb, &v[1]
, &scale, &rwork[1], &ierr);
*(unsigned char *)normin = 'Y';
/* Test for sufficient growth in the norm of v. */
vnorm = scasum_(n, &v[1], &c__1);
if (vnorm >= growto * scale) {
goto L120;
}
/* Choose new orthogonal starting vector and try again. */
rtemp = *eps3 / (rootn + 1.f);
v[1].r = *eps3, v[1].i = 0.f;
i__2 = *n;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = i__;
v[i__3].r = rtemp, v[i__3].i = 0.f;
/* L100: */
}
i__2 = *n - its + 1;
i__3 = *n - its + 1;
r__1 = *eps3 * rootn;
q__1.r = v[i__3].r - r__1, q__1.i = v[i__3].i;
v[i__2].r = q__1.r, v[i__2].i = q__1.i;
/* L110: */
}
/* Failure to find eigenvector in N iterations. */
*info = 1;
L120:
/* Normalize eigenvector. */
i__ = icamax_(n, &v[1], &c__1);
i__1 = i__;
r__3 = 1.f / ((r__1 = v[i__1].r, dabs(r__1)) + (r__2 = r_imag(&v[i__]),
dabs(r__2)));
csscal_(n, &r__3, &v[1], &c__1);
return 0;
/* End of CLAEIN */
} /* claein_ */
/* Subroutine */ int ctrcon_(char *norm, char *uplo, char *diag, integer *n,
complex *a, integer *lda, real *rcond, complex *work, real *rwork,
integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
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
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1;
real r__1, r__2;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static integer kase, kase1;
static real scale;
extern logical lsame_(char *, char *);
static real anorm;
static logical upper;
static real xnorm;
extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real
*, integer *);
static integer ix;
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 *);
static real ainvnm;
extern /* Subroutine */ int clatrs_(char *, char *, char *, char *,
integer *, complex *, integer *, complex *, real *, real *,
integer *), csrscl_(integer *,
real *, complex *, integer *);
static logical onenrm;
static char normin[1];
static real smlnum;
static logical nounit;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
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:
clacon_(n, &work[*n + 1], &work[1], &ainvnm, &kase);
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_ */
int claein_(int *rightv, int *noinit, int *n,
complex *h__, int *ldh, complex *w, complex *v, complex *b,
int *ldb, float *rwork, float *eps3, float *smlnum, int *info)
{
/* System generated locals */
int b_dim1, b_offset, h_dim1, h_offset, i__1, i__2, i__3, i__4, i__5;
float r__1, r__2, r__3, r__4;
complex q__1, q__2;
/* Builtin functions */
double sqrt(double), r_imag(complex *);
/* Local variables */
int i__, j;
complex x, ei, ej;
int its, ierr;
complex temp;
float scale;
char trans[1];
float rtemp, rootn, vnorm;
extern double scnrm2_(int *, complex *, int *);
extern int icamax_(int *, complex *, int *);
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
extern int csscal_(int *, float *, complex *, int
*), clatrs_(char *, char *, char *, char *, int *, complex *,
int *, complex *, float *, float *, int *);
extern double scasum_(int *, complex *, int *);
char normin[1];
float nrmsml, growto;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLAEIN uses inverse iteration to find a right or left eigenvector */
/* corresponding to the eigenvalue W of a complex upper Hessenberg */
/* matrix H. */
/* Arguments */
/* ========= */
/* RIGHTV (input) LOGICAL */
/* = .TRUE. : compute right eigenvector; */
/* = .FALSE.: compute left eigenvector. */
/* NOINIT (input) LOGICAL */
/* = .TRUE. : no initial vector supplied in V */
/* = .FALSE.: initial vector supplied in V. */
/* N (input) INTEGER */
/* The order of the matrix H. N >= 0. */
/* H (input) COMPLEX array, dimension (LDH,N) */
/* The upper Hessenberg matrix H. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH >= MAX(1,N). */
/* W (input) COMPLEX */
/* The eigenvalue of H whose corresponding right or left */
/* eigenvector is to be computed. */
/* V (input/output) COMPLEX array, dimension (N) */
/* On entry, if NOINIT = .FALSE., V must contain a starting */
/* vector for inverse iteration; otherwise V need not be set. */
/* On exit, V contains the computed eigenvector, normalized so */
/* that the component of largest magnitude has magnitude 1; here */
/* the magnitude of a complex number (x,y) is taken to be */
/* |x| + |y|. */
/* B (workspace) COMPLEX array, dimension (LDB,N) */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= MAX(1,N). */
/* RWORK (workspace) REAL array, dimension (N) */
/* EPS3 (input) REAL */
/* A small machine-dependent value which is used to perturb */
/* close eigenvalues, and to replace zero pivots. */
/* SMLNUM (input) REAL */
/* A machine-dependent value close to the underflow threshold. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* = 1: inverse iteration did not converge; V is set to the */
/* last iterate. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--v;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--rwork;
/* Function Body */
*info = 0;
/* GROWTO is the threshold used in the acceptance test for an */
/* eigenvector. */
rootn = sqrt((float) (*n));
growto = .1f / rootn;
/* Computing MAX */
r__1 = 1.f, r__2 = *eps3 * rootn;
nrmsml = MAX(r__1,r__2) * *smlnum;
/* Form B = H - W*I (except that the subdiagonal elements are not */
/* stored). */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * b_dim1;
i__4 = i__ + j * h_dim1;
b[i__3].r = h__[i__4].r, b[i__3].i = h__[i__4].i;
/* L10: */
}
i__2 = j + j * b_dim1;
i__3 = j + j * h_dim1;
q__1.r = h__[i__3].r - w->r, q__1.i = h__[i__3].i - w->i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L20: */
}
if (*noinit) {
/* Initialize V. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
v[i__2].r = *eps3, v[i__2].i = 0.f;
/* L30: */
}
} else {
/* Scale supplied initial vector. */
vnorm = scnrm2_(n, &v[1], &c__1);
r__1 = *eps3 * rootn / MAX(vnorm,nrmsml);
csscal_(n, &r__1, &v[1], &c__1);
}
if (*rightv) {
/* LU decomposition with partial pivoting of B, replacing zero */
/* pivots by EPS3. */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + 1 + i__ * h_dim1;
ei.r = h__[i__2].r, ei.i = h__[i__2].i;
i__2 = i__ + i__ * b_dim1;
if ((r__1 = b[i__2].r, ABS(r__1)) + (r__2 = r_imag(&b[i__ + i__ *
b_dim1]), ABS(r__2)) < (r__3 = ei.r, ABS(r__3)) + (
r__4 = r_imag(&ei), ABS(r__4))) {
/* Interchange rows and eliminate. */
cladiv_(&q__1, &b[i__ + i__ * b_dim1], &ei);
x.r = q__1.r, x.i = q__1.i;
i__2 = i__ + i__ * b_dim1;
b[i__2].r = ei.r, b[i__2].i = ei.i;
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = i__ + 1 + j * b_dim1;
temp.r = b[i__3].r, temp.i = b[i__3].i;
i__3 = i__ + 1 + j * b_dim1;
i__4 = i__ + j * b_dim1;
q__2.r = x.r * temp.r - x.i * temp.i, q__2.i = x.r *
temp.i + x.i * temp.r;
q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i - q__2.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
i__3 = i__ + j * b_dim1;
b[i__3].r = temp.r, b[i__3].i = temp.i;
/* L40: */
}
} else {
/* Eliminate without interchange. */
i__2 = i__ + i__ * b_dim1;
if (b[i__2].r == 0.f && b[i__2].i == 0.f) {
i__3 = i__ + i__ * b_dim1;
b[i__3].r = *eps3, b[i__3].i = 0.f;
}
cladiv_(&q__1, &ei, &b[i__ + i__ * b_dim1]);
x.r = q__1.r, x.i = q__1.i;
if (x.r != 0.f || x.i != 0.f) {
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = i__ + 1 + j * b_dim1;
i__4 = i__ + 1 + j * b_dim1;
i__5 = i__ + j * b_dim1;
q__2.r = x.r * b[i__5].r - x.i * b[i__5].i, q__2.i =
x.r * b[i__5].i + x.i * b[i__5].r;
q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i -
q__2.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L50: */
}
}
}
/* L60: */
}
i__1 = *n + *n * b_dim1;
if (b[i__1].r == 0.f && b[i__1].i == 0.f) {
i__2 = *n + *n * b_dim1;
b[i__2].r = *eps3, b[i__2].i = 0.f;
}
*(unsigned char *)trans = 'N';
} else {
/* UL decomposition with partial pivoting of B, replacing zero */
/* pivots by EPS3. */
for (j = *n; j >= 2; --j) {
i__1 = j + (j - 1) * h_dim1;
ej.r = h__[i__1].r, ej.i = h__[i__1].i;
i__1 = j + j * b_dim1;
if ((r__1 = b[i__1].r, ABS(r__1)) + (r__2 = r_imag(&b[j + j *
b_dim1]), ABS(r__2)) < (r__3 = ej.r, ABS(r__3)) + (r__4
= r_imag(&ej), ABS(r__4))) {
/* Interchange columns and eliminate. */
cladiv_(&q__1, &b[j + j * b_dim1], &ej);
x.r = q__1.r, x.i = q__1.i;
i__1 = j + j * b_dim1;
b[i__1].r = ej.r, b[i__1].i = ej.i;
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + (j - 1) * b_dim1;
temp.r = b[i__2].r, temp.i = b[i__2].i;
i__2 = i__ + (j - 1) * b_dim1;
i__3 = i__ + j * b_dim1;
q__2.r = x.r * temp.r - x.i * temp.i, q__2.i = x.r *
temp.i + x.i * temp.r;
q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = i__ + j * b_dim1;
b[i__2].r = temp.r, b[i__2].i = temp.i;
/* L70: */
}
} else {
/* Eliminate without interchange. */
i__1 = j + j * b_dim1;
if (b[i__1].r == 0.f && b[i__1].i == 0.f) {
i__2 = j + j * b_dim1;
b[i__2].r = *eps3, b[i__2].i = 0.f;
}
cladiv_(&q__1, &ej, &b[j + j * b_dim1]);
x.r = q__1.r, x.i = q__1.i;
if (x.r != 0.f || x.i != 0.f) {
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + (j - 1) * b_dim1;
i__3 = i__ + (j - 1) * b_dim1;
i__4 = i__ + j * b_dim1;
q__2.r = x.r * b[i__4].r - x.i * b[i__4].i, q__2.i =
x.r * b[i__4].i + x.i * b[i__4].r;
q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i -
q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L80: */
}
}
}
/* L90: */
}
i__1 = b_dim1 + 1;
if (b[i__1].r == 0.f && b[i__1].i == 0.f) {
i__2 = b_dim1 + 1;
b[i__2].r = *eps3, b[i__2].i = 0.f;
}
*(unsigned char *)trans = 'C';
}
*(unsigned char *)normin = 'N';
i__1 = *n;
for (its = 1; its <= i__1; ++its) {
/* Solve U*x = scale*v for a right eigenvector */
/* or U'*x = scale*v for a left eigenvector, */
/* overwriting x on v. */
clatrs_("Upper", trans, "Nonunit", normin, n, &b[b_offset], ldb, &v[1]
, &scale, &rwork[1], &ierr);
*(unsigned char *)normin = 'Y';
/* Test for sufficient growth in the norm of v. */
vnorm = scasum_(n, &v[1], &c__1);
if (vnorm >= growto * scale) {
goto L120;
}
/* Choose new orthogonal starting vector and try again. */
rtemp = *eps3 / (rootn + 1.f);
v[1].r = *eps3, v[1].i = 0.f;
i__2 = *n;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = i__;
v[i__3].r = rtemp, v[i__3].i = 0.f;
/* L100: */
}
i__2 = *n - its + 1;
i__3 = *n - its + 1;
r__1 = *eps3 * rootn;
q__1.r = v[i__3].r - r__1, q__1.i = v[i__3].i;
v[i__2].r = q__1.r, v[i__2].i = q__1.i;
/* L110: */
}
/* Failure to find eigenvector in N iterations. */
*info = 1;
L120:
/* Normalize eigenvector. */
i__ = icamax_(n, &v[1], &c__1);
i__1 = i__;
r__3 = 1.f / ((r__1 = v[i__1].r, ABS(r__1)) + (r__2 = r_imag(&v[i__]),
ABS(r__2)));
csscal_(n, &r__3, &v[1], &c__1);
return 0;
/* End of CLAEIN */
} /* claein_ */
/* Subroutine */ int cchktr_(logical *dotype, integer *nn, integer *nval,
integer *nnb, integer *nbval, integer *nns, integer *nsval, real *
thresh, logical *tsterr, integer *nmax, complex *a, complex *ainv,
complex *b, complex *x, complex *xact, complex *work, real *rwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
static char transs[1*3] = "N" "T" "C";
/* Format strings */
static char fmt_9999[] = "(\002 UPLO='\002,a1,\002', DIAG='\002,a1,\002'"
", N=\002,i5,\002, NB=\002,i4,\002, type \002,i2,\002, test(\002,"
"i2,\002)= \002,g12.5)";
static char fmt_9998[] = "(\002 UPLO='\002,a1,\002', TRANS='\002,a1,\002"
"', DIAG='\002,a1,\002', N=\002,i5,\002, NB=\002,i4,\002, type"
" \002,i2,\002, test(\002,i2,\002)= \002,g12"
".5)";
static char fmt_9997[] = "(\002 NORM='\002,a1,\002', UPLO ='\002,a1,\002"
"', N=\002,i5,\002,\002,11x,\002 type \002,i2,\002, test(\002,i2"
",\002)=\002,g12.5)";
static char fmt_9996[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', "
"'\002,a1,\002', '\002,a1,\002',\002,i5,\002, ... ), type \002,i2,"
"\002, test(\002,i2,\002)=\002,g12.5)";
/* System generated locals */
address a__1[2], a__2[3], a__3[4];
integer i__1, i__2, i__3[2], i__4, i__5[3], i__6[4];
char ch__1[2], ch__2[3], ch__3[4];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
char **, integer *, integer *, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, k, n, nb, in, lda, inb;
char diag[1];
integer imat, info;
char path[3];
integer irhs, nrhs;
char norm[1], uplo[1];
integer nrun;
extern /* Subroutine */ int alahd_(integer *, char *);
integer idiag;
extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
integer *, complex *, integer *, real *, real *);
real scale;
integer nfail, iseed[4];
extern logical lsame_(char *, char *);
real rcond, anorm;
integer itran;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), ctrt01_(char *, char *, integer *, complex
*, integer *, complex *, integer *, real *, real *, real *), ctrt02_(char *, char *, char *, integer *,
integer *, complex *, integer *, complex *, integer *, complex *,
integer *, complex *, real *, real *),
ctrt03_(char *, char *, char *, integer *, integer *, complex *,
integer *, real *, real *, real *, complex *, integer *, complex *
, integer *, complex *, real *), ctrt05_(
char *, char *, char *, integer *, integer *, complex *, integer *
, complex *, integer *, complex *, integer *, complex *, integer *
, real *, real *, real *), ctrt06_(real *,
real *, char *, char *, integer *, complex *, integer *, real *,
real *);
char trans[1];
integer iuplo, nerrs;
real dummy;
char xtype[1];
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
real rcondc;
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), clarhs_(char *, char
*, char *, char *, integer *, integer *, integer *, integer *,
integer *, complex *, integer *, complex *, integer *, complex *,
integer *, integer *, integer *);
real rcondi;
extern doublereal clantr_(char *, char *, char *, integer *, integer *,
complex *, integer *, real *);
real rcondo;
extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
*, integer *);
real ainvnm;
extern /* Subroutine */ int clatrs_(char *, char *, char *, char *,
integer *, complex *, integer *, complex *, real *, real *,
integer *), clattr_(integer *,
char *, char *, char *, integer *, integer *, complex *, integer *
, complex *, complex *, real *, integer *)
, ctrcon_(char *, char *, char *, integer *, complex *, integer *,
real *, complex *, real *, integer *),
xlaenv_(integer *, integer *), cerrtr_(char *, integer *),
ctrrfs_(char *, char *, char *, integer *, integer *, complex *,
integer *, complex *, integer *, complex *, integer *, real *,
real *, complex *, real *, integer *),
ctrtri_(char *, char *, integer *, complex *, integer *, integer *
);
real result[9];
extern /* Subroutine */ int ctrtrs_(char *, char *, char *, integer *,
integer *, complex *, integer *, complex *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___27 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9996, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CCHKTR tests CTRTRI, -TRS, -RFS, and -CON, and CLATRS */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix column dimension N. */
/* NNB (input) INTEGER */
/* The number of values of NB contained in the vector NBVAL. */
/* NBVAL (input) INTEGER array, dimension (NNB) */
/* The values of the blocksize NB. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) REAL */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The leading dimension of the work arrays. */
/* NMAX >= the maximum value of N in NVAL. */
/* A (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* AINV (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* B (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
/* XACT (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
/* WORK (workspace) COMPLEX array, dimension */
/* (NMAX*max(3,NSMAX)) */
/* RWORK (workspace) REAL array, dimension */
/* (max(NMAX,2*NSMAX)) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--a;
--nsval;
--nbval;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "TR", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
cerrtr_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
/* Do for each value of N in NVAL */
n = nval[in];
lda = max(1,n);
*(unsigned char *)xtype = 'N';
for (imat = 1; imat <= 10; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L80;
}
for (iuplo = 1; iuplo <= 2; ++iuplo) {
/* Do first for UPLO = 'U', then for UPLO = 'L' */
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
/* Call CLATTR to generate a triangular test matrix. */
s_copy(srnamc_1.srnamt, "CLATTR", (ftnlen)32, (ftnlen)6);
clattr_(&imat, uplo, "No transpose", diag, iseed, &n, &a[1], &
lda, &x[1], &work[1], &rwork[1], &info);
/* Set IDIAG = 1 for non-unit matrices, 2 for unit. */
if (lsame_(diag, "N")) {
idiag = 1;
} else {
idiag = 2;
}
i__2 = *nnb;
for (inb = 1; inb <= i__2; ++inb) {
/* Do for each blocksize in NBVAL */
nb = nbval[inb];
xlaenv_(&c__1, &nb);
/* + TEST 1 */
/* Form the inverse of A. */
clacpy_(uplo, &n, &n, &a[1], &lda, &ainv[1], &lda);
s_copy(srnamc_1.srnamt, "CTRTRI", (ftnlen)32, (ftnlen)6);
ctrtri_(uplo, diag, &n, &ainv[1], &lda, &info);
/* Check error code from CTRTRI. */
if (info != 0) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = uplo;
i__3[1] = 1, a__1[1] = diag;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
alaerh_(path, "CTRTRI", &info, &c__0, ch__1, &n, &n, &
c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
}
/* Compute the infinity-norm condition number of A. */
anorm = clantr_("I", uplo, diag, &n, &n, &a[1], &lda, &
rwork[1]);
ainvnm = clantr_("I", uplo, diag, &n, &n, &ainv[1], &lda,
&rwork[1]);
if (anorm <= 0.f || ainvnm <= 0.f) {
rcondi = 1.f;
} else {
rcondi = 1.f / anorm / ainvnm;
}
/* Compute the residual for the triangular matrix times */
/* its inverse. Also compute the 1-norm condition number */
/* of A. */
ctrt01_(uplo, diag, &n, &a[1], &lda, &ainv[1], &lda, &
rcondo, &rwork[1], result);
/* Print the test ratio if it is .GE. THRESH. */
if (result[0] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___27.ciunit = *nout;
s_wsfe(&io___27);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, diag, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(real)
);
e_wsfe();
++nfail;
}
++nrun;
/* Skip remaining tests if not the first block size. */
if (inb != 1) {
goto L60;
}
i__4 = *nns;
for (irhs = 1; irhs <= i__4; ++irhs) {
nrhs = nsval[irhs];
*(unsigned char *)xtype = 'N';
for (itran = 1; itran <= 3; ++itran) {
/* Do for op(A) = A, A**T, or A**H. */
*(unsigned char *)trans = *(unsigned char *)&
transs[itran - 1];
if (itran == 1) {
*(unsigned char *)norm = 'O';
rcondc = rcondo;
} else {
*(unsigned char *)norm = 'I';
rcondc = rcondi;
}
/* + TEST 2 */
/* Solve and compute residual for op(A)*x = b. */
s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, (
ftnlen)6);
clarhs_(path, xtype, uplo, trans, &n, &n, &c__0, &
idiag, &nrhs, &a[1], &lda, &xact[1], &lda,
&b[1], &lda, iseed, &info);
*(unsigned char *)xtype = 'C';
clacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
lda);
s_copy(srnamc_1.srnamt, "CTRTRS", (ftnlen)32, (
ftnlen)6);
ctrtrs_(uplo, trans, diag, &n, &nrhs, &a[1], &lda,
&x[1], &lda, &info);
/* Check error code from CTRTRS. */
if (info != 0) {
/* Writing concatenation */
i__5[0] = 1, a__2[0] = uplo;
i__5[1] = 1, a__2[1] = trans;
i__5[2] = 1, a__2[2] = diag;
s_cat(ch__2, a__2, i__5, &c__3, (ftnlen)3);
alaerh_(path, "CTRTRS", &info, &c__0, ch__2, &
n, &n, &c_n1, &c_n1, &nrhs, &imat, &
nfail, &nerrs, nout);
}
/* This line is needed on a Sun SPARCstation. */
if (n > 0) {
dummy = a[1].r;
}
ctrt02_(uplo, trans, diag, &n, &nrhs, &a[1], &lda,
&x[1], &lda, &b[1], &lda, &work[1], &
rwork[1], &result[1]);
/* + TEST 3 */
/* Check solution from generated exact solution. */
cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
/* + TESTS 4, 5, and 6 */
/* Use iterative refinement to improve the solution */
/* and compute error bounds. */
s_copy(srnamc_1.srnamt, "CTRRFS", (ftnlen)32, (
ftnlen)6);
ctrrfs_(uplo, trans, diag, &n, &nrhs, &a[1], &lda,
&b[1], &lda, &x[1], &lda, &rwork[1], &
rwork[nrhs + 1], &work[1], &rwork[(nrhs <<
1) + 1], &info);
/* Check error code from CTRRFS. */
if (info != 0) {
/* Writing concatenation */
i__5[0] = 1, a__2[0] = uplo;
i__5[1] = 1, a__2[1] = trans;
i__5[2] = 1, a__2[2] = diag;
s_cat(ch__2, a__2, i__5, &c__3, (ftnlen)3);
alaerh_(path, "CTRRFS", &info, &c__0, ch__2, &
n, &n, &c_n1, &c_n1, &nrhs, &imat, &
nfail, &nerrs, nout);
}
cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[3]);
ctrt05_(uplo, trans, diag, &n, &nrhs, &a[1], &lda,
&b[1], &lda, &x[1], &lda, &xact[1], &lda,
&rwork[1], &rwork[nrhs + 1], &result[4]);
/* Print information about the tests that did not */
/* pass the threshold. */
for (k = 2; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, diag, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nrhs, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(real));
e_wsfe();
++nfail;
}
/* L20: */
}
nrun += 5;
/* L30: */
}
/* L40: */
}
/* + TEST 7 */
/* Get an estimate of RCOND = 1/CNDNUM. */
for (itran = 1; itran <= 2; ++itran) {
if (itran == 1) {
*(unsigned char *)norm = 'O';
rcondc = rcondo;
} else {
*(unsigned char *)norm = 'I';
rcondc = rcondi;
}
s_copy(srnamc_1.srnamt, "CTRCON", (ftnlen)32, (ftnlen)
6);
ctrcon_(norm, uplo, diag, &n, &a[1], &lda, &rcond, &
work[1], &rwork[1], &info);
/* Check error code from CTRCON. */
if (info != 0) {
/* Writing concatenation */
i__5[0] = 1, a__2[0] = norm;
i__5[1] = 1, a__2[1] = uplo;
i__5[2] = 1, a__2[2] = diag;
s_cat(ch__2, a__2, i__5, &c__3, (ftnlen)3);
alaerh_(path, "CTRCON", &info, &c__0, ch__2, &n, &
n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
nerrs, nout);
}
ctrt06_(&rcond, &rcondc, uplo, diag, &n, &a[1], &lda,
&rwork[1], &result[6]);
/* Print the test ratio if it is .GE. THRESH. */
if (result[6] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, norm, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(
real));
e_wsfe();
++nfail;
}
++nrun;
/* L50: */
}
L60:
;
}
/* L70: */
}
L80:
;
}
/* Use pathological test matrices to test CLATRS. */
for (imat = 11; imat <= 18; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L110;
}
for (iuplo = 1; iuplo <= 2; ++iuplo) {
/* Do first for UPLO = 'U', then for UPLO = 'L' */
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
for (itran = 1; itran <= 3; ++itran) {
/* Do for op(A) = A, A**T, and A**H. */
*(unsigned char *)trans = *(unsigned char *)&transs[itran
- 1];
/* Call CLATTR to generate a triangular test matrix. */
s_copy(srnamc_1.srnamt, "CLATTR", (ftnlen)32, (ftnlen)6);
clattr_(&imat, uplo, trans, diag, iseed, &n, &a[1], &lda,
&x[1], &work[1], &rwork[1], &info);
/* + TEST 8 */
/* Solve the system op(A)*x = b. */
s_copy(srnamc_1.srnamt, "CLATRS", (ftnlen)32, (ftnlen)6);
ccopy_(&n, &x[1], &c__1, &b[1], &c__1);
clatrs_(uplo, trans, diag, "N", &n, &a[1], &lda, &b[1], &
scale, &rwork[1], &info);
/* Check error code from CLATRS. */
if (info != 0) {
/* Writing concatenation */
i__6[0] = 1, a__3[0] = uplo;
i__6[1] = 1, a__3[1] = trans;
i__6[2] = 1, a__3[2] = diag;
i__6[3] = 1, a__3[3] = "N";
s_cat(ch__3, a__3, i__6, &c__4, (ftnlen)4);
alaerh_(path, "CLATRS", &info, &c__0, ch__3, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
ctrt03_(uplo, trans, diag, &n, &c__1, &a[1], &lda, &scale,
&rwork[1], &c_b99, &b[1], &lda, &x[1], &lda, &
work[1], &result[7]);
/* + TEST 9 */
/* Solve op(A)*X = b again with NORMIN = 'Y'. */
ccopy_(&n, &x[1], &c__1, &b[n + 1], &c__1);
clatrs_(uplo, trans, diag, "Y", &n, &a[1], &lda, &b[n + 1]
, &scale, &rwork[1], &info);
/* Check error code from CLATRS. */
if (info != 0) {
/* Writing concatenation */
i__6[0] = 1, a__3[0] = uplo;
i__6[1] = 1, a__3[1] = trans;
i__6[2] = 1, a__3[2] = diag;
i__6[3] = 1, a__3[3] = "Y";
s_cat(ch__3, a__3, i__6, &c__4, (ftnlen)4);
alaerh_(path, "CLATRS", &info, &c__0, ch__3, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
ctrt03_(uplo, trans, diag, &n, &c__1, &a[1], &lda, &scale,
&rwork[1], &c_b99, &b[n + 1], &lda, &x[1], &lda,
&work[1], &result[8]);
/* Print information about the tests that did not pass */
/* the threshold. */
if (result[7] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, "CLATRS", (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, diag, (ftnlen)1);
do_fio(&c__1, "N", (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(real)
);
e_wsfe();
++nfail;
}
if (result[8] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, "CLATRS", (ftnlen)6);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, diag, (ftnlen)1);
do_fio(&c__1, "Y", (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[8], (ftnlen)sizeof(real)
);
e_wsfe();
++nfail;
}
nrun += 2;
/* L90: */
}
/* L100: */
}
L110:
;
}
/* L120: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of CCHKTR */
} /* cchktr_ */
/* Subroutine */ int cpocon_(char *uplo, integer *n, complex *a, integer *lda,
real *anorm, real *rcond, complex *work, real *rwork, integer *info,
ftnlen uplo_len)
{
/* System generated locals */
integer a_dim1, a_offset, i__1;
real r__1, r__2;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static integer ix, kase;
static real scale;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static logical upper;
extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real
*, integer *);
extern integer icamax_(integer *, complex *, integer *);
static real scalel;
extern doublereal slamch_(char *, ftnlen);
static real scaleu;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
static real ainvnm;
extern /* Subroutine */ int clatrs_(char *, char *, char *, char *,
integer *, complex *, integer *, complex *, real *, real *,
integer *, ftnlen, ftnlen, ftnlen, ftnlen), csrscl_(integer *,
real *, complex *, integer *);
static char normin[1];
static real smlnum;
/* -- 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 */
/* ======= */
/* CPOCON estimates the reciprocal of the condition number (in the */
/* 1-norm) of a complex Hermitian positive definite matrix using the */
/* Cholesky factorization A = U**H*U or A = L*L**H computed by CPOTRF. */
/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The triangular factor U or L from the Cholesky factorization */
/* A = U**H*U or A = L*L**H, as computed by CPOTRF. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* ANORM (input) REAL */
/* The 1-norm (or infinity-norm) of the Hermitian matrix A. */
/* RCOND (output) REAL */
/* The reciprocal of the condition number of the matrix A, */
/* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */
/* estimate of the 1-norm of inv(A) computed in this routine. */
/* 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 */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--work;
--rwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
} else if (*anorm < 0.f) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CPOCON", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
*rcond = 0.f;
if (*n == 0) {
*rcond = 1.f;
return 0;
} else if (*anorm == 0.f) {
return 0;
}
smlnum = slamch_("Safe minimum", (ftnlen)12);
/* Estimate the 1-norm of inv(A). */
kase = 0;
*(unsigned char *)normin = 'N';
L10:
clacon_(n, &work[*n + 1], &work[1], &ainvnm, &kase);
if (kase != 0) {
if (upper) {
/* Multiply by inv(U'). */
clatrs_("Upper", "Conjugate transpose", "Non-unit", normin, n, &a[
a_offset], lda, &work[1], &scalel, &rwork[1], info, (
ftnlen)5, (ftnlen)19, (ftnlen)8, (ftnlen)1);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(U). */
clatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[
a_offset], lda, &work[1], &scaleu, &rwork[1], info, (
ftnlen)5, (ftnlen)12, (ftnlen)8, (ftnlen)1);
} else {
/* Multiply by inv(L). */
clatrs_("Lower", "No transpose", "Non-unit", normin, n, &a[
a_offset], lda, &work[1], &scalel, &rwork[1], info, (
ftnlen)5, (ftnlen)12, (ftnlen)8, (ftnlen)1);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(L'). */
clatrs_("Lower", "Conjugate transpose", "Non-unit", normin, n, &a[
a_offset], lda, &work[1], &scaleu, &rwork[1], info, (
ftnlen)5, (ftnlen)19, (ftnlen)8, (ftnlen)1);
}
/* Multiply by 1/SCALE if doing so will not cause overflow. */
scale = scalel * scaleu;
if (scale != 1.f) {
ix = icamax_(n, &work[1], &c__1);
i__1 = ix;
if (scale < ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(&
work[ix]), dabs(r__2))) * 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 / ainvnm / *anorm;
}
L20:
return 0;
/* End of CPOCON */
} /* cpocon_ */
/* Subroutine */
int ctrevc_(char *side, char *howmny, logical *select, integer *n, complex *t, integer *ldt, complex *vl, integer *ldvl, complex *vr, integer *ldvr, integer *mm, integer *m, complex *work, real *rwork, integer *info)
{
/* System generated locals */
integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3;
complex q__1, q__2;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
integer i__, j, k, ii, ki, is;
real ulp;
logical allv;
real unfl, ovfl, smin;
logical over;
real scale;
extern logical lsame_(char *, char *);
extern /* Subroutine */
int cgemv_(char *, integer *, integer *, complex * , complex *, integer *, complex *, integer *, complex *, complex * , integer *);
real remax;
extern /* Subroutine */
int ccopy_(integer *, complex *, integer *, complex *, integer *);
logical leftv, bothv, somev;
extern /* Subroutine */
int slabad_(real *, real *);
extern integer icamax_(integer *, complex *, integer *);
extern real slamch_(char *);
extern /* Subroutine */
int csscal_(integer *, real *, complex *, integer *), xerbla_(char *, integer *), clatrs_(char *, char *, char *, char *, integer *, complex *, integer *, complex *, real * , real *, integer *);
extern real scasum_(integer *, complex *, integer *);
logical rightv;
real smlnum;
/* -- 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 .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and test the input parameters */
/* Parameter adjustments */
--select;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--work;
--rwork;
/* Function Body */
bothv = lsame_(side, "B");
rightv = lsame_(side, "R") || bothv;
leftv = lsame_(side, "L") || bothv;
allv = lsame_(howmny, "A");
over = lsame_(howmny, "B");
somev = lsame_(howmny, "S");
/* Set M to the number of columns required to store the selected */
/* eigenvectors. */
if (somev)
{
*m = 0;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
if (select[j])
{
++(*m);
}
/* L10: */
}
}
else
{
*m = *n;
}
*info = 0;
if (! rightv && ! leftv)
{
*info = -1;
}
else if (! allv && ! over && ! somev)
{
*info = -2;
}
else if (*n < 0)
{
*info = -4;
}
else if (*ldt < max(1,*n))
{
*info = -6;
}
else if (*ldvl < 1 || leftv && *ldvl < *n)
{
*info = -8;
}
else if (*ldvr < 1 || rightv && *ldvr < *n)
{
*info = -10;
}
else if (*mm < *m)
{
*info = -11;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CTREVC", &i__1);
return 0;
}
/* Quick return if possible. */
if (*n == 0)
{
return 0;
}
/* Set the constants to control overflow. */
unfl = slamch_("Safe minimum");
ovfl = 1.f / unfl;
slabad_(&unfl, &ovfl);
ulp = slamch_("Precision");
smlnum = unfl * (*n / ulp);
/* Store the diagonal elements of T in working array WORK. */
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
i__2 = i__ + *n;
i__3 = i__ + i__ * t_dim1;
work[i__2].r = t[i__3].r;
work[i__2].i = t[i__3].i; // , expr subst
/* L20: */
}
/* Compute 1-norm of each column of strictly upper triangular */
/* part of T to control overflow in triangular solver. */
rwork[1] = 0.f;
i__1 = *n;
for (j = 2;
j <= i__1;
++j)
{
i__2 = j - 1;
rwork[j] = scasum_(&i__2, &t[j * t_dim1 + 1], &c__1);
/* L30: */
}
if (rightv)
{
/* Compute right eigenvectors. */
is = *m;
for (ki = *n;
ki >= 1;
--ki)
{
if (somev)
{
if (! select[ki])
{
goto L80;
}
}
/* Computing MAX */
i__1 = ki + ki * t_dim1;
r__3 = ulp * ((r__1 = t[i__1].r, f2c_abs(r__1)) + (r__2 = r_imag(&t[ ki + ki * t_dim1]), f2c_abs(r__2)));
smin = max(r__3,smlnum);
work[1].r = 1.f;
work[1].i = 0.f; // , expr subst
/* Form right-hand side. */
i__1 = ki - 1;
for (k = 1;
k <= i__1;
++k)
{
i__2 = k;
i__3 = k + ki * t_dim1;
q__1.r = -t[i__3].r;
q__1.i = -t[i__3].i; // , expr subst
work[i__2].r = q__1.r;
work[i__2].i = q__1.i; // , expr subst
/* L40: */
}
/* Solve the triangular system: */
/* (T(1:KI-1,1:KI-1) - T(KI,KI))*X = SCALE*WORK. */
i__1 = ki - 1;
for (k = 1;
k <= i__1;
++k)
{
i__2 = k + k * t_dim1;
i__3 = k + k * t_dim1;
i__4 = ki + ki * t_dim1;
q__1.r = t[i__3].r - t[i__4].r;
q__1.i = t[i__3].i - t[i__4] .i; // , expr subst
t[i__2].r = q__1.r;
t[i__2].i = q__1.i; // , expr subst
i__2 = k + k * t_dim1;
if ((r__1 = t[i__2].r, f2c_abs(r__1)) + (r__2 = r_imag(&t[k + k * t_dim1]), f2c_abs(r__2)) < smin)
{
i__3 = k + k * t_dim1;
t[i__3].r = smin;
t[i__3].i = 0.f; // , expr subst
}
/* L50: */
}
if (ki > 1)
{
i__1 = ki - 1;
clatrs_("Upper", "No transpose", "Non-unit", "Y", &i__1, &t[ t_offset], ldt, &work[1], &scale, &rwork[1], info);
i__1 = ki;
work[i__1].r = scale;
work[i__1].i = 0.f; // , expr subst
}
/* Copy the vector x or Q*x to VR and normalize. */
if (! over)
{
ccopy_(&ki, &work[1], &c__1, &vr[is * vr_dim1 + 1], &c__1);
ii = icamax_(&ki, &vr[is * vr_dim1 + 1], &c__1);
i__1 = ii + is * vr_dim1;
remax = 1.f / ((r__1 = vr[i__1].r, f2c_abs(r__1)) + (r__2 = r_imag(&vr[ii + is * vr_dim1]), f2c_abs(r__2)));
csscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1);
i__1 = *n;
for (k = ki + 1;
k <= i__1;
++k)
{
i__2 = k + is * vr_dim1;
vr[i__2].r = 0.f;
vr[i__2].i = 0.f; // , expr subst
/* L60: */
}
}
else
{
if (ki > 1)
{
i__1 = ki - 1;
q__1.r = scale;
q__1.i = 0.f; // , expr subst
cgemv_("N", n, &i__1, &c_b2, &vr[vr_offset], ldvr, &work[ 1], &c__1, &q__1, &vr[ki * vr_dim1 + 1], &c__1);
}
ii = icamax_(n, &vr[ki * vr_dim1 + 1], &c__1);
i__1 = ii + ki * vr_dim1;
remax = 1.f / ((r__1 = vr[i__1].r, f2c_abs(r__1)) + (r__2 = r_imag(&vr[ii + ki * vr_dim1]), f2c_abs(r__2)));
csscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1);
}
/* Set back the original diagonal elements of T. */
i__1 = ki - 1;
for (k = 1;
k <= i__1;
++k)
{
i__2 = k + k * t_dim1;
i__3 = k + *n;
t[i__2].r = work[i__3].r;
t[i__2].i = work[i__3].i; // , expr subst
/* L70: */
}
--is;
L80:
;
}
}
if (leftv)
{
/* Compute left eigenvectors. */
is = 1;
i__1 = *n;
for (ki = 1;
ki <= i__1;
++ki)
{
if (somev)
{
if (! select[ki])
{
goto L130;
}
}
/* Computing MAX */
i__2 = ki + ki * t_dim1;
r__3 = ulp * ((r__1 = t[i__2].r, f2c_abs(r__1)) + (r__2 = r_imag(&t[ ki + ki * t_dim1]), f2c_abs(r__2)));
smin = max(r__3,smlnum);
i__2 = *n;
work[i__2].r = 1.f;
work[i__2].i = 0.f; // , expr subst
/* Form right-hand side. */
i__2 = *n;
for (k = ki + 1;
k <= i__2;
++k)
{
i__3 = k;
r_cnjg(&q__2, &t[ki + k * t_dim1]);
q__1.r = -q__2.r;
q__1.i = -q__2.i; // , expr subst
work[i__3].r = q__1.r;
work[i__3].i = q__1.i; // , expr subst
/* L90: */
}
/* Solve the triangular system: */
/* (T(KI+1:N,KI+1:N) - T(KI,KI))**H*X = SCALE*WORK. */
i__2 = *n;
for (k = ki + 1;
k <= i__2;
++k)
{
i__3 = k + k * t_dim1;
i__4 = k + k * t_dim1;
i__5 = ki + ki * t_dim1;
q__1.r = t[i__4].r - t[i__5].r;
q__1.i = t[i__4].i - t[i__5] .i; // , expr subst
t[i__3].r = q__1.r;
t[i__3].i = q__1.i; // , expr subst
i__3 = k + k * t_dim1;
if ((r__1 = t[i__3].r, f2c_abs(r__1)) + (r__2 = r_imag(&t[k + k * t_dim1]), f2c_abs(r__2)) < smin)
{
i__4 = k + k * t_dim1;
t[i__4].r = smin;
t[i__4].i = 0.f; // , expr subst
}
/* L100: */
}
if (ki < *n)
{
i__2 = *n - ki;
clatrs_("Upper", "Conjugate transpose", "Non-unit", "Y", & i__2, &t[ki + 1 + (ki + 1) * t_dim1], ldt, &work[ki + 1], &scale, &rwork[1], info);
i__2 = ki;
work[i__2].r = scale;
work[i__2].i = 0.f; // , expr subst
}
/* Copy the vector x or Q*x to VL and normalize. */
if (! over)
{
i__2 = *n - ki + 1;
ccopy_(&i__2, &work[ki], &c__1, &vl[ki + is * vl_dim1], &c__1) ;
i__2 = *n - ki + 1;
ii = icamax_(&i__2, &vl[ki + is * vl_dim1], &c__1) + ki - 1;
i__2 = ii + is * vl_dim1;
remax = 1.f / ((r__1 = vl[i__2].r, f2c_abs(r__1)) + (r__2 = r_imag(&vl[ii + is * vl_dim1]), f2c_abs(r__2)));
i__2 = *n - ki + 1;
csscal_(&i__2, &remax, &vl[ki + is * vl_dim1], &c__1);
i__2 = ki - 1;
for (k = 1;
k <= i__2;
++k)
{
i__3 = k + is * vl_dim1;
vl[i__3].r = 0.f;
vl[i__3].i = 0.f; // , expr subst
/* L110: */
}
}
else
{
if (ki < *n)
{
i__2 = *n - ki;
q__1.r = scale;
q__1.i = 0.f; // , expr subst
cgemv_("N", n, &i__2, &c_b2, &vl[(ki + 1) * vl_dim1 + 1], ldvl, &work[ki + 1], &c__1, &q__1, &vl[ki * vl_dim1 + 1], &c__1);
}
ii = icamax_(n, &vl[ki * vl_dim1 + 1], &c__1);
i__2 = ii + ki * vl_dim1;
remax = 1.f / ((r__1 = vl[i__2].r, f2c_abs(r__1)) + (r__2 = r_imag(&vl[ii + ki * vl_dim1]), f2c_abs(r__2)));
csscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1);
}
/* Set back the original diagonal elements of T. */
i__2 = *n;
for (k = ki + 1;
k <= i__2;
++k)
{
i__3 = k + k * t_dim1;
i__4 = k + *n;
t[i__3].r = work[i__4].r;
t[i__3].i = work[i__4].i; // , expr subst
/* L120: */
}
++is;
L130:
;
}
}
return 0;
/* End of CTREVC */
}
/* Subroutine */ int ctrsna_(char *job, char *howmny, logical *select,
integer *n, complex *t, integer *ldt, complex *vl, integer *ldvl,
complex *vr, integer *ldvr, real *s, real *sep, integer *mm, integer *
m, complex *work, integer *ldwork, real *rwork, integer *info)
{
/* System generated locals */
integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset,
work_dim1, work_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2;
complex q__1;
/* Builtin functions */
double c_abs(complex *), r_imag(complex *);
/* Local variables */
integer i__, j, k, ks, ix;
real eps, est;
integer kase, ierr;
complex prod;
real lnrm, rnrm, scale;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
integer isave[3];
complex dummy[1];
logical wants;
extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
*, integer *, integer *);
real xnorm;
extern doublereal scnrm2_(integer *, complex *, integer *);
extern /* Subroutine */ int slabad_(real *, real *);
extern integer icamax_(integer *, complex *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), xerbla_(char *,
integer *);
real bignum;
logical wantbh;
extern /* Subroutine */ int clatrs_(char *, char *, char *, char *,
integer *, complex *, integer *, complex *, real *, real *,
integer *), csrscl_(integer *,
real *, complex *, integer *), ctrexc_(char *, integer *, complex
*, integer *, complex *, integer *, integer *, integer *, integer
*);
logical somcon;
char normin[1];
real smlnum;
logical wantsp;
/* -- 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 */
/* ======= */
/* CTRSNA estimates reciprocal condition numbers for specified */
/* eigenvalues and/or right eigenvectors of a complex upper triangular */
/* matrix T (or of any matrix Q*T*Q**H with Q unitary). */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* Specifies whether condition numbers are required for */
/* eigenvalues (S) or eigenvectors (SEP): */
/* = 'E': for eigenvalues only (S); */
/* = 'V': for eigenvectors only (SEP); */
/* = 'B': for both eigenvalues and eigenvectors (S and SEP). */
/* HOWMNY (input) CHARACTER*1 */
/* = 'A': compute condition numbers for all eigenpairs; */
/* = 'S': compute condition numbers for selected eigenpairs */
/* specified by the array SELECT. */
/* SELECT (input) LOGICAL array, dimension (N) */
/* If HOWMNY = 'S', SELECT specifies the eigenpairs for which */
/* condition numbers are required. To select condition numbers */
/* for the j-th eigenpair, SELECT(j) must be set to .TRUE.. */
/* If HOWMNY = 'A', SELECT is not referenced. */
/* N (input) INTEGER */
/* The order of the matrix T. N >= 0. */
/* T (input) COMPLEX array, dimension (LDT,N) */
/* The upper triangular matrix T. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= max(1,N). */
/* VL (input) COMPLEX array, dimension (LDVL,M) */
/* If JOB = 'E' or 'B', VL must contain left eigenvectors of T */
/* (or of any Q*T*Q**H with Q unitary), corresponding to the */
/* eigenpairs specified by HOWMNY and SELECT. The eigenvectors */
/* must be stored in consecutive columns of VL, as returned by */
/* CHSEIN or CTREVC. */
/* If JOB = 'V', VL is not referenced. */
/* LDVL (input) INTEGER */
/* The leading dimension of the array VL. */
/* LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N. */
/* VR (input) COMPLEX array, dimension (LDVR,M) */
/* If JOB = 'E' or 'B', VR must contain right eigenvectors of T */
/* (or of any Q*T*Q**H with Q unitary), corresponding to the */
/* eigenpairs specified by HOWMNY and SELECT. The eigenvectors */
/* must be stored in consecutive columns of VR, as returned by */
/* CHSEIN or CTREVC. */
/* If JOB = 'V', VR is not referenced. */
/* LDVR (input) INTEGER */
/* The leading dimension of the array VR. */
/* LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N. */
/* S (output) REAL array, dimension (MM) */
/* If JOB = 'E' or 'B', the reciprocal condition numbers of the */
/* selected eigenvalues, stored in consecutive elements of the */
/* array. Thus S(j), SEP(j), and the j-th columns of VL and VR */
/* all correspond to the same eigenpair (but not in general the */
/* j-th eigenpair, unless all eigenpairs are selected). */
/* If JOB = 'V', S is not referenced. */
/* SEP (output) REAL array, dimension (MM) */
/* If JOB = 'V' or 'B', the estimated reciprocal condition */
/* numbers of the selected eigenvectors, stored in consecutive */
/* elements of the array. */
/* If JOB = 'E', SEP is not referenced. */
/* MM (input) INTEGER */
/* The number of elements in the arrays S (if JOB = 'E' or 'B') */
/* and/or SEP (if JOB = 'V' or 'B'). MM >= M. */
/* M (output) INTEGER */
/* The number of elements of the arrays S and/or SEP actually */
/* used to store the estimated condition numbers. */
/* If HOWMNY = 'A', M is set to N. */
/* WORK (workspace) COMPLEX array, dimension (LDWORK,N+6) */
/* If JOB = 'E', WORK is not referenced. */
/* LDWORK (input) INTEGER */
/* The leading dimension of the array WORK. */
/* LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N. */
/* RWORK (workspace) REAL array, dimension (N) */
/* If JOB = 'E', RWORK is not referenced. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* The reciprocal of the condition number of an eigenvalue lambda is */
/* defined as */
/* S(lambda) = |v'*u| / (norm(u)*norm(v)) */
/* where u and v are the right and left eigenvectors of T corresponding */
/* to lambda; v' denotes the conjugate transpose of v, and norm(u) */
/* denotes the Euclidean norm. These reciprocal condition numbers always */
/* lie between zero (very badly conditioned) and one (very well */
/* conditioned). If n = 1, S(lambda) is defined to be 1. */
/* An approximate error bound for a computed eigenvalue W(i) is given by */
/* EPS * norm(T) / S(i) */
/* where EPS is the machine precision. */
/* The reciprocal of the condition number of the right eigenvector u */
/* corresponding to lambda is defined as follows. Suppose */
/* T = ( lambda c ) */
/* ( 0 T22 ) */
/* Then the reciprocal condition number is */
/* SEP( lambda, T22 ) = sigma-min( T22 - lambda*I ) */
/* where sigma-min denotes the smallest singular value. We approximate */
/* the smallest singular value by the reciprocal of an estimate of the */
/* one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is */
/* defined to be abs(T(1,1)). */
/* An approximate error bound for a computed right eigenvector VR(i) */
/* is given by */
/* EPS * norm(T) / SEP(i) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and test the input parameters */
/* Parameter adjustments */
--select;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--s;
--sep;
work_dim1 = *ldwork;
work_offset = 1 + work_dim1;
work -= work_offset;
--rwork;
/* Function Body */
wantbh = lsame_(job, "B");
wants = lsame_(job, "E") || wantbh;
wantsp = lsame_(job, "V") || wantbh;
somcon = lsame_(howmny, "S");
/* Set M to the number of eigenpairs for which condition numbers are */
/* to be computed. */
if (somcon) {
*m = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (select[j]) {
++(*m);
}
/* L10: */
}
} else {
*m = *n;
}
*info = 0;
if (! wants && ! wantsp) {
*info = -1;
} else if (! lsame_(howmny, "A") && ! somcon) {
*info = -2;
} else if (*n < 0) {
*info = -4;
} else if (*ldt < max(1,*n)) {
*info = -6;
} else if (*ldvl < 1 || wants && *ldvl < *n) {
*info = -8;
} else if (*ldvr < 1 || wants && *ldvr < *n) {
*info = -10;
} else if (*mm < *m) {
*info = -13;
} else if (*ldwork < 1 || wantsp && *ldwork < *n) {
*info = -16;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTRSNA", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (somcon) {
if (! select[1]) {
return 0;
}
}
if (wants) {
s[1] = 1.f;
}
if (wantsp) {
sep[1] = c_abs(&t[t_dim1 + 1]);
}
return 0;
}
/* Get machine constants */
eps = slamch_("P");
smlnum = slamch_("S") / eps;
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
ks = 1;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (somcon) {
if (! select[k]) {
goto L50;
}
}
if (wants) {
/* Compute the reciprocal condition number of the k-th */
/* eigenvalue. */
cdotc_(&q__1, n, &vr[ks * vr_dim1 + 1], &c__1, &vl[ks * vl_dim1 +
1], &c__1);
prod.r = q__1.r, prod.i = q__1.i;
rnrm = scnrm2_(n, &vr[ks * vr_dim1 + 1], &c__1);
lnrm = scnrm2_(n, &vl[ks * vl_dim1 + 1], &c__1);
s[ks] = c_abs(&prod) / (rnrm * lnrm);
}
if (wantsp) {
/* Estimate the reciprocal condition number of the k-th */
/* eigenvector. */
/* Copy the matrix T to the array WORK and swap the k-th */
/* diagonal element to the (1,1) position. */
clacpy_("Full", n, n, &t[t_offset], ldt, &work[work_offset],
ldwork);
ctrexc_("No Q", n, &work[work_offset], ldwork, dummy, &c__1, &k, &
c__1, &ierr);
/* Form C = T22 - lambda*I in WORK(2:N,2:N). */
i__2 = *n;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = i__ + i__ * work_dim1;
i__4 = i__ + i__ * work_dim1;
i__5 = work_dim1 + 1;
q__1.r = work[i__4].r - work[i__5].r, q__1.i = work[i__4].i -
work[i__5].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L20: */
}
/* Estimate a lower bound for the 1-norm of inv(C'). The 1st */
/* and (N+1)th columns of WORK are used to store work vectors. */
sep[ks] = 0.f;
est = 0.f;
kase = 0;
*(unsigned char *)normin = 'N';
L30:
i__2 = *n - 1;
clacn2_(&i__2, &work[(*n + 1) * work_dim1 + 1], &work[work_offset]
, &est, &kase, isave);
if (kase != 0) {
if (kase == 1) {
/* Solve C'*x = scale*b */
i__2 = *n - 1;
clatrs_("Upper", "Conjugate transpose", "Nonunit", normin,
&i__2, &work[(work_dim1 << 1) + 2], ldwork, &
work[work_offset], &scale, &rwork[1], &ierr);
} else {
/* Solve C*x = scale*b */
i__2 = *n - 1;
clatrs_("Upper", "No transpose", "Nonunit", normin, &i__2,
&work[(work_dim1 << 1) + 2], ldwork, &work[
work_offset], &scale, &rwork[1], &ierr);
}
*(unsigned char *)normin = 'Y';
if (scale != 1.f) {
/* Multiply by 1/SCALE if doing so will not cause */
/* overflow. */
i__2 = *n - 1;
ix = icamax_(&i__2, &work[work_offset], &c__1);
i__2 = ix + work_dim1;
xnorm = (r__1 = work[i__2].r, dabs(r__1)) + (r__2 =
r_imag(&work[ix + work_dim1]), dabs(r__2));
if (scale < xnorm * smlnum || scale == 0.f) {
goto L40;
}
csrscl_(n, &scale, &work[work_offset], &c__1);
}
goto L30;
}
sep[ks] = 1.f / dmax(est,smlnum);
}
L40:
++ks;
L50:
;
}
return 0;
/* End of CTRSNA */
} /* ctrsna_ */
/* Subroutine */ int cerrtr_(char *path, integer *nunit)
{
/* Local variables */
complex a[4] /* was [2][2] */, b[2], w[2], x[2];
char c2[2];
real r1[2], r2[2], rw[2];
integer info;
real scale, rcond;
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CERRTR tests the error exits for the COMPLEX triangular routines. */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The LAPACK path name for the routines to be tested. */
/* NUNIT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
a[0].r = 1.f, a[0].i = 0.f;
a[2].r = 2.f, a[2].i = 0.f;
a[3].r = 3.f, a[3].i = 0.f;
a[1].r = 4.f, a[1].i = 0.f;
infoc_1.ok = TRUE_;
/* Test error exits for the general triangular routines. */
if (lsamen_(&c__2, c2, "TR")) {
/* CTRTRI */
s_copy(srnamc_1.srnamt, "CTRTRI", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
ctrtri_("/", "N", &c__0, a, &c__1, &info);
chkxer_("CTRTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ctrtri_("U", "/", &c__0, a, &c__1, &info);
chkxer_("CTRTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
ctrtri_("U", "N", &c_n1, a, &c__1, &info);
chkxer_("CTRTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
ctrtri_("U", "N", &c__2, a, &c__1, &info);
chkxer_("CTRTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CTRTI2 */
s_copy(srnamc_1.srnamt, "CTRTI2", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
ctrti2_("/", "N", &c__0, a, &c__1, &info);
chkxer_("CTRTI2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ctrti2_("U", "/", &c__0, a, &c__1, &info);
chkxer_("CTRTI2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
ctrti2_("U", "N", &c_n1, a, &c__1, &info);
chkxer_("CTRTI2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
ctrti2_("U", "N", &c__2, a, &c__1, &info);
chkxer_("CTRTI2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CTRTRS */
s_copy(srnamc_1.srnamt, "CTRTRS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
ctrtrs_("/", "N", "N", &c__0, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("CTRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ctrtrs_("U", "/", "N", &c__0, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("CTRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
ctrtrs_("U", "N", "/", &c__0, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("CTRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ctrtrs_("U", "N", "N", &c_n1, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("CTRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
ctrtrs_("U", "N", "N", &c__0, &c_n1, a, &c__1, x, &c__1, &info);
chkxer_("CTRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
/* CTRRFS */
s_copy(srnamc_1.srnamt, "CTRRFS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
ctrrfs_("/", "N", "N", &c__0, &c__0, a, &c__1, b, &c__1, x, &c__1, r1,
r2, w, rw, &info);
chkxer_("CTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ctrrfs_("U", "/", "N", &c__0, &c__0, a, &c__1, b, &c__1, x, &c__1, r1,
r2, w, rw, &info);
chkxer_("CTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
ctrrfs_("U", "N", "/", &c__0, &c__0, a, &c__1, b, &c__1, x, &c__1, r1,
r2, w, rw, &info);
chkxer_("CTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ctrrfs_("U", "N", "N", &c_n1, &c__0, a, &c__1, b, &c__1, x, &c__1, r1,
r2, w, rw, &info);
chkxer_("CTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
ctrrfs_("U", "N", "N", &c__0, &c_n1, a, &c__1, b, &c__1, x, &c__1, r1,
r2, w, rw, &info);
chkxer_("CTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
ctrrfs_("U", "N", "N", &c__2, &c__1, a, &c__1, b, &c__2, x, &c__2, r1,
r2, w, rw, &info);
chkxer_("CTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
ctrrfs_("U", "N", "N", &c__2, &c__1, a, &c__2, b, &c__1, x, &c__2, r1,
r2, w, rw, &info);
chkxer_("CTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
ctrrfs_("U", "N", "N", &c__2, &c__1, a, &c__2, b, &c__2, x, &c__1, r1,
r2, w, rw, &info);
chkxer_("CTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CTRCON */
s_copy(srnamc_1.srnamt, "CTRCON", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
ctrcon_("/", "U", "N", &c__0, a, &c__1, &rcond, w, rw, &info);
chkxer_("CTRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ctrcon_("1", "/", "N", &c__0, a, &c__1, &rcond, w, rw, &info);
chkxer_("CTRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
ctrcon_("1", "U", "/", &c__0, a, &c__1, &rcond, w, rw, &info);
chkxer_("CTRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ctrcon_("1", "U", "N", &c_n1, a, &c__1, &rcond, w, rw, &info);
chkxer_("CTRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
ctrcon_("1", "U", "N", &c__2, a, &c__1, &rcond, w, rw, &info);
chkxer_("CTRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CLATRS */
s_copy(srnamc_1.srnamt, "CLATRS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
clatrs_("/", "N", "N", "N", &c__0, a, &c__1, x, &scale, rw, &info);
chkxer_("CLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
clatrs_("U", "/", "N", "N", &c__0, a, &c__1, x, &scale, rw, &info);
chkxer_("CLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
clatrs_("U", "N", "/", "N", &c__0, a, &c__1, x, &scale, rw, &info);
chkxer_("CLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
clatrs_("U", "N", "N", "/", &c__0, a, &c__1, x, &scale, rw, &info);
chkxer_("CLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
clatrs_("U", "N", "N", "N", &c_n1, a, &c__1, x, &scale, rw, &info);
chkxer_("CLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
clatrs_("U", "N", "N", "N", &c__2, a, &c__1, x, &scale, rw, &info);
chkxer_("CLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* Test error exits for the packed triangular routines. */
} else if (lsamen_(&c__2, c2, "TP")) {
/* CTPTRI */
s_copy(srnamc_1.srnamt, "CTPTRI", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
ctptri_("/", "N", &c__0, a, &info);
chkxer_("CTPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ctptri_("U", "/", &c__0, a, &info);
chkxer_("CTPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
ctptri_("U", "N", &c_n1, a, &info);
chkxer_("CTPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CTPTRS */
s_copy(srnamc_1.srnamt, "CTPTRS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
ctptrs_("/", "N", "N", &c__0, &c__0, a, x, &c__1, &info);
chkxer_("CTPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ctptrs_("U", "/", "N", &c__0, &c__0, a, x, &c__1, &info);
chkxer_("CTPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
ctptrs_("U", "N", "/", &c__0, &c__0, a, x, &c__1, &info);
chkxer_("CTPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ctptrs_("U", "N", "N", &c_n1, &c__0, a, x, &c__1, &info);
chkxer_("CTPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
ctptrs_("U", "N", "N", &c__0, &c_n1, a, x, &c__1, &info);
chkxer_("CTPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
ctptrs_("U", "N", "N", &c__2, &c__1, a, x, &c__1, &info);
chkxer_("CTPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CTPRFS */
s_copy(srnamc_1.srnamt, "CTPRFS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
ctprfs_("/", "N", "N", &c__0, &c__0, a, b, &c__1, x, &c__1, r1, r2, w,
rw, &info);
chkxer_("CTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ctprfs_("U", "/", "N", &c__0, &c__0, a, b, &c__1, x, &c__1, r1, r2, w,
rw, &info);
chkxer_("CTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
ctprfs_("U", "N", "/", &c__0, &c__0, a, b, &c__1, x, &c__1, r1, r2, w,
rw, &info);
chkxer_("CTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ctprfs_("U", "N", "N", &c_n1, &c__0, a, b, &c__1, x, &c__1, r1, r2, w,
rw, &info);
chkxer_("CTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
ctprfs_("U", "N", "N", &c__0, &c_n1, a, b, &c__1, x, &c__1, r1, r2, w,
rw, &info);
chkxer_("CTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
ctprfs_("U", "N", "N", &c__2, &c__1, a, b, &c__1, x, &c__2, r1, r2, w,
rw, &info);
chkxer_("CTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
ctprfs_("U", "N", "N", &c__2, &c__1, a, b, &c__2, x, &c__1, r1, r2, w,
rw, &info);
chkxer_("CTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CTPCON */
s_copy(srnamc_1.srnamt, "CTPCON", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
ctpcon_("/", "U", "N", &c__0, a, &rcond, w, rw, &info);
chkxer_("CTPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ctpcon_("1", "/", "N", &c__0, a, &rcond, w, rw, &info);
chkxer_("CTPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
ctpcon_("1", "U", "/", &c__0, a, &rcond, w, rw, &info);
chkxer_("CTPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ctpcon_("1", "U", "N", &c_n1, a, &rcond, w, rw, &info);
chkxer_("CTPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CLATPS */
s_copy(srnamc_1.srnamt, "CLATPS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
clatps_("/", "N", "N", "N", &c__0, a, x, &scale, rw, &info);
chkxer_("CLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
clatps_("U", "/", "N", "N", &c__0, a, x, &scale, rw, &info);
chkxer_("CLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
clatps_("U", "N", "/", "N", &c__0, a, x, &scale, rw, &info);
chkxer_("CLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
clatps_("U", "N", "N", "/", &c__0, a, x, &scale, rw, &info);
chkxer_("CLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
clatps_("U", "N", "N", "N", &c_n1, a, x, &scale, rw, &info);
chkxer_("CLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* Test error exits for the banded triangular routines. */
} else if (lsamen_(&c__2, c2, "TB")) {
/* CTBTRS */
s_copy(srnamc_1.srnamt, "CTBTRS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
ctbtrs_("/", "N", "N", &c__0, &c__0, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("CTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ctbtrs_("U", "/", "N", &c__0, &c__0, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("CTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
ctbtrs_("U", "N", "/", &c__0, &c__0, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("CTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ctbtrs_("U", "N", "N", &c_n1, &c__0, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("CTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
ctbtrs_("U", "N", "N", &c__0, &c_n1, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("CTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
ctbtrs_("U", "N", "N", &c__0, &c__0, &c_n1, a, &c__1, x, &c__1, &info);
chkxer_("CTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
ctbtrs_("U", "N", "N", &c__2, &c__1, &c__1, a, &c__1, x, &c__2, &info);
chkxer_("CTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
ctbtrs_("U", "N", "N", &c__2, &c__0, &c__1, a, &c__1, x, &c__1, &info);
chkxer_("CTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CTBRFS */
s_copy(srnamc_1.srnamt, "CTBRFS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
ctbrfs_("/", "N", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, x, &
c__1, r1, r2, w, rw, &info);
chkxer_("CTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ctbrfs_("U", "/", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, x, &
c__1, r1, r2, w, rw, &info);
chkxer_("CTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
ctbrfs_("U", "N", "/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, x, &
c__1, r1, r2, w, rw, &info);
chkxer_("CTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ctbrfs_("U", "N", "N", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, x, &
c__1, r1, r2, w, rw, &info);
chkxer_("CTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
ctbrfs_("U", "N", "N", &c__0, &c_n1, &c__0, a, &c__1, b, &c__1, x, &
c__1, r1, r2, w, rw, &info);
chkxer_("CTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
ctbrfs_("U", "N", "N", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, x, &
c__1, r1, r2, w, rw, &info);
chkxer_("CTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
ctbrfs_("U", "N", "N", &c__2, &c__1, &c__1, a, &c__1, b, &c__2, x, &
c__2, r1, r2, w, rw, &info);
chkxer_("CTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
ctbrfs_("U", "N", "N", &c__2, &c__1, &c__1, a, &c__2, b, &c__1, x, &
c__2, r1, r2, w, rw, &info);
chkxer_("CTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
ctbrfs_("U", "N", "N", &c__2, &c__1, &c__1, a, &c__2, b, &c__2, x, &
c__1, r1, r2, w, rw, &info);
chkxer_("CTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CTBCON */
s_copy(srnamc_1.srnamt, "CTBCON", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
ctbcon_("/", "U", "N", &c__0, &c__0, a, &c__1, &rcond, w, rw, &info);
chkxer_("CTBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
ctbcon_("1", "/", "N", &c__0, &c__0, a, &c__1, &rcond, w, rw, &info);
chkxer_("CTBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
ctbcon_("1", "U", "/", &c__0, &c__0, a, &c__1, &rcond, w, rw, &info);
chkxer_("CTBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
ctbcon_("1", "U", "N", &c_n1, &c__0, a, &c__1, &rcond, w, rw, &info);
chkxer_("CTBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
ctbcon_("1", "U", "N", &c__0, &c_n1, a, &c__1, &rcond, w, rw, &info);
chkxer_("CTBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
ctbcon_("1", "U", "N", &c__2, &c__1, a, &c__1, &rcond, w, rw, &info);
chkxer_("CTBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CLATBS */
s_copy(srnamc_1.srnamt, "CLATBS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
clatbs_("/", "N", "N", "N", &c__0, &c__0, a, &c__1, x, &scale, rw, &
info);
chkxer_("CLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
clatbs_("U", "/", "N", "N", &c__0, &c__0, a, &c__1, x, &scale, rw, &
info);
chkxer_("CLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
clatbs_("U", "N", "/", "N", &c__0, &c__0, a, &c__1, x, &scale, rw, &
info);
chkxer_("CLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
clatbs_("U", "N", "N", "/", &c__0, &c__0, a, &c__1, x, &scale, rw, &
info);
chkxer_("CLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
clatbs_("U", "N", "N", "N", &c_n1, &c__0, a, &c__1, x, &scale, rw, &
info);
chkxer_("CLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
clatbs_("U", "N", "N", "N", &c__1, &c_n1, a, &c__1, x, &scale, rw, &
info);
chkxer_("CLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
clatbs_("U", "N", "N", "N", &c__2, &c__1, a, &c__1, x, &scale, rw, &
info);
chkxer_("CLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
}
/* Print a summary line. */
alaesm_(path, &infoc_1.ok, &infoc_1.nout);
return 0;
/* End of CERRTR */
} /* cerrtr_ */
/* Subroutine */
int cpocon_(char *uplo, integer *n, complex *a, integer *lda, real *anorm, 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;
real scale;
extern logical lsame_(char *, char *);
integer isave[3];
logical upper;
extern /* Subroutine */
int clacn2_(integer *, complex *, complex *, real *, integer *, integer *);
extern integer icamax_(integer *, complex *, integer *);
real scalel;
extern real slamch_(char *);
real scaleu;
extern /* Subroutine */
int xerbla_(char *, integer *);
real ainvnm;
extern /* Subroutine */
int clatrs_(char *, char *, char *, char *, integer *, complex *, integer *, complex *, real *, real *, integer *), csrscl_(integer *, real *, complex *, integer *);
char normin[1];
real smlnum;
/* -- 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 */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--work;
--rwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*lda < max(1,*n))
{
*info = -4;
}
else if (*anorm < 0.f)
{
*info = -5;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CPOCON", &i__1);
return 0;
}
/* Quick return if possible */
*rcond = 0.f;
if (*n == 0)
{
*rcond = 1.f;
return 0;
}
else if (*anorm == 0.f)
{
return 0;
}
smlnum = slamch_("Safe minimum");
/* Estimate the 1-norm of inv(A). */
kase = 0;
*(unsigned char *)normin = 'N';
L10:
clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
if (kase != 0)
{
if (upper)
{
/* Multiply by inv(U**H). */
clatrs_("Upper", "Conjugate transpose", "Non-unit", normin, n, &a[ a_offset], lda, &work[1], &scalel, &rwork[1], info);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(U). */
clatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[ a_offset], lda, &work[1], &scaleu, &rwork[1], info);
}
else
{
/* Multiply by inv(L). */
clatrs_("Lower", "No transpose", "Non-unit", normin, n, &a[ a_offset], lda, &work[1], &scalel, &rwork[1], info);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(L**H). */
clatrs_("Lower", "Conjugate transpose", "Non-unit", normin, n, &a[ a_offset], lda, &work[1], &scaleu, &rwork[1], info);
}
/* Multiply by 1/SCALE if doing so will not cause overflow. */
scale = scalel * scaleu;
if (scale != 1.f)
{
ix = icamax_(n, &work[1], &c__1);
i__1 = ix;
if (scale < ((r__1 = work[i__1].r, abs(r__1)) + (r__2 = r_imag(& work[ix]), abs(r__2))) * 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 / ainvnm / *anorm;
}
L20:
return 0;
/* End of CPOCON */
}
/* Subroutine */ int cgecon_(char *norm, integer *n, complex *a, integer *lda,
real *anorm, real *rcond, complex *work, real *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1;
real r__1, r__2;
/* Local variables */
real sl;
integer ix;
real su;
integer kase, kase1;
real scale;
integer isave[3];
real ainvnm;
logical onenrm;
char normin[1];
real smlnum;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
/* Purpose */
/* ======= */
/* CGECON estimates the reciprocal of the condition number of a general */
/* complex matrix A, in either the 1-norm or the infinity-norm, using */
/* the LU factorization computed by CGETRF. */
/* An estimate is obtained for norm(inv(A)), and 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. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The factors L and U from the factorization A = P*L*U */
/* as computed by CGETRF. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* ANORM (input) REAL */
/* If NORM = '1' or 'O', the 1-norm of the original matrix A. */
/* If NORM = 'I', the infinity-norm of the original matrix A. */
/* 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 (2*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 */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--work;
--rwork;
/* Function Body */
*info = 0;
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
if (! onenrm && ! lsame_(norm, "I")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
} else if (*anorm < 0.f) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGECON", &i__1);
return 0;
}
/* Quick return if possible */
*rcond = 0.f;
if (*n == 0) {
*rcond = 1.f;
return 0;
} else if (*anorm == 0.f) {
return 0;
}
smlnum = slamch_("Safe minimum");
/* Estimate the norm of inv(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(L). */
clatrs_("Lower", "No transpose", "Unit", normin, n, &a[a_offset],
lda, &work[1], &sl, &rwork[1], info);
/* Multiply by inv(U). */
clatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[
a_offset], lda, &work[1], &su, &rwork[*n + 1], info);
} else {
/* Multiply by inv(U'). */
clatrs_("Upper", "Conjugate transpose", "Non-unit", normin, n, &a[
a_offset], lda, &work[1], &su, &rwork[*n + 1], info);
/* Multiply by inv(L'). */
clatrs_("Lower", "Conjugate transpose", "Unit", normin, n, &a[
a_offset], lda, &work[1], &sl, &rwork[1], info);
}
/* Divide X by 1/(SL*SU) if doing so will not cause overflow. */
scale = sl * su;
*(unsigned char *)normin = 'Y';
if (scale != 1.f) {
ix = icamax_(n, &work[1], &c__1);
i__1 = ix;
if (scale < ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(&
work[ix]), dabs(r__2))) * 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 / ainvnm / *anorm;
}
L20:
return 0;
/* End of CGECON */
} /* cgecon_ */
