complex
cdotc (int n, complex *cx, int incx, complex *cy, int incy)
{
complex result ;
cdotc_ ( &result, &n, cx, &incx, cy, &incy );
return result ;
}
void
f2c_cdotc(complex* retval,
integer* N,
complex* X, integer* incX,
complex* Y, integer* incY)
{
cdotc_(retval, N, X, incX, Y, incY);
}
complex cdotc( int n, complex *x, int incx, complex *y, int incy)
{
complex ans;
#if defined( _WIN32 ) || defined( _WIN64 )
ans = cdotc_(&n, x, &incx, y, &incy);
#else
cdotcsub_(&n, x, &incx, y, &incy, &ans);
#endif
return ans;
}
/* Subroutine */ int cppt01_(char *uplo, integer *n, complex *a, complex *
afac, real *rwork, real *resid)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
real r__1;
complex q__1;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
integer i__, k, kc;
complex tc;
real tr, eps;
extern /* Subroutine */ int chpr_(char *, integer *, real *, complex *,
integer *, complex *), cscal_(integer *, complex *,
complex *, integer *);
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
real anorm;
extern /* Subroutine */ int ctpmv_(char *, char *, char *, integer *,
complex *, complex *, integer *);
extern doublereal clanhp_(char *, char *, integer *, complex *, real *), slamch_(char *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CPPT01 reconstructs a Hermitian positive definite packed matrix A */
/* from its L*L' or U'*U factorization and computes the residual */
/* norm( L*L' - A ) / ( N * norm(A) * EPS ) or */
/* norm( U'*U - A ) / ( N * norm(A) * EPS ), */
/* where EPS is the machine epsilon, L' is the conjugate transpose of */
/* L, and U' is the conjugate transpose of U. */
/* Arguments */
/* ========== */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The number of rows and columns of the matrix A. N >= 0. */
/* A (input) COMPLEX array, dimension (N*(N+1)/2) */
/* The original Hermitian matrix A, stored as a packed */
/* triangular matrix. */
/* AFAC (input/output) COMPLEX array, dimension (N*(N+1)/2) */
/* On entry, the factor L or U from the L*L' or U'*U */
/* factorization of A, stored as a packed triangular matrix. */
/* Overwritten with the reconstructed matrix, and then with the */
/* difference L*L' - A (or U'*U - A). */
/* RWORK (workspace) REAL array, dimension (N) */
/* RESID (output) REAL */
/* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
/* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0 */
/* Parameter adjustments */
--rwork;
--afac;
--a;
/* Function Body */
if (*n <= 0) {
*resid = 0.f;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = slamch_("Epsilon");
anorm = clanhp_("1", uplo, n, &a[1], &rwork[1]);
if (anorm <= 0.f) {
*resid = 1.f / eps;
return 0;
}
/* Check the imaginary parts of the diagonal elements and return with */
/* an error code if any are nonzero. */
kc = 1;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (r_imag(&afac[kc]) != 0.f) {
*resid = 1.f / eps;
return 0;
}
kc = kc + k + 1;
/* L10: */
}
} else {
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (r_imag(&afac[kc]) != 0.f) {
*resid = 1.f / eps;
return 0;
}
kc = kc + *n - k + 1;
/* L20: */
}
}
/* Compute the product U'*U, overwriting U. */
if (lsame_(uplo, "U")) {
kc = *n * (*n - 1) / 2 + 1;
for (k = *n; k >= 1; --k) {
/* Compute the (K,K) element of the result. */
cdotc_(&q__1, &k, &afac[kc], &c__1, &afac[kc], &c__1);
tr = q__1.r;
i__1 = kc + k - 1;
afac[i__1].r = tr, afac[i__1].i = 0.f;
/* Compute the rest of column K. */
if (k > 1) {
i__1 = k - 1;
ctpmv_("Upper", "Conjugate", "Non-unit", &i__1, &afac[1], &
afac[kc], &c__1);
kc -= k - 1;
}
/* L30: */
}
/* Compute the difference L*L' - A */
kc = 1;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
i__2 = k - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = kc + i__ - 1;
i__4 = kc + i__ - 1;
i__5 = kc + i__ - 1;
q__1.r = afac[i__4].r - a[i__5].r, q__1.i = afac[i__4].i - a[
i__5].i;
afac[i__3].r = q__1.r, afac[i__3].i = q__1.i;
/* L40: */
}
i__2 = kc + k - 1;
i__3 = kc + k - 1;
i__4 = kc + k - 1;
r__1 = a[i__4].r;
q__1.r = afac[i__3].r - r__1, q__1.i = afac[i__3].i;
afac[i__2].r = q__1.r, afac[i__2].i = q__1.i;
kc += k;
/* L50: */
}
/* Compute the product L*L', overwriting L. */
} else {
kc = *n * (*n + 1) / 2;
for (k = *n; k >= 1; --k) {
/* Add a multiple of column K of the factor L to each of */
/* columns K+1 through N. */
if (k < *n) {
i__1 = *n - k;
chpr_("Lower", &i__1, &c_b19, &afac[kc + 1], &c__1, &afac[kc
+ *n - k + 1]);
}
/* Scale column K by the diagonal element. */
i__1 = kc;
tc.r = afac[i__1].r, tc.i = afac[i__1].i;
i__1 = *n - k + 1;
cscal_(&i__1, &tc, &afac[kc], &c__1);
kc -= *n - k + 2;
/* L60: */
}
/* Compute the difference U'*U - A */
kc = 1;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
i__2 = kc;
i__3 = kc;
i__4 = kc;
r__1 = a[i__4].r;
q__1.r = afac[i__3].r - r__1, q__1.i = afac[i__3].i;
afac[i__2].r = q__1.r, afac[i__2].i = q__1.i;
i__2 = *n;
for (i__ = k + 1; i__ <= i__2; ++i__) {
i__3 = kc + i__ - k;
i__4 = kc + i__ - k;
i__5 = kc + i__ - k;
q__1.r = afac[i__4].r - a[i__5].r, q__1.i = afac[i__4].i - a[
i__5].i;
afac[i__3].r = q__1.r, afac[i__3].i = q__1.i;
/* L70: */
}
kc = kc + *n - k + 1;
/* L80: */
}
}
/* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */
*resid = clanhp_("1", uplo, n, &afac[1], &rwork[1]);
*resid = *resid / (real) (*n) / anorm / eps;
return 0;
/* End of CPPT01 */
} /* cppt01_ */
/* Subroutine */ int claic1_(integer *job, integer *j, complex *x, real *sest,
complex *w, complex *gamma, real *sestpr, complex *s, complex *c__)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
CLAIC1 applies one step of incremental condition estimation in
its simplest version:
Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j
lower triangular matrix L, such that
twonorm(L*x) = sest
Then CLAIC1 computes sestpr, s, c such that
the vector
[ s*x ]
xhat = [ c ]
is an approximate singular vector of
[ L 0 ]
Lhat = [ w' gamma ]
in the sense that
twonorm(Lhat*xhat) = sestpr.
Depending on JOB, an estimate for the largest or smallest singular
value is computed.
Note that [s c]' and sestpr**2 is an eigenpair of the system
diag(sest*sest, 0) + [alpha gamma] * [ conjg(alpha) ]
[ conjg(gamma) ]
where alpha = conjg(x)'*w.
Arguments
=========
JOB (input) INTEGER
= 1: an estimate for the largest singular value is computed.
= 2: an estimate for the smallest singular value is computed.
J (input) INTEGER
Length of X and W
X (input) COMPLEX array, dimension (J)
The j-vector x.
SEST (input) REAL
Estimated singular value of j by j matrix L
W (input) COMPLEX array, dimension (J)
The j-vector w.
GAMMA (input) COMPLEX
The diagonal element gamma.
SESTPR (output) REAL
Estimated singular value of (j+1) by (j+1) matrix Lhat.
S (output) COMPLEX
Sine needed in forming xhat.
C (output) COMPLEX
Cosine needed in forming xhat.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
real r__1, r__2;
complex q__1, q__2, q__3, q__4, q__5, q__6;
/* Builtin functions */
double c_abs(complex *);
void r_cnjg(complex *, complex *), c_sqrt(complex *, complex *);
double sqrt(doublereal);
void c_div(complex *, complex *, complex *);
/* Local variables */
static complex sine;
static real test, zeta1, zeta2, b, t;
static complex alpha;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
static real norma, s1, s2, absgam, absalp;
extern doublereal slamch_(char *);
static complex cosine;
static real absest, scl, eps, tmp;
--w;
--x;
/* Function Body */
eps = slamch_("Epsilon");
cdotc_(&q__1, j, &x[1], &c__1, &w[1], &c__1);
alpha.r = q__1.r, alpha.i = q__1.i;
absalp = c_abs(&alpha);
absgam = c_abs(gamma);
absest = dabs(*sest);
if (*job == 1) {
/* Estimating largest singular value
special cases */
if (*sest == 0.f) {
s1 = dmax(absgam,absalp);
if (s1 == 0.f) {
s->r = 0.f, s->i = 0.f;
c__->r = 1.f, c__->i = 0.f;
*sestpr = 0.f;
} else {
q__1.r = alpha.r / s1, q__1.i = alpha.i / s1;
s->r = q__1.r, s->i = q__1.i;
q__1.r = gamma->r / s1, q__1.i = gamma->i / s1;
c__->r = q__1.r, c__->i = q__1.i;
r_cnjg(&q__4, s);
q__3.r = s->r * q__4.r - s->i * q__4.i, q__3.i = s->r *
q__4.i + s->i * q__4.r;
r_cnjg(&q__6, c__);
q__5.r = c__->r * q__6.r - c__->i * q__6.i, q__5.i = c__->r *
q__6.i + c__->i * q__6.r;
q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
c_sqrt(&q__1, &q__2);
tmp = q__1.r;
q__1.r = s->r / tmp, q__1.i = s->i / tmp;
s->r = q__1.r, s->i = q__1.i;
q__1.r = c__->r / tmp, q__1.i = c__->i / tmp;
c__->r = q__1.r, c__->i = q__1.i;
*sestpr = s1 * tmp;
}
return 0;
} else if (absgam <= eps * absest) {
s->r = 1.f, s->i = 0.f;
c__->r = 0.f, c__->i = 0.f;
tmp = dmax(absest,absalp);
s1 = absest / tmp;
s2 = absalp / tmp;
*sestpr = tmp * sqrt(s1 * s1 + s2 * s2);
return 0;
} else if (absalp <= eps * absest) {
s1 = absgam;
s2 = absest;
if (s1 <= s2) {
s->r = 1.f, s->i = 0.f;
c__->r = 0.f, c__->i = 0.f;
*sestpr = s2;
} else {
s->r = 0.f, s->i = 0.f;
c__->r = 1.f, c__->i = 0.f;
*sestpr = s1;
}
return 0;
} else if (absest <= eps * absalp || absest <= eps * absgam) {
s1 = absgam;
s2 = absalp;
if (s1 <= s2) {
tmp = s1 / s2;
scl = sqrt(tmp * tmp + 1.f);
*sestpr = s2 * scl;
q__2.r = alpha.r / s2, q__2.i = alpha.i / s2;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
s->r = q__1.r, s->i = q__1.i;
q__2.r = gamma->r / s2, q__2.i = gamma->i / s2;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
c__->r = q__1.r, c__->i = q__1.i;
} else {
tmp = s2 / s1;
scl = sqrt(tmp * tmp + 1.f);
*sestpr = s1 * scl;
q__2.r = alpha.r / s1, q__2.i = alpha.i / s1;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
s->r = q__1.r, s->i = q__1.i;
q__2.r = gamma->r / s1, q__2.i = gamma->i / s1;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
c__->r = q__1.r, c__->i = q__1.i;
}
return 0;
} else {
/* normal case */
zeta1 = absalp / absest;
zeta2 = absgam / absest;
b = (1.f - zeta1 * zeta1 - zeta2 * zeta2) * .5f;
r__1 = zeta1 * zeta1;
c__->r = r__1, c__->i = 0.f;
if (b > 0.f) {
r__1 = b * b;
q__4.r = r__1 + c__->r, q__4.i = c__->i;
c_sqrt(&q__3, &q__4);
q__2.r = b + q__3.r, q__2.i = q__3.i;
c_div(&q__1, c__, &q__2);
t = q__1.r;
} else {
r__1 = b * b;
q__3.r = r__1 + c__->r, q__3.i = c__->i;
c_sqrt(&q__2, &q__3);
q__1.r = q__2.r - b, q__1.i = q__2.i;
t = q__1.r;
}
q__3.r = alpha.r / absest, q__3.i = alpha.i / absest;
q__2.r = -q__3.r, q__2.i = -q__3.i;
q__1.r = q__2.r / t, q__1.i = q__2.i / t;
sine.r = q__1.r, sine.i = q__1.i;
q__3.r = gamma->r / absest, q__3.i = gamma->i / absest;
q__2.r = -q__3.r, q__2.i = -q__3.i;
r__1 = t + 1.f;
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
cosine.r = q__1.r, cosine.i = q__1.i;
r_cnjg(&q__4, &sine);
q__3.r = sine.r * q__4.r - sine.i * q__4.i, q__3.i = sine.r *
q__4.i + sine.i * q__4.r;
r_cnjg(&q__6, &cosine);
q__5.r = cosine.r * q__6.r - cosine.i * q__6.i, q__5.i = cosine.r
* q__6.i + cosine.i * q__6.r;
q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
c_sqrt(&q__1, &q__2);
tmp = q__1.r;
q__1.r = sine.r / tmp, q__1.i = sine.i / tmp;
s->r = q__1.r, s->i = q__1.i;
q__1.r = cosine.r / tmp, q__1.i = cosine.i / tmp;
c__->r = q__1.r, c__->i = q__1.i;
*sestpr = sqrt(t + 1.f) * absest;
return 0;
}
} else if (*job == 2) {
/* Estimating smallest singular value
special cases */
if (*sest == 0.f) {
*sestpr = 0.f;
if (dmax(absgam,absalp) == 0.f) {
sine.r = 1.f, sine.i = 0.f;
cosine.r = 0.f, cosine.i = 0.f;
} else {
r_cnjg(&q__2, gamma);
q__1.r = -q__2.r, q__1.i = -q__2.i;
sine.r = q__1.r, sine.i = q__1.i;
r_cnjg(&q__1, &alpha);
cosine.r = q__1.r, cosine.i = q__1.i;
}
/* Computing MAX */
r__1 = c_abs(&sine), r__2 = c_abs(&cosine);
s1 = dmax(r__1,r__2);
q__1.r = sine.r / s1, q__1.i = sine.i / s1;
s->r = q__1.r, s->i = q__1.i;
q__1.r = cosine.r / s1, q__1.i = cosine.i / s1;
c__->r = q__1.r, c__->i = q__1.i;
r_cnjg(&q__4, s);
q__3.r = s->r * q__4.r - s->i * q__4.i, q__3.i = s->r * q__4.i +
s->i * q__4.r;
r_cnjg(&q__6, c__);
q__5.r = c__->r * q__6.r - c__->i * q__6.i, q__5.i = c__->r *
q__6.i + c__->i * q__6.r;
q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
c_sqrt(&q__1, &q__2);
tmp = q__1.r;
q__1.r = s->r / tmp, q__1.i = s->i / tmp;
s->r = q__1.r, s->i = q__1.i;
q__1.r = c__->r / tmp, q__1.i = c__->i / tmp;
c__->r = q__1.r, c__->i = q__1.i;
return 0;
} else if (absgam <= eps * absest) {
s->r = 0.f, s->i = 0.f;
c__->r = 1.f, c__->i = 0.f;
*sestpr = absgam;
return 0;
} else if (absalp <= eps * absest) {
s1 = absgam;
s2 = absest;
if (s1 <= s2) {
s->r = 0.f, s->i = 0.f;
c__->r = 1.f, c__->i = 0.f;
*sestpr = s1;
} else {
s->r = 1.f, s->i = 0.f;
c__->r = 0.f, c__->i = 0.f;
*sestpr = s2;
}
return 0;
} else if (absest <= eps * absalp || absest <= eps * absgam) {
s1 = absgam;
s2 = absalp;
if (s1 <= s2) {
tmp = s1 / s2;
scl = sqrt(tmp * tmp + 1.f);
*sestpr = absest * (tmp / scl);
r_cnjg(&q__4, gamma);
q__3.r = q__4.r / s2, q__3.i = q__4.i / s2;
q__2.r = -q__3.r, q__2.i = -q__3.i;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
s->r = q__1.r, s->i = q__1.i;
r_cnjg(&q__3, &alpha);
q__2.r = q__3.r / s2, q__2.i = q__3.i / s2;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
c__->r = q__1.r, c__->i = q__1.i;
} else {
tmp = s2 / s1;
scl = sqrt(tmp * tmp + 1.f);
*sestpr = absest / scl;
r_cnjg(&q__4, gamma);
q__3.r = q__4.r / s1, q__3.i = q__4.i / s1;
q__2.r = -q__3.r, q__2.i = -q__3.i;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
s->r = q__1.r, s->i = q__1.i;
r_cnjg(&q__3, &alpha);
q__2.r = q__3.r / s1, q__2.i = q__3.i / s1;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
c__->r = q__1.r, c__->i = q__1.i;
}
return 0;
} else {
/* normal case */
zeta1 = absalp / absest;
zeta2 = absgam / absest;
/* Computing MAX */
r__1 = zeta1 * zeta1 + 1.f + zeta1 * zeta2, r__2 = zeta1 * zeta2
+ zeta2 * zeta2;
norma = dmax(r__1,r__2);
/* See if root is closer to zero or to ONE */
test = (zeta1 - zeta2) * 2.f * (zeta1 + zeta2) + 1.f;
if (test >= 0.f) {
/* root is close to zero, compute directly */
b = (zeta1 * zeta1 + zeta2 * zeta2 + 1.f) * .5f;
r__1 = zeta2 * zeta2;
c__->r = r__1, c__->i = 0.f;
r__2 = b * b;
q__2.r = r__2 - c__->r, q__2.i = -c__->i;
r__1 = b + sqrt(c_abs(&q__2));
q__1.r = c__->r / r__1, q__1.i = c__->i / r__1;
t = q__1.r;
q__2.r = alpha.r / absest, q__2.i = alpha.i / absest;
r__1 = 1.f - t;
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
sine.r = q__1.r, sine.i = q__1.i;
q__3.r = gamma->r / absest, q__3.i = gamma->i / absest;
q__2.r = -q__3.r, q__2.i = -q__3.i;
q__1.r = q__2.r / t, q__1.i = q__2.i / t;
cosine.r = q__1.r, cosine.i = q__1.i;
*sestpr = sqrt(t + eps * 4.f * eps * norma) * absest;
} else {
/* root is closer to ONE, shift by that amount */
b = (zeta2 * zeta2 + zeta1 * zeta1 - 1.f) * .5f;
r__1 = zeta1 * zeta1;
c__->r = r__1, c__->i = 0.f;
if (b >= 0.f) {
q__2.r = -c__->r, q__2.i = -c__->i;
r__1 = b * b;
q__5.r = r__1 + c__->r, q__5.i = c__->i;
c_sqrt(&q__4, &q__5);
q__3.r = b + q__4.r, q__3.i = q__4.i;
c_div(&q__1, &q__2, &q__3);
t = q__1.r;
} else {
r__1 = b * b;
q__3.r = r__1 + c__->r, q__3.i = c__->i;
c_sqrt(&q__2, &q__3);
q__1.r = b - q__2.r, q__1.i = -q__2.i;
t = q__1.r;
}
q__3.r = alpha.r / absest, q__3.i = alpha.i / absest;
q__2.r = -q__3.r, q__2.i = -q__3.i;
q__1.r = q__2.r / t, q__1.i = q__2.i / t;
sine.r = q__1.r, sine.i = q__1.i;
q__3.r = gamma->r / absest, q__3.i = gamma->i / absest;
q__2.r = -q__3.r, q__2.i = -q__3.i;
r__1 = t + 1.f;
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
cosine.r = q__1.r, cosine.i = q__1.i;
*sestpr = sqrt(t + 1.f + eps * 4.f * eps * norma) * absest;
}
r_cnjg(&q__4, &sine);
q__3.r = sine.r * q__4.r - sine.i * q__4.i, q__3.i = sine.r *
q__4.i + sine.i * q__4.r;
r_cnjg(&q__6, &cosine);
q__5.r = cosine.r * q__6.r - cosine.i * q__6.i, q__5.i = cosine.r
* q__6.i + cosine.i * q__6.r;
q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
c_sqrt(&q__1, &q__2);
tmp = q__1.r;
q__1.r = sine.r / tmp, q__1.i = sine.i / tmp;
s->r = q__1.r, s->i = q__1.i;
q__1.r = cosine.r / tmp, q__1.i = cosine.i / tmp;
c__->r = q__1.r, c__->i = q__1.i;
return 0;
}
}
return 0;
/* End of CLAIC1 */
} /* claic1_ */
int ctgsna_(char *job, char *howmny, int *select,
int *n, complex *a, int *lda, complex *b, int *ldb,
complex *vl, int *ldvl, complex *vr, int *ldvr, float *s, float
*dif, int *mm, int *m, complex *work, int *lwork, int
*iwork, int *info)
{
/* System generated locals */
int a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
vr_offset, i__1;
float r__1, r__2;
complex q__1;
/* Builtin functions */
double c_abs(complex *);
/* Local variables */
int i__, k, n1, n2, ks;
float eps, cond;
int ierr, ifst;
float lnrm;
complex yhax, yhbx;
int ilst;
float rnrm, scale;
extern /* Complex */ VOID cdotc_(complex *, int *, complex *, int
*, complex *, int *);
extern int lsame_(char *, char *);
extern int cgemv_(char *, int *, int *, complex *
, complex *, int *, complex *, int *, complex *, complex *
, int *);
int lwmin;
int wants;
complex dummy[1];
extern double scnrm2_(int *, complex *, int *), slapy2_(float *
, float *);
complex dummy1[1];
extern int slabad_(float *, float *);
extern double slamch_(char *);
extern int clacpy_(char *, int *, int *, complex
*, int *, complex *, int *), ctgexc_(int *,
int *, int *, complex *, int *, complex *, int *,
complex *, int *, complex *, int *, int *, int *,
int *), xerbla_(char *, int *);
float bignum;
int wantbh, wantdf, somcon;
extern int ctgsyl_(char *, int *, int *, int
*, complex *, int *, complex *, int *, complex *, int
*, complex *, int *, complex *, int *, complex *, int
*, float *, float *, complex *, int *, int *, int *);
float smlnum;
int lquery;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CTGSNA estimates reciprocal condition numbers for specified */
/* eigenvalues and/or eigenvectors of a matrix pair (A, B). */
/* (A, B) must be in generalized Schur canonical form, that is, A and */
/* B are both upper triangular. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* Specifies whether condition numbers are required for */
/* eigenvalues (S) or eigenvectors (DIF): */
/* = 'E': for eigenvalues only (S); */
/* = 'V': for eigenvectors only (DIF); */
/* = 'B': for both eigenvalues and eigenvectors (S and DIF). */
/* 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 corresponding j-th eigenvalue and/or eigenvector, */
/* SELECT(j) must be set to .TRUE.. */
/* If HOWMNY = 'A', SELECT is not referenced. */
/* N (input) INTEGER */
/* The order of the square matrix pair (A, B). N >= 0. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The upper triangular matrix A in the pair (A,B). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,N). */
/* B (input) COMPLEX array, dimension (LDB,N) */
/* The upper triangular matrix B in the pair (A, B). */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= MAX(1,N). */
/* VL (input) COMPLEX array, dimension (LDVL,M) */
/* IF JOB = 'E' or 'B', VL must contain left eigenvectors of */
/* (A, B), corresponding to the eigenpairs specified by HOWMNY */
/* and SELECT. The eigenvectors must be stored in consecutive */
/* columns of VL, as returned by CTGEVC. */
/* 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 */
/* (A, B), corresponding to the eigenpairs specified by HOWMNY */
/* and SELECT. The eigenvectors must be stored in consecutive */
/* columns of VR, as returned by CTGEVC. */
/* If JOB = 'V', VR is not referenced. */
/* LDVR (input) INTEGER */
/* The leading dimension of the array VR. LDVR >= 1; */
/* 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. */
/* If JOB = 'V', S is not referenced. */
/* DIF (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 the eigenvalues cannot be reordered to compute DIF(j), */
/* DIF(j) is set to 0; this can only occur when the true value */
/* would be very small anyway. */
/* For each eigenvalue/vector specified by SELECT, DIF stores */
/* a Frobenius norm-based estimate of Difl. */
/* If JOB = 'E', DIF is not referenced. */
/* MM (input) INTEGER */
/* The number of elements in the arrays S and DIF. MM >= M. */
/* M (output) INTEGER */
/* The number of elements of the arrays S and DIF used to store */
/* the specified condition numbers; for each selected eigenvalue */
/* one element is used. If HOWMNY = 'A', M is set to N. */
/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= MAX(1,N). */
/* If JOB = 'V' or 'B', LWORK >= MAX(1,2*N*N). */
/* IWORK (workspace) INTEGER array, dimension (N+2) */
/* If JOB = 'E', IWORK 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 the i-th generalized */
/* eigenvalue w = (a, b) is defined as */
/* S(I) = (|v'Au|**2 + |v'Bu|**2)**(1/2) / (norm(u)*norm(v)) */
/* where u and v are the right and left eigenvectors of (A, B) */
/* corresponding to w; |z| denotes the absolute value of the complex */
/* number, and norm(u) denotes the 2-norm of the vector u. The pair */
/* (a, b) corresponds to an eigenvalue w = a/b (= v'Au/v'Bu) of the */
/* matrix pair (A, B). If both a and b equal zero, then (A,B) is */
/* singular and S(I) = -1 is returned. */
/* An approximate error bound on the chordal distance between the i-th */
/* computed generalized eigenvalue w and the corresponding exact */
/* eigenvalue lambda is */
/* chord(w, lambda) <= EPS * norm(A, B) / S(I), */
/* where EPS is the machine precision. */
/* The reciprocal of the condition number of the right eigenvector u */
/* and left eigenvector v corresponding to the generalized eigenvalue w */
/* is defined as follows. Suppose */
/* (A, B) = ( a * ) ( b * ) 1 */
/* ( 0 A22 ),( 0 B22 ) n-1 */
/* 1 n-1 1 n-1 */
/* Then the reciprocal condition number DIF(I) is */
/* Difl[(a, b), (A22, B22)] = sigma-MIN( Zl ) */
/* where sigma-MIN(Zl) denotes the smallest singular value of */
/* Zl = [ kron(a, In-1) -kron(1, A22) ] */
/* [ kron(b, In-1) -kron(1, B22) ]. */
/* Here In-1 is the identity matrix of size n-1 and X' is the conjugate */
/* transpose of X. kron(X, Y) is the Kronecker product between the */
/* matrices X and Y. */
/* We approximate the smallest singular value of Zl with an upper */
/* bound. This is done by CLATDF. */
/* An approximate error bound for a computed eigenvector VL(i) or */
/* VR(i) is given by */
/* EPS * norm(A, B) / DIF(i). */
/* See ref. [2-3] for more details and further references. */
/* Based on contributions by */
/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
/* Umea University, S-901 87 Umea, Sweden. */
/* References */
/* ========== */
/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */
/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */
/* Estimation: Theory, Algorithms and Software, Report */
/* UMINF - 94.04, Department of Computing Science, Umea University, */
/* S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87. */
/* To appear in Numerical Algorithms, 1996. */
/* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */
/* for Solving the Generalized Sylvester Equation and Estimating the */
/* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */
/* Department of Computing Science, Umea University, S-901 87 Umea, */
/* Sweden, December 1993, Revised April 1994, Also as LAPACK Working */
/* Note 75. */
/* To appear in ACM Trans. on Math. Software, Vol 22, No 1, 1996. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and test the input parameters */
/* Parameter adjustments */
--select;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--s;
--dif;
--work;
--iwork;
/* Function Body */
wantbh = lsame_(job, "B");
wants = lsame_(job, "E") || wantbh;
wantdf = lsame_(job, "V") || wantbh;
somcon = lsame_(howmny, "S");
*info = 0;
lquery = *lwork == -1;
if (! wants && ! wantdf) {
*info = -1;
} else if (! lsame_(howmny, "A") && ! somcon) {
*info = -2;
} else if (*n < 0) {
*info = -4;
} else if (*lda < MAX(1,*n)) {
*info = -6;
} else if (*ldb < MAX(1,*n)) {
*info = -8;
} else if (wants && *ldvl < *n) {
*info = -10;
} else if (wants && *ldvr < *n) {
*info = -12;
} else {
/* Set M to the number of eigenpairs for which condition numbers */
/* are required, and test MM. */
if (somcon) {
*m = 0;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (select[k]) {
++(*m);
}
/* L10: */
}
} else {
*m = *n;
}
if (*n == 0) {
lwmin = 1;
} else if (lsame_(job, "V") || lsame_(job,
"B")) {
lwmin = (*n << 1) * *n;
} else {
lwmin = *n;
}
work[1].r = (float) lwmin, work[1].i = 0.f;
if (*mm < *m) {
*info = -15;
} else if (*lwork < lwmin && ! lquery) {
*info = -18;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTGSNA", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = slamch_("P");
smlnum = slamch_("S") / eps;
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
ks = 0;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Determine whether condition numbers are required for the k-th */
/* eigenpair. */
if (somcon) {
if (! select[k]) {
goto L20;
}
}
++ks;
if (wants) {
/* Compute the reciprocal condition number of the k-th */
/* eigenvalue. */
rnrm = scnrm2_(n, &vr[ks * vr_dim1 + 1], &c__1);
lnrm = scnrm2_(n, &vl[ks * vl_dim1 + 1], &c__1);
cgemv_("N", n, n, &c_b19, &a[a_offset], lda, &vr[ks * vr_dim1 + 1]
, &c__1, &c_b20, &work[1], &c__1);
cdotc_(&q__1, n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &c__1);
yhax.r = q__1.r, yhax.i = q__1.i;
cgemv_("N", n, n, &c_b19, &b[b_offset], ldb, &vr[ks * vr_dim1 + 1]
, &c__1, &c_b20, &work[1], &c__1);
cdotc_(&q__1, n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &c__1);
yhbx.r = q__1.r, yhbx.i = q__1.i;
r__1 = c_abs(&yhax);
r__2 = c_abs(&yhbx);
cond = slapy2_(&r__1, &r__2);
if (cond == 0.f) {
s[ks] = -1.f;
} else {
s[ks] = cond / (rnrm * lnrm);
}
}
if (wantdf) {
if (*n == 1) {
r__1 = c_abs(&a[a_dim1 + 1]);
r__2 = c_abs(&b[b_dim1 + 1]);
dif[ks] = slapy2_(&r__1, &r__2);
} else {
/* Estimate the reciprocal condition number of the k-th */
/* eigenvectors. */
/* Copy the matrix (A, B) to the array WORK and move the */
/* (k,k)th pair to the (1,1) position. */
clacpy_("Full", n, n, &a[a_offset], lda, &work[1], n);
clacpy_("Full", n, n, &b[b_offset], ldb, &work[*n * *n + 1],
n);
ifst = k;
ilst = 1;
ctgexc_(&c_false, &c_false, n, &work[1], n, &work[*n * *n + 1]
, n, dummy, &c__1, dummy1, &c__1, &ifst, &ilst, &ierr)
;
if (ierr > 0) {
/* Ill-conditioned problem - swap rejected. */
dif[ks] = 0.f;
} else {
/* Reordering successful, solve generalized Sylvester */
/* equation for R and L, */
/* A22 * R - L * A11 = A12 */
/* B22 * R - L * B11 = B12, */
/* and compute estimate of Difl[(A11,B11), (A22, B22)]. */
n1 = 1;
n2 = *n - n1;
i__ = *n * *n + 1;
ctgsyl_("N", &c__3, &n2, &n1, &work[*n * n1 + n1 + 1], n,
&work[1], n, &work[n1 + 1], n, &work[*n * n1 + n1
+ i__], n, &work[i__], n, &work[n1 + i__], n, &
scale, &dif[ks], dummy, &c__1, &iwork[1], &ierr);
}
}
}
L20:
;
}
work[1].r = (float) lwmin, work[1].i = 0.f;
return 0;
/* End of CTGSNA */
} /* ctgsna_ */
/* Subroutine */ int chpgst_(integer *itype, char *uplo, integer *n, complex *
ap, complex *bp, integer *info, ftnlen uplo_len)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4;
real r__1, r__2;
complex q__1, q__2, q__3;
/* Local variables */
static integer j, k, j1, k1, jj, kk;
static complex ct;
static real ajj;
static integer j1j1;
static real akk;
static integer k1k1;
static real bjj, bkk;
extern /* Subroutine */ int chpr2_(char *, integer *, complex *, complex *
, integer *, complex *, integer *, complex *, ftnlen);
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int chpmv_(char *, integer *, complex *, complex *
, complex *, integer *, complex *, complex *, integer *, ftnlen),
caxpy_(integer *, complex *, complex *, integer *, complex *,
integer *), ctpmv_(char *, char *, char *, integer *, complex *,
complex *, integer *, ftnlen, ftnlen, ftnlen);
static logical upper;
extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *,
complex *, complex *, integer *, ftnlen, ftnlen, ftnlen), csscal_(
integer *, real *, complex *, integer *), xerbla_(char *, integer
*, ftnlen);
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHPGST reduces a complex Hermitian-definite generalized */
/* eigenproblem to standard form, using packed storage. */
/* If ITYPE = 1, the problem is A*x = lambda*B*x, */
/* and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H) */
/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */
/* B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L. */
/* B must have been previously factorized as U**H*U or L*L**H by CPPTRF. */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H); */
/* = 2 or 3: compute U*A*U**H or L**H*A*L. */
/* UPLO (input) CHARACTER */
/* = 'U': Upper triangle of A is stored and B is factored as */
/* U**H*U; */
/* = 'L': Lower triangle of A is stored and B is factored as */
/* L*L**H. */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the Hermitian matrix */
/* A, packed columnwise in a linear array. The j-th column of A */
/* is stored in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
/* On exit, if INFO = 0, the transformed matrix, stored in the */
/* same format as A. */
/* BP (input) COMPLEX array, dimension (N*(N+1)/2) */
/* The triangular factor from the Cholesky factorization of B, */
/* stored in the same format as A, as returned by CPPTRF. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--bp;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
*info = -2;
} else if (*n < 0) {
*info = -3;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHPGST", &i__1, (ftnlen)6);
return 0;
}
if (*itype == 1) {
if (upper) {
/* Compute inv(U')*A*inv(U) */
/* J1 and JJ are the indices of A(1,j) and A(j,j) */
jj = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
j1 = jj + 1;
jj += j;
/* Compute the j-th column of the upper triangle of A */
i__2 = jj;
i__3 = jj;
r__1 = ap[i__3].r;
ap[i__2].r = r__1, ap[i__2].i = 0.f;
i__2 = jj;
bjj = bp[i__2].r;
ctpsv_(uplo, "Conjugate transpose", "Non-unit", &j, &bp[1], &
ap[j1], &c__1, (ftnlen)1, (ftnlen)19, (ftnlen)8);
i__2 = j - 1;
q__1.r = -1.f, q__1.i = -0.f;
chpmv_(uplo, &i__2, &q__1, &ap[1], &bp[j1], &c__1, &c_b1, &ap[
j1], &c__1, (ftnlen)1);
i__2 = j - 1;
r__1 = 1.f / bjj;
csscal_(&i__2, &r__1, &ap[j1], &c__1);
i__2 = jj;
i__3 = jj;
i__4 = j - 1;
cdotc_(&q__3, &i__4, &ap[j1], &c__1, &bp[j1], &c__1);
q__2.r = ap[i__3].r - q__3.r, q__2.i = ap[i__3].i - q__3.i;
q__1.r = q__2.r / bjj, q__1.i = q__2.i / bjj;
ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
/* L10: */
}
} else {
/* Compute inv(L)*A*inv(L') */
/* KK and K1K1 are the indices of A(k,k) and A(k+1,k+1) */
kk = 1;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
k1k1 = kk + *n - k + 1;
/* Update the lower triangle of A(k:n,k:n) */
i__2 = kk;
akk = ap[i__2].r;
i__2 = kk;
bkk = bp[i__2].r;
/* Computing 2nd power */
r__1 = bkk;
akk /= r__1 * r__1;
i__2 = kk;
ap[i__2].r = akk, ap[i__2].i = 0.f;
if (k < *n) {
i__2 = *n - k;
r__1 = 1.f / bkk;
csscal_(&i__2, &r__1, &ap[kk + 1], &c__1);
r__1 = akk * -.5f;
ct.r = r__1, ct.i = 0.f;
i__2 = *n - k;
caxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1)
;
i__2 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
chpr2_(uplo, &i__2, &q__1, &ap[kk + 1], &c__1, &bp[kk + 1]
, &c__1, &ap[k1k1], (ftnlen)1);
i__2 = *n - k;
caxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1)
;
i__2 = *n - k;
ctpsv_(uplo, "No transpose", "Non-unit", &i__2, &bp[k1k1],
&ap[kk + 1], &c__1, (ftnlen)1, (ftnlen)12, (
ftnlen)8);
}
kk = k1k1;
/* L20: */
}
}
} else {
if (upper) {
/* Compute U*A*U' */
/* K1 and KK are the indices of A(1,k) and A(k,k) */
kk = 0;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
k1 = kk + 1;
kk += k;
/* Update the upper triangle of A(1:k,1:k) */
i__2 = kk;
akk = ap[i__2].r;
i__2 = kk;
bkk = bp[i__2].r;
i__2 = k - 1;
ctpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[
k1], &c__1, (ftnlen)1, (ftnlen)12, (ftnlen)8);
r__1 = akk * .5f;
ct.r = r__1, ct.i = 0.f;
i__2 = k - 1;
caxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
i__2 = k - 1;
chpr2_(uplo, &i__2, &c_b1, &ap[k1], &c__1, &bp[k1], &c__1, &
ap[1], (ftnlen)1);
i__2 = k - 1;
caxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
i__2 = k - 1;
csscal_(&i__2, &bkk, &ap[k1], &c__1);
i__2 = kk;
/* Computing 2nd power */
r__2 = bkk;
r__1 = akk * (r__2 * r__2);
ap[i__2].r = r__1, ap[i__2].i = 0.f;
/* L30: */
}
} else {
/* Compute L'*A*L */
/* JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1) */
jj = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
j1j1 = jj + *n - j + 1;
/* Compute the j-th column of the lower triangle of A */
i__2 = jj;
ajj = ap[i__2].r;
i__2 = jj;
bjj = bp[i__2].r;
i__2 = jj;
r__1 = ajj * bjj;
i__3 = *n - j;
cdotc_(&q__2, &i__3, &ap[jj + 1], &c__1, &bp[jj + 1], &c__1);
q__1.r = r__1 + q__2.r, q__1.i = q__2.i;
ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
i__2 = *n - j;
csscal_(&i__2, &bjj, &ap[jj + 1], &c__1);
i__2 = *n - j;
chpmv_(uplo, &i__2, &c_b1, &ap[j1j1], &bp[jj + 1], &c__1, &
c_b1, &ap[jj + 1], &c__1, (ftnlen)1);
i__2 = *n - j + 1;
ctpmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &bp[jj]
, &ap[jj], &c__1, (ftnlen)1, (ftnlen)19, (ftnlen)8);
jj = j1j1;
/* L40: */
}
}
}
return 0;
/* End of CHPGST */
} /* chpgst_ */
/* Subroutine */ int clagsy_(integer *n, integer *k, real *d__, complex *a,
integer *lda, integer *iseed, complex *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8,
i__9;
real r__1;
complex q__1, q__2, q__3, q__4;
/* Local variables */
integer i__, j, ii, jj;
complex wa, wb;
real wn;
complex tau;
complex alpha;
/* -- LAPACK auxiliary test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLAGSY generates a complex symmetric matrix A, by pre- and post- */
/* multiplying a real diagonal matrix D with a random unitary matrix: */
/* A = U*D*U**T. The semi-bandwidth may then be reduced to k by */
/* additional unitary transformations. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* K (input) INTEGER */
/* The number of nonzero subdiagonals within the band of A. */
/* 0 <= K <= N-1. */
/* D (input) REAL array, dimension (N) */
/* The diagonal elements of the diagonal matrix D. */
/* A (output) COMPLEX array, dimension (LDA,N) */
/* The generated n by n symmetric matrix A (the full matrix is */
/* stored). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= N. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry, the seed of the random number generator; the array */
/* elements must be between 0 and 4095, and ISEED(4) must be */
/* odd. */
/* On exit, the seed is updated. */
/* WORK (workspace) COMPLEX 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 Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
--d__;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--iseed;
--work;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*k < 0 || *k > *n - 1) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info < 0) {
i__1 = -(*info);
xerbla_("CLAGSY", &i__1);
return 0;
}
/* initialize lower triangle of A to diagonal matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
/* L10: */
}
/* L20: */
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + i__ * a_dim1;
i__3 = i__;
a[i__2].r = d__[i__3], a[i__2].i = 0.f;
/* L30: */
}
/* Generate lower triangle of symmetric matrix */
for (i__ = *n - 1; i__ >= 1; --i__) {
/* generate random reflection */
i__1 = *n - i__ + 1;
clarnv_(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *n - i__ + 1;
wn = scnrm2_(&i__1, &work[1], &c__1);
r__1 = wn / c_abs(&work[1]);
q__1.r = r__1 * work[1].r, q__1.i = r__1 * work[1].i;
wa.r = q__1.r, wa.i = q__1.i;
if (wn == 0.f) {
tau.r = 0.f, tau.i = 0.f;
} else {
q__1.r = work[1].r + wa.r, q__1.i = work[1].i + wa.i;
wb.r = q__1.r, wb.i = q__1.i;
i__1 = *n - i__;
c_div(&q__1, &c_b2, &wb);
cscal_(&i__1, &q__1, &work[2], &c__1);
work[1].r = 1.f, work[1].i = 0.f;
c_div(&q__1, &wb, &wa);
r__1 = q__1.r;
tau.r = r__1, tau.i = 0.f;
}
/* apply random reflection to A(i:n,i:n) from the left */
/* and the right */
/* compute y := tau * A * conjg(u) */
i__1 = *n - i__ + 1;
clacgv_(&i__1, &work[1], &c__1);
i__1 = *n - i__ + 1;
csymv_("Lower", &i__1, &tau, &a[i__ + i__ * a_dim1], lda, &work[1], &
c__1, &c_b1, &work[*n + 1], &c__1);
i__1 = *n - i__ + 1;
clacgv_(&i__1, &work[1], &c__1);
/* compute v := y - 1/2 * tau * ( u, y ) * u */
q__3.r = -.5f, q__3.i = -0.f;
q__2.r = q__3.r * tau.r - q__3.i * tau.i, q__2.i = q__3.r * tau.i +
q__3.i * tau.r;
i__1 = *n - i__ + 1;
cdotc_(&q__4, &i__1, &work[1], &c__1, &work[*n + 1], &c__1);
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i
+ q__2.i * q__4.r;
alpha.r = q__1.r, alpha.i = q__1.i;
i__1 = *n - i__ + 1;
caxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1);
/* apply the transformation as a rank-2 update to A(i:n,i:n) */
/* CALL CSYR2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1, */
/* $ A( I, I ), LDA ) */
i__1 = *n;
for (jj = i__; jj <= i__1; ++jj) {
i__2 = *n;
for (ii = jj; ii <= i__2; ++ii) {
i__3 = ii + jj * a_dim1;
i__4 = ii + jj * a_dim1;
i__5 = ii - i__ + 1;
i__6 = *n + jj - i__ + 1;
q__3.r = work[i__5].r * work[i__6].r - work[i__5].i * work[
i__6].i, q__3.i = work[i__5].r * work[i__6].i + work[
i__5].i * work[i__6].r;
q__2.r = a[i__4].r - q__3.r, q__2.i = a[i__4].i - q__3.i;
i__7 = *n + ii - i__ + 1;
i__8 = jj - i__ + 1;
q__4.r = work[i__7].r * work[i__8].r - work[i__7].i * work[
i__8].i, q__4.i = work[i__7].r * work[i__8].i + work[
i__7].i * work[i__8].r;
q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
a[i__3].r = q__1.r, a[i__3].i = q__1.i;
/* L40: */
}
/* L50: */
}
/* L60: */
}
/* Reduce number of subdiagonals to K */
i__1 = *n - 1 - *k;
for (i__ = 1; i__ <= i__1; ++i__) {
/* generate reflection to annihilate A(k+i+1:n,i) */
i__2 = *n - *k - i__ + 1;
wn = scnrm2_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1);
r__1 = wn / c_abs(&a[*k + i__ + i__ * a_dim1]);
i__2 = *k + i__ + i__ * a_dim1;
q__1.r = r__1 * a[i__2].r, q__1.i = r__1 * a[i__2].i;
wa.r = q__1.r, wa.i = q__1.i;
if (wn == 0.f) {
tau.r = 0.f, tau.i = 0.f;
} else {
i__2 = *k + i__ + i__ * a_dim1;
q__1.r = a[i__2].r + wa.r, q__1.i = a[i__2].i + wa.i;
wb.r = q__1.r, wb.i = q__1.i;
i__2 = *n - *k - i__;
c_div(&q__1, &c_b2, &wb);
cscal_(&i__2, &q__1, &a[*k + i__ + 1 + i__ * a_dim1], &c__1);
i__2 = *k + i__ + i__ * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
c_div(&q__1, &wb, &wa);
r__1 = q__1.r;
tau.r = r__1, tau.i = 0.f;
}
/* apply reflection to A(k+i:n,i+1:k+i-1) from the left */
i__2 = *n - *k - i__ + 1;
i__3 = *k - 1;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ + (i__
+ 1) * a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &
c_b1, &work[1], &c__1);
i__2 = *n - *k - i__ + 1;
i__3 = *k - 1;
q__1.r = -tau.r, q__1.i = -tau.i;
cgerc_(&i__2, &i__3, &q__1, &a[*k + i__ + i__ * a_dim1], &c__1, &work[
1], &c__1, &a[*k + i__ + (i__ + 1) * a_dim1], lda);
/* apply reflection to A(k+i:n,k+i:n) from the left and the right */
/* compute y := tau * A * conjg(u) */
i__2 = *n - *k - i__ + 1;
clacgv_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1);
i__2 = *n - *k - i__ + 1;
csymv_("Lower", &i__2, &tau, &a[*k + i__ + (*k + i__) * a_dim1], lda,
&a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &work[1], &c__1);
i__2 = *n - *k - i__ + 1;
clacgv_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1);
/* compute v := y - 1/2 * tau * ( u, y ) * u */
q__3.r = -.5f, q__3.i = -0.f;
q__2.r = q__3.r * tau.r - q__3.i * tau.i, q__2.i = q__3.r * tau.i +
q__3.i * tau.r;
i__2 = *n - *k - i__ + 1;
cdotc_(&q__4, &i__2, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], &
c__1);
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i
+ q__2.i * q__4.r;
alpha.r = q__1.r, alpha.i = q__1.i;
i__2 = *n - *k - i__ + 1;
caxpy_(&i__2, &alpha, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], &
c__1);
/* apply symmetric rank-2 update to A(k+i:n,k+i:n) */
/* CALL CSYR2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1, */
/* $ A( K+I, K+I ), LDA ) */
i__2 = *n;
for (jj = *k + i__; jj <= i__2; ++jj) {
i__3 = *n;
for (ii = jj; ii <= i__3; ++ii) {
i__4 = ii + jj * a_dim1;
i__5 = ii + jj * a_dim1;
i__6 = ii + i__ * a_dim1;
i__7 = jj - *k - i__ + 1;
q__3.r = a[i__6].r * work[i__7].r - a[i__6].i * work[i__7].i,
q__3.i = a[i__6].r * work[i__7].i + a[i__6].i * work[
i__7].r;
q__2.r = a[i__5].r - q__3.r, q__2.i = a[i__5].i - q__3.i;
i__8 = ii - *k - i__ + 1;
i__9 = jj + i__ * a_dim1;
q__4.r = work[i__8].r * a[i__9].r - work[i__8].i * a[i__9].i,
q__4.i = work[i__8].r * a[i__9].i + work[i__8].i * a[
i__9].r;
q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
a[i__4].r = q__1.r, a[i__4].i = q__1.i;
/* L70: */
}
/* L80: */
}
i__2 = *k + i__ + i__ * a_dim1;
q__1.r = -wa.r, q__1.i = -wa.i;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
i__2 = *n;
for (j = *k + i__ + 1; j <= i__2; ++j) {
i__3 = j + i__ * a_dim1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
/* L90: */
}
/* L100: */
}
/* Store full symmetric matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = j + i__ * a_dim1;
i__4 = i__ + j * a_dim1;
a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i;
/* L110: */
}
/* L120: */
}
return 0;
/* End of CLAGSY */
} /* clagsy_ */
/* Subroutine */ int cgbcon_(char *norm, integer *n, integer *kl, integer *ku,
complex *ab, integer *ldab, integer *ipiv, real *anorm, real *rcond,
complex *work, real *rwork, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3;
real r__1, r__2;
complex q__1, q__2;
/* Local variables */
integer j;
complex t;
integer kd, lm, jp, ix, kase, kase1;
real scale;
integer isave[3];
logical lnoti;
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 */
/* ======= */
/* CGBCON estimates the reciprocal of the condition number of a complex */
/* general band matrix A, in either the 1-norm or the infinity-norm, */
/* using the LU factorization computed by CGBTRF. */
/* 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. */
/* KL (input) INTEGER */
/* The number of subdiagonals within the band of A. KL >= 0. */
/* KU (input) INTEGER */
/* The number of superdiagonals within the band of A. KU >= 0. */
/* AB (input) COMPLEX array, dimension (LDAB,N) */
/* Details of the LU factorization of the band matrix A, as */
/* computed by CGBTRF. U is stored as an upper triangular band */
/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */
/* the multipliers used during the factorization are stored in */
/* rows KL+KU+2 to 2*KL+KU+1. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices; for 1 <= i <= N, row i of the matrix was */
/* interchanged with row IPIV(i). */
/* 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 (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 */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--ipiv;
--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 (*kl < 0) {
*info = -3;
} else if (*ku < 0) {
*info = -4;
} else if (*ldab < (*kl << 1) + *ku + 1) {
*info = -6;
} else if (*anorm < 0.f) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGBCON", &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;
}
kd = *kl + *ku + 1;
lnoti = *kl > 0;
kase = 0;
L10:
clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(L). */
if (lnoti) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__2 = *kl, i__3 = *n - j;
lm = min(i__2,i__3);
jp = ipiv[j];
i__2 = jp;
t.r = work[i__2].r, t.i = work[i__2].i;
if (jp != j) {
i__2 = jp;
i__3 = j;
work[i__2].r = work[i__3].r, work[i__2].i = work[i__3]
.i;
i__2 = j;
work[i__2].r = t.r, work[i__2].i = t.i;
}
q__1.r = -t.r, q__1.i = -t.i;
caxpy_(&lm, &q__1, &ab[kd + 1 + j * ab_dim1], &c__1, &
work[j + 1], &c__1);
}
}
/* Multiply by inv(U). */
i__1 = *kl + *ku;
clatbs_("Upper", "No transpose", "Non-unit", normin, n, &i__1, &
ab[ab_offset], ldab, &work[1], &scale, &rwork[1], info);
} else {
/* Multiply by inv(U'). */
i__1 = *kl + *ku;
clatbs_("Upper", "Conjugate transpose", "Non-unit", normin, n, &
i__1, &ab[ab_offset], ldab, &work[1], &scale, &rwork[1],
info);
/* Multiply by inv(L'). */
if (lnoti) {
for (j = *n - 1; j >= 1; --j) {
/* Computing MIN */
i__1 = *kl, i__2 = *n - j;
lm = min(i__1,i__2);
i__1 = j;
i__2 = j;
cdotc_(&q__2, &lm, &ab[kd + 1 + j * ab_dim1], &c__1, &
work[j + 1], &c__1);
q__1.r = work[i__2].r - q__2.r, q__1.i = work[i__2].i -
q__2.i;
work[i__1].r = q__1.r, work[i__1].i = q__1.i;
jp = ipiv[j];
if (jp != j) {
i__1 = jp;
t.r = work[i__1].r, t.i = work[i__1].i;
i__1 = jp;
i__2 = j;
work[i__1].r = work[i__2].r, work[i__1].i = work[i__2]
.i;
i__1 = j;
work[i__1].r = t.r, work[i__1].i = t.i;
}
}
}
}
/* Divide X by 1/SCALE if doing so will not cause overflow. */
*(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 L40;
}
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;
}
L40:
return 0;
/* End of CGBCON */
} /* cgbcon_ */
/* DECK CGECO */
/* Subroutine */ int cgeco_(complex *a, integer *lda, integer *n, integer *
ipvt, real *rcond, complex *z__)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8;
complex q__1, q__2, q__3, q__4;
/* Local variables */
static integer j, k, l;
static real s;
static complex t;
static integer kb;
static complex ek;
static real sm;
static complex wk;
static integer kp1;
static complex wkm;
static integer info;
extern /* Subroutine */ int cgefa_(complex *, integer *, integer *,
integer *, integer *);
extern /* Complex */ void cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
static real anorm;
extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
static real ynorm;
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*);
extern doublereal scasum_(integer *, complex *, integer *);
/* ***BEGIN PROLOGUE CGECO */
/* ***PURPOSE Factor a matrix using Gaussian elimination and estimate */
/* the condition number of the matrix. */
/* ***LIBRARY SLATEC (LINPACK) */
/* ***CATEGORY D2C1 */
/* ***TYPE COMPLEX (SGECO-S, DGECO-D, CGECO-C) */
/* ***KEYWORDS CONDITION NUMBER, GENERAL MATRIX, LINEAR ALGEBRA, LINPACK, */
/* MATRIX FACTORIZATION */
/* ***AUTHOR Moler, C. B., (U. of New Mexico) */
/* ***DESCRIPTION */
/* CGECO factors a complex matrix by Gaussian elimination */
/* and estimates the condition of the matrix. */
/* If RCOND is not needed, CGEFA is slightly faster. */
/* To solve A*X = B , follow CGECO By CGESL. */
/* To Compute INVERSE(A)*C , follow CGECO by CGESL. */
/* To compute DETERMINANT(A) , follow CGECO by CGEDI. */
/* To compute INVERSE(A) , follow CGECO by CGEDI. */
/* On Entry */
/* A COMPLEX(LDA, N) */
/* the matrix to be factored. */
/* LDA INTEGER */
/* the leading dimension of the array A . */
/* N INTEGER */
/* the order of the matrix A . */
/* On Return */
/* A an upper triangular matrix and the multipliers */
/* which were used to obtain it. */
/* The factorization can be written A = L*U where */
/* L is a product of permutation and unit lower */
/* triangular matrices and U is upper triangular. */
/* IPVT INTEGER(N) */
/* an integer vector of pivot indices. */
/* RCOND REAL */
/* an estimate of the reciprocal condition of A . */
/* For the system A*X = B , relative perturbations */
/* in A and B of size EPSILON may cause */
/* relative perturbations in X of size EPSILON/RCOND . */
/* If RCOND is so small that the logical expression */
/* 1.0 + RCOND .EQ. 1.0 */
/* is true, then A may be singular to working */
/* precision. In particular, RCOND is zero if */
/* exact singularity is detected or the estimate */
/* underflows. */
/* Z COMPLEX(N) */
/* a work vector whose contents are usually unimportant. */
/* If A is close to a singular matrix, then Z is */
/* an approximate null vector in the sense that */
/* NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . */
/* ***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. */
/* Stewart, LINPACK Users' Guide, SIAM, 1979. */
/* ***ROUTINES CALLED CAXPY, CDOTC, CGEFA, CSSCAL, SCASUM */
/* ***REVISION HISTORY (YYMMDD) */
/* 780814 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890831 Modified array declarations. (WRB) */
/* 890831 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900326 Removed duplicate information from DESCRIPTION section. */
/* (WRB) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE CGECO */
/* COMPUTE 1-NORM OF A */
/* ***FIRST EXECUTABLE STATEMENT CGECO */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipvt;
--z__;
/* Function Body */
anorm = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__1 = anorm, r__2 = scasum_(n, &a[j * a_dim1 + 1], &c__1);
anorm = dmax(r__1,r__2);
/* L10: */
}
/* FACTOR */
cgefa_(&a[a_offset], lda, n, &ipvt[1], &info);
/* RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . */
/* ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND CTRANS(A)*Y = E . */
/* CTRANS(A) IS THE CONJUGATE TRANSPOSE OF A . */
/* THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL */
/* GROWTH IN THE ELEMENTS OF W WHERE CTRANS(U)*W = E . */
/* THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. */
/* SOLVE CTRANS(U)*W = E */
ek.r = 1.f, ek.i = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
z__[i__2].r = 0.f, z__[i__2].i = 0.f;
/* L20: */
}
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
i__2 = k;
if ((r__1 = z__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&z__[k]), dabs(
r__2)) != 0.f) {
i__3 = k;
q__2.r = -z__[i__3].r, q__2.i = -z__[i__3].i;
q__1.r = q__2.r, q__1.i = q__2.i;
r__7 = (r__3 = ek.r, dabs(r__3)) + (r__4 = r_imag(&ek), dabs(r__4)
);
r__8 = (r__5 = q__1.r, dabs(r__5)) + (r__6 = r_imag(&q__1), dabs(
r__6));
q__4.r = q__1.r / r__8, q__4.i = q__1.i / r__8;
q__3.r = r__7 * q__4.r, q__3.i = r__7 * q__4.i;
ek.r = q__3.r, ek.i = q__3.i;
}
i__2 = k;
q__2.r = ek.r - z__[i__2].r, q__2.i = ek.i - z__[i__2].i;
q__1.r = q__2.r, q__1.i = q__2.i;
i__3 = k + k * a_dim1;
if ((r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1), dabs(r__2))
<= (r__3 = a[i__3].r, dabs(r__3)) + (r__4 = r_imag(&a[k + k *
a_dim1]), dabs(r__4))) {
goto L30;
}
i__2 = k;
q__2.r = ek.r - z__[i__2].r, q__2.i = ek.i - z__[i__2].i;
q__1.r = q__2.r, q__1.i = q__2.i;
i__3 = k + k * a_dim1;
s = ((r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[k + k *
a_dim1]), dabs(r__2))) / ((r__3 = q__1.r, dabs(r__3)) + (r__4
= r_imag(&q__1), dabs(r__4)));
csscal_(n, &s, &z__[1], &c__1);
q__2.r = s, q__2.i = 0.f;
q__1.r = q__2.r * ek.r - q__2.i * ek.i, q__1.i = q__2.r * ek.i +
q__2.i * ek.r;
ek.r = q__1.r, ek.i = q__1.i;
L30:
i__2 = k;
q__1.r = ek.r - z__[i__2].r, q__1.i = ek.i - z__[i__2].i;
wk.r = q__1.r, wk.i = q__1.i;
q__2.r = -ek.r, q__2.i = -ek.i;
i__2 = k;
q__1.r = q__2.r - z__[i__2].r, q__1.i = q__2.i - z__[i__2].i;
wkm.r = q__1.r, wkm.i = q__1.i;
s = (r__1 = wk.r, dabs(r__1)) + (r__2 = r_imag(&wk), dabs(r__2));
sm = (r__1 = wkm.r, dabs(r__1)) + (r__2 = r_imag(&wkm), dabs(r__2));
i__2 = k + k * a_dim1;
if ((r__1 = a[i__2].r, dabs(r__1)) + (r__2 = r_imag(&a[k + k * a_dim1]
), dabs(r__2)) == 0.f) {
goto L40;
}
r_cnjg(&q__2, &a[k + k * a_dim1]);
c_div(&q__1, &wk, &q__2);
wk.r = q__1.r, wk.i = q__1.i;
r_cnjg(&q__2, &a[k + k * a_dim1]);
c_div(&q__1, &wkm, &q__2);
wkm.r = q__1.r, wkm.i = q__1.i;
goto L50;
L40:
wk.r = 1.f, wk.i = 0.f;
wkm.r = 1.f, wkm.i = 0.f;
L50:
kp1 = k + 1;
if (kp1 > *n) {
goto L90;
}
i__2 = *n;
for (j = kp1; j <= i__2; ++j) {
i__3 = j;
r_cnjg(&q__4, &a[k + j * a_dim1]);
q__3.r = wkm.r * q__4.r - wkm.i * q__4.i, q__3.i = wkm.r * q__4.i
+ wkm.i * q__4.r;
q__2.r = z__[i__3].r + q__3.r, q__2.i = z__[i__3].i + q__3.i;
q__1.r = q__2.r, q__1.i = q__2.i;
sm += (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1), dabs(
r__2));
i__3 = j;
i__4 = j;
r_cnjg(&q__3, &a[k + j * a_dim1]);
q__2.r = wk.r * q__3.r - wk.i * q__3.i, q__2.i = wk.r * q__3.i +
wk.i * q__3.r;
q__1.r = z__[i__4].r + q__2.r, q__1.i = z__[i__4].i + q__2.i;
z__[i__3].r = q__1.r, z__[i__3].i = q__1.i;
i__3 = j;
s += (r__1 = z__[i__3].r, dabs(r__1)) + (r__2 = r_imag(&z__[j]),
dabs(r__2));
/* L60: */
}
if (s >= sm) {
goto L80;
}
q__1.r = wkm.r - wk.r, q__1.i = wkm.i - wk.i;
t.r = q__1.r, t.i = q__1.i;
wk.r = wkm.r, wk.i = wkm.i;
i__2 = *n;
for (j = kp1; j <= i__2; ++j) {
i__3 = j;
i__4 = j;
r_cnjg(&q__3, &a[k + j * a_dim1]);
q__2.r = t.r * q__3.r - t.i * q__3.i, q__2.i = t.r * q__3.i + t.i
* q__3.r;
q__1.r = z__[i__4].r + q__2.r, q__1.i = z__[i__4].i + q__2.i;
z__[i__3].r = q__1.r, z__[i__3].i = q__1.i;
/* L70: */
}
L80:
L90:
i__2 = k;
z__[i__2].r = wk.r, z__[i__2].i = wk.i;
/* L100: */
}
s = 1.f / scasum_(n, &z__[1], &c__1);
csscal_(n, &s, &z__[1], &c__1);
/* SOLVE CTRANS(L)*Y = W */
i__1 = *n;
for (kb = 1; kb <= i__1; ++kb) {
k = *n + 1 - kb;
if (k < *n) {
i__2 = k;
i__3 = k;
i__4 = *n - k;
cdotc_(&q__2, &i__4, &a[k + 1 + k * a_dim1], &c__1, &z__[k + 1], &
c__1);
q__1.r = z__[i__3].r + q__2.r, q__1.i = z__[i__3].i + q__2.i;
z__[i__2].r = q__1.r, z__[i__2].i = q__1.i;
}
i__2 = k;
if ((r__1 = z__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&z__[k]), dabs(
r__2)) <= 1.f) {
goto L110;
}
i__2 = k;
s = 1.f / ((r__1 = z__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&z__[k]),
dabs(r__2)));
csscal_(n, &s, &z__[1], &c__1);
L110:
l = ipvt[k];
i__2 = l;
t.r = z__[i__2].r, t.i = z__[i__2].i;
i__2 = l;
i__3 = k;
z__[i__2].r = z__[i__3].r, z__[i__2].i = z__[i__3].i;
i__2 = k;
z__[i__2].r = t.r, z__[i__2].i = t.i;
/* L120: */
}
s = 1.f / scasum_(n, &z__[1], &c__1);
csscal_(n, &s, &z__[1], &c__1);
ynorm = 1.f;
/* SOLVE L*V = Y */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
l = ipvt[k];
i__2 = l;
t.r = z__[i__2].r, t.i = z__[i__2].i;
i__2 = l;
i__3 = k;
z__[i__2].r = z__[i__3].r, z__[i__2].i = z__[i__3].i;
i__2 = k;
z__[i__2].r = t.r, z__[i__2].i = t.i;
if (k < *n) {
i__2 = *n - k;
caxpy_(&i__2, &t, &a[k + 1 + k * a_dim1], &c__1, &z__[k + 1], &
c__1);
}
i__2 = k;
if ((r__1 = z__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&z__[k]), dabs(
r__2)) <= 1.f) {
goto L130;
}
i__2 = k;
s = 1.f / ((r__1 = z__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&z__[k]),
dabs(r__2)));
csscal_(n, &s, &z__[1], &c__1);
ynorm = s * ynorm;
L130:
/* L140: */
;
}
s = 1.f / scasum_(n, &z__[1], &c__1);
csscal_(n, &s, &z__[1], &c__1);
ynorm = s * ynorm;
/* SOLVE U*Z = V */
i__1 = *n;
for (kb = 1; kb <= i__1; ++kb) {
k = *n + 1 - kb;
i__2 = k;
i__3 = k + k * a_dim1;
if ((r__1 = z__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&z__[k]), dabs(
r__2)) <= (r__3 = a[i__3].r, dabs(r__3)) + (r__4 = r_imag(&a[
k + k * a_dim1]), dabs(r__4))) {
goto L150;
}
i__2 = k + k * a_dim1;
i__3 = k;
s = ((r__1 = a[i__2].r, dabs(r__1)) + (r__2 = r_imag(&a[k + k *
a_dim1]), dabs(r__2))) / ((r__3 = z__[i__3].r, dabs(r__3)) + (
r__4 = r_imag(&z__[k]), dabs(r__4)));
csscal_(n, &s, &z__[1], &c__1);
ynorm = s * ynorm;
L150:
i__2 = k + k * a_dim1;
if ((r__1 = a[i__2].r, dabs(r__1)) + (r__2 = r_imag(&a[k + k * a_dim1]
), dabs(r__2)) != 0.f) {
i__3 = k;
c_div(&q__1, &z__[k], &a[k + k * a_dim1]);
z__[i__3].r = q__1.r, z__[i__3].i = q__1.i;
}
i__2 = k + k * a_dim1;
if ((r__1 = a[i__2].r, dabs(r__1)) + (r__2 = r_imag(&a[k + k * a_dim1]
), dabs(r__2)) == 0.f) {
i__3 = k;
z__[i__3].r = 1.f, z__[i__3].i = 0.f;
}
i__2 = k;
q__1.r = -z__[i__2].r, q__1.i = -z__[i__2].i;
t.r = q__1.r, t.i = q__1.i;
i__2 = k - 1;
caxpy_(&i__2, &t, &a[k * a_dim1 + 1], &c__1, &z__[1], &c__1);
/* L160: */
}
/* MAKE ZNORM = 1.0 */
s = 1.f / scasum_(n, &z__[1], &c__1);
csscal_(n, &s, &z__[1], &c__1);
ynorm = s * ynorm;
if (anorm != 0.f) {
*rcond = ynorm / anorm;
}
if (anorm == 0.f) {
*rcond = 0.f;
}
return 0;
} /* cgeco_ */
/* Subroutine */ int cpbt01_(char *uplo, integer *n, integer *kd, complex *a,
integer *lda, complex *afac, integer *ldafac, real *rwork, real *
resid)
{
/* System generated locals */
integer a_dim1, a_offset, afac_dim1, afac_offset, i__1, i__2, i__3, i__4,
i__5;
complex q__1;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
integer i__, j, k, kc, ml, mu;
real akk, eps;
extern /* Subroutine */ int cher_(char *, integer *, real *, complex *,
integer *, complex *, integer *);
integer klen;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
real anorm;
extern /* Subroutine */ int ctrmv_(char *, char *, char *, integer *,
complex *, integer *, complex *, integer *);
extern doublereal clanhb_(char *, char *, integer *, integer *, complex *,
integer *, real *), slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CPBT01 reconstructs a Hermitian positive definite band matrix A from */
/* its L*L' or U'*U factorization and computes the residual */
/* norm( L*L' - A ) / ( N * norm(A) * EPS ) or */
/* norm( U'*U - A ) / ( N * norm(A) * EPS ), */
/* where EPS is the machine epsilon, L' is the conjugate transpose of */
/* L, and U' is the conjugate transpose of U. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The number of rows and columns of the matrix A. N >= 0. */
/* KD (input) INTEGER */
/* The number of super-diagonals of the matrix A if UPLO = 'U', */
/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The original Hermitian band matrix A. If UPLO = 'U', the */
/* upper triangular part of A is stored as a band matrix; if */
/* UPLO = 'L', the lower triangular part of A is stored. The */
/* columns of the appropriate triangle are stored in the columns */
/* of A and the diagonals of the triangle are stored in the rows */
/* of A. See CPBTRF for further details. */
/* LDA (input) INTEGER. */
/* The leading dimension of the array A. LDA >= max(1,KD+1). */
/* AFAC (input) COMPLEX array, dimension (LDAFAC,N) */
/* The factored form of the matrix A. AFAC contains the factor */
/* L or U from the L*L' or U'*U factorization in band storage */
/* format, as computed by CPBTRF. */
/* LDAFAC (input) INTEGER */
/* The leading dimension of the array AFAC. */
/* LDAFAC >= max(1,KD+1). */
/* RWORK (workspace) REAL array, dimension (N) */
/* RESID (output) REAL */
/* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
/* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
afac_dim1 = *ldafac;
afac_offset = 1 + afac_dim1;
afac -= afac_offset;
--rwork;
/* Function Body */
if (*n <= 0) {
*resid = 0.f;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = slamch_("Epsilon");
anorm = clanhb_("1", uplo, n, kd, &a[a_offset], lda, &rwork[1]);
if (anorm <= 0.f) {
*resid = 1.f / eps;
return 0;
}
/* Check the imaginary parts of the diagonal elements and return with */
/* an error code if any are nonzero. */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (r_imag(&afac[*kd + 1 + j * afac_dim1]) != 0.f) {
*resid = 1.f / eps;
return 0;
}
/* L10: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (r_imag(&afac[j * afac_dim1 + 1]) != 0.f) {
*resid = 1.f / eps;
return 0;
}
/* L20: */
}
}
/* Compute the product U'*U, overwriting U. */
if (lsame_(uplo, "U")) {
for (k = *n; k >= 1; --k) {
/* Computing MAX */
i__1 = 1, i__2 = *kd + 2 - k;
kc = max(i__1,i__2);
klen = *kd + 1 - kc;
/* Compute the (K,K) element of the result. */
i__1 = klen + 1;
cdotc_(&q__1, &i__1, &afac[kc + k * afac_dim1], &c__1, &afac[kc +
k * afac_dim1], &c__1);
akk = q__1.r;
i__1 = *kd + 1 + k * afac_dim1;
afac[i__1].r = akk, afac[i__1].i = 0.f;
/* Compute the rest of column K. */
if (klen > 0) {
i__1 = *ldafac - 1;
ctrmv_("Upper", "Conjugate", "Non-unit", &klen, &afac[*kd + 1
+ (k - klen) * afac_dim1], &i__1, &afac[kc + k *
afac_dim1], &c__1);
}
/* L30: */
}
/* UPLO = 'L': Compute the product L*L', overwriting L. */
} else {
for (k = *n; k >= 1; --k) {
/* Computing MIN */
i__1 = *kd, i__2 = *n - k;
klen = min(i__1,i__2);
/* Add a multiple of column K of the factor L to each of */
/* columns K+1 through N. */
if (klen > 0) {
i__1 = *ldafac - 1;
cher_("Lower", &klen, &c_b17, &afac[k * afac_dim1 + 2], &c__1,
&afac[(k + 1) * afac_dim1 + 1], &i__1);
}
/* Scale column K by the diagonal element. */
i__1 = k * afac_dim1 + 1;
akk = afac[i__1].r;
i__1 = klen + 1;
csscal_(&i__1, &akk, &afac[k * afac_dim1 + 1], &c__1);
/* L40: */
}
}
/* Compute the difference L*L' - A or U'*U - A. */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = 1, i__3 = *kd + 2 - j;
mu = max(i__2,i__3);
i__2 = *kd + 1;
for (i__ = mu; i__ <= i__2; ++i__) {
i__3 = i__ + j * afac_dim1;
i__4 = i__ + j * afac_dim1;
i__5 = i__ + j * a_dim1;
q__1.r = afac[i__4].r - a[i__5].r, q__1.i = afac[i__4].i - a[
i__5].i;
afac[i__3].r = q__1.r, afac[i__3].i = q__1.i;
/* L50: */
}
/* L60: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__2 = *kd + 1, i__3 = *n - j + 1;
ml = min(i__2,i__3);
i__2 = ml;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * afac_dim1;
i__4 = i__ + j * afac_dim1;
i__5 = i__ + j * a_dim1;
q__1.r = afac[i__4].r - a[i__5].r, q__1.i = afac[i__4].i - a[
i__5].i;
afac[i__3].r = q__1.r, afac[i__3].i = q__1.i;
/* L70: */
}
/* L80: */
}
}
/* Compute norm( L*L' - A ) / ( N * norm(A) * EPS ) */
*resid = clanhb_("1", uplo, n, kd, &afac[afac_offset], ldafac, &rwork[1]);
*resid = *resid / (real) (*n) / anorm / eps;
return 0;
/* End of CPBT01 */
} /* cpbt01_ */
int cpptri_(char *uplo, int *n, complex *ap, int *
info)
{
/* System generated locals */
int i__1, i__2, i__3;
float r__1;
complex q__1;
/* Local variables */
int j, jc, jj;
float ajj;
int jjn;
extern int chpr_(char *, int *, float *, complex *,
int *, complex *);
extern /* Complex */ VOID cdotc_(complex *, int *, complex *, int
*, complex *, int *);
extern int lsame_(char *, char *);
extern int ctpmv_(char *, char *, char *, int *,
complex *, complex *, int *);
int upper;
extern int csscal_(int *, float *, complex *, int
*), xerbla_(char *, int *), ctptri_(char *, char *,
int *, complex *, int *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CPPTRI computes the inverse of a complex Hermitian positive definite */
/* matrix A using the Cholesky factorization A = U**H*U or A = L*L**H */
/* computed by CPPTRF. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangular factor is stored in AP; */
/* = 'L': Lower triangular factor is stored in AP. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
/* On entry, the triangular factor U or L from the Cholesky */
/* factorization A = U**H*U or A = L*L**H, packed columnwise as */
/* a linear array. The j-th column of U or L is stored in the */
/* array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */
/* On exit, the upper or lower triangle of the (Hermitian) */
/* inverse of A, overwriting the input factor U or L. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the (i,i) element of the factor U or L is */
/* zero, and the inverse could not be computed. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CPPTRI", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Invert the triangular Cholesky factor U or L. */
ctptri_(uplo, "Non-unit", n, &ap[1], info);
if (*info > 0) {
return 0;
}
if (upper) {
/* Compute the product inv(U) * inv(U)'. */
jj = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
jc = jj + 1;
jj += j;
if (j > 1) {
i__2 = j - 1;
chpr_("Upper", &i__2, &c_b8, &ap[jc], &c__1, &ap[1]);
}
i__2 = jj;
ajj = ap[i__2].r;
csscal_(&j, &ajj, &ap[jc], &c__1);
/* L10: */
}
} else {
/* Compute the product inv(L)' * inv(L). */
jj = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
jjn = jj + *n - j + 1;
i__2 = jj;
i__3 = *n - j + 1;
cdotc_(&q__1, &i__3, &ap[jj], &c__1, &ap[jj], &c__1);
r__1 = q__1.r;
ap[i__2].r = r__1, ap[i__2].i = 0.f;
if (j < *n) {
i__2 = *n - j;
ctpmv_("Lower", "Conjugate transpose", "Non-unit", &i__2, &ap[
jjn], &ap[jj + 1], &c__1);
}
jj = jjn;
/* L20: */
}
}
return 0;
/* End of CPPTRI */
} /* cpptri_ */
/* Subroutine */ int ctgsna_(char *job, char *howmny, logical *select,
integer *n, complex *a, integer *lda, complex *b, integer *ldb,
complex *vl, integer *ldvl, complex *vr, integer *ldvr, real *s, real
*dif, integer *mm, integer *m, complex *work, integer *lwork, integer
*iwork, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
CTGSNA estimates reciprocal condition numbers for specified
eigenvalues and/or eigenvectors of a matrix pair (A, B).
(A, B) must be in generalized Schur canonical form, that is, A and
B are both upper triangular.
Arguments
=========
JOB (input) CHARACTER*1
Specifies whether condition numbers are required for
eigenvalues (S) or eigenvectors (DIF):
= 'E': for eigenvalues only (S);
= 'V': for eigenvectors only (DIF);
= 'B': for both eigenvalues and eigenvectors (S and DIF).
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 corresponding j-th eigenvalue and/or eigenvector,
SELECT(j) must be set to .TRUE..
If HOWMNY = 'A', SELECT is not referenced.
N (input) INTEGER
The order of the square matrix pair (A, B). N >= 0.
A (input) COMPLEX array, dimension (LDA,N)
The upper triangular matrix A in the pair (A,B).
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
B (input) COMPLEX array, dimension (LDB,N)
The upper triangular matrix B in the pair (A, B).
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
VL (input) COMPLEX array, dimension (LDVL,M)
IF JOB = 'E' or 'B', VL must contain left eigenvectors of
(A, B), corresponding to the eigenpairs specified by HOWMNY
and SELECT. The eigenvectors must be stored in consecutive
columns of VL, as returned by CTGEVC.
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
(A, B), corresponding to the eigenpairs specified by HOWMNY
and SELECT. The eigenvectors must be stored in consecutive
columns of VR, as returned by CTGEVC.
If JOB = 'V', VR is not referenced.
LDVR (input) INTEGER
The leading dimension of the array VR. LDVR >= 1;
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.
If JOB = 'V', S is not referenced.
DIF (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 the eigenvalues cannot be reordered to compute DIF(j),
DIF(j) is set to 0; this can only occur when the true value
would be very small anyway.
For each eigenvalue/vector specified by SELECT, DIF stores
a Frobenius norm-based estimate of Difl.
If JOB = 'E', DIF is not referenced.
MM (input) INTEGER
The number of elements in the arrays S and DIF. MM >= M.
M (output) INTEGER
The number of elements of the arrays S and DIF used to store
the specified condition numbers; for each selected eigenvalue
one element is used. If HOWMNY = 'A', M is set to N.
WORK (workspace/output) COMPLEX array, dimension (LWORK)
If JOB = 'E', WORK is not referenced. Otherwise,
on exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= 1.
If JOB = 'V' or 'B', LWORK >= 2*N*N.
IWORK (workspace) INTEGER array, dimension (N+2)
If JOB = 'E', IWORK 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 the i-th generalized
eigenvalue w = (a, b) is defined as
S(I) = (|v'Au|**2 + |v'Bu|**2)**(1/2) / (norm(u)*norm(v))
where u and v are the right and left eigenvectors of (A, B)
corresponding to w; |z| denotes the absolute value of the complex
number, and norm(u) denotes the 2-norm of the vector u. The pair
(a, b) corresponds to an eigenvalue w = a/b (= v'Au/v'Bu) of the
matrix pair (A, B). If both a and b equal zero, then (A,B) is
singular and S(I) = -1 is returned.
An approximate error bound on the chordal distance between the i-th
computed generalized eigenvalue w and the corresponding exact
eigenvalue lambda is
chord(w, lambda) <= EPS * norm(A, B) / S(I),
where EPS is the machine precision.
The reciprocal of the condition number of the right eigenvector u
and left eigenvector v corresponding to the generalized eigenvalue w
is defined as follows. Suppose
(A, B) = ( a * ) ( b * ) 1
( 0 A22 ),( 0 B22 ) n-1
1 n-1 1 n-1
Then the reciprocal condition number DIF(I) is
Difl[(a, b), (A22, B22)] = sigma-min( Zl )
where sigma-min(Zl) denotes the smallest singular value of
Zl = [ kron(a, In-1) -kron(1, A22) ]
[ kron(b, In-1) -kron(1, B22) ].
Here In-1 is the identity matrix of size n-1 and X' is the conjugate
transpose of X. kron(X, Y) is the Kronecker product between the
matrices X and Y.
We approximate the smallest singular value of Zl with an upper
bound. This is done by CLATDF.
An approximate error bound for a computed eigenvector VL(i) or
VR(i) is given by
EPS * norm(A, B) / DIF(i).
See ref. [2-3] for more details and further references.
Based on contributions by
Bo Kagstrom and Peter Poromaa, Department of Computing Science,
Umea University, S-901 87 Umea, Sweden.
References
==========
[1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
M.S. Moonen et al (eds), Linear Algebra for Large Scale and
Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
[2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
Eigenvalues of a Regular Matrix Pair (A, B) and Condition
Estimation: Theory, Algorithms and Software, Report
UMINF - 94.04, Department of Computing Science, Umea University,
S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.
To appear in Numerical Algorithms, 1996.
[3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
for Solving the Generalized Sylvester Equation and Estimating the
Separation between Regular Matrix Pairs, Report UMINF - 93.23,
Department of Computing Science, Umea University, S-901 87 Umea,
Sweden, December 1993, Revised April 1994, Also as LAPACK Working
Note 75.
To appear in ACM Trans. on Math. Software, Vol 22, No 1, 1996.
=====================================================================
Decode and test the input parameters
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static complex c_b19 = {1.f,0.f};
static complex c_b20 = {0.f,0.f};
static logical c_false = FALSE_;
static integer c__3 = 3;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
vr_offset, i__1, i__2;
real r__1, r__2;
complex q__1;
/* Builtin functions */
double c_abs(complex *);
/* Local variables */
static real cond;
static integer ierr, ifst;
static real lnrm;
static complex yhax, yhbx;
static integer ilst;
static real rnrm;
static integer i__, k;
static real scale;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *);
static integer lwmin;
static logical wants;
static integer llwrk, n1, n2;
static complex dummy[1];
extern doublereal scnrm2_(integer *, complex *, integer *), slapy2_(real *
, real *);
static complex dummy1[1];
extern /* Subroutine */ int slabad_(real *, real *);
static integer ks;
extern doublereal slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), ctgexc_(logical *,
logical *, integer *, complex *, integer *, complex *, integer *,
complex *, integer *, complex *, integer *, integer *, integer *,
integer *), xerbla_(char *, integer *);
static real bignum;
static logical wantbh, wantdf, somcon;
extern /* Subroutine */ int ctgsyl_(char *, integer *, integer *, integer
*, complex *, integer *, complex *, integer *, complex *, integer
*, complex *, integer *, complex *, integer *, complex *, integer
*, real *, real *, complex *, integer *, integer *, integer *);
static real smlnum;
static logical lquery;
static real eps;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#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 vl_subscr(a_1,a_2) (a_2)*vl_dim1 + a_1
#define vl_ref(a_1,a_2) vl[vl_subscr(a_1,a_2)]
#define vr_subscr(a_1,a_2) (a_2)*vr_dim1 + a_1
#define vr_ref(a_1,a_2) vr[vr_subscr(a_1,a_2)]
--select;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1 * 1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1 * 1;
vr -= vr_offset;
--s;
--dif;
--work;
--iwork;
/* Function Body */
wantbh = lsame_(job, "B");
wants = lsame_(job, "E") || wantbh;
wantdf = lsame_(job, "V") || wantbh;
somcon = lsame_(howmny, "S");
*info = 0;
lquery = *lwork == -1;
if (lsame_(job, "V") || lsame_(job, "B")) {
/* Computing MAX */
i__1 = 1, i__2 = (*n << 1) * *n;
lwmin = max(i__1,i__2);
} else {
lwmin = 1;
}
if (! wants && ! wantdf) {
*info = -1;
} else if (! lsame_(howmny, "A") && ! somcon) {
*info = -2;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldb < max(1,*n)) {
*info = -8;
} else if (wants && *ldvl < *n) {
*info = -10;
} else if (wants && *ldvr < *n) {
*info = -12;
} else {
/* Set M to the number of eigenpairs for which condition numbers
are required, and test MM. */
if (somcon) {
*m = 0;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (select[k]) {
++(*m);
}
/* L10: */
}
} else {
*m = *n;
}
if (*mm < *m) {
*info = -15;
} else if (*lwork < lwmin && ! lquery) {
*info = -18;
}
}
if (*info == 0) {
work[1].r = (real) lwmin, work[1].i = 0.f;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTGSNA", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = slamch_("P");
smlnum = slamch_("S") / eps;
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
llwrk = *lwork - (*n << 1) * *n;
ks = 0;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Determine whether condition numbers are required for the k-th
eigenpair. */
if (somcon) {
if (! select[k]) {
goto L20;
}
}
++ks;
if (wants) {
/* Compute the reciprocal condition number of the k-th
eigenvalue. */
rnrm = scnrm2_(n, &vr_ref(1, ks), &c__1);
lnrm = scnrm2_(n, &vl_ref(1, ks), &c__1);
cgemv_("N", n, n, &c_b19, &a[a_offset], lda, &vr_ref(1, ks), &
c__1, &c_b20, &work[1], &c__1);
cdotc_(&q__1, n, &work[1], &c__1, &vl_ref(1, ks), &c__1);
yhax.r = q__1.r, yhax.i = q__1.i;
cgemv_("N", n, n, &c_b19, &b[b_offset], ldb, &vr_ref(1, ks), &
c__1, &c_b20, &work[1], &c__1);
cdotc_(&q__1, n, &work[1], &c__1, &vl_ref(1, ks), &c__1);
yhbx.r = q__1.r, yhbx.i = q__1.i;
r__1 = c_abs(&yhax);
r__2 = c_abs(&yhbx);
cond = slapy2_(&r__1, &r__2);
if (cond == 0.f) {
s[ks] = -1.f;
} else {
s[ks] = cond / (rnrm * lnrm);
}
}
if (wantdf) {
if (*n == 1) {
r__1 = c_abs(&a_ref(1, 1));
r__2 = c_abs(&b_ref(1, 1));
dif[ks] = slapy2_(&r__1, &r__2);
goto L20;
}
/* Estimate the reciprocal condition number of the k-th
eigenvectors.
Copy the matrix (A, B) to the array WORK and move the
(k,k)th pair to the (1,1) position. */
clacpy_("Full", n, n, &a[a_offset], lda, &work[1], n);
clacpy_("Full", n, n, &b[b_offset], ldb, &work[*n * *n + 1], n);
ifst = k;
ilst = 1;
ctgexc_(&c_false, &c_false, n, &work[1], n, &work[*n * *n + 1], n,
dummy, &c__1, dummy1, &c__1, &ifst, &ilst, &ierr);
if (ierr > 0) {
/* Ill-conditioned problem - swap rejected. */
dif[ks] = 0.f;
} else {
/* Reordering successful, solve generalized Sylvester
equation for R and L,
A22 * R - L * A11 = A12
B22 * R - L * B11 = B12,
and compute estimate of Difl[(A11,B11), (A22, B22)]. */
n1 = 1;
n2 = *n - n1;
i__ = *n * *n + 1;
ctgsyl_("N", &c__3, &n2, &n1, &work[*n * n1 + n1 + 1], n, &
work[1], n, &work[n1 + 1], n, &work[*n * n1 + n1 +
i__], n, &work[i__], n, &work[n1 + i__], n, &scale, &
dif[ks], &work[(*n * *n << 1) + 1], &llwrk, &iwork[1],
&ierr);
}
}
L20:
;
}
work[1].r = (real) lwmin, work[1].i = 0.f;
return 0;
/* End of CTGSNA */
} /* ctgsna_ */
/* Subroutine */ int clatrd_(char *uplo, integer *n, integer *nb, complex *a,
integer *lda, real *e, complex *tau, complex *w, integer *ldw, ftnlen
uplo_len)
{
/* System generated locals */
integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3;
real r__1;
complex q__1, q__2, q__3, q__4;
/* Local variables */
static integer i__, iw;
static complex alpha;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *, ftnlen), chemv_(char *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, complex *,
integer *, ftnlen);
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *), clarfg_(integer *, complex *,
complex *, integer *, complex *), clacgv_(integer *, complex *,
integer *);
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLATRD reduces NB rows and columns of a complex Hermitian matrix A to */
/* Hermitian tridiagonal form by a unitary similarity */
/* transformation Q' * A * Q, and returns the matrices V and W which are */
/* needed to apply the transformation to the unreduced part of A. */
/* If UPLO = 'U', CLATRD reduces the last NB rows and columns of a */
/* matrix, of which the upper triangle is supplied; */
/* if UPLO = 'L', CLATRD reduces the first NB rows and columns of a */
/* matrix, of which the lower triangle is supplied. */
/* This is an auxiliary routine called by CHETRD. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the matrix A. */
/* NB (input) INTEGER */
/* The number of rows and columns to be reduced. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the Hermitian matrix A. If UPLO = 'U', the leading */
/* n-by-n upper triangular part of A contains the upper */
/* triangular part of the matrix A, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading n-by-n lower triangular part of A contains the lower */
/* triangular part of the matrix A, and the strictly upper */
/* triangular part of A is not referenced. */
/* On exit: */
/* if UPLO = 'U', the last NB columns have been reduced to */
/* tridiagonal form, with the diagonal elements overwriting */
/* the diagonal elements of A; the elements above the diagonal */
/* with the array TAU, represent the unitary matrix Q as a */
/* product of elementary reflectors; */
/* if UPLO = 'L', the first NB columns have been reduced to */
/* tridiagonal form, with the diagonal elements overwriting */
/* the diagonal elements of A; the elements below the diagonal */
/* with the array TAU, represent the unitary matrix Q as a */
/* product of elementary reflectors. */
/* See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* E (output) REAL array, dimension (N-1) */
/* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal */
/* elements of the last NB columns of the reduced matrix; */
/* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of */
/* the first NB columns of the reduced matrix. */
/* TAU (output) COMPLEX array, dimension (N-1) */
/* The scalar factors of the elementary reflectors, stored in */
/* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. */
/* See Further Details. */
/* W (output) COMPLEX array, dimension (LDW,NB) */
/* The n-by-nb matrix W required to update the unreduced part */
/* of A. */
/* LDW (input) INTEGER */
/* The leading dimension of the array W. LDW >= max(1,N). */
/* Further Details */
/* =============== */
/* If UPLO = 'U', the matrix Q is represented as a product of elementary */
/* reflectors */
/* Q = H(n) H(n-1) . . . H(n-nb+1). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a complex scalar, and v is a complex vector with */
/* v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), */
/* and tau in TAU(i-1). */
/* If UPLO = 'L', the matrix Q is represented as a product of elementary */
/* reflectors */
/* Q = H(1) H(2) . . . H(nb). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a complex scalar, and v is a complex vector with */
/* v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), */
/* and tau in TAU(i). */
/* The elements of the vectors v together form the n-by-nb matrix V */
/* which is needed, with W, to apply the transformation to the unreduced */
/* part of the matrix, using a Hermitian rank-2k update of the form: */
/* A := A - V*W' - W*V'. */
/* The contents of A on exit are illustrated by the following examples */
/* with n = 5 and nb = 2: */
/* if UPLO = 'U': if UPLO = 'L': */
/* ( a a a v4 v5 ) ( d ) */
/* ( a a v4 v5 ) ( 1 d ) */
/* ( a 1 v5 ) ( v1 1 a ) */
/* ( d 1 ) ( v1 v2 a a ) */
/* ( d ) ( v1 v2 a a a ) */
/* where d denotes a diagonal element of the reduced matrix, a denotes */
/* an element of the original matrix that is unchanged, and vi denotes */
/* an element of the vector defining H(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--e;
--tau;
w_dim1 = *ldw;
w_offset = 1 + w_dim1;
w -= w_offset;
/* Function Body */
if (*n <= 0) {
return 0;
}
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
/* Reduce last NB columns of upper triangle */
i__1 = *n - *nb + 1;
for (i__ = *n; i__ >= i__1; --i__) {
iw = i__ - *n + *nb;
if (i__ < *n) {
/* Update A(1:i,i) */
i__2 = i__ + i__ * a_dim1;
i__3 = i__ + i__ * a_dim1;
r__1 = a[i__3].r;
a[i__2].r = r__1, a[i__2].i = 0.f;
i__2 = *n - i__;
clacgv_(&i__2, &w[i__ + (iw + 1) * w_dim1], ldw);
i__2 = *n - i__;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &i__, &i__2, &q__1, &a[(i__ + 1) *
a_dim1 + 1], lda, &w[i__ + (iw + 1) * w_dim1], ldw, &
c_b2, &a[i__ * a_dim1 + 1], &c__1, (ftnlen)12);
i__2 = *n - i__;
clacgv_(&i__2, &w[i__ + (iw + 1) * w_dim1], ldw);
i__2 = *n - i__;
clacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
i__2 = *n - i__;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &i__, &i__2, &q__1, &w[(iw + 1) *
w_dim1 + 1], ldw, &a[i__ + (i__ + 1) * a_dim1], lda, &
c_b2, &a[i__ * a_dim1 + 1], &c__1, (ftnlen)12);
i__2 = *n - i__;
clacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
i__2 = i__ + i__ * a_dim1;
i__3 = i__ + i__ * a_dim1;
r__1 = a[i__3].r;
a[i__2].r = r__1, a[i__2].i = 0.f;
}
if (i__ > 1) {
/* Generate elementary reflector H(i) to annihilate */
/* A(1:i-2,i) */
i__2 = i__ - 1 + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = i__ - 1;
clarfg_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &tau[i__
- 1]);
i__2 = i__ - 1;
e[i__2] = alpha.r;
i__2 = i__ - 1 + i__ * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
/* Compute W(1:i-1,i) */
i__2 = i__ - 1;
chemv_("Upper", &i__2, &c_b2, &a[a_offset], lda, &a[i__ *
a_dim1 + 1], &c__1, &c_b1, &w[iw * w_dim1 + 1], &c__1,
(ftnlen)5);
if (i__ < *n) {
i__2 = i__ - 1;
i__3 = *n - i__;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &w[(iw
+ 1) * w_dim1 + 1], ldw, &a[i__ * a_dim1 + 1], &
c__1, &c_b1, &w[i__ + 1 + iw * w_dim1], &c__1, (
ftnlen)19);
i__2 = i__ - 1;
i__3 = *n - i__;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &i__2, &i__3, &q__1, &a[(i__ + 1) *
a_dim1 + 1], lda, &w[i__ + 1 + iw * w_dim1], &
c__1, &c_b2, &w[iw * w_dim1 + 1], &c__1, (ftnlen)
12);
i__2 = i__ - 1;
i__3 = *n - i__;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[(
i__ + 1) * a_dim1 + 1], lda, &a[i__ * a_dim1 + 1],
&c__1, &c_b1, &w[i__ + 1 + iw * w_dim1], &c__1, (
ftnlen)19);
i__2 = i__ - 1;
i__3 = *n - i__;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &i__2, &i__3, &q__1, &w[(iw + 1) *
w_dim1 + 1], ldw, &w[i__ + 1 + iw * w_dim1], &
c__1, &c_b2, &w[iw * w_dim1 + 1], &c__1, (ftnlen)
12);
}
i__2 = i__ - 1;
cscal_(&i__2, &tau[i__ - 1], &w[iw * w_dim1 + 1], &c__1);
q__3.r = -.5f, q__3.i = -0.f;
i__2 = i__ - 1;
q__2.r = q__3.r * tau[i__2].r - q__3.i * tau[i__2].i, q__2.i =
q__3.r * tau[i__2].i + q__3.i * tau[i__2].r;
i__3 = i__ - 1;
cdotc_(&q__4, &i__3, &w[iw * w_dim1 + 1], &c__1, &a[i__ *
a_dim1 + 1], &c__1);
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r *
q__4.i + q__2.i * q__4.r;
alpha.r = q__1.r, alpha.i = q__1.i;
i__2 = i__ - 1;
caxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &w[iw *
w_dim1 + 1], &c__1);
}
/* L10: */
}
} else {
/* Reduce first NB columns of lower triangle */
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Update A(i:n,i) */
i__2 = i__ + i__ * a_dim1;
i__3 = i__ + i__ * a_dim1;
r__1 = a[i__3].r;
a[i__2].r = r__1, a[i__2].i = 0.f;
i__2 = i__ - 1;
clacgv_(&i__2, &w[i__ + w_dim1], ldw);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &i__2, &i__3, &q__1, &a[i__ + a_dim1], lda,
&w[i__ + w_dim1], ldw, &c_b2, &a[i__ + i__ * a_dim1], &
c__1, (ftnlen)12);
i__2 = i__ - 1;
clacgv_(&i__2, &w[i__ + w_dim1], ldw);
i__2 = i__ - 1;
clacgv_(&i__2, &a[i__ + a_dim1], lda);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &i__2, &i__3, &q__1, &w[i__ + w_dim1], ldw,
&a[i__ + a_dim1], lda, &c_b2, &a[i__ + i__ * a_dim1], &
c__1, (ftnlen)12);
i__2 = i__ - 1;
clacgv_(&i__2, &a[i__ + a_dim1], lda);
i__2 = i__ + i__ * a_dim1;
i__3 = i__ + i__ * a_dim1;
r__1 = a[i__3].r;
a[i__2].r = r__1, a[i__2].i = 0.f;
if (i__ < *n) {
/* Generate elementary reflector H(i) to annihilate */
/* A(i+2:n,i) */
i__2 = i__ + 1 + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *n - i__;
/* Computing MIN */
i__3 = i__ + 2;
clarfg_(&i__2, &alpha, &a[min(i__3,*n) + i__ * a_dim1], &c__1,
&tau[i__]);
i__2 = i__;
e[i__2] = alpha.r;
i__2 = i__ + 1 + i__ * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
/* Compute W(i+1:n,i) */
i__2 = *n - i__;
chemv_("Lower", &i__2, &c_b2, &a[i__ + 1 + (i__ + 1) * a_dim1]
, lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b1, &w[
i__ + 1 + i__ * w_dim1], &c__1, (ftnlen)5);
i__2 = *n - i__;
i__3 = i__ - 1;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &w[i__ + 1
+ w_dim1], ldw, &a[i__ + 1 + i__ * a_dim1], &c__1, &
c_b1, &w[i__ * w_dim1 + 1], &c__1, (ftnlen)19);
i__2 = *n - i__;
i__3 = i__ - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &i__2, &i__3, &q__1, &a[i__ + 1 +
a_dim1], lda, &w[i__ * w_dim1 + 1], &c__1, &c_b2, &w[
i__ + 1 + i__ * w_dim1], &c__1, (ftnlen)12);
i__2 = *n - i__;
i__3 = i__ - 1;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + 1
+ a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &
c_b1, &w[i__ * w_dim1 + 1], &c__1, (ftnlen)19);
i__2 = *n - i__;
i__3 = i__ - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &i__2, &i__3, &q__1, &w[i__ + 1 +
w_dim1], ldw, &w[i__ * w_dim1 + 1], &c__1, &c_b2, &w[
i__ + 1 + i__ * w_dim1], &c__1, (ftnlen)12);
i__2 = *n - i__;
cscal_(&i__2, &tau[i__], &w[i__ + 1 + i__ * w_dim1], &c__1);
q__3.r = -.5f, q__3.i = -0.f;
i__2 = i__;
q__2.r = q__3.r * tau[i__2].r - q__3.i * tau[i__2].i, q__2.i =
q__3.r * tau[i__2].i + q__3.i * tau[i__2].r;
i__3 = *n - i__;
cdotc_(&q__4, &i__3, &w[i__ + 1 + i__ * w_dim1], &c__1, &a[
i__ + 1 + i__ * a_dim1], &c__1);
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r *
q__4.i + q__2.i * q__4.r;
alpha.r = q__1.r, alpha.i = q__1.i;
i__2 = *n - i__;
caxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &w[
i__ + 1 + i__ * w_dim1], &c__1);
}
/* L20: */
}
}
return 0;
/* End of CLATRD */
} /* clatrd_ */
/* DECK CQRDC */
/* Subroutine */ int cqrdc_(complex *x, integer *ldx, integer *n, integer *p,
complex *qraux, integer *jpvt, complex *work, integer *job)
{
/* System generated locals */
integer x_dim1, x_offset, i__1, i__2, i__3, i__4;
real r__1, r__2, r__3, r__4;
complex q__1, q__2, q__3;
/* Local variables */
static integer j, l;
static complex t;
static integer jj, jp, pl, pu;
static real tt;
static integer lp1, lup;
static logical negj;
static integer maxj;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
extern /* Complex */ void cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
complex *, integer *);
static logical swapj;
extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
static complex nrmxl;
extern doublereal scnrm2_(integer *, complex *, integer *);
static real maxnrm;
/* ***BEGIN PROLOGUE CQRDC */
/* ***PURPOSE Use Householder transformations to compute the QR */
/* factorization of an N by P matrix. Column pivoting is a */
/* users option. */
/* ***LIBRARY SLATEC (LINPACK) */
/* ***CATEGORY D5 */
/* ***TYPE COMPLEX (SQRDC-S, DQRDC-D, CQRDC-C) */
/* ***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, ORTHOGONAL TRIANGULAR, */
/* QR DECOMPOSITION */
/* ***AUTHOR Stewart, G. W., (U. of Maryland) */
/* ***DESCRIPTION */
/* CQRDC uses Householder transformations to compute the QR */
/* factorization of an N by P matrix X. Column pivoting */
/* based on the 2-norms of the reduced columns may be */
/* performed at the users option. */
/* On Entry */
/* X COMPLEX(LDX,P), where LDX .GE. N. */
/* X contains the matrix whose decomposition is to be */
/* computed. */
/* LDX INTEGER. */
/* LDX is the leading dimension of the array X. */
/* N INTEGER. */
/* N is the number of rows of the matrix X. */
/* P INTEGER. */
/* P is the number of columns of the matrix X. */
/* JVPT INTEGER(P). */
/* JVPT contains integers that control the selection */
/* of the pivot columns. The K-th column X(K) of X */
/* is placed in one of three classes according to the */
/* value of JVPT(K). */
/* If JVPT(K) .GT. 0, then X(K) is an initial */
/* column. */
/* If JVPT(K) .EQ. 0, then X(K) is a free column. */
/* If JVPT(K) .LT. 0, then X(K) is a final column. */
/* Before the decomposition is computed, initial columns */
/* are moved to the beginning of the array X and final */
/* columns to the end. Both initial and final columns */
/* are frozen in place during the computation and only */
/* free columns are moved. At the K-th stage of the */
/* reduction, if X(K) is occupied by a free column */
/* it is interchanged with the free column of largest */
/* reduced norm. JVPT is not referenced if */
/* JOB .EQ. 0. */
/* WORK COMPLEX(P). */
/* WORK is a work array. WORK is not referenced if */
/* JOB .EQ. 0. */
/* JOB INTEGER. */
/* JOB is an integer that initiates column pivoting. */
/* If JOB .EQ. 0, no pivoting is done. */
/* If JOB .NE. 0, pivoting is done. */
/* On Return */
/* X X contains in its upper triangle the upper */
/* triangular matrix R of the QR factorization. */
/* Below its diagonal X contains information from */
/* which the unitary part of the decomposition */
/* can be recovered. Note that if pivoting has */
/* been requested, the decomposition is not that */
/* of the original matrix X but that of X */
/* with its columns permuted as described by JVPT. */
/* QRAUX COMPLEX(P). */
/* QRAUX contains further information required to recover */
/* the unitary part of the decomposition. */
/* JVPT JVPT(K) contains the index of the column of the */
/* original matrix that has been interchanged into */
/* the K-th column, if pivoting was requested. */
/* ***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. */
/* Stewart, LINPACK Users' Guide, SIAM, 1979. */
/* ***ROUTINES CALLED CAXPY, CDOTC, CSCAL, CSWAP, SCNRM2 */
/* ***REVISION HISTORY (YYMMDD) */
/* 780814 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890831 Modified array declarations. (WRB) */
/* 890831 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900326 Removed duplicate information from DESCRIPTION section. */
/* (WRB) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE CQRDC */
/* ***FIRST EXECUTABLE STATEMENT CQRDC */
/* Parameter adjustments */
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--qraux;
--jpvt;
--work;
/* Function Body */
pl = 1;
pu = 0;
if (*job == 0) {
goto L60;
}
/* PIVOTING HAS BEEN REQUESTED. REARRANGE THE COLUMNS */
/* ACCORDING TO JPVT. */
i__1 = *p;
for (j = 1; j <= i__1; ++j) {
swapj = jpvt[j] > 0;
negj = jpvt[j] < 0;
jpvt[j] = j;
if (negj) {
jpvt[j] = -j;
}
if (! swapj) {
goto L10;
}
if (j != pl) {
cswap_(n, &x[pl * x_dim1 + 1], &c__1, &x[j * x_dim1 + 1], &c__1);
}
jpvt[j] = jpvt[pl];
jpvt[pl] = j;
++pl;
L10:
/* L20: */
;
}
pu = *p;
i__1 = *p;
for (jj = 1; jj <= i__1; ++jj) {
j = *p - jj + 1;
if (jpvt[j] >= 0) {
goto L40;
}
jpvt[j] = -jpvt[j];
if (j == pu) {
goto L30;
}
cswap_(n, &x[pu * x_dim1 + 1], &c__1, &x[j * x_dim1 + 1], &c__1);
jp = jpvt[pu];
jpvt[pu] = jpvt[j];
jpvt[j] = jp;
L30:
--pu;
L40:
/* L50: */
;
}
L60:
/* COMPUTE THE NORMS OF THE FREE COLUMNS. */
if (pu < pl) {
goto L80;
}
i__1 = pu;
for (j = pl; j <= i__1; ++j) {
i__2 = j;
r__1 = scnrm2_(n, &x[j * x_dim1 + 1], &c__1);
q__1.r = r__1, q__1.i = 0.f;
qraux[i__2].r = q__1.r, qraux[i__2].i = q__1.i;
i__2 = j;
i__3 = j;
work[i__2].r = qraux[i__3].r, work[i__2].i = qraux[i__3].i;
/* L70: */
}
L80:
/* PERFORM THE HOUSEHOLDER REDUCTION OF X. */
lup = min(*n,*p);
i__1 = lup;
for (l = 1; l <= i__1; ++l) {
if (l < pl || l >= pu) {
goto L120;
}
/* LOCATE THE COLUMN OF LARGEST NORM AND BRING IT */
/* INTO THE PIVOT POSITION. */
maxnrm = 0.f;
maxj = l;
i__2 = pu;
for (j = l; j <= i__2; ++j) {
i__3 = j;
if (qraux[i__3].r <= maxnrm) {
goto L90;
}
i__3 = j;
maxnrm = qraux[i__3].r;
maxj = j;
L90:
/* L100: */
;
}
if (maxj == l) {
goto L110;
}
cswap_(n, &x[l * x_dim1 + 1], &c__1, &x[maxj * x_dim1 + 1], &c__1);
i__2 = maxj;
i__3 = l;
qraux[i__2].r = qraux[i__3].r, qraux[i__2].i = qraux[i__3].i;
i__2 = maxj;
i__3 = l;
work[i__2].r = work[i__3].r, work[i__2].i = work[i__3].i;
jp = jpvt[maxj];
jpvt[maxj] = jpvt[l];
jpvt[l] = jp;
L110:
L120:
i__2 = l;
qraux[i__2].r = 0.f, qraux[i__2].i = 0.f;
if (l == *n) {
goto L190;
}
/* COMPUTE THE HOUSEHOLDER TRANSFORMATION FOR COLUMN L. */
i__2 = *n - l + 1;
r__1 = scnrm2_(&i__2, &x[l + l * x_dim1], &c__1);
q__1.r = r__1, q__1.i = 0.f;
nrmxl.r = q__1.r, nrmxl.i = q__1.i;
if ((r__1 = nrmxl.r, dabs(r__1)) + (r__2 = r_imag(&nrmxl), dabs(r__2))
== 0.f) {
goto L180;
}
i__2 = l + l * x_dim1;
if ((r__1 = x[i__2].r, dabs(r__1)) + (r__2 = r_imag(&x[l + l * x_dim1]
), dabs(r__2)) != 0.f) {
r__3 = c_abs(&nrmxl);
i__3 = l + l * x_dim1;
r__4 = c_abs(&x[l + l * x_dim1]);
q__2.r = x[i__3].r / r__4, q__2.i = x[i__3].i / r__4;
q__1.r = r__3 * q__2.r, q__1.i = r__3 * q__2.i;
nrmxl.r = q__1.r, nrmxl.i = q__1.i;
}
i__2 = *n - l + 1;
c_div(&q__1, &c_b26, &nrmxl);
cscal_(&i__2, &q__1, &x[l + l * x_dim1], &c__1);
i__2 = l + l * x_dim1;
i__3 = l + l * x_dim1;
q__1.r = x[i__3].r + 1.f, q__1.i = x[i__3].i + 0.f;
x[i__2].r = q__1.r, x[i__2].i = q__1.i;
/* APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS, */
/* UPDATING THE NORMS. */
lp1 = l + 1;
if (*p < lp1) {
goto L170;
}
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
i__3 = *n - l + 1;
cdotc_(&q__3, &i__3, &x[l + l * x_dim1], &c__1, &x[l + j * x_dim1]
, &c__1);
q__2.r = -q__3.r, q__2.i = -q__3.i;
c_div(&q__1, &q__2, &x[l + l * x_dim1]);
t.r = q__1.r, t.i = q__1.i;
i__3 = *n - l + 1;
caxpy_(&i__3, &t, &x[l + l * x_dim1], &c__1, &x[l + j * x_dim1], &
c__1);
if (j < pl || j > pu) {
goto L150;
}
i__3 = j;
if ((r__1 = qraux[i__3].r, dabs(r__1)) + (r__2 = r_imag(&qraux[j])
, dabs(r__2)) == 0.f) {
goto L150;
}
i__3 = j;
/* Computing 2nd power */
r__1 = c_abs(&x[l + j * x_dim1]) / qraux[i__3].r;
tt = 1.f - r__1 * r__1;
tt = dmax(tt,0.f);
q__1.r = tt, q__1.i = 0.f;
t.r = q__1.r, t.i = q__1.i;
i__3 = j;
i__4 = j;
/* Computing 2nd power */
r__1 = qraux[i__3].r / work[i__4].r;
tt = tt * .05f * (r__1 * r__1) + 1.f;
if (tt == 1.f) {
goto L130;
}
i__3 = j;
i__4 = j;
c_sqrt(&q__2, &t);
q__1.r = qraux[i__4].r * q__2.r - qraux[i__4].i * q__2.i, q__1.i =
qraux[i__4].r * q__2.i + qraux[i__4].i * q__2.r;
qraux[i__3].r = q__1.r, qraux[i__3].i = q__1.i;
goto L140;
L130:
i__3 = j;
i__4 = *n - l;
r__1 = scnrm2_(&i__4, &x[l + 1 + j * x_dim1], &c__1);
q__1.r = r__1, q__1.i = 0.f;
qraux[i__3].r = q__1.r, qraux[i__3].i = q__1.i;
i__3 = j;
i__4 = j;
work[i__3].r = qraux[i__4].r, work[i__3].i = qraux[i__4].i;
L140:
L150:
/* L160: */
;
}
L170:
/* SAVE THE TRANSFORMATION. */
i__2 = l;
i__3 = l + l * x_dim1;
qraux[i__2].r = x[i__3].r, qraux[i__2].i = x[i__3].i;
i__2 = l + l * x_dim1;
q__1.r = -nrmxl.r, q__1.i = -nrmxl.i;
x[i__2].r = q__1.r, x[i__2].i = q__1.i;
L180:
L190:
/* L200: */
;
}
return 0;
} /* cqrdc_ */
/* Subroutine */ int cpptrf_(char *uplo, integer *n, complex *ap, integer *
info)
{
/* -- LAPACK 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
=======
CPPTRF computes the Cholesky factorization of a complex Hermitian
positive definite matrix A stored in packed format.
The factorization has the form
A = U**H * U, if UPLO = 'U', or
A = L * L**H, if UPLO = 'L',
where U is an upper triangular matrix and L is lower triangular.
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.
AP (input/output) COMPLEX array, dimension (N*(N+1)/2)
On entry, the upper or lower triangle of the Hermitian matrix
A, packed columnwise in a linear array. The j-th column of A
is stored in the array AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
See below for further details.
On exit, if INFO = 0, the triangular factor U or L from the
Cholesky factorization A = U**H*U or A = L*L**H, in the same
storage format as A.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, the leading minor of order i is not
positive definite, and the factorization could not be
completed.
Further Details
===============
The packed storage scheme is illustrated by the following example
when N = 4, UPLO = 'U':
Two-dimensional storage of the Hermitian matrix A:
a11 a12 a13 a14
a22 a23 a24
a33 a34 (aij = conjg(aji))
a44
Packed storage of the upper triangle of A:
AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static real c_b16 = -1.f;
/* System generated locals */
integer i__1, i__2, i__3;
real r__1;
complex q__1, q__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
extern /* Subroutine */ int chpr_(char *, integer *, real *, complex *,
integer *, complex *);
static integer j;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
static logical upper;
extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *,
complex *, complex *, integer *);
static integer jc, jj;
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), xerbla_(char *, integer *);
static real ajj;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CPPTRF", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (upper) {
/* Compute the Cholesky factorization A = U'*U. */
jj = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
jc = jj + 1;
jj += j;
/* Compute elements 1:J-1 of column J. */
if (j > 1) {
i__2 = j - 1;
ctpsv_("Upper", "Conjugate transpose", "Non-unit", &i__2, &ap[
1], &ap[jc], &c__1);
}
/* Compute U(J,J) and test for non-positive-definiteness. */
i__2 = jj;
r__1 = ap[i__2].r;
i__3 = j - 1;
cdotc_(&q__2, &i__3, &ap[jc], &c__1, &ap[jc], &c__1);
q__1.r = r__1 - q__2.r, q__1.i = -q__2.i;
ajj = q__1.r;
if (ajj <= 0.f) {
i__2 = jj;
ap[i__2].r = ajj, ap[i__2].i = 0.f;
goto L30;
}
i__2 = jj;
r__1 = sqrt(ajj);
ap[i__2].r = r__1, ap[i__2].i = 0.f;
/* L10: */
}
} else {
/* Compute the Cholesky factorization A = L*L'. */
jj = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute L(J,J) and test for non-positive-definiteness. */
i__2 = jj;
ajj = ap[i__2].r;
if (ajj <= 0.f) {
i__2 = jj;
ap[i__2].r = ajj, ap[i__2].i = 0.f;
goto L30;
}
ajj = sqrt(ajj);
i__2 = jj;
ap[i__2].r = ajj, ap[i__2].i = 0.f;
/* Compute elements J+1:N of column J and update the trailing
submatrix. */
if (j < *n) {
i__2 = *n - j;
r__1 = 1.f / ajj;
csscal_(&i__2, &r__1, &ap[jj + 1], &c__1);
i__2 = *n - j;
chpr_("Lower", &i__2, &c_b16, &ap[jj + 1], &c__1, &ap[jj + *n
- j + 1]);
jj = jj + *n - j + 1;
}
/* L20: */
}
}
goto L40;
L30:
*info = j;
L40:
return 0;
/* End of CPPTRF */
} /* cpptrf_ */
/* Subroutine */ int clapll_(integer *n, complex *x, integer *incx, complex *
y, integer *incy, real *ssmin)
{
/* -- LAPACK auxiliary routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
Given two column vectors X and Y, let
A = ( X Y ).
The subroutine first computes the QR factorization of A = Q*R,
and then computes the SVD of the 2-by-2 upper triangular matrix R.
The smaller singular value of R is returned in SSMIN, which is used
as the measurement of the linear dependency of the vectors X and Y.
Arguments
=========
N (input) INTEGER
The length of the vectors X and Y.
X (input/output) COMPLEX array, dimension (1+(N-1)*INCX)
On entry, X contains the N-vector X.
On exit, X is overwritten.
INCX (input) INTEGER
The increment between successive elements of X. INCX > 0.
Y (input/output) COMPLEX array, dimension (1+(N-1)*INCY)
On entry, Y contains the N-vector Y.
On exit, Y is overwritten.
INCY (input) INTEGER
The increment between successive elements of Y. INCY > 0.
SSMIN (output) REAL
The smallest singular value of the N-by-2 matrix A = ( X Y ).
=====================================================================
Quick return if possible
Parameter adjustments
Function Body */
/* System generated locals */
integer i__1;
real r__1, r__2, r__3;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */
void r_cnjg(complex *, complex *);
double c_abs(complex *);
/* Local variables */
extern /* Subroutine */ int slas2_(real *, real *, real *, real *, real *)
;
static complex c;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
static real ssmax;
static complex a11, a12, a22;
extern /* Subroutine */ int clarfg_(integer *, complex *, complex *,
integer *, complex *);
static complex tau;
#define Y(I) y[(I)-1]
#define X(I) x[(I)-1]
if (*n <= 1) {
*ssmin = 0.f;
return 0;
}
/* Compute the QR factorization of the N-by-2 matrix ( X Y ) */
clarfg_(n, &X(1), &X(*incx + 1), incx, &tau);
a11.r = X(1).r, a11.i = X(1).i;
X(1).r = 1.f, X(1).i = 0.f;
r_cnjg(&q__3, &tau);
q__2.r = -(doublereal)q__3.r, q__2.i = -(doublereal)q__3.i;
cdotc_(&q__4, n, &X(1), incx, &Y(1), incy);
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i +
q__2.i * q__4.r;
c.r = q__1.r, c.i = q__1.i;
caxpy_(n, &c, &X(1), incx, &Y(1), incy);
i__1 = *n - 1;
clarfg_(&i__1, &Y(*incy + 1), &Y((*incy << 1) + 1), incy, &tau);
a12.r = Y(1).r, a12.i = Y(1).i;
i__1 = *incy + 1;
a22.r = Y(*incy+1).r, a22.i = Y(*incy+1).i;
/* Compute the SVD of 2-by-2 Upper triangular matrix. */
r__1 = c_abs(&a11);
r__2 = c_abs(&a12);
r__3 = c_abs(&a22);
slas2_(&r__1, &r__2, &r__3, ssmin, &ssmax);
return 0;
/* End of CLAPLL */
} /* clapll_ */
/* Subroutine */ int chptrd_(char *uplo, integer *n, complex *ap, real *d__,
real *e, complex *tau, integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3;
real r__1;
complex q__1, q__2, q__3, q__4;
/* Local variables */
integer i__, i1, ii, i1i1;
complex taui;
extern /* Subroutine */ int chpr2_(char *, integer *, complex *, complex *
, integer *, complex *, integer *, complex *);
complex alpha;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int chpmv_(char *, integer *, complex *, complex *
, complex *, integer *, complex *, complex *, integer *),
caxpy_(integer *, complex *, complex *, integer *, complex *,
integer *);
logical upper;
extern /* Subroutine */ int clarfg_(integer *, complex *, complex *,
integer *, complex *), xerbla_(char *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHPTRD reduces a complex Hermitian matrix A stored in packed form to */
/* real symmetric tridiagonal form T by a unitary similarity */
/* transformation: Q**H * A * Q = T. */
/* 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. */
/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the Hermitian matrix */
/* A, packed columnwise in a linear array. The j-th column of A */
/* is stored in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
/* On exit, if UPLO = 'U', the diagonal and first superdiagonal */
/* of A are overwritten by the corresponding elements of the */
/* tridiagonal matrix T, and the elements above the first */
/* superdiagonal, with the array TAU, represent the unitary */
/* matrix Q as a product of elementary reflectors; if UPLO */
/* = 'L', the diagonal and first subdiagonal of A are over- */
/* written by the corresponding elements of the tridiagonal */
/* matrix T, and the elements below the first subdiagonal, with */
/* the array TAU, represent the unitary matrix Q as a product */
/* of elementary reflectors. See Further Details. */
/* D (output) REAL array, dimension (N) */
/* The diagonal elements of the tridiagonal matrix T: */
/* D(i) = A(i,i). */
/* E (output) REAL array, dimension (N-1) */
/* The off-diagonal elements of the tridiagonal matrix T: */
/* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */
/* TAU (output) COMPLEX array, dimension (N-1) */
/* The scalar factors of the elementary reflectors (see Further */
/* Details). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* If UPLO = 'U', the matrix Q is represented as a product of elementary */
/* reflectors */
/* Q = H(n-1) . . . H(2) H(1). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a complex scalar, and v is a complex vector with */
/* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP, */
/* overwriting A(1:i-1,i+1), and tau is stored in TAU(i). */
/* If UPLO = 'L', the matrix Q is represented as a product of elementary */
/* reflectors */
/* Q = H(1) H(2) . . . H(n-1). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a complex scalar, and v is a complex vector with */
/* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP, */
/* overwriting A(i+2:n,i), and tau is stored in TAU(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
--tau;
--e;
--d__;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHPTRD", &i__1);
return 0;
}
/* Quick return if possible */
if (*n <= 0) {
return 0;
}
if (upper) {
/* Reduce the upper triangle of A. */
/* I1 is the index in AP of A(1,I+1). */
i1 = *n * (*n - 1) / 2 + 1;
i__1 = i1 + *n - 1;
i__2 = i1 + *n - 1;
r__1 = ap[i__2].r;
ap[i__1].r = r__1, ap[i__1].i = 0.f;
for (i__ = *n - 1; i__ >= 1; --i__) {
/* Generate elementary reflector H(i) = I - tau * v * v' */
/* to annihilate A(1:i-1,i+1) */
i__1 = i1 + i__ - 1;
alpha.r = ap[i__1].r, alpha.i = ap[i__1].i;
clarfg_(&i__, &alpha, &ap[i1], &c__1, &taui);
i__1 = i__;
e[i__1] = alpha.r;
if (taui.r != 0.f || taui.i != 0.f) {
/* Apply H(i) from both sides to A(1:i,1:i) */
i__1 = i1 + i__ - 1;
ap[i__1].r = 1.f, ap[i__1].i = 0.f;
/* Compute y := tau * A * v storing y in TAU(1:i) */
chpmv_(uplo, &i__, &taui, &ap[1], &ap[i1], &c__1, &c_b2, &tau[
1], &c__1);
/* Compute w := y - 1/2 * tau * (y'*v) * v */
q__3.r = -.5f, q__3.i = -0.f;
q__2.r = q__3.r * taui.r - q__3.i * taui.i, q__2.i = q__3.r *
taui.i + q__3.i * taui.r;
cdotc_(&q__4, &i__, &tau[1], &c__1, &ap[i1], &c__1);
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r *
q__4.i + q__2.i * q__4.r;
alpha.r = q__1.r, alpha.i = q__1.i;
caxpy_(&i__, &alpha, &ap[i1], &c__1, &tau[1], &c__1);
/* Apply the transformation as a rank-2 update: */
/* A := A - v * w' - w * v' */
q__1.r = -1.f, q__1.i = -0.f;
chpr2_(uplo, &i__, &q__1, &ap[i1], &c__1, &tau[1], &c__1, &ap[
1]);
}
i__1 = i1 + i__ - 1;
i__2 = i__;
ap[i__1].r = e[i__2], ap[i__1].i = 0.f;
i__1 = i__ + 1;
i__2 = i1 + i__;
d__[i__1] = ap[i__2].r;
i__1 = i__;
tau[i__1].r = taui.r, tau[i__1].i = taui.i;
i1 -= i__;
/* L10: */
}
d__[1] = ap[1].r;
} else {
/* Reduce the lower triangle of A. II is the index in AP of */
/* A(i,i) and I1I1 is the index of A(i+1,i+1). */
ii = 1;
r__1 = ap[1].r;
ap[1].r = r__1, ap[1].i = 0.f;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i1i1 = ii + *n - i__ + 1;
/* Generate elementary reflector H(i) = I - tau * v * v' */
/* to annihilate A(i+2:n,i) */
i__2 = ii + 1;
alpha.r = ap[i__2].r, alpha.i = ap[i__2].i;
i__2 = *n - i__;
clarfg_(&i__2, &alpha, &ap[ii + 2], &c__1, &taui);
i__2 = i__;
e[i__2] = alpha.r;
if (taui.r != 0.f || taui.i != 0.f) {
/* Apply H(i) from both sides to A(i+1:n,i+1:n) */
i__2 = ii + 1;
ap[i__2].r = 1.f, ap[i__2].i = 0.f;
/* Compute y := tau * A * v storing y in TAU(i:n-1) */
i__2 = *n - i__;
chpmv_(uplo, &i__2, &taui, &ap[i1i1], &ap[ii + 1], &c__1, &
c_b2, &tau[i__], &c__1);
/* Compute w := y - 1/2 * tau * (y'*v) * v */
q__3.r = -.5f, q__3.i = -0.f;
q__2.r = q__3.r * taui.r - q__3.i * taui.i, q__2.i = q__3.r *
taui.i + q__3.i * taui.r;
i__2 = *n - i__;
cdotc_(&q__4, &i__2, &tau[i__], &c__1, &ap[ii + 1], &c__1);
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r *
q__4.i + q__2.i * q__4.r;
alpha.r = q__1.r, alpha.i = q__1.i;
i__2 = *n - i__;
caxpy_(&i__2, &alpha, &ap[ii + 1], &c__1, &tau[i__], &c__1);
/* Apply the transformation as a rank-2 update: */
/* A := A - v * w' - w * v' */
i__2 = *n - i__;
q__1.r = -1.f, q__1.i = -0.f;
chpr2_(uplo, &i__2, &q__1, &ap[ii + 1], &c__1, &tau[i__], &
c__1, &ap[i1i1]);
}
i__2 = ii + 1;
i__3 = i__;
ap[i__2].r = e[i__3], ap[i__2].i = 0.f;
i__2 = i__;
i__3 = ii;
d__[i__2] = ap[i__3].r;
i__2 = i__;
tau[i__2].r = taui.r, tau[i__2].i = taui.i;
ii = i1i1;
/* L20: */
}
i__1 = *n;
i__2 = ii;
d__[i__1] = ap[i__2].r;
}
return 0;
/* End of CHPTRD */
} /* chptrd_ */
/* Subroutine */ int ctrsyl_(char *trana, char *tranb, integer *isgn, integer
*m, integer *n, complex *a, integer *lda, complex *b, integer *ldb,
complex *c__, integer *ldc, real *scale, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
CTRSYL solves the complex Sylvester matrix equation:
op(A)*X + X*op(B) = scale*C or
op(A)*X - X*op(B) = scale*C,
where op(A) = A or A**H, and A and B are both upper triangular. A is
M-by-M and B is N-by-N; the right hand side C and the solution X are
M-by-N; and scale is an output scale factor, set <= 1 to avoid
overflow in X.
Arguments
=========
TRANA (input) CHARACTER*1
Specifies the option op(A):
= 'N': op(A) = A (No transpose)
= 'C': op(A) = A**H (Conjugate transpose)
TRANB (input) CHARACTER*1
Specifies the option op(B):
= 'N': op(B) = B (No transpose)
= 'C': op(B) = B**H (Conjugate transpose)
ISGN (input) INTEGER
Specifies the sign in the equation:
= +1: solve op(A)*X + X*op(B) = scale*C
= -1: solve op(A)*X - X*op(B) = scale*C
M (input) INTEGER
The order of the matrix A, and the number of rows in the
matrices X and C. M >= 0.
N (input) INTEGER
The order of the matrix B, and the number of columns in the
matrices X and C. N >= 0.
A (input) COMPLEX array, dimension (LDA,M)
The upper triangular matrix A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
B (input) COMPLEX array, dimension (LDB,N)
The upper triangular matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
C (input/output) COMPLEX array, dimension (LDC,N)
On entry, the M-by-N right hand side matrix C.
On exit, C is overwritten by the solution matrix X.
LDC (input) INTEGER
The leading dimension of the array C. LDC >= max(1,M)
SCALE (output) REAL
The scale factor, scale, set <= 1 to avoid overflow in X.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
= 1: A and B have common or very close eigenvalues; perturbed
values were used to solve the equation (but the matrices
A and B are unchanged).
=====================================================================
Decode and Test input parameters
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
i__3, i__4;
real r__1, r__2;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
static real smin;
static complex suml, sumr;
static integer j, k, l;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer
*, complex *, integer *);
static complex a11;
static real db;
extern /* Subroutine */ int slabad_(real *, real *);
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *);
static complex x11;
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
static real scaloc;
extern doublereal slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), xerbla_(char *, integer *);
static real bignum;
static logical notrna, notrnb;
static real smlnum, da11;
static complex vec;
static real dum[1], eps, sgn;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#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 c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1
#define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
/* Function Body */
notrna = lsame_(trana, "N");
notrnb = lsame_(tranb, "N");
*info = 0;
if (! notrna && ! lsame_(trana, "T") && ! lsame_(
trana, "C")) {
*info = -1;
} else if (! notrnb && ! lsame_(tranb, "T") && !
lsame_(tranb, "C")) {
*info = -2;
} else if (*isgn != 1 && *isgn != -1) {
*info = -3;
} else if (*m < 0) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*m)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldc < max(1,*m)) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTRSYL", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
/* Set constants to control overflow */
eps = slamch_("P");
smlnum = slamch_("S");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum = smlnum * (real) (*m * *n) / eps;
bignum = 1.f / smlnum;
/* Computing MAX */
r__1 = smlnum, r__2 = eps * clange_("M", m, m, &a[a_offset], lda, dum), r__1 = max(r__1,r__2), r__2 = eps * clange_("M", n, n,
&b[b_offset], ldb, dum);
smin = dmax(r__1,r__2);
*scale = 1.f;
sgn = (real) (*isgn);
if (notrna && notrnb) {
/* Solve A*X + ISGN*X*B = scale*C.
The (K,L)th block of X is determined starting from
bottom-left corner column by column by
A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
Where
M L-1
R(K,L) = SUM [A(K,I)*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)].
I=K+1 J=1 */
i__1 = *n;
for (l = 1; l <= i__1; ++l) {
for (k = *m; k >= 1; --k) {
/* Computing MIN */
i__2 = k + 1;
/* Computing MIN */
i__3 = k + 1;
i__4 = *m - k;
cdotu_(&q__1, &i__4, &a_ref(k, min(i__2,*m)), lda, &c___ref(
min(i__3,*m), l), &c__1);
suml.r = q__1.r, suml.i = q__1.i;
i__2 = l - 1;
cdotu_(&q__1, &i__2, &c___ref(k, 1), ldc, &b_ref(1, l), &c__1)
;
sumr.r = q__1.r, sumr.i = q__1.i;
i__2 = c___subscr(k, l);
q__3.r = sgn * sumr.r, q__3.i = sgn * sumr.i;
q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
q__1.r = c__[i__2].r - q__2.r, q__1.i = c__[i__2].i - q__2.i;
vec.r = q__1.r, vec.i = q__1.i;
scaloc = 1.f;
i__2 = a_subscr(k, k);
i__3 = b_subscr(l, l);
q__2.r = sgn * b[i__3].r, q__2.i = sgn * b[i__3].i;
q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i;
a11.r = q__1.r, a11.i = q__1.i;
da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
dabs(r__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.f;
da11 = smin;
*info = 1;
}
db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
r__2));
if (da11 < 1.f && db > 1.f) {
if (db > bignum * da11) {
scaloc = 1.f / db;
}
}
q__3.r = scaloc, q__3.i = 0.f;
q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
q__3.i + vec.i * q__3.r;
cladiv_(&q__1, &q__2, &a11);
x11.r = q__1.r, x11.i = q__1.i;
if (scaloc != 1.f) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
csscal_(m, &scaloc, &c___ref(1, j), &c__1);
/* L10: */
}
*scale *= scaloc;
}
i__2 = c___subscr(k, l);
c__[i__2].r = x11.r, c__[i__2].i = x11.i;
/* L20: */
}
/* L30: */
}
} else if (! notrna && notrnb) {
/* Solve A' *X + ISGN*X*B = scale*C.
The (K,L)th block of X is determined starting from
upper-left corner column by column by
A'(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
Where
K-1 L-1
R(K,L) = SUM [A'(I,K)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)]
I=1 J=1 */
i__1 = *n;
for (l = 1; l <= i__1; ++l) {
i__2 = *m;
for (k = 1; k <= i__2; ++k) {
i__3 = k - 1;
cdotc_(&q__1, &i__3, &a_ref(1, k), &c__1, &c___ref(1, l), &
c__1);
suml.r = q__1.r, suml.i = q__1.i;
i__3 = l - 1;
cdotu_(&q__1, &i__3, &c___ref(k, 1), ldc, &b_ref(1, l), &c__1)
;
sumr.r = q__1.r, sumr.i = q__1.i;
i__3 = c___subscr(k, l);
q__3.r = sgn * sumr.r, q__3.i = sgn * sumr.i;
q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
vec.r = q__1.r, vec.i = q__1.i;
scaloc = 1.f;
r_cnjg(&q__2, &a_ref(k, k));
i__3 = b_subscr(l, l);
q__3.r = sgn * b[i__3].r, q__3.i = sgn * b[i__3].i;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
a11.r = q__1.r, a11.i = q__1.i;
da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
dabs(r__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.f;
da11 = smin;
*info = 1;
}
db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
r__2));
if (da11 < 1.f && db > 1.f) {
if (db > bignum * da11) {
scaloc = 1.f / db;
}
}
q__3.r = scaloc, q__3.i = 0.f;
q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
q__3.i + vec.i * q__3.r;
cladiv_(&q__1, &q__2, &a11);
x11.r = q__1.r, x11.i = q__1.i;
if (scaloc != 1.f) {
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
csscal_(m, &scaloc, &c___ref(1, j), &c__1);
/* L40: */
}
*scale *= scaloc;
}
i__3 = c___subscr(k, l);
c__[i__3].r = x11.r, c__[i__3].i = x11.i;
/* L50: */
}
/* L60: */
}
} else if (! notrna && ! notrnb) {
/* Solve A'*X + ISGN*X*B' = C.
The (K,L)th block of X is determined starting from
upper-right corner column by column by
A'(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L)
Where
K-1
R(K,L) = SUM [A'(I,K)*X(I,L)] +
I=1
N
ISGN*SUM [X(K,J)*B'(L,J)].
J=L+1 */
for (l = *n; l >= 1; --l) {
i__1 = *m;
for (k = 1; k <= i__1; ++k) {
i__2 = k - 1;
cdotc_(&q__1, &i__2, &a_ref(1, k), &c__1, &c___ref(1, l), &
c__1);
suml.r = q__1.r, suml.i = q__1.i;
/* Computing MIN */
i__2 = l + 1;
/* Computing MIN */
i__3 = l + 1;
i__4 = *n - l;
cdotc_(&q__1, &i__4, &c___ref(k, min(i__2,*n)), ldc, &b_ref(l,
min(i__3,*n)), ldb);
sumr.r = q__1.r, sumr.i = q__1.i;
i__2 = c___subscr(k, l);
r_cnjg(&q__4, &sumr);
q__3.r = sgn * q__4.r, q__3.i = sgn * q__4.i;
q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
q__1.r = c__[i__2].r - q__2.r, q__1.i = c__[i__2].i - q__2.i;
vec.r = q__1.r, vec.i = q__1.i;
scaloc = 1.f;
i__2 = a_subscr(k, k);
i__3 = b_subscr(l, l);
q__3.r = sgn * b[i__3].r, q__3.i = sgn * b[i__3].i;
q__2.r = a[i__2].r + q__3.r, q__2.i = a[i__2].i + q__3.i;
r_cnjg(&q__1, &q__2);
a11.r = q__1.r, a11.i = q__1.i;
da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
dabs(r__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.f;
da11 = smin;
*info = 1;
}
db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
r__2));
if (da11 < 1.f && db > 1.f) {
if (db > bignum * da11) {
scaloc = 1.f / db;
}
}
q__3.r = scaloc, q__3.i = 0.f;
q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
q__3.i + vec.i * q__3.r;
cladiv_(&q__1, &q__2, &a11);
x11.r = q__1.r, x11.i = q__1.i;
if (scaloc != 1.f) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
csscal_(m, &scaloc, &c___ref(1, j), &c__1);
/* L70: */
}
*scale *= scaloc;
}
i__2 = c___subscr(k, l);
c__[i__2].r = x11.r, c__[i__2].i = x11.i;
/* L80: */
}
/* L90: */
}
} else if (notrna && ! notrnb) {
/* Solve A*X + ISGN*X*B' = C.
The (K,L)th block of X is determined starting from
bottom-left corner column by column by
A(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L)
Where
M N
R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B'(L,J)]
I=K+1 J=L+1 */
for (l = *n; l >= 1; --l) {
for (k = *m; k >= 1; --k) {
/* Computing MIN */
i__1 = k + 1;
/* Computing MIN */
i__2 = k + 1;
i__3 = *m - k;
cdotu_(&q__1, &i__3, &a_ref(k, min(i__1,*m)), lda, &c___ref(
min(i__2,*m), l), &c__1);
suml.r = q__1.r, suml.i = q__1.i;
/* Computing MIN */
i__1 = l + 1;
/* Computing MIN */
i__2 = l + 1;
i__3 = *n - l;
cdotc_(&q__1, &i__3, &c___ref(k, min(i__1,*n)), ldc, &b_ref(l,
min(i__2,*n)), ldb);
sumr.r = q__1.r, sumr.i = q__1.i;
i__1 = c___subscr(k, l);
r_cnjg(&q__4, &sumr);
q__3.r = sgn * q__4.r, q__3.i = sgn * q__4.i;
q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
q__1.r = c__[i__1].r - q__2.r, q__1.i = c__[i__1].i - q__2.i;
vec.r = q__1.r, vec.i = q__1.i;
scaloc = 1.f;
i__1 = a_subscr(k, k);
r_cnjg(&q__3, &b_ref(l, l));
q__2.r = sgn * q__3.r, q__2.i = sgn * q__3.i;
q__1.r = a[i__1].r + q__2.r, q__1.i = a[i__1].i + q__2.i;
a11.r = q__1.r, a11.i = q__1.i;
da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
dabs(r__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.f;
da11 = smin;
*info = 1;
}
db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
r__2));
if (da11 < 1.f && db > 1.f) {
if (db > bignum * da11) {
scaloc = 1.f / db;
}
}
q__3.r = scaloc, q__3.i = 0.f;
q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
q__3.i + vec.i * q__3.r;
cladiv_(&q__1, &q__2, &a11);
x11.r = q__1.r, x11.i = q__1.i;
if (scaloc != 1.f) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
csscal_(m, &scaloc, &c___ref(1, j), &c__1);
/* L100: */
}
*scale *= scaloc;
}
i__1 = c___subscr(k, l);
c__[i__1].r = x11.r, c__[i__1].i = x11.i;
/* L110: */
}
/* L120: */
}
}
return 0;
/* End of CTRSYL */
} /* ctrsyl_ */
/* Subroutine */ int clauu2_(char *uplo, integer *n, complex *a, integer *lda,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
real r__1;
complex q__1;
/* Local variables */
integer i__;
real aii;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *);
logical upper;
extern /* Subroutine */ int clacgv_(integer *, complex *, integer *),
csscal_(integer *, real *, complex *, integer *), xerbla_(char *,
integer *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLAUU2 computes the product U * U' or L' * L, where the triangular */
/* factor U or L is stored in the upper or lower triangular part of */
/* the array A. */
/* If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */
/* overwriting the factor U in A. */
/* If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */
/* overwriting the factor L in A. */
/* This is the unblocked form of the algorithm, calling Level 2 BLAS. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the triangular factor stored in the array A */
/* is upper or lower triangular: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the triangular factor U or L. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the triangular factor U or L. */
/* On exit, if UPLO = 'U', the upper triangle of A is */
/* overwritten with the upper triangle of the product U * U'; */
/* if UPLO = 'L', the lower triangle of A is overwritten with */
/* the lower triangle of the product L' * L. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* 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;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CLAUU2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (upper) {
/* Compute the product U * U'. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + i__ * a_dim1;
aii = a[i__2].r;
if (i__ < *n) {
i__2 = i__ + i__ * a_dim1;
i__3 = *n - i__;
cdotc_(&q__1, &i__3, &a[i__ + (i__ + 1) * a_dim1], lda, &a[
i__ + (i__ + 1) * a_dim1], lda);
r__1 = aii * aii + q__1.r;
a[i__2].r = r__1, a[i__2].i = 0.f;
i__2 = *n - i__;
clacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
i__2 = i__ - 1;
i__3 = *n - i__;
q__1.r = aii, q__1.i = 0.f;
cgemv_("No transpose", &i__2, &i__3, &c_b1, &a[(i__ + 1) *
a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, &
q__1, &a[i__ * a_dim1 + 1], &c__1);
i__2 = *n - i__;
clacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
} else {
csscal_(&i__, &aii, &a[i__ * a_dim1 + 1], &c__1);
}
/* L10: */
}
} else {
/* Compute the product L' * L. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + i__ * a_dim1;
aii = a[i__2].r;
if (i__ < *n) {
i__2 = i__ + i__ * a_dim1;
i__3 = *n - i__;
cdotc_(&q__1, &i__3, &a[i__ + 1 + i__ * a_dim1], &c__1, &a[
i__ + 1 + i__ * a_dim1], &c__1);
r__1 = aii * aii + q__1.r;
a[i__2].r = r__1, a[i__2].i = 0.f;
i__2 = i__ - 1;
clacgv_(&i__2, &a[i__ + a_dim1], lda);
i__2 = *n - i__;
i__3 = i__ - 1;
q__1.r = aii, q__1.i = 0.f;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b1, &a[i__ + 1
+ a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &
q__1, &a[i__ + a_dim1], lda);
i__2 = i__ - 1;
clacgv_(&i__2, &a[i__ + a_dim1], lda);
} else {
csscal_(&i__, &aii, &a[i__ + a_dim1], lda);
}
/* L20: */
}
}
return 0;
/* End of CLAUU2 */
} /* clauu2_ */
/* Subroutine */ int cpst01_(char *uplo, integer *n, complex *a, integer *lda,
complex *afac, integer *ldafac, complex *perm, integer *ldperm,
integer *piv, real *rwork, real *resid, integer *rank)
{
/* System generated locals */
integer a_dim1, a_offset, afac_dim1, afac_offset, perm_dim1, perm_offset,
i__1, i__2, i__3, i__4, i__5;
real r__1;
complex q__1;
/* Local variables */
integer i__, j, k;
complex tc;
real tr, eps;
real anorm;
/* -- LAPACK test routine (version 3.1) -- */
/* Craig Lucas, University of Manchester / NAG Ltd. */
/* October, 2008 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CPST01 reconstructs an Hermitian positive semidefinite matrix A */
/* from its L or U factors and the permutation matrix P and computes */
/* the residual */
/* norm( P*L*L'*P' - A ) / ( N * norm(A) * EPS ) or */
/* norm( P*U'*U*P' - A ) / ( N * norm(A) * EPS ), */
/* where EPS is the machine epsilon, L' is the conjugate transpose of L, */
/* and U' is the conjugate transpose of U. */
/* Arguments */
/* ========== */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The number of rows and columns of the matrix A. N >= 0. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The original Hermitian matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N) */
/* AFAC (input) COMPLEX array, dimension (LDAFAC,N) */
/* The factor L or U from the L*L' or U'*U */
/* factorization of A. */
/* LDAFAC (input) INTEGER */
/* The leading dimension of the array AFAC. LDAFAC >= max(1,N). */
/* PERM (output) COMPLEX array, dimension (LDPERM,N) */
/* Overwritten with the reconstructed matrix, and then with the */
/* difference P*L*L'*P' - A (or P*U'*U*P' - A) */
/* LDPERM (input) INTEGER */
/* The leading dimension of the array PERM. */
/* LDAPERM >= max(1,N). */
/* PIV (input) INTEGER array, dimension (N) */
/* PIV is such that the nonzero entries are */
/* P( PIV( K ), K ) = 1. */
/* RWORK (workspace) REAL array, dimension (N) */
/* RESID (output) REAL */
/* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
/* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
afac_dim1 = *ldafac;
afac_offset = 1 + afac_dim1;
afac -= afac_offset;
perm_dim1 = *ldperm;
perm_offset = 1 + perm_dim1;
perm -= perm_offset;
--piv;
--rwork;
/* Function Body */
if (*n <= 0) {
*resid = 0.f;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = slamch_("Epsilon");
anorm = clanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
if (anorm <= 0.f) {
*resid = 1.f / eps;
return 0;
}
/* Check the imaginary parts of the diagonal elements and return with */
/* an error code if any are nonzero. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (r_imag(&afac[j + j * afac_dim1]) != 0.f) {
*resid = 1.f / eps;
return 0;
}
/* L100: */
}
/* Compute the product U'*U, overwriting U. */
if (lsame_(uplo, "U")) {
if (*rank < *n) {
i__1 = *n;
for (j = *rank + 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = *rank + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * afac_dim1;
afac[i__3].r = 0.f, afac[i__3].i = 0.f;
/* L110: */
}
/* L120: */
}
}
for (k = *n; k >= 1; --k) {
/* Compute the (K,K) element of the result. */
cdotc_(&q__1, &k, &afac[k * afac_dim1 + 1], &c__1, &afac[k *
afac_dim1 + 1], &c__1);
tr = q__1.r;
i__1 = k + k * afac_dim1;
afac[i__1].r = tr, afac[i__1].i = 0.f;
/* Compute the rest of column K. */
i__1 = k - 1;
ctrmv_("Upper", "Conjugate", "Non-unit", &i__1, &afac[afac_offset]
, ldafac, &afac[k * afac_dim1 + 1], &c__1);
/* L130: */
}
/* Compute the product L*L', overwriting L. */
} else {
if (*rank < *n) {
i__1 = *n;
for (j = *rank + 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
i__3 = i__ + j * afac_dim1;
afac[i__3].r = 0.f, afac[i__3].i = 0.f;
/* L140: */
}
/* L150: */
}
}
for (k = *n; k >= 1; --k) {
/* Add a multiple of column K of the factor L to each of */
/* columns K+1 through N. */
if (k + 1 <= *n) {
i__1 = *n - k;
cher_("Lower", &i__1, &c_b20, &afac[k + 1 + k * afac_dim1], &
c__1, &afac[k + 1 + (k + 1) * afac_dim1], ldafac);
}
/* Scale column K by the diagonal element. */
i__1 = k + k * afac_dim1;
tc.r = afac[i__1].r, tc.i = afac[i__1].i;
i__1 = *n - k + 1;
cscal_(&i__1, &tc, &afac[k + k * afac_dim1], &c__1);
/* L160: */
}
}
/* Form P*L*L'*P' or P*U'*U*P' */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (piv[i__] <= piv[j]) {
if (i__ <= j) {
i__3 = piv[i__] + piv[j] * perm_dim1;
i__4 = i__ + j * afac_dim1;
perm[i__3].r = afac[i__4].r, perm[i__3].i = afac[i__4]
.i;
} else {
i__3 = piv[i__] + piv[j] * perm_dim1;
r_cnjg(&q__1, &afac[j + i__ * afac_dim1]);
perm[i__3].r = q__1.r, perm[i__3].i = q__1.i;
}
}
/* L170: */
}
/* L180: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (piv[i__] >= piv[j]) {
if (i__ >= j) {
i__3 = piv[i__] + piv[j] * perm_dim1;
i__4 = i__ + j * afac_dim1;
perm[i__3].r = afac[i__4].r, perm[i__3].i = afac[i__4]
.i;
} else {
i__3 = piv[i__] + piv[j] * perm_dim1;
r_cnjg(&q__1, &afac[j + i__ * afac_dim1]);
perm[i__3].r = q__1.r, perm[i__3].i = q__1.i;
}
}
/* L190: */
}
/* L200: */
}
}
/* Compute the difference P*L*L'*P' - A (or P*U'*U*P' - A). */
if (lsame_(uplo, "U")) {
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 * perm_dim1;
i__4 = i__ + j * perm_dim1;
i__5 = i__ + j * a_dim1;
q__1.r = perm[i__4].r - a[i__5].r, q__1.i = perm[i__4].i - a[
i__5].i;
perm[i__3].r = q__1.r, perm[i__3].i = q__1.i;
/* L210: */
}
i__2 = j + j * perm_dim1;
i__3 = j + j * perm_dim1;
i__4 = j + j * a_dim1;
r__1 = a[i__4].r;
q__1.r = perm[i__3].r - r__1, q__1.i = perm[i__3].i;
perm[i__2].r = q__1.r, perm[i__2].i = q__1.i;
/* L220: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j + j * perm_dim1;
i__3 = j + j * perm_dim1;
i__4 = j + j * a_dim1;
r__1 = a[i__4].r;
q__1.r = perm[i__3].r - r__1, q__1.i = perm[i__3].i;
perm[i__2].r = q__1.r, perm[i__2].i = q__1.i;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * perm_dim1;
i__4 = i__ + j * perm_dim1;
i__5 = i__ + j * a_dim1;
q__1.r = perm[i__4].r - a[i__5].r, q__1.i = perm[i__4].i - a[
i__5].i;
perm[i__3].r = q__1.r, perm[i__3].i = q__1.i;
/* L230: */
}
/* L240: */
}
}
/* Compute norm( P*L*L'P - A ) / ( N * norm(A) * EPS ), or */
/* ( P*U'*U*P' - A )/ ( N * norm(A) * EPS ). */
*resid = clanhe_("1", uplo, n, &perm[perm_offset], ldafac, &rwork[1]);
*resid = *resid / (real) (*n) / anorm / eps;
return 0;
/* End of CPST01 */
} /* cpst01_ */
/* DECK CHIDI */
/* Subroutine */ int chidi_(complex *a, integer *lda, integer *n, integer *
kpvt, real *det, integer *inert, complex *work, integer *job)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
real r__1;
complex q__1, q__2, q__3;
/* Local variables */
static real d__;
static integer j, k;
static real t, ak;
static integer jb, ks, km1;
static real ten, akp1;
static complex temp, akkp1;
extern /* Complex */ void cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
static logical nodet;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), cswap_(integer *, complex *, integer *,
complex *, integer *), caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
static integer kstep;
static logical noert, noinv;
/* ***BEGIN PROLOGUE CHIDI */
/* ***PURPOSE Compute the determinant, inertia and inverse of a complex */
/* Hermitian matrix using the factors obtained from CHIFA. */
/* ***LIBRARY SLATEC (LINPACK) */
/* ***CATEGORY D2D1A, D3D1A */
/* ***TYPE COMPLEX (SSIDI-S, DSISI-D, CHIDI-C, CSIDI-C) */
/* ***KEYWORDS DETERMINANT, HERMITIAN, INVERSE, LINEAR ALGEBRA, LINPACK, */
/* MATRIX */
/* ***AUTHOR Bunch, J., (UCSD) */
/* ***DESCRIPTION */
/* CHIDI computes the determinant, inertia and inverse */
/* of a complex Hermitian matrix using the factors from CHIFA. */
/* On Entry */
/* A COMPLEX(LDA,N) */
/* the output from CHIFA. */
/* LDA INTEGER */
/* the leading dimension of the array A. */
/* N INTEGER */
/* the order of the matrix A. */
/* KVPT INTEGER(N) */
/* the pivot vector from CHIFA. */
/* WORK COMPLEX(N) */
/* work vector. Contents destroyed. */
/* JOB INTEGER */
/* JOB has the decimal expansion ABC where */
/* if C .NE. 0, the inverse is computed, */
/* if B .NE. 0, the determinant is computed, */
/* if A .NE. 0, the inertia is computed. */
/* For example, JOB = 111 gives all three. */
/* On Return */
/* Variables not requested by JOB are not used. */
/* A contains the upper triangle of the inverse of */
/* the original matrix. The strict lower triangle */
/* is never referenced. */
/* DET REAL(2) */
/* determinant of original matrix. */
/* Determinant = DET(1) * 10.0**DET(2) */
/* with 1.0 .LE. ABS(DET(1)) .LT. 10.0 */
/* or DET(1) = 0.0. */
/* INERT INTEGER(3) */
/* the inertia of the original matrix. */
/* INERT(1) = number of positive eigenvalues. */
/* INERT(2) = number of negative eigenvalues. */
/* INERT(3) = number of zero eigenvalues. */
/* Error Condition */
/* A division by zero may occur if the inverse is requested */
/* and CHICO has set RCOND .EQ. 0.0 */
/* or CHIFA has set INFO .NE. 0 . */
/* ***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. */
/* Stewart, LINPACK Users' Guide, SIAM, 1979. */
/* ***ROUTINES CALLED CAXPY, CCOPY, CDOTC, CSWAP */
/* ***REVISION HISTORY (YYMMDD) */
/* 780814 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890831 Modified array declarations. (WRB) */
/* 891107 Modified routine equivalence list. (WRB) */
/* 891107 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900326 Removed duplicate information from DESCRIPTION section. */
/* (WRB) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE CHIDI */
/* ***FIRST EXECUTABLE STATEMENT CHIDI */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--kpvt;
--det;
--inert;
--work;
/* Function Body */
noinv = *job % 10 == 0;
nodet = *job % 100 / 10 == 0;
noert = *job % 1000 / 100 == 0;
if (nodet && noert) {
goto L140;
}
if (noert) {
goto L10;
}
inert[1] = 0;
inert[2] = 0;
inert[3] = 0;
L10:
if (nodet) {
goto L20;
}
det[1] = 1.f;
det[2] = 0.f;
ten = 10.f;
L20:
t = 0.f;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
i__2 = k + k * a_dim1;
d__ = a[i__2].r;
/* CHECK IF 1 BY 1 */
if (kpvt[k] > 0) {
goto L50;
}
/* 2 BY 2 BLOCK */
/* USE DET (D S) = (D/T * C - T) * T , T = ABS(S) */
/* (S C) */
/* TO AVOID UNDERFLOW/OVERFLOW TROUBLES. */
/* TAKE TWO PASSES THROUGH SCALING. USE T FOR FLAG. */
if (t != 0.f) {
goto L30;
}
t = c_abs(&a[k + (k + 1) * a_dim1]);
i__2 = k + 1 + (k + 1) * a_dim1;
d__ = d__ / t * a[i__2].r - t;
goto L40;
L30:
d__ = t;
t = 0.f;
L40:
L50:
if (noert) {
goto L60;
}
if (d__ > 0.f) {
++inert[1];
}
if (d__ < 0.f) {
++inert[2];
}
if (d__ == 0.f) {
++inert[3];
}
L60:
if (nodet) {
goto L120;
}
det[1] = d__ * det[1];
if (det[1] == 0.f) {
goto L110;
}
L70:
if (dabs(det[1]) >= 1.f) {
goto L80;
}
det[1] = ten * det[1];
det[2] += -1.f;
goto L70;
L80:
L90:
if (dabs(det[1]) < ten) {
goto L100;
}
det[1] /= ten;
det[2] += 1.f;
goto L90;
L100:
L110:
L120:
/* L130: */
;
}
L140:
/* COMPUTE INVERSE(A) */
if (noinv) {
goto L270;
}
k = 1;
L150:
if (k > *n) {
goto L260;
}
km1 = k - 1;
if (kpvt[k] < 0) {
goto L180;
}
/* 1 BY 1 */
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
r__1 = 1.f / a[i__2].r;
q__1.r = r__1, q__1.i = 0.f;
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
if (km1 < 1) {
goto L170;
}
ccopy_(&km1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
i__1 = km1;
for (j = 1; j <= i__1; ++j) {
i__2 = j + k * a_dim1;
cdotc_(&q__1, &j, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
i__2 = j - 1;
caxpy_(&i__2, &work[j], &a[j * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1],
&c__1);
/* L160: */
}
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
cdotc_(&q__3, &km1, &work[1], &c__1, &a[k * a_dim1 + 1], &c__1);
r__1 = q__3.r;
q__2.r = r__1, q__2.i = 0.f;
q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i;
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
L170:
kstep = 1;
goto L220;
L180:
/* 2 BY 2 */
t = c_abs(&a[k + (k + 1) * a_dim1]);
i__1 = k + k * a_dim1;
ak = a[i__1].r / t;
i__1 = k + 1 + (k + 1) * a_dim1;
akp1 = a[i__1].r / t;
i__1 = k + (k + 1) * a_dim1;
q__1.r = a[i__1].r / t, q__1.i = a[i__1].i / t;
akkp1.r = q__1.r, akkp1.i = q__1.i;
d__ = t * (ak * akp1 - 1.f);
i__1 = k + k * a_dim1;
r__1 = akp1 / d__;
q__1.r = r__1, q__1.i = 0.f;
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
i__1 = k + 1 + (k + 1) * a_dim1;
r__1 = ak / d__;
q__1.r = r__1, q__1.i = 0.f;
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
i__1 = k + (k + 1) * a_dim1;
q__2.r = -akkp1.r, q__2.i = -akkp1.i;
q__1.r = q__2.r / d__, q__1.i = q__2.i / d__;
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
if (km1 < 1) {
goto L210;
}
ccopy_(&km1, &a[(k + 1) * a_dim1 + 1], &c__1, &work[1], &c__1);
i__1 = km1;
for (j = 1; j <= i__1; ++j) {
i__2 = j + (k + 1) * a_dim1;
cdotc_(&q__1, &j, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
i__2 = j - 1;
caxpy_(&i__2, &work[j], &a[j * a_dim1 + 1], &c__1, &a[(k + 1) *
a_dim1 + 1], &c__1);
/* L190: */
}
i__1 = k + 1 + (k + 1) * a_dim1;
i__2 = k + 1 + (k + 1) * a_dim1;
cdotc_(&q__3, &km1, &work[1], &c__1, &a[(k + 1) * a_dim1 + 1], &c__1);
r__1 = q__3.r;
q__2.r = r__1, q__2.i = 0.f;
q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i;
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
i__1 = k + (k + 1) * a_dim1;
i__2 = k + (k + 1) * a_dim1;
cdotc_(&q__2, &km1, &a[k * a_dim1 + 1], &c__1, &a[(k + 1) * a_dim1 + 1], &
c__1);
q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i;
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
ccopy_(&km1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
i__1 = km1;
for (j = 1; j <= i__1; ++j) {
i__2 = j + k * a_dim1;
cdotc_(&q__1, &j, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
i__2 = j - 1;
caxpy_(&i__2, &work[j], &a[j * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1],
&c__1);
/* L200: */
}
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
cdotc_(&q__3, &km1, &work[1], &c__1, &a[k * a_dim1 + 1], &c__1);
r__1 = q__3.r;
q__2.r = r__1, q__2.i = 0.f;
q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i;
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
L210:
kstep = 2;
L220:
/* SWAP */
ks = (i__1 = kpvt[k], abs(i__1));
if (ks == k) {
goto L250;
}
cswap_(&ks, &a[ks * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1);
i__1 = k;
for (jb = ks; jb <= i__1; ++jb) {
j = k + ks - jb;
r_cnjg(&q__1, &a[j + k * a_dim1]);
temp.r = q__1.r, temp.i = q__1.i;
i__2 = j + k * a_dim1;
r_cnjg(&q__1, &a[ks + j * a_dim1]);
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
i__2 = ks + j * a_dim1;
a[i__2].r = temp.r, a[i__2].i = temp.i;
/* L230: */
}
if (kstep == 1) {
goto L240;
}
i__1 = ks + (k + 1) * a_dim1;
temp.r = a[i__1].r, temp.i = a[i__1].i;
i__1 = ks + (k + 1) * a_dim1;
i__2 = k + (k + 1) * a_dim1;
a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
i__1 = k + (k + 1) * a_dim1;
a[i__1].r = temp.r, a[i__1].i = temp.i;
L240:
L250:
k += kstep;
goto L150;
L260:
L270:
return 0;
} /* chidi_ */
/* Subroutine */ int clagsy_(integer *n, integer *k, real *d, complex *a,
integer *lda, integer *iseed, complex *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8,
i__9;
doublereal d__1;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */
double c_abs(complex *);
void c_div(complex *, complex *, complex *);
/* Local variables */
static integer i, j;
extern /* Subroutine */ int cgerc_(integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *);
static complex alpha;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *), caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *), csymv_(char *, integer *,
complex *, complex *, integer *, complex *, integer *, complex *,
complex *, integer *);
extern real scnrm2_(integer *, complex *, integer *);
static integer ii, jj;
static complex wa, wb;
extern /* Subroutine */ int clacgv_(integer *, complex *, integer *);
static real wn;
extern /* Subroutine */ int xerbla_(char *, integer *), clarnv_(
integer *, integer *, integer *, complex *);
static complex tau;
/* -- LAPACK auxiliary test routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CLAGSY generates a complex symmetric matrix A, by pre- and post-
multiplying a real diagonal matrix D with a random unitary matrix:
A = U*D*U**T. The semi-bandwidth may then be reduced to k by
additional unitary transformations.
Arguments
=========
N (input) INTEGER
The order of the matrix A. N >= 0.
K (input) INTEGER
The number of nonzero subdiagonals within the band of A.
0 <= K <= N-1.
D (input) REAL array, dimension (N)
The diagonal elements of the diagonal matrix D.
A (output) COMPLEX array, dimension (LDA,N)
The generated n by n symmetric matrix A (the full matrix is
stored).
LDA (input) INTEGER
The leading dimension of the array A. LDA >= N.
ISEED (input/output) INTEGER array, dimension (4)
On entry, the seed of the random number generator; the array
elements must be between 0 and 4095, and ISEED(4) must be
odd.
On exit, the seed is updated.
WORK (workspace) COMPLEX 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 arguments
Parameter adjustments */
--d;
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--iseed;
--work;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*k < 0 || *k > *n - 1) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info < 0) {
i__1 = -(*info);
xerbla_("CLAGSY", &i__1);
return 0;
}
/* initialize lower triangle of A to diagonal matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i = j + 1; i <= i__2; ++i) {
i__3 = i + j * a_dim1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
/* L10: */
}
/* L20: */
}
i__1 = *n;
for (i = 1; i <= i__1; ++i) {
i__2 = i + i * a_dim1;
i__3 = i;
a[i__2].r = d[i__3], a[i__2].i = 0.f;
/* L30: */
}
/* Generate lower triangle of symmetric matrix */
for (i = *n - 1; i >= 1; --i) {
/* generate random reflection */
i__1 = *n - i + 1;
clarnv_(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *n - i + 1;
wn = scnrm2_(&i__1, &work[1], &c__1);
d__1 = wn / c_abs(&work[1]);
q__1.r = d__1 * work[1].r, q__1.i = d__1 * work[1].i;
wa.r = q__1.r, wa.i = q__1.i;
if (wn == 0.f) {
tau.r = 0.f, tau.i = 0.f;
} else {
q__1.r = work[1].r + wa.r, q__1.i = work[1].i + wa.i;
wb.r = q__1.r, wb.i = q__1.i;
i__1 = *n - i;
c_div(&q__1, &c_b2, &wb);
cscal_(&i__1, &q__1, &work[2], &c__1);
work[1].r = 1.f, work[1].i = 0.f;
c_div(&q__1, &wb, &wa);
d__1 = q__1.r;
tau.r = d__1, tau.i = 0.f;
}
/* apply random reflection to A(i:n,i:n) from the left
and the right
compute y := tau * A * conjg(u) */
i__1 = *n - i + 1;
clacgv_(&i__1, &work[1], &c__1);
i__1 = *n - i + 1;
csymv_("Lower", &i__1, &tau, &a[i + i * a_dim1], lda, &work[1], &c__1,
&c_b1, &work[*n + 1], &c__1);
i__1 = *n - i + 1;
clacgv_(&i__1, &work[1], &c__1);
/* compute v := y - 1/2 * tau * ( u, y ) * u */
q__3.r = -.5f, q__3.i = 0.f;
q__2.r = q__3.r * tau.r - q__3.i * tau.i, q__2.i = q__3.r * tau.i +
q__3.i * tau.r;
i__1 = *n - i + 1;
cdotc_(&q__4, &i__1, &work[1], &c__1, &work[*n + 1], &c__1);
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i
+ q__2.i * q__4.r;
alpha.r = q__1.r, alpha.i = q__1.i;
i__1 = *n - i + 1;
caxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1);
/* apply the transformation as a rank-2 update to A(i:n,i:n)
CALL CSYR2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1,
$ A( I, I ), LDA ) */
i__1 = *n;
for (jj = i; jj <= i__1; ++jj) {
i__2 = *n;
for (ii = jj; ii <= i__2; ++ii) {
i__3 = ii + jj * a_dim1;
i__4 = ii + jj * a_dim1;
i__5 = ii - i + 1;
i__6 = *n + jj - i + 1;
q__3.r = work[i__5].r * work[i__6].r - work[i__5].i * work[
i__6].i, q__3.i = work[i__5].r * work[i__6].i + work[
i__5].i * work[i__6].r;
q__2.r = a[i__4].r - q__3.r, q__2.i = a[i__4].i - q__3.i;
i__7 = *n + ii - i + 1;
i__8 = jj - i + 1;
q__4.r = work[i__7].r * work[i__8].r - work[i__7].i * work[
i__8].i, q__4.i = work[i__7].r * work[i__8].i + work[
i__7].i * work[i__8].r;
q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
a[i__3].r = q__1.r, a[i__3].i = q__1.i;
/* L40: */
}
/* L50: */
}
/* L60: */
}
/* Reduce number of subdiagonals to K */
i__1 = *n - 1 - *k;
for (i = 1; i <= i__1; ++i) {
/* generate reflection to annihilate A(k+i+1:n,i) */
i__2 = *n - *k - i + 1;
wn = scnrm2_(&i__2, &a[*k + i + i * a_dim1], &c__1);
d__1 = wn / c_abs(&a[*k + i + i * a_dim1]);
i__2 = *k + i + i * a_dim1;
q__1.r = d__1 * a[i__2].r, q__1.i = d__1 * a[i__2].i;
wa.r = q__1.r, wa.i = q__1.i;
if (wn == 0.f) {
tau.r = 0.f, tau.i = 0.f;
} else {
i__2 = *k + i + i * a_dim1;
q__1.r = a[i__2].r + wa.r, q__1.i = a[i__2].i + wa.i;
wb.r = q__1.r, wb.i = q__1.i;
i__2 = *n - *k - i;
c_div(&q__1, &c_b2, &wb);
cscal_(&i__2, &q__1, &a[*k + i + 1 + i * a_dim1], &c__1);
i__2 = *k + i + i * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
c_div(&q__1, &wb, &wa);
d__1 = q__1.r;
tau.r = d__1, tau.i = 0.f;
}
/* apply reflection to A(k+i:n,i+1:k+i-1) from the left */
i__2 = *n - *k - i + 1;
i__3 = *k - 1;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i + (i + 1)
* a_dim1], lda, &a[*k + i + i * a_dim1], &c__1, &c_b1, &work[
1], &c__1);
i__2 = *n - *k - i + 1;
i__3 = *k - 1;
q__1.r = -(doublereal)tau.r, q__1.i = -(doublereal)tau.i;
cgerc_(&i__2, &i__3, &q__1, &a[*k + i + i * a_dim1], &c__1, &work[1],
&c__1, &a[*k + i + (i + 1) * a_dim1], lda);
/* apply reflection to A(k+i:n,k+i:n) from the left and the rig
ht
compute y := tau * A * conjg(u) */
i__2 = *n - *k - i + 1;
clacgv_(&i__2, &a[*k + i + i * a_dim1], &c__1);
i__2 = *n - *k - i + 1;
csymv_("Lower", &i__2, &tau, &a[*k + i + (*k + i) * a_dim1], lda, &a[*
k + i + i * a_dim1], &c__1, &c_b1, &work[1], &c__1);
i__2 = *n - *k - i + 1;
clacgv_(&i__2, &a[*k + i + i * a_dim1], &c__1);
/* compute v := y - 1/2 * tau * ( u, y ) * u */
q__3.r = -.5f, q__3.i = 0.f;
q__2.r = q__3.r * tau.r - q__3.i * tau.i, q__2.i = q__3.r * tau.i +
q__3.i * tau.r;
i__2 = *n - *k - i + 1;
cdotc_(&q__4, &i__2, &a[*k + i + i * a_dim1], &c__1, &work[1], &c__1);
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i
+ q__2.i * q__4.r;
alpha.r = q__1.r, alpha.i = q__1.i;
i__2 = *n - *k - i + 1;
caxpy_(&i__2, &alpha, &a[*k + i + i * a_dim1], &c__1, &work[1], &c__1)
;
/* apply symmetric rank-2 update to A(k+i:n,k+i:n)
CALL CSYR2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1,
$ A( K+I, K+I ), LDA ) */
i__2 = *n;
for (jj = *k + i; jj <= i__2; ++jj) {
i__3 = *n;
for (ii = jj; ii <= i__3; ++ii) {
i__4 = ii + jj * a_dim1;
i__5 = ii + jj * a_dim1;
i__6 = ii + i * a_dim1;
i__7 = jj - *k - i + 1;
q__3.r = a[i__6].r * work[i__7].r - a[i__6].i * work[i__7].i,
q__3.i = a[i__6].r * work[i__7].i + a[i__6].i * work[
i__7].r;
q__2.r = a[i__5].r - q__3.r, q__2.i = a[i__5].i - q__3.i;
i__8 = ii - *k - i + 1;
i__9 = jj + i * a_dim1;
q__4.r = work[i__8].r * a[i__9].r - work[i__8].i * a[i__9].i,
q__4.i = work[i__8].r * a[i__9].i + work[i__8].i * a[
i__9].r;
q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
a[i__4].r = q__1.r, a[i__4].i = q__1.i;
/* L70: */
}
/* L80: */
}
i__2 = *k + i + i * a_dim1;
q__1.r = -(doublereal)wa.r, q__1.i = -(doublereal)wa.i;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
i__2 = *n;
for (j = *k + i + 1; j <= i__2; ++j) {
i__3 = j + i * a_dim1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
/* L90: */
}
/* L100: */
}
/* Store full symmetric matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i = j + 1; i <= i__2; ++i) {
i__3 = j + i * a_dim1;
i__4 = i + j * a_dim1;
a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i;
/* L110: */
}
/* L120: */
}
return 0;
/* End of CLAGSY */
} /* clagsy_ */
/* Subroutine */ int cpotf2_(char *uplo, integer *n, complex *a, integer *lda,
integer *info)
{
/* -- LAPACK 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
=======
CPOTF2 computes the Cholesky factorization of a complex Hermitian
positive definite matrix A.
The factorization has the form
A = U' * U , if UPLO = 'U', or
A = L * L', if UPLO = 'L',
where U is an upper triangular matrix and L is lower triangular.
This is the unblocked version of the algorithm, calling Level 2 BLAS.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the upper or lower triangular part of the
Hermitian matrix A is stored.
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) COMPLEX array, dimension (LDA,N)
On entry, the Hermitian matrix A. If UPLO = 'U', the leading
n by n upper triangular part of A contains the upper
triangular part of the matrix A, and the strictly lower
triangular part of A is not referenced. If UPLO = 'L', the
leading n by n lower triangular part of A contains the lower
triangular part of the matrix A, and the strictly upper
triangular part of A is not referenced.
On exit, if INFO = 0, the factor U or L from the Cholesky
factorization A = U'*U or A = L*L'.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -k, the k-th argument had an illegal value
> 0: if INFO = k, the leading minor of order k is not
positive definite, and the factorization could not be
completed.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {1.f,0.f};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
real r__1;
complex q__1, q__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer j;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *);
static logical upper;
extern /* Subroutine */ int clacgv_(integer *, complex *, integer *),
csscal_(integer *, real *, complex *, integer *), xerbla_(char *,
integer *);
static real ajj;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
/* 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;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CPOTF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (upper) {
/* Compute the Cholesky factorization A = U'*U. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute U(J,J) and test for non-positive-definiteness. */
i__2 = a_subscr(j, j);
r__1 = a[i__2].r;
i__3 = j - 1;
cdotc_(&q__2, &i__3, &a_ref(1, j), &c__1, &a_ref(1, j), &c__1);
q__1.r = r__1 - q__2.r, q__1.i = -q__2.i;
ajj = q__1.r;
if (ajj <= 0.f) {
i__2 = a_subscr(j, j);
a[i__2].r = ajj, a[i__2].i = 0.f;
goto L30;
}
ajj = sqrt(ajj);
i__2 = a_subscr(j, j);
a[i__2].r = ajj, a[i__2].i = 0.f;
/* Compute elements J+1:N of row J. */
if (j < *n) {
i__2 = j - 1;
clacgv_(&i__2, &a_ref(1, j), &c__1);
i__2 = j - 1;
i__3 = *n - j;
q__1.r = -1.f, q__1.i = 0.f;
cgemv_("Transpose", &i__2, &i__3, &q__1, &a_ref(1, j + 1),
lda, &a_ref(1, j), &c__1, &c_b1, &a_ref(j, j + 1),
lda);
i__2 = j - 1;
clacgv_(&i__2, &a_ref(1, j), &c__1);
i__2 = *n - j;
r__1 = 1.f / ajj;
csscal_(&i__2, &r__1, &a_ref(j, j + 1), lda);
}
/* L10: */
}
} else {
/* Compute the Cholesky factorization A = L*L'. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute L(J,J) and test for non-positive-definiteness. */
i__2 = a_subscr(j, j);
r__1 = a[i__2].r;
i__3 = j - 1;
cdotc_(&q__2, &i__3, &a_ref(j, 1), lda, &a_ref(j, 1), lda);
q__1.r = r__1 - q__2.r, q__1.i = -q__2.i;
ajj = q__1.r;
if (ajj <= 0.f) {
i__2 = a_subscr(j, j);
a[i__2].r = ajj, a[i__2].i = 0.f;
goto L30;
}
ajj = sqrt(ajj);
i__2 = a_subscr(j, j);
a[i__2].r = ajj, a[i__2].i = 0.f;
/* Compute elements J+1:N of column J. */
if (j < *n) {
i__2 = j - 1;
clacgv_(&i__2, &a_ref(j, 1), lda);
i__2 = *n - j;
i__3 = j - 1;
q__1.r = -1.f, q__1.i = 0.f;
cgemv_("No transpose", &i__2, &i__3, &q__1, &a_ref(j + 1, 1),
lda, &a_ref(j, 1), lda, &c_b1, &a_ref(j + 1, j), &
c__1);
i__2 = j - 1;
clacgv_(&i__2, &a_ref(j, 1), lda);
i__2 = *n - j;
r__1 = 1.f / ajj;
csscal_(&i__2, &r__1, &a_ref(j + 1, j), &c__1);
}
/* L20: */
}
}
goto L40;
L30:
*info = j;
L40:
return 0;
/* End of CPOTF2 */
} /* cpotf2_ */
/* Subroutine */ int clauu2_(char *uplo, integer *n, complex *a, integer *lda,
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
=======
CLAUU2 computes the product U * U' or L' * L, where the triangular
factor U or L is stored in the upper or lower triangular part of
the array A.
If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
overwriting the factor U in A.
If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
overwriting the factor L in A.
This is the unblocked form of the algorithm, calling Level 2 BLAS.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the triangular factor stored in the array A
is upper or lower triangular:
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the triangular factor U or L. N >= 0.
A (input/output) COMPLEX array, dimension (LDA,N)
On entry, the triangular factor U or L.
On exit, if UPLO = 'U', the upper triangle of A is
overwritten with the upper triangle of the product U * U';
if UPLO = 'L', the lower triangle of A is overwritten with
the lower triangle of the product L' * L.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -k, the k-th argument had an illegal value
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {1.f,0.f};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
real r__1;
complex q__1;
/* Local variables */
static integer i__;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *);
static logical upper;
extern /* Subroutine */ int clacgv_(integer *, complex *, integer *),
csscal_(integer *, real *, complex *, integer *), xerbla_(char *,
integer *);
static real aii;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
/* 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;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CLAUU2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (upper) {
/* Compute the product U * U'. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = a_subscr(i__, i__);
aii = a[i__2].r;
if (i__ < *n) {
i__2 = a_subscr(i__, i__);
i__3 = *n - i__;
cdotc_(&q__1, &i__3, &a_ref(i__, i__ + 1), lda, &a_ref(i__,
i__ + 1), lda);
r__1 = aii * aii + q__1.r;
a[i__2].r = r__1, a[i__2].i = 0.f;
i__2 = *n - i__;
clacgv_(&i__2, &a_ref(i__, i__ + 1), lda);
i__2 = i__ - 1;
i__3 = *n - i__;
q__1.r = aii, q__1.i = 0.f;
cgemv_("No transpose", &i__2, &i__3, &c_b1, &a_ref(1, i__ + 1)
, lda, &a_ref(i__, i__ + 1), lda, &q__1, &a_ref(1,
i__), &c__1);
i__2 = *n - i__;
clacgv_(&i__2, &a_ref(i__, i__ + 1), lda);
} else {
csscal_(&i__, &aii, &a_ref(1, i__), &c__1);
}
/* L10: */
}
} else {
/* Compute the product L' * L. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = a_subscr(i__, i__);
aii = a[i__2].r;
if (i__ < *n) {
i__2 = a_subscr(i__, i__);
i__3 = *n - i__;
cdotc_(&q__1, &i__3, &a_ref(i__ + 1, i__), &c__1, &a_ref(i__
+ 1, i__), &c__1);
r__1 = aii * aii + q__1.r;
a[i__2].r = r__1, a[i__2].i = 0.f;
i__2 = i__ - 1;
clacgv_(&i__2, &a_ref(i__, 1), lda);
i__2 = *n - i__;
i__3 = i__ - 1;
q__1.r = aii, q__1.i = 0.f;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b1, &a_ref(i__
+ 1, 1), lda, &a_ref(i__ + 1, i__), &c__1, &q__1, &
a_ref(i__, 1), lda);
i__2 = i__ - 1;
clacgv_(&i__2, &a_ref(i__, 1), lda);
} else {
csscal_(&i__, &aii, &a_ref(i__, 1), lda);
}
/* L20: */
}
}
return 0;
/* End of CLAUU2 */
} /* clauu2_ */
/* DECK CTRSL */
/* Subroutine */ int ctrsl_(complex *t, integer *ldt, integer *n, complex *b,
integer *job, integer *info)
{
/* System generated locals */
integer t_dim1, t_offset, i__1, i__2, i__3, i__4;
real r__1, r__2;
complex q__1, q__2;
/* Local variables */
static integer j, jj, case__;
static complex temp;
extern /* Complex */ void cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
/* ***BEGIN PROLOGUE CTRSL */
/* ***PURPOSE Solve a system of the form T*X=B or CTRANS(T)*X=B, where */
/* T is a triangular matrix. Here CTRANS(T) is the conjugate */
/* transpose. */
/* ***LIBRARY SLATEC (LINPACK) */
/* ***CATEGORY D2C3 */
/* ***TYPE COMPLEX (STRSL-S, DTRSL-D, CTRSL-C) */
/* ***KEYWORDS LINEAR ALGEBRA, LINPACK, TRIANGULAR LINEAR SYSTEM, */
/* TRIANGULAR MATRIX */
/* ***AUTHOR Stewart, G. W., (U. of Maryland) */
/* ***DESCRIPTION */
/* CTRSL solves systems of the form */
/* T * X = B */
/* or */
/* CTRANS(T) * X = B */
/* where T is a triangular matrix of order N. Here CTRANS(T) */
/* denotes the conjugate transpose of the matrix T. */
/* On Entry */
/* T COMPLEX(LDT,N) */
/* T contains the matrix of the system. The zero */
/* elements of the matrix are not referenced, and */
/* the corresponding elements of the array can be */
/* used to store other information. */
/* LDT INTEGER */
/* LDT is the leading dimension of the array T. */
/* N INTEGER */
/* N is the order of the system. */
/* B COMPLEX(N). */
/* B contains the right hand side of the system. */
/* JOB INTEGER */
/* JOB specifies what kind of system is to be solved. */
/* If JOB is */
/* 00 solve T*X = B, T lower triangular, */
/* 01 solve T*X = B, T upper triangular, */
/* 10 solve CTRANS(T)*X = B, T lower triangular, */
/* 11 solve CTRANS(T)*X = B, T upper triangular. */
/* On Return */
/* B B contains the solution, if INFO .EQ. 0. */
/* Otherwise B is unaltered. */
/* INFO INTEGER */
/* INFO contains zero if the system is nonsingular. */
/* Otherwise INFO contains the index of */
/* the first zero diagonal element of T. */
/* ***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. */
/* Stewart, LINPACK Users' Guide, SIAM, 1979. */
/* ***ROUTINES CALLED CAXPY, CDOTC */
/* ***REVISION HISTORY (YYMMDD) */
/* 780814 DATE WRITTEN */
/* 890831 Modified array declarations. (WRB) */
/* 890831 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900326 Removed duplicate information from DESCRIPTION section. */
/* (WRB) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE CTRSL */
/* ***FIRST EXECUTABLE STATEMENT CTRSL */
/* CHECK FOR ZERO DIAGONAL ELEMENTS. */
/* Parameter adjustments */
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
--b;
/* Function Body */
i__1 = *n;
for (*info = 1; *info <= i__1; ++(*info)) {
i__2 = *info + *info * t_dim1;
if ((r__1 = t[i__2].r, dabs(r__1)) + (r__2 = r_imag(&t[*info + *info *
t_dim1]), dabs(r__2)) == 0.f) {
goto L150;
}
/* L10: */
}
*info = 0;
/* DETERMINE THE TASK AND GO TO IT. */
case__ = 1;
if (*job % 10 != 0) {
case__ = 2;
}
if (*job % 100 / 10 != 0) {
case__ += 2;
}
switch (case__) {
case 1: goto L20;
case 2: goto L50;
case 3: goto L80;
case 4: goto L110;
}
/* SOLVE T*X=B FOR T LOWER TRIANGULAR */
L20:
c_div(&q__1, &b[1], &t[t_dim1 + 1]);
b[1].r = q__1.r, b[1].i = q__1.i;
if (*n < 2) {
goto L40;
}
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
i__2 = j - 1;
q__1.r = -b[i__2].r, q__1.i = -b[i__2].i;
temp.r = q__1.r, temp.i = q__1.i;
i__2 = *n - j + 1;
caxpy_(&i__2, &temp, &t[j + (j - 1) * t_dim1], &c__1, &b[j], &c__1);
i__2 = j;
c_div(&q__1, &b[j], &t[j + j * t_dim1]);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L30: */
}
L40:
goto L140;
/* SOLVE T*X=B FOR T UPPER TRIANGULAR. */
L50:
i__1 = *n;
c_div(&q__1, &b[*n], &t[*n + *n * t_dim1]);
b[i__1].r = q__1.r, b[i__1].i = q__1.i;
if (*n < 2) {
goto L70;
}
i__1 = *n;
for (jj = 2; jj <= i__1; ++jj) {
j = *n - jj + 1;
i__2 = j + 1;
q__1.r = -b[i__2].r, q__1.i = -b[i__2].i;
temp.r = q__1.r, temp.i = q__1.i;
caxpy_(&j, &temp, &t[(j + 1) * t_dim1 + 1], &c__1, &b[1], &c__1);
i__2 = j;
c_div(&q__1, &b[j], &t[j + j * t_dim1]);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L60: */
}
L70:
goto L140;
/* SOLVE CTRANS(T)*X=B FOR T LOWER TRIANGULAR. */
L80:
i__1 = *n;
r_cnjg(&q__2, &t[*n + *n * t_dim1]);
c_div(&q__1, &b[*n], &q__2);
b[i__1].r = q__1.r, b[i__1].i = q__1.i;
if (*n < 2) {
goto L100;
}
i__1 = *n;
for (jj = 2; jj <= i__1; ++jj) {
j = *n - jj + 1;
i__2 = j;
i__3 = j;
i__4 = jj - 1;
cdotc_(&q__2, &i__4, &t[j + 1 + j * t_dim1], &c__1, &b[j + 1], &c__1);
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 = j;
r_cnjg(&q__2, &t[j + j * t_dim1]);
c_div(&q__1, &b[j], &q__2);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L90: */
}
L100:
goto L140;
/* SOLVE CTRANS(T)*X=B FOR T UPPER TRIANGULAR. */
L110:
r_cnjg(&q__2, &t[t_dim1 + 1]);
c_div(&q__1, &b[1], &q__2);
b[1].r = q__1.r, b[1].i = q__1.i;
if (*n < 2) {
goto L130;
}
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
i__2 = j;
i__3 = j;
i__4 = j - 1;
cdotc_(&q__2, &i__4, &t[j * t_dim1 + 1], &c__1, &b[1], &c__1);
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 = j;
r_cnjg(&q__2, &t[j + j * t_dim1]);
c_div(&q__1, &b[j], &q__2);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L120: */
}
L130:
L140:
L150:
return 0;
} /* ctrsl_ */
/*< subroutine csvdc(x,ldx,n,p,s,e,u,ldu,v,ldv,work,job,info) >*/
/* Subroutine */ int csvdc_(complex *x, integer *ldx, integer *n, integer *p,
complex *s, complex *e, complex *u, integer *ldu, complex *v, integer
*ldv, complex *work, integer *job, integer *info)
{
/* System generated locals */
integer x_dim1, x_offset, u_dim1, u_offset, v_dim1, v_offset, i__1, i__2,
i__3, i__4;
real r__1, r__2, r__3, r__4;
complex q__1, q__2, q__3;
/* Builtin functions */
double r_imag(complex *), c_abs(complex *);
void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *);
double sqrt(doublereal);
/* Local variables */
real b, c__, f, g;
integer i__, j, k, l=0, m;
complex r__, t;
real t1, el;
integer kk;
real cs;
integer ll, mm, ls=0;
real sl;
integer lu;
real sm, sn;
integer lm1, mm1, lp1, mp1, nct, ncu, lls, nrt;
real emm1, smm1;
integer kase, jobu, iter;
real test;
integer nctp1, nrtp1;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
real scale;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
real shift;
extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
complex *, integer *);
integer maxit;
extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *), csrot_(integer *, complex *,
integer *, complex *, integer *, real *, real *);
logical wantu, wantv;
extern /* Subroutine */ int srotg_(real *, real *, real *, real *);
real ztest;
extern doublereal scnrm2_(integer *, complex *, integer *);
/*< integer ldx,n,p,ldu,ldv,job,info >*/
/*< complex x(ldx,1),s(1),e(1),u(ldu,1),v(ldv,1),work(1) >*/
/* csvdc is a subroutine to reduce a complex nxp matrix x by */
/* unitary transformations u and v to diagonal form. the */
/* diagonal elements s(i) are the singular values of x. the */
/* columns of u are the corresponding left singular vectors, */
/* and the columns of v the right singular vectors. */
/* on entry */
/* x complex(ldx,p), where ldx.ge.n. */
/* x contains the matrix whose singular value */
/* decomposition is to be computed. x is */
/* destroyed by csvdc. */
/* ldx integer. */
/* ldx is the leading dimension of the array x. */
/* n integer. */
/* n is the number of rows of the matrix x. */
/* p integer. */
/* p is the number of columns of the matrix x. */
/* ldu integer. */
/* ldu is the leading dimension of the array u */
/* (see below). */
/* ldv integer. */
/* ldv is the leading dimension of the array v */
/* (see below). */
/* work complex(n). */
/* work is a scratch array. */
/* job integer. */
/* job controls the computation of the singular */
/* vectors. it has the decimal expansion ab */
/* with the following meaning */
/* a.eq.0 do not compute the left singular */
/* vectors. */
/* a.eq.1 return the n left singular vectors */
/* in u. */
/* a.ge.2 returns the first min(n,p) */
/* left singular vectors in u. */
/* b.eq.0 do not compute the right singular */
/* vectors. */
/* b.eq.1 return the right singular vectors */
/* in v. */
/* on return */
/* s complex(mm), where mm=min(n+1,p). */
/* the first min(n,p) entries of s contain the */
/* singular values of x arranged in descending */
/* order of magnitude. */
/* e complex(p). */
/* e ordinarily contains zeros. however see the */
/* discussion of info for exceptions. */
/* u complex(ldu,k), where ldu.ge.n. if joba.eq.1 then */
/* k.eq.n, if joba.ge.2 then */
/* k.eq.min(n,p). */
/* u contains the matrix of left singular vectors. */
/* u is not referenced if joba.eq.0. if n.le.p */
/* or if joba.gt.2, then u may be identified with x */
/* in the subroutine call. */
/* v complex(ldv,p), where ldv.ge.p. */
/* v contains the matrix of right singular vectors. */
/* v is not referenced if jobb.eq.0. if p.le.n, */
/* then v may be identified whth x in the */
/* subroutine call. */
/* info integer. */
/* the singular values (and their corresponding */
/* singular vectors) s(info+1),s(info+2),...,s(m) */
/* are correct (here m=min(n,p)). thus if */
/* info.eq.0, all the singular values and their */
/* vectors are correct. in any event, the matrix */
/* b = ctrans(u)*x*v is the bidiagonal matrix */
/* with the elements of s on its diagonal and the */
/* elements of e on its super-diagonal (ctrans(u) */
/* is the conjugate-transpose of u). thus the */
/* singular values of x and b are the same. */
/* linpack. this version dated 03/19/79 . */
/* correction to shift calculation made 2/85. */
/* g.w. stewart, university of maryland, argonne national lab. */
/* csvdc uses the following functions and subprograms. */
/* external csrot */
/* blas caxpy,cdotc,cscal,cswap,scnrm2,srotg */
/* fortran abs,aimag,amax1,cabs,cmplx */
/* fortran conjg,max0,min0,mod,real,sqrt */
/* internal variables */
/*< >*/
/*< complex cdotc,t,r >*/
/*< >*/
/*< logical wantu,wantv >*/
/*< complex csign,zdum,zdum1,zdum2 >*/
/*< real cabs1 >*/
/*< cabs1(zdum) = abs(real(zdum)) + abs(aimag(zdum)) >*/
/*< csign(zdum1,zdum2) = cabs(zdum1)*(zdum2/cabs(zdum2)) >*/
/* set the maximum number of iterations. */
/*< maxit = 1000 >*/
/* Parameter adjustments */
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--s;
--e;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--work;
/* Function Body */
maxit = 1000;
/* determine what is to be computed. */
/*< wantu = .false. >*/
wantu = FALSE_;
/*< wantv = .false. >*/
wantv = FALSE_;
/*< jobu = mod(job,100)/10 >*/
jobu = *job % 100 / 10;
/*< ncu = n >*/
ncu = *n;
/*< if (jobu .gt. 1) ncu = min0(n,p) >*/
if (jobu > 1) {
ncu = min(*n,*p);
}
/*< if (jobu .ne. 0) wantu = .true. >*/
if (jobu != 0) {
wantu = TRUE_;
}
/*< if (mod(job,10) .ne. 0) wantv = .true. >*/
if (*job % 10 != 0) {
wantv = TRUE_;
}
/* reduce x to bidiagonal form, storing the diagonal elements */
/* in s and the super-diagonal elements in e. */
/*< info = 0 >*/
*info = 0;
/*< nct = min0(n-1,p) >*/
/* Computing MIN */
i__1 = *n - 1;
nct = min(i__1,*p);
/*< nrt = max0(0,min0(p-2,n)) >*/
/* Computing MAX */
/* Computing MIN */
i__3 = *p - 2;
i__1 = 0, i__2 = min(i__3,*n);
nrt = max(i__1,i__2);
/*< lu = max0(nct,nrt) >*/
lu = max(nct,nrt);
/*< if (lu .lt. 1) go to 170 >*/
if (lu < 1) {
goto L170;
}
/*< do 160 l = 1, lu >*/
i__1 = lu;
for (l = 1; l <= i__1; ++l) {
/*< lp1 = l + 1 >*/
lp1 = l + 1;
/*< if (l .gt. nct) go to 20 >*/
if (l > nct) {
goto L20;
}
/* compute the transformation for the l-th column and */
/* place the l-th diagonal in s(l). */
/*< s(l) = cmplx(scnrm2(n-l+1,x(l,l),1),0.0e0) >*/
i__2 = l;
i__3 = *n - l + 1;
r__1 = scnrm2_(&i__3, &x[l + l * x_dim1], &c__1);
q__1.r = r__1, q__1.i = (float)0.;
s[i__2].r = q__1.r, s[i__2].i = q__1.i;
/*< if (cabs1(s(l)) .eq. 0.0e0) go to 10 >*/
i__2 = l;
if ((r__1 = s[i__2].r, dabs(r__1)) + (r__2 = r_imag(&s[l]), dabs(r__2)
) == (float)0.) {
goto L10;
}
/*< if (cabs1(x(l,l)) .ne. 0.0e0) s(l) = csign(s(l),x(l,l)) >*/
i__2 = l + l * x_dim1;
if ((r__1 = x[i__2].r, dabs(r__1)) + (r__2 = r_imag(&x[l + l * x_dim1]
), dabs(r__2)) != (float)0.) {
i__3 = l;
r__3 = c_abs(&s[l]);
i__4 = l + l * x_dim1;
r__4 = c_abs(&x[l + l * x_dim1]);
q__2.r = x[i__4].r / r__4, q__2.i = x[i__4].i / r__4;
q__1.r = r__3 * q__2.r, q__1.i = r__3 * q__2.i;
s[i__3].r = q__1.r, s[i__3].i = q__1.i;
}
/*< call cscal(n-l+1,1.0e0/s(l),x(l,l),1) >*/
i__2 = *n - l + 1;
c_div(&q__1, &c_b8, &s[l]);
cscal_(&i__2, &q__1, &x[l + l * x_dim1], &c__1);
/*< x(l,l) = (1.0e0,0.0e0) + x(l,l) >*/
i__2 = l + l * x_dim1;
i__3 = l + l * x_dim1;
q__1.r = x[i__3].r + (float)1., q__1.i = x[i__3].i + (float)0.;
x[i__2].r = q__1.r, x[i__2].i = q__1.i;
/*< 10 continue >*/
L10:
/*< s(l) = -s(l) >*/
i__2 = l;
i__3 = l;
q__1.r = -s[i__3].r, q__1.i = -s[i__3].i;
s[i__2].r = q__1.r, s[i__2].i = q__1.i;
/*< 20 continue >*/
L20:
/*< if (p .lt. lp1) go to 50 >*/
if (*p < lp1) {
goto L50;
}
/*< do 40 j = lp1, p >*/
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
/*< if (l .gt. nct) go to 30 >*/
if (l > nct) {
goto L30;
}
/*< if (cabs1(s(l)) .eq. 0.0e0) go to 30 >*/
i__3 = l;
if ((r__1 = s[i__3].r, dabs(r__1)) + (r__2 = r_imag(&s[l]), dabs(
r__2)) == (float)0.) {
goto L30;
}
/* apply the transformation. */
/*< t = -cdotc(n-l+1,x(l,l),1,x(l,j),1)/x(l,l) >*/
i__3 = *n - l + 1;
cdotc_(&q__3, &i__3, &x[l + l * x_dim1], &c__1, &x[l + j * x_dim1]
, &c__1);
q__2.r = -q__3.r, q__2.i = -q__3.i;
c_div(&q__1, &q__2, &x[l + l * x_dim1]);
t.r = q__1.r, t.i = q__1.i;
/*< call caxpy(n-l+1,t,x(l,l),1,x(l,j),1) >*/
i__3 = *n - l + 1;
caxpy_(&i__3, &t, &x[l + l * x_dim1], &c__1, &x[l + j * x_dim1], &
c__1);
/*< 30 continue >*/
L30:
/* place the l-th row of x into e for the */
/* subsequent calculation of the row transformation. */
/*< e(j) = conjg(x(l,j)) >*/
i__3 = j;
r_cnjg(&q__1, &x[l + j * x_dim1]);
e[i__3].r = q__1.r, e[i__3].i = q__1.i;
/*< 40 continue >*/
/* L40: */
}
/*< 50 continue >*/
L50:
/*< if (.not.wantu .or. l .gt. nct) go to 70 >*/
if (! wantu || l > nct) {
goto L70;
}
/* place the transformation in u for subsequent back */
/* multiplication. */
/*< do 60 i = l, n >*/
i__2 = *n;
for (i__ = l; i__ <= i__2; ++i__) {
/*< u(i,l) = x(i,l) >*/
i__3 = i__ + l * u_dim1;
i__4 = i__ + l * x_dim1;
u[i__3].r = x[i__4].r, u[i__3].i = x[i__4].i;
/*< 60 continue >*/
/* L60: */
}
/*< 70 continue >*/
L70:
/*< if (l .gt. nrt) go to 150 >*/
if (l > nrt) {
goto L150;
}
/* compute the l-th row transformation and place the */
/* l-th super-diagonal in e(l). */
/*< e(l) = cmplx(scnrm2(p-l,e(lp1),1),0.0e0) >*/
i__2 = l;
i__3 = *p - l;
r__1 = scnrm2_(&i__3, &e[lp1], &c__1);
q__1.r = r__1, q__1.i = (float)0.;
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
/*< if (cabs1(e(l)) .eq. 0.0e0) go to 80 >*/
i__2 = l;
if ((r__1 = e[i__2].r, dabs(r__1)) + (r__2 = r_imag(&e[l]), dabs(r__2)
) == (float)0.) {
goto L80;
}
/*< if (cabs1(e(lp1)) .ne. 0.0e0) e(l) = csign(e(l),e(lp1)) >*/
i__2 = lp1;
if ((r__1 = e[i__2].r, dabs(r__1)) + (r__2 = r_imag(&e[lp1]), dabs(
r__2)) != (float)0.) {
i__3 = l;
r__3 = c_abs(&e[l]);
i__4 = lp1;
r__4 = c_abs(&e[lp1]);
q__2.r = e[i__4].r / r__4, q__2.i = e[i__4].i / r__4;
q__1.r = r__3 * q__2.r, q__1.i = r__3 * q__2.i;
e[i__3].r = q__1.r, e[i__3].i = q__1.i;
}
/*< call cscal(p-l,1.0e0/e(l),e(lp1),1) >*/
i__2 = *p - l;
c_div(&q__1, &c_b8, &e[l]);
cscal_(&i__2, &q__1, &e[lp1], &c__1);
/*< e(lp1) = (1.0e0,0.0e0) + e(lp1) >*/
i__2 = lp1;
i__3 = lp1;
q__1.r = e[i__3].r + (float)1., q__1.i = e[i__3].i + (float)0.;
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
/*< 80 continue >*/
L80:
/*< e(l) = -conjg(e(l)) >*/
i__2 = l;
r_cnjg(&q__2, &e[l]);
q__1.r = -q__2.r, q__1.i = -q__2.i;
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
/*< if (lp1 .gt. n .or. cabs1(e(l)) .eq. 0.0e0) go to 120 >*/
i__2 = l;
if (lp1 > *n || (r__1 = e[i__2].r, dabs(r__1)) + (r__2 = r_imag(&e[l])
, dabs(r__2)) == (float)0.) {
goto L120;
}
/* apply the transformation. */
/*< do 90 i = lp1, n >*/
i__2 = *n;
for (i__ = lp1; i__ <= i__2; ++i__) {
/*< work(i) = (0.0e0,0.0e0) >*/
i__3 = i__;
work[i__3].r = (float)0., work[i__3].i = (float)0.;
/*< 90 continue >*/
/* L90: */
}
/*< do 100 j = lp1, p >*/
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
/*< call caxpy(n-l,e(j),x(lp1,j),1,work(lp1),1) >*/
i__3 = *n - l;
caxpy_(&i__3, &e[j], &x[lp1 + j * x_dim1], &c__1, &work[lp1], &
c__1);
/*< 100 continue >*/
/* L100: */
}
/*< do 110 j = lp1, p >*/
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
/*< >*/
i__3 = *n - l;
i__4 = j;
q__3.r = -e[i__4].r, q__3.i = -e[i__4].i;
c_div(&q__2, &q__3, &e[lp1]);
r_cnjg(&q__1, &q__2);
caxpy_(&i__3, &q__1, &work[lp1], &c__1, &x[lp1 + j * x_dim1], &
c__1);
/*< 110 continue >*/
/* L110: */
}
/*< 120 continue >*/
L120:
/*< if (.not.wantv) go to 140 >*/
if (! wantv) {
goto L140;
}
/* place the transformation in v for subsequent */
/* back multiplication. */
/*< do 130 i = lp1, p >*/
i__2 = *p;
for (i__ = lp1; i__ <= i__2; ++i__) {
/*< v(i,l) = e(i) >*/
i__3 = i__ + l * v_dim1;
i__4 = i__;
v[i__3].r = e[i__4].r, v[i__3].i = e[i__4].i;
/*< 130 continue >*/
/* L130: */
}
/*< 140 continue >*/
L140:
/*< 150 continue >*/
L150:
/*< 160 continue >*/
/* L160: */
;
}
/*< 170 continue >*/
L170:
/* set up the final bidiagonal matrix or order m. */
/*< m = min0(p,n+1) >*/
/* Computing MIN */
i__1 = *p, i__2 = *n + 1;
m = min(i__1,i__2);
/*< nctp1 = nct + 1 >*/
nctp1 = nct + 1;
/*< nrtp1 = nrt + 1 >*/
nrtp1 = nrt + 1;
/*< if (nct .lt. p) s(nctp1) = x(nctp1,nctp1) >*/
if (nct < *p) {
i__1 = nctp1;
i__2 = nctp1 + nctp1 * x_dim1;
s[i__1].r = x[i__2].r, s[i__1].i = x[i__2].i;
}
/*< if (n .lt. m) s(m) = (0.0e0,0.0e0) >*/
if (*n < m) {
i__1 = m;
s[i__1].r = (float)0., s[i__1].i = (float)0.;
}
/*< if (nrtp1 .lt. m) e(nrtp1) = x(nrtp1,m) >*/
if (nrtp1 < m) {
i__1 = nrtp1;
i__2 = nrtp1 + m * x_dim1;
e[i__1].r = x[i__2].r, e[i__1].i = x[i__2].i;
}
/*< e(m) = (0.0e0,0.0e0) >*/
i__1 = m;
e[i__1].r = (float)0., e[i__1].i = (float)0.;
/* if required, generate u. */
/*< if (.not.wantu) go to 300 >*/
if (! wantu) {
goto L300;
}
/*< if (ncu .lt. nctp1) go to 200 >*/
if (ncu < nctp1) {
goto L200;
}
/*< do 190 j = nctp1, ncu >*/
i__1 = ncu;
for (j = nctp1; j <= i__1; ++j) {
/*< do 180 i = 1, n >*/
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/*< u(i,j) = (0.0e0,0.0e0) >*/
i__3 = i__ + j * u_dim1;
u[i__3].r = (float)0., u[i__3].i = (float)0.;
/*< 180 continue >*/
/* L180: */
}
/*< u(j,j) = (1.0e0,0.0e0) >*/
i__2 = j + j * u_dim1;
u[i__2].r = (float)1., u[i__2].i = (float)0.;
/*< 190 continue >*/
/* L190: */
}
/*< 200 continue >*/
L200:
/*< if (nct .lt. 1) go to 290 >*/
if (nct < 1) {
goto L290;
}
/*< do 280 ll = 1, nct >*/
i__1 = nct;
for (ll = 1; ll <= i__1; ++ll) {
/*< l = nct - ll + 1 >*/
l = nct - ll + 1;
/*< if (cabs1(s(l)) .eq. 0.0e0) go to 250 >*/
i__2 = l;
if ((r__1 = s[i__2].r, dabs(r__1)) + (r__2 = r_imag(&s[l]), dabs(r__2)
) == (float)0.) {
goto L250;
}
/*< lp1 = l + 1 >*/
lp1 = l + 1;
/*< if (ncu .lt. lp1) go to 220 >*/
if (ncu < lp1) {
goto L220;
}
/*< do 210 j = lp1, ncu >*/
i__2 = ncu;
for (j = lp1; j <= i__2; ++j) {
/*< t = -cdotc(n-l+1,u(l,l),1,u(l,j),1)/u(l,l) >*/
i__3 = *n - l + 1;
cdotc_(&q__3, &i__3, &u[l + l * u_dim1], &c__1, &u[l + j * u_dim1]
, &c__1);
q__2.r = -q__3.r, q__2.i = -q__3.i;
c_div(&q__1, &q__2, &u[l + l * u_dim1]);
t.r = q__1.r, t.i = q__1.i;
/*< call caxpy(n-l+1,t,u(l,l),1,u(l,j),1) >*/
i__3 = *n - l + 1;
caxpy_(&i__3, &t, &u[l + l * u_dim1], &c__1, &u[l + j * u_dim1], &
c__1);
/*< 210 continue >*/
/* L210: */
}
/*< 220 continue >*/
L220:
/*< call cscal(n-l+1,(-1.0e0,0.0e0),u(l,l),1) >*/
i__2 = *n - l + 1;
cscal_(&i__2, &c_b53, &u[l + l * u_dim1], &c__1);
/*< u(l,l) = (1.0e0,0.0e0) + u(l,l) >*/
i__2 = l + l * u_dim1;
i__3 = l + l * u_dim1;
q__1.r = u[i__3].r + (float)1., q__1.i = u[i__3].i + (float)0.;
u[i__2].r = q__1.r, u[i__2].i = q__1.i;
/*< lm1 = l - 1 >*/
lm1 = l - 1;
/*< if (lm1 .lt. 1) go to 240 >*/
if (lm1 < 1) {
goto L240;
}
/*< do 230 i = 1, lm1 >*/
i__2 = lm1;
for (i__ = 1; i__ <= i__2; ++i__) {
/*< u(i,l) = (0.0e0,0.0e0) >*/
i__3 = i__ + l * u_dim1;
u[i__3].r = (float)0., u[i__3].i = (float)0.;
/*< 230 continue >*/
/* L230: */
}
/*< 240 continue >*/
L240:
/*< go to 270 >*/
goto L270;
/*< 250 continue >*/
L250:
/*< do 260 i = 1, n >*/
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/*< u(i,l) = (0.0e0,0.0e0) >*/
i__3 = i__ + l * u_dim1;
u[i__3].r = (float)0., u[i__3].i = (float)0.;
/*< 260 continue >*/
/* L260: */
}
/*< u(l,l) = (1.0e0,0.0e0) >*/
i__2 = l + l * u_dim1;
u[i__2].r = (float)1., u[i__2].i = (float)0.;
/*< 270 continue >*/
L270:
/*< 280 continue >*/
/* L280: */
;
}
/*< 290 continue >*/
L290:
/*< 300 continue >*/
L300:
/* if it is required, generate v. */
/*< if (.not.wantv) go to 350 >*/
if (! wantv) {
goto L350;
}
/*< do 340 ll = 1, p >*/
i__1 = *p;
for (ll = 1; ll <= i__1; ++ll) {
/*< l = p - ll + 1 >*/
l = *p - ll + 1;
/*< lp1 = l + 1 >*/
lp1 = l + 1;
/*< if (l .gt. nrt) go to 320 >*/
if (l > nrt) {
goto L320;
}
/*< if (cabs1(e(l)) .eq. 0.0e0) go to 320 >*/
i__2 = l;
if ((r__1 = e[i__2].r, dabs(r__1)) + (r__2 = r_imag(&e[l]), dabs(r__2)
) == (float)0.) {
goto L320;
}
/*< do 310 j = lp1, p >*/
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
/*< t = -cdotc(p-l,v(lp1,l),1,v(lp1,j),1)/v(lp1,l) >*/
i__3 = *p - l;
cdotc_(&q__3, &i__3, &v[lp1 + l * v_dim1], &c__1, &v[lp1 + j *
v_dim1], &c__1);
q__2.r = -q__3.r, q__2.i = -q__3.i;
c_div(&q__1, &q__2, &v[lp1 + l * v_dim1]);
t.r = q__1.r, t.i = q__1.i;
/*< call caxpy(p-l,t,v(lp1,l),1,v(lp1,j),1) >*/
i__3 = *p - l;
caxpy_(&i__3, &t, &v[lp1 + l * v_dim1], &c__1, &v[lp1 + j *
v_dim1], &c__1);
/*< 310 continue >*/
/* L310: */
}
/*< 320 continue >*/
L320:
/*< do 330 i = 1, p >*/
i__2 = *p;
for (i__ = 1; i__ <= i__2; ++i__) {
/*< v(i,l) = (0.0e0,0.0e0) >*/
i__3 = i__ + l * v_dim1;
v[i__3].r = (float)0., v[i__3].i = (float)0.;
/*< 330 continue >*/
/* L330: */
}
/*< v(l,l) = (1.0e0,0.0e0) >*/
i__2 = l + l * v_dim1;
v[i__2].r = (float)1., v[i__2].i = (float)0.;
/*< 340 continue >*/
/* L340: */
}
/*< 350 continue >*/
L350:
/* transform s and e so that they are real. */
/*< do 380 i = 1, m >*/
i__1 = m;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< if (cabs1(s(i)) .eq. 0.0e0) go to 360 >*/
i__2 = i__;
if ((r__1 = s[i__2].r, dabs(r__1)) + (r__2 = r_imag(&s[i__]), dabs(
r__2)) == (float)0.) {
goto L360;
}
/*< t = cmplx(cabs(s(i)),0.0e0) >*/
r__1 = c_abs(&s[i__]);
q__1.r = r__1, q__1.i = (float)0.;
t.r = q__1.r, t.i = q__1.i;
/*< r = s(i)/t >*/
c_div(&q__1, &s[i__], &t);
r__.r = q__1.r, r__.i = q__1.i;
/*< s(i) = t >*/
i__2 = i__;
s[i__2].r = t.r, s[i__2].i = t.i;
/*< if (i .lt. m) e(i) = e(i)/r >*/
if (i__ < m) {
i__2 = i__;
c_div(&q__1, &e[i__], &r__);
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
}
/*< if (wantu) call cscal(n,r,u(1,i),1) >*/
if (wantu) {
cscal_(n, &r__, &u[i__ * u_dim1 + 1], &c__1);
}
/*< 360 continue >*/
L360:
/* ...exit */
/*< if (i .eq. m) go to 390 >*/
if (i__ == m) {
goto L390;
}
/*< if (cabs1(e(i)) .eq. 0.0e0) go to 370 >*/
i__2 = i__;
if ((r__1 = e[i__2].r, dabs(r__1)) + (r__2 = r_imag(&e[i__]), dabs(
r__2)) == (float)0.) {
goto L370;
}
/*< t = cmplx(cabs(e(i)),0.0e0) >*/
r__1 = c_abs(&e[i__]);
q__1.r = r__1, q__1.i = (float)0.;
t.r = q__1.r, t.i = q__1.i;
/*< r = t/e(i) >*/
c_div(&q__1, &t, &e[i__]);
r__.r = q__1.r, r__.i = q__1.i;
/*< e(i) = t >*/
i__2 = i__;
e[i__2].r = t.r, e[i__2].i = t.i;
/*< s(i+1) = s(i+1)*r >*/
i__2 = i__ + 1;
i__3 = i__ + 1;
q__1.r = s[i__3].r * r__.r - s[i__3].i * r__.i, q__1.i = s[i__3].r *
r__.i + s[i__3].i * r__.r;
s[i__2].r = q__1.r, s[i__2].i = q__1.i;
/*< if (wantv) call cscal(p,r,v(1,i+1),1) >*/
if (wantv) {
cscal_(p, &r__, &v[(i__ + 1) * v_dim1 + 1], &c__1);
}
/*< 370 continue >*/
L370:
/*< 380 continue >*/
/* L380: */
;
}
/*< 390 continue >*/
L390:
/* main iteration loop for the singular values. */
/*< mm = m >*/
mm = m;
/*< iter = 0 >*/
iter = 0;
/*< 400 continue >*/
L400:
/* quit if all the singular values have been found. */
/* ...exit */
/*< if (m .eq. 0) go to 660 >*/
if (m == 0) {
goto L660;
}
/* if too many iterations have been performed, set */
/* flag and return. */
/*< if (iter .lt. maxit) go to 410 >*/
if (iter < maxit) {
goto L410;
}
/*< info = m >*/
*info = m;
/* ......exit */
/*< go to 660 >*/
goto L660;
/*< 410 continue >*/
L410:
/* this section of the program inspects for */
/* negligible elements in the s and e arrays. on */
/* completion the variables kase and l are set as follows. */
/* kase = 1 if s(m) and e(l-1) are negligible and l.lt.m */
/* kase = 2 if s(l) is negligible and l.lt.m */
/* kase = 3 if e(l-1) is negligible, l.lt.m, and */
/* s(l), ..., s(m) are not negligible (qr step). */
/* kase = 4 if e(m-1) is negligible (convergence). */
/*< do 430 ll = 1, m >*/
i__1 = m;
for (ll = 1; ll <= i__1; ++ll) {
/*< l = m - ll >*/
l = m - ll;
/* ...exit */
/*< if (l .eq. 0) go to 440 >*/
if (l == 0) {
goto L440;
}
/*< test = cabs(s(l)) + cabs(s(l+1)) >*/
test = c_abs(&s[l]) + c_abs(&s[l + 1]);
/*< ztest = test + cabs(e(l)) >*/
ztest = test + c_abs(&e[l]);
/*< if (ztest .ne. test) go to 420 >*/
if (ztest != test) {
goto L420;
}
/*< e(l) = (0.0e0,0.0e0) >*/
i__2 = l;
e[i__2].r = (float)0., e[i__2].i = (float)0.;
/* ......exit */
/*< go to 440 >*/
goto L440;
/*< 420 continue >*/
L420:
/*< 430 continue >*/
/* L430: */
;
}
/*< 440 continue >*/
L440:
/*< if (l .ne. m - 1) go to 450 >*/
if (l != m - 1) {
goto L450;
}
/*< kase = 4 >*/
kase = 4;
/*< go to 520 >*/
goto L520;
/*< 450 continue >*/
L450:
/*< lp1 = l + 1 >*/
lp1 = l + 1;
/*< mp1 = m + 1 >*/
mp1 = m + 1;
/*< do 470 lls = lp1, mp1 >*/
i__1 = mp1;
for (lls = lp1; lls <= i__1; ++lls) {
/*< ls = m - lls + lp1 >*/
ls = m - lls + lp1;
/* ...exit */
/*< if (ls .eq. l) go to 480 >*/
if (ls == l) {
goto L480;
}
/*< test = 0.0e0 >*/
test = (float)0.;
/*< if (ls .ne. m) test = test + cabs(e(ls)) >*/
if (ls != m) {
test += c_abs(&e[ls]);
}
/*< if (ls .ne. l + 1) test = test + cabs(e(ls-1)) >*/
if (ls != l + 1) {
test += c_abs(&e[ls - 1]);
}
/*< ztest = test + cabs(s(ls)) >*/
ztest = test + c_abs(&s[ls]);
/*< if (ztest .ne. test) go to 460 >*/
if (ztest != test) {
goto L460;
}
/*< s(ls) = (0.0e0,0.0e0) >*/
i__2 = ls;
s[i__2].r = (float)0., s[i__2].i = (float)0.;
/* ......exit */
/*< go to 480 >*/
goto L480;
/*< 460 continue >*/
L460:
/*< 470 continue >*/
/* L470: */
;
}
/*< 480 continue >*/
L480:
/*< if (ls .ne. l) go to 490 >*/
if (ls != l) {
goto L490;
}
/*< kase = 3 >*/
kase = 3;
/*< go to 510 >*/
goto L510;
/*< 490 continue >*/
L490:
/*< if (ls .ne. m) go to 500 >*/
if (ls != m) {
goto L500;
}
/*< kase = 1 >*/
kase = 1;
/*< go to 510 >*/
goto L510;
/*< 500 continue >*/
L500:
/*< kase = 2 >*/
kase = 2;
/*< l = ls >*/
l = ls;
/*< 510 continue >*/
L510:
/*< 520 continue >*/
L520:
/*< l = l + 1 >*/
++l;
/* perform the task indicated by kase. */
/*< go to (530, 560, 580, 610), kase >*/
switch (kase) {
case 1: goto L530;
case 2: goto L560;
case 3: goto L580;
case 4: goto L610;
}
/* deflate negligible s(m). */
/*< 530 continue >*/
L530:
/*< mm1 = m - 1 >*/
mm1 = m - 1;
/*< f = real(e(m-1)) >*/
i__1 = m - 1;
f = e[i__1].r;
/*< e(m-1) = (0.0e0,0.0e0) >*/
i__1 = m - 1;
e[i__1].r = (float)0., e[i__1].i = (float)0.;
/*< do 550 kk = l, mm1 >*/
i__1 = mm1;
for (kk = l; kk <= i__1; ++kk) {
/*< k = mm1 - kk + l >*/
k = mm1 - kk + l;
/*< t1 = real(s(k)) >*/
i__2 = k;
t1 = s[i__2].r;
/*< call srotg(t1,f,cs,sn) >*/
srotg_(&t1, &f, &cs, &sn);
/*< s(k) = cmplx(t1,0.0e0) >*/
i__2 = k;
q__1.r = t1, q__1.i = (float)0.;
s[i__2].r = q__1.r, s[i__2].i = q__1.i;
/*< if (k .eq. l) go to 540 >*/
if (k == l) {
goto L540;
}
/*< f = -sn*real(e(k-1)) >*/
i__2 = k - 1;
f = -sn * e[i__2].r;
/*< e(k-1) = cs*e(k-1) >*/
i__2 = k - 1;
i__3 = k - 1;
q__1.r = cs * e[i__3].r, q__1.i = cs * e[i__3].i;
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
/*< 540 continue >*/
L540:
/*< if (wantv) call csrot(p,v(1,k),1,v(1,m),1,cs,sn) >*/
if (wantv) {
csrot_(p, &v[k * v_dim1 + 1], &c__1, &v[m * v_dim1 + 1], &c__1, &
cs, &sn);
}
/*< 550 continue >*/
/* L550: */
}
/*< go to 650 >*/
goto L650;
/* split at negligible s(l). */
/*< 560 continue >*/
L560:
/*< f = real(e(l-1)) >*/
i__1 = l - 1;
f = e[i__1].r;
/*< e(l-1) = (0.0e0,0.0e0) >*/
i__1 = l - 1;
e[i__1].r = (float)0., e[i__1].i = (float)0.;
/*< do 570 k = l, m >*/
i__1 = m;
for (k = l; k <= i__1; ++k) {
/*< t1 = real(s(k)) >*/
i__2 = k;
t1 = s[i__2].r;
/*< call srotg(t1,f,cs,sn) >*/
srotg_(&t1, &f, &cs, &sn);
/*< s(k) = cmplx(t1,0.0e0) >*/
i__2 = k;
q__1.r = t1, q__1.i = (float)0.;
s[i__2].r = q__1.r, s[i__2].i = q__1.i;
/*< f = -sn*real(e(k)) >*/
i__2 = k;
f = -sn * e[i__2].r;
/*< e(k) = cs*e(k) >*/
i__2 = k;
i__3 = k;
q__1.r = cs * e[i__3].r, q__1.i = cs * e[i__3].i;
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
/*< if (wantu) call csrot(n,u(1,k),1,u(1,l-1),1,cs,sn) >*/
if (wantu) {
csrot_(n, &u[k * u_dim1 + 1], &c__1, &u[(l - 1) * u_dim1 + 1], &
c__1, &cs, &sn);
}
/*< 570 continue >*/
/* L570: */
}
/*< go to 650 >*/
goto L650;
/* perform one qr step. */
/*< 580 continue >*/
L580:
/* calculate the shift. */
/*< >*/
/* Computing MAX */
r__1 = c_abs(&s[m]), r__2 = c_abs(&s[m - 1]), r__1 = max(r__1,r__2), r__2
= c_abs(&e[m - 1]), r__1 = max(r__1,r__2), r__2 = c_abs(&s[l]),
r__1 = max(r__1,r__2), r__2 = c_abs(&e[l]);
scale = dmax(r__1,r__2);
/*< sm = real(s(m))/scale >*/
i__1 = m;
sm = s[i__1].r / scale;
/*< smm1 = real(s(m-1))/scale >*/
i__1 = m - 1;
smm1 = s[i__1].r / scale;
/*< emm1 = real(e(m-1))/scale >*/
i__1 = m - 1;
emm1 = e[i__1].r / scale;
/*< sl = real(s(l))/scale >*/
i__1 = l;
sl = s[i__1].r / scale;
/*< el = real(e(l))/scale >*/
i__1 = l;
el = e[i__1].r / scale;
/*< b = ((smm1 + sm)*(smm1 - sm) + emm1**2)/2.0e0 >*/
/* Computing 2nd power */
r__1 = emm1;
b = ((smm1 + sm) * (smm1 - sm) + r__1 * r__1) / (float)2.;
/*< c = (sm*emm1)**2 >*/
/* Computing 2nd power */
r__1 = sm * emm1;
c__ = r__1 * r__1;
/*< shift = 0.0e0 >*/
shift = (float)0.;
/*< if (b .eq. 0.0e0 .and. c .eq. 0.0e0) go to 590 >*/
if (b == (float)0. && c__ == (float)0.) {
goto L590;
}
/*< shift = sqrt(b**2+c) >*/
/* Computing 2nd power */
r__1 = b;
shift = sqrt(r__1 * r__1 + c__);
/*< if (b .lt. 0.0e0) shift = -shift >*/
if (b < (float)0.) {
shift = -shift;
}
/*< shift = c/(b + shift) >*/
shift = c__ / (b + shift);
/*< 590 continue >*/
L590:
/*< f = (sl + sm)*(sl - sm) + shift >*/
f = (sl + sm) * (sl - sm) + shift;
/*< g = sl*el >*/
g = sl * el;
/* chase zeros. */
/*< mm1 = m - 1 >*/
mm1 = m - 1;
/*< do 600 k = l, mm1 >*/
i__1 = mm1;
for (k = l; k <= i__1; ++k) {
/*< call srotg(f,g,cs,sn) >*/
srotg_(&f, &g, &cs, &sn);
/*< if (k .ne. l) e(k-1) = cmplx(f,0.0e0) >*/
if (k != l) {
i__2 = k - 1;
q__1.r = f, q__1.i = (float)0.;
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
}
/*< f = cs*real(s(k)) + sn*real(e(k)) >*/
i__2 = k;
i__3 = k;
f = cs * s[i__2].r + sn * e[i__3].r;
/*< e(k) = cs*e(k) - sn*s(k) >*/
i__2 = k;
i__3 = k;
q__2.r = cs * e[i__3].r, q__2.i = cs * e[i__3].i;
i__4 = k;
q__3.r = sn * s[i__4].r, q__3.i = sn * s[i__4].i;
q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
/*< g = sn*real(s(k+1)) >*/
i__2 = k + 1;
g = sn * s[i__2].r;
/*< s(k+1) = cs*s(k+1) >*/
i__2 = k + 1;
i__3 = k + 1;
q__1.r = cs * s[i__3].r, q__1.i = cs * s[i__3].i;
s[i__2].r = q__1.r, s[i__2].i = q__1.i;
/*< if (wantv) call csrot(p,v(1,k),1,v(1,k+1),1,cs,sn) >*/
if (wantv) {
csrot_(p, &v[k * v_dim1 + 1], &c__1, &v[(k + 1) * v_dim1 + 1], &
c__1, &cs, &sn);
}
/*< call srotg(f,g,cs,sn) >*/
srotg_(&f, &g, &cs, &sn);
/*< s(k) = cmplx(f,0.0e0) >*/
i__2 = k;
q__1.r = f, q__1.i = (float)0.;
s[i__2].r = q__1.r, s[i__2].i = q__1.i;
/*< f = cs*real(e(k)) + sn*real(s(k+1)) >*/
i__2 = k;
i__3 = k + 1;
f = cs * e[i__2].r + sn * s[i__3].r;
/*< s(k+1) = -sn*e(k) + cs*s(k+1) >*/
i__2 = k + 1;
r__1 = -sn;
i__3 = k;
q__2.r = r__1 * e[i__3].r, q__2.i = r__1 * e[i__3].i;
i__4 = k + 1;
q__3.r = cs * s[i__4].r, q__3.i = cs * s[i__4].i;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
s[i__2].r = q__1.r, s[i__2].i = q__1.i;
/*< g = sn*real(e(k+1)) >*/
i__2 = k + 1;
g = sn * e[i__2].r;
/*< e(k+1) = cs*e(k+1) >*/
i__2 = k + 1;
i__3 = k + 1;
q__1.r = cs * e[i__3].r, q__1.i = cs * e[i__3].i;
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
/*< >*/
if (wantu && k < *n) {
csrot_(n, &u[k * u_dim1 + 1], &c__1, &u[(k + 1) * u_dim1 + 1], &
c__1, &cs, &sn);
}
/*< 600 continue >*/
/* L600: */
}
/*< e(m-1) = cmplx(f,0.0e0) >*/
i__1 = m - 1;
q__1.r = f, q__1.i = (float)0.;
e[i__1].r = q__1.r, e[i__1].i = q__1.i;
/*< iter = iter + 1 >*/
++iter;
/*< go to 650 >*/
goto L650;
/* convergence. */
/*< 610 continue >*/
L610:
/* make the singular value positive */
/*< if (real(s(l)) .ge. 0.0e0) go to 620 >*/
i__1 = l;
if (s[i__1].r >= (float)0.) {
goto L620;
}
/*< s(l) = -s(l) >*/
i__1 = l;
i__2 = l;
q__1.r = -s[i__2].r, q__1.i = -s[i__2].i;
s[i__1].r = q__1.r, s[i__1].i = q__1.i;
/*< if (wantv) call cscal(p,(-1.0e0,0.0e0),v(1,l),1) >*/
if (wantv) {
cscal_(p, &c_b53, &v[l * v_dim1 + 1], &c__1);
}
/*< 620 continue >*/
L620:
/* order the singular value. */
/*< 630 if (l .eq. mm) go to 640 >*/
L630:
if (l == mm) {
goto L640;
}
/* ...exit */
/*< if (real(s(l)) .ge. real(s(l+1))) go to 640 >*/
i__1 = l;
i__2 = l + 1;
if (s[i__1].r >= s[i__2].r) {
goto L640;
}
/*< t = s(l) >*/
i__1 = l;
t.r = s[i__1].r, t.i = s[i__1].i;
/*< s(l) = s(l+1) >*/
i__1 = l;
i__2 = l + 1;
s[i__1].r = s[i__2].r, s[i__1].i = s[i__2].i;
/*< s(l+1) = t >*/
i__1 = l + 1;
s[i__1].r = t.r, s[i__1].i = t.i;
/*< >*/
if (wantv && l < *p) {
cswap_(p, &v[l * v_dim1 + 1], &c__1, &v[(l + 1) * v_dim1 + 1], &c__1);
}
/*< >*/
if (wantu && l < *n) {
cswap_(n, &u[l * u_dim1 + 1], &c__1, &u[(l + 1) * u_dim1 + 1], &c__1);
}
/*< l = l + 1 >*/
++l;
/*< go to 630 >*/
goto L630;
/*< 640 continue >*/
L640:
/*< iter = 0 >*/
iter = 0;
/*< m = m - 1 >*/
--m;
/*< 650 continue >*/
L650:
/*< go to 400 >*/
goto L400;
/*< 660 continue >*/
L660:
/*< return >*/
return 0;
/*< end >*/
} /* csvdc_ */
/* 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 clatrs_(char *uplo, char *trans, char *diag, char *
normin, integer *n, complex *a, integer *lda, complex *x, real *scale,
real *cnorm, integer *info)
{
/* System generated locals */
integer a_dim1, a_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, q__3, q__4;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
integer i__, j;
real xj, rec, tjj;
integer jinc;
real xbnd;
integer imax;
real tmax;
complex tjjs;
real xmax, grow;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
real tscal;
complex uscal;
integer jlast;
extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer
*, complex *, integer *);
complex csumj;
extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
logical upper;
extern /* Subroutine */ int ctrsv_(char *, char *, char *, integer *,
complex *, integer *, complex *, integer *), slabad_(real *, real *);
extern integer icamax_(integer *, complex *, integer *);
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), xerbla_(char *, integer *);
real bignum;
extern integer isamax_(integer *, real *, integer *);
extern doublereal scasum_(integer *, complex *, integer *);
logical notran;
integer jfirst;
real smlnum;
logical nounit;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLATRS solves one of the triangular systems */
/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b, */
/* with scaling to prevent overflow. Here A is an upper or lower */
/* triangular matrix, A**T denotes the transpose of A, A**H denotes the */
/* conjugate transpose of A, x and b are n-element vectors, and s is a */
/* scaling factor, usually less than or equal to 1, chosen so that the */
/* components of x will be less than the overflow threshold. If the */
/* unscaled problem will not cause overflow, the Level 2 BLAS routine */
/* CTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j), */
/* then s is set to 0 and a non-trivial solution to A*x = 0 is returned. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A is upper or lower triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* TRANS (input) CHARACTER*1 */
/* Specifies the operation applied to A. */
/* = 'N': Solve A * x = s*b (No transpose) */
/* = 'T': Solve A**T * x = s*b (Transpose) */
/* = 'C': Solve A**H * x = s*b (Conjugate transpose) */
/* DIAG (input) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* NORMIN (input) CHARACTER*1 */
/* Specifies whether CNORM has been set or not. */
/* = 'Y': CNORM contains the column norms on entry */
/* = 'N': CNORM is not set on entry. On exit, the norms will */
/* be computed and stored in CNORM. */
/* 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). */
/* X (input/output) COMPLEX array, dimension (N) */
/* On entry, the right hand side b of the triangular system. */
/* On exit, X is overwritten by the solution vector x. */
/* SCALE (output) REAL */
/* The scaling factor s for the triangular system */
/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b. */
/* If SCALE = 0, the matrix A is singular or badly scaled, and */
/* the vector x is an exact or approximate solution to A*x = 0. */
/* CNORM (input or output) REAL array, dimension (N) */
/* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */
/* contains the norm of the off-diagonal part of the j-th column */
/* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */
/* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */
/* must be greater than or equal to the 1-norm. */
/* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */
/* returns the 1-norm of the offdiagonal part of the j-th column */
/* of A. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* Further Details */
/* ======= ======= */
/* A rough bound on x is computed; if that is less than overflow, CTRSV */
/* is called, otherwise, specific code is used which checks for possible */
/* overflow or divide-by-zero at every operation. */
/* A columnwise scheme is used for solving A*x = b. The basic algorithm */
/* if A is lower triangular is */
/* x[1:n] := b[1:n] */
/* for j = 1, ..., n */
/* x(j) := x(j) / A(j,j) */
/* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */
/* end */
/* Define bounds on the components of x after j iterations of the loop: */
/* M(j) = bound on x[1:j] */
/* G(j) = bound on x[j+1:n] */
/* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. */
/* Then for iteration j+1 we have */
/* M(j+1) <= G(j) / | A(j+1,j+1) | */
/* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */
/* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */
/* where CNORM(j+1) is greater than or equal to the infinity-norm of */
/* column j+1 of A, not counting the diagonal. Hence */
/* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */
/* 1<=i<=j */
/* and */
/* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */
/* 1<=i< j */
/* Since |x(j)| <= M(j), we use the Level 2 BLAS routine CTRSV if the */
/* reciprocal of the largest M(j), j=1,..,n, is larger than */
/* max(underflow, 1/overflow). */
/* The bound on x(j) is also used to determine when a step in the */
/* columnwise method can be performed without fear of overflow. If */
/* the computed bound is greater than a large constant, x is scaled to */
/* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */
/* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */
/* Similarly, a row-wise scheme is used to solve A**T *x = b or */
/* A**H *x = b. The basic algorithm for A upper triangular is */
/* for j = 1, ..., n */
/* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */
/* end */
/* We simultaneously compute two bounds */
/* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */
/* M(j) = bound on x(i), 1<=i<=j */
/* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we */
/* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */
/* Then the bound on x(j) is */
/* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */
/* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */
/* 1<=i<=j */
/* and we can safely call CTRSV if 1/M(n) and 1/G(n) are both greater */
/* than max(underflow, 1/overflow). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--x;
--cnorm;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
/* Test the input parameters. */
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && !
lsame_(trans, "C")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (! lsame_(normin, "Y") && ! lsame_(normin,
"N")) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CLATRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine machine dependent parameters to control overflow. */
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum /= slamch_("Precision");
bignum = 1.f / smlnum;
*scale = 1.f;
if (lsame_(normin, "N")) {
/* Compute the 1-norm of each column, not including the diagonal. */
if (upper) {
/* A is upper triangular. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
cnorm[j] = scasum_(&i__2, &a[j * a_dim1 + 1], &c__1);
/* L10: */
}
} else {
/* A is lower triangular. */
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j;
cnorm[j] = scasum_(&i__2, &a[j + 1 + j * a_dim1], &c__1);
/* L20: */
}
cnorm[*n] = 0.f;
}
}
/* Scale the column norms by TSCAL if the maximum element in CNORM is */
/* greater than BIGNUM/2. */
imax = isamax_(n, &cnorm[1], &c__1);
tmax = cnorm[imax];
if (tmax <= bignum * .5f) {
tscal = 1.f;
} else {
tscal = .5f / (smlnum * tmax);
sscal_(n, &tscal, &cnorm[1], &c__1);
}
/* Compute a bound on the computed solution vector to see if the */
/* Level 2 BLAS routine CTRSV can be used. */
xmax = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = j;
r__3 = xmax, r__4 = (r__1 = x[i__2].r / 2.f, dabs(r__1)) + (r__2 =
r_imag(&x[j]) / 2.f, dabs(r__2));
xmax = dmax(r__3,r__4);
/* L30: */
}
xbnd = xmax;
if (notran) {
/* Compute the growth in A * x = b. */
if (upper) {
jfirst = *n;
jlast = 1;
jinc = -1;
} else {
jfirst = 1;
jlast = *n;
jinc = 1;
}
if (tscal != 1.f) {
grow = 0.f;
goto L60;
}
if (nounit) {
/* A is non-unit triangular. */
/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
/* Initially, G(0) = max{x(i), i=1,...,n}. */
grow = .5f / dmax(xbnd,smlnum);
xbnd = grow;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L60;
}
i__3 = j + j * a_dim1;
tjjs.r = a[i__3].r, tjjs.i = a[i__3].i;
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj >= smlnum) {
/* M(j) = G(j-1) / abs(A(j,j)) */
/* Computing MIN */
r__1 = xbnd, r__2 = dmin(1.f,tjj) * grow;
xbnd = dmin(r__1,r__2);
} else {
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.f;
}
if (tjj + cnorm[j] >= smlnum) {
/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */
grow *= tjj / (tjj + cnorm[j]);
} else {
/* G(j) could overflow, set GROW to 0. */
grow = 0.f;
}
/* L40: */
}
grow = xbnd;
} else {
/* A is unit triangular. */
/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
/* Computing MIN */
r__1 = 1.f, r__2 = .5f / dmax(xbnd,smlnum);
grow = dmin(r__1,r__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L60;
}
/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
grow *= 1.f / (cnorm[j] + 1.f);
/* L50: */
}
}
L60:
;
} else {
/* Compute the growth in A**T * x = b or A**H * x = b. */
if (upper) {
jfirst = 1;
jlast = *n;
jinc = 1;
} else {
jfirst = *n;
jlast = 1;
jinc = -1;
}
if (tscal != 1.f) {
grow = 0.f;
goto L90;
}
if (nounit) {
/* A is non-unit triangular. */
/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
/* Initially, M(0) = max{x(i), i=1,...,n}. */
grow = .5f / dmax(xbnd,smlnum);
xbnd = grow;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L90;
}
/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */
xj = cnorm[j] + 1.f;
/* Computing MIN */
r__1 = grow, r__2 = xbnd / xj;
grow = dmin(r__1,r__2);
i__3 = j + j * a_dim1;
tjjs.r = a[i__3].r, tjjs.i = a[i__3].i;
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj >= smlnum) {
/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */
if (xj > tjj) {
xbnd *= tjj / xj;
}
} else {
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.f;
}
/* L70: */
}
grow = dmin(grow,xbnd);
} else {
/* A is unit triangular. */
/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
/* Computing MIN */
r__1 = 1.f, r__2 = .5f / dmax(xbnd,smlnum);
grow = dmin(r__1,r__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L90;
}
/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
xj = cnorm[j] + 1.f;
grow /= xj;
/* L80: */
}
}
L90:
;
}
if (grow * tscal > smlnum) {
/* Use the Level 2 BLAS solve if the reciprocal of the bound on */
/* elements of X is not too small. */
ctrsv_(uplo, trans, diag, n, &a[a_offset], lda, &x[1], &c__1);
} else {
/* Use a Level 1 BLAS solve, scaling intermediate results. */
if (xmax > bignum * .5f) {
/* Scale X so that its components are less than or equal to */
/* BIGNUM in absolute value. */
*scale = bignum * .5f / xmax;
csscal_(n, scale, &x[1], &c__1);
xmax = bignum;
} else {
xmax *= 2.f;
}
if (notran) {
/* Solve A * x = b */
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
dabs(r__2));
if (nounit) {
i__3 = j + j * a_dim1;
q__1.r = tscal * a[i__3].r, q__1.i = tscal * a[i__3].i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
if (tscal == 1.f) {
goto L105;
}
}
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f) {
if (xj > tjj * bignum) {
/* Scale x by 1/b(j). */
rec = 1.f / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
), dabs(r__2));
} else if (tjj > 0.f) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */
/* to avoid overflow when dividing by A(j,j). */
rec = tjj * bignum / xj;
if (cnorm[j] > 1.f) {
/* Scale by 1/CNORM(j) to avoid overflow when */
/* multiplying x(j) times column j. */
rec /= cnorm[j];
}
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
), dabs(r__2));
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0, and compute a solution to A*x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0.f, x[i__4].i = 0.f;
/* L100: */
}
i__3 = j;
x[i__3].r = 1.f, x[i__3].i = 0.f;
xj = 1.f;
*scale = 0.f;
xmax = 0.f;
}
L105:
/* Scale x if necessary to avoid overflow when adding a */
/* multiple of column j of A. */
if (xj > 1.f) {
rec = 1.f / xj;
if (cnorm[j] > (bignum - xmax) * rec) {
/* Scale x by 1/(2*abs(x(j))). */
rec *= .5f;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
} else if (xj * cnorm[j] > bignum - xmax) {
/* Scale x by 1/2. */
csscal_(n, &c_b36, &x[1], &c__1);
*scale *= .5f;
}
if (upper) {
if (j > 1) {
/* Compute the update */
/* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */
i__3 = j - 1;
i__4 = j;
q__2.r = -x[i__4].r, q__2.i = -x[i__4].i;
q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
caxpy_(&i__3, &q__1, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
i__3 = j - 1;
i__ = icamax_(&i__3, &x[1], &c__1);
i__3 = i__;
xmax = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[i__]), dabs(r__2));
}
} else {
if (j < *n) {
/* Compute the update */
/* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */
i__3 = *n - j;
i__4 = j;
q__2.r = -x[i__4].r, q__2.i = -x[i__4].i;
q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
caxpy_(&i__3, &q__1, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
i__3 = *n - j;
i__ = j + icamax_(&i__3, &x[j + 1], &c__1);
i__3 = i__;
xmax = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[i__]), dabs(r__2));
}
}
/* L110: */
}
} else if (lsame_(trans, "T")) {
/* Solve A**T * x = b */
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
/* k<>j */
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
dabs(r__2));
uscal.r = tscal, uscal.i = 0.f;
rec = 1.f / dmax(xmax,1.f);
if (cnorm[j] > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5f;
if (nounit) {
i__3 = j + j * a_dim1;
q__1.r = tscal * a[i__3].r, q__1.i = tscal * a[i__3]
.i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
}
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > 1.f) {
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
r__1 = 1.f, r__2 = rec * tjj;
rec = dmin(r__1,r__2);
cladiv_(&q__1, &uscal, &tjjs);
uscal.r = q__1.r, uscal.i = q__1.i;
}
if (rec < 1.f) {
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0.f, csumj.i = 0.f;
if (uscal.r == 1.f && uscal.i == 0.f) {
/* If the scaling needed for A in the dot product is 1, */
/* call CDOTU to perform the dot product. */
if (upper) {
i__3 = j - 1;
cdotu_(&q__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
csumj.r = q__1.r, csumj.i = q__1.i;
} else if (j < *n) {
i__3 = *n - j;
cdotu_(&q__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
csumj.r = q__1.r, csumj.i = q__1.i;
}
} else {
/* Otherwise, use in-line code for the dot product. */
if (upper) {
i__3 = j - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * a_dim1;
q__3.r = a[i__4].r * uscal.r - a[i__4].i *
uscal.i, q__3.i = a[i__4].r * uscal.i + a[
i__4].i * uscal.r;
i__5 = i__;
q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i,
q__2.i = q__3.r * x[i__5].i + q__3.i * x[
i__5].r;
q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
q__2.i;
csumj.r = q__1.r, csumj.i = q__1.i;
/* L120: */
}
} else if (j < *n) {
i__3 = *n;
for (i__ = j + 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * a_dim1;
q__3.r = a[i__4].r * uscal.r - a[i__4].i *
uscal.i, q__3.i = a[i__4].r * uscal.i + a[
i__4].i * uscal.r;
i__5 = i__;
q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i,
q__2.i = q__3.r * x[i__5].i + q__3.i * x[
i__5].r;
q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
q__2.i;
csumj.r = q__1.r, csumj.i = q__1.i;
/* L130: */
}
}
}
q__1.r = tscal, q__1.i = 0.f;
if (uscal.r == q__1.r && uscal.i == q__1.i) {
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
/* was not used to scale the dotproduct. */
i__3 = j;
i__4 = j;
q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i -
csumj.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
), dabs(r__2));
if (nounit) {
i__3 = j + j * a_dim1;
q__1.r = tscal * a[i__3].r, q__1.i = tscal * a[i__3]
.i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
if (tscal == 1.f) {
goto L145;
}
}
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f) {
if (xj > tjj * bignum) {
/* Scale X by 1/abs(x(j)). */
rec = 1.f / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
} else if (tjj > 0.f) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0 and compute a solution to A**T *x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0.f, x[i__4].i = 0.f;
/* L140: */
}
i__3 = j;
x[i__3].r = 1.f, x[i__3].i = 0.f;
*scale = 0.f;
xmax = 0.f;
}
L145:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
/* product has already been divided by 1/A(j,j). */
i__3 = j;
cladiv_(&q__2, &x[j], &tjjs);
q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
}
/* Computing MAX */
i__3 = j;
r__3 = xmax, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[j]), dabs(r__2));
xmax = dmax(r__3,r__4);
/* L150: */
}
} else {
/* Solve A**H * x = b */
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
/* k<>j */
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
dabs(r__2));
uscal.r = tscal, uscal.i = 0.f;
rec = 1.f / dmax(xmax,1.f);
if (cnorm[j] > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5f;
if (nounit) {
r_cnjg(&q__2, &a[j + j * a_dim1]);
q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
}
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > 1.f) {
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
r__1 = 1.f, r__2 = rec * tjj;
rec = dmin(r__1,r__2);
cladiv_(&q__1, &uscal, &tjjs);
uscal.r = q__1.r, uscal.i = q__1.i;
}
if (rec < 1.f) {
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0.f, csumj.i = 0.f;
if (uscal.r == 1.f && uscal.i == 0.f) {
/* If the scaling needed for A in the dot product is 1, */
/* call CDOTC to perform the dot product. */
if (upper) {
i__3 = j - 1;
cdotc_(&q__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
csumj.r = q__1.r, csumj.i = q__1.i;
} else if (j < *n) {
i__3 = *n - j;
cdotc_(&q__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
csumj.r = q__1.r, csumj.i = q__1.i;
}
} else {
/* Otherwise, use in-line code for the dot product. */
if (upper) {
i__3 = j - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
r_cnjg(&q__4, &a[i__ + j * a_dim1]);
q__3.r = q__4.r * uscal.r - q__4.i * uscal.i,
q__3.i = q__4.r * uscal.i + q__4.i *
uscal.r;
i__4 = i__;
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i,
q__2.i = q__3.r * x[i__4].i + q__3.i * x[
i__4].r;
q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
q__2.i;
csumj.r = q__1.r, csumj.i = q__1.i;
/* L160: */
}
} else if (j < *n) {
i__3 = *n;
for (i__ = j + 1; i__ <= i__3; ++i__) {
r_cnjg(&q__4, &a[i__ + j * a_dim1]);
q__3.r = q__4.r * uscal.r - q__4.i * uscal.i,
q__3.i = q__4.r * uscal.i + q__4.i *
uscal.r;
i__4 = i__;
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i,
q__2.i = q__3.r * x[i__4].i + q__3.i * x[
i__4].r;
q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
q__2.i;
csumj.r = q__1.r, csumj.i = q__1.i;
/* L170: */
}
}
}
q__1.r = tscal, q__1.i = 0.f;
if (uscal.r == q__1.r && uscal.i == q__1.i) {
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
/* was not used to scale the dotproduct. */
i__3 = j;
i__4 = j;
q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i -
csumj.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
), dabs(r__2));
if (nounit) {
r_cnjg(&q__2, &a[j + j * a_dim1]);
q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
if (tscal == 1.f) {
goto L185;
}
}
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f) {
if (xj > tjj * bignum) {
/* Scale X by 1/abs(x(j)). */
rec = 1.f / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
} else if (tjj > 0.f) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0 and compute a solution to A**H *x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0.f, x[i__4].i = 0.f;
/* L180: */
}
i__3 = j;
x[i__3].r = 1.f, x[i__3].i = 0.f;
*scale = 0.f;
xmax = 0.f;
}
L185:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
/* product has already been divided by 1/A(j,j). */
i__3 = j;
cladiv_(&q__2, &x[j], &tjjs);
q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
}
/* Computing MAX */
i__3 = j;
r__3 = xmax, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[j]), dabs(r__2));
xmax = dmax(r__3,r__4);
/* L190: */
}
}
*scale /= tscal;
}
/* Scale the column norms by 1/TSCAL for return. */
if (tscal != 1.f) {
r__1 = 1.f / tscal;
sscal_(n, &r__1, &cnorm[1], &c__1);
}
return 0;
/* End of CLATRS */
} /* clatrs_ */
/* Subroutine */ int claic1_(integer *job, integer *j, complex *x, real *sest,
complex *w, complex *gamma, real *sestpr, complex *s, complex *c__)
{
/* System generated locals */
real r__1, r__2;
complex q__1, q__2, q__3, q__4, q__5, q__6;
/* Local variables */
real b, t, s1, s2, scl, eps, tmp;
complex sine;
real test, zeta1, zeta2;
complex alpha;
real norma, absgam, absalp;
complex cosine;
real absest;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* CLAIC1 applies one step of incremental condition estimation in */
/* its simplest version: */
/* Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j */
/* lower triangular matrix L, such that */
/* twonorm(L*x) = sest */
/* Then CLAIC1 computes sestpr, s, c such that */
/* the vector */
/* [ s*x ] */
/* xhat = [ c ] */
/* is an approximate singular vector of */
/* [ L 0 ] */
/* Lhat = [ w' gamma ] */
/* in the sense that */
/* twonorm(Lhat*xhat) = sestpr. */
/* Depending on JOB, an estimate for the largest or smallest singular */
/* value is computed. */
/* Note that [s c]' and sestpr**2 is an eigenpair of the system */
/* diag(sest*sest, 0) + [alpha gamma] * [ conjg(alpha) ] */
/* [ conjg(gamma) ] */
/* where alpha = conjg(x)'*w. */
/* Arguments */
/* ========= */
/* JOB (input) INTEGER */
/* = 1: an estimate for the largest singular value is computed. */
/* = 2: an estimate for the smallest singular value is computed. */
/* J (input) INTEGER */
/* Length of X and W */
/* X (input) COMPLEX array, dimension (J) */
/* The j-vector x. */
/* SEST (input) REAL */
/* Estimated singular value of j by j matrix L */
/* W (input) COMPLEX array, dimension (J) */
/* The j-vector w. */
/* GAMMA (input) COMPLEX */
/* The diagonal element gamma. */
/* SESTPR (output) REAL */
/* Estimated singular value of (j+1) by (j+1) matrix Lhat. */
/* S (output) COMPLEX */
/* Sine needed in forming xhat. */
/* C (output) COMPLEX */
/* Cosine needed in forming xhat. */
/* ===================================================================== */
/* Parameter adjustments */
--w;
--x;
/* Function Body */
eps = slamch_("Epsilon");
cdotc_(&q__1, j, &x[1], &c__1, &w[1], &c__1);
alpha.r = q__1.r, alpha.i = q__1.i;
absalp = c_abs(&alpha);
absgam = c_abs(gamma);
absest = dabs(*sest);
if (*job == 1) {
/* Estimating largest singular value */
/* special cases */
if (*sest == 0.f) {
s1 = dmax(absgam,absalp);
if (s1 == 0.f) {
s->r = 0.f, s->i = 0.f;
c__->r = 1.f, c__->i = 0.f;
*sestpr = 0.f;
} else {
q__1.r = alpha.r / s1, q__1.i = alpha.i / s1;
s->r = q__1.r, s->i = q__1.i;
q__1.r = gamma->r / s1, q__1.i = gamma->i / s1;
c__->r = q__1.r, c__->i = q__1.i;
r_cnjg(&q__4, s);
q__3.r = s->r * q__4.r - s->i * q__4.i, q__3.i = s->r *
q__4.i + s->i * q__4.r;
r_cnjg(&q__6, c__);
q__5.r = c__->r * q__6.r - c__->i * q__6.i, q__5.i = c__->r *
q__6.i + c__->i * q__6.r;
q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
c_sqrt(&q__1, &q__2);
tmp = q__1.r;
q__1.r = s->r / tmp, q__1.i = s->i / tmp;
s->r = q__1.r, s->i = q__1.i;
q__1.r = c__->r / tmp, q__1.i = c__->i / tmp;
c__->r = q__1.r, c__->i = q__1.i;
*sestpr = s1 * tmp;
}
return 0;
} else if (absgam <= eps * absest) {
s->r = 1.f, s->i = 0.f;
c__->r = 0.f, c__->i = 0.f;
tmp = dmax(absest,absalp);
s1 = absest / tmp;
s2 = absalp / tmp;
*sestpr = tmp * sqrt(s1 * s1 + s2 * s2);
return 0;
} else if (absalp <= eps * absest) {
s1 = absgam;
s2 = absest;
if (s1 <= s2) {
s->r = 1.f, s->i = 0.f;
c__->r = 0.f, c__->i = 0.f;
*sestpr = s2;
} else {
s->r = 0.f, s->i = 0.f;
c__->r = 1.f, c__->i = 0.f;
*sestpr = s1;
}
return 0;
} else if (absest <= eps * absalp || absest <= eps * absgam) {
s1 = absgam;
s2 = absalp;
if (s1 <= s2) {
tmp = s1 / s2;
scl = sqrt(tmp * tmp + 1.f);
*sestpr = s2 * scl;
q__2.r = alpha.r / s2, q__2.i = alpha.i / s2;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
s->r = q__1.r, s->i = q__1.i;
q__2.r = gamma->r / s2, q__2.i = gamma->i / s2;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
c__->r = q__1.r, c__->i = q__1.i;
} else {
tmp = s2 / s1;
scl = sqrt(tmp * tmp + 1.f);
*sestpr = s1 * scl;
q__2.r = alpha.r / s1, q__2.i = alpha.i / s1;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
s->r = q__1.r, s->i = q__1.i;
q__2.r = gamma->r / s1, q__2.i = gamma->i / s1;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
c__->r = q__1.r, c__->i = q__1.i;
}
return 0;
} else {
/* normal case */
zeta1 = absalp / absest;
zeta2 = absgam / absest;
b = (1.f - zeta1 * zeta1 - zeta2 * zeta2) * .5f;
r__1 = zeta1 * zeta1;
c__->r = r__1, c__->i = 0.f;
if (b > 0.f) {
r__1 = b * b;
q__4.r = r__1 + c__->r, q__4.i = c__->i;
c_sqrt(&q__3, &q__4);
q__2.r = b + q__3.r, q__2.i = q__3.i;
c_div(&q__1, c__, &q__2);
t = q__1.r;
} else {
r__1 = b * b;
q__3.r = r__1 + c__->r, q__3.i = c__->i;
c_sqrt(&q__2, &q__3);
q__1.r = q__2.r - b, q__1.i = q__2.i;
t = q__1.r;
}
q__3.r = alpha.r / absest, q__3.i = alpha.i / absest;
q__2.r = -q__3.r, q__2.i = -q__3.i;
q__1.r = q__2.r / t, q__1.i = q__2.i / t;
sine.r = q__1.r, sine.i = q__1.i;
q__3.r = gamma->r / absest, q__3.i = gamma->i / absest;
q__2.r = -q__3.r, q__2.i = -q__3.i;
r__1 = t + 1.f;
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
cosine.r = q__1.r, cosine.i = q__1.i;
r_cnjg(&q__4, &sine);
q__3.r = sine.r * q__4.r - sine.i * q__4.i, q__3.i = sine.r *
q__4.i + sine.i * q__4.r;
r_cnjg(&q__6, &cosine);
q__5.r = cosine.r * q__6.r - cosine.i * q__6.i, q__5.i = cosine.r
* q__6.i + cosine.i * q__6.r;
q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
c_sqrt(&q__1, &q__2);
tmp = q__1.r;
q__1.r = sine.r / tmp, q__1.i = sine.i / tmp;
s->r = q__1.r, s->i = q__1.i;
q__1.r = cosine.r / tmp, q__1.i = cosine.i / tmp;
c__->r = q__1.r, c__->i = q__1.i;
*sestpr = sqrt(t + 1.f) * absest;
return 0;
}
} else if (*job == 2) {
/* Estimating smallest singular value */
/* special cases */
if (*sest == 0.f) {
*sestpr = 0.f;
if (dmax(absgam,absalp) == 0.f) {
sine.r = 1.f, sine.i = 0.f;
cosine.r = 0.f, cosine.i = 0.f;
} else {
r_cnjg(&q__2, gamma);
q__1.r = -q__2.r, q__1.i = -q__2.i;
sine.r = q__1.r, sine.i = q__1.i;
r_cnjg(&q__1, &alpha);
cosine.r = q__1.r, cosine.i = q__1.i;
}
/* Computing MAX */
r__1 = c_abs(&sine), r__2 = c_abs(&cosine);
s1 = dmax(r__1,r__2);
q__1.r = sine.r / s1, q__1.i = sine.i / s1;
s->r = q__1.r, s->i = q__1.i;
q__1.r = cosine.r / s1, q__1.i = cosine.i / s1;
c__->r = q__1.r, c__->i = q__1.i;
r_cnjg(&q__4, s);
q__3.r = s->r * q__4.r - s->i * q__4.i, q__3.i = s->r * q__4.i +
s->i * q__4.r;
r_cnjg(&q__6, c__);
q__5.r = c__->r * q__6.r - c__->i * q__6.i, q__5.i = c__->r *
q__6.i + c__->i * q__6.r;
q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
c_sqrt(&q__1, &q__2);
tmp = q__1.r;
q__1.r = s->r / tmp, q__1.i = s->i / tmp;
s->r = q__1.r, s->i = q__1.i;
q__1.r = c__->r / tmp, q__1.i = c__->i / tmp;
c__->r = q__1.r, c__->i = q__1.i;
return 0;
} else if (absgam <= eps * absest) {
s->r = 0.f, s->i = 0.f;
c__->r = 1.f, c__->i = 0.f;
*sestpr = absgam;
return 0;
} else if (absalp <= eps * absest) {
s1 = absgam;
s2 = absest;
if (s1 <= s2) {
s->r = 0.f, s->i = 0.f;
c__->r = 1.f, c__->i = 0.f;
*sestpr = s1;
} else {
s->r = 1.f, s->i = 0.f;
c__->r = 0.f, c__->i = 0.f;
*sestpr = s2;
}
return 0;
} else if (absest <= eps * absalp || absest <= eps * absgam) {
s1 = absgam;
s2 = absalp;
if (s1 <= s2) {
tmp = s1 / s2;
scl = sqrt(tmp * tmp + 1.f);
*sestpr = absest * (tmp / scl);
r_cnjg(&q__4, gamma);
q__3.r = q__4.r / s2, q__3.i = q__4.i / s2;
q__2.r = -q__3.r, q__2.i = -q__3.i;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
s->r = q__1.r, s->i = q__1.i;
r_cnjg(&q__3, &alpha);
q__2.r = q__3.r / s2, q__2.i = q__3.i / s2;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
c__->r = q__1.r, c__->i = q__1.i;
} else {
tmp = s2 / s1;
scl = sqrt(tmp * tmp + 1.f);
*sestpr = absest / scl;
r_cnjg(&q__4, gamma);
q__3.r = q__4.r / s1, q__3.i = q__4.i / s1;
q__2.r = -q__3.r, q__2.i = -q__3.i;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
s->r = q__1.r, s->i = q__1.i;
r_cnjg(&q__3, &alpha);
q__2.r = q__3.r / s1, q__2.i = q__3.i / s1;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
c__->r = q__1.r, c__->i = q__1.i;
}
return 0;
} else {
/* normal case */
zeta1 = absalp / absest;
zeta2 = absgam / absest;
/* Computing MAX */
r__1 = zeta1 * zeta1 + 1.f + zeta1 * zeta2, r__2 = zeta1 * zeta2
+ zeta2 * zeta2;
norma = dmax(r__1,r__2);
/* See if root is closer to zero or to ONE */
test = (zeta1 - zeta2) * 2.f * (zeta1 + zeta2) + 1.f;
if (test >= 0.f) {
/* root is close to zero, compute directly */
b = (zeta1 * zeta1 + zeta2 * zeta2 + 1.f) * .5f;
r__1 = zeta2 * zeta2;
c__->r = r__1, c__->i = 0.f;
r__2 = b * b;
q__2.r = r__2 - c__->r, q__2.i = -c__->i;
r__1 = b + sqrt(c_abs(&q__2));
q__1.r = c__->r / r__1, q__1.i = c__->i / r__1;
t = q__1.r;
q__2.r = alpha.r / absest, q__2.i = alpha.i / absest;
r__1 = 1.f - t;
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
sine.r = q__1.r, sine.i = q__1.i;
q__3.r = gamma->r / absest, q__3.i = gamma->i / absest;
q__2.r = -q__3.r, q__2.i = -q__3.i;
q__1.r = q__2.r / t, q__1.i = q__2.i / t;
cosine.r = q__1.r, cosine.i = q__1.i;
*sestpr = sqrt(t + eps * 4.f * eps * norma) * absest;
} else {
/* root is closer to ONE, shift by that amount */
b = (zeta2 * zeta2 + zeta1 * zeta1 - 1.f) * .5f;
r__1 = zeta1 * zeta1;
c__->r = r__1, c__->i = 0.f;
if (b >= 0.f) {
q__2.r = -c__->r, q__2.i = -c__->i;
r__1 = b * b;
q__5.r = r__1 + c__->r, q__5.i = c__->i;
c_sqrt(&q__4, &q__5);
q__3.r = b + q__4.r, q__3.i = q__4.i;
c_div(&q__1, &q__2, &q__3);
t = q__1.r;
} else {
r__1 = b * b;
q__3.r = r__1 + c__->r, q__3.i = c__->i;
c_sqrt(&q__2, &q__3);
q__1.r = b - q__2.r, q__1.i = -q__2.i;
t = q__1.r;
}
q__3.r = alpha.r / absest, q__3.i = alpha.i / absest;
q__2.r = -q__3.r, q__2.i = -q__3.i;
q__1.r = q__2.r / t, q__1.i = q__2.i / t;
sine.r = q__1.r, sine.i = q__1.i;
q__3.r = gamma->r / absest, q__3.i = gamma->i / absest;
q__2.r = -q__3.r, q__2.i = -q__3.i;
r__1 = t + 1.f;
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
cosine.r = q__1.r, cosine.i = q__1.i;
*sestpr = sqrt(t + 1.f + eps * 4.f * eps * norma) * absest;
}
r_cnjg(&q__4, &sine);
q__3.r = sine.r * q__4.r - sine.i * q__4.i, q__3.i = sine.r *
q__4.i + sine.i * q__4.r;
r_cnjg(&q__6, &cosine);
q__5.r = cosine.r * q__6.r - cosine.i * q__6.i, q__5.i = cosine.r
* q__6.i + cosine.i * q__6.r;
q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
c_sqrt(&q__1, &q__2);
tmp = q__1.r;
q__1.r = sine.r / tmp, q__1.i = sine.i / tmp;
s->r = q__1.r, s->i = q__1.i;
q__1.r = cosine.r / tmp, q__1.i = cosine.i / tmp;
c__->r = q__1.r, c__->i = q__1.i;
return 0;
}
}
return 0;
/* End of CLAIC1 */
} /* claic1_ */