/* Subroutine */ int zrotg_(doublecomplex *ca, doublecomplex *cb, doublereal *
c, doublecomplex *s)
{
/* System generated locals */
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
double sqrt(doublereal);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static doublereal norm;
extern doublereal cdabs_(doublecomplex *);
static doublecomplex alpha;
static doublereal scale;
if (cdabs_(ca) != 0.) {
goto L10;
}
*c = 0.;
s->r = 1., s->i = 0.;
ca->r = cb->r, ca->i = cb->i;
goto L20;
L10:
scale = cdabs_(ca) + cdabs_(cb);
z__2.r = scale, z__2.i = 0.;
z_div(&z__1, ca, &z__2);
/* Computing 2nd power */
d__1 = cdabs_(&z__1);
z__4.r = scale, z__4.i = 0.;
z_div(&z__3, cb, &z__4);
/* Computing 2nd power */
d__2 = cdabs_(&z__3);
norm = scale * sqrt(d__1 * d__1 + d__2 * d__2);
d__1 = cdabs_(ca);
z__1.r = ca->r / d__1, z__1.i = ca->i / d__1;
alpha.r = z__1.r, alpha.i = z__1.i;
*c = cdabs_(ca) / norm;
d_cnjg(&z__3, cb);
z__2.r = alpha.r * z__3.r - alpha.i * z__3.i, z__2.i = alpha.r * z__3.i +
alpha.i * z__3.r;
z__1.r = z__2.r / norm, z__1.i = z__2.i / norm;
s->r = z__1.r, s->i = z__1.i;
z__1.r = norm * alpha.r, z__1.i = norm * alpha.i;
ca->r = z__1.r, ca->i = z__1.i;
L20:
return 0;
} /* zrotg_ */
void
pow_zi(dcomplex *p, dcomplex *a, long int *b) /* p = a**b */
{
long int n;
double t;
dcomplex x;
n = *b;
p->dreal = 1;
p->dimag = 0;
if(n == 0)
return;
if(n < 0) {
n = -n;
z_div(&x, p, a);
} else {
x.dreal = a->dreal;
x.dimag = a->dimag;
}
for( ; ; ) {
if(n & 01) {
t = p->dreal * x.dreal - p->dimag * x.dimag;
p->dimag = p->dreal * x.dimag + p->dimag * x.dreal;
p->dreal = t;
}
if(n >>= 1) {
t = x.dreal * x.dreal - x.dimag * x.dimag;
x.dimag = 2 * x.dreal * x.dimag;
x.dreal = t;
} else
break;
}
static void
VanVlietResidue(
int whichDeriv, /* Which derivative are we evaluating */
const doublecomplex* polej, /* Which pole are we computing for */
const doublecomplex poles[4],
/* Poles of the filter */
double gain, /* Gain of the filter */
doublecomplex* residue /* Output: Computed residue */
) {
doublecomplex pi;
doublecomplex pj = *polej;
doublecomplex qj;
doublecomplex gz = {1.0, 0.0};
doublecomplex gp = {1.0, 0.0};
doublecomplex temp, temp2;
int i;
z_recip(&qj, &pj);
if (whichDeriv == 1) {
temp.r = (1.0 - qj.r) * gz.r + qj.i * gz.i;
temp.i = (1.0 - qj.r) * gz.i - qj.i * gz.r; /* gz * (1-qj) */
gz = temp;
temp.r = (1.0 + pj.r) * gz.r - pj.i * gz.i;
temp.i = (1.0 + pj.r) * gz.i + pj.i * gz.r; /* gz * (1+pj) */
gz = temp;
temp.r = pj.r * gz.r - pj.i * gz.i; /* gz * pj */
temp.i = pj.r * gz.i + pj.i * gz.r;
gz.r = 0.5 * temp.r; gz.i = 0.5 * temp.i;
} else if (whichDeriv == 2) {
temp.r = (1.0 - qj.r) * gz.r + qj.i * gz.i;
temp.i = (1.0 - qj.r) * gz.i - qj.i * gz.r; /* gz * (1 - qj) */
gz = temp;
temp.r = (1.0 - pj.r) * gz.r + pj.i * gz.i;
temp.i = (1.0 - pj.r) * gz.i - pj.i * gz.r; /* gz * (1 - pj) */
gz.r = -temp.r; gz.i = -temp.i;
}
for (i = 0; i < 4; ++i) {
pi = poles[i];
if ((pi.r != pj.r) || (pi.i != pj.i && pi.i != -pj.i)) {
temp.r = 1.0 - pi.r * qj.r + pi.i * qj.i;
temp.i = - pi.r * qj.i - pi.i * qj.r; /* 1 - pi * qj */
temp2.r = gp.r * temp.r - gp.i * temp.i;
temp2.i = gp.i * temp.r + gp.r * temp.i; /* gp * (1 - pi * qj) */
gp = temp2;
}
temp.r = 1.0 - pi.r * pj.r + pi.i * pj.i;
temp.i = -pi.r * pj.i - pi.i * pj.r; /* 1 - pi * pj */
temp2.r = gp.r * temp.r - gp.i * temp.i;
temp2.i = gp.i * temp.r + gp.r * temp.i; /* gp * (1 - pi * pj) */
gp = temp2;
}
z_div(&temp, &gz, &gp); /* gz / gp */
residue->r = gain * temp.r;
residue->i = gain * temp.i; /* gain * gz/gp */
}
void pow_zi(doublecomplex *p, doublecomplex *a, integer *b) /* p = a**b */
#endif
{
integer n;
unsigned long u;
double t;
doublecomplex q, x;
static doublecomplex one = {1.0, 0.0};
n = *b;
q.r = 1;
q.i = 0;
if(n == 0)
goto done;
if(n < 0)
{
n = -n;
z_div(&x, &one, a);
}
else
{
x.r = a->r;
x.i = a->i;
}
for(u = n; ; )
{
if(u & 01)
{
t = q.r * x.r - q.i * x.i;
q.i = q.r * x.i + q.i * x.r;
q.r = t;
}
if(u >>= 1)
{
t = x.r * x.r - x.i * x.i;
x.i = 2 * x.r * x.i;
x.r = t;
}
else
break;
}
void pow_zi(doublecomplex *p, doublecomplex *a, integer *b) /* p = a**b */
#endif
{
integer n;
double t;
doublecomplex x;
static doublecomplex one = {1.0, 0.0};
n = *b;
p->r = 1;
p->i = 0;
if(n == 0)
return;
if(n < 0)
{
n = -n;
z_div(&x, &one, a);
}
else
{
x.r = a->r;
x.i = a->i;
}
for( ; ; )
{
if(n & 01)
{
t = p->r * x.r - p->i * x.i;
p->i = p->r * x.i + p->i * x.r;
p->r = t;
}
if(n >>= 1)
{
t = x.r * x.r - x.i * x.i;
x.i = 2 * x.r * x.i;
x.r = t;
}
else
break;
}
static double
VanVlietComputeSigma(
double sigma, /* Scale factor */
const doublecomplex poles[4]
/* Poles of the filter */
) {
double q = sigma / 2.0;
doublecomplex cs = {0.0, 0.0};
doublecomplex b, c, d, temp;
int i;
for (i = 0; i < 4; ++i) {
doublecomplex pi = poles[i];
double a = pow(z_abs(&pi), -1.0 / q);
double t = atan2(pi.i, pi.r) / q;
b.r = a * cos(t); b.i = a * sin(t);
c.r = 1.0 - b.r; c.i = - b.i;
d.r = c.r * c.r - c.i * c.i; d.i = 2.0 * c.r * c.i;
b.r *= 2.0; b.i *= 2.0;
z_div(&temp, &b, &d);
cs.r += temp.r; cs.i += temp.i;
}
return sqrt(cs.r);
}
doublereal zla_hercond_x__(char *uplo, integer *n, doublecomplex *a, integer *
lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublecomplex *
x, integer *info, doublecomplex *work, doublereal *rwork, ftnlen
uplo_len)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4;
doublereal ret_val, d__1, d__2;
doublecomplex z__1, z__2;
/* Local variables */
integer i__, j;
logical up;
doublereal tmp;
integer kase;
integer isave[3];
doublereal anorm;
doublereal ainvnm;
/* -- LAPACK routine (version 3.2.1) -- */
/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
/* -- Jason Riedy of Univ. of California Berkeley. -- */
/* -- April 2009 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley and NAG Ltd. -- */
/* Purpose */
/* ======= */
/* ZLA_HERCOND_X computes the infinity norm condition number of */
/* op(A) * diag(X) where X is a COMPLEX*16 vector. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The number of linear equations, i.e., the order of the */
/* matrix A. N >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the N-by-N matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* AF (input) COMPLEX*16 array, dimension (LDAF,N) */
/* The block diagonal matrix D and the multipliers used to */
/* obtain the factor U or L as computed by ZHETRF. */
/* LDAF (input) INTEGER */
/* The leading dimension of the array AF. LDAF >= max(1,N). */
/* IPIV (input) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D */
/* as determined by CHETRF. */
/* X (input) COMPLEX*16 array, dimension (N) */
/* The vector X in the formula op(A) * diag(X). */
/* INFO (output) INTEGER */
/* = 0: Successful exit. */
/* i > 0: The ith argument is invalid. */
/* WORK (input) COMPLEX*16 array, dimension (2*N). */
/* Workspace. */
/* RWORK (input) DOUBLE PRECISION array, dimension (N). */
/* Workspace. */
/* ===================================================================== */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--ipiv;
--x;
--work;
--rwork;
/* Function Body */
ret_val = 0.;
*info = 0;
if (*n < 0) {
*info = -2;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZLA_HERCOND_X", &i__1);
return ret_val;
}
up = FALSE_;
if (lsame_(uplo, "U")) {
up = TRUE_;
}
/* Compute norm of op(A)*op2(C). */
anorm = 0.;
if (up) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
tmp = 0.;
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
i__3 = j + i__ * a_dim1;
i__4 = j;
z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
.r;
z__1.r = z__2.r, z__1.i = z__2.i;
tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1),
abs(d__2));
}
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = i__ + j * a_dim1;
i__4 = j;
z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
.r;
z__1.r = z__2.r, z__1.i = z__2.i;
tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1),
abs(d__2));
}
rwork[i__] = tmp;
anorm = max(anorm,tmp);
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
tmp = 0.;
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
i__3 = i__ + j * a_dim1;
i__4 = j;
z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
.r;
z__1.r = z__2.r, z__1.i = z__2.i;
tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1),
abs(d__2));
}
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = j + i__ * a_dim1;
i__4 = j;
z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
.r;
z__1.r = z__2.r, z__1.i = z__2.i;
tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1),
abs(d__2));
}
rwork[i__] = tmp;
anorm = max(anorm,tmp);
}
}
/* Quick return if possible. */
if (*n == 0) {
ret_val = 1.;
return ret_val;
} else if (anorm == 0.) {
return ret_val;
}
/* Estimate the norm of inv(op(A)). */
ainvnm = 0.;
kase = 0;
L10:
zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
if (kase != 0) {
if (kase == 2) {
/* Multiply by R. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__;
i__4 = i__;
z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] *
work[i__3].i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
}
if (up) {
zhetrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
1], n, info);
} else {
zhetrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
1], n, info);
}
/* Multiply by inv(X). */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
z_div(&z__1, &work[i__], &x[i__]);
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
}
} else {
/* Multiply by inv(X'). */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
z_div(&z__1, &work[i__], &x[i__]);
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
}
if (up) {
zhetrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
1], n, info);
} else {
zhetrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
1], n, info);
}
/* Multiply by R. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__;
i__4 = i__;
z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] *
work[i__3].i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
}
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.) {
ret_val = 1. / ainvnm;
}
return ret_val;
} /* zla_hercond_x__ */
/* Subroutine */
int zgtsv_(integer *n, integer *nrhs, doublecomplex *dl, doublecomplex *d__, doublecomplex *du, doublecomplex *b, integer *ldb, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2, z__3, z__4, z__5;
/* Builtin functions */
double d_imag(doublecomplex *);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
/* Local variables */
integer j, k;
doublecomplex temp, mult;
extern /* Subroutine */
int xerbla_(char *, integer *);
/* -- LAPACK driver routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--dl;
--d__;
--du;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
if (*n < 0)
{
*info = -1;
}
else if (*nrhs < 0)
{
*info = -2;
}
else if (*ldb < max(1,*n))
{
*info = -7;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("ZGTSV ", &i__1);
return 0;
}
if (*n == 0)
{
return 0;
}
i__1 = *n - 1;
for (k = 1;
k <= i__1;
++k)
{
i__2 = k;
if (dl[i__2].r == 0. && dl[i__2].i == 0.)
{
/* Subdiagonal is zero, no elimination is required. */
i__2 = k;
if (d__[i__2].r == 0. && d__[i__2].i == 0.)
{
/* Diagonal is zero: set INFO = K and return;
a unique */
/* solution can not be found. */
*info = k;
return 0;
}
}
else /* if(complicated condition) */
{
i__2 = k;
i__3 = k;
if ((d__1 = d__[i__2].r, f2c_abs(d__1)) + (d__2 = d_imag(&d__[k]), f2c_abs(d__2)) >= (d__3 = dl[i__3].r, f2c_abs(d__3)) + (d__4 = d_imag(&dl[k]), f2c_abs(d__4)))
{
/* No row interchange required */
z_div(&z__1, &dl[k], &d__[k]);
mult.r = z__1.r;
mult.i = z__1.i; // , expr subst
i__2 = k + 1;
i__3 = k + 1;
i__4 = k;
z__2.r = mult.r * du[i__4].r - mult.i * du[i__4].i;
z__2.i = mult.r * du[i__4].i + mult.i * du[i__4].r; // , expr subst
z__1.r = d__[i__3].r - z__2.r;
z__1.i = d__[i__3].i - z__2.i; // , expr subst
d__[i__2].r = z__1.r;
d__[i__2].i = z__1.i; // , expr subst
i__2 = *nrhs;
for (j = 1;
j <= i__2;
++j)
{
i__3 = k + 1 + j * b_dim1;
i__4 = k + 1 + j * b_dim1;
i__5 = k + j * b_dim1;
z__2.r = mult.r * b[i__5].r - mult.i * b[i__5].i;
z__2.i = mult.r * b[i__5].i + mult.i * b[i__5].r; // , expr subst
z__1.r = b[i__4].r - z__2.r;
z__1.i = b[i__4].i - z__2.i; // , expr subst
b[i__3].r = z__1.r;
b[i__3].i = z__1.i; // , expr subst
/* L10: */
}
if (k < *n - 1)
{
i__2 = k;
dl[i__2].r = 0.;
dl[i__2].i = 0.; // , expr subst
}
}
else
{
/* Interchange rows K and K+1 */
z_div(&z__1, &d__[k], &dl[k]);
mult.r = z__1.r;
mult.i = z__1.i; // , expr subst
i__2 = k;
i__3 = k;
d__[i__2].r = dl[i__3].r;
d__[i__2].i = dl[i__3].i; // , expr subst
i__2 = k + 1;
temp.r = d__[i__2].r;
temp.i = d__[i__2].i; // , expr subst
i__2 = k + 1;
i__3 = k;
z__2.r = mult.r * temp.r - mult.i * temp.i;
z__2.i = mult.r * temp.i + mult.i * temp.r; // , expr subst
z__1.r = du[i__3].r - z__2.r;
z__1.i = du[i__3].i - z__2.i; // , expr subst
d__[i__2].r = z__1.r;
d__[i__2].i = z__1.i; // , expr subst
if (k < *n - 1)
{
i__2 = k;
i__3 = k + 1;
dl[i__2].r = du[i__3].r;
dl[i__2].i = du[i__3].i; // , expr subst
i__2 = k + 1;
z__2.r = -mult.r;
z__2.i = -mult.i; // , expr subst
i__3 = k;
z__1.r = z__2.r * dl[i__3].r - z__2.i * dl[i__3].i;
z__1.i = z__2.r * dl[i__3].i + z__2.i * dl[i__3] .r; // , expr subst
du[i__2].r = z__1.r;
du[i__2].i = z__1.i; // , expr subst
}
i__2 = k;
du[i__2].r = temp.r;
du[i__2].i = temp.i; // , expr subst
i__2 = *nrhs;
for (j = 1;
j <= i__2;
++j)
{
i__3 = k + j * b_dim1;
temp.r = b[i__3].r;
temp.i = b[i__3].i; // , expr subst
i__3 = k + j * b_dim1;
i__4 = k + 1 + j * b_dim1;
b[i__3].r = b[i__4].r;
b[i__3].i = b[i__4].i; // , expr subst
i__3 = k + 1 + j * b_dim1;
i__4 = k + 1 + j * b_dim1;
z__2.r = mult.r * b[i__4].r - mult.i * b[i__4].i;
z__2.i = mult.r * b[i__4].i + mult.i * b[i__4].r; // , expr subst
z__1.r = temp.r - z__2.r;
z__1.i = temp.i - z__2.i; // , expr subst
b[i__3].r = z__1.r;
b[i__3].i = z__1.i; // , expr subst
/* L20: */
}
}
}
/* L30: */
}
i__1 = *n;
if (d__[i__1].r == 0. && d__[i__1].i == 0.)
{
*info = *n;
return 0;
}
/* Back solve with the matrix U from the factorization. */
i__1 = *nrhs;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n + j * b_dim1;
z_div(&z__1, &b[*n + j * b_dim1], &d__[*n]);
b[i__2].r = z__1.r;
b[i__2].i = z__1.i; // , expr subst
if (*n > 1)
{
i__2 = *n - 1 + j * b_dim1;
i__3 = *n - 1 + j * b_dim1;
i__4 = *n - 1;
i__5 = *n + j * b_dim1;
z__3.r = du[i__4].r * b[i__5].r - du[i__4].i * b[i__5].i;
z__3.i = du[i__4].r * b[i__5].i + du[i__4].i * b[i__5].r; // , expr subst
z__2.r = b[i__3].r - z__3.r;
z__2.i = b[i__3].i - z__3.i; // , expr subst
z_div(&z__1, &z__2, &d__[*n - 1]);
b[i__2].r = z__1.r;
b[i__2].i = z__1.i; // , expr subst
}
for (k = *n - 2;
k >= 1;
--k)
{
i__2 = k + j * b_dim1;
i__3 = k + j * b_dim1;
i__4 = k;
i__5 = k + 1 + j * b_dim1;
z__4.r = du[i__4].r * b[i__5].r - du[i__4].i * b[i__5].i;
z__4.i = du[i__4].r * b[i__5].i + du[i__4].i * b[i__5].r; // , expr subst
z__3.r = b[i__3].r - z__4.r;
z__3.i = b[i__3].i - z__4.i; // , expr subst
i__6 = k;
i__7 = k + 2 + j * b_dim1;
z__5.r = dl[i__6].r * b[i__7].r - dl[i__6].i * b[i__7].i;
z__5.i = dl[i__6].r * b[i__7].i + dl[i__6].i * b[i__7].r; // , expr subst
z__2.r = z__3.r - z__5.r;
z__2.i = z__3.i - z__5.i; // , expr subst
z_div(&z__1, &z__2, &d__[k]);
b[i__2].r = z__1.r;
b[i__2].i = z__1.i; // , expr subst
/* L40: */
}
/* L50: */
}
return 0;
/* End of ZGTSV */
}
/* Subroutine */ int zgetc2_(integer *n, doublecomplex *a, integer *lda,
integer *ipiv, integer *jpiv, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1;
/* Builtin functions */
double z_abs(doublecomplex *);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
/* Local variables */
static integer i__, j, ip, jp;
static doublereal eps;
static integer ipv, jpv;
static doublereal smin, xmax;
extern /* Subroutine */ int zgeru_(integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zswap_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *), dlabad_(doublereal *,
doublereal *);
extern doublereal dlamch_(char *, ftnlen);
static doublereal bignum, smlnum;
/* -- LAPACK auxiliary routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* June 30, 1999 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGETC2 computes an LU factorization, using complete pivoting, of the */
/* n-by-n matrix A. The factorization has the form A = P * L * U * Q, */
/* where P and Q are permutation matrices, L is lower triangular with */
/* unit diagonal elements and U is upper triangular. */
/* This is a level 1 BLAS version of the algorithm. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA, N) */
/* On entry, the n-by-n matrix to be factored. */
/* On exit, the factors L and U from the factorization */
/* A = P*L*U*Q; the unit diagonal elements of L are not stored. */
/* If U(k, k) appears to be less than SMIN, U(k, k) is given the */
/* value of SMIN, giving a nonsingular perturbed system. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1, N). */
/* IPIV (output) INTEGER array, dimension (N). */
/* The pivot indices; for 1 <= i <= N, row i of the */
/* matrix has been interchanged with row IPIV(i). */
/* JPIV (output) INTEGER array, dimension (N). */
/* The pivot indices; for 1 <= j <= N, column j of the */
/* matrix has been interchanged with column JPIV(j). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* > 0: if INFO = k, U(k, k) is likely to produce overflow if */
/* one tries to solve for x in Ax = b. So U is perturbed */
/* to avoid the overflow. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
/* Umea University, S-901 87 Umea, Sweden. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Set constants to control overflow */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
--jpiv;
/* Function Body */
*info = 0;
eps = dlamch_("P", (ftnlen)1);
smlnum = dlamch_("S", (ftnlen)1) / eps;
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
/* Factorize A using complete pivoting. */
/* Set pivots less than SMIN to SMIN */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Find max element in matrix A */
xmax = 0.;
i__2 = *n;
for (ip = i__; ip <= i__2; ++ip) {
i__3 = *n;
for (jp = i__; jp <= i__3; ++jp) {
if (z_abs(&a[ip + jp * a_dim1]) >= xmax) {
xmax = z_abs(&a[ip + jp * a_dim1]);
ipv = ip;
jpv = jp;
}
/* L10: */
}
/* L20: */
}
if (i__ == 1) {
/* Computing MAX */
d__1 = eps * xmax;
smin = max(d__1,smlnum);
}
/* Swap rows */
if (ipv != i__) {
zswap_(n, &a[ipv + a_dim1], lda, &a[i__ + a_dim1], lda);
}
ipiv[i__] = ipv;
/* Swap columns */
if (jpv != i__) {
zswap_(n, &a[jpv * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &
c__1);
}
jpiv[i__] = jpv;
/* Check for singularity */
if (z_abs(&a[i__ + i__ * a_dim1]) < smin) {
*info = i__;
i__2 = i__ + i__ * a_dim1;
z__1.r = smin, z__1.i = 0.;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = j + i__ * a_dim1;
z_div(&z__1, &a[j + i__ * a_dim1], &a[i__ + i__ * a_dim1]);
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L30: */
}
i__2 = *n - i__;
i__3 = *n - i__;
zgeru_(&i__2, &i__3, &c_b10, &a[i__ + 1 + i__ * a_dim1], &c__1, &a[
i__ + (i__ + 1) * a_dim1], lda, &a[i__ + 1 + (i__ + 1) *
a_dim1], lda);
/* L40: */
}
if (z_abs(&a[*n + *n * a_dim1]) < smin) {
*info = *n;
i__1 = *n + *n * a_dim1;
z__1.r = smin, z__1.i = 0.;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
}
return 0;
/* End of ZGETC2 */
} /* zgetc2_ */
/* Subroutine */ int zdrgvx_(integer *nsize, doublereal *thresh, integer *nin,
integer *nout, doublecomplex *a, integer *lda, doublecomplex *b,
doublecomplex *ai, doublecomplex *bi, doublecomplex *alpha,
doublecomplex *beta, doublecomplex *vl, doublecomplex *vr, integer *
ilo, integer *ihi, doublereal *lscale, doublereal *rscale, doublereal
*s, doublereal *dtru, doublereal *dif, doublereal *diftru,
doublecomplex *work, integer *lwork, doublereal *rwork, integer *
iwork, integer *liwork, doublereal *result, logical *bwork, integer *
info)
{
/* Format strings */
static char fmt_9999[] = "(\002 ZDRGVX: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002)\002)";
static char fmt_9998[] = "(\002 ZDRGVX: \002,a,\002 Eigenvectors from"
" \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
"error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
"i6,\002, IWA=\002,i5,\002, IWB=\002,i5,\002, IWX=\002,i5,\002, I"
"WY=\002,i5)";
static char fmt_9997[] = "(/1x,a3,\002 -- Complex Expert Eigenvalue/vect"
"or\002,\002 problem driver\002)";
static char fmt_9995[] = "(\002 Matrix types: \002,/)";
static char fmt_9994[] = "(\002 TYPE 1: Da is diagonal, Db is identity,"
" \002,/\002 A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1) \002,/"
"\002 YH and X are left and right eigenvectors. \002,/)";
static char fmt_9993[] = "(\002 TYPE 2: Da is quasi-diagonal, Db is iden"
"tity, \002,/\002 A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1)"
" \002,/\002 YH and X are left and right eigenvectors. \002,/)"
;
static char fmt_9992[] = "(/\002 Tests performed: \002,/4x,\002 a is al"
"pha, b is beta, l is a left eigenvector, \002,/4x,\002 r is a ri"
"ght eigenvector and \002,a,\002 means \002,a,\002.\002,/\002 1 ="
" max | ( b A - a B )\002,a,\002 l | / const.\002,/\002 2 = max |"
" ( b A - a B ) r | / const.\002,/\002 3 = max ( Sest/Stru, Stru/"
"Sest ) \002,\002 over all eigenvalues\002,/\002 4 = max( DIFest/"
"DIFtru, DIFtru/DIFest ) \002,\002 over the 1st and 5th eigenvect"
"ors\002,/)";
static char fmt_9991[] = "(\002 Type=\002,i2,\002,\002,\002 IWA=\002,i2"
",\002, IWB=\002,i2,\002, IWX=\002,i2,\002, IWY=\002,i2,\002, res"
"ult \002,i2,\002 is\002,0p,f8.2)";
static char fmt_9990[] = "(\002 Type=\002,i2,\002,\002,\002 IWA=\002,i2"
",\002, IWB=\002,i2,\002, IWX=\002,i2,\002, IWY=\002,i2,\002, res"
"ult \002,i2,\002 is\002,1p,d10.3)";
static char fmt_9987[] = "(\002 ZDRGVX: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, Input example #\002,i2,\002"
")\002)";
static char fmt_9986[] = "(\002 ZDRGVX: \002,a,\002 Eigenvectors from"
" \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
"error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, Input Examp"
"le #\002,i2,\002)\002)";
static char fmt_9996[] = "(\002Input Example\002)";
static char fmt_9989[] = "(\002 Input example #\002,i2,\002, matrix orde"
"r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,0p,f8.2)";
static char fmt_9988[] = "(\002 Input example #\002,i2,\002, matrix orde"
"r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,1p,d10.3)";
/* System generated locals */
integer a_dim1, a_offset, ai_dim1, ai_offset, b_dim1, b_offset, bi_dim1,
bi_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1;
/* Builtin functions */
double sqrt(doublereal);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
/* Local variables */
integer i__, j, n, iwa, iwb;
doublereal ulp;
integer iwx, iwy, nmax, linfo;
doublereal anorm, bnorm;
extern /* Subroutine */ int zget52_(logical *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *
, doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
doublereal *);
integer nerrs;
doublereal ratio1, ratio2, thrsh2;
extern /* Subroutine */ int zlatm6_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublereal *, doublereal *);
extern doublereal dlamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
doublereal abnorm;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *);
doublecomplex weight[5];
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
integer minwrk, maxwrk, iptype;
extern /* Subroutine */ int zggevx_(char *, char *, char *, char *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublecomplex *, integer *, doublereal *, integer *,
logical *, integer *);
doublereal ulpinv;
integer nptknt, ntestt;
/* Fortran I/O blocks */
static cilist io___20 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___22 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___23 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___28 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___29 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___30 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___31 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___32 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___33 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9990, 0 };
static cilist io___35 = { 0, 0, 1, 0, 0 };
static cilist io___36 = { 0, 0, 0, 0, 0 };
static cilist io___37 = { 0, 0, 0, 0, 0 };
static cilist io___38 = { 0, 0, 0, 0, 0 };
static cilist io___39 = { 0, 0, 0, 0, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9987, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9986, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9986, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9989, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9988, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZDRGVX checks the nonsymmetric generalized eigenvalue problem */
/* expert driver ZGGEVX. */
/* ZGGEVX computes the generalized eigenvalues, (optionally) the left */
/* and/or right eigenvectors, (optionally) computes a balancing */
/* transformation to improve the conditioning, and (optionally) */
/* reciprocal condition numbers for the eigenvalues and eigenvectors. */
/* When ZDRGVX is called with NSIZE > 0, two types of test matrix pairs */
/* are generated by the subroutine DLATM6 and test the driver ZGGEVX. */
/* The test matrices have the known exact condition numbers for */
/* eigenvalues. For the condition numbers of the eigenvectors */
/* corresponding the first and last eigenvalues are also know */
/* ``exactly'' (see ZLATM6). */
/* For each matrix pair, the following tests will be performed and */
/* compared with the threshhold THRESH. */
/* (1) max over all left eigenvalue/-vector pairs (beta/alpha,l) of */
/* | l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) ) */
/* where l**H is the conjugate tranpose of l. */
/* (2) max over all right eigenvalue/-vector pairs (beta/alpha,r) of */
/* | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) ) */
/* (3) The condition number S(i) of eigenvalues computed by ZGGEVX */
/* differs less than a factor THRESH from the exact S(i) (see */
/* ZLATM6). */
/* (4) DIF(i) computed by ZTGSNA differs less than a factor 10*THRESH */
/* from the exact value (for the 1st and 5th vectors only). */
/* Test Matrices */
/* ============= */
/* Two kinds of test matrix pairs */
/* (A, B) = inverse(YH) * (Da, Db) * inverse(X) */
/* are used in the tests: */
/* 1: Da = 1+a 0 0 0 0 Db = 1 0 0 0 0 */
/* 0 2+a 0 0 0 0 1 0 0 0 */
/* 0 0 3+a 0 0 0 0 1 0 0 */
/* 0 0 0 4+a 0 0 0 0 1 0 */
/* 0 0 0 0 5+a , 0 0 0 0 1 , and */
/* 2: Da = 1 -1 0 0 0 Db = 1 0 0 0 0 */
/* 1 1 0 0 0 0 1 0 0 0 */
/* 0 0 1 0 0 0 0 1 0 0 */
/* 0 0 0 1+a 1+b 0 0 0 1 0 */
/* 0 0 0 -1-b 1+a , 0 0 0 0 1 . */
/* In both cases the same inverse(YH) and inverse(X) are used to compute */
/* (A, B), giving the exact eigenvectors to (A,B) as (YH, X): */
/* YH: = 1 0 -y y -y X = 1 0 -x -x x */
/* 0 1 -y y -y 0 1 x -x -x */
/* 0 0 1 0 0 0 0 1 0 0 */
/* 0 0 0 1 0 0 0 0 1 0 */
/* 0 0 0 0 1, 0 0 0 0 1 , where */
/* a, b, x and y will have all values independently of each other from */
/* { sqrt(sqrt(ULP)), 0.1, 1, 10, 1/sqrt(sqrt(ULP)) }. */
/* Arguments */
/* ========= */
/* NSIZE (input) INTEGER */
/* The number of sizes of matrices to use. NSIZE must be at */
/* least zero. If it is zero, no randomly generated matrices */
/* are tested, but any test matrices read from NIN will be */
/* tested. If it is not zero, then N = 5. */
/* THRESH (input) DOUBLE PRECISION */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error */
/* is scaled to be O(1), so THRESH should be a reasonably */
/* small multiple of 1, e.g., 10 or 100. In particular, */
/* it should not depend on the precision (single vs. double) */
/* or the size of the matrix. It must be at least zero. */
/* NIN (input) INTEGER */
/* The FORTRAN unit number for reading in the data file of */
/* problems to solve. */
/* NOUT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns IINFO not equal to 0.) */
/* A (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
/* Used to hold the matrix whose eigenvalues are to be */
/* computed. On exit, A contains the last matrix actually used. */
/* LDA (input) INTEGER */
/* The leading dimension of A, B, AI, BI, Ao, and Bo. */
/* It must be at least 1 and at least NSIZE. */
/* B (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
/* Used to hold the matrix whose eigenvalues are to be */
/* computed. On exit, B contains the last matrix actually used. */
/* AI (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
/* Copy of A, modified by ZGGEVX. */
/* BI (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
/* Copy of B, modified by ZGGEVX. */
/* ALPHA (workspace) COMPLEX*16 array, dimension (NSIZE) */
/* BETA (workspace) COMPLEX*16 array, dimension (NSIZE) */
/* On exit, ALPHA/BETA are the eigenvalues. */
/* VL (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
/* VL holds the left eigenvectors computed by ZGGEVX. */
/* VR (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
/* VR holds the right eigenvectors computed by ZGGEVX. */
/* ILO (output/workspace) INTEGER */
/* IHI (output/workspace) INTEGER */
/* LSCALE (output/workspace) DOUBLE PRECISION array, dimension (N) */
/* RSCALE (output/workspace) DOUBLE PRECISION array, dimension (N) */
/* S (output/workspace) DOUBLE PRECISION array, dimension (N) */
/* DTRU (output/workspace) DOUBLE PRECISION array, dimension (N) */
/* DIF (output/workspace) DOUBLE PRECISION array, dimension (N) */
/* DIFTRU (output/workspace) DOUBLE PRECISION array, dimension (N) */
/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* Leading dimension of WORK. LWORK >= 2*N*N + 2*N */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (6*N) */
/* IWORK (workspace) INTEGER array, dimension (LIWORK) */
/* LIWORK (input) INTEGER */
/* Leading dimension of IWORK. LIWORK >= N+2. */
/* RESULT (output/workspace) DOUBLE PRECISION array, dimension (4) */
/* BWORK (workspace) LOGICAL array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: A routine returned an error code. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Check for errors */
/* Parameter adjustments */
vr_dim1 = *lda;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
vl_dim1 = *lda;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
bi_dim1 = *lda;
bi_offset = 1 + bi_dim1;
bi -= bi_offset;
ai_dim1 = *lda;
ai_offset = 1 + ai_dim1;
ai -= ai_offset;
b_dim1 = *lda;
b_offset = 1 + b_dim1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--alpha;
--beta;
--lscale;
--rscale;
--s;
--dtru;
--dif;
--diftru;
--work;
--rwork;
--iwork;
--result;
--bwork;
/* Function Body */
*info = 0;
nmax = 5;
if (*nsize < 0) {
*info = -1;
} else if (*thresh < 0.) {
*info = -2;
} else if (*nin <= 0) {
*info = -3;
} else if (*nout <= 0) {
*info = -4;
} else if (*lda < 1 || *lda < nmax) {
*info = -6;
} else if (*liwork < nmax + 2) {
*info = -26;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "Workspace:" describe the */
/* minimal amount of workspace needed at that point in the code, */
/* as well as the preferred amount for good performance. */
/* NB refers to the optimal block size for the immediately */
/* following subroutine, as returned by ILAENV.) */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
minwrk = (nmax << 1) * (nmax + 1);
maxwrk = nmax * (ilaenv_(&c__1, "ZGEQRF", " ", &nmax, &c__1, &nmax, &
c__0) + 1);
/* Computing MAX */
i__1 = maxwrk, i__2 = (nmax << 1) * (nmax + 1);
maxwrk = max(i__1,i__2);
work[1].r = (doublereal) maxwrk, work[1].i = 0.;
}
if (*lwork < minwrk) {
*info = -23;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZDRGVX", &i__1);
return 0;
}
n = 5;
ulp = dlamch_("P");
ulpinv = 1. / ulp;
thrsh2 = *thresh * 10.;
nerrs = 0;
nptknt = 0;
ntestt = 0;
if (*nsize == 0) {
goto L90;
}
/* Parameters used for generating test matrices. */
d__1 = sqrt(sqrt(ulp));
z__1.r = d__1, z__1.i = 0.;
weight[0].r = z__1.r, weight[0].i = z__1.i;
weight[1].r = .1, weight[1].i = 0.;
weight[2].r = 1., weight[2].i = 0.;
z_div(&z__1, &c_b11, &weight[1]);
weight[3].r = z__1.r, weight[3].i = z__1.i;
z_div(&z__1, &c_b11, weight);
weight[4].r = z__1.r, weight[4].i = z__1.i;
for (iptype = 1; iptype <= 2; ++iptype) {
for (iwa = 1; iwa <= 5; ++iwa) {
for (iwb = 1; iwb <= 5; ++iwb) {
for (iwx = 1; iwx <= 5; ++iwx) {
for (iwy = 1; iwy <= 5; ++iwy) {
/* generated a pair of test matrix */
zlatm6_(&iptype, &c__5, &a[a_offset], lda, &b[
b_offset], &vr[vr_offset], lda, &vl[vl_offset]
, lda, &weight[iwa - 1], &weight[iwb - 1], &
weight[iwx - 1], &weight[iwy - 1], &dtru[1], &
diftru[1]);
/* Compute eigenvalues/eigenvectors of (A, B). */
/* Compute eigenvalue/eigenvector condition numbers */
/* using computed eigenvectors. */
zlacpy_("F", &n, &n, &a[a_offset], lda, &ai[ai_offset]
, lda);
zlacpy_("F", &n, &n, &b[b_offset], lda, &bi[bi_offset]
, lda);
zggevx_("N", "V", "V", "B", &n, &ai[ai_offset], lda, &
bi[bi_offset], lda, &alpha[1], &beta[1], &vl[
vl_offset], lda, &vr[vr_offset], lda, ilo,
ihi, &lscale[1], &rscale[1], &anorm, &bnorm, &
s[1], &dif[1], &work[1], lwork, &rwork[1], &
iwork[1], &bwork[1], &linfo);
if (linfo != 0) {
io___20.ciunit = *nout;
s_wsfe(&io___20);
do_fio(&c__1, "ZGGEVX", (ftnlen)6);
do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&iptype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwa, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwb, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwx, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwy, (ftnlen)sizeof(
integer));
e_wsfe();
goto L30;
}
/* Compute the norm(A, B) */
zlacpy_("Full", &n, &n, &ai[ai_offset], lda, &work[1],
&n);
zlacpy_("Full", &n, &n, &bi[bi_offset], lda, &work[n *
n + 1], &n);
i__1 = n << 1;
abnorm = zlange_("Fro", &n, &i__1, &work[1], &n, &
rwork[1]);
/* Tests (1) and (2) */
result[1] = 0.;
zget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset],
lda, &vl[vl_offset], lda, &alpha[1], &beta[1],
&work[1], &rwork[1], &result[1]);
if (result[2] > *thresh) {
io___22.ciunit = *nout;
s_wsfe(&io___22);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "ZGGEVX", (ftnlen)6);
do_fio(&c__1, (char *)&result[2], (ftnlen)sizeof(
doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&iptype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwa, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwb, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwx, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwy, (ftnlen)sizeof(
integer));
e_wsfe();
}
result[2] = 0.;
zget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset],
lda, &vr[vr_offset], lda, &alpha[1], &beta[1]
, &work[1], &rwork[1], &result[2]);
if (result[3] > *thresh) {
io___23.ciunit = *nout;
s_wsfe(&io___23);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "ZGGEVX", (ftnlen)6);
do_fio(&c__1, (char *)&result[3], (ftnlen)sizeof(
doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&iptype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwa, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwb, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwx, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwy, (ftnlen)sizeof(
integer));
e_wsfe();
}
/* Test (3) */
result[3] = 0.;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (s[i__] == 0.) {
if (dtru[i__] > abnorm * ulp) {
result[3] = ulpinv;
}
} else if (dtru[i__] == 0.) {
if (s[i__] > abnorm * ulp) {
result[3] = ulpinv;
}
} else {
/* Computing MAX */
d__3 = (d__1 = dtru[i__] / s[i__], abs(d__1)),
d__4 = (d__2 = s[i__] / dtru[i__],
abs(d__2));
rwork[i__] = max(d__3,d__4);
/* Computing MAX */
d__1 = result[3], d__2 = rwork[i__];
result[3] = max(d__1,d__2);
}
/* L10: */
}
/* Test (4) */
result[4] = 0.;
if (dif[1] == 0.) {
if (diftru[1] > abnorm * ulp) {
result[4] = ulpinv;
}
} else if (diftru[1] == 0.) {
if (dif[1] > abnorm * ulp) {
result[4] = ulpinv;
}
} else if (dif[5] == 0.) {
if (diftru[5] > abnorm * ulp) {
result[4] = ulpinv;
}
} else if (diftru[5] == 0.) {
if (dif[5] > abnorm * ulp) {
result[4] = ulpinv;
}
} else {
/* Computing MAX */
d__3 = (d__1 = diftru[1] / dif[1], abs(d__1)),
d__4 = (d__2 = dif[1] / diftru[1], abs(
d__2));
ratio1 = max(d__3,d__4);
/* Computing MAX */
d__3 = (d__1 = diftru[5] / dif[5], abs(d__1)),
d__4 = (d__2 = dif[5] / diftru[5], abs(
d__2));
ratio2 = max(d__3,d__4);
result[4] = max(ratio1,ratio2);
}
ntestt += 4;
/* Print out tests which fail. */
for (j = 1; j <= 4; ++j) {
if (result[j] >= thrsh2 && j >= 4 || result[j] >=
*thresh && j <= 3) {
/* If this is the first test to fail, */
/* print a header to the data file. */
if (nerrs == 0) {
io___28.ciunit = *nout;
s_wsfe(&io___28);
do_fio(&c__1, "ZXV", (ftnlen)3);
e_wsfe();
/* Print out messages for built-in examples */
/* Matrix types */
io___29.ciunit = *nout;
s_wsfe(&io___29);
e_wsfe();
io___30.ciunit = *nout;
s_wsfe(&io___30);
e_wsfe();
io___31.ciunit = *nout;
s_wsfe(&io___31);
e_wsfe();
/* Tests performed */
io___32.ciunit = *nout;
s_wsfe(&io___32);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
do_fio(&c__1, "'", (ftnlen)1);
e_wsfe();
}
++nerrs;
if (result[j] < 1e4) {
io___33.ciunit = *nout;
s_wsfe(&io___33);
do_fio(&c__1, (char *)&iptype, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&iwa, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&iwb, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&iwx, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&iwy, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)
sizeof(doublereal));
e_wsfe();
} else {
io___34.ciunit = *nout;
s_wsfe(&io___34);
do_fio(&c__1, (char *)&iptype, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&iwa, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&iwb, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&iwx, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&iwy, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)
sizeof(doublereal));
e_wsfe();
}
}
/* L20: */
}
L30:
/* L40: */
;
}
/* L50: */
}
/* L60: */
}
/* L70: */
}
/* L80: */
}
goto L150;
L90:
/* Read in data from file to check accuracy of condition estimation */
/* Read input data until N=0 */
io___35.ciunit = *nin;
i__1 = s_rsle(&io___35);
if (i__1 != 0) {
goto L150;
}
i__1 = do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L150;
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L150;
}
if (n == 0) {
goto L150;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___36.ciunit = *nin;
s_rsle(&io___36);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L100: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___37.ciunit = *nin;
s_rsle(&io___37);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&b[i__ + j * b_dim1], (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L110: */
}
io___38.ciunit = *nin;
s_rsle(&io___38);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__5, &c__1, (char *)&dtru[i__], (ftnlen)sizeof(doublereal));
}
e_rsle();
io___39.ciunit = *nin;
s_rsle(&io___39);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__5, &c__1, (char *)&diftru[i__], (ftnlen)sizeof(doublereal))
;
}
e_rsle();
++nptknt;
/* Compute eigenvalues/eigenvectors of (A, B). */
/* Compute eigenvalue/eigenvector condition numbers */
/* using computed eigenvectors. */
zlacpy_("F", &n, &n, &a[a_offset], lda, &ai[ai_offset], lda);
zlacpy_("F", &n, &n, &b[b_offset], lda, &bi[bi_offset], lda);
zggevx_("N", "V", "V", "B", &n, &ai[ai_offset], lda, &bi[bi_offset], lda,
&alpha[1], &beta[1], &vl[vl_offset], lda, &vr[vr_offset], lda,
ilo, ihi, &lscale[1], &rscale[1], &anorm, &bnorm, &s[1], &dif[1],
&work[1], lwork, &rwork[1], &iwork[1], &bwork[1], &linfo);
if (linfo != 0) {
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, "ZGGEVX", (ftnlen)6);
do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
e_wsfe();
goto L140;
}
/* Compute the norm(A, B) */
zlacpy_("Full", &n, &n, &ai[ai_offset], lda, &work[1], &n);
zlacpy_("Full", &n, &n, &bi[bi_offset], lda, &work[n * n + 1], &n);
i__1 = n << 1;
abnorm = zlange_("Fro", &n, &i__1, &work[1], &n, &rwork[1]);
/* Tests (1) and (2) */
result[1] = 0.;
zget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], lda, &vl[vl_offset],
lda, &alpha[1], &beta[1], &work[1], &rwork[1], &result[1]);
if (result[2] > *thresh) {
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "ZGGEVX", (ftnlen)6);
do_fio(&c__1, (char *)&result[2], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
e_wsfe();
}
result[2] = 0.;
zget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], lda, &vr[vr_offset]
, lda, &alpha[1], &beta[1], &work[1], &rwork[1], &result[2]);
if (result[3] > *thresh) {
io___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "ZGGEVX", (ftnlen)6);
do_fio(&c__1, (char *)&result[3], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
e_wsfe();
}
/* Test (3) */
result[3] = 0.;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (s[i__] == 0.) {
if (dtru[i__] > abnorm * ulp) {
result[3] = ulpinv;
}
} else if (dtru[i__] == 0.) {
if (s[i__] > abnorm * ulp) {
result[3] = ulpinv;
}
} else {
/* Computing MAX */
d__3 = (d__1 = dtru[i__] / s[i__], abs(d__1)), d__4 = (d__2 = s[
i__] / dtru[i__], abs(d__2));
rwork[i__] = max(d__3,d__4);
/* Computing MAX */
d__1 = result[3], d__2 = rwork[i__];
result[3] = max(d__1,d__2);
}
/* L120: */
}
/* Test (4) */
result[4] = 0.;
if (dif[1] == 0.) {
if (diftru[1] > abnorm * ulp) {
result[4] = ulpinv;
}
} else if (diftru[1] == 0.) {
if (dif[1] > abnorm * ulp) {
result[4] = ulpinv;
}
} else if (dif[5] == 0.) {
if (diftru[5] > abnorm * ulp) {
result[4] = ulpinv;
}
} else if (diftru[5] == 0.) {
if (dif[5] > abnorm * ulp) {
result[4] = ulpinv;
}
} else {
/* Computing MAX */
d__3 = (d__1 = diftru[1] / dif[1], abs(d__1)), d__4 = (d__2 = dif[1] /
diftru[1], abs(d__2));
ratio1 = max(d__3,d__4);
/* Computing MAX */
d__3 = (d__1 = diftru[5] / dif[5], abs(d__1)), d__4 = (d__2 = dif[5] /
diftru[5], abs(d__2));
ratio2 = max(d__3,d__4);
result[4] = max(ratio1,ratio2);
}
ntestt += 4;
/* Print out tests which fail. */
for (j = 1; j <= 4; ++j) {
if (result[j] >= thrsh2) {
/* If this is the first test to fail, */
/* print a header to the data file. */
if (nerrs == 0) {
io___43.ciunit = *nout;
s_wsfe(&io___43);
do_fio(&c__1, "ZXV", (ftnlen)3);
e_wsfe();
/* Print out messages for built-in examples */
/* Matrix types */
io___44.ciunit = *nout;
s_wsfe(&io___44);
e_wsfe();
/* Tests performed */
io___45.ciunit = *nout;
s_wsfe(&io___45);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
do_fio(&c__1, "'", (ftnlen)1);
e_wsfe();
}
++nerrs;
if (result[j] < 1e4) {
io___46.ciunit = *nout;
s_wsfe(&io___46);
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(doublereal));
e_wsfe();
} else {
io___47.ciunit = *nout;
s_wsfe(&io___47);
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(doublereal));
e_wsfe();
}
}
/* L130: */
}
L140:
goto L90;
L150:
/* Summary */
alasvm_("ZXV", nout, &nerrs, &ntestt, &c__0);
work[1].r = (doublereal) maxwrk, work[1].i = 0.;
return 0;
/* End of ZDRGVX */
} /* zdrgvx_ */
/* Subroutine */
int zsytf2_rook_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *ipiv, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
/* Builtin functions */
double sqrt(doublereal), d_imag(doublecomplex *);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j, k, p;
doublecomplex t, d11, d12, d21, d22;
integer ii, kk, kp;
doublecomplex wk, wkm1, wkp1;
logical done;
integer imax, jmax;
extern /* Subroutine */
int zsyr_(char *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *);
doublereal alpha;
extern logical lsame_(char *, char *);
doublereal dtemp, sfmin;
extern /* Subroutine */
int zscal_(integer *, doublecomplex *, doublecomplex *, integer *);
integer itemp, kstep;
logical upper;
extern /* Subroutine */
int zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal dlamch_(char *);
doublereal absakk;
extern /* Subroutine */
int xerbla_(char *, integer *);
doublereal colmax;
extern integer izamax_(integer *, doublecomplex *, integer *);
doublereal rowmax;
/* -- LAPACK computational routine (version 3.5.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2013 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
/* 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_("ZSYTF2_ROOK", &i__1);
return 0;
}
/* Initialize ALPHA for use in choosing pivot block size. */
alpha = (sqrt(17.) + 1.) / 8.;
/* Compute machine safe minimum */
sfmin = dlamch_("S");
if (upper)
{
/* Factorize A as U*D*U**T using the upper triangle of A */
/* K is the main loop index, decreasing from N to 1 in steps of */
/* 1 or 2 */
k = *n;
L10: /* If K < 1, exit from loop */
if (k < 1)
{
goto L70;
}
kstep = 1;
p = k;
/* Determine rows and columns to be interchanged and whether */
/* a 1-by-1 or 2-by-2 pivot block will be used */
i__1 = k + k * a_dim1;
absakk = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[k + k * a_dim1]), abs(d__2));
/* IMAX is the row-index of the largest off-diagonal element in */
/* column K, and COLMAX is its absolute value. */
/* Determine both COLMAX and IMAX. */
if (k > 1)
{
i__1 = k - 1;
imax = izamax_(&i__1, &a[k * a_dim1 + 1], &c__1);
i__1 = imax + k * a_dim1;
colmax = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[imax + k * a_dim1]), abs(d__2));
}
else
{
colmax = 0.;
}
if (max(absakk,colmax) == 0.)
{
/* Column K is zero or underflow: set INFO and continue */
if (*info == 0)
{
*info = k;
}
kp = k;
}
else
{
/* Test for interchange */
/* Equivalent to testing for (used to handle NaN and Inf) */
/* ABSAKK.GE.ALPHA*COLMAX */
if (! (absakk < alpha * colmax))
{
/* no interchange, */
/* use 1-by-1 pivot block */
kp = k;
}
else
{
done = FALSE_;
/* Loop until pivot found */
L12: /* Begin pivot search loop body */
/* JMAX is the column-index of the largest off-diagonal */
/* element in row IMAX, and ROWMAX is its absolute value. */
/* Determine both ROWMAX and JMAX. */
if (imax != k)
{
i__1 = k - imax;
jmax = imax + izamax_(&i__1, &a[imax + (imax + 1) * a_dim1], lda);
i__1 = imax + jmax * a_dim1;
rowmax = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(& a[imax + jmax * a_dim1]), abs(d__2));
}
else
{
rowmax = 0.;
}
if (imax > 1)
{
i__1 = imax - 1;
itemp = izamax_(&i__1, &a[imax * a_dim1 + 1], &c__1);
i__1 = itemp + imax * a_dim1;
dtemp = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[ itemp + imax * a_dim1]), abs(d__2));
if (dtemp > rowmax)
{
rowmax = dtemp;
jmax = itemp;
}
}
/* Equivalent to testing for (used to handle NaN and Inf) */
/* CABS1( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX */
i__1 = imax + imax * a_dim1;
if (! ((d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[imax + imax * a_dim1]), abs(d__2)) < alpha * rowmax))
{
/* interchange rows and columns K and IMAX, */
/* use 1-by-1 pivot block */
kp = imax;
done = TRUE_;
/* Equivalent to testing for ROWMAX .EQ. COLMAX, */
/* used to handle NaN and Inf */
}
else if (p == jmax || rowmax <= colmax)
{
/* interchange rows and columns K+1 and IMAX, */
/* use 2-by-2 pivot block */
kp = imax;
kstep = 2;
done = TRUE_;
}
else
{
/* Pivot NOT found, set variables and repeat */
p = imax;
colmax = rowmax;
imax = jmax;
}
/* End pivot search loop body */
if (! done)
{
goto L12;
}
}
/* Swap TWO rows and TWO columns */
/* First swap */
if (kstep == 2 && p != k)
{
/* Interchange rows and column K and P in the leading */
/* submatrix A(1:k,1:k) if we have a 2-by-2 pivot */
if (p > 1)
{
i__1 = p - 1;
zswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[p * a_dim1 + 1], &c__1);
}
if (p < k - 1)
{
i__1 = k - p - 1;
zswap_(&i__1, &a[p + 1 + k * a_dim1], &c__1, &a[p + (p + 1) * a_dim1], lda);
}
i__1 = k + k * a_dim1;
t.r = a[i__1].r;
t.i = a[i__1].i; // , expr subst
i__1 = k + k * a_dim1;
i__2 = p + p * a_dim1;
a[i__1].r = a[i__2].r;
a[i__1].i = a[i__2].i; // , expr subst
i__1 = p + p * a_dim1;
a[i__1].r = t.r;
a[i__1].i = t.i; // , expr subst
}
/* Second swap */
kk = k - kstep + 1;
if (kp != kk)
{
/* Interchange rows and columns KK and KP in the leading */
/* submatrix A(1:k,1:k) */
if (kp > 1)
{
i__1 = kp - 1;
zswap_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], &c__1);
}
if (kk > 1 && kp < kk - 1)
{
i__1 = kk - kp - 1;
zswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + ( kp + 1) * a_dim1], lda);
}
i__1 = kk + kk * a_dim1;
t.r = a[i__1].r;
t.i = a[i__1].i; // , expr subst
i__1 = kk + kk * a_dim1;
i__2 = kp + kp * a_dim1;
a[i__1].r = a[i__2].r;
a[i__1].i = a[i__2].i; // , expr subst
i__1 = kp + kp * a_dim1;
a[i__1].r = t.r;
a[i__1].i = t.i; // , expr subst
if (kstep == 2)
{
i__1 = k - 1 + k * a_dim1;
t.r = a[i__1].r;
t.i = a[i__1].i; // , expr subst
i__1 = k - 1 + k * a_dim1;
i__2 = kp + k * a_dim1;
a[i__1].r = a[i__2].r;
a[i__1].i = a[i__2].i; // , expr subst
i__1 = kp + k * a_dim1;
a[i__1].r = t.r;
a[i__1].i = t.i; // , expr subst
}
}
/* Update the leading submatrix */
if (kstep == 1)
{
/* 1-by-1 pivot block D(k): column k now holds */
/* W(k) = U(k)*D(k) */
/* where U(k) is the k-th column of U */
if (k > 1)
{
/* Perform a rank-1 update of A(1:k-1,1:k-1) and */
/* store U(k) in column k */
i__1 = k + k * a_dim1;
if ((d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[k + k * a_dim1]), abs(d__2)) >= sfmin)
{
/* Perform a rank-1 update of A(1:k-1,1:k-1) as */
/* A := A - U(k)*D(k)*U(k)**T */
/* = A - W(k)*1/D(k)*W(k)**T */
z_div(&z__1, &c_b1, &a[k + k * a_dim1]);
d11.r = z__1.r;
d11.i = z__1.i; // , expr subst
i__1 = k - 1;
z__1.r = -d11.r;
z__1.i = -d11.i; // , expr subst
zsyr_(uplo, &i__1, &z__1, &a[k * a_dim1 + 1], &c__1, & a[a_offset], lda);
/* Store U(k) in column k */
i__1 = k - 1;
zscal_(&i__1, &d11, &a[k * a_dim1 + 1], &c__1);
}
else
{
/* Store L(k) in column K */
i__1 = k + k * a_dim1;
d11.r = a[i__1].r;
d11.i = a[i__1].i; // , expr subst
i__1 = k - 1;
for (ii = 1;
ii <= i__1;
++ii)
{
i__2 = ii + k * a_dim1;
z_div(&z__1, &a[ii + k * a_dim1], &d11);
a[i__2].r = z__1.r;
a[i__2].i = z__1.i; // , expr subst
/* L16: */
}
/* Perform a rank-1 update of A(k+1:n,k+1:n) as */
/* A := A - U(k)*D(k)*U(k)**T */
/* = A - W(k)*(1/D(k))*W(k)**T */
/* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T */
i__1 = k - 1;
z__1.r = -d11.r;
z__1.i = -d11.i; // , expr subst
zsyr_(uplo, &i__1, &z__1, &a[k * a_dim1 + 1], &c__1, & a[a_offset], lda);
}
}
}
else
{
/* 2-by-2 pivot block D(k): columns k and k-1 now hold */
/* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) */
/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */
/* of U */
/* Perform a rank-2 update of A(1:k-2,1:k-2) as */
/* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T */
/* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T */
/* and store L(k) and L(k+1) in columns k and k+1 */
if (k > 2)
{
i__1 = k - 1 + k * a_dim1;
d12.r = a[i__1].r;
d12.i = a[i__1].i; // , expr subst
z_div(&z__1, &a[k - 1 + (k - 1) * a_dim1], &d12);
d22.r = z__1.r;
d22.i = z__1.i; // , expr subst
z_div(&z__1, &a[k + k * a_dim1], &d12);
d11.r = z__1.r;
d11.i = z__1.i; // , expr subst
z__3.r = d11.r * d22.r - d11.i * d22.i;
z__3.i = d11.r * d22.i + d11.i * d22.r; // , expr subst
z__2.r = z__3.r - 1.;
z__2.i = z__3.i - 0.; // , expr subst
z_div(&z__1, &c_b1, &z__2);
t.r = z__1.r;
t.i = z__1.i; // , expr subst
for (j = k - 2;
j >= 1;
--j)
{
i__1 = j + (k - 1) * a_dim1;
z__3.r = d11.r * a[i__1].r - d11.i * a[i__1].i;
z__3.i = d11.r * a[i__1].i + d11.i * a[i__1] .r; // , expr subst
i__2 = j + k * a_dim1;
z__2.r = z__3.r - a[i__2].r;
z__2.i = z__3.i - a[i__2] .i; // , expr subst
z__1.r = t.r * z__2.r - t.i * z__2.i;
z__1.i = t.r * z__2.i + t.i * z__2.r; // , expr subst
wkm1.r = z__1.r;
wkm1.i = z__1.i; // , expr subst
i__1 = j + k * a_dim1;
z__3.r = d22.r * a[i__1].r - d22.i * a[i__1].i;
z__3.i = d22.r * a[i__1].i + d22.i * a[i__1] .r; // , expr subst
i__2 = j + (k - 1) * a_dim1;
z__2.r = z__3.r - a[i__2].r;
z__2.i = z__3.i - a[i__2] .i; // , expr subst
z__1.r = t.r * z__2.r - t.i * z__2.i;
z__1.i = t.r * z__2.i + t.i * z__2.r; // , expr subst
wk.r = z__1.r;
wk.i = z__1.i; // , expr subst
for (i__ = j;
i__ >= 1;
--i__)
{
i__1 = i__ + j * a_dim1;
i__2 = i__ + j * a_dim1;
z_div(&z__4, &a[i__ + k * a_dim1], &d12);
z__3.r = z__4.r * wk.r - z__4.i * wk.i;
z__3.i = z__4.r * wk.i + z__4.i * wk.r; // , expr subst
z__2.r = a[i__2].r - z__3.r;
z__2.i = a[i__2].i - z__3.i; // , expr subst
z_div(&z__6, &a[i__ + (k - 1) * a_dim1], &d12);
z__5.r = z__6.r * wkm1.r - z__6.i * wkm1.i;
z__5.i = z__6.r * wkm1.i + z__6.i * wkm1.r; // , expr subst
z__1.r = z__2.r - z__5.r;
z__1.i = z__2.i - z__5.i; // , expr subst
a[i__1].r = z__1.r;
a[i__1].i = z__1.i; // , expr subst
/* L20: */
}
/* Store U(k) and U(k-1) in cols k and k-1 for row J */
i__1 = j + k * a_dim1;
z_div(&z__1, &wk, &d12);
a[i__1].r = z__1.r;
a[i__1].i = z__1.i; // , expr subst
i__1 = j + (k - 1) * a_dim1;
z_div(&z__1, &wkm1, &d12);
a[i__1].r = z__1.r;
a[i__1].i = z__1.i; // , expr subst
/* L30: */
}
}
}
}
/* Store details of the interchanges in IPIV */
if (kstep == 1)
{
ipiv[k] = kp;
}
else
{
ipiv[k] = -p;
ipiv[k - 1] = -kp;
}
/* Decrease K and return to the start of the main loop */
k -= kstep;
goto L10;
}
else
{
/* Factorize A as L*D*L**T using the lower triangle of A */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2 */
k = 1;
L40: /* If K > N, exit from loop */
if (k > *n)
{
goto L70;
}
kstep = 1;
p = k;
/* Determine rows and columns to be interchanged and whether */
/* a 1-by-1 or 2-by-2 pivot block will be used */
i__1 = k + k * a_dim1;
absakk = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[k + k * a_dim1]), abs(d__2));
/* IMAX is the row-index of the largest off-diagonal element in */
/* column K, and COLMAX is its absolute value. */
/* Determine both COLMAX and IMAX. */
if (k < *n)
{
i__1 = *n - k;
imax = k + izamax_(&i__1, &a[k + 1 + k * a_dim1], &c__1);
i__1 = imax + k * a_dim1;
colmax = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[imax + k * a_dim1]), abs(d__2));
}
else
{
colmax = 0.;
}
if (max(absakk,colmax) == 0.)
{
/* Column K is zero or underflow: set INFO and continue */
if (*info == 0)
{
*info = k;
}
kp = k;
}
else
{
/* Test for interchange */
/* Equivalent to testing for (used to handle NaN and Inf) */
/* ABSAKK.GE.ALPHA*COLMAX */
if (! (absakk < alpha * colmax))
{
/* no interchange, use 1-by-1 pivot block */
kp = k;
}
else
{
done = FALSE_;
/* Loop until pivot found */
L42: /* Begin pivot search loop body */
/* JMAX is the column-index of the largest off-diagonal */
/* element in row IMAX, and ROWMAX is its absolute value. */
/* Determine both ROWMAX and JMAX. */
if (imax != k)
{
i__1 = imax - k;
jmax = k - 1 + izamax_(&i__1, &a[imax + k * a_dim1], lda);
i__1 = imax + jmax * a_dim1;
rowmax = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(& a[imax + jmax * a_dim1]), abs(d__2));
}
else
{
rowmax = 0.;
}
if (imax < *n)
{
i__1 = *n - imax;
itemp = imax + izamax_(&i__1, &a[imax + 1 + imax * a_dim1] , &c__1);
i__1 = itemp + imax * a_dim1;
dtemp = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[ itemp + imax * a_dim1]), abs(d__2));
if (dtemp > rowmax)
{
rowmax = dtemp;
jmax = itemp;
}
}
/* Equivalent to testing for (used to handle NaN and Inf) */
/* CABS1( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX */
i__1 = imax + imax * a_dim1;
if (! ((d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[imax + imax * a_dim1]), abs(d__2)) < alpha * rowmax))
{
/* interchange rows and columns K and IMAX, */
/* use 1-by-1 pivot block */
kp = imax;
done = TRUE_;
/* Equivalent to testing for ROWMAX .EQ. COLMAX, */
/* used to handle NaN and Inf */
}
else if (p == jmax || rowmax <= colmax)
{
/* interchange rows and columns K+1 and IMAX, */
/* use 2-by-2 pivot block */
kp = imax;
kstep = 2;
done = TRUE_;
}
else
{
/* Pivot NOT found, set variables and repeat */
p = imax;
colmax = rowmax;
imax = jmax;
}
/* End pivot search loop body */
if (! done)
{
goto L42;
}
}
/* Swap TWO rows and TWO columns */
/* First swap */
if (kstep == 2 && p != k)
{
/* Interchange rows and column K and P in the trailing */
/* submatrix A(k:n,k:n) if we have a 2-by-2 pivot */
if (p < *n)
{
i__1 = *n - p;
zswap_(&i__1, &a[p + 1 + k * a_dim1], &c__1, &a[p + 1 + p * a_dim1], &c__1);
}
if (p > k + 1)
{
i__1 = p - k - 1;
zswap_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[p + (k + 1) * a_dim1], lda);
}
i__1 = k + k * a_dim1;
t.r = a[i__1].r;
t.i = a[i__1].i; // , expr subst
i__1 = k + k * a_dim1;
i__2 = p + p * a_dim1;
a[i__1].r = a[i__2].r;
a[i__1].i = a[i__2].i; // , expr subst
i__1 = p + p * a_dim1;
a[i__1].r = t.r;
a[i__1].i = t.i; // , expr subst
}
/* Second swap */
kk = k + kstep - 1;
if (kp != kk)
{
/* Interchange rows and columns KK and KP in the trailing */
/* submatrix A(k:n,k:n) */
if (kp < *n)
{
i__1 = *n - kp;
zswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1 + kp * a_dim1], &c__1);
}
if (kk < *n && kp > kk + 1)
{
i__1 = kp - kk - 1;
zswap_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + ( kk + 1) * a_dim1], lda);
}
i__1 = kk + kk * a_dim1;
t.r = a[i__1].r;
t.i = a[i__1].i; // , expr subst
i__1 = kk + kk * a_dim1;
i__2 = kp + kp * a_dim1;
a[i__1].r = a[i__2].r;
a[i__1].i = a[i__2].i; // , expr subst
i__1 = kp + kp * a_dim1;
a[i__1].r = t.r;
a[i__1].i = t.i; // , expr subst
if (kstep == 2)
{
i__1 = k + 1 + k * a_dim1;
t.r = a[i__1].r;
t.i = a[i__1].i; // , expr subst
i__1 = k + 1 + k * a_dim1;
i__2 = kp + k * a_dim1;
a[i__1].r = a[i__2].r;
a[i__1].i = a[i__2].i; // , expr subst
i__1 = kp + k * a_dim1;
a[i__1].r = t.r;
a[i__1].i = t.i; // , expr subst
}
}
/* Update the trailing submatrix */
if (kstep == 1)
{
/* 1-by-1 pivot block D(k): column k now holds */
/* W(k) = L(k)*D(k) */
/* where L(k) is the k-th column of L */
if (k < *n)
{
/* Perform a rank-1 update of A(k+1:n,k+1:n) and */
/* store L(k) in column k */
i__1 = k + k * a_dim1;
if ((d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[k + k * a_dim1]), abs(d__2)) >= sfmin)
{
/* Perform a rank-1 update of A(k+1:n,k+1:n) as */
/* A := A - L(k)*D(k)*L(k)**T */
/* = A - W(k)*(1/D(k))*W(k)**T */
z_div(&z__1, &c_b1, &a[k + k * a_dim1]);
d11.r = z__1.r;
d11.i = z__1.i; // , expr subst
i__1 = *n - k;
z__1.r = -d11.r;
z__1.i = -d11.i; // , expr subst
zsyr_(uplo, &i__1, &z__1, &a[k + 1 + k * a_dim1], & c__1, &a[k + 1 + (k + 1) * a_dim1], lda);
/* Store L(k) in column k */
i__1 = *n - k;
zscal_(&i__1, &d11, &a[k + 1 + k * a_dim1], &c__1);
}
else
{
/* Store L(k) in column k */
i__1 = k + k * a_dim1;
d11.r = a[i__1].r;
d11.i = a[i__1].i; // , expr subst
i__1 = *n;
for (ii = k + 1;
ii <= i__1;
++ii)
{
i__2 = ii + k * a_dim1;
z_div(&z__1, &a[ii + k * a_dim1], &d11);
a[i__2].r = z__1.r;
a[i__2].i = z__1.i; // , expr subst
/* L46: */
}
/* Perform a rank-1 update of A(k+1:n,k+1:n) as */
/* A := A - L(k)*D(k)*L(k)**T */
/* = A - W(k)*(1/D(k))*W(k)**T */
/* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T */
i__1 = *n - k;
z__1.r = -d11.r;
z__1.i = -d11.i; // , expr subst
zsyr_(uplo, &i__1, &z__1, &a[k + 1 + k * a_dim1], & c__1, &a[k + 1 + (k + 1) * a_dim1], lda);
}
}
}
else
{
/* 2-by-2 pivot block D(k): columns k and k+1 now hold */
/* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) */
/* where L(k) and L(k+1) are the k-th and (k+1)-th columns */
/* of L */
/* Perform a rank-2 update of A(k+2:n,k+2:n) as */
/* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T */
/* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T */
/* and store L(k) and L(k+1) in columns k and k+1 */
if (k < *n - 1)
{
i__1 = k + 1 + k * a_dim1;
d21.r = a[i__1].r;
d21.i = a[i__1].i; // , expr subst
z_div(&z__1, &a[k + 1 + (k + 1) * a_dim1], &d21);
d11.r = z__1.r;
d11.i = z__1.i; // , expr subst
z_div(&z__1, &a[k + k * a_dim1], &d21);
d22.r = z__1.r;
d22.i = z__1.i; // , expr subst
z__3.r = d11.r * d22.r - d11.i * d22.i;
z__3.i = d11.r * d22.i + d11.i * d22.r; // , expr subst
z__2.r = z__3.r - 1.;
z__2.i = z__3.i - 0.; // , expr subst
z_div(&z__1, &c_b1, &z__2);
t.r = z__1.r;
t.i = z__1.i; // , expr subst
i__1 = *n;
for (j = k + 2;
j <= i__1;
++j)
{
/* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J */
i__2 = j + k * a_dim1;
z__3.r = d11.r * a[i__2].r - d11.i * a[i__2].i;
z__3.i = d11.r * a[i__2].i + d11.i * a[i__2] .r; // , expr subst
i__3 = j + (k + 1) * a_dim1;
z__2.r = z__3.r - a[i__3].r;
z__2.i = z__3.i - a[i__3] .i; // , expr subst
z__1.r = t.r * z__2.r - t.i * z__2.i;
z__1.i = t.r * z__2.i + t.i * z__2.r; // , expr subst
wk.r = z__1.r;
wk.i = z__1.i; // , expr subst
i__2 = j + (k + 1) * a_dim1;
z__3.r = d22.r * a[i__2].r - d22.i * a[i__2].i;
z__3.i = d22.r * a[i__2].i + d22.i * a[i__2] .r; // , expr subst
i__3 = j + k * a_dim1;
z__2.r = z__3.r - a[i__3].r;
z__2.i = z__3.i - a[i__3] .i; // , expr subst
z__1.r = t.r * z__2.r - t.i * z__2.i;
z__1.i = t.r * z__2.i + t.i * z__2.r; // , expr subst
wkp1.r = z__1.r;
wkp1.i = z__1.i; // , expr subst
/* Perform a rank-2 update of A(k+2:n,k+2:n) */
i__2 = *n;
for (i__ = j;
i__ <= i__2;
++i__)
{
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
z_div(&z__4, &a[i__ + k * a_dim1], &d21);
z__3.r = z__4.r * wk.r - z__4.i * wk.i;
z__3.i = z__4.r * wk.i + z__4.i * wk.r; // , expr subst
z__2.r = a[i__4].r - z__3.r;
z__2.i = a[i__4].i - z__3.i; // , expr subst
z_div(&z__6, &a[i__ + (k + 1) * a_dim1], &d21);
z__5.r = z__6.r * wkp1.r - z__6.i * wkp1.i;
z__5.i = z__6.r * wkp1.i + z__6.i * wkp1.r; // , expr subst
z__1.r = z__2.r - z__5.r;
z__1.i = z__2.i - z__5.i; // , expr subst
a[i__3].r = z__1.r;
a[i__3].i = z__1.i; // , expr subst
/* L50: */
}
/* Store L(k) and L(k+1) in cols k and k+1 for row J */
i__2 = j + k * a_dim1;
z_div(&z__1, &wk, &d21);
a[i__2].r = z__1.r;
a[i__2].i = z__1.i; // , expr subst
i__2 = j + (k + 1) * a_dim1;
z_div(&z__1, &wkp1, &d21);
a[i__2].r = z__1.r;
a[i__2].i = z__1.i; // , expr subst
/* L60: */
}
}
}
}
/* Store details of the interchanges in IPIV */
if (kstep == 1)
{
ipiv[k] = kp;
}
else
{
ipiv[k] = -p;
ipiv[k + 1] = -kp;
}
/* Increase K and return to the start of the main loop */
k += kstep;
goto L40;
}
L70:
return 0;
/* End of ZSYTF2_ROOK */
}
/* Subroutine */ int ztptri_(char *uplo, char *diag, integer *n,
doublecomplex *ap, integer *info)
{
/* System generated locals */
integer i__1, i__2;
doublecomplex z__1;
/* Builtin functions */
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
/* Local variables */
integer j, jc, jj;
doublecomplex ajj;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
logical upper;
extern /* Subroutine */ int ztpmv_(char *, char *, char *, integer *,
doublecomplex *, doublecomplex *, integer *), xerbla_(char *, integer *);
integer jclast;
logical nounit;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZTPTRI computes the inverse of a complex upper or lower triangular */
/* matrix A stored in packed format. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': A is upper triangular; */
/* = 'L': A is lower triangular. */
/* DIAG (input) CHARACTER*1 */
/* = 'N': A is non-unit triangular; */
/* = 'U': A is unit triangular. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangular matrix A, stored */
/* 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. */
/* See below for further details. */
/* On exit, the (triangular) inverse of the original matrix, in */
/* the same packed storage format. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, A(i,i) is exactly zero. The triangular */
/* matrix is singular and its inverse can not be computed. */
/* Further Details */
/* =============== */
/* A triangular matrix A can be transferred to packed storage using one */
/* of the following program segments: */
/* UPLO = 'U': UPLO = 'L': */
/* JC = 1 JC = 1 */
/* DO 2 J = 1, N DO 2 J = 1, N */
/* DO 1 I = 1, J DO 1 I = J, N */
/* AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J) */
/* 1 CONTINUE 1 CONTINUE */
/* JC = JC + J JC = JC + N - J + 1 */
/* 2 CONTINUE 2 CONTINUE */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZTPTRI", &i__1);
return 0;
}
/* Check for singularity if non-unit. */
if (nounit) {
if (upper) {
jj = 0;
i__1 = *n;
for (*info = 1; *info <= i__1; ++(*info)) {
jj += *info;
i__2 = jj;
if (ap[i__2].r == 0. && ap[i__2].i == 0.) {
return 0;
}
/* L10: */
}
} else {
jj = 1;
i__1 = *n;
for (*info = 1; *info <= i__1; ++(*info)) {
i__2 = jj;
if (ap[i__2].r == 0. && ap[i__2].i == 0.) {
return 0;
}
jj = jj + *n - *info + 1;
/* L20: */
}
}
*info = 0;
}
if (upper) {
/* Compute inverse of upper triangular matrix. */
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (nounit) {
i__2 = jc + j - 1;
z_div(&z__1, &c_b1, &ap[jc + j - 1]);
ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
i__2 = jc + j - 1;
z__1.r = -ap[i__2].r, z__1.i = -ap[i__2].i;
ajj.r = z__1.r, ajj.i = z__1.i;
} else {
z__1.r = -1., z__1.i = -0.;
ajj.r = z__1.r, ajj.i = z__1.i;
}
/* Compute elements 1:j-1 of j-th column. */
i__2 = j - 1;
ztpmv_("Upper", "No transpose", diag, &i__2, &ap[1], &ap[jc], &
c__1);
i__2 = j - 1;
zscal_(&i__2, &ajj, &ap[jc], &c__1);
jc += j;
/* L30: */
}
} else {
/* Compute inverse of lower triangular matrix. */
jc = *n * (*n + 1) / 2;
for (j = *n; j >= 1; --j) {
if (nounit) {
i__1 = jc;
z_div(&z__1, &c_b1, &ap[jc]);
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
i__1 = jc;
z__1.r = -ap[i__1].r, z__1.i = -ap[i__1].i;
ajj.r = z__1.r, ajj.i = z__1.i;
} else {
z__1.r = -1., z__1.i = -0.;
ajj.r = z__1.r, ajj.i = z__1.i;
}
if (j < *n) {
/* Compute elements j+1:n of j-th column. */
i__1 = *n - j;
ztpmv_("Lower", "No transpose", diag, &i__1, &ap[jclast], &ap[
jc + 1], &c__1);
i__1 = *n - j;
zscal_(&i__1, &ajj, &ap[jc + 1], &c__1);
}
jclast = jc;
jc = jc - *n + j - 2;
/* L40: */
}
}
return 0;
/* End of ZTPTRI */
} /* ztptri_ */
int zrotg_(doublecomplex *ca, doublecomplex *cb, double *
c__, doublecomplex *s)
{
/* System generated locals */
double d__1, d__2;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double z_abs(doublecomplex *);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
double sqrt(double);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
double norm;
doublecomplex alpha;
double scale;
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* determines a double complex Givens rotation. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
if (z_abs(ca) != 0.) {
goto L10;
}
*c__ = 0.;
s->r = 1., s->i = 0.;
ca->r = cb->r, ca->i = cb->i;
goto L20;
L10:
scale = z_abs(ca) + z_abs(cb);
z__2.r = scale, z__2.i = 0.;
z_div(&z__1, ca, &z__2);
/* Computing 2nd power */
d__1 = z_abs(&z__1);
z__4.r = scale, z__4.i = 0.;
z_div(&z__3, cb, &z__4);
/* Computing 2nd power */
d__2 = z_abs(&z__3);
norm = scale * sqrt(d__1 * d__1 + d__2 * d__2);
d__1 = z_abs(ca);
z__1.r = ca->r / d__1, z__1.i = ca->i / d__1;
alpha.r = z__1.r, alpha.i = z__1.i;
*c__ = z_abs(ca) / norm;
d_cnjg(&z__3, cb);
z__2.r = alpha.r * z__3.r - alpha.i * z__3.i, z__2.i = alpha.r * z__3.i +
alpha.i * z__3.r;
z__1.r = z__2.r / norm, z__1.i = z__2.i / norm;
s->r = z__1.r, s->i = z__1.i;
z__1.r = norm * alpha.r, z__1.i = norm * alpha.i;
ca->r = z__1.r, ca->i = z__1.i;
L20:
return 0;
} /* zrotg_ */
/* Subroutine */ int zsptri_(char *uplo, integer *n, doublecomplex *ap,
integer *ipiv, doublecomplex *work, integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3;
doublecomplex z__1, z__2, z__3;
/* Local variables */
doublecomplex d__;
integer j, k;
doublecomplex t, ak;
integer kc, kp, kx, kpc, npp;
doublecomplex akp1, temp, akkp1;
integer kstep;
logical upper;
integer kcnext;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* ZSPTRI computes the inverse of a complex symmetric indefinite matrix */
/* A in packed storage using the factorization A = U*D*U**T or */
/* A = L*D*L**T computed by ZSPTRF. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the details of the factorization are stored */
/* as an upper or lower triangular matrix. */
/* = 'U': Upper triangular, form is A = U*D*U**T; */
/* = 'L': Lower triangular, form is A = L*D*L**T. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
/* On entry, the block diagonal matrix D and the multipliers */
/* used to obtain the factor U or L as computed by ZSPTRF, */
/* stored as a packed triangular matrix. */
/* On exit, if INFO = 0, the (symmetric) inverse of the original */
/* matrix, stored as a packed triangular matrix. The j-th column */
/* of inv(A) is stored in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j; */
/* if UPLO = 'L', */
/* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n. */
/* IPIV (input) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D */
/* as determined by ZSPTRF. */
/* WORK (workspace) COMPLEX*16 array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its */
/* inverse could not be computed. */
/* ===================================================================== */
/* Test the input parameters. */
/* Parameter adjustments */
--work;
--ipiv;
--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_("ZSPTRI", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Check that the diagonal matrix D is nonsingular. */
if (upper) {
/* Upper triangular storage: examine D from bottom to top */
kp = *n * (*n + 1) / 2;
for (*info = *n; *info >= 1; --(*info)) {
i__1 = kp;
if (ipiv[*info] > 0 && (ap[i__1].r == 0. && ap[i__1].i == 0.)) {
return 0;
}
kp -= *info;
}
} else {
/* Lower triangular storage: examine D from top to bottom. */
kp = 1;
i__1 = *n;
for (*info = 1; *info <= i__1; ++(*info)) {
i__2 = kp;
if (ipiv[*info] > 0 && (ap[i__2].r == 0. && ap[i__2].i == 0.)) {
return 0;
}
kp = kp + *n - *info + 1;
}
}
*info = 0;
if (upper) {
/* Compute inv(A) from the factorization A = U*D*U'. */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = 1;
kc = 1;
L30:
/* If K > N, exit from loop. */
if (k > *n) {
goto L50;
}
kcnext = kc + k;
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Invert the diagonal block. */
i__1 = kc + k - 1;
z_div(&z__1, &c_b1, &ap[kc + k - 1]);
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
/* Compute column K of the inverse. */
if (k > 1) {
i__1 = k - 1;
zcopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1);
i__1 = k - 1;
z__1.r = -1., z__1.i = -0.;
zspmv_(uplo, &i__1, &z__1, &ap[1], &work[1], &c__1, &c_b2, &
ap[kc], &c__1);
i__1 = kc + k - 1;
i__2 = kc + k - 1;
i__3 = k - 1;
zdotu_(&z__2, &i__3, &work[1], &c__1, &ap[kc], &c__1);
z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i;
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
}
kstep = 1;
} else {
/* 2 x 2 diagonal block */
/* Invert the diagonal block. */
i__1 = kcnext + k - 1;
t.r = ap[i__1].r, t.i = ap[i__1].i;
z_div(&z__1, &ap[kc + k - 1], &t);
ak.r = z__1.r, ak.i = z__1.i;
z_div(&z__1, &ap[kcnext + k], &t);
akp1.r = z__1.r, akp1.i = z__1.i;
z_div(&z__1, &ap[kcnext + k - 1], &t);
akkp1.r = z__1.r, akkp1.i = z__1.i;
z__3.r = ak.r * akp1.r - ak.i * akp1.i, z__3.i = ak.r * akp1.i +
ak.i * akp1.r;
z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.;
z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * z__2.i + t.i
* z__2.r;
d__.r = z__1.r, d__.i = z__1.i;
i__1 = kc + k - 1;
z_div(&z__1, &akp1, &d__);
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
i__1 = kcnext + k;
z_div(&z__1, &ak, &d__);
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
i__1 = kcnext + k - 1;
z__2.r = -akkp1.r, z__2.i = -akkp1.i;
z_div(&z__1, &z__2, &d__);
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
/* Compute columns K and K+1 of the inverse. */
if (k > 1) {
i__1 = k - 1;
zcopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1);
i__1 = k - 1;
z__1.r = -1., z__1.i = -0.;
zspmv_(uplo, &i__1, &z__1, &ap[1], &work[1], &c__1, &c_b2, &
ap[kc], &c__1);
i__1 = kc + k - 1;
i__2 = kc + k - 1;
i__3 = k - 1;
zdotu_(&z__2, &i__3, &work[1], &c__1, &ap[kc], &c__1);
z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i;
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
i__1 = kcnext + k - 1;
i__2 = kcnext + k - 1;
i__3 = k - 1;
zdotu_(&z__2, &i__3, &ap[kc], &c__1, &ap[kcnext], &c__1);
z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i;
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
i__1 = k - 1;
zcopy_(&i__1, &ap[kcnext], &c__1, &work[1], &c__1);
i__1 = k - 1;
z__1.r = -1., z__1.i = -0.;
zspmv_(uplo, &i__1, &z__1, &ap[1], &work[1], &c__1, &c_b2, &
ap[kcnext], &c__1);
i__1 = kcnext + k;
i__2 = kcnext + k;
i__3 = k - 1;
zdotu_(&z__2, &i__3, &work[1], &c__1, &ap[kcnext], &c__1);
z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i;
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
}
kstep = 2;
kcnext = kcnext + k + 1;
}
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k) {
/* Interchange rows and columns K and KP in the leading */
/* submatrix A(1:k+1,1:k+1) */
kpc = (kp - 1) * kp / 2 + 1;
i__1 = kp - 1;
zswap_(&i__1, &ap[kc], &c__1, &ap[kpc], &c__1);
kx = kpc + kp - 1;
i__1 = k - 1;
for (j = kp + 1; j <= i__1; ++j) {
kx = kx + j - 1;
i__2 = kc + j - 1;
temp.r = ap[i__2].r, temp.i = ap[i__2].i;
i__2 = kc + j - 1;
i__3 = kx;
ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i;
i__2 = kx;
ap[i__2].r = temp.r, ap[i__2].i = temp.i;
}
i__1 = kc + k - 1;
temp.r = ap[i__1].r, temp.i = ap[i__1].i;
i__1 = kc + k - 1;
i__2 = kpc + kp - 1;
ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
i__1 = kpc + kp - 1;
ap[i__1].r = temp.r, ap[i__1].i = temp.i;
if (kstep == 2) {
i__1 = kc + k + k - 1;
temp.r = ap[i__1].r, temp.i = ap[i__1].i;
i__1 = kc + k + k - 1;
i__2 = kc + k + kp - 1;
ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
i__1 = kc + k + kp - 1;
ap[i__1].r = temp.r, ap[i__1].i = temp.i;
}
}
k += kstep;
kc = kcnext;
goto L30;
L50:
;
} else {
/* Compute inv(A) from the factorization A = L*D*L'. */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
npp = *n * (*n + 1) / 2;
k = *n;
kc = npp;
L60:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L80;
}
kcnext = kc - (*n - k + 2);
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Invert the diagonal block. */
i__1 = kc;
z_div(&z__1, &c_b1, &ap[kc]);
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
/* Compute column K of the inverse. */
if (k < *n) {
i__1 = *n - k;
zcopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1);
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zspmv_(uplo, &i__1, &z__1, &ap[kc + *n - k + 1], &work[1], &
c__1, &c_b2, &ap[kc + 1], &c__1);
i__1 = kc;
i__2 = kc;
i__3 = *n - k;
zdotu_(&z__2, &i__3, &work[1], &c__1, &ap[kc + 1], &c__1);
z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i;
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
}
kstep = 1;
} else {
/* 2 x 2 diagonal block */
/* Invert the diagonal block. */
i__1 = kcnext + 1;
t.r = ap[i__1].r, t.i = ap[i__1].i;
z_div(&z__1, &ap[kcnext], &t);
ak.r = z__1.r, ak.i = z__1.i;
z_div(&z__1, &ap[kc], &t);
akp1.r = z__1.r, akp1.i = z__1.i;
z_div(&z__1, &ap[kcnext + 1], &t);
akkp1.r = z__1.r, akkp1.i = z__1.i;
z__3.r = ak.r * akp1.r - ak.i * akp1.i, z__3.i = ak.r * akp1.i +
ak.i * akp1.r;
z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.;
z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * z__2.i + t.i
* z__2.r;
d__.r = z__1.r, d__.i = z__1.i;
i__1 = kcnext;
z_div(&z__1, &akp1, &d__);
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
i__1 = kc;
z_div(&z__1, &ak, &d__);
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
i__1 = kcnext + 1;
z__2.r = -akkp1.r, z__2.i = -akkp1.i;
z_div(&z__1, &z__2, &d__);
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
/* Compute columns K-1 and K of the inverse. */
if (k < *n) {
i__1 = *n - k;
zcopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1);
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zspmv_(uplo, &i__1, &z__1, &ap[kc + (*n - k + 1)], &work[1], &
c__1, &c_b2, &ap[kc + 1], &c__1);
i__1 = kc;
i__2 = kc;
i__3 = *n - k;
zdotu_(&z__2, &i__3, &work[1], &c__1, &ap[kc + 1], &c__1);
z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i;
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
i__1 = kcnext + 1;
i__2 = kcnext + 1;
i__3 = *n - k;
zdotu_(&z__2, &i__3, &ap[kc + 1], &c__1, &ap[kcnext + 2], &
c__1);
z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i;
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
i__1 = *n - k;
zcopy_(&i__1, &ap[kcnext + 2], &c__1, &work[1], &c__1);
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zspmv_(uplo, &i__1, &z__1, &ap[kc + (*n - k + 1)], &work[1], &
c__1, &c_b2, &ap[kcnext + 2], &c__1);
i__1 = kcnext;
i__2 = kcnext;
i__3 = *n - k;
zdotu_(&z__2, &i__3, &work[1], &c__1, &ap[kcnext + 2], &c__1);
z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i;
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
}
kstep = 2;
kcnext -= *n - k + 3;
}
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k) {
/* Interchange rows and columns K and KP in the trailing */
/* submatrix A(k-1:n,k-1:n) */
kpc = npp - (*n - kp + 1) * (*n - kp + 2) / 2 + 1;
if (kp < *n) {
i__1 = *n - kp;
zswap_(&i__1, &ap[kc + kp - k + 1], &c__1, &ap[kpc + 1], &
c__1);
}
kx = kc + kp - k;
i__1 = kp - 1;
for (j = k + 1; j <= i__1; ++j) {
kx = kx + *n - j + 1;
i__2 = kc + j - k;
temp.r = ap[i__2].r, temp.i = ap[i__2].i;
i__2 = kc + j - k;
i__3 = kx;
ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i;
i__2 = kx;
ap[i__2].r = temp.r, ap[i__2].i = temp.i;
}
i__1 = kc;
temp.r = ap[i__1].r, temp.i = ap[i__1].i;
i__1 = kc;
i__2 = kpc;
ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
i__1 = kpc;
ap[i__1].r = temp.r, ap[i__1].i = temp.i;
if (kstep == 2) {
i__1 = kc - *n + k - 1;
temp.r = ap[i__1].r, temp.i = ap[i__1].i;
i__1 = kc - *n + k - 1;
i__2 = kc - *n + kp - 1;
ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
i__1 = kc - *n + kp - 1;
ap[i__1].r = temp.r, ap[i__1].i = temp.i;
}
}
k -= kstep;
kc = kcnext;
goto L60;
L80:
;
}
return 0;
/* End of ZSPTRI */
} /* zsptri_ */
/* Subroutine */ int zlaghe_(integer *n, integer *k, doublereal *d,
doublecomplex *a, integer *lda, integer *iseed, doublecomplex *work,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double z_abs(doublecomplex *);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *), d_cnjg(
doublecomplex *, doublecomplex *);
/* Local variables */
extern /* Subroutine */ int zher2_(char *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
static integer i, j;
static doublecomplex alpha;
extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *),
zhemv_(char *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *), zaxpy_(integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
static doublecomplex wa, wb;
static doublereal wn;
extern /* Subroutine */ int xerbla_(char *, integer *), zlarnv_(
integer *, integer *, integer *, doublecomplex *);
static doublecomplex 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
=======
ZLAGHE generates a complex hermitian matrix A, by pre- and post-
multiplying a real diagonal matrix D with a random unitary matrix:
A = U*D*U'. 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) DOUBLE PRECISION array, dimension (N)
The diagonal elements of the diagonal matrix D.
A (output) COMPLEX*16 array, dimension (LDA,N)
The generated n by n hermitian 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*16 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_("ZLAGHE", &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., a[i__3].i = 0.;
/* 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.;
/* L30: */
}
/* Generate lower triangle of hermitian matrix */
for (i = *n - 1; i >= 1; --i) {
/* generate random reflection */
i__1 = *n - i + 1;
zlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *n - i + 1;
wn = dznrm2_(&i__1, &work[1], &c__1);
d__1 = wn / z_abs(&work[1]);
z__1.r = d__1 * work[1].r, z__1.i = d__1 * work[1].i;
wa.r = z__1.r, wa.i = z__1.i;
if (wn == 0.) {
tau.r = 0., tau.i = 0.;
} else {
z__1.r = work[1].r + wa.r, z__1.i = work[1].i + wa.i;
wb.r = z__1.r, wb.i = z__1.i;
i__1 = *n - i;
z_div(&z__1, &c_b2, &wb);
zscal_(&i__1, &z__1, &work[2], &c__1);
work[1].r = 1., work[1].i = 0.;
z_div(&z__1, &wb, &wa);
d__1 = z__1.r;
tau.r = d__1, tau.i = 0.;
}
/* apply random reflection to A(i:n,i:n) from the left
and the right
compute y := tau * A * u */
i__1 = *n - i + 1;
zhemv_("Lower", &i__1, &tau, &a[i + i * a_dim1], lda, &work[1], &c__1,
&c_b1, &work[*n + 1], &c__1);
/* compute v := y - 1/2 * tau * ( y, u ) * u */
z__3.r = -.5, z__3.i = 0.;
z__2.r = z__3.r * tau.r - z__3.i * tau.i, z__2.i = z__3.r * tau.i +
z__3.i * tau.r;
i__1 = *n - i + 1;
zdotc_(&z__4, &i__1, &work[*n + 1], &c__1, &work[1], &c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * z__4.i
+ z__2.i * z__4.r;
alpha.r = z__1.r, alpha.i = z__1.i;
i__1 = *n - i + 1;
zaxpy_(&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) */
i__1 = *n - i + 1;
z__1.r = -1., z__1.i = 0.;
zher2_("Lower", &i__1, &z__1, &work[1], &c__1, &work[*n + 1], &c__1, &
a[i + i * a_dim1], lda);
/* L40: */
}
/* 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 = dznrm2_(&i__2, &a[*k + i + i * a_dim1], &c__1);
d__1 = wn / z_abs(&a[*k + i + i * a_dim1]);
i__2 = *k + i + i * a_dim1;
z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i;
wa.r = z__1.r, wa.i = z__1.i;
if (wn == 0.) {
tau.r = 0., tau.i = 0.;
} else {
i__2 = *k + i + i * a_dim1;
z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i;
wb.r = z__1.r, wb.i = z__1.i;
i__2 = *n - *k - i;
z_div(&z__1, &c_b2, &wb);
zscal_(&i__2, &z__1, &a[*k + i + 1 + i * a_dim1], &c__1);
i__2 = *k + i + i * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
z_div(&z__1, &wb, &wa);
d__1 = z__1.r;
tau.r = d__1, tau.i = 0.;
}
/* 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;
zgemv_("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;
z__1.r = -tau.r, z__1.i = -tau.i;
zgerc_(&i__2, &i__3, &z__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 * u */
i__2 = *n - *k - i + 1;
zhemv_("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);
/* compute v := y - 1/2 * tau * ( y, u ) * u */
z__3.r = -.5, z__3.i = 0.;
z__2.r = z__3.r * tau.r - z__3.i * tau.i, z__2.i = z__3.r * tau.i +
z__3.i * tau.r;
i__2 = *n - *k - i + 1;
zdotc_(&z__4, &i__2, &work[1], &c__1, &a[*k + i + i * a_dim1], &c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * z__4.i
+ z__2.i * z__4.r;
alpha.r = z__1.r, alpha.i = z__1.i;
i__2 = *n - *k - i + 1;
zaxpy_(&i__2, &alpha, &a[*k + i + i * a_dim1], &c__1, &work[1], &c__1)
;
/* apply hermitian rank-2 update to A(k+i:n,k+i:n) */
i__2 = *n - *k - i + 1;
z__1.r = -1., z__1.i = 0.;
zher2_("Lower", &i__2, &z__1, &a[*k + i + i * a_dim1], &c__1, &work[1]
, &c__1, &a[*k + i + (*k + i) * a_dim1], lda);
i__2 = *k + i + i * a_dim1;
z__1.r = -wa.r, z__1.i = -wa.i;
a[i__2].r = z__1.r, a[i__2].i = z__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., a[i__3].i = 0.;
/* L50: */
}
/* L60: */
}
/* Store full hermitian 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;
d_cnjg(&z__1, &a[i + j * a_dim1]);
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L70: */
}
/* L80: */
}
return 0;
/* End of ZLAGHE */
} /* zlaghe_ */
/* Subroutine */ int zlahef_(char *uplo, integer *n, integer *nb, integer *kb,
doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *w,
integer *ldw, 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
=======
ZLAHEF computes a partial factorization of a complex Hermitian
matrix A using the Bunch-Kaufman diagonal pivoting method. The
partial factorization has the form:
A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
( 0 U22 ) ( 0 D ) ( U12' U22' )
A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L'
( L21 I ) ( 0 A22 ) ( 0 I )
where the order of D is at most NB. The actual order is returned in
the argument KB, and is either NB or NB-1, or N if N <= NB.
Note that U' denotes the conjugate transpose of U.
ZLAHEF is an auxiliary routine called by ZHETRF. It uses blocked code
(calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or
A22 (if UPLO = 'L').
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.
NB (input) INTEGER
The maximum number of columns of the matrix A that should be
factored. NB should be at least 2 to allow for 2-by-2 pivot
blocks.
KB (output) INTEGER
The number of columns of A that were actually factored.
KB is either NB-1 or NB, or N if N <= NB.
A (input/output) COMPLEX*16 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, A contains details of the partial factorization.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
IPIV (output) INTEGER array, dimension (N)
Details of the interchanges and the block structure of D.
If UPLO = 'U', only the last KB elements of IPIV are set;
if UPLO = 'L', only the first KB elements are set.
If IPIV(k) > 0, then rows and columns k and IPIV(k) were
interchanged and D(k,k) is a 1-by-1 diagonal block.
If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
W (workspace) COMPLEX*16 array, dimension (LDW,NB)
LDW (input) INTEGER
The leading dimension of the array W. LDW >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
> 0: if INFO = k, D(k,k) is exactly zero. The factorization
has been completed, but the block diagonal matrix D is
exactly singular.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b1 = {1.,0.};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double sqrt(doublereal), d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *), z_div(doublecomplex *,
doublecomplex *, doublecomplex *);
/* Local variables */
static integer imax, jmax, j, k;
static doublereal t, alpha;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
static integer kstep;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static doublereal r1;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zswap_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *);
static doublecomplex d11, d21, d22;
static integer jb, jj, kk, jp, kp;
static doublereal absakk;
static integer kw;
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *);
static doublereal colmax;
extern /* Subroutine */ int zlacgv_(integer *, doublecomplex *, integer *)
;
extern integer izamax_(integer *, doublecomplex *, integer *);
static doublereal rowmax;
static integer kkw;
#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 w_subscr(a_1,a_2) (a_2)*w_dim1 + a_1
#define w_ref(a_1,a_2) w[w_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--ipiv;
w_dim1 = *ldw;
w_offset = 1 + w_dim1 * 1;
w -= w_offset;
/* Function Body */
*info = 0;
/* Initialize ALPHA for use in choosing pivot block size. */
alpha = (sqrt(17.) + 1.) / 8.;
if (lsame_(uplo, "U")) {
/* Factorize the trailing columns of A using the upper triangle
of A and working backwards, and compute the matrix W = U12*D
for use in updating A11 (note that conjg(W) is actually stored)
K is the main loop index, decreasing from N in steps of 1 or 2
KW is the column of W which corresponds to column K of A */
k = *n;
L10:
kw = *nb + k - *n;
/* Exit from loop */
if (k <= *n - *nb + 1 && *nb < *n || k < 1) {
goto L30;
}
/* Copy column K of A to column KW of W and update it */
i__1 = k - 1;
zcopy_(&i__1, &a_ref(1, k), &c__1, &w_ref(1, kw), &c__1);
i__1 = w_subscr(k, kw);
i__2 = a_subscr(k, k);
d__1 = a[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
if (k < *n) {
i__1 = *n - k;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &k, &i__1, &z__1, &a_ref(1, k + 1), lda, &
w_ref(k, kw + 1), ldw, &c_b1, &w_ref(1, kw), &c__1);
i__1 = w_subscr(k, kw);
i__2 = w_subscr(k, kw);
d__1 = w[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
}
kstep = 1;
/* Determine rows and columns to be interchanged and whether
a 1-by-1 or 2-by-2 pivot block will be used */
i__1 = w_subscr(k, kw);
absakk = (d__1 = w[i__1].r, abs(d__1));
/* IMAX is the row-index of the largest off-diagonal element in
column K, and COLMAX is its absolute value */
if (k > 1) {
i__1 = k - 1;
imax = izamax_(&i__1, &w_ref(1, kw), &c__1);
i__1 = w_subscr(imax, kw);
colmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w_ref(
imax, kw)), abs(d__2));
} else {
colmax = 0.;
}
if (max(absakk,colmax) == 0.) {
/* Column K is zero: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
i__1 = a_subscr(k, k);
i__2 = a_subscr(k, k);
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
} else {
if (absakk >= alpha * colmax) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else {
/* Copy column IMAX to column KW-1 of W and update it */
i__1 = imax - 1;
zcopy_(&i__1, &a_ref(1, imax), &c__1, &w_ref(1, kw - 1), &
c__1);
i__1 = w_subscr(imax, kw - 1);
i__2 = a_subscr(imax, imax);
d__1 = a[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
i__1 = k - imax;
zcopy_(&i__1, &a_ref(imax, imax + 1), lda, &w_ref(imax + 1,
kw - 1), &c__1);
i__1 = k - imax;
zlacgv_(&i__1, &w_ref(imax + 1, kw - 1), &c__1);
if (k < *n) {
i__1 = *n - k;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &k, &i__1, &z__1, &a_ref(1, k + 1),
lda, &w_ref(imax, kw + 1), ldw, &c_b1, &w_ref(1,
kw - 1), &c__1);
i__1 = w_subscr(imax, kw - 1);
i__2 = w_subscr(imax, kw - 1);
d__1 = w[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
}
/* JMAX is the column-index of the largest off-diagonal
element in row IMAX, and ROWMAX is its absolute value */
i__1 = k - imax;
jmax = imax + izamax_(&i__1, &w_ref(imax + 1, kw - 1), &c__1);
i__1 = w_subscr(jmax, kw - 1);
rowmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&
w_ref(jmax, kw - 1)), abs(d__2));
if (imax > 1) {
i__1 = imax - 1;
jmax = izamax_(&i__1, &w_ref(1, kw - 1), &c__1);
/* Computing MAX */
i__1 = w_subscr(jmax, kw - 1);
d__3 = rowmax, d__4 = (d__1 = w[i__1].r, abs(d__1)) + (
d__2 = d_imag(&w_ref(jmax, kw - 1)), abs(d__2));
rowmax = max(d__3,d__4);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else /* if(complicated condition) */ {
i__1 = w_subscr(imax, kw - 1);
if ((d__1 = w[i__1].r, abs(d__1)) >= alpha * rowmax) {
/* interchange rows and columns K and IMAX, use 1-by-1
pivot block */
kp = imax;
/* copy column KW-1 of W to column KW */
zcopy_(&k, &w_ref(1, kw - 1), &c__1, &w_ref(1, kw), &
c__1);
} else {
/* interchange rows and columns K-1 and IMAX, use 2-by-2
pivot block */
kp = imax;
kstep = 2;
}
}
}
kk = k - kstep + 1;
kkw = *nb + kk - *n;
/* Updated column KP is already stored in column KKW of W */
if (kp != kk) {
/* Copy non-updated column KK to column KP */
i__1 = a_subscr(kp, kp);
i__2 = a_subscr(kk, kk);
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = kk - 1 - kp;
zcopy_(&i__1, &a_ref(kp + 1, kk), &c__1, &a_ref(kp, kp + 1),
lda);
i__1 = kk - 1 - kp;
zlacgv_(&i__1, &a_ref(kp, kp + 1), lda);
i__1 = kp - 1;
zcopy_(&i__1, &a_ref(1, kk), &c__1, &a_ref(1, kp), &c__1);
/* Interchange rows KK and KP in last KK columns of A and W */
if (kk < *n) {
i__1 = *n - kk;
zswap_(&i__1, &a_ref(kk, kk + 1), lda, &a_ref(kp, kk + 1),
lda);
}
i__1 = *n - kk + 1;
zswap_(&i__1, &w_ref(kk, kkw), ldw, &w_ref(kp, kkw), ldw);
}
if (kstep == 1) {
/* 1-by-1 pivot block D(k): column KW of W now holds
W(k) = U(k)*D(k)
where U(k) is the k-th column of U
Store U(k) in column k of A */
zcopy_(&k, &w_ref(1, kw), &c__1, &a_ref(1, k), &c__1);
i__1 = a_subscr(k, k);
r1 = 1. / a[i__1].r;
i__1 = k - 1;
zdscal_(&i__1, &r1, &a_ref(1, k), &c__1);
/* Conjugate W(k) */
i__1 = k - 1;
zlacgv_(&i__1, &w_ref(1, kw), &c__1);
} else {
/* 2-by-2 pivot block D(k): columns KW and KW-1 of W now
hold
( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
where U(k) and U(k-1) are the k-th and (k-1)-th columns
of U */
if (k > 2) {
/* Store U(k) and U(k-1) in columns k and k-1 of A */
i__1 = w_subscr(k - 1, kw);
d21.r = w[i__1].r, d21.i = w[i__1].i;
d_cnjg(&z__2, &d21);
z_div(&z__1, &w_ref(k, kw), &z__2);
d11.r = z__1.r, d11.i = z__1.i;
z_div(&z__1, &w_ref(k - 1, kw - 1), &d21);
d22.r = z__1.r, d22.i = z__1.i;
z__1.r = d11.r * d22.r - d11.i * d22.i, z__1.i = d11.r *
d22.i + d11.i * d22.r;
t = 1. / (z__1.r - 1.);
z__2.r = t, z__2.i = 0.;
z_div(&z__1, &z__2, &d21);
d21.r = z__1.r, d21.i = z__1.i;
i__1 = k - 2;
for (j = 1; j <= i__1; ++j) {
i__2 = a_subscr(j, k - 1);
i__3 = w_subscr(j, kw - 1);
z__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i,
z__3.i = d11.r * w[i__3].i + d11.i * w[i__3]
.r;
i__4 = w_subscr(j, kw);
z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4]
.i;
z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i =
d21.r * z__2.i + d21.i * z__2.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = a_subscr(j, k);
d_cnjg(&z__2, &d21);
i__3 = w_subscr(j, kw);
z__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i,
z__4.i = d22.r * w[i__3].i + d22.i * w[i__3]
.r;
i__4 = w_subscr(j, kw - 1);
z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4]
.i;
z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i =
z__2.r * z__3.i + z__2.i * z__3.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L20: */
}
}
/* Copy D(k) to A */
i__1 = a_subscr(k - 1, k - 1);
i__2 = w_subscr(k - 1, kw - 1);
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = a_subscr(k - 1, k);
i__2 = w_subscr(k - 1, kw);
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = a_subscr(k, k);
i__2 = w_subscr(k, kw);
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
/* Conjugate W(k) and W(k-1) */
i__1 = k - 1;
zlacgv_(&i__1, &w_ref(1, kw), &c__1);
i__1 = k - 2;
zlacgv_(&i__1, &w_ref(1, kw - 1), &c__1);
}
}
/* Store details of the interchanges in IPIV */
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k - 1] = -kp;
}
/* Decrease K and return to the start of the main loop */
k -= kstep;
goto L10;
L30:
/* Update the upper triangle of A11 (= A(1:k,1:k)) as
A11 := A11 - U12*D*U12' = A11 - U12*W'
computing blocks of NB columns at a time (note that conjg(W) is
actually stored) */
i__1 = -(*nb);
for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j +=
i__1) {
/* Computing MIN */
i__2 = *nb, i__3 = k - j + 1;
jb = min(i__2,i__3);
/* Update the upper triangle of the diagonal block */
i__2 = j + jb - 1;
for (jj = j; jj <= i__2; ++jj) {
i__3 = a_subscr(jj, jj);
i__4 = a_subscr(jj, jj);
d__1 = a[i__4].r;
a[i__3].r = d__1, a[i__3].i = 0.;
i__3 = jj - j + 1;
i__4 = *n - k;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__3, &i__4, &z__1, &a_ref(j, k + 1),
lda, &w_ref(jj, kw + 1), ldw, &c_b1, &a_ref(j, jj), &
c__1);
i__3 = a_subscr(jj, jj);
i__4 = a_subscr(jj, jj);
d__1 = a[i__4].r;
a[i__3].r = d__1, a[i__3].i = 0.;
/* L40: */
}
/* Update the rectangular superdiagonal block */
i__2 = j - 1;
i__3 = *n - k;
z__1.r = -1., z__1.i = 0.;
zgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &z__1, &
a_ref(1, k + 1), lda, &w_ref(j, kw + 1), ldw, &c_b1, &
a_ref(1, j), lda);
/* L50: */
}
/* Put U12 in standard form by partially undoing the interchanges
in columns k+1:n */
j = k + 1;
L60:
jj = j;
jp = ipiv[j];
if (jp < 0) {
jp = -jp;
++j;
}
++j;
if (jp != jj && j <= *n) {
i__1 = *n - j + 1;
zswap_(&i__1, &a_ref(jp, j), lda, &a_ref(jj, j), lda);
}
if (j <= *n) {
goto L60;
}
/* Set KB to the number of columns factorized */
*kb = *n - k;
} else {
/* Factorize the leading columns of A using the lower triangle
of A and working forwards, and compute the matrix W = L21*D
for use in updating A22 (note that conjg(W) is actually stored)
K is the main loop index, increasing from 1 in steps of 1 or 2 */
k = 1;
L70:
/* Exit from loop */
if (k >= *nb && *nb < *n || k > *n) {
goto L90;
}
/* Copy column K of A to column K of W and update it */
i__1 = w_subscr(k, k);
i__2 = a_subscr(k, k);
d__1 = a[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
if (k < *n) {
i__1 = *n - k;
zcopy_(&i__1, &a_ref(k + 1, k), &c__1, &w_ref(k + 1, k), &c__1);
}
i__1 = *n - k + 1;
i__2 = k - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__1, &i__2, &z__1, &a_ref(k, 1), lda, &w_ref(
k, 1), ldw, &c_b1, &w_ref(k, k), &c__1);
i__1 = w_subscr(k, k);
i__2 = w_subscr(k, k);
d__1 = w[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
kstep = 1;
/* Determine rows and columns to be interchanged and whether
a 1-by-1 or 2-by-2 pivot block will be used */
i__1 = w_subscr(k, k);
absakk = (d__1 = w[i__1].r, abs(d__1));
/* IMAX is the row-index of the largest off-diagonal element in
column K, and COLMAX is its absolute value */
if (k < *n) {
i__1 = *n - k;
imax = k + izamax_(&i__1, &w_ref(k + 1, k), &c__1);
i__1 = w_subscr(imax, k);
colmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w_ref(
imax, k)), abs(d__2));
} else {
colmax = 0.;
}
if (max(absakk,colmax) == 0.) {
/* Column K is zero: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
i__1 = a_subscr(k, k);
i__2 = a_subscr(k, k);
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
} else {
if (absakk >= alpha * colmax) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else {
/* Copy column IMAX to column K+1 of W and update it */
i__1 = imax - k;
zcopy_(&i__1, &a_ref(imax, k), lda, &w_ref(k, k + 1), &c__1);
i__1 = imax - k;
zlacgv_(&i__1, &w_ref(k, k + 1), &c__1);
i__1 = w_subscr(imax, k + 1);
i__2 = a_subscr(imax, imax);
d__1 = a[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
if (imax < *n) {
i__1 = *n - imax;
zcopy_(&i__1, &a_ref(imax + 1, imax), &c__1, &w_ref(imax
+ 1, k + 1), &c__1);
}
i__1 = *n - k + 1;
i__2 = k - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__1, &i__2, &z__1, &a_ref(k, 1), lda,
&w_ref(imax, 1), ldw, &c_b1, &w_ref(k, k + 1), &c__1);
i__1 = w_subscr(imax, k + 1);
i__2 = w_subscr(imax, k + 1);
d__1 = w[i__2].r;
w[i__1].r = d__1, w[i__1].i = 0.;
/* JMAX is the column-index of the largest off-diagonal
element in row IMAX, and ROWMAX is its absolute value */
i__1 = imax - k;
jmax = k - 1 + izamax_(&i__1, &w_ref(k, k + 1), &c__1);
i__1 = w_subscr(jmax, k + 1);
rowmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&
w_ref(jmax, k + 1)), abs(d__2));
if (imax < *n) {
i__1 = *n - imax;
jmax = imax + izamax_(&i__1, &w_ref(imax + 1, k + 1), &
c__1);
/* Computing MAX */
i__1 = w_subscr(jmax, k + 1);
d__3 = rowmax, d__4 = (d__1 = w[i__1].r, abs(d__1)) + (
d__2 = d_imag(&w_ref(jmax, k + 1)), abs(d__2));
rowmax = max(d__3,d__4);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else /* if(complicated condition) */ {
i__1 = w_subscr(imax, k + 1);
if ((d__1 = w[i__1].r, abs(d__1)) >= alpha * rowmax) {
/* interchange rows and columns K and IMAX, use 1-by-1
pivot block */
kp = imax;
/* copy column K+1 of W to column K */
i__1 = *n - k + 1;
zcopy_(&i__1, &w_ref(k, k + 1), &c__1, &w_ref(k, k), &
c__1);
} else {
/* interchange rows and columns K+1 and IMAX, use 2-by-2
pivot block */
kp = imax;
kstep = 2;
}
}
}
kk = k + kstep - 1;
/* Updated column KP is already stored in column KK of W */
if (kp != kk) {
/* Copy non-updated column KK to column KP */
i__1 = a_subscr(kp, kp);
i__2 = a_subscr(kk, kk);
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = kp - kk - 1;
zcopy_(&i__1, &a_ref(kk + 1, kk), &c__1, &a_ref(kp, kk + 1),
lda);
i__1 = kp - kk - 1;
zlacgv_(&i__1, &a_ref(kp, kk + 1), lda);
if (kp < *n) {
i__1 = *n - kp;
zcopy_(&i__1, &a_ref(kp + 1, kk), &c__1, &a_ref(kp + 1,
kp), &c__1);
}
/* Interchange rows KK and KP in first KK columns of A and W */
i__1 = kk - 1;
zswap_(&i__1, &a_ref(kk, 1), lda, &a_ref(kp, 1), lda);
zswap_(&kk, &w_ref(kk, 1), ldw, &w_ref(kp, 1), ldw);
}
if (kstep == 1) {
/* 1-by-1 pivot block D(k): column k of W now holds
W(k) = L(k)*D(k)
where L(k) is the k-th column of L
Store L(k) in column k of A */
i__1 = *n - k + 1;
zcopy_(&i__1, &w_ref(k, k), &c__1, &a_ref(k, k), &c__1);
if (k < *n) {
i__1 = a_subscr(k, k);
r1 = 1. / a[i__1].r;
i__1 = *n - k;
zdscal_(&i__1, &r1, &a_ref(k + 1, k), &c__1);
/* Conjugate W(k) */
i__1 = *n - k;
zlacgv_(&i__1, &w_ref(k + 1, k), &c__1);
}
} else {
/* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
where L(k) and L(k+1) are the k-th and (k+1)-th columns
of L */
if (k < *n - 1) {
/* Store L(k) and L(k+1) in columns k and k+1 of A */
i__1 = w_subscr(k + 1, k);
d21.r = w[i__1].r, d21.i = w[i__1].i;
z_div(&z__1, &w_ref(k + 1, k + 1), &d21);
d11.r = z__1.r, d11.i = z__1.i;
d_cnjg(&z__2, &d21);
z_div(&z__1, &w_ref(k, k), &z__2);
d22.r = z__1.r, d22.i = z__1.i;
z__1.r = d11.r * d22.r - d11.i * d22.i, z__1.i = d11.r *
d22.i + d11.i * d22.r;
t = 1. / (z__1.r - 1.);
z__2.r = t, z__2.i = 0.;
z_div(&z__1, &z__2, &d21);
d21.r = z__1.r, d21.i = z__1.i;
i__1 = *n;
for (j = k + 2; j <= i__1; ++j) {
i__2 = a_subscr(j, k);
d_cnjg(&z__2, &d21);
i__3 = w_subscr(j, k);
z__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i,
z__4.i = d11.r * w[i__3].i + d11.i * w[i__3]
.r;
i__4 = w_subscr(j, k + 1);
z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4]
.i;
z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i =
z__2.r * z__3.i + z__2.i * z__3.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = a_subscr(j, k + 1);
i__3 = w_subscr(j, k + 1);
z__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i,
z__3.i = d22.r * w[i__3].i + d22.i * w[i__3]
.r;
i__4 = w_subscr(j, k);
z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4]
.i;
z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i =
d21.r * z__2.i + d21.i * z__2.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L80: */
}
}
/* Copy D(k) to A */
i__1 = a_subscr(k, k);
i__2 = w_subscr(k, k);
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = a_subscr(k + 1, k);
i__2 = w_subscr(k + 1, k);
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = a_subscr(k + 1, k + 1);
i__2 = w_subscr(k + 1, k + 1);
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
/* Conjugate W(k) and W(k+1) */
i__1 = *n - k;
zlacgv_(&i__1, &w_ref(k + 1, k), &c__1);
i__1 = *n - k - 1;
zlacgv_(&i__1, &w_ref(k + 2, k + 1), &c__1);
}
}
/* Store details of the interchanges in IPIV */
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k + 1] = -kp;
}
/* Increase K and return to the start of the main loop */
k += kstep;
goto L70;
L90:
/* Update the lower triangle of A22 (= A(k:n,k:n)) as
A22 := A22 - L21*D*L21' = A22 - L21*W'
computing blocks of NB columns at a time (note that conjg(W) is
actually stored) */
i__1 = *n;
i__2 = *nb;
for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Computing MIN */
i__3 = *nb, i__4 = *n - j + 1;
jb = min(i__3,i__4);
/* Update the lower triangle of the diagonal block */
i__3 = j + jb - 1;
for (jj = j; jj <= i__3; ++jj) {
i__4 = a_subscr(jj, jj);
i__5 = a_subscr(jj, jj);
d__1 = a[i__5].r;
a[i__4].r = d__1, a[i__4].i = 0.;
i__4 = j + jb - jj;
i__5 = k - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("No transpose", &i__4, &i__5, &z__1, &a_ref(jj, 1),
lda, &w_ref(jj, 1), ldw, &c_b1, &a_ref(jj, jj), &c__1);
i__4 = a_subscr(jj, jj);
i__5 = a_subscr(jj, jj);
d__1 = a[i__5].r;
a[i__4].r = d__1, a[i__4].i = 0.;
/* L100: */
}
/* Update the rectangular subdiagonal block */
if (j + jb <= *n) {
i__3 = *n - j - jb + 1;
i__4 = k - 1;
z__1.r = -1., z__1.i = 0.;
zgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &z__1,
&a_ref(j + jb, 1), lda, &w_ref(j, 1), ldw, &c_b1, &
a_ref(j + jb, j), lda);
}
/* L110: */
}
/* Put L21 in standard form by partially undoing the interchanges
in columns 1:k-1 */
j = k - 1;
L120:
jj = j;
jp = ipiv[j];
if (jp < 0) {
jp = -jp;
--j;
}
--j;
if (jp != jj && j >= 1) {
zswap_(&j, &a_ref(jp, 1), lda, &a_ref(jj, 1), lda);
}
if (j >= 1) {
goto L120;
}
/* Set KB to the number of columns factorized */
*kb = k - 1;
}
return 0;
/* End of ZLAHEF */
} /* zlahef_ */
doublereal zla_gbrcond_x__(char *trans, integer *n, integer *kl, integer *ku,
doublecomplex *ab, integer *ldab, doublecomplex *afb, integer *ldafb,
integer *ipiv, doublecomplex *x, integer *info, doublecomplex *work,
doublereal *rwork, ftnlen trans_len)
{
/* System generated locals */
integer ab_dim1, ab_offset, afb_dim1, afb_offset, i__1, i__2, i__3, i__4;
doublereal ret_val, d__1, d__2;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j, kd, ke;
doublereal tmp;
integer kase;
extern logical lsame_(char *, char *);
integer isave[3];
doublereal anorm;
extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *,
doublecomplex *, doublereal *, integer *, integer *), xerbla_(
char *, integer *);
doublereal ainvnm;
extern /* Subroutine */ int zgbtrs_(char *, integer *, integer *, integer
*, integer *, doublecomplex *, integer *, integer *,
doublecomplex *, integer *, integer *);
logical notrans;
/* -- LAPACK routine (version 3.2.1) -- */
/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
/* -- Jason Riedy of Univ. of California Berkeley. -- */
/* -- April 2009 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley and NAG Ltd. -- */
/* .. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* Purpose */
/* ======= */
/* ZLA_GBRCOND_X Computes the infinity norm condition number of */
/* op(A) * diag(X) where X is a COMPLEX*16 vector. */
/* Arguments */
/* ========= */
/* TRANS (input) CHARACTER*1 */
/* Specifies the form of the system of equations: */
/* = 'N': A * X = B (No transpose) */
/* = 'T': A**T * X = B (Transpose) */
/* = 'C': A**H * X = B (Conjugate Transpose = Transpose) */
/* N (input) INTEGER */
/* The number of linear equations, i.e., the order of the */
/* matrix A. N >= 0. */
/* KL (input) INTEGER */
/* The number of subdiagonals within the band of A. KL >= 0. */
/* KU (input) INTEGER */
/* The number of superdiagonals within the band of A. KU >= 0. */
/* AB (input) COMPLEX*16 array, dimension (LDAB,N) */
/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */
/* The j-th column of A is stored in the j-th column of the */
/* array AB as follows: */
/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
/* AFB (input) COMPLEX*16 array, dimension (LDAFB,N) */
/* Details of the LU factorization of the band matrix A, as */
/* computed by ZGBTRF. U is stored as an upper triangular */
/* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */
/* and the multipliers used during the factorization are stored */
/* in rows KL+KU+2 to 2*KL+KU+1. */
/* LDAFB (input) INTEGER */
/* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices from the factorization A = P*L*U */
/* as computed by ZGBTRF; row i of the matrix was interchanged */
/* with row IPIV(i). */
/* X (input) COMPLEX*16 array, dimension (N) */
/* The vector X in the formula op(A) * diag(X). */
/* INFO (output) INTEGER */
/* = 0: Successful exit. */
/* i > 0: The ith argument is invalid. */
/* WORK (input) COMPLEX*16 array, dimension (2*N). */
/* Workspace. */
/* RWORK (input) DOUBLE PRECISION array, dimension (N). */
/* Workspace. */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function Definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
afb_dim1 = *ldafb;
afb_offset = 1 + afb_dim1;
afb -= afb_offset;
--ipiv;
--x;
--work;
--rwork;
/* Function Body */
ret_val = 0.;
*info = 0;
notrans = lsame_(trans, "N");
if (! notrans && ! lsame_(trans, "T") && ! lsame_(
trans, "C")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kl < 0 || *kl > *n - 1) {
*info = -3;
} else if (*ku < 0 || *ku > *n - 1) {
*info = -4;
} else if (*ldab < *kl + *ku + 1) {
*info = -6;
} else if (*ldafb < (*kl << 1) + *ku + 1) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZLA_GBRCOND_X", &i__1);
return ret_val;
}
/* Compute norm of op(A)*op2(C). */
kd = *ku + 1;
ke = *kl + 1;
anorm = 0.;
if (notrans) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
tmp = 0.;
/* Computing MAX */
i__2 = i__ - *kl;
/* Computing MIN */
i__4 = i__ + *ku;
i__3 = min(i__4,*n);
for (j = max(i__2,1); j <= i__3; ++j) {
i__2 = kd + i__ - j + j * ab_dim1;
i__4 = j;
z__2.r = ab[i__2].r * x[i__4].r - ab[i__2].i * x[i__4].i,
z__2.i = ab[i__2].r * x[i__4].i + ab[i__2].i * x[i__4]
.r;
z__1.r = z__2.r, z__1.i = z__2.i;
tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1),
abs(d__2));
}
rwork[i__] = tmp;
anorm = max(anorm,tmp);
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
tmp = 0.;
/* Computing MAX */
i__3 = i__ - *kl;
/* Computing MIN */
i__4 = i__ + *ku;
i__2 = min(i__4,*n);
for (j = max(i__3,1); j <= i__2; ++j) {
i__3 = ke - i__ + j + i__ * ab_dim1;
i__4 = j;
z__2.r = ab[i__3].r * x[i__4].r - ab[i__3].i * x[i__4].i,
z__2.i = ab[i__3].r * x[i__4].i + ab[i__3].i * x[i__4]
.r;
z__1.r = z__2.r, z__1.i = z__2.i;
tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1),
abs(d__2));
}
rwork[i__] = tmp;
anorm = max(anorm,tmp);
}
}
/* Quick return if possible. */
if (*n == 0) {
ret_val = 1.;
return ret_val;
} else if (anorm == 0.) {
return ret_val;
}
/* Estimate the norm of inv(op(A)). */
ainvnm = 0.;
kase = 0;
L10:
zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
if (kase != 0) {
if (kase == 2) {
/* Multiply by R. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__;
i__4 = i__;
z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] *
work[i__3].i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
}
if (notrans) {
zgbtrs_("No transpose", n, kl, ku, &c__1, &afb[afb_offset],
ldafb, &ipiv[1], &work[1], n, info);
} else {
zgbtrs_("Conjugate transpose", n, kl, ku, &c__1, &afb[
afb_offset], ldafb, &ipiv[1], &work[1], n, info);
}
/* Multiply by inv(X). */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
z_div(&z__1, &work[i__], &x[i__]);
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
}
} else {
/* Multiply by inv(X'). */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
z_div(&z__1, &work[i__], &x[i__]);
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
}
if (notrans) {
zgbtrs_("Conjugate transpose", n, kl, ku, &c__1, &afb[
afb_offset], ldafb, &ipiv[1], &work[1], n, info);
} else {
zgbtrs_("No transpose", n, kl, ku, &c__1, &afb[afb_offset],
ldafb, &ipiv[1], &work[1], n, info);
}
/* Multiply by R. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__;
i__4 = i__;
z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] *
work[i__3].i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
}
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.) {
ret_val = 1. / ainvnm;
}
return ret_val;
} /* zla_gbrcond_x__ */
/* Subroutine */ int zlatdf_(integer *ijob, integer *n, doublecomplex *z__,
integer *ldz, doublecomplex *rhs, doublereal *rdsum, doublereal *
rdscal, integer *ipiv, integer *jpiv)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
double z_abs(doublecomplex *);
void z_sqrt(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j, k;
doublecomplex bm, bp, xm[2], xp[2];
integer info;
doublecomplex temp, work[8];
doublereal scale;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
doublecomplex pmone;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
doublereal rtemp, sminu, rwork[2];
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
doublereal splus;
extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *), zgesc2_(
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
integer *, doublereal *), zgecon_(char *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *,
doublecomplex *, doublereal *, integer *);
extern doublereal dzasum_(integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
doublereal *, doublereal *), zlaswp_(integer *, doublecomplex *,
integer *, integer *, integer *, integer *, integer *);
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLATDF computes the contribution to the reciprocal Dif-estimate */
/* by solving for x in Z * x = b, where b is chosen such that the norm */
/* of x is as large as possible. It is assumed that LU decomposition */
/* of Z has been computed by ZGETC2. On entry RHS = f holds the */
/* contribution from earlier solved sub-systems, and on return RHS = x. */
/* The factorization of Z returned by ZGETC2 has the form */
/* Z = P * L * U * Q, where P and Q are permutation matrices. L is lower */
/* triangular with unit diagonal elements and U is upper triangular. */
/* Arguments */
/* ========= */
/* IJOB (input) INTEGER */
/* IJOB = 2: First compute an approximative null-vector e */
/* of Z using ZGECON, e is normalized and solve for */
/* Zx = +-e - f with the sign giving the greater value of */
/* 2-norm(x). About 5 times as expensive as Default. */
/* IJOB .ne. 2: Local look ahead strategy where */
/* all entries of the r.h.s. b is choosen as either +1 or */
/* -1. Default. */
/* N (input) INTEGER */
/* The number of columns of the matrix Z. */
/* Z (input) DOUBLE PRECISION array, dimension (LDZ, N) */
/* On entry, the LU part of the factorization of the n-by-n */
/* matrix Z computed by ZGETC2: Z = P * L * U * Q */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDA >= max(1, N). */
/* RHS (input/output) DOUBLE PRECISION array, dimension (N). */
/* On entry, RHS contains contributions from other subsystems. */
/* On exit, RHS contains the solution of the subsystem with */
/* entries according to the value of IJOB (see above). */
/* RDSUM (input/output) DOUBLE PRECISION */
/* On entry, the sum of squares of computed contributions to */
/* the Dif-estimate under computation by ZTGSYL, where the */
/* scaling factor RDSCAL (see below) has been factored out. */
/* On exit, the corresponding sum of squares updated with the */
/* contributions from the current sub-system. */
/* If TRANS = 'T' RDSUM is not touched. */
/* NOTE: RDSUM only makes sense when ZTGSY2 is called by CTGSYL. */
/* RDSCAL (input/output) DOUBLE PRECISION */
/* On entry, scaling factor used to prevent overflow in RDSUM. */
/* On exit, RDSCAL is updated w.r.t. the current contributions */
/* in RDSUM. */
/* If TRANS = 'T', RDSCAL is not touched. */
/* NOTE: RDSCAL only makes sense when ZTGSY2 is called by */
/* ZTGSYL. */
/* IPIV (input) INTEGER array, dimension (N). */
/* The pivot indices; for 1 <= i <= N, row i of the */
/* matrix has been interchanged with row IPIV(i). */
/* JPIV (input) INTEGER array, dimension (N). */
/* The pivot indices; for 1 <= j <= N, column j of the */
/* matrix has been interchanged with column JPIV(j). */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
/* Umea University, S-901 87 Umea, Sweden. */
/* This routine is a further developed implementation of algorithm */
/* BSOLVE in [1] using complete pivoting in the LU factorization. */
/* [1] Bo Kagstrom and Lars Westin, */
/* Generalized Schur Methods with Condition Estimators for */
/* Solving the Generalized Sylvester Equation, IEEE Transactions */
/* on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751. */
/* [2] Peter Poromaa, */
/* On Efficient and Robust Estimators for the Separation */
/* between two Regular Matrix Pairs with Applications in */
/* Condition Estimation. Report UMINF-95.05, Department of */
/* Computing Science, Umea University, S-901 87 Umea, Sweden, */
/* 1995. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--rhs;
--ipiv;
--jpiv;
/* Function Body */
if (*ijob != 2) {
/* Apply permutations IPIV to RHS */
i__1 = *n - 1;
zlaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &ipiv[1], &c__1);
/* Solve for L-part choosing RHS either to +1 or -1. */
z__1.r = -1., z__1.i = -0.;
pmone.r = z__1.r, pmone.i = z__1.i;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
z__1.r = rhs[i__2].r + 1., z__1.i = rhs[i__2].i + 0.;
bp.r = z__1.r, bp.i = z__1.i;
i__2 = j;
z__1.r = rhs[i__2].r - 1., z__1.i = rhs[i__2].i - 0.;
bm.r = z__1.r, bm.i = z__1.i;
splus = 1.;
/* Lockahead for L- part RHS(1:N-1) = +-1 */
/* SPLUS and SMIN computed more efficiently than in BSOLVE[1]. */
i__2 = *n - j;
zdotc_(&z__1, &i__2, &z__[j + 1 + j * z_dim1], &c__1, &z__[j + 1
+ j * z_dim1], &c__1);
splus += z__1.r;
i__2 = *n - j;
zdotc_(&z__1, &i__2, &z__[j + 1 + j * z_dim1], &c__1, &rhs[j + 1],
&c__1);
sminu = z__1.r;
i__2 = j;
splus *= rhs[i__2].r;
if (splus > sminu) {
i__2 = j;
rhs[i__2].r = bp.r, rhs[i__2].i = bp.i;
} else if (sminu > splus) {
i__2 = j;
rhs[i__2].r = bm.r, rhs[i__2].i = bm.i;
} else {
/* In this case the updating sums are equal and we can */
/* choose RHS(J) +1 or -1. The first time this happens we */
/* choose -1, thereafter +1. This is a simple way to get */
/* good estimates of matrices like Byers well-known example */
/* (see [1]). (Not done in BSOLVE.) */
i__2 = j;
i__3 = j;
z__1.r = rhs[i__3].r + pmone.r, z__1.i = rhs[i__3].i +
pmone.i;
rhs[i__2].r = z__1.r, rhs[i__2].i = z__1.i;
pmone.r = 1., pmone.i = 0.;
}
/* Compute the remaining r.h.s. */
i__2 = j;
z__1.r = -rhs[i__2].r, z__1.i = -rhs[i__2].i;
temp.r = z__1.r, temp.i = z__1.i;
i__2 = *n - j;
zaxpy_(&i__2, &temp, &z__[j + 1 + j * z_dim1], &c__1, &rhs[j + 1],
&c__1);
/* L10: */
}
/* Solve for U- part, lockahead for RHS(N) = +-1. This is not done */
/* In BSOLVE and will hopefully give us a better estimate because */
/* any ill-conditioning of the original matrix is transfered to U */
/* and not to L. U(N, N) is an approximation to sigma_min(LU). */
i__1 = *n - 1;
zcopy_(&i__1, &rhs[1], &c__1, work, &c__1);
i__1 = *n - 1;
i__2 = *n;
z__1.r = rhs[i__2].r + 1., z__1.i = rhs[i__2].i + 0.;
work[i__1].r = z__1.r, work[i__1].i = z__1.i;
i__1 = *n;
i__2 = *n;
z__1.r = rhs[i__2].r - 1., z__1.i = rhs[i__2].i - 0.;
rhs[i__1].r = z__1.r, rhs[i__1].i = z__1.i;
splus = 0.;
sminu = 0.;
for (i__ = *n; i__ >= 1; --i__) {
z_div(&z__1, &c_b1, &z__[i__ + i__ * z_dim1]);
temp.r = z__1.r, temp.i = z__1.i;
i__1 = i__ - 1;
i__2 = i__ - 1;
z__1.r = work[i__2].r * temp.r - work[i__2].i * temp.i, z__1.i =
work[i__2].r * temp.i + work[i__2].i * temp.r;
work[i__1].r = z__1.r, work[i__1].i = z__1.i;
i__1 = i__;
i__2 = i__;
z__1.r = rhs[i__2].r * temp.r - rhs[i__2].i * temp.i, z__1.i =
rhs[i__2].r * temp.i + rhs[i__2].i * temp.r;
rhs[i__1].r = z__1.r, rhs[i__1].i = z__1.i;
i__1 = *n;
for (k = i__ + 1; k <= i__1; ++k) {
i__2 = i__ - 1;
i__3 = i__ - 1;
i__4 = k - 1;
i__5 = i__ + k * z_dim1;
z__3.r = z__[i__5].r * temp.r - z__[i__5].i * temp.i, z__3.i =
z__[i__5].r * temp.i + z__[i__5].i * temp.r;
z__2.r = work[i__4].r * z__3.r - work[i__4].i * z__3.i,
z__2.i = work[i__4].r * z__3.i + work[i__4].i *
z__3.r;
z__1.r = work[i__3].r - z__2.r, z__1.i = work[i__3].i -
z__2.i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
i__2 = i__;
i__3 = i__;
i__4 = k;
i__5 = i__ + k * z_dim1;
z__3.r = z__[i__5].r * temp.r - z__[i__5].i * temp.i, z__3.i =
z__[i__5].r * temp.i + z__[i__5].i * temp.r;
z__2.r = rhs[i__4].r * z__3.r - rhs[i__4].i * z__3.i, z__2.i =
rhs[i__4].r * z__3.i + rhs[i__4].i * z__3.r;
z__1.r = rhs[i__3].r - z__2.r, z__1.i = rhs[i__3].i - z__2.i;
rhs[i__2].r = z__1.r, rhs[i__2].i = z__1.i;
/* L20: */
}
splus += z_abs(&work[i__ - 1]);
sminu += z_abs(&rhs[i__]);
/* L30: */
}
if (splus > sminu) {
zcopy_(n, work, &c__1, &rhs[1], &c__1);
}
/* Apply the permutations JPIV to the computed solution (RHS) */
i__1 = *n - 1;
zlaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &jpiv[1], &c_n1);
/* Compute the sum of squares */
zlassq_(n, &rhs[1], &c__1, rdscal, rdsum);
return 0;
}
/* ENTRY IJOB = 2 */
/* Compute approximate nullvector XM of Z */
zgecon_("I", n, &z__[z_offset], ldz, &c_b24, &rtemp, work, rwork, &info);
zcopy_(n, &work[*n], &c__1, xm, &c__1);
/* Compute RHS */
i__1 = *n - 1;
zlaswp_(&c__1, xm, ldz, &c__1, &i__1, &ipiv[1], &c_n1);
zdotc_(&z__3, n, xm, &c__1, xm, &c__1);
z_sqrt(&z__2, &z__3);
z_div(&z__1, &c_b1, &z__2);
temp.r = z__1.r, temp.i = z__1.i;
zscal_(n, &temp, xm, &c__1);
zcopy_(n, xm, &c__1, xp, &c__1);
zaxpy_(n, &c_b1, &rhs[1], &c__1, xp, &c__1);
z__1.r = -1., z__1.i = -0.;
zaxpy_(n, &z__1, xm, &c__1, &rhs[1], &c__1);
zgesc2_(n, &z__[z_offset], ldz, &rhs[1], &ipiv[1], &jpiv[1], &scale);
zgesc2_(n, &z__[z_offset], ldz, xp, &ipiv[1], &jpiv[1], &scale);
if (dzasum_(n, xp, &c__1) > dzasum_(n, &rhs[1], &c__1)) {
zcopy_(n, xp, &c__1, &rhs[1], &c__1);
}
/* Compute the sum of squares */
zlassq_(n, &rhs[1], &c__1, rdscal, rdsum);
return 0;
/* End of ZLATDF */
} /* zlatdf_ */
/* Subroutine */ int zhgeqz_(char *job, char *compq, char *compz, integer *n,
integer *ilo, integer *ihi, doublecomplex *a, integer *lda,
doublecomplex *b, integer *ldb, doublecomplex *alpha, doublecomplex *
beta, doublecomplex *q, integer *ldq, doublecomplex *z__, integer *
ldz, doublecomplex *work, integer *lwork, doublereal *rwork, integer *
info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
z_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
/* Builtin functions */
double z_abs(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
double d_imag(doublecomplex *);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *), pow_zi(
doublecomplex *, doublecomplex *, integer *), z_sqrt(
doublecomplex *, doublecomplex *);
/* Local variables */
static doublereal absb, atol, btol, temp, opst;
extern /* Subroutine */ int zrot_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, doublecomplex *);
static doublereal temp2, c__;
static integer j;
static doublecomplex s, t;
extern logical lsame_(char *, char *);
static doublecomplex ctemp;
static integer iiter, ilast, jiter;
static doublereal anorm;
static integer maxit;
static doublereal bnorm;
static doublecomplex shift;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
static doublereal tempr;
static doublecomplex ctemp2, ctemp3;
static logical ilazr2;
static integer jc, in;
static doublereal ascale, bscale;
static doublecomplex u12;
extern doublereal dlamch_(char *);
static integer jr, nq;
static doublecomplex signbc;
static integer nz;
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublecomplex eshift;
static logical ilschr;
static integer icompq, ilastm;
static doublecomplex rtdisc;
static integer ischur;
extern doublereal zlanhs_(char *, integer *, doublecomplex *, integer *,
doublereal *);
static logical ilazro;
static integer icompz, ifirst;
extern /* Subroutine */ int zlartg_(doublecomplex *, doublecomplex *,
doublereal *, doublecomplex *, doublecomplex *);
static integer ifrstm;
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
static integer istart;
static logical lquery;
static doublecomplex ad11, ad12, ad21, ad22;
static integer jch;
static logical ilq, ilz;
static doublereal ulp;
static doublecomplex abi22;
#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 q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1
#define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)]
#define z___subscr(a_1,a_2) (a_2)*z_dim1 + a_1
#define z___ref(a_1,a_2) z__[z___subscr(a_1,a_2)]
/* -- LAPACK routine (instrumented to count operations, version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
----------------------- Begin Timing Code ------------------------
Common block to return operation count and iteration count
ITCNT is initialized to 0, OPS is only incremented
OPST is used to accumulate small contributions to OPS
to avoid roundoff error
------------------------ End Timing Code -------------------------
Purpose
=======
ZHGEQZ implements a single-shift version of the QZ
method for finding the generalized eigenvalues w(i)=ALPHA(i)/BETA(i)
of the equation
det( A - w(i) B ) = 0
If JOB='S', then the pair (A,B) is simultaneously
reduced to Schur form (i.e., A and B are both upper triangular) by
applying one unitary tranformation (usually called Q) on the left and
another (usually called Z) on the right. The diagonal elements of
A are then ALPHA(1),...,ALPHA(N), and of B are BETA(1),...,BETA(N).
If JOB='S' and COMPQ and COMPZ are 'V' or 'I', then the unitary
transformations used to reduce (A,B) are accumulated into the arrays
Q and Z s.t.:
Q(in) A(in) Z(in)* = Q(out) A(out) Z(out)*
Q(in) B(in) Z(in)* = Q(out) B(out) Z(out)*
Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix
Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973),
pp. 241--256.
Arguments
=========
JOB (input) CHARACTER*1
= 'E': compute only ALPHA and BETA. A and B will not
necessarily be put into generalized Schur form.
= 'S': put A and B into generalized Schur form, as well
as computing ALPHA and BETA.
COMPQ (input) CHARACTER*1
= 'N': do not modify Q.
= 'V': multiply the array Q on the right by the conjugate
transpose of the unitary tranformation that is
applied to the left side of A and B to reduce them
to Schur form.
= 'I': like COMPQ='V', except that Q will be initialized to
the identity first.
COMPZ (input) CHARACTER*1
= 'N': do not modify Z.
= 'V': multiply the array Z on the right by the unitary
tranformation that is applied to the right side of
A and B to reduce them to Schur form.
= 'I': like COMPZ='V', except that Z will be initialized to
the identity first.
N (input) INTEGER
The order of the matrices A, B, Q, and Z. N >= 0.
ILO (input) INTEGER
IHI (input) INTEGER
It is assumed that A is already upper triangular in rows and
columns 1:ILO-1 and IHI+1:N.
1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
A (input/output) COMPLEX*16 array, dimension (LDA, N)
On entry, the N-by-N upper Hessenberg matrix A. Elements
below the subdiagonal must be zero.
If JOB='S', then on exit A and B will have been
simultaneously reduced to upper triangular form.
If JOB='E', then on exit A will have been destroyed.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max( 1, N ).
B (input/output) COMPLEX*16 array, dimension (LDB, N)
On entry, the N-by-N upper triangular matrix B. Elements
below the diagonal must be zero.
If JOB='S', then on exit A and B will have been
simultaneously reduced to upper triangular form.
If JOB='E', then on exit B will have been destroyed.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max( 1, N ).
ALPHA (output) COMPLEX*16 array, dimension (N)
The diagonal elements of A when the pair (A,B) has been
reduced to Schur form. ALPHA(i)/BETA(i) i=1,...,N
are the generalized eigenvalues.
BETA (output) COMPLEX*16 array, dimension (N)
The diagonal elements of B when the pair (A,B) has been
reduced to Schur form. ALPHA(i)/BETA(i) i=1,...,N
are the generalized eigenvalues. A and B are normalized
so that BETA(1),...,BETA(N) are non-negative real numbers.
Q (input/output) COMPLEX*16 array, dimension (LDQ, N)
If COMPQ='N', then Q will not be referenced.
If COMPQ='V' or 'I', then the conjugate transpose of the
unitary transformations which are applied to A and B on
the left will be applied to the array Q on the right.
LDQ (input) INTEGER
The leading dimension of the array Q. LDQ >= 1.
If COMPQ='V' or 'I', then LDQ >= N.
Z (input/output) COMPLEX*16 array, dimension (LDZ, N)
If COMPZ='N', then Z will not be referenced.
If COMPZ='V' or 'I', then the unitary transformations which
are applied to A and B on the right will be applied to the
array Z on the right.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1.
If COMPZ='V' or 'I', then LDZ >= N.
WORK (workspace/output) COMPLEX*16 array, dimension (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 LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
RWORK (workspace) DOUBLE PRECISION array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
= 1,...,N: the QZ iteration did not converge. (A,B) is not
in Schur form, but ALPHA(i) and BETA(i),
i=INFO+1,...,N should be correct.
= N+1,...,2*N: the shift calculation failed. (A,B) is not
in Schur form, but ALPHA(i) and BETA(i),
i=INFO-N+1,...,N should be correct.
> 2*N: various "impossible" errors.
Further Details
===============
We assume that complex ABS works as long as its value is less than
overflow.
=====================================================================
----------------------- Begin Timing Code ------------------------
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--alpha;
--beta;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
--rwork;
/* Function Body */
latime_1.itcnt = 0.;
/* ------------------------ End Timing Code -------------------------
Decode JOB, COMPQ, COMPZ */
if (lsame_(job, "E")) {
ilschr = FALSE_;
ischur = 1;
} else if (lsame_(job, "S")) {
ilschr = TRUE_;
ischur = 2;
} else {
ischur = 0;
}
if (lsame_(compq, "N")) {
ilq = FALSE_;
icompq = 1;
nq = 0;
} else if (lsame_(compq, "V")) {
ilq = TRUE_;
icompq = 2;
nq = *n;
} else if (lsame_(compq, "I")) {
ilq = TRUE_;
icompq = 3;
nq = *n;
} else {
icompq = 0;
}
if (lsame_(compz, "N")) {
ilz = FALSE_;
icompz = 1;
nz = 0;
} else if (lsame_(compz, "V")) {
ilz = TRUE_;
icompz = 2;
nz = *n;
} else if (lsame_(compz, "I")) {
ilz = TRUE_;
icompz = 3;
nz = *n;
} else {
icompz = 0;
}
/* Check Argument Values */
*info = 0;
i__1 = max(1,*n);
work[1].r = (doublereal) i__1, work[1].i = 0.;
lquery = *lwork == -1;
if (ischur == 0) {
*info = -1;
} else if (icompq == 0) {
*info = -2;
} else if (icompz == 0) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*ilo < 1) {
*info = -5;
} else if (*ihi > *n || *ihi < *ilo - 1) {
*info = -6;
} else if (*lda < *n) {
*info = -8;
} else if (*ldb < *n) {
*info = -10;
} else if (*ldq < 1 || ilq && *ldq < *n) {
*info = -14;
} else if (*ldz < 1 || ilz && *ldz < *n) {
*info = -16;
} else if (*lwork < max(1,*n) && ! lquery) {
*info = -18;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHGEQZ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible
WORK( 1 ) = CMPLX( 1 ) */
if (*n <= 0) {
work[1].r = 1., work[1].i = 0.;
return 0;
}
/* Initialize Q and Z */
if (icompq == 3) {
zlaset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq);
}
if (icompz == 3) {
zlaset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz);
}
/* Machine Constants */
in = *ihi + 1 - *ilo;
safmin = dlamch_("S");
ulp = dlamch_("E") * dlamch_("B");
anorm = zlanhs_("F", &in, &a_ref(*ilo, *ilo), lda, &rwork[1]);
bnorm = zlanhs_("F", &in, &b_ref(*ilo, *ilo), ldb, &rwork[1]);
/* Computing MAX */
d__1 = safmin, d__2 = ulp * anorm;
atol = max(d__1,d__2);
/* Computing MAX */
d__1 = safmin, d__2 = ulp * bnorm;
btol = max(d__1,d__2);
ascale = 1. / max(safmin,anorm);
bscale = 1. / max(safmin,bnorm);
/* ---------------------- Begin Timing Code -------------------------
Count ops for norms, etc. */
opst = 0.;
/* Computing 2nd power */
i__1 = *n;
latime_1.ops += (doublereal) ((i__1 * i__1 << 2) + *n * 12 - 5);
/* ----------------------- End Timing Code --------------------------
Set Eigenvalues IHI+1:N */
i__1 = *n;
for (j = *ihi + 1; j <= i__1; ++j) {
absb = z_abs(&b_ref(j, j));
if (absb > safmin) {
i__2 = b_subscr(j, j);
z__2.r = b[i__2].r / absb, z__2.i = b[i__2].i / absb;
d_cnjg(&z__1, &z__2);
signbc.r = z__1.r, signbc.i = z__1.i;
i__2 = b_subscr(j, j);
b[i__2].r = absb, b[i__2].i = 0.;
if (ilschr) {
i__2 = j - 1;
zscal_(&i__2, &signbc, &b_ref(1, j), &c__1);
zscal_(&j, &signbc, &a_ref(1, j), &c__1);
/* ----------------- Begin Timing Code --------------------- */
opst += (doublereal) ((j - 1) * 12);
/* ------------------ End Timing Code ---------------------- */
} else {
i__2 = a_subscr(j, j);
i__3 = a_subscr(j, j);
z__1.r = a[i__3].r * signbc.r - a[i__3].i * signbc.i, z__1.i =
a[i__3].r * signbc.i + a[i__3].i * signbc.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
if (ilz) {
zscal_(n, &signbc, &z___ref(1, j), &c__1);
}
/* ------------------- Begin Timing Code ---------------------- */
opst += (doublereal) (nz * 6 + 13);
/* -------------------- End Timing Code ----------------------- */
} else {
i__2 = b_subscr(j, j);
b[i__2].r = 0., b[i__2].i = 0.;
}
i__2 = j;
i__3 = a_subscr(j, j);
alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i;
i__2 = j;
i__3 = b_subscr(j, j);
beta[i__2].r = b[i__3].r, beta[i__2].i = b[i__3].i;
/* L10: */
}
/* If IHI < ILO, skip QZ steps */
if (*ihi < *ilo) {
goto L190;
}
/* MAIN QZ ITERATION LOOP
Initialize dynamic indices
Eigenvalues ILAST+1:N have been found.
Column operations modify rows IFRSTM:whatever
Row operations modify columns whatever:ILASTM
If only eigenvalues are being computed, then
IFRSTM is the row of the last splitting row above row ILAST;
this is always at least ILO.
IITER counts iterations since the last eigenvalue was found,
to tell when to use an extraordinary shift.
MAXIT is the maximum number of QZ sweeps allowed. */
ilast = *ihi;
if (ilschr) {
ifrstm = 1;
ilastm = *n;
} else {
ifrstm = *ilo;
ilastm = *ihi;
}
iiter = 0;
eshift.r = 0., eshift.i = 0.;
maxit = (*ihi - *ilo + 1) * 30;
i__1 = maxit;
for (jiter = 1; jiter <= i__1; ++jiter) {
/* Check for too many iterations. */
if (jiter > maxit) {
goto L180;
}
/* Split the matrix if possible.
Two tests:
1: A(j,j-1)=0 or j=ILO
2: B(j,j)=0
Special case: j=ILAST */
if (ilast == *ilo) {
goto L60;
} else {
i__2 = a_subscr(ilast, ilast - 1);
if ((d__1 = a[i__2].r, abs(d__1)) + (d__2 = d_imag(&a_ref(ilast,
ilast - 1)), abs(d__2)) <= atol) {
i__2 = a_subscr(ilast, ilast - 1);
a[i__2].r = 0., a[i__2].i = 0.;
goto L60;
}
}
if (z_abs(&b_ref(ilast, ilast)) <= btol) {
i__2 = b_subscr(ilast, ilast);
b[i__2].r = 0., b[i__2].i = 0.;
goto L50;
}
/* General case: j<ILAST */
i__2 = *ilo;
for (j = ilast - 1; j >= i__2; --j) {
/* Test 1: for A(j,j-1)=0 or j=ILO */
if (j == *ilo) {
ilazro = TRUE_;
} else {
i__3 = a_subscr(j, j - 1);
if ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a_ref(j,
j - 1)), abs(d__2)) <= atol) {
i__3 = a_subscr(j, j - 1);
a[i__3].r = 0., a[i__3].i = 0.;
ilazro = TRUE_;
} else {
ilazro = FALSE_;
}
}
/* Test 2: for B(j,j)=0 */
if (z_abs(&b_ref(j, j)) < btol) {
i__3 = b_subscr(j, j);
b[i__3].r = 0., b[i__3].i = 0.;
/* Test 1a: Check for 2 consecutive small subdiagonals in A */
ilazr2 = FALSE_;
if (! ilazro) {
i__3 = a_subscr(j, j - 1);
i__4 = a_subscr(j + 1, j);
i__5 = a_subscr(j, j);
if (((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&
a_ref(j, j - 1)), abs(d__2))) * (ascale * ((d__3 =
a[i__4].r, abs(d__3)) + (d__4 = d_imag(&a_ref(j
+ 1, j)), abs(d__4)))) <= ((d__5 = a[i__5].r, abs(
d__5)) + (d__6 = d_imag(&a_ref(j, j)), abs(d__6)))
* (ascale * atol)) {
ilazr2 = TRUE_;
}
}
/* If both tests pass (1 & 2), i.e., the leading diagonal
element of B in the block is zero, split a 1x1 block off
at the top. (I.e., at the J-th row/column) The leading
diagonal element of the remainder can also be zero, so
this may have to be done repeatedly. */
if (ilazro || ilazr2) {
i__3 = ilast - 1;
for (jch = j; jch <= i__3; ++jch) {
i__4 = a_subscr(jch, jch);
ctemp.r = a[i__4].r, ctemp.i = a[i__4].i;
zlartg_(&ctemp, &a_ref(jch + 1, jch), &c__, &s, &
a_ref(jch, jch));
i__4 = a_subscr(jch + 1, jch);
a[i__4].r = 0., a[i__4].i = 0.;
i__4 = ilastm - jch;
zrot_(&i__4, &a_ref(jch, jch + 1), lda, &a_ref(jch +
1, jch + 1), lda, &c__, &s);
i__4 = ilastm - jch;
zrot_(&i__4, &b_ref(jch, jch + 1), ldb, &b_ref(jch +
1, jch + 1), ldb, &c__, &s);
if (ilq) {
d_cnjg(&z__1, &s);
zrot_(n, &q_ref(1, jch), &c__1, &q_ref(1, jch + 1)
, &c__1, &c__, &z__1);
}
if (ilazr2) {
i__4 = a_subscr(jch, jch - 1);
i__5 = a_subscr(jch, jch - 1);
z__1.r = c__ * a[i__5].r, z__1.i = c__ * a[i__5]
.i;
a[i__4].r = z__1.r, a[i__4].i = z__1.i;
}
ilazr2 = FALSE_;
/* --------------- Begin Timing Code ----------------- */
opst += (doublereal) ((ilastm - jch) * 40 + 32 + nq *
20);
/* ---------------- End Timing Code ------------------ */
i__4 = b_subscr(jch + 1, jch + 1);
if ((d__1 = b[i__4].r, abs(d__1)) + (d__2 = d_imag(&
b_ref(jch + 1, jch + 1)), abs(d__2)) >= btol)
{
if (jch + 1 >= ilast) {
goto L60;
} else {
ifirst = jch + 1;
goto L70;
}
}
i__4 = b_subscr(jch + 1, jch + 1);
b[i__4].r = 0., b[i__4].i = 0.;
/* L20: */
}
goto L50;
} else {
/* Only test 2 passed -- chase the zero to B(ILAST,ILAST)
Then process as in the case B(ILAST,ILAST)=0 */
i__3 = ilast - 1;
for (jch = j; jch <= i__3; ++jch) {
i__4 = b_subscr(jch, jch + 1);
ctemp.r = b[i__4].r, ctemp.i = b[i__4].i;
zlartg_(&ctemp, &b_ref(jch + 1, jch + 1), &c__, &s, &
b_ref(jch, jch + 1));
i__4 = b_subscr(jch + 1, jch + 1);
b[i__4].r = 0., b[i__4].i = 0.;
if (jch < ilastm - 1) {
i__4 = ilastm - jch - 1;
zrot_(&i__4, &b_ref(jch, jch + 2), ldb, &b_ref(
jch + 1, jch + 2), ldb, &c__, &s);
}
i__4 = ilastm - jch + 2;
zrot_(&i__4, &a_ref(jch, jch - 1), lda, &a_ref(jch +
1, jch - 1), lda, &c__, &s);
if (ilq) {
d_cnjg(&z__1, &s);
zrot_(n, &q_ref(1, jch), &c__1, &q_ref(1, jch + 1)
, &c__1, &c__, &z__1);
}
i__4 = a_subscr(jch + 1, jch);
ctemp.r = a[i__4].r, ctemp.i = a[i__4].i;
zlartg_(&ctemp, &a_ref(jch + 1, jch - 1), &c__, &s, &
a_ref(jch + 1, jch));
i__4 = a_subscr(jch + 1, jch - 1);
a[i__4].r = 0., a[i__4].i = 0.;
i__4 = jch + 1 - ifrstm;
zrot_(&i__4, &a_ref(ifrstm, jch), &c__1, &a_ref(
ifrstm, jch - 1), &c__1, &c__, &s);
i__4 = jch - ifrstm;
zrot_(&i__4, &b_ref(ifrstm, jch), &c__1, &b_ref(
ifrstm, jch - 1), &c__1, &c__, &s);
if (ilz) {
zrot_(n, &z___ref(1, jch), &c__1, &z___ref(1, jch
- 1), &c__1, &c__, &s);
}
/* L30: */
}
/* ---------------- Begin Timing Code ------------------- */
opst += (doublereal) ((ilastm + 1 - ifrstm) * 40 + 64 + (
nq + nz) * 20) * (doublereal) (ilast - j);
/* ----------------- End Timing Code -------------------- */
goto L50;
}
} else if (ilazro) {
/* Only test 1 passed -- work on J:ILAST */
ifirst = j;
goto L70;
}
/* Neither test passed -- try next J
L40: */
}
/* (Drop-through is "impossible") */
*info = (*n << 1) + 1;
goto L210;
/* B(ILAST,ILAST)=0 -- clear A(ILAST,ILAST-1) to split off a
1x1 block. */
L50:
i__2 = a_subscr(ilast, ilast);
ctemp.r = a[i__2].r, ctemp.i = a[i__2].i;
zlartg_(&ctemp, &a_ref(ilast, ilast - 1), &c__, &s, &a_ref(ilast,
ilast));
i__2 = a_subscr(ilast, ilast - 1);
a[i__2].r = 0., a[i__2].i = 0.;
i__2 = ilast - ifrstm;
zrot_(&i__2, &a_ref(ifrstm, ilast), &c__1, &a_ref(ifrstm, ilast - 1),
&c__1, &c__, &s);
i__2 = ilast - ifrstm;
zrot_(&i__2, &b_ref(ifrstm, ilast), &c__1, &b_ref(ifrstm, ilast - 1),
&c__1, &c__, &s);
if (ilz) {
zrot_(n, &z___ref(1, ilast), &c__1, &z___ref(1, ilast - 1), &c__1,
&c__, &s);
}
/* --------------------- Begin Timing Code ----------------------- */
opst += (doublereal) ((ilast - ifrstm) * 40 + 32 + nz * 20);
/* ---------------------- End Timing Code ------------------------
A(ILAST,ILAST-1)=0 -- Standardize B, set ALPHA and BETA */
L60:
absb = z_abs(&b_ref(ilast, ilast));
if (absb > safmin) {
i__2 = b_subscr(ilast, ilast);
z__2.r = b[i__2].r / absb, z__2.i = b[i__2].i / absb;
d_cnjg(&z__1, &z__2);
signbc.r = z__1.r, signbc.i = z__1.i;
i__2 = b_subscr(ilast, ilast);
b[i__2].r = absb, b[i__2].i = 0.;
if (ilschr) {
i__2 = ilast - ifrstm;
zscal_(&i__2, &signbc, &b_ref(ifrstm, ilast), &c__1);
i__2 = ilast + 1 - ifrstm;
zscal_(&i__2, &signbc, &a_ref(ifrstm, ilast), &c__1);
/* ----------------- Begin Timing Code --------------------- */
opst += (doublereal) ((ilast - ifrstm) * 12);
/* ------------------ End Timing Code ---------------------- */
} else {
i__2 = a_subscr(ilast, ilast);
i__3 = a_subscr(ilast, ilast);
z__1.r = a[i__3].r * signbc.r - a[i__3].i * signbc.i, z__1.i =
a[i__3].r * signbc.i + a[i__3].i * signbc.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
if (ilz) {
zscal_(n, &signbc, &z___ref(1, ilast), &c__1);
}
/* ------------------- Begin Timing Code ---------------------- */
opst += (doublereal) (nz * 6 + 13);
/* -------------------- End Timing Code ----------------------- */
} else {
i__2 = b_subscr(ilast, ilast);
b[i__2].r = 0., b[i__2].i = 0.;
}
i__2 = ilast;
i__3 = a_subscr(ilast, ilast);
alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i;
i__2 = ilast;
i__3 = b_subscr(ilast, ilast);
beta[i__2].r = b[i__3].r, beta[i__2].i = b[i__3].i;
/* Go to next block -- exit if finished. */
--ilast;
if (ilast < *ilo) {
goto L190;
}
/* Reset counters */
iiter = 0;
eshift.r = 0., eshift.i = 0.;
if (! ilschr) {
ilastm = ilast;
if (ifrstm > ilast) {
ifrstm = *ilo;
}
}
goto L160;
/* QZ step
This iteration only involves rows/columns IFIRST:ILAST. We
assume IFIRST < ILAST, and that the diagonal of B is non-zero. */
L70:
++iiter;
if (! ilschr) {
ifrstm = ifirst;
}
/* Compute the Shift.
At this point, IFIRST < ILAST, and the diagonal elements of
B(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in
magnitude) */
if (iiter / 10 * 10 != iiter) {
/* The Wilkinson shift (AEP p.512), i.e., the eigenvalue of
the bottom-right 2x2 block of A inv(B) which is nearest to
the bottom-right element.
We factor B as U*D, where U has unit diagonals, and
compute (A*inv(D))*inv(U). */
i__2 = b_subscr(ilast - 1, ilast);
z__2.r = bscale * b[i__2].r, z__2.i = bscale * b[i__2].i;
i__3 = b_subscr(ilast, ilast);
z__3.r = bscale * b[i__3].r, z__3.i = bscale * b[i__3].i;
z_div(&z__1, &z__2, &z__3);
u12.r = z__1.r, u12.i = z__1.i;
i__2 = a_subscr(ilast - 1, ilast - 1);
z__2.r = ascale * a[i__2].r, z__2.i = ascale * a[i__2].i;
i__3 = b_subscr(ilast - 1, ilast - 1);
z__3.r = bscale * b[i__3].r, z__3.i = bscale * b[i__3].i;
z_div(&z__1, &z__2, &z__3);
ad11.r = z__1.r, ad11.i = z__1.i;
i__2 = a_subscr(ilast, ilast - 1);
z__2.r = ascale * a[i__2].r, z__2.i = ascale * a[i__2].i;
i__3 = b_subscr(ilast - 1, ilast - 1);
z__3.r = bscale * b[i__3].r, z__3.i = bscale * b[i__3].i;
z_div(&z__1, &z__2, &z__3);
ad21.r = z__1.r, ad21.i = z__1.i;
i__2 = a_subscr(ilast - 1, ilast);
z__2.r = ascale * a[i__2].r, z__2.i = ascale * a[i__2].i;
i__3 = b_subscr(ilast, ilast);
z__3.r = bscale * b[i__3].r, z__3.i = bscale * b[i__3].i;
z_div(&z__1, &z__2, &z__3);
ad12.r = z__1.r, ad12.i = z__1.i;
i__2 = a_subscr(ilast, ilast);
z__2.r = ascale * a[i__2].r, z__2.i = ascale * a[i__2].i;
i__3 = b_subscr(ilast, ilast);
z__3.r = bscale * b[i__3].r, z__3.i = bscale * b[i__3].i;
z_div(&z__1, &z__2, &z__3);
ad22.r = z__1.r, ad22.i = z__1.i;
z__2.r = u12.r * ad21.r - u12.i * ad21.i, z__2.i = u12.r * ad21.i
+ u12.i * ad21.r;
z__1.r = ad22.r - z__2.r, z__1.i = ad22.i - z__2.i;
abi22.r = z__1.r, abi22.i = z__1.i;
z__2.r = ad11.r + abi22.r, z__2.i = ad11.i + abi22.i;
z__1.r = z__2.r * .5, z__1.i = z__2.i * .5;
t.r = z__1.r, t.i = z__1.i;
pow_zi(&z__4, &t, &c__2);
z__5.r = ad12.r * ad21.r - ad12.i * ad21.i, z__5.i = ad12.r *
ad21.i + ad12.i * ad21.r;
z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
z__6.r = ad11.r * ad22.r - ad11.i * ad22.i, z__6.i = ad11.r *
ad22.i + ad11.i * ad22.r;
z__2.r = z__3.r - z__6.r, z__2.i = z__3.i - z__6.i;
z_sqrt(&z__1, &z__2);
rtdisc.r = z__1.r, rtdisc.i = z__1.i;
z__1.r = t.r - abi22.r, z__1.i = t.i - abi22.i;
z__2.r = t.r - abi22.r, z__2.i = t.i - abi22.i;
temp = z__1.r * rtdisc.r + d_imag(&z__2) * d_imag(&rtdisc);
if (temp <= 0.) {
z__1.r = t.r + rtdisc.r, z__1.i = t.i + rtdisc.i;
shift.r = z__1.r, shift.i = z__1.i;
} else {
z__1.r = t.r - rtdisc.r, z__1.i = t.i - rtdisc.i;
shift.r = z__1.r, shift.i = z__1.i;
}
/* ------------------- Begin Timing Code ---------------------- */
opst += 116.;
/* -------------------- End Timing Code ----------------------- */
} else {
/* Exceptional shift. Chosen for no particularly good reason. */
i__2 = a_subscr(ilast - 1, ilast);
z__4.r = ascale * a[i__2].r, z__4.i = ascale * a[i__2].i;
i__3 = b_subscr(ilast - 1, ilast - 1);
z__5.r = bscale * b[i__3].r, z__5.i = bscale * b[i__3].i;
z_div(&z__3, &z__4, &z__5);
d_cnjg(&z__2, &z__3);
z__1.r = eshift.r + z__2.r, z__1.i = eshift.i + z__2.i;
eshift.r = z__1.r, eshift.i = z__1.i;
shift.r = eshift.r, shift.i = eshift.i;
/* ------------------- Begin Timing Code ---------------------- */
opst += 15.;
/* -------------------- End Timing Code ----------------------- */
}
/* Now check for two consecutive small subdiagonals. */
i__2 = ifirst + 1;
for (j = ilast - 1; j >= i__2; --j) {
istart = j;
i__3 = a_subscr(j, j);
z__2.r = ascale * a[i__3].r, z__2.i = ascale * a[i__3].i;
i__4 = b_subscr(j, j);
z__4.r = bscale * b[i__4].r, z__4.i = bscale * b[i__4].i;
z__3.r = shift.r * z__4.r - shift.i * z__4.i, z__3.i = shift.r *
z__4.i + shift.i * z__4.r;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
ctemp.r = z__1.r, ctemp.i = z__1.i;
temp = (d__1 = ctemp.r, abs(d__1)) + (d__2 = d_imag(&ctemp), abs(
d__2));
i__3 = a_subscr(j + 1, j);
temp2 = ascale * ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&
a_ref(j + 1, j)), abs(d__2)));
tempr = max(temp,temp2);
if (tempr < 1. && tempr != 0.) {
temp /= tempr;
temp2 /= tempr;
}
i__3 = a_subscr(j, j - 1);
if (((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a_ref(j, j -
1)), abs(d__2))) * temp2 <= temp * atol) {
goto L90;
}
/* L80: */
}
istart = ifirst;
i__2 = a_subscr(ifirst, ifirst);
z__2.r = ascale * a[i__2].r, z__2.i = ascale * a[i__2].i;
i__3 = b_subscr(ifirst, ifirst);
z__4.r = bscale * b[i__3].r, z__4.i = bscale * b[i__3].i;
z__3.r = shift.r * z__4.r - shift.i * z__4.i, z__3.i = shift.r *
z__4.i + shift.i * z__4.r;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
ctemp.r = z__1.r, ctemp.i = z__1.i;
/* --------------------- Begin Timing Code ----------------------- */
opst += -6.;
/* ---------------------- End Timing Code ------------------------ */
L90:
/* Do an implicit-shift QZ sweep.
Initial Q */
i__2 = a_subscr(istart + 1, istart);
z__1.r = ascale * a[i__2].r, z__1.i = ascale * a[i__2].i;
ctemp2.r = z__1.r, ctemp2.i = z__1.i;
/* --------------------- Begin Timing Code ----------------------- */
opst += (doublereal) ((ilast - istart) * 18 + 2);
/* ---------------------- End Timing Code ------------------------ */
zlartg_(&ctemp, &ctemp2, &c__, &s, &ctemp3);
/* Sweep */
i__2 = ilast - 1;
for (j = istart; j <= i__2; ++j) {
if (j > istart) {
i__3 = a_subscr(j, j - 1);
ctemp.r = a[i__3].r, ctemp.i = a[i__3].i;
zlartg_(&ctemp, &a_ref(j + 1, j - 1), &c__, &s, &a_ref(j, j -
1));
i__3 = a_subscr(j + 1, j - 1);
a[i__3].r = 0., a[i__3].i = 0.;
}
i__3 = ilastm;
for (jc = j; jc <= i__3; ++jc) {
i__4 = a_subscr(j, jc);
z__2.r = c__ * a[i__4].r, z__2.i = c__ * a[i__4].i;
i__5 = a_subscr(j + 1, jc);
z__3.r = s.r * a[i__5].r - s.i * a[i__5].i, z__3.i = s.r * a[
i__5].i + s.i * a[i__5].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__4 = a_subscr(j + 1, jc);
d_cnjg(&z__4, &s);
z__3.r = -z__4.r, z__3.i = -z__4.i;
i__5 = a_subscr(j, jc);
z__2.r = z__3.r * a[i__5].r - z__3.i * a[i__5].i, z__2.i =
z__3.r * a[i__5].i + z__3.i * a[i__5].r;
i__6 = a_subscr(j + 1, jc);
z__5.r = c__ * a[i__6].r, z__5.i = c__ * a[i__6].i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
a[i__4].r = z__1.r, a[i__4].i = z__1.i;
i__4 = a_subscr(j, jc);
a[i__4].r = ctemp.r, a[i__4].i = ctemp.i;
i__4 = b_subscr(j, jc);
z__2.r = c__ * b[i__4].r, z__2.i = c__ * b[i__4].i;
i__5 = b_subscr(j + 1, jc);
z__3.r = s.r * b[i__5].r - s.i * b[i__5].i, z__3.i = s.r * b[
i__5].i + s.i * b[i__5].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
ctemp2.r = z__1.r, ctemp2.i = z__1.i;
i__4 = b_subscr(j + 1, jc);
d_cnjg(&z__4, &s);
z__3.r = -z__4.r, z__3.i = -z__4.i;
i__5 = b_subscr(j, jc);
z__2.r = z__3.r * b[i__5].r - z__3.i * b[i__5].i, z__2.i =
z__3.r * b[i__5].i + z__3.i * b[i__5].r;
i__6 = b_subscr(j + 1, jc);
z__5.r = c__ * b[i__6].r, z__5.i = c__ * b[i__6].i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
b[i__4].r = z__1.r, b[i__4].i = z__1.i;
i__4 = b_subscr(j, jc);
b[i__4].r = ctemp2.r, b[i__4].i = ctemp2.i;
/* L100: */
}
if (ilq) {
i__3 = *n;
for (jr = 1; jr <= i__3; ++jr) {
i__4 = q_subscr(jr, j);
z__2.r = c__ * q[i__4].r, z__2.i = c__ * q[i__4].i;
d_cnjg(&z__4, &s);
i__5 = q_subscr(jr, j + 1);
z__3.r = z__4.r * q[i__5].r - z__4.i * q[i__5].i, z__3.i =
z__4.r * q[i__5].i + z__4.i * q[i__5].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__4 = q_subscr(jr, j + 1);
z__3.r = -s.r, z__3.i = -s.i;
i__5 = q_subscr(jr, j);
z__2.r = z__3.r * q[i__5].r - z__3.i * q[i__5].i, z__2.i =
z__3.r * q[i__5].i + z__3.i * q[i__5].r;
i__6 = q_subscr(jr, j + 1);
z__4.r = c__ * q[i__6].r, z__4.i = c__ * q[i__6].i;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
q[i__4].r = z__1.r, q[i__4].i = z__1.i;
i__4 = q_subscr(jr, j);
q[i__4].r = ctemp.r, q[i__4].i = ctemp.i;
/* L110: */
}
}
i__3 = b_subscr(j + 1, j + 1);
ctemp.r = b[i__3].r, ctemp.i = b[i__3].i;
zlartg_(&ctemp, &b_ref(j + 1, j), &c__, &s, &b_ref(j + 1, j + 1));
i__3 = b_subscr(j + 1, j);
b[i__3].r = 0., b[i__3].i = 0.;
/* Computing MIN */
i__4 = j + 2;
i__3 = min(i__4,ilast);
for (jr = ifrstm; jr <= i__3; ++jr) {
i__4 = a_subscr(jr, j + 1);
z__2.r = c__ * a[i__4].r, z__2.i = c__ * a[i__4].i;
i__5 = a_subscr(jr, j);
z__3.r = s.r * a[i__5].r - s.i * a[i__5].i, z__3.i = s.r * a[
i__5].i + s.i * a[i__5].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__4 = a_subscr(jr, j);
d_cnjg(&z__4, &s);
z__3.r = -z__4.r, z__3.i = -z__4.i;
i__5 = a_subscr(jr, j + 1);
z__2.r = z__3.r * a[i__5].r - z__3.i * a[i__5].i, z__2.i =
z__3.r * a[i__5].i + z__3.i * a[i__5].r;
i__6 = a_subscr(jr, j);
z__5.r = c__ * a[i__6].r, z__5.i = c__ * a[i__6].i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
a[i__4].r = z__1.r, a[i__4].i = z__1.i;
i__4 = a_subscr(jr, j + 1);
a[i__4].r = ctemp.r, a[i__4].i = ctemp.i;
/* L120: */
}
i__3 = j;
for (jr = ifrstm; jr <= i__3; ++jr) {
i__4 = b_subscr(jr, j + 1);
z__2.r = c__ * b[i__4].r, z__2.i = c__ * b[i__4].i;
i__5 = b_subscr(jr, j);
z__3.r = s.r * b[i__5].r - s.i * b[i__5].i, z__3.i = s.r * b[
i__5].i + s.i * b[i__5].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__4 = b_subscr(jr, j);
d_cnjg(&z__4, &s);
z__3.r = -z__4.r, z__3.i = -z__4.i;
i__5 = b_subscr(jr, j + 1);
z__2.r = z__3.r * b[i__5].r - z__3.i * b[i__5].i, z__2.i =
z__3.r * b[i__5].i + z__3.i * b[i__5].r;
i__6 = b_subscr(jr, j);
z__5.r = c__ * b[i__6].r, z__5.i = c__ * b[i__6].i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
b[i__4].r = z__1.r, b[i__4].i = z__1.i;
i__4 = b_subscr(jr, j + 1);
b[i__4].r = ctemp.r, b[i__4].i = ctemp.i;
/* L130: */
}
if (ilz) {
i__3 = *n;
for (jr = 1; jr <= i__3; ++jr) {
i__4 = z___subscr(jr, j + 1);
z__2.r = c__ * z__[i__4].r, z__2.i = c__ * z__[i__4].i;
i__5 = z___subscr(jr, j);
z__3.r = s.r * z__[i__5].r - s.i * z__[i__5].i, z__3.i =
s.r * z__[i__5].i + s.i * z__[i__5].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__4 = z___subscr(jr, j);
d_cnjg(&z__4, &s);
z__3.r = -z__4.r, z__3.i = -z__4.i;
i__5 = z___subscr(jr, j + 1);
z__2.r = z__3.r * z__[i__5].r - z__3.i * z__[i__5].i,
z__2.i = z__3.r * z__[i__5].i + z__3.i * z__[i__5]
.r;
i__6 = z___subscr(jr, j);
z__5.r = c__ * z__[i__6].r, z__5.i = c__ * z__[i__6].i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
i__4 = z___subscr(jr, j + 1);
z__[i__4].r = ctemp.r, z__[i__4].i = ctemp.i;
/* L140: */
}
}
/* L150: */
}
/* --------------------- Begin Timing Code ----------------------- */
opst += (doublereal) (ilast - istart) * (doublereal) ((ilastm -
ifrstm) * 40 + 184 + (nq + nz) * 20) - 20;
/* ---------------------- End Timing Code ------------------------ */
L160:
/* --------------------- Begin Timing Code -----------------------
End of iteration -- add in "small" contributions. */
latime_1.ops += opst;
opst = 0.;
/* ---------------------- End Timing Code ------------------------
L170: */
}
/* Drop-through = non-convergence */
L180:
*info = ilast;
/* ---------------------- Begin Timing Code ------------------------- */
latime_1.ops += opst;
opst = 0.;
/* ----------------------- End Timing Code -------------------------- */
goto L210;
/* Successful completion of all QZ steps */
L190:
/* Set Eigenvalues 1:ILO-1 */
i__1 = *ilo - 1;
for (j = 1; j <= i__1; ++j) {
absb = z_abs(&b_ref(j, j));
if (absb > safmin) {
i__2 = b_subscr(j, j);
z__2.r = b[i__2].r / absb, z__2.i = b[i__2].i / absb;
d_cnjg(&z__1, &z__2);
signbc.r = z__1.r, signbc.i = z__1.i;
i__2 = b_subscr(j, j);
b[i__2].r = absb, b[i__2].i = 0.;
if (ilschr) {
i__2 = j - 1;
zscal_(&i__2, &signbc, &b_ref(1, j), &c__1);
zscal_(&j, &signbc, &a_ref(1, j), &c__1);
/* ----------------- Begin Timing Code --------------------- */
opst += (doublereal) ((j - 1) * 12);
/* ------------------ End Timing Code ---------------------- */
} else {
i__2 = a_subscr(j, j);
i__3 = a_subscr(j, j);
z__1.r = a[i__3].r * signbc.r - a[i__3].i * signbc.i, z__1.i =
a[i__3].r * signbc.i + a[i__3].i * signbc.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
if (ilz) {
zscal_(n, &signbc, &z___ref(1, j), &c__1);
}
/* ------------------- Begin Timing Code ---------------------- */
opst += (doublereal) (nz * 6 + 13);
/* -------------------- End Timing Code ----------------------- */
} else {
i__2 = b_subscr(j, j);
b[i__2].r = 0., b[i__2].i = 0.;
}
i__2 = j;
i__3 = a_subscr(j, j);
alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i;
i__2 = j;
i__3 = b_subscr(j, j);
beta[i__2].r = b[i__3].r, beta[i__2].i = b[i__3].i;
/* L200: */
}
/* Normal Termination */
*info = 0;
/* Exit (other than argument error) -- return optimal workspace size */
L210:
/* ---------------------- Begin Timing Code ------------------------- */
latime_1.ops += opst;
opst = 0.;
latime_1.itcnt = (doublereal) jiter;
/* ----------------------- End Timing Code -------------------------- */
z__1.r = (doublereal) (*n), z__1.i = 0.;
work[1].r = z__1.r, work[1].i = z__1.i;
return 0;
/* End of ZHGEQZ */
} /* zhgeqz_ */
/* Subroutine */ int zsptrf_(char *uplo, integer *n, doublecomplex *ap,
integer *ipiv, integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double sqrt(doublereal), d_imag(doublecomplex *);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j, k;
doublecomplex t, r1, d11, d12, d21, d22;
integer kc, kk, kp;
doublecomplex wk;
integer kx, knc, kpc, npp;
doublecomplex wkm1, wkp1;
integer imax, jmax;
extern /* Subroutine */ int zspr_(char *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *);
doublereal alpha;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
integer kstep;
logical upper;
extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
doublereal absakk;
extern /* Subroutine */ int xerbla_(char *, integer *);
doublereal colmax;
extern integer izamax_(integer *, doublecomplex *, integer *);
doublereal rowmax;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZSPTRF computes the factorization of a complex symmetric matrix A */
/* stored in packed format using the Bunch-Kaufman diagonal pivoting */
/* method: */
/* A = U*D*U**T or A = L*D*L**T */
/* where U (or L) is a product of permutation and unit upper (lower) */
/* triangular matrices, and D is symmetric and block diagonal with */
/* 1-by-1 and 2-by-2 diagonal blocks. */
/* 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*16 array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the symmetric 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, the block diagonal matrix D and the multipliers used */
/* to obtain the factor U or L, stored as a packed triangular */
/* matrix overwriting A (see below for further details). */
/* IPIV (output) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D. */
/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, D(i,i) is exactly zero. The factorization */
/* has been completed, but the block diagonal matrix D is */
/* exactly singular, and division by zero will occur if it */
/* is used to solve a system of equations. */
/* Further Details */
/* =============== */
/* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services */
/* Company */
/* If UPLO = 'U', then A = U*D*U', where */
/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */
/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */
/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */
/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
/* ( I v 0 ) k-s */
/* U(k) = ( 0 I 0 ) s */
/* ( 0 0 I ) n-k */
/* k-s s n-k */
/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */
/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */
/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */
/* If UPLO = 'L', then A = L*D*L', where */
/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */
/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */
/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */
/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
/* ( I 0 0 ) k-1 */
/* L(k) = ( 0 I 0 ) s */
/* ( 0 v I ) n-k-s+1 */
/* k-1 s n-k-s+1 */
/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */
/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */
/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ipiv;
--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_("ZSPTRF", &i__1);
return 0;
}
/* Initialize ALPHA for use in choosing pivot block size. */
alpha = (sqrt(17.) + 1.) / 8.;
if (upper) {
/* Factorize A as U*D*U' using the upper triangle of A */
/* K is the main loop index, decreasing from N to 1 in steps of */
/* 1 or 2 */
k = *n;
kc = (*n - 1) * *n / 2 + 1;
L10:
knc = kc;
/* If K < 1, exit from loop */
if (k < 1) {
goto L110;
}
kstep = 1;
/* Determine rows and columns to be interchanged and whether */
/* a 1-by-1 or 2-by-2 pivot block will be used */
i__1 = kc + k - 1;
absakk = (d__1 = ap[i__1].r, abs(d__1)) + (d__2 = d_imag(&ap[kc + k -
1]), abs(d__2));
/* IMAX is the row-index of the largest off-diagonal element in */
/* column K, and COLMAX is its absolute value */
if (k > 1) {
i__1 = k - 1;
imax = izamax_(&i__1, &ap[kc], &c__1);
i__1 = kc + imax - 1;
colmax = (d__1 = ap[i__1].r, abs(d__1)) + (d__2 = d_imag(&ap[kc +
imax - 1]), abs(d__2));
} else {
colmax = 0.;
}
if (max(absakk,colmax) == 0.) {
/* Column K is zero: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
} else {
if (absakk >= alpha * colmax) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else {
/* JMAX is the column-index of the largest off-diagonal */
/* element in row IMAX, and ROWMAX is its absolute value */
rowmax = 0.;
jmax = imax;
kx = imax * (imax + 1) / 2 + imax;
i__1 = k;
for (j = imax + 1; j <= i__1; ++j) {
i__2 = kx;
if ((d__1 = ap[i__2].r, abs(d__1)) + (d__2 = d_imag(&ap[
kx]), abs(d__2)) > rowmax) {
i__2 = kx;
rowmax = (d__1 = ap[i__2].r, abs(d__1)) + (d__2 =
d_imag(&ap[kx]), abs(d__2));
jmax = j;
}
kx += j;
/* L20: */
}
kpc = (imax - 1) * imax / 2 + 1;
if (imax > 1) {
i__1 = imax - 1;
jmax = izamax_(&i__1, &ap[kpc], &c__1);
/* Computing MAX */
i__1 = kpc + jmax - 1;
d__3 = rowmax, d__4 = (d__1 = ap[i__1].r, abs(d__1)) + (
d__2 = d_imag(&ap[kpc + jmax - 1]), abs(d__2));
rowmax = max(d__3,d__4);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else /* if(complicated condition) */ {
i__1 = kpc + imax - 1;
if ((d__1 = ap[i__1].r, abs(d__1)) + (d__2 = d_imag(&ap[
kpc + imax - 1]), abs(d__2)) >= alpha * rowmax) {
/* interchange rows and columns K and IMAX, use 1-by-1 */
/* pivot block */
kp = imax;
} else {
/* interchange rows and columns K-1 and IMAX, use 2-by-2 */
/* pivot block */
kp = imax;
kstep = 2;
}
}
}
kk = k - kstep + 1;
if (kstep == 2) {
knc = knc - k + 1;
}
if (kp != kk) {
/* Interchange rows and columns KK and KP in the leading */
/* submatrix A(1:k,1:k) */
i__1 = kp - 1;
zswap_(&i__1, &ap[knc], &c__1, &ap[kpc], &c__1);
kx = kpc + kp - 1;
i__1 = kk - 1;
for (j = kp + 1; j <= i__1; ++j) {
kx = kx + j - 1;
i__2 = knc + j - 1;
t.r = ap[i__2].r, t.i = ap[i__2].i;
i__2 = knc + j - 1;
i__3 = kx;
ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i;
i__2 = kx;
ap[i__2].r = t.r, ap[i__2].i = t.i;
/* L30: */
}
i__1 = knc + kk - 1;
t.r = ap[i__1].r, t.i = ap[i__1].i;
i__1 = knc + kk - 1;
i__2 = kpc + kp - 1;
ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
i__1 = kpc + kp - 1;
ap[i__1].r = t.r, ap[i__1].i = t.i;
if (kstep == 2) {
i__1 = kc + k - 2;
t.r = ap[i__1].r, t.i = ap[i__1].i;
i__1 = kc + k - 2;
i__2 = kc + kp - 1;
ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
i__1 = kc + kp - 1;
ap[i__1].r = t.r, ap[i__1].i = t.i;
}
}
/* Update the leading submatrix */
if (kstep == 1) {
/* 1-by-1 pivot block D(k): column k now holds */
/* W(k) = U(k)*D(k) */
/* where U(k) is the k-th column of U */
/* Perform a rank-1 update of A(1:k-1,1:k-1) as */
/* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' */
z_div(&z__1, &c_b1, &ap[kc + k - 1]);
r1.r = z__1.r, r1.i = z__1.i;
i__1 = k - 1;
z__1.r = -r1.r, z__1.i = -r1.i;
zspr_(uplo, &i__1, &z__1, &ap[kc], &c__1, &ap[1]);
/* Store U(k) in column k */
i__1 = k - 1;
zscal_(&i__1, &r1, &ap[kc], &c__1);
} else {
/* 2-by-2 pivot block D(k): columns k and k-1 now hold */
/* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) */
/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */
/* of U */
/* Perform a rank-2 update of A(1:k-2,1:k-2) as */
/* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )' */
/* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' */
if (k > 2) {
i__1 = k - 1 + (k - 1) * k / 2;
d12.r = ap[i__1].r, d12.i = ap[i__1].i;
z_div(&z__1, &ap[k - 1 + (k - 2) * (k - 1) / 2], &d12);
d22.r = z__1.r, d22.i = z__1.i;
z_div(&z__1, &ap[k + (k - 1) * k / 2], &d12);
d11.r = z__1.r, d11.i = z__1.i;
z__3.r = d11.r * d22.r - d11.i * d22.i, z__3.i = d11.r *
d22.i + d11.i * d22.r;
z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.;
z_div(&z__1, &c_b1, &z__2);
t.r = z__1.r, t.i = z__1.i;
z_div(&z__1, &t, &d12);
d12.r = z__1.r, d12.i = z__1.i;
for (j = k - 2; j >= 1; --j) {
i__1 = j + (k - 2) * (k - 1) / 2;
z__3.r = d11.r * ap[i__1].r - d11.i * ap[i__1].i,
z__3.i = d11.r * ap[i__1].i + d11.i * ap[i__1]
.r;
i__2 = j + (k - 1) * k / 2;
z__2.r = z__3.r - ap[i__2].r, z__2.i = z__3.i - ap[
i__2].i;
z__1.r = d12.r * z__2.r - d12.i * z__2.i, z__1.i =
d12.r * z__2.i + d12.i * z__2.r;
wkm1.r = z__1.r, wkm1.i = z__1.i;
i__1 = j + (k - 1) * k / 2;
z__3.r = d22.r * ap[i__1].r - d22.i * ap[i__1].i,
z__3.i = d22.r * ap[i__1].i + d22.i * ap[i__1]
.r;
i__2 = j + (k - 2) * (k - 1) / 2;
z__2.r = z__3.r - ap[i__2].r, z__2.i = z__3.i - ap[
i__2].i;
z__1.r = d12.r * z__2.r - d12.i * z__2.i, z__1.i =
d12.r * z__2.i + d12.i * z__2.r;
wk.r = z__1.r, wk.i = z__1.i;
for (i__ = j; i__ >= 1; --i__) {
i__1 = i__ + (j - 1) * j / 2;
i__2 = i__ + (j - 1) * j / 2;
i__3 = i__ + (k - 1) * k / 2;
z__3.r = ap[i__3].r * wk.r - ap[i__3].i * wk.i,
z__3.i = ap[i__3].r * wk.i + ap[i__3].i *
wk.r;
z__2.r = ap[i__2].r - z__3.r, z__2.i = ap[i__2].i
- z__3.i;
i__4 = i__ + (k - 2) * (k - 1) / 2;
z__4.r = ap[i__4].r * wkm1.r - ap[i__4].i *
wkm1.i, z__4.i = ap[i__4].r * wkm1.i + ap[
i__4].i * wkm1.r;
z__1.r = z__2.r - z__4.r, z__1.i = z__2.i -
z__4.i;
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
/* L40: */
}
i__1 = j + (k - 1) * k / 2;
ap[i__1].r = wk.r, ap[i__1].i = wk.i;
i__1 = j + (k - 2) * (k - 1) / 2;
ap[i__1].r = wkm1.r, ap[i__1].i = wkm1.i;
/* L50: */
}
}
}
}
/* Store details of the interchanges in IPIV */
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k - 1] = -kp;
}
/* Decrease K and return to the start of the main loop */
k -= kstep;
kc = knc - k;
goto L10;
} else {
/* Factorize A as L*D*L' using the lower triangle of A */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2 */
k = 1;
kc = 1;
npp = *n * (*n + 1) / 2;
L60:
knc = kc;
/* If K > N, exit from loop */
if (k > *n) {
goto L110;
}
kstep = 1;
/* Determine rows and columns to be interchanged and whether */
/* a 1-by-1 or 2-by-2 pivot block will be used */
i__1 = kc;
absakk = (d__1 = ap[i__1].r, abs(d__1)) + (d__2 = d_imag(&ap[kc]),
abs(d__2));
/* IMAX is the row-index of the largest off-diagonal element in */
/* column K, and COLMAX is its absolute value */
if (k < *n) {
i__1 = *n - k;
imax = k + izamax_(&i__1, &ap[kc + 1], &c__1);
i__1 = kc + imax - k;
colmax = (d__1 = ap[i__1].r, abs(d__1)) + (d__2 = d_imag(&ap[kc +
imax - k]), abs(d__2));
} else {
colmax = 0.;
}
if (max(absakk,colmax) == 0.) {
/* Column K is zero: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
} else {
if (absakk >= alpha * colmax) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else {
/* JMAX is the column-index of the largest off-diagonal */
/* element in row IMAX, and ROWMAX is its absolute value */
rowmax = 0.;
kx = kc + imax - k;
i__1 = imax - 1;
for (j = k; j <= i__1; ++j) {
i__2 = kx;
if ((d__1 = ap[i__2].r, abs(d__1)) + (d__2 = d_imag(&ap[
kx]), abs(d__2)) > rowmax) {
i__2 = kx;
rowmax = (d__1 = ap[i__2].r, abs(d__1)) + (d__2 =
d_imag(&ap[kx]), abs(d__2));
jmax = j;
}
kx = kx + *n - j;
/* L70: */
}
kpc = npp - (*n - imax + 1) * (*n - imax + 2) / 2 + 1;
if (imax < *n) {
i__1 = *n - imax;
jmax = imax + izamax_(&i__1, &ap[kpc + 1], &c__1);
/* Computing MAX */
i__1 = kpc + jmax - imax;
d__3 = rowmax, d__4 = (d__1 = ap[i__1].r, abs(d__1)) + (
d__2 = d_imag(&ap[kpc + jmax - imax]), abs(d__2));
rowmax = max(d__3,d__4);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else /* if(complicated condition) */ {
i__1 = kpc;
if ((d__1 = ap[i__1].r, abs(d__1)) + (d__2 = d_imag(&ap[
kpc]), abs(d__2)) >= alpha * rowmax) {
/* interchange rows and columns K and IMAX, use 1-by-1 */
/* pivot block */
kp = imax;
} else {
/* interchange rows and columns K+1 and IMAX, use 2-by-2 */
/* pivot block */
kp = imax;
kstep = 2;
}
}
}
kk = k + kstep - 1;
if (kstep == 2) {
knc = knc + *n - k + 1;
}
if (kp != kk) {
/* Interchange rows and columns KK and KP in the trailing */
/* submatrix A(k:n,k:n) */
if (kp < *n) {
i__1 = *n - kp;
zswap_(&i__1, &ap[knc + kp - kk + 1], &c__1, &ap[kpc + 1],
&c__1);
}
kx = knc + kp - kk;
i__1 = kp - 1;
for (j = kk + 1; j <= i__1; ++j) {
kx = kx + *n - j + 1;
i__2 = knc + j - kk;
t.r = ap[i__2].r, t.i = ap[i__2].i;
i__2 = knc + j - kk;
i__3 = kx;
ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i;
i__2 = kx;
ap[i__2].r = t.r, ap[i__2].i = t.i;
/* L80: */
}
i__1 = knc;
t.r = ap[i__1].r, t.i = ap[i__1].i;
i__1 = knc;
i__2 = kpc;
ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
i__1 = kpc;
ap[i__1].r = t.r, ap[i__1].i = t.i;
if (kstep == 2) {
i__1 = kc + 1;
t.r = ap[i__1].r, t.i = ap[i__1].i;
i__1 = kc + 1;
i__2 = kc + kp - k;
ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
i__1 = kc + kp - k;
ap[i__1].r = t.r, ap[i__1].i = t.i;
}
}
/* Update the trailing submatrix */
if (kstep == 1) {
/* 1-by-1 pivot block D(k): column k now holds */
/* W(k) = L(k)*D(k) */
/* where L(k) is the k-th column of L */
if (k < *n) {
/* Perform a rank-1 update of A(k+1:n,k+1:n) as */
/* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' */
z_div(&z__1, &c_b1, &ap[kc]);
r1.r = z__1.r, r1.i = z__1.i;
i__1 = *n - k;
z__1.r = -r1.r, z__1.i = -r1.i;
zspr_(uplo, &i__1, &z__1, &ap[kc + 1], &c__1, &ap[kc + *n
- k + 1]);
/* Store L(k) in column K */
i__1 = *n - k;
zscal_(&i__1, &r1, &ap[kc + 1], &c__1);
}
} else {
/* 2-by-2 pivot block D(k): columns K and K+1 now hold */
/* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) */
/* where L(k) and L(k+1) are the k-th and (k+1)-th columns */
/* of L */
if (k < *n - 1) {
/* Perform a rank-2 update of A(k+2:n,k+2:n) as */
/* A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )' */
/* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )' */
/* where L(k) and L(k+1) are the k-th and (k+1)-th */
/* columns of L */
i__1 = k + 1 + (k - 1) * ((*n << 1) - k) / 2;
d21.r = ap[i__1].r, d21.i = ap[i__1].i;
z_div(&z__1, &ap[k + 1 + k * ((*n << 1) - k - 1) / 2], &
d21);
d11.r = z__1.r, d11.i = z__1.i;
z_div(&z__1, &ap[k + (k - 1) * ((*n << 1) - k) / 2], &d21)
;
d22.r = z__1.r, d22.i = z__1.i;
z__3.r = d11.r * d22.r - d11.i * d22.i, z__3.i = d11.r *
d22.i + d11.i * d22.r;
z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.;
z_div(&z__1, &c_b1, &z__2);
t.r = z__1.r, t.i = z__1.i;
z_div(&z__1, &t, &d21);
d21.r = z__1.r, d21.i = z__1.i;
i__1 = *n;
for (j = k + 2; j <= i__1; ++j) {
i__2 = j + (k - 1) * ((*n << 1) - k) / 2;
z__3.r = d11.r * ap[i__2].r - d11.i * ap[i__2].i,
z__3.i = d11.r * ap[i__2].i + d11.i * ap[i__2]
.r;
i__3 = j + k * ((*n << 1) - k - 1) / 2;
z__2.r = z__3.r - ap[i__3].r, z__2.i = z__3.i - ap[
i__3].i;
z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i =
d21.r * z__2.i + d21.i * z__2.r;
wk.r = z__1.r, wk.i = z__1.i;
i__2 = j + k * ((*n << 1) - k - 1) / 2;
z__3.r = d22.r * ap[i__2].r - d22.i * ap[i__2].i,
z__3.i = d22.r * ap[i__2].i + d22.i * ap[i__2]
.r;
i__3 = j + (k - 1) * ((*n << 1) - k) / 2;
z__2.r = z__3.r - ap[i__3].r, z__2.i = z__3.i - ap[
i__3].i;
z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i =
d21.r * z__2.i + d21.i * z__2.r;
wkp1.r = z__1.r, wkp1.i = z__1.i;
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
i__3 = i__ + (j - 1) * ((*n << 1) - j) / 2;
i__4 = i__ + (j - 1) * ((*n << 1) - j) / 2;
i__5 = i__ + (k - 1) * ((*n << 1) - k) / 2;
z__3.r = ap[i__5].r * wk.r - ap[i__5].i * wk.i,
z__3.i = ap[i__5].r * wk.i + ap[i__5].i *
wk.r;
z__2.r = ap[i__4].r - z__3.r, z__2.i = ap[i__4].i
- z__3.i;
i__6 = i__ + k * ((*n << 1) - k - 1) / 2;
z__4.r = ap[i__6].r * wkp1.r - ap[i__6].i *
wkp1.i, z__4.i = ap[i__6].r * wkp1.i + ap[
i__6].i * wkp1.r;
z__1.r = z__2.r - z__4.r, z__1.i = z__2.i -
z__4.i;
ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
/* L90: */
}
i__2 = j + (k - 1) * ((*n << 1) - k) / 2;
ap[i__2].r = wk.r, ap[i__2].i = wk.i;
i__2 = j + k * ((*n << 1) - k - 1) / 2;
ap[i__2].r = wkp1.r, ap[i__2].i = wkp1.i;
/* L100: */
}
}
}
}
/* Store details of the interchanges in IPIV */
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k + 1] = -kp;
}
/* Increase K and return to the start of the main loop */
k += kstep;
kc = knc + *n - k + 2;
goto L60;
}
L110:
return 0;
/* End of ZSPTRF */
} /* zsptrf_ */
int
zpivotL(
const int jcol, /* in */
const double u, /* in - diagonal pivoting threshold */
int *usepr, /* re-use the pivot sequence given by perm_r/iperm_r */
int *perm_r, /* may be modified */
int *iperm_r, /* in - inverse of perm_r */
int *iperm_c, /* in - used to find diagonal of Pc*A*Pc' */
int *pivrow, /* out */
GlobalLU_t *Glu, /* modified - global LU data structures */
SuperLUStat_t *stat /* output */
)
{
doublecomplex one = {1.0, 0.0};
int fsupc; /* first column in the supernode */
int nsupc; /* no of columns in the supernode */
int nsupr; /* no of rows in the supernode */
int lptr; /* points to the starting subscript of the supernode */
int pivptr, old_pivptr, diag, diagind;
double pivmax, rtemp, thresh;
doublecomplex temp;
doublecomplex *lu_sup_ptr;
doublecomplex *lu_col_ptr;
int *lsub_ptr;
int isub, icol, k, itemp;
int *lsub, *xlsub;
doublecomplex *lusup;
int *xlusup;
flops_t *ops = stat->ops;
/* Initialize pointers */
lsub = Glu->lsub;
xlsub = Glu->xlsub;
lusup = Glu->lusup;
xlusup = Glu->xlusup;
fsupc = (Glu->xsup)[(Glu->supno)[jcol]];
nsupc = jcol - fsupc; /* excluding jcol; nsupc >= 0 */
lptr = xlsub[fsupc];
nsupr = xlsub[fsupc+1] - lptr;
lu_sup_ptr = &lusup[xlusup[fsupc]]; /* start of the current supernode */
lu_col_ptr = &lusup[xlusup[jcol]]; /* start of jcol in the supernode */
lsub_ptr = &lsub[lptr]; /* start of row indices of the supernode */
#ifdef DEBUG
if ( jcol == MIN_COL ) {
printf("Before cdiv: col %d\n", jcol);
for (k = nsupc; k < nsupr; k++)
printf(" lu[%d] %f\n", lsub_ptr[k], lu_col_ptr[k]);
}
#endif
/* Determine the largest abs numerical value for partial pivoting;
Also search for user-specified pivot, and diagonal element. */
if ( *usepr ) *pivrow = iperm_r[jcol];
diagind = iperm_c[jcol];
pivmax = 0.0;
pivptr = nsupc;
diag = EMPTY;
old_pivptr = nsupc;
for (isub = nsupc; isub < nsupr; ++isub) {
rtemp = z_abs1 (&lu_col_ptr[isub]);
if ( rtemp > pivmax ) {
pivmax = rtemp;
pivptr = isub;
}
if ( *usepr && lsub_ptr[isub] == *pivrow ) old_pivptr = isub;
if ( lsub_ptr[isub] == diagind ) diag = isub;
}
/* Test for singularity */
if ( pivmax == 0.0 ) {
#if 1
#if SCIPY_FIX
if (pivptr < nsupr) {
*pivrow = lsub_ptr[pivptr];
}
else {
*pivrow = diagind;
}
#else
*pivrow = lsub_ptr[pivptr];
#endif
perm_r[*pivrow] = jcol;
#else
perm_r[diagind] = jcol;
#endif
*usepr = 0;
return (jcol+1);
}
thresh = u * pivmax;
/* Choose appropriate pivotal element by our policy. */
if ( *usepr ) {
rtemp = z_abs1 (&lu_col_ptr[old_pivptr]);
if ( rtemp != 0.0 && rtemp >= thresh )
pivptr = old_pivptr;
else
*usepr = 0;
}
if ( *usepr == 0 ) {
/* Use diagonal pivot? */
if ( diag >= 0 ) { /* diagonal exists */
rtemp = z_abs1 (&lu_col_ptr[diag]);
if ( rtemp != 0.0 && rtemp >= thresh ) pivptr = diag;
}
*pivrow = lsub_ptr[pivptr];
}
/* Record pivot row */
perm_r[*pivrow] = jcol;
/* Interchange row subscripts */
if ( pivptr != nsupc ) {
itemp = lsub_ptr[pivptr];
lsub_ptr[pivptr] = lsub_ptr[nsupc];
lsub_ptr[nsupc] = itemp;
/* Interchange numerical values as well, for the whole snode, such
* that L is indexed the same way as A.
*/
for (icol = 0; icol <= nsupc; icol++) {
itemp = pivptr + icol * nsupr;
temp = lu_sup_ptr[itemp];
lu_sup_ptr[itemp] = lu_sup_ptr[nsupc + icol*nsupr];
lu_sup_ptr[nsupc + icol*nsupr] = temp;
}
} /* if */
/* cdiv operation */
ops[FACT] += 10 * (nsupr - nsupc);
z_div(&temp, &one, &lu_col_ptr[nsupc]);
for (k = nsupc+1; k < nsupr; k++)
zz_mult(&lu_col_ptr[k], &lu_col_ptr[k], &temp);
return 0;
}
/* Subroutine */ int zhptrs_(char *uplo, integer *n, integer *nrhs,
doublecomplex *ap, integer *ipiv, doublecomplex *b, integer *ldb,
integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, i__1, i__2;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
void z_div(doublecomplex *, doublecomplex *, doublecomplex *), d_cnjg(
doublecomplex *, doublecomplex *);
/* Local variables */
integer j, k;
doublereal s;
doublecomplex ak, bk;
integer kc, kp;
doublecomplex akm1, bkm1, akm1k;
extern logical lsame_(char *, char *);
doublecomplex denom;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
logical upper;
extern /* Subroutine */ int zgeru_(integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zswap_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *), xerbla_(char *, integer *), zdscal_(integer *, doublereal *, doublecomplex *,
integer *), zlacgv_(integer *, doublecomplex *, integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZHPTRS solves a system of linear equations A*X = B with a complex */
/* Hermitian matrix A stored in packed format using the factorization */
/* A = U*D*U**H or A = L*D*L**H computed by ZHPTRF. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the details of the factorization are stored */
/* as an upper or lower triangular matrix. */
/* = 'U': Upper triangular, form is A = U*D*U**H; */
/* = 'L': Lower triangular, form is A = L*D*L**H. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrix B. NRHS >= 0. */
/* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
/* The block diagonal matrix D and the multipliers used to */
/* obtain the factor U or L as computed by ZHPTRF, stored as a */
/* packed triangular matrix. */
/* IPIV (input) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D */
/* as determined by ZHPTRF. */
/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
/* On entry, the right hand side matrix B. */
/* On exit, the solution matrix X. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--ap;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*ldb < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHPTRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
return 0;
}
if (upper) {
/* Solve A*X = B, where A = U*D*U'. */
/* First solve U*D*X = B, overwriting B with X. */
/* K is the main loop index, decreasing from N to 1 in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = *n;
kc = *n * (*n + 1) / 2 + 1;
L10:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L30;
}
kc -= k;
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
/* Multiply by inv(U(K)), where U(K) is the transformation */
/* stored in column K of A. */
i__1 = k - 1;
z__1.r = -1., z__1.i = -0.;
zgeru_(&i__1, nrhs, &z__1, &ap[kc], &c__1, &b[k + b_dim1], ldb, &
b[b_dim1 + 1], ldb);
/* Multiply by the inverse of the diagonal block. */
i__1 = kc + k - 1;
s = 1. / ap[i__1].r;
zdscal_(nrhs, &s, &b[k + b_dim1], ldb);
--k;
} else {
/* 2 x 2 diagonal block */
/* Interchange rows K-1 and -IPIV(K). */
kp = -ipiv[k];
if (kp != k - 1) {
zswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
/* Multiply by inv(U(K)), where U(K) is the transformation */
/* stored in columns K-1 and K of A. */
i__1 = k - 2;
z__1.r = -1., z__1.i = -0.;
zgeru_(&i__1, nrhs, &z__1, &ap[kc], &c__1, &b[k + b_dim1], ldb, &
b[b_dim1 + 1], ldb);
i__1 = k - 2;
z__1.r = -1., z__1.i = -0.;
zgeru_(&i__1, nrhs, &z__1, &ap[kc - (k - 1)], &c__1, &b[k - 1 +
b_dim1], ldb, &b[b_dim1 + 1], ldb);
/* Multiply by the inverse of the diagonal block. */
i__1 = kc + k - 2;
akm1k.r = ap[i__1].r, akm1k.i = ap[i__1].i;
z_div(&z__1, &ap[kc - 1], &akm1k);
akm1.r = z__1.r, akm1.i = z__1.i;
d_cnjg(&z__2, &akm1k);
z_div(&z__1, &ap[kc + k - 1], &z__2);
ak.r = z__1.r, ak.i = z__1.i;
z__2.r = akm1.r * ak.r - akm1.i * ak.i, z__2.i = akm1.r * ak.i +
akm1.i * ak.r;
z__1.r = z__2.r - 1., z__1.i = z__2.i - 0.;
denom.r = z__1.r, denom.i = z__1.i;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
z_div(&z__1, &b[k - 1 + j * b_dim1], &akm1k);
bkm1.r = z__1.r, bkm1.i = z__1.i;
d_cnjg(&z__2, &akm1k);
z_div(&z__1, &b[k + j * b_dim1], &z__2);
bk.r = z__1.r, bk.i = z__1.i;
i__2 = k - 1 + j * b_dim1;
z__3.r = ak.r * bkm1.r - ak.i * bkm1.i, z__3.i = ak.r *
bkm1.i + ak.i * bkm1.r;
z__2.r = z__3.r - bk.r, z__2.i = z__3.i - bk.i;
z_div(&z__1, &z__2, &denom);
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
i__2 = k + j * b_dim1;
z__3.r = akm1.r * bk.r - akm1.i * bk.i, z__3.i = akm1.r *
bk.i + akm1.i * bk.r;
z__2.r = z__3.r - bkm1.r, z__2.i = z__3.i - bkm1.i;
z_div(&z__1, &z__2, &denom);
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
/* L20: */
}
kc = kc - k + 1;
k += -2;
}
goto L10;
L30:
/* Next solve U'*X = B, overwriting B with X. */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = 1;
kc = 1;
L40:
/* If K > N, exit from loop. */
if (k > *n) {
goto L50;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Multiply by inv(U'(K)), where U(K) is the transformation */
/* stored in column K of A. */
if (k > 1) {
zlacgv_(nrhs, &b[k + b_dim1], ldb);
i__1 = k - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[b_offset]
, ldb, &ap[kc], &c__1, &c_b1, &b[k + b_dim1], ldb);
zlacgv_(nrhs, &b[k + b_dim1], ldb);
}
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
kc += k;
++k;
} else {
/* 2 x 2 diagonal block */
/* Multiply by inv(U'(K+1)), where U(K+1) is the transformation */
/* stored in columns K and K+1 of A. */
if (k > 1) {
zlacgv_(nrhs, &b[k + b_dim1], ldb);
i__1 = k - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[b_offset]
, ldb, &ap[kc], &c__1, &c_b1, &b[k + b_dim1], ldb);
zlacgv_(nrhs, &b[k + b_dim1], ldb);
zlacgv_(nrhs, &b[k + 1 + b_dim1], ldb);
i__1 = k - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[b_offset]
, ldb, &ap[kc + k], &c__1, &c_b1, &b[k + 1 + b_dim1],
ldb);
zlacgv_(nrhs, &b[k + 1 + b_dim1], ldb);
}
/* Interchange rows K and -IPIV(K). */
kp = -ipiv[k];
if (kp != k) {
zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
kc = kc + (k << 1) + 1;
k += 2;
}
goto L40;
L50:
;
} else {
/* Solve A*X = B, where A = L*D*L'. */
/* First solve L*D*X = B, overwriting B with X. */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = 1;
kc = 1;
L60:
/* If K > N, exit from loop. */
if (k > *n) {
goto L80;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
/* Multiply by inv(L(K)), where L(K) is the transformation */
/* stored in column K of A. */
if (k < *n) {
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zgeru_(&i__1, nrhs, &z__1, &ap[kc + 1], &c__1, &b[k + b_dim1],
ldb, &b[k + 1 + b_dim1], ldb);
}
/* Multiply by the inverse of the diagonal block. */
i__1 = kc;
s = 1. / ap[i__1].r;
zdscal_(nrhs, &s, &b[k + b_dim1], ldb);
kc = kc + *n - k + 1;
++k;
} else {
/* 2 x 2 diagonal block */
/* Interchange rows K+1 and -IPIV(K). */
kp = -ipiv[k];
if (kp != k + 1) {
zswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
/* Multiply by inv(L(K)), where L(K) is the transformation */
/* stored in columns K and K+1 of A. */
if (k < *n - 1) {
i__1 = *n - k - 1;
z__1.r = -1., z__1.i = -0.;
zgeru_(&i__1, nrhs, &z__1, &ap[kc + 2], &c__1, &b[k + b_dim1],
ldb, &b[k + 2 + b_dim1], ldb);
i__1 = *n - k - 1;
z__1.r = -1., z__1.i = -0.;
zgeru_(&i__1, nrhs, &z__1, &ap[kc + *n - k + 2], &c__1, &b[k
+ 1 + b_dim1], ldb, &b[k + 2 + b_dim1], ldb);
}
/* Multiply by the inverse of the diagonal block. */
i__1 = kc + 1;
akm1k.r = ap[i__1].r, akm1k.i = ap[i__1].i;
d_cnjg(&z__2, &akm1k);
z_div(&z__1, &ap[kc], &z__2);
akm1.r = z__1.r, akm1.i = z__1.i;
z_div(&z__1, &ap[kc + *n - k + 1], &akm1k);
ak.r = z__1.r, ak.i = z__1.i;
z__2.r = akm1.r * ak.r - akm1.i * ak.i, z__2.i = akm1.r * ak.i +
akm1.i * ak.r;
z__1.r = z__2.r - 1., z__1.i = z__2.i - 0.;
denom.r = z__1.r, denom.i = z__1.i;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
d_cnjg(&z__2, &akm1k);
z_div(&z__1, &b[k + j * b_dim1], &z__2);
bkm1.r = z__1.r, bkm1.i = z__1.i;
z_div(&z__1, &b[k + 1 + j * b_dim1], &akm1k);
bk.r = z__1.r, bk.i = z__1.i;
i__2 = k + j * b_dim1;
z__3.r = ak.r * bkm1.r - ak.i * bkm1.i, z__3.i = ak.r *
bkm1.i + ak.i * bkm1.r;
z__2.r = z__3.r - bk.r, z__2.i = z__3.i - bk.i;
z_div(&z__1, &z__2, &denom);
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
i__2 = k + 1 + j * b_dim1;
z__3.r = akm1.r * bk.r - akm1.i * bk.i, z__3.i = akm1.r *
bk.i + akm1.i * bk.r;
z__2.r = z__3.r - bkm1.r, z__2.i = z__3.i - bkm1.i;
z_div(&z__1, &z__2, &denom);
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
/* L70: */
}
kc = kc + (*n - k << 1) + 1;
k += 2;
}
goto L60;
L80:
/* Next solve L'*X = B, overwriting B with X. */
/* K is the main loop index, decreasing from N to 1 in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = *n;
kc = *n * (*n + 1) / 2 + 1;
L90:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L100;
}
kc -= *n - k + 1;
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Multiply by inv(L'(K)), where L(K) is the transformation */
/* stored in column K of A. */
if (k < *n) {
zlacgv_(nrhs, &b[k + b_dim1], ldb);
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[k + 1 +
b_dim1], ldb, &ap[kc + 1], &c__1, &c_b1, &b[k +
b_dim1], ldb);
zlacgv_(nrhs, &b[k + b_dim1], ldb);
}
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
--k;
} else {
/* 2 x 2 diagonal block */
/* Multiply by inv(L'(K-1)), where L(K-1) is the transformation */
/* stored in columns K-1 and K of A. */
if (k < *n) {
zlacgv_(nrhs, &b[k + b_dim1], ldb);
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[k + 1 +
b_dim1], ldb, &ap[kc + 1], &c__1, &c_b1, &b[k +
b_dim1], ldb);
zlacgv_(nrhs, &b[k + b_dim1], ldb);
zlacgv_(nrhs, &b[k - 1 + b_dim1], ldb);
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[k + 1 +
b_dim1], ldb, &ap[kc - (*n - k)], &c__1, &c_b1, &b[k
- 1 + b_dim1], ldb);
zlacgv_(nrhs, &b[k - 1 + b_dim1], ldb);
}
/* Interchange rows K and -IPIV(K). */
kp = -ipiv[k];
if (kp != k) {
zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
kc -= *n - k + 2;
k += -2;
}
goto L90;
L100:
;
}
return 0;
/* End of ZHPTRS */
} /* zhptrs_ */
/* Subroutine */ int zgttrf_(integer *n, doublecomplex *dl, doublecomplex *
d__, doublecomplex *du, doublecomplex *du2, integer *ipiv, integer *
info)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
/* Local variables */
static integer i__;
static doublecomplex fact, temp;
extern /* Subroutine */ int 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 */
/* June 30, 1999 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGTTRF computes an LU factorization of a complex tridiagonal matrix A */
/* using elimination with partial pivoting and row interchanges. */
/* The factorization has the form */
/* A = L * U */
/* where L is a product of permutation and unit lower bidiagonal */
/* matrices and U is upper triangular with nonzeros in only the main */
/* diagonal and first two superdiagonals. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. */
/* DL (input/output) COMPLEX*16 array, dimension (N-1) */
/* On entry, DL must contain the (n-1) sub-diagonal elements of */
/* A. */
/* On exit, DL is overwritten by the (n-1) multipliers that */
/* define the matrix L from the LU factorization of A. */
/* D (input/output) COMPLEX*16 array, dimension (N) */
/* On entry, D must contain the diagonal elements of A. */
/* On exit, D is overwritten by the n diagonal elements of the */
/* upper triangular matrix U from the LU factorization of A. */
/* DU (input/output) COMPLEX*16 array, dimension (N-1) */
/* On entry, DU must contain the (n-1) super-diagonal elements */
/* of A. */
/* On exit, DU is overwritten by the (n-1) elements of the first */
/* super-diagonal of U. */
/* DU2 (output) COMPLEX*16 array, dimension (N-2) */
/* On exit, DU2 is overwritten by the (n-2) elements of the */
/* second super-diagonal of U. */
/* IPIV (output) INTEGER array, dimension (N) */
/* The pivot indices; for 1 <= i <= n, row i of the matrix was */
/* interchanged with row IPIV(i). IPIV(i) will always be either */
/* i or i+1; IPIV(i) = i indicates a row interchange was not */
/* required. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* > 0: if INFO = k, U(k,k) is exactly zero. The factorization */
/* has been completed, but the factor U is exactly */
/* singular, and division by zero will occur if it is used */
/* to solve a system of equations. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--ipiv;
--du2;
--du;
--d__;
--dl;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
i__1 = -(*info);
xerbla_("ZGTTRF", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Initialize IPIV(i) = i and DU2(i) = 0 */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
ipiv[i__] = i__;
/* L10: */
}
i__1 = *n - 2;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
du2[i__2].r = 0., du2[i__2].i = 0.;
/* L20: */
}
i__1 = *n - 2;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__;
if ((d__1 = d__[i__2].r, abs(d__1)) + (d__2 = d_imag(&d__[i__]), abs(
d__2)) >= (d__3 = dl[i__3].r, abs(d__3)) + (d__4 = d_imag(&dl[
i__]), abs(d__4))) {
/* No row interchange required, eliminate DL(I) */
i__2 = i__;
if ((d__1 = d__[i__2].r, abs(d__1)) + (d__2 = d_imag(&d__[i__]),
abs(d__2)) != 0.) {
z_div(&z__1, &dl[i__], &d__[i__]);
fact.r = z__1.r, fact.i = z__1.i;
i__2 = i__;
dl[i__2].r = fact.r, dl[i__2].i = fact.i;
i__2 = i__ + 1;
i__3 = i__ + 1;
i__4 = i__;
z__2.r = fact.r * du[i__4].r - fact.i * du[i__4].i, z__2.i =
fact.r * du[i__4].i + fact.i * du[i__4].r;
z__1.r = d__[i__3].r - z__2.r, z__1.i = d__[i__3].i - z__2.i;
d__[i__2].r = z__1.r, d__[i__2].i = z__1.i;
}
} else {
/* Interchange rows I and I+1, eliminate DL(I) */
z_div(&z__1, &d__[i__], &dl[i__]);
fact.r = z__1.r, fact.i = z__1.i;
i__2 = i__;
i__3 = i__;
d__[i__2].r = dl[i__3].r, d__[i__2].i = dl[i__3].i;
i__2 = i__;
dl[i__2].r = fact.r, dl[i__2].i = fact.i;
i__2 = i__;
temp.r = du[i__2].r, temp.i = du[i__2].i;
i__2 = i__;
i__3 = i__ + 1;
du[i__2].r = d__[i__3].r, du[i__2].i = d__[i__3].i;
i__2 = i__ + 1;
i__3 = i__ + 1;
z__2.r = fact.r * d__[i__3].r - fact.i * d__[i__3].i, z__2.i =
fact.r * d__[i__3].i + fact.i * d__[i__3].r;
z__1.r = temp.r - z__2.r, z__1.i = temp.i - z__2.i;
d__[i__2].r = z__1.r, d__[i__2].i = z__1.i;
i__2 = i__;
i__3 = i__ + 1;
du2[i__2].r = du[i__3].r, du2[i__2].i = du[i__3].i;
i__2 = i__ + 1;
z__2.r = -fact.r, z__2.i = -fact.i;
i__3 = i__ + 1;
z__1.r = z__2.r * du[i__3].r - z__2.i * du[i__3].i, z__1.i =
z__2.r * du[i__3].i + z__2.i * du[i__3].r;
du[i__2].r = z__1.r, du[i__2].i = z__1.i;
ipiv[i__] = i__ + 1;
}
/* L30: */
}
if (*n > 1) {
i__ = *n - 1;
i__1 = i__;
i__2 = i__;
if ((d__1 = d__[i__1].r, abs(d__1)) + (d__2 = d_imag(&d__[i__]), abs(
d__2)) >= (d__3 = dl[i__2].r, abs(d__3)) + (d__4 = d_imag(&dl[
i__]), abs(d__4))) {
i__1 = i__;
if ((d__1 = d__[i__1].r, abs(d__1)) + (d__2 = d_imag(&d__[i__]),
abs(d__2)) != 0.) {
z_div(&z__1, &dl[i__], &d__[i__]);
fact.r = z__1.r, fact.i = z__1.i;
i__1 = i__;
dl[i__1].r = fact.r, dl[i__1].i = fact.i;
i__1 = i__ + 1;
i__2 = i__ + 1;
i__3 = i__;
z__2.r = fact.r * du[i__3].r - fact.i * du[i__3].i, z__2.i =
fact.r * du[i__3].i + fact.i * du[i__3].r;
z__1.r = d__[i__2].r - z__2.r, z__1.i = d__[i__2].i - z__2.i;
d__[i__1].r = z__1.r, d__[i__1].i = z__1.i;
}
} else {
z_div(&z__1, &d__[i__], &dl[i__]);
fact.r = z__1.r, fact.i = z__1.i;
i__1 = i__;
i__2 = i__;
d__[i__1].r = dl[i__2].r, d__[i__1].i = dl[i__2].i;
i__1 = i__;
dl[i__1].r = fact.r, dl[i__1].i = fact.i;
i__1 = i__;
temp.r = du[i__1].r, temp.i = du[i__1].i;
i__1 = i__;
i__2 = i__ + 1;
du[i__1].r = d__[i__2].r, du[i__1].i = d__[i__2].i;
i__1 = i__ + 1;
i__2 = i__ + 1;
z__2.r = fact.r * d__[i__2].r - fact.i * d__[i__2].i, z__2.i =
fact.r * d__[i__2].i + fact.i * d__[i__2].r;
z__1.r = temp.r - z__2.r, z__1.i = temp.i - z__2.i;
d__[i__1].r = z__1.r, d__[i__1].i = z__1.i;
ipiv[i__] = i__ + 1;
}
}
/* Check for a zero on the diagonal of U. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
if ((d__1 = d__[i__2].r, abs(d__1)) + (d__2 = d_imag(&d__[i__]), abs(
d__2)) == 0.) {
*info = i__;
goto L50;
}
/* L40: */
}
L50:
return 0;
/* End of ZGTTRF */
} /* zgttrf_ */
/* Double Complex */ void zlatm2_(doublecomplex * ret_val, integer *m,
integer *n, integer *i__, integer *j, integer *kl, integer *ku,
integer *idist, integer *iseed, doublecomplex *d__, integer *igrade,
doublecomplex *dl, doublecomplex *dr, integer *ipvtng, integer *iwork,
doublereal *sparse)
{
/* System generated locals */
integer i__1, i__2;
doublecomplex z__1, z__2, z__3;
/* Local variables */
integer isub, jsub;
doublecomplex ctemp;
extern doublereal dlaran_(integer *);
extern /* Double Complex */ void zlarnd_(doublecomplex *, integer *,
integer *);
/* -- LAPACK auxiliary test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLATM2 returns the (I,J) entry of a random matrix of dimension */
/* (M, N) described by the other paramters. It is called by the */
/* ZLATMR routine in order to build random test matrices. No error */
/* checking on parameters is done, because this routine is called in */
/* a tight loop by ZLATMR which has already checked the parameters. */
/* Use of ZLATM2 differs from CLATM3 in the order in which the random */
/* number generator is called to fill in random matrix entries. */
/* With ZLATM2, the generator is called to fill in the pivoted matrix */
/* columnwise. With ZLATM3, the generator is called to fill in the */
/* matrix columnwise, after which it is pivoted. Thus, ZLATM3 can */
/* be used to construct random matrices which differ only in their */
/* order of rows and/or columns. ZLATM2 is used to construct band */
/* matrices while avoiding calling the random number generator for */
/* entries outside the band (and therefore generating random numbers */
/* The matrix whose (I,J) entry is returned is constructed as */
/* follows (this routine only computes one entry): */
/* If I is outside (1..M) or J is outside (1..N), return zero */
/* (this is convenient for generating matrices in band format). */
/* Generate a matrix A with random entries of distribution IDIST. */
/* Set the diagonal to D. */
/* Grade the matrix, if desired, from the left (by DL) and/or */
/* from the right (by DR or DL) as specified by IGRADE. */
/* Permute, if desired, the rows and/or columns as specified by */
/* IPVTNG and IWORK. */
/* Band the matrix to have lower bandwidth KL and upper */
/* bandwidth KU. */
/* Set random entries to zero as specified by SPARSE. */
/* Arguments */
/* ========= */
/* M - INTEGER */
/* Number of rows of matrix. Not modified. */
/* N - INTEGER */
/* Number of columns of matrix. Not modified. */
/* I - INTEGER */
/* Row of entry to be returned. Not modified. */
/* J - INTEGER */
/* Column of entry to be returned. Not modified. */
/* KL - INTEGER */
/* Lower bandwidth. Not modified. */
/* KU - INTEGER */
/* Upper bandwidth. Not modified. */
/* IDIST - INTEGER */
/* On entry, IDIST specifies the type of distribution to be */
/* used to generate a random matrix . */
/* 1 => real and imaginary parts each UNIFORM( 0, 1 ) */
/* 2 => real and imaginary parts each UNIFORM( -1, 1 ) */
/* 3 => real and imaginary parts each NORMAL( 0, 1 ) */
/* 4 => complex number uniform in DISK( 0 , 1 ) */
/* Not modified. */
/* ISEED - INTEGER array of dimension ( 4 ) */
/* Seed for random number generator. */
/* Changed on exit. */
/* D - COMPLEX*16 array of dimension ( MIN( I , J ) ) */
/* Diagonal entries of matrix. Not modified. */
/* IGRADE - INTEGER */
/* Specifies grading of matrix as follows: */
/* 0 => no grading */
/* 1 => matrix premultiplied by diag( DL ) */
/* 2 => matrix postmultiplied by diag( DR ) */
/* 3 => matrix premultiplied by diag( DL ) and */
/* postmultiplied by diag( DR ) */
/* 4 => matrix premultiplied by diag( DL ) and */
/* postmultiplied by inv( diag( DL ) ) */
/* 5 => matrix premultiplied by diag( DL ) and */
/* postmultiplied by diag( CONJG(DL) ) */
/* 6 => matrix premultiplied by diag( DL ) and */
/* postmultiplied by diag( DL ) */
/* Not modified. */
/* DL - COMPLEX*16 array ( I or J, as appropriate ) */
/* Left scale factors for grading matrix. Not modified. */
/* DR - COMPLEX*16 array ( I or J, as appropriate ) */
/* Right scale factors for grading matrix. Not modified. */
/* IPVTNG - INTEGER */
/* On entry specifies pivoting permutations as follows: */
/* 0 => none. */
/* 1 => row pivoting. */
/* 2 => column pivoting. */
/* 3 => full pivoting, i.e., on both sides. */
/* Not modified. */
/* IWORK - INTEGER array ( I or J, as appropriate ) */
/* This array specifies the permutation used. The */
/* row (or column) in position K was originally in */
/* position IWORK( K ). */
/* This differs from IWORK for ZLATM3. Not modified. */
/* SPARSE - DOUBLE PRECISION between 0. and 1. */
/* On entry specifies the sparsity of the matrix */
/* if sparse matix is to be generated. */
/* SPARSE should lie between 0 and 1. */
/* A uniform ( 0, 1 ) random number x is generated and */
/* compared to SPARSE; if x is larger the matrix entry */
/* is unchanged and if x is smaller the entry is set */
/* to zero. Thus on the average a fraction SPARSE of the */
/* entries will be set to zero. */
/* Not modified. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* ----------------------------------------------------------------------- */
/* .. Executable Statements .. */
/* Check for I and J in range */
/* Parameter adjustments */
--iwork;
--dr;
--dl;
--d__;
--iseed;
/* Function Body */
if (*i__ < 1 || *i__ > *m || *j < 1 || *j > *n) {
ret_val->r = 0., ret_val->i = 0.;
return ;
}
/* Check for banding */
if (*j > *i__ + *ku || *j < *i__ - *kl) {
ret_val->r = 0., ret_val->i = 0.;
return ;
}
/* Check for sparsity */
if (*sparse > 0.) {
if (dlaran_(&iseed[1]) < *sparse) {
ret_val->r = 0., ret_val->i = 0.;
return ;
}
}
/* Compute subscripts depending on IPVTNG */
if (*ipvtng == 0) {
isub = *i__;
jsub = *j;
} else if (*ipvtng == 1) {
isub = iwork[*i__];
jsub = *j;
} else if (*ipvtng == 2) {
isub = *i__;
jsub = iwork[*j];
} else if (*ipvtng == 3) {
isub = iwork[*i__];
jsub = iwork[*j];
}
/* Compute entry and grade it according to IGRADE */
if (isub == jsub) {
i__1 = isub;
ctemp.r = d__[i__1].r, ctemp.i = d__[i__1].i;
} else {
zlarnd_(&z__1, idist, &iseed[1]);
ctemp.r = z__1.r, ctemp.i = z__1.i;
}
if (*igrade == 1) {
i__1 = isub;
z__1.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__1.i =
ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
ctemp.r = z__1.r, ctemp.i = z__1.i;
} else if (*igrade == 2) {
i__1 = jsub;
z__1.r = ctemp.r * dr[i__1].r - ctemp.i * dr[i__1].i, z__1.i =
ctemp.r * dr[i__1].i + ctemp.i * dr[i__1].r;
ctemp.r = z__1.r, ctemp.i = z__1.i;
} else if (*igrade == 3) {
i__1 = isub;
z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i =
ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
i__2 = jsub;
z__1.r = z__2.r * dr[i__2].r - z__2.i * dr[i__2].i, z__1.i = z__2.r *
dr[i__2].i + z__2.i * dr[i__2].r;
ctemp.r = z__1.r, ctemp.i = z__1.i;
} else if (*igrade == 4 && isub != jsub) {
i__1 = isub;
z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i =
ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
z_div(&z__1, &z__2, &dl[jsub]);
ctemp.r = z__1.r, ctemp.i = z__1.i;
} else if (*igrade == 5) {
i__1 = isub;
z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i =
ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
d_cnjg(&z__3, &dl[jsub]);
z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * z__3.i
+ z__2.i * z__3.r;
ctemp.r = z__1.r, ctemp.i = z__1.i;
} else if (*igrade == 6) {
i__1 = isub;
z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i =
ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
i__2 = jsub;
z__1.r = z__2.r * dl[i__2].r - z__2.i * dl[i__2].i, z__1.i = z__2.r *
dl[i__2].i + z__2.i * dl[i__2].r;
ctemp.r = z__1.r, ctemp.i = z__1.i;
}
ret_val->r = ctemp.r, ret_val->i = ctemp.i;
return ;
/* End of ZLATM2 */
} /* zlatm2_ */
/* Subroutine */ int zgetf2_(integer *m, integer *n, doublecomplex *a,
integer *lda, integer *ipiv, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublecomplex z__1;
/* Builtin functions */
double z_abs(doublecomplex *);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j, jp;
doublereal sfmin;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *), zgeru_(integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *), zswap_(integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal dlamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer izamax_(integer *, doublecomplex *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGETF2 computes an LU factorization of a general m-by-n matrix A */
/* using partial pivoting with row interchanges. */
/* The factorization has the form */
/* A = P * L * U */
/* where P is a permutation matrix, L is lower triangular with unit */
/* diagonal elements (lower trapezoidal if m > n), and U is upper */
/* triangular (upper trapezoidal if m < n). */
/* This is the right-looking Level 2 BLAS version of the algorithm. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the m by n matrix to be factored. */
/* On exit, the factors L and U from the factorization */
/* A = P*L*U; the unit diagonal elements of L are not stored. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* IPIV (output) INTEGER array, dimension (min(M,N)) */
/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
/* matrix was interchanged with row IPIV(i). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* > 0: if INFO = k, U(k,k) is exactly zero. The factorization */
/* has been completed, but the factor U is exactly */
/* singular, and division by zero will occur if it is used */
/* to solve a system of equations. */
/* ===================================================================== */
/* .. 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;
--ipiv;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGETF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
/* Compute machine safe minimum */
sfmin = dlamch_("S");
i__1 = min(*m,*n);
for (j = 1; j <= i__1; ++j) {
/* Find pivot and test for singularity. */
i__2 = *m - j + 1;
jp = j - 1 + izamax_(&i__2, &a[j + j * a_dim1], &c__1);
ipiv[j] = jp;
i__2 = jp + j * a_dim1;
if (a[i__2].r != 0. || a[i__2].i != 0.) {
/* Apply the interchange to columns 1:N. */
if (jp != j) {
zswap_(n, &a[j + a_dim1], lda, &a[jp + a_dim1], lda);
}
/* Compute elements J+1:M of J-th column. */
if (j < *m) {
if (z_abs(&a[j + j * a_dim1]) >= sfmin) {
i__2 = *m - j;
z_div(&z__1, &c_b1, &a[j + j * a_dim1]);
zscal_(&i__2, &z__1, &a[j + 1 + j * a_dim1], &c__1);
} else {
i__2 = *m - j;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = j + i__ + j * a_dim1;
z_div(&z__1, &a[j + i__ + j * a_dim1], &a[j + j *
a_dim1]);
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L20: */
}
}
}
} else if (*info == 0) {
*info = j;
}
if (j < min(*m,*n)) {
/* Update trailing submatrix. */
i__2 = *m - j;
i__3 = *n - j;
z__1.r = -1., z__1.i = -0.;
zgeru_(&i__2, &i__3, &z__1, &a[j + 1 + j * a_dim1], &c__1, &a[j +
(j + 1) * a_dim1], lda, &a[j + 1 + (j + 1) * a_dim1], lda)
;
}
/* L10: */
}
return 0;
/* End of ZGETF2 */
} /* zgetf2_ */
int
sp_ztrsv(char *uplo, char *trans, char *diag, SuperMatrix *L,
SuperMatrix *U, doublecomplex *x, int *info)
{
/*
* Purpose
* =======
*
* sp_ztrsv() solves one of the systems of equations
* A*x = b, or A'*x = b,
* where b and x are n element vectors and A is a sparse unit , or
* non-unit, upper or lower triangular matrix.
* No test for singularity or near-singularity is included in this
* routine. Such tests must be performed before calling this routine.
*
* Parameters
* ==========
*
* uplo - (input) char*
* On entry, uplo specifies whether the matrix is an upper or
* lower triangular matrix as follows:
* uplo = 'U' or 'u' A is an upper triangular matrix.
* uplo = 'L' or 'l' A is a lower triangular matrix.
*
* trans - (input) char*
* On entry, trans specifies the equations to be solved as
* follows:
* trans = 'N' or 'n' A*x = b.
* trans = 'T' or 't' A'*x = b.
* trans = 'C' or 'c' A'*x = b.
*
* diag - (input) char*
* On entry, diag specifies whether or not A is unit
* triangular as follows:
* diag = 'U' or 'u' A is assumed to be unit triangular.
* diag = 'N' or 'n' A is not assumed to be unit
* triangular.
*
* L - (input) SuperMatrix*
* The factor L from the factorization Pr*A*Pc=L*U. Use
* compressed row subscripts storage for supernodes,
* i.e., L has types: Stype = SC, Dtype = SLU_Z, Mtype = TRLU.
*
* U - (input) SuperMatrix*
* The factor U from the factorization Pr*A*Pc=L*U.
* U has types: Stype = NC, Dtype = SLU_Z, Mtype = TRU.
*
* x - (input/output) doublecomplex*
* Before entry, the incremented array X must contain the n
* element right-hand side vector b. On exit, X is overwritten
* with the solution vector x.
*
* info - (output) int*
* If *info = -i, the i-th argument had an illegal value.
*
*/
#ifdef _CRAY
_fcd ftcs1 = _cptofcd("L", strlen("L")),
ftcs2 = _cptofcd("N", strlen("N")),
ftcs3 = _cptofcd("U", strlen("U"));
#endif
SCformat *Lstore;
NCformat *Ustore;
doublecomplex *Lval, *Uval;
int incx = 1, incy = 1;
doublecomplex alpha = {1.0, 0.0}, beta = {1.0, 0.0};
doublecomplex comp_zero = {0.0, 0.0};
int nrow;
int fsupc, nsupr, nsupc, luptr, istart, irow;
int i, k, iptr, jcol;
doublecomplex *work;
flops_t solve_ops;
extern SuperLUStat_t SuperLUStat;
/* Test the input parameters */
*info = 0;
if ( !lsame_(uplo,"L") && !lsame_(uplo, "U") ) *info = -1;
else if ( !lsame_(trans, "N") && !lsame_(trans, "T") ) *info = -2;
else if ( !lsame_(diag, "U") && !lsame_(diag, "N") ) *info = -3;
else if ( L->nrow != L->ncol || L->nrow < 0 ) *info = -4;
else if ( U->nrow != U->ncol || U->nrow < 0 ) *info = -5;
if ( *info ) {
i = -(*info);
xerbla_("sp_ztrsv", &i);
return 0;
}
Lstore = L->Store;
Lval = Lstore->nzval;
Ustore = U->Store;
Uval = Ustore->nzval;
solve_ops = 0;
if ( !(work = doublecomplexCalloc(L->nrow)) )
ABORT("Malloc fails for work in sp_ztrsv().");
if ( lsame_(trans, "N") ) { /* Form x := inv(A)*x. */
if ( lsame_(uplo, "L") ) {
/* Form x := inv(L)*x */
if ( L->nrow == 0 ) return 0; /* Quick return */
for (k = 0; k <= Lstore->nsuper; k++) {
fsupc = L_FST_SUPC(k);
istart = L_SUB_START(fsupc);
nsupr = L_SUB_START(fsupc+1) - istart;
nsupc = L_FST_SUPC(k+1) - fsupc;
luptr = L_NZ_START(fsupc);
nrow = nsupr - nsupc;
solve_ops += 4 * nsupc * (nsupc - 1);
solve_ops += 8 * nrow * nsupc;
if ( nsupc == 1 ) {
for (iptr=istart+1; iptr < L_SUB_START(fsupc+1); ++iptr) {
irow = L_SUB(iptr);
++luptr;
zz_mult(&comp_zero, &x[fsupc], &Lval[luptr]);
z_sub(&x[irow], &x[irow], &comp_zero);
}
} else {
#ifdef USE_VENDOR_BLAS
#ifdef _CRAY
CTRSV(ftcs1, ftcs2, ftcs3, &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
CGEMV(ftcs2, &nrow, &nsupc, &alpha, &Lval[luptr+nsupc],
&nsupr, &x[fsupc], &incx, &beta, &work[0], &incy);
#else
ztrsv_("L", "N", "U", &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
zgemv_("N", &nrow, &nsupc, &alpha, &Lval[luptr+nsupc],
&nsupr, &x[fsupc], &incx, &beta, &work[0], &incy);
#endif
#else
zlsolve ( nsupr, nsupc, &Lval[luptr], &x[fsupc]);
zmatvec ( nsupr, nsupr-nsupc, nsupc, &Lval[luptr+nsupc],
&x[fsupc], &work[0] );
#endif
iptr = istart + nsupc;
for (i = 0; i < nrow; ++i, ++iptr) {
irow = L_SUB(iptr);
z_sub(&x[irow], &x[irow], &work[i]); /* Scatter */
work[i] = comp_zero;
}
}
} /* for k ... */
} else {
/* Form x := inv(U)*x */
if ( U->nrow == 0 ) return 0; /* Quick return */
for (k = Lstore->nsuper; k >= 0; k--) {
fsupc = L_FST_SUPC(k);
nsupr = L_SUB_START(fsupc+1) - L_SUB_START(fsupc);
nsupc = L_FST_SUPC(k+1) - fsupc;
luptr = L_NZ_START(fsupc);
solve_ops += 4 * nsupc * (nsupc + 1);
if ( nsupc == 1 ) {
z_div(&x[fsupc], &x[fsupc], &Lval[luptr]);
for (i = U_NZ_START(fsupc); i < U_NZ_START(fsupc+1); ++i) {
irow = U_SUB(i);
zz_mult(&comp_zero, &x[fsupc], &Uval[i]);
z_sub(&x[irow], &x[irow], &comp_zero);
}
} else {
#ifdef USE_VENDOR_BLAS
#ifdef _CRAY
CTRSV(ftcs3, ftcs2, ftcs2, &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#else
ztrsv_("U", "N", "N", &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#endif
#else
zusolve ( nsupr, nsupc, &Lval[luptr], &x[fsupc] );
#endif
for (jcol = fsupc; jcol < L_FST_SUPC(k+1); jcol++) {
solve_ops += 8*(U_NZ_START(jcol+1) - U_NZ_START(jcol));
for (i = U_NZ_START(jcol); i < U_NZ_START(jcol+1);
i++) {
irow = U_SUB(i);
zz_mult(&comp_zero, &x[jcol], &Uval[i]);
z_sub(&x[irow], &x[irow], &comp_zero);
}
}
}
} /* for k ... */
}
} else { /* Form x := inv(A')*x */
if ( lsame_(uplo, "L") ) {
/* Form x := inv(L')*x */
if ( L->nrow == 0 ) return 0; /* Quick return */
for (k = Lstore->nsuper; k >= 0; --k) {
fsupc = L_FST_SUPC(k);
istart = L_SUB_START(fsupc);
nsupr = L_SUB_START(fsupc+1) - istart;
nsupc = L_FST_SUPC(k+1) - fsupc;
luptr = L_NZ_START(fsupc);
solve_ops += 8 * (nsupr - nsupc) * nsupc;
for (jcol = fsupc; jcol < L_FST_SUPC(k+1); jcol++) {
iptr = istart + nsupc;
for (i = L_NZ_START(jcol) + nsupc;
i < L_NZ_START(jcol+1); i++) {
irow = L_SUB(iptr);
zz_mult(&comp_zero, &x[irow], &Lval[i]);
z_sub(&x[jcol], &x[jcol], &comp_zero);
iptr++;
}
}
if ( nsupc > 1 ) {
solve_ops += 4 * nsupc * (nsupc - 1);
#ifdef _CRAY
ftcs1 = _cptofcd("L", strlen("L"));
ftcs2 = _cptofcd("T", strlen("T"));
ftcs3 = _cptofcd("U", strlen("U"));
CTRSV(ftcs1, ftcs2, ftcs3, &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#else
ztrsv_("L", "T", "U", &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#endif
}
}
} else {
/* Form x := inv(U')*x */
if ( U->nrow == 0 ) return 0; /* Quick return */
for (k = 0; k <= Lstore->nsuper; k++) {
fsupc = L_FST_SUPC(k);
nsupr = L_SUB_START(fsupc+1) - L_SUB_START(fsupc);
nsupc = L_FST_SUPC(k+1) - fsupc;
luptr = L_NZ_START(fsupc);
for (jcol = fsupc; jcol < L_FST_SUPC(k+1); jcol++) {
solve_ops += 8*(U_NZ_START(jcol+1) - U_NZ_START(jcol));
for (i = U_NZ_START(jcol); i < U_NZ_START(jcol+1); i++) {
irow = U_SUB(i);
zz_mult(&comp_zero, &x[irow], &Uval[i]);
z_sub(&x[jcol], &x[jcol], &comp_zero);
}
}
solve_ops += 4 * nsupc * (nsupc + 1);
if ( nsupc == 1 ) {
z_div(&x[fsupc], &x[fsupc], &Lval[luptr]);
} else {
#ifdef _CRAY
ftcs1 = _cptofcd("U", strlen("U"));
ftcs2 = _cptofcd("T", strlen("T"));
ftcs3 = _cptofcd("N", strlen("N"));
CTRSV( ftcs1, ftcs2, ftcs3, &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#else
ztrsv_("U", "T", "N", &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#endif
}
} /* for k ... */
}
}
SuperLUStat.ops[SOLVE] += solve_ops;
SUPERLU_FREE(work);
return 0;
}
/* Subroutine */ int ztptri_(char *uplo, char *diag, integer *n,
doublecomplex *ap, integer *info)
{
/* -- LAPACK 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
=======
ZTPTRI computes the inverse of a complex upper or lower triangular
matrix A stored in packed format.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': A is upper triangular;
= 'L': A is lower triangular.
DIAG (input) CHARACTER*1
= 'N': A is non-unit triangular;
= 'U': A is unit triangular.
N (input) INTEGER
The order of the matrix A. N >= 0.
AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
On entry, the upper or lower triangular matrix A, stored
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.
See below for further details.
On exit, the (triangular) inverse of the original matrix, in
the same packed storage format.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, A(i,i) is exactly zero. The triangular
matrix is singular and its inverse can not be computed.
Further Details
===============
A triangular matrix A can be transferred to packed storage using one
of the following program segments:
UPLO = 'U': UPLO = 'L':
JC = 1 JC = 1
DO 2 J = 1, N DO 2 J = 1, N
DO 1 I = 1, J DO 1 I = J, N
AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J)
1 CONTINUE 1 CONTINUE
JC = JC + J JC = JC + N - J + 1
2 CONTINUE 2 CONTINUE
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static doublecomplex c_b1 = {1.,0.};
static integer c__1 = 1;
/* System generated locals */
integer i__1, i__2;
doublecomplex z__1;
/* Builtin functions */
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
/* Local variables */
static integer j;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
static logical upper;
extern /* Subroutine */ int ztpmv_(char *, char *, char *, integer *,
doublecomplex *, doublecomplex *, integer *);
static integer jc, jj;
extern /* Subroutine */ int xerbla_(char *, integer *);
static integer jclast;
static logical nounit;
static doublecomplex ajj;
#define AP(I) ap[(I)-1]
*info = 0;
upper = lsame_(uplo, "U");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZTPTRI", &i__1);
return 0;
}
/* Check for singularity if non-unit. */
if (nounit) {
if (upper) {
jj = 0;
i__1 = *n;
for (*info = 1; *info <= i__1; ++(*info)) {
jj += *info;
i__2 = jj;
if (AP(jj).r == 0. && AP(jj).i == 0.) {
return 0;
}
/* L10: */
}
} else {
jj = 1;
i__1 = *n;
for (*info = 1; *info <= i__1; ++(*info)) {
i__2 = jj;
if (AP(jj).r == 0. && AP(jj).i == 0.) {
return 0;
}
jj = jj + *n - *info + 1;
/* L20: */
}
}
*info = 0;
}
if (upper) {
/* Compute inverse of upper triangular matrix. */
jc = 1;
i__1 = *n;
for (j = 1; j <= *n; ++j) {
if (nounit) {
i__2 = jc + j - 1;
z_div(&z__1, &c_b1, &AP(jc + j - 1));
AP(jc+j-1).r = z__1.r, AP(jc+j-1).i = z__1.i;
i__2 = jc + j - 1;
z__1.r = -AP(jc+j-1).r, z__1.i = -AP(jc+j-1).i;
ajj.r = z__1.r, ajj.i = z__1.i;
} else {
z__1.r = -1., z__1.i = 0.;
ajj.r = z__1.r, ajj.i = z__1.i;
}
/* Compute elements 1:j-1 of j-th column. */
i__2 = j - 1;
ztpmv_("Upper", "No transpose", diag, &i__2, &AP(1), &AP(jc), &
c__1);
i__2 = j - 1;
zscal_(&i__2, &ajj, &AP(jc), &c__1);
jc += j;
/* L30: */
}
} else {
/* Compute inverse of lower triangular matrix. */
jc = *n * (*n + 1) / 2;
for (j = *n; j >= 1; --j) {
if (nounit) {
i__1 = jc;
z_div(&z__1, &c_b1, &AP(jc));
AP(jc).r = z__1.r, AP(jc).i = z__1.i;
i__1 = jc;
z__1.r = -AP(jc).r, z__1.i = -AP(jc).i;
ajj.r = z__1.r, ajj.i = z__1.i;
} else {
z__1.r = -1., z__1.i = 0.;
ajj.r = z__1.r, ajj.i = z__1.i;
}
if (j < *n) {
/* Compute elements j+1:n of j-th column. */
i__1 = *n - j;
ztpmv_("Lower", "No transpose", diag, &i__1, &AP(jclast), &AP(
jc + 1), &c__1);
i__1 = *n - j;
zscal_(&i__1, &ajj, &AP(jc + 1), &c__1);
}
jclast = jc;
jc = jc - *n + j - 2;
/* L40: */
}
}
return 0;
/* End of ZTPTRI */
} /* ztptri_ */
void
zgstrs (trans_t trans, SuperMatrix *L, SuperMatrix *U,
int *perm_c, int *perm_r, SuperMatrix *B,
SuperLUStat_t *stat, int *info)
{
/*
* Purpose
* =======
*
* ZGSTRS solves a system of linear equations A*X=B or A'*X=B
* with A sparse and B dense, using the LU factorization computed by
* ZGSTRF.
*
* See supermatrix.h for the definition of 'SuperMatrix' structure.
*
* Arguments
* =========
*
* trans (input) trans_t
* Specifies the form of the system of equations:
* = NOTRANS: A * X = B (No transpose)
* = TRANS: A'* X = B (Transpose)
* = CONJ: A**H * X = B (Conjugate transpose)
*
* L (input) SuperMatrix*
* The factor L from the factorization Pr*A*Pc=L*U as computed by
* zgstrf(). Use compressed row subscripts storage for supernodes,
* i.e., L has types: Stype = SLU_SC, Dtype = SLU_Z, Mtype = SLU_TRLU.
*
* U (input) SuperMatrix*
* The factor U from the factorization Pr*A*Pc=L*U as computed by
* zgstrf(). Use column-wise storage scheme, i.e., U has types:
* Stype = SLU_NC, Dtype = SLU_Z, Mtype = SLU_TRU.
*
* perm_c (input) int*, dimension (L->ncol)
* Column permutation vector, which defines the
* permutation matrix Pc; perm_c[i] = j means column i of A is
* in position j in A*Pc.
*
* perm_r (input) int*, dimension (L->nrow)
* Row permutation vector, which defines the permutation matrix Pr;
* perm_r[i] = j means row i of A is in position j in Pr*A.
*
* B (input/output) SuperMatrix*
* B has types: Stype = SLU_DN, Dtype = SLU_Z, Mtype = SLU_GE.
* On entry, the right hand side matrix.
* On exit, the solution matrix if info = 0;
*
* stat (output) SuperLUStat_t*
* Record the statistics on runtime and floating-point operation count.
* See util.h for the definition of 'SuperLUStat_t'.
*
* info (output) int*
* = 0: successful exit
* < 0: if info = -i, the i-th argument had an illegal value
*
*/
#ifdef _CRAY
_fcd ftcs1, ftcs2, ftcs3, ftcs4;
#endif
int incx = 1, incy = 1;
#ifdef USE_VENDOR_BLAS
doublecomplex alpha = {1.0, 0.0}, beta = {1.0, 0.0};
doublecomplex *work_col;
#endif
doublecomplex temp_comp;
DNformat *Bstore;
doublecomplex *Bmat;
SCformat *Lstore;
NCformat *Ustore;
doublecomplex *Lval, *Uval;
int fsupc, nrow, nsupr, nsupc, luptr, istart, irow;
int i, j, k, iptr, jcol, n, ldb, nrhs;
doublecomplex *work, *rhs_work, *soln;
flops_t solve_ops;
void zprint_soln();
/* Test input parameters ... */
*info = 0;
Bstore = B->Store;
ldb = Bstore->lda;
nrhs = B->ncol;
if ( trans != NOTRANS && trans != TRANS && trans != CONJ ) *info = -1;
else if ( L->nrow != L->ncol || L->nrow < 0 ||
L->Stype != SLU_SC || L->Dtype != SLU_Z || L->Mtype != SLU_TRLU )
*info = -2;
else if ( U->nrow != U->ncol || U->nrow < 0 ||
U->Stype != SLU_NC || U->Dtype != SLU_Z || U->Mtype != SLU_TRU )
*info = -3;
else if ( ldb < SUPERLU_MAX(0, L->nrow) ||
B->Stype != SLU_DN || B->Dtype != SLU_Z || B->Mtype != SLU_GE )
*info = -6;
if ( *info ) {
i = -(*info);
xerbla_("zgstrs", &i);
return;
}
n = L->nrow;
work = doublecomplexCalloc(n * nrhs);
if ( !work ) ABORT("Malloc fails for local work[].");
soln = doublecomplexMalloc(n);
if ( !soln ) ABORT("Malloc fails for local soln[].");
Bmat = Bstore->nzval;
Lstore = L->Store;
Lval = Lstore->nzval;
Ustore = U->Store;
Uval = Ustore->nzval;
solve_ops = 0;
if ( trans == NOTRANS ) {
/* Permute right hand sides to form Pr*B */
for (i = 0; i < nrhs; i++) {
rhs_work = &Bmat[i*ldb];
for (k = 0; k < n; k++) soln[perm_r[k]] = rhs_work[k];
for (k = 0; k < n; k++) rhs_work[k] = soln[k];
}
/* Forward solve PLy=Pb. */
for (k = 0; k <= Lstore->nsuper; k++) {
fsupc = L_FST_SUPC(k);
istart = L_SUB_START(fsupc);
nsupr = L_SUB_START(fsupc+1) - istart;
nsupc = L_FST_SUPC(k+1) - fsupc;
nrow = nsupr - nsupc;
solve_ops += 4 * nsupc * (nsupc - 1) * nrhs;
solve_ops += 8 * nrow * nsupc * nrhs;
if ( nsupc == 1 ) {
for (j = 0; j < nrhs; j++) {
rhs_work = &Bmat[j*ldb];
luptr = L_NZ_START(fsupc);
for (iptr=istart+1; iptr < L_SUB_START(fsupc+1); iptr++){
irow = L_SUB(iptr);
++luptr;
zz_mult(&temp_comp, &rhs_work[fsupc], &Lval[luptr]);
z_sub(&rhs_work[irow], &rhs_work[irow], &temp_comp);
}
}
} else {
luptr = L_NZ_START(fsupc);
#ifdef USE_VENDOR_BLAS
#ifdef _CRAY
ftcs1 = _cptofcd("L", strlen("L"));
ftcs2 = _cptofcd("N", strlen("N"));
ftcs3 = _cptofcd("U", strlen("U"));
CTRSM( ftcs1, ftcs1, ftcs2, ftcs3, &nsupc, &nrhs, &alpha,
&Lval[luptr], &nsupr, &Bmat[fsupc], &ldb);
CGEMM( ftcs2, ftcs2, &nrow, &nrhs, &nsupc, &alpha,
&Lval[luptr+nsupc], &nsupr, &Bmat[fsupc], &ldb,
&beta, &work[0], &n );
#else
ztrsm_("L", "L", "N", "U", &nsupc, &nrhs, &alpha,
&Lval[luptr], &nsupr, &Bmat[fsupc], &ldb);
zgemm_( "N", "N", &nrow, &nrhs, &nsupc, &alpha,
&Lval[luptr+nsupc], &nsupr, &Bmat[fsupc], &ldb,
&beta, &work[0], &n );
#endif
for (j = 0; j < nrhs; j++) {
rhs_work = &Bmat[j*ldb];
work_col = &work[j*n];
iptr = istart + nsupc;
for (i = 0; i < nrow; i++) {
irow = L_SUB(iptr);
z_sub(&rhs_work[irow], &rhs_work[irow], &work_col[i]);
work_col[i].r = 0.0;
work_col[i].i = 0.0;
iptr++;
}
}
#else
for (j = 0; j < nrhs; j++) {
rhs_work = &Bmat[j*ldb];
zlsolve (nsupr, nsupc, &Lval[luptr], &rhs_work[fsupc]);
zmatvec (nsupr, nrow, nsupc, &Lval[luptr+nsupc],
&rhs_work[fsupc], &work[0] );
iptr = istart + nsupc;
for (i = 0; i < nrow; i++) {
irow = L_SUB(iptr);
z_sub(&rhs_work[irow], &rhs_work[irow], &work[i]);
work[i].r = 0.;
work[i].i = 0.;
iptr++;
}
}
#endif
} /* else ... */
} /* for L-solve */
#ifdef DEBUG
printf("After L-solve: y=\n");
zprint_soln(n, nrhs, Bmat);
#endif
/*
* Back solve Ux=y.
*/
for (k = Lstore->nsuper; k >= 0; k--) {
fsupc = L_FST_SUPC(k);
istart = L_SUB_START(fsupc);
nsupr = L_SUB_START(fsupc+1) - istart;
nsupc = L_FST_SUPC(k+1) - fsupc;
luptr = L_NZ_START(fsupc);
solve_ops += 4 * nsupc * (nsupc + 1) * nrhs;
if ( nsupc == 1 ) {
rhs_work = &Bmat[0];
for (j = 0; j < nrhs; j++) {
z_div(&rhs_work[fsupc], &rhs_work[fsupc], &Lval[luptr]);
rhs_work += ldb;
}
} else {
#ifdef USE_VENDOR_BLAS
#ifdef _CRAY
ftcs1 = _cptofcd("L", strlen("L"));
ftcs2 = _cptofcd("U", strlen("U"));
ftcs3 = _cptofcd("N", strlen("N"));
CTRSM( ftcs1, ftcs2, ftcs3, ftcs3, &nsupc, &nrhs, &alpha,
&Lval[luptr], &nsupr, &Bmat[fsupc], &ldb);
#else
ztrsm_("L", "U", "N", "N", &nsupc, &nrhs, &alpha,
&Lval[luptr], &nsupr, &Bmat[fsupc], &ldb);
#endif
#else
for (j = 0; j < nrhs; j++)
zusolve ( nsupr, nsupc, &Lval[luptr], &Bmat[fsupc+j*ldb] );
#endif
}
for (j = 0; j < nrhs; ++j) {
rhs_work = &Bmat[j*ldb];
for (jcol = fsupc; jcol < fsupc + nsupc; jcol++) {
solve_ops += 8*(U_NZ_START(jcol+1) - U_NZ_START(jcol));
for (i = U_NZ_START(jcol); i < U_NZ_START(jcol+1); i++ ){
irow = U_SUB(i);
zz_mult(&temp_comp, &rhs_work[jcol], &Uval[i]);
z_sub(&rhs_work[irow], &rhs_work[irow], &temp_comp);
}
}
}
} /* for U-solve */
#ifdef DEBUG
printf("After U-solve: x=\n");
zprint_soln(n, nrhs, Bmat);
#endif
/* Compute the final solution X := Pc*X. */
for (i = 0; i < nrhs; i++) {
rhs_work = &Bmat[i*ldb];
for (k = 0; k < n; k++) soln[k] = rhs_work[perm_c[k]];
for (k = 0; k < n; k++) rhs_work[k] = soln[k];
}
stat->ops[SOLVE] = solve_ops;
} else { /* Solve A'*X=B */
/* Permute right hand sides to form Pc'*B. */
for (i = 0; i < nrhs; i++) {
rhs_work = &Bmat[i*ldb];
for (k = 0; k < n; k++) soln[perm_c[k]] = rhs_work[k];
for (k = 0; k < n; k++) rhs_work[k] = soln[k];
}
stat->ops[SOLVE] = 0;
if (trans == TRANS) {
for (k = 0; k < nrhs; ++k) {
/* Multiply by inv(U'). */
sp_ztrsv("U", "T", "N", L, U, &Bmat[k*ldb], stat, info);
/* Multiply by inv(L'). */
sp_ztrsv("L", "T", "U", L, U, &Bmat[k*ldb], stat, info);
}
}
else {
for (k = 0; k < nrhs; ++k) {
/* Multiply by inv(U'). */
sp_ztrsv("U", "C", "N", L, U, &Bmat[k*ldb], stat, info);
/* Multiply by inv(L'). */
sp_ztrsv("L", "C", "U", L, U, &Bmat[k*ldb], stat, info);
}
}
/* Compute the final solution X := Pr'*X (=inv(Pr)*X) */
for (i = 0; i < nrhs; i++) {
rhs_work = &Bmat[i*ldb];
for (k = 0; k < n; k++) soln[k] = rhs_work[perm_r[k]];
for (k = 0; k < n; k++) rhs_work[k] = soln[k];
}
}
SUPERLU_FREE(work);
SUPERLU_FREE(soln);
}
/* Double Complex */ VOID zlatm2_(doublecomplex * ret_val, integer *m,
integer *n, integer *i, integer *j, integer *kl, integer *ku, integer
*idist, integer *iseed, doublecomplex *d, integer *igrade,
doublecomplex *dl, doublecomplex *dr, integer *ipvtng, integer *iwork,
doublereal *sparse)
{
/* System generated locals */
integer i__1, i__2;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
void z_div(doublecomplex *, doublecomplex *, doublecomplex *), d_cnjg(
doublecomplex *, doublecomplex *);
/* Local variables */
static integer isub, jsub;
static doublecomplex ctemp;
extern doublereal dlaran_(integer *);
extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
integer *);
/* -- LAPACK auxiliary test routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
ZLATM2 returns the (I,J) entry of a random matrix of dimension
(M, N) described by the other paramters. It is called by the
ZLATMR routine in order to build random test matrices. No error
checking on parameters is done, because this routine is called in
a tight loop by ZLATMR which has already checked the parameters.
Use of ZLATM2 differs from CLATM3 in the order in which the random
number generator is called to fill in random matrix entries.
With ZLATM2, the generator is called to fill in the pivoted matrix
columnwise. With ZLATM3, the generator is called to fill in the
matrix columnwise, after which it is pivoted. Thus, ZLATM3 can
be used to construct random matrices which differ only in their
order of rows and/or columns. ZLATM2 is used to construct band
matrices while avoiding calling the random number generator for
entries outside the band (and therefore generating random numbers
The matrix whose (I,J) entry is returned is constructed as
follows (this routine only computes one entry):
If I is outside (1..M) or J is outside (1..N), return zero
(this is convenient for generating matrices in band format).
Generate a matrix A with random entries of distribution IDIST.
Set the diagonal to D.
Grade the matrix, if desired, from the left (by DL) and/or
from the right (by DR or DL) as specified by IGRADE.
Permute, if desired, the rows and/or columns as specified by
IPVTNG and IWORK.
Band the matrix to have lower bandwidth KL and upper
bandwidth KU.
Set random entries to zero as specified by SPARSE.
Arguments
=========
M - INTEGER
Number of rows of matrix. Not modified.
N - INTEGER
Number of columns of matrix. Not modified.
I - INTEGER
Row of entry to be returned. Not modified.
J - INTEGER
Column of entry to be returned. Not modified.
KL - INTEGER
Lower bandwidth. Not modified.
KU - INTEGER
Upper bandwidth. Not modified.
IDIST - INTEGER
On entry, IDIST specifies the type of distribution to be
used to generate a random matrix .
1 => real and imaginary parts each UNIFORM( 0, 1 )
2 => real and imaginary parts each UNIFORM( -1, 1 )
3 => real and imaginary parts each NORMAL( 0, 1 )
4 => complex number uniform in DISK( 0 , 1 )
Not modified.
ISEED - INTEGER array of dimension ( 4 )
Seed for random number generator.
Changed on exit.
D - COMPLEX*16 array of dimension ( MIN( I , J ) )
Diagonal entries of matrix. Not modified.
IGRADE - INTEGER
Specifies grading of matrix as follows:
0 => no grading
1 => matrix premultiplied by diag( DL )
2 => matrix postmultiplied by diag( DR )
3 => matrix premultiplied by diag( DL ) and
postmultiplied by diag( DR )
4 => matrix premultiplied by diag( DL ) and
postmultiplied by inv( diag( DL ) )
5 => matrix premultiplied by diag( DL ) and
postmultiplied by diag( CONJG(DL) )
6 => matrix premultiplied by diag( DL ) and
postmultiplied by diag( DL )
Not modified.
DL - COMPLEX*16 array ( I or J, as appropriate )
Left scale factors for grading matrix. Not modified.
DR - COMPLEX*16 array ( I or J, as appropriate )
Right scale factors for grading matrix. Not modified.
IPVTNG - INTEGER
On entry specifies pivoting permutations as follows:
0 => none.
1 => row pivoting.
2 => column pivoting.
3 => full pivoting, i.e., on both sides.
Not modified.
IWORK - INTEGER array ( I or J, as appropriate )
This array specifies the permutation used. The
row (or column) in position K was originally in
position IWORK( K ).
This differs from IWORK for ZLATM3. Not modified.
SPARSE - DOUBLE PRECISION between 0. and 1.
On entry specifies the sparsity of the matrix
if sparse matix is to be generated.
SPARSE should lie between 0 and 1.
A uniform ( 0, 1 ) random number x is generated and
compared to SPARSE; if x is larger the matrix entry
is unchanged and if x is smaller the entry is set
to zero. Thus on the average a fraction SPARSE of the
entries will be set to zero.
Not modified.
=====================================================================
-----------------------------------------------------------------------
Check for I and J in range
Parameter adjustments */
--iwork;
--dr;
--dl;
--d;
--iseed;
/* Function Body */
if (*i < 1 || *i > *m || *j < 1 || *j > *n) {
ret_val->r = 0., ret_val->i = 0.;
return ;
}
/* Check for banding */
if (*j > *i + *ku || *j < *i - *kl) {
ret_val->r = 0., ret_val->i = 0.;
return ;
}
/* Check for sparsity */
if (*sparse > 0.) {
if (dlaran_(&iseed[1]) < *sparse) {
ret_val->r = 0., ret_val->i = 0.;
return ;
}
}
/* Compute subscripts depending on IPVTNG */
if (*ipvtng == 0) {
isub = *i;
jsub = *j;
} else if (*ipvtng == 1) {
isub = iwork[*i];
jsub = *j;
} else if (*ipvtng == 2) {
isub = *i;
jsub = iwork[*j];
} else if (*ipvtng == 3) {
isub = iwork[*i];
jsub = iwork[*j];
}
/* Compute entry and grade it according to IGRADE */
if (isub == jsub) {
i__1 = isub;
ctemp.r = d[i__1].r, ctemp.i = d[i__1].i;
} else {
zlarnd_(&z__1, idist, &iseed[1]);
ctemp.r = z__1.r, ctemp.i = z__1.i;
}
if (*igrade == 1) {
i__1 = isub;
z__1.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__1.i =
ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
ctemp.r = z__1.r, ctemp.i = z__1.i;
} else if (*igrade == 2) {
i__1 = jsub;
z__1.r = ctemp.r * dr[i__1].r - ctemp.i * dr[i__1].i, z__1.i =
ctemp.r * dr[i__1].i + ctemp.i * dr[i__1].r;
ctemp.r = z__1.r, ctemp.i = z__1.i;
} else if (*igrade == 3) {
i__1 = isub;
z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i =
ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
i__2 = jsub;
z__1.r = z__2.r * dr[i__2].r - z__2.i * dr[i__2].i, z__1.i = z__2.r *
dr[i__2].i + z__2.i * dr[i__2].r;
ctemp.r = z__1.r, ctemp.i = z__1.i;
} else if (*igrade == 4 && isub != jsub) {
i__1 = isub;
z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i =
ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
z_div(&z__1, &z__2, &dl[jsub]);
ctemp.r = z__1.r, ctemp.i = z__1.i;
} else if (*igrade == 5) {
i__1 = isub;
z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i =
ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
d_cnjg(&z__3, &dl[jsub]);
z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * z__3.i
+ z__2.i * z__3.r;
ctemp.r = z__1.r, ctemp.i = z__1.i;
} else if (*igrade == 6) {
i__1 = isub;
z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i =
ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
i__2 = jsub;
z__1.r = z__2.r * dl[i__2].r - z__2.i * dl[i__2].i, z__1.i = z__2.r *
dl[i__2].i + z__2.i * dl[i__2].r;
ctemp.r = z__1.r, ctemp.i = z__1.i;
}
ret_val->r = ctemp.r, ret_val->i = ctemp.i;
return ;
/* End of ZLATM2 */
} /* zlatm2_ */
/* Subroutine */ int ztrsv_(char *uplo, char *trans, char *diag, integer *n,
doublecomplex *a, integer *lda, doublecomplex *x, integer *incx)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
void z_div(doublecomplex *, doublecomplex *, doublecomplex *), d_cnjg(
doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j, ix, jx, kx, info;
doublecomplex temp;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
logical noconj, nounit;
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZTRSV solves one of the systems of equations */
/* A*x = b, or A'*x = b, or conjg( A' )*x = b, */
/* where b and x are n element vectors and A is an n by n unit, or */
/* non-unit, upper or lower triangular matrix. */
/* No test for singularity or near-singularity is included in this */
/* routine. Such tests must be performed before calling this routine. */
/* Arguments */
/* ========== */
/* UPLO - CHARACTER*1. */
/* On entry, UPLO specifies whether the matrix is an upper or */
/* lower triangular matrix as follows: */
/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
/* Unchanged on exit. */
/* TRANS - CHARACTER*1. */
/* On entry, TRANS specifies the equations to be solved as */
/* follows: */
/* TRANS = 'N' or 'n' A*x = b. */
/* TRANS = 'T' or 't' A'*x = b. */
/* TRANS = 'C' or 'c' conjg( A' )*x = b. */
/* Unchanged on exit. */
/* DIAG - CHARACTER*1. */
/* On entry, DIAG specifies whether or not A is unit */
/* triangular as follows: */
/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
/* DIAG = 'N' or 'n' A is not assumed to be unit */
/* triangular. */
/* Unchanged on exit. */
/* N - INTEGER. */
/* On entry, N specifies the order of the matrix A. */
/* N must be at least zero. */
/* Unchanged on exit. */
/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */
/* Before entry with UPLO = 'U' or 'u', the leading n by n */
/* upper triangular part of the array A must contain the upper */
/* triangular matrix and the strictly lower triangular part of */
/* A is not referenced. */
/* Before entry with UPLO = 'L' or 'l', the leading n by n */
/* lower triangular part of the array A must contain the lower */
/* triangular matrix and the strictly upper triangular part of */
/* A is not referenced. */
/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
/* A are not referenced either, but are assumed to be unity. */
/* Unchanged on exit. */
/* LDA - INTEGER. */
/* On entry, LDA specifies the first dimension of A as declared */
/* in the calling (sub) program. LDA must be at least */
/* max( 1, n ). */
/* Unchanged on exit. */
/* X - COMPLEX*16 array of dimension at least */
/* ( 1 + ( n - 1 )*abs( INCX ) ). */
/* Before entry, the incremented array X must contain the n */
/* element right-hand side vector b. On exit, X is overwritten */
/* with the solution vector x. */
/* INCX - INTEGER. */
/* On entry, INCX specifies the increment for the elements of */
/* X. INCX must not be zero. */
/* Unchanged on exit. */
/* Level 2 Blas routine. */
/* -- Written on 22-October-1986. */
/* Jack Dongarra, Argonne National Lab. */
/* Jeremy Du Croz, Nag Central Office. */
/* Sven Hammarling, Nag Central Office. */
/* Richard Hanson, Sandia National Labs. */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--x;
/* Function Body */
info = 0;
if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
info = 1;
} else if (! lsame_(trans, "N") && ! lsame_(trans,
"T") && ! lsame_(trans, "C")) {
info = 2;
} else if (! lsame_(diag, "U") && ! lsame_(diag,
"N")) {
info = 3;
} else if (*n < 0) {
info = 4;
} else if (*lda < max(1,*n)) {
info = 6;
} else if (*incx == 0) {
info = 8;
}
if (info != 0) {
xerbla_("ZTRSV ", &info);
return 0;
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
noconj = lsame_(trans, "T");
nounit = lsame_(diag, "N");
/* Set up the start point in X if the increment is not unity. This */
/* will be ( N - 1 )*INCX too small for descending loops. */
if (*incx <= 0) {
kx = 1 - (*n - 1) * *incx;
} else if (*incx != 1) {
kx = 1;
}
/* Start the operations. In this version the elements of A are */
/* accessed sequentially with one pass through A. */
if (lsame_(trans, "N")) {
/* Form x := inv( A )*x. */
if (lsame_(uplo, "U")) {
if (*incx == 1) {
for (j = *n; j >= 1; --j) {
i__1 = j;
if (x[i__1].r != 0. || x[i__1].i != 0.) {
if (nounit) {
i__1 = j;
z_div(&z__1, &x[j], &a[j + j * a_dim1]);
x[i__1].r = z__1.r, x[i__1].i = z__1.i;
}
i__1 = j;
temp.r = x[i__1].r, temp.i = x[i__1].i;
for (i__ = j - 1; i__ >= 1; --i__) {
i__1 = i__;
i__2 = i__;
i__3 = i__ + j * a_dim1;
z__2.r = temp.r * a[i__3].r - temp.i * a[i__3].i,
z__2.i = temp.r * a[i__3].i + temp.i * a[
i__3].r;
z__1.r = x[i__2].r - z__2.r, z__1.i = x[i__2].i -
z__2.i;
x[i__1].r = z__1.r, x[i__1].i = z__1.i;
/* L10: */
}
}
/* L20: */
}
} else {
jx = kx + (*n - 1) * *incx;
for (j = *n; j >= 1; --j) {
i__1 = jx;
if (x[i__1].r != 0. || x[i__1].i != 0.) {
if (nounit) {
i__1 = jx;
z_div(&z__1, &x[jx], &a[j + j * a_dim1]);
x[i__1].r = z__1.r, x[i__1].i = z__1.i;
}
i__1 = jx;
temp.r = x[i__1].r, temp.i = x[i__1].i;
ix = jx;
for (i__ = j - 1; i__ >= 1; --i__) {
ix -= *incx;
i__1 = ix;
i__2 = ix;
i__3 = i__ + j * a_dim1;
z__2.r = temp.r * a[i__3].r - temp.i * a[i__3].i,
z__2.i = temp.r * a[i__3].i + temp.i * a[
i__3].r;
z__1.r = x[i__2].r - z__2.r, z__1.i = x[i__2].i -
z__2.i;
x[i__1].r = z__1.r, x[i__1].i = z__1.i;
/* L30: */
}
}
jx -= *incx;
/* L40: */
}
}
} else {
if (*incx == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
if (x[i__2].r != 0. || x[i__2].i != 0.) {
if (nounit) {
i__2 = j;
z_div(&z__1, &x[j], &a[j + j * a_dim1]);
x[i__2].r = z__1.r, x[i__2].i = z__1.i;
}
i__2 = j;
temp.r = x[i__2].r, temp.i = x[i__2].i;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__ + j * a_dim1;
z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
z__2.i = temp.r * a[i__5].i + temp.i * a[
i__5].r;
z__1.r = x[i__4].r - z__2.r, z__1.i = x[i__4].i -
z__2.i;
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
/* L50: */
}
}
/* L60: */
}
} else {
jx = kx;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = jx;
if (x[i__2].r != 0. || x[i__2].i != 0.) {
if (nounit) {
i__2 = jx;
z_div(&z__1, &x[jx], &a[j + j * a_dim1]);
x[i__2].r = z__1.r, x[i__2].i = z__1.i;
}
i__2 = jx;
temp.r = x[i__2].r, temp.i = x[i__2].i;
ix = jx;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
ix += *incx;
i__3 = ix;
i__4 = ix;
i__5 = i__ + j * a_dim1;
z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
z__2.i = temp.r * a[i__5].i + temp.i * a[
i__5].r;
z__1.r = x[i__4].r - z__2.r, z__1.i = x[i__4].i -
z__2.i;
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
/* L70: */
}
}
jx += *incx;
/* L80: */
}
}
}
} else {
/* Form x := inv( A' )*x or x := inv( conjg( A' ) )*x. */
if (lsame_(uplo, "U")) {
if (*incx == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
temp.r = x[i__2].r, temp.i = x[i__2].i;
if (noconj) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__;
z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[
i__4].i, z__2.i = a[i__3].r * x[i__4].i +
a[i__3].i * x[i__4].r;
z__1.r = temp.r - z__2.r, z__1.i = temp.i -
z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
/* L90: */
}
if (nounit) {
z_div(&z__1, &temp, &a[j + j * a_dim1]);
temp.r = z__1.r, temp.i = z__1.i;
}
} else {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
d_cnjg(&z__3, &a[i__ + j * a_dim1]);
i__3 = i__;
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i,
z__2.i = z__3.r * x[i__3].i + z__3.i * x[
i__3].r;
z__1.r = temp.r - z__2.r, z__1.i = temp.i -
z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
/* L100: */
}
if (nounit) {
d_cnjg(&z__2, &a[j + j * a_dim1]);
z_div(&z__1, &temp, &z__2);
temp.r = z__1.r, temp.i = z__1.i;
}
}
i__2 = j;
x[i__2].r = temp.r, x[i__2].i = temp.i;
/* L110: */
}
} else {
jx = kx;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
ix = kx;
i__2 = jx;
temp.r = x[i__2].r, temp.i = x[i__2].i;
if (noconj) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = ix;
z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[
i__4].i, z__2.i = a[i__3].r * x[i__4].i +
a[i__3].i * x[i__4].r;
z__1.r = temp.r - z__2.r, z__1.i = temp.i -
z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
ix += *incx;
/* L120: */
}
if (nounit) {
z_div(&z__1, &temp, &a[j + j * a_dim1]);
temp.r = z__1.r, temp.i = z__1.i;
}
} else {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
d_cnjg(&z__3, &a[i__ + j * a_dim1]);
i__3 = ix;
z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i,
z__2.i = z__3.r * x[i__3].i + z__3.i * x[
i__3].r;
z__1.r = temp.r - z__2.r, z__1.i = temp.i -
z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
ix += *incx;
/* L130: */
}
if (nounit) {
d_cnjg(&z__2, &a[j + j * a_dim1]);
z_div(&z__1, &temp, &z__2);
temp.r = z__1.r, temp.i = z__1.i;
}
}
i__2 = jx;
x[i__2].r = temp.r, x[i__2].i = temp.i;
jx += *incx;
/* L140: */
}
}
} else {
if (*incx == 1) {
for (j = *n; j >= 1; --j) {
i__1 = j;
temp.r = x[i__1].r, temp.i = x[i__1].i;
if (noconj) {
i__1 = j + 1;
for (i__ = *n; i__ >= i__1; --i__) {
i__2 = i__ + j * a_dim1;
i__3 = i__;
z__2.r = a[i__2].r * x[i__3].r - a[i__2].i * x[
i__3].i, z__2.i = a[i__2].r * x[i__3].i +
a[i__2].i * x[i__3].r;
z__1.r = temp.r - z__2.r, z__1.i = temp.i -
z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
/* L150: */
}
if (nounit) {
z_div(&z__1, &temp, &a[j + j * a_dim1]);
temp.r = z__1.r, temp.i = z__1.i;
}
} else {
i__1 = j + 1;
for (i__ = *n; i__ >= i__1; --i__) {
d_cnjg(&z__3, &a[i__ + j * a_dim1]);
i__2 = i__;
z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i,
z__2.i = z__3.r * x[i__2].i + z__3.i * x[
i__2].r;
z__1.r = temp.r - z__2.r, z__1.i = temp.i -
z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
/* L160: */
}
if (nounit) {
d_cnjg(&z__2, &a[j + j * a_dim1]);
z_div(&z__1, &temp, &z__2);
temp.r = z__1.r, temp.i = z__1.i;
}
}
i__1 = j;
x[i__1].r = temp.r, x[i__1].i = temp.i;
/* L170: */
}
} else {
kx += (*n - 1) * *incx;
jx = kx;
for (j = *n; j >= 1; --j) {
ix = kx;
i__1 = jx;
temp.r = x[i__1].r, temp.i = x[i__1].i;
if (noconj) {
i__1 = j + 1;
for (i__ = *n; i__ >= i__1; --i__) {
i__2 = i__ + j * a_dim1;
i__3 = ix;
z__2.r = a[i__2].r * x[i__3].r - a[i__2].i * x[
i__3].i, z__2.i = a[i__2].r * x[i__3].i +
a[i__2].i * x[i__3].r;
z__1.r = temp.r - z__2.r, z__1.i = temp.i -
z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
ix -= *incx;
/* L180: */
}
if (nounit) {
z_div(&z__1, &temp, &a[j + j * a_dim1]);
temp.r = z__1.r, temp.i = z__1.i;
}
} else {
i__1 = j + 1;
for (i__ = *n; i__ >= i__1; --i__) {
d_cnjg(&z__3, &a[i__ + j * a_dim1]);
i__2 = ix;
z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i,
z__2.i = z__3.r * x[i__2].i + z__3.i * x[
i__2].r;
z__1.r = temp.r - z__2.r, z__1.i = temp.i -
z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
ix -= *incx;
/* L190: */
}
if (nounit) {
d_cnjg(&z__2, &a[j + j * a_dim1]);
z_div(&z__1, &temp, &z__2);
temp.r = z__1.r, temp.i = z__1.i;
}
}
i__1 = jx;
x[i__1].r = temp.r, x[i__1].i = temp.i;
jx -= *incx;
/* L200: */
}
}
}
}
return 0;
/* End of ZTRSV . */
} /* ztrsv_ */