/* Subroutine */ int cnapps_(integer *n, integer *kev, integer *np, complex *
shift, complex *v, integer *ldv, complex *h__, integer *ldh, complex *
resid, complex *q, integer *ldq, complex *workl, complex *workd)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer h_dim1, h_offset, v_dim1, v_offset, q_dim1, q_offset, i__1, i__2,
i__3, i__4, i__5, i__6;
real r__1, r__2, r__3, r__4;
complex q__1, q__2, q__3, q__4, q__5;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
static real c__;
static complex f, g;
static integer i__, j;
static complex r__, s, t;
static real t0, t1;
static complex h11, h21;
static integer jj;
static real ulp, tst1;
static integer iend;
static real unfl, ovfl;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
static complex sigma;
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *, ftnlen), ccopy_(integer *, complex *, integer *,
complex *, integer *), caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *), cmout_(integer *, integer *,
integer *, complex *, integer *, integer *, char *, ftnlen),
cvout_(integer *, integer *, complex *, integer *, char *, ftnlen)
, ivout_(integer *, integer *, integer *, integer *, char *,
ftnlen);
extern doublereal slapy2_(real *, real *);
extern /* Subroutine */ int slabad_(real *, real *);
extern doublereal clanhs_(char *, integer *, complex *, integer *,
complex *, ftnlen), slamch_(char *, ftnlen);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *, ftnlen);
static integer istart, kplusp, msglvl;
static real smlnum;
extern /* Subroutine */ int clartg_(complex *, complex *, real *, complex
*, complex *), claset_(char *, integer *, integer *, complex *,
complex *, complex *, integer *, ftnlen), second_(real *);
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %------------------------% */
/* | Local Scalars & Arrays | */
/* %------------------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %----------------------% */
/* | Intrinsics Functions | */
/* %----------------------% */
/* %---------------------% */
/* | Statement Functions | */
/* %---------------------% */
/* %----------------% */
/* | Data statments | */
/* %----------------% */
/* Parameter adjustments */
--workd;
--resid;
--workl;
--shift;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
/* Function Body */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
if (first) {
/* %-----------------------------------------------% */
/* | Set machine-dependent constants for the | */
/* | stopping criterion. If norm(H) <= sqrt(OVFL), | */
/* | overflow should not occur. | */
/* | REFERENCE: LAPACK subroutine clahqr | */
/* %-----------------------------------------------% */
unfl = slamch_("safe minimum", (ftnlen)12);
q__1.r = 1.f / unfl, q__1.i = 0.f / unfl;
ovfl = q__1.r;
slabad_(&unfl, &ovfl);
ulp = slamch_("precision", (ftnlen)9);
smlnum = unfl * (*n / ulp);
first = FALSE_;
}
/* %-------------------------------% */
/* | Initialize timing statistics | */
/* | & message level for debugging | */
/* %-------------------------------% */
second_(&t0);
msglvl = debug_1.mcapps;
kplusp = *kev + *np;
/* %--------------------------------------------% */
/* | Initialize Q to the identity to accumulate | */
/* | the rotations and reflections | */
/* %--------------------------------------------% */
claset_("All", &kplusp, &kplusp, &c_b2, &c_b1, &q[q_offset], ldq, (ftnlen)
3);
/* %----------------------------------------------% */
/* | Quick return if there are no shifts to apply | */
/* %----------------------------------------------% */
if (*np == 0) {
goto L9000;
}
/* %----------------------------------------------% */
/* | Chase the bulge with the application of each | */
/* | implicit shift. Each shift is applied to the | */
/* | whole matrix including each block. | */
/* %----------------------------------------------% */
i__1 = *np;
for (jj = 1; jj <= i__1; ++jj) {
i__2 = jj;
sigma.r = shift[i__2].r, sigma.i = shift[i__2].i;
if (msglvl > 2) {
ivout_(&debug_1.logfil, &c__1, &jj, &debug_1.ndigit, "_napps: sh"
"ift number.", (ftnlen)21);
cvout_(&debug_1.logfil, &c__1, &sigma, &debug_1.ndigit, "_napps:"
" Value of the shift ", (ftnlen)27);
}
istart = 1;
L20:
i__2 = kplusp - 1;
for (i__ = istart; i__ <= i__2; ++i__) {
/* %----------------------------------------% */
/* | Check for splitting and deflation. Use | */
/* | a standard test as in the QR algorithm | */
/* | REFERENCE: LAPACK subroutine clahqr | */
/* %----------------------------------------% */
i__3 = i__ + i__ * h_dim1;
i__4 = i__ + 1 + (i__ + 1) * h_dim1;
tst1 = (r__1 = h__[i__3].r, dabs(r__1)) + (r__2 = r_imag(&h__[i__
+ i__ * h_dim1]), dabs(r__2)) + ((r__3 = h__[i__4].r,
dabs(r__3)) + (r__4 = r_imag(&h__[i__ + 1 + (i__ + 1) *
h_dim1]), dabs(r__4)));
if (tst1 == 0.f) {
i__3 = kplusp - jj + 1;
tst1 = clanhs_("1", &i__3, &h__[h_offset], ldh, &workl[1], (
ftnlen)1);
}
i__3 = i__ + 1 + i__ * h_dim1;
/* Computing MAX */
r__2 = ulp * tst1;
if ((r__1 = h__[i__3].r, dabs(r__1)) <= dmax(r__2,smlnum)) {
if (msglvl > 0) {
ivout_(&debug_1.logfil, &c__1, &i__, &debug_1.ndigit,
"_napps: matrix splitting at row/column no.", (
ftnlen)42);
ivout_(&debug_1.logfil, &c__1, &jj, &debug_1.ndigit,
"_napps: matrix splitting with shift number.", (
ftnlen)43);
cvout_(&debug_1.logfil, &c__1, &h__[i__ + 1 + i__ *
h_dim1], &debug_1.ndigit, "_napps: off diagonal "
"element.", (ftnlen)29);
}
iend = i__;
i__3 = i__ + 1 + i__ * h_dim1;
h__[i__3].r = 0.f, h__[i__3].i = 0.f;
goto L40;
}
/* L30: */
}
iend = kplusp;
L40:
if (msglvl > 2) {
ivout_(&debug_1.logfil, &c__1, &istart, &debug_1.ndigit, "_napps"
": Start of current block ", (ftnlen)31);
ivout_(&debug_1.logfil, &c__1, &iend, &debug_1.ndigit, "_napps: "
"End of current block ", (ftnlen)29);
}
/* %------------------------------------------------% */
/* | No reason to apply a shift to block of order 1 | */
/* | or if the current block starts after the point | */
/* | of compression since we'll discard this stuff | */
/* %------------------------------------------------% */
if (istart == iend || istart > *kev) {
goto L100;
}
i__2 = istart + istart * h_dim1;
h11.r = h__[i__2].r, h11.i = h__[i__2].i;
i__2 = istart + 1 + istart * h_dim1;
h21.r = h__[i__2].r, h21.i = h__[i__2].i;
q__1.r = h11.r - sigma.r, q__1.i = h11.i - sigma.i;
f.r = q__1.r, f.i = q__1.i;
g.r = h21.r, g.i = h21.i;
i__2 = iend - 1;
for (i__ = istart; i__ <= i__2; ++i__) {
/* %------------------------------------------------------% */
/* | Construct the plane rotation G to zero out the bulge | */
/* %------------------------------------------------------% */
clartg_(&f, &g, &c__, &s, &r__);
if (i__ > istart) {
i__3 = i__ + (i__ - 1) * h_dim1;
h__[i__3].r = r__.r, h__[i__3].i = r__.i;
i__3 = i__ + 1 + (i__ - 1) * h_dim1;
h__[i__3].r = 0.f, h__[i__3].i = 0.f;
}
/* %---------------------------------------------% */
/* | Apply rotation to the left of H; H <- G'*H | */
/* %---------------------------------------------% */
i__3 = kplusp;
for (j = i__; j <= i__3; ++j) {
i__4 = i__ + j * h_dim1;
q__2.r = c__ * h__[i__4].r, q__2.i = c__ * h__[i__4].i;
i__5 = i__ + 1 + j * h_dim1;
q__3.r = s.r * h__[i__5].r - s.i * h__[i__5].i, q__3.i = s.r *
h__[i__5].i + s.i * h__[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
t.r = q__1.r, t.i = q__1.i;
i__4 = i__ + 1 + j * h_dim1;
r_cnjg(&q__4, &s);
q__3.r = -q__4.r, q__3.i = -q__4.i;
i__5 = i__ + j * h_dim1;
q__2.r = q__3.r * h__[i__5].r - q__3.i * h__[i__5].i, q__2.i =
q__3.r * h__[i__5].i + q__3.i * h__[i__5].r;
i__6 = i__ + 1 + j * h_dim1;
q__5.r = c__ * h__[i__6].r, q__5.i = c__ * h__[i__6].i;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
h__[i__4].r = q__1.r, h__[i__4].i = q__1.i;
i__4 = i__ + j * h_dim1;
h__[i__4].r = t.r, h__[i__4].i = t.i;
/* L50: */
}
/* %---------------------------------------------% */
/* | Apply rotation to the right of H; H <- H*G | */
/* %---------------------------------------------% */
/* Computing MIN */
i__4 = i__ + 2;
i__3 = min(i__4,iend);
for (j = 1; j <= i__3; ++j) {
i__4 = j + i__ * h_dim1;
q__2.r = c__ * h__[i__4].r, q__2.i = c__ * h__[i__4].i;
r_cnjg(&q__4, &s);
i__5 = j + (i__ + 1) * h_dim1;
q__3.r = q__4.r * h__[i__5].r - q__4.i * h__[i__5].i, q__3.i =
q__4.r * h__[i__5].i + q__4.i * h__[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
t.r = q__1.r, t.i = q__1.i;
i__4 = j + (i__ + 1) * h_dim1;
q__3.r = -s.r, q__3.i = -s.i;
i__5 = j + i__ * h_dim1;
q__2.r = q__3.r * h__[i__5].r - q__3.i * h__[i__5].i, q__2.i =
q__3.r * h__[i__5].i + q__3.i * h__[i__5].r;
i__6 = j + (i__ + 1) * h_dim1;
q__4.r = c__ * h__[i__6].r, q__4.i = c__ * h__[i__6].i;
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
h__[i__4].r = q__1.r, h__[i__4].i = q__1.i;
i__4 = j + i__ * h_dim1;
h__[i__4].r = t.r, h__[i__4].i = t.i;
/* L60: */
}
/* %-----------------------------------------------------% */
/* | Accumulate the rotation in the matrix Q; Q <- Q*G' | */
/* %-----------------------------------------------------% */
/* Computing MIN */
i__4 = i__ + jj;
i__3 = min(i__4,kplusp);
for (j = 1; j <= i__3; ++j) {
i__4 = j + i__ * q_dim1;
q__2.r = c__ * q[i__4].r, q__2.i = c__ * q[i__4].i;
r_cnjg(&q__4, &s);
i__5 = j + (i__ + 1) * q_dim1;
q__3.r = q__4.r * q[i__5].r - q__4.i * q[i__5].i, q__3.i =
q__4.r * q[i__5].i + q__4.i * q[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
t.r = q__1.r, t.i = q__1.i;
i__4 = j + (i__ + 1) * q_dim1;
q__3.r = -s.r, q__3.i = -s.i;
i__5 = j + i__ * q_dim1;
q__2.r = q__3.r * q[i__5].r - q__3.i * q[i__5].i, q__2.i =
q__3.r * q[i__5].i + q__3.i * q[i__5].r;
i__6 = j + (i__ + 1) * q_dim1;
q__4.r = c__ * q[i__6].r, q__4.i = c__ * q[i__6].i;
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
q[i__4].r = q__1.r, q[i__4].i = q__1.i;
i__4 = j + i__ * q_dim1;
q[i__4].r = t.r, q[i__4].i = t.i;
/* L70: */
}
/* %---------------------------% */
/* | Prepare for next rotation | */
/* %---------------------------% */
if (i__ < iend - 1) {
i__3 = i__ + 1 + i__ * h_dim1;
f.r = h__[i__3].r, f.i = h__[i__3].i;
i__3 = i__ + 2 + i__ * h_dim1;
g.r = h__[i__3].r, g.i = h__[i__3].i;
}
/* L80: */
}
/* %-------------------------------% */
/* | Finished applying the shift. | */
/* %-------------------------------% */
L100:
/* %---------------------------------------------------------% */
/* | Apply the same shift to the next block if there is any. | */
/* %---------------------------------------------------------% */
istart = iend + 1;
if (iend < kplusp) {
goto L20;
}
/* %---------------------------------------------% */
/* | Loop back to the top to get the next shift. | */
/* %---------------------------------------------% */
/* L110: */
}
/* %---------------------------------------------------% */
/* | Perform a similarity transformation that makes | */
/* | sure that the compressed H will have non-negative | */
/* | real subdiagonal elements. | */
/* %---------------------------------------------------% */
i__1 = *kev;
for (j = 1; j <= i__1; ++j) {
i__2 = j + 1 + j * h_dim1;
if (h__[i__2].r < 0.f || r_imag(&h__[j + 1 + j * h_dim1]) != 0.f) {
i__2 = j + 1 + j * h_dim1;
i__3 = j + 1 + j * h_dim1;
r__2 = h__[i__3].r;
r__3 = r_imag(&h__[j + 1 + j * h_dim1]);
r__1 = slapy2_(&r__2, &r__3);
q__1.r = h__[i__2].r / r__1, q__1.i = h__[i__2].i / r__1;
t.r = q__1.r, t.i = q__1.i;
i__2 = kplusp - j + 1;
r_cnjg(&q__1, &t);
cscal_(&i__2, &q__1, &h__[j + 1 + j * h_dim1], ldh);
/* Computing MIN */
i__3 = j + 2;
i__2 = min(i__3,kplusp);
cscal_(&i__2, &t, &h__[(j + 1) * h_dim1 + 1], &c__1);
/* Computing MIN */
i__3 = j + *np + 1;
i__2 = min(i__3,kplusp);
cscal_(&i__2, &t, &q[(j + 1) * q_dim1 + 1], &c__1);
i__2 = j + 1 + j * h_dim1;
i__3 = j + 1 + j * h_dim1;
r__1 = h__[i__3].r;
q__1.r = r__1, q__1.i = 0.f;
h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
}
/* L120: */
}
i__1 = *kev;
for (i__ = 1; i__ <= i__1; ++i__) {
/* %--------------------------------------------% */
/* | Final check for splitting and deflation. | */
/* | Use a standard test as in the QR algorithm | */
/* | REFERENCE: LAPACK subroutine clahqr. | */
/* | Note: Since the subdiagonals of the | */
/* | compressed H are nonnegative real numbers, | */
/* | we take advantage of this. | */
/* %--------------------------------------------% */
i__2 = i__ + i__ * h_dim1;
i__3 = i__ + 1 + (i__ + 1) * h_dim1;
tst1 = (r__1 = h__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&h__[i__ +
i__ * h_dim1]), dabs(r__2)) + ((r__3 = h__[i__3].r, dabs(r__3)
) + (r__4 = r_imag(&h__[i__ + 1 + (i__ + 1) * h_dim1]), dabs(
r__4)));
if (tst1 == 0.f) {
tst1 = clanhs_("1", kev, &h__[h_offset], ldh, &workl[1], (ftnlen)
1);
}
i__2 = i__ + 1 + i__ * h_dim1;
/* Computing MAX */
r__1 = ulp * tst1;
if (h__[i__2].r <= dmax(r__1,smlnum)) {
i__3 = i__ + 1 + i__ * h_dim1;
h__[i__3].r = 0.f, h__[i__3].i = 0.f;
}
/* L130: */
}
/* %-------------------------------------------------% */
/* | Compute the (kev+1)-st column of (V*Q) and | */
/* | temporarily store the result in WORKD(N+1:2*N). | */
/* | This is needed in the residual update since we | */
/* | cannot GUARANTEE that the corresponding entry | */
/* | of H would be zero as in exact arithmetic. | */
/* %-------------------------------------------------% */
i__1 = *kev + 1 + *kev * h_dim1;
if (h__[i__1].r > 0.f) {
cgemv_("N", n, &kplusp, &c_b1, &v[v_offset], ldv, &q[(*kev + 1) *
q_dim1 + 1], &c__1, &c_b2, &workd[*n + 1], &c__1, (ftnlen)1);
}
/* %----------------------------------------------------------% */
/* | Compute column 1 to kev of (V*Q) in backward order | */
/* | taking advantage of the upper Hessenberg structure of Q. | */
/* %----------------------------------------------------------% */
i__1 = *kev;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = kplusp - i__ + 1;
cgemv_("N", n, &i__2, &c_b1, &v[v_offset], ldv, &q[(*kev - i__ + 1) *
q_dim1 + 1], &c__1, &c_b2, &workd[1], &c__1, (ftnlen)1);
ccopy_(n, &workd[1], &c__1, &v[(kplusp - i__ + 1) * v_dim1 + 1], &
c__1);
/* L140: */
}
/* %-------------------------------------------------% */
/* | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | */
/* %-------------------------------------------------% */
clacpy_("A", n, kev, &v[(kplusp - *kev + 1) * v_dim1 + 1], ldv, &v[
v_offset], ldv, (ftnlen)1);
/* %--------------------------------------------------------------% */
/* | Copy the (kev+1)-st column of (V*Q) in the appropriate place | */
/* %--------------------------------------------------------------% */
i__1 = *kev + 1 + *kev * h_dim1;
if (h__[i__1].r > 0.f) {
ccopy_(n, &workd[*n + 1], &c__1, &v[(*kev + 1) * v_dim1 + 1], &c__1);
}
/* %-------------------------------------% */
/* | Update the residual vector: | */
/* | r <- sigmak*r + betak*v(:,kev+1) | */
/* | where | */
/* | sigmak = (e_{kev+p}'*Q)*e_{kev} | */
/* | betak = e_{kev+1}'*H*e_{kev} | */
/* %-------------------------------------% */
cscal_(n, &q[kplusp + *kev * q_dim1], &resid[1], &c__1);
i__1 = *kev + 1 + *kev * h_dim1;
if (h__[i__1].r > 0.f) {
caxpy_(n, &h__[*kev + 1 + *kev * h_dim1], &v[(*kev + 1) * v_dim1 + 1],
&c__1, &resid[1], &c__1);
}
if (msglvl > 1) {
cvout_(&debug_1.logfil, &c__1, &q[kplusp + *kev * q_dim1], &
debug_1.ndigit, "_napps: sigmak = (e_{kev+p}^T*Q)*e_{kev}", (
ftnlen)40);
cvout_(&debug_1.logfil, &c__1, &h__[*kev + 1 + *kev * h_dim1], &
debug_1.ndigit, "_napps: betak = e_{kev+1}^T*H*e_{kev}", (
ftnlen)37);
ivout_(&debug_1.logfil, &c__1, kev, &debug_1.ndigit, "_napps: Order "
"of the final Hessenberg matrix ", (ftnlen)45);
if (msglvl > 2) {
cmout_(&debug_1.logfil, kev, kev, &h__[h_offset], ldh, &
debug_1.ndigit, "_napps: updated Hessenberg matrix H for"
" next iteration", (ftnlen)54);
}
}
L9000:
second_(&t1);
timing_1.tcapps += t1 - t0;
return 0;
/* %---------------% */
/* | End of cnapps | */
/* %---------------% */
} /* cnapps_ */
/*< SUBROUTINE SLARFG( N, ALPHA, X, INCX, TAU ) >*/
/* Subroutine */ int slarfg_(integer *n, real *alpha, real *x, integer *incx,
real *tau)
{
/* System generated locals */
integer i__1;
real r__1;
/* Builtin functions */
double r_sign(real *, real *);
/* Local variables */
integer j, knt;
real beta;
extern doublereal snrm2_(integer *, real *, integer *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
real xnorm;
extern doublereal slapy2_(real *, real *), slamch_(char *, ftnlen);
real safmin, rsafmn;
/* -- LAPACK auxiliary routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/*< INTEGER INCX, N >*/
/*< REAL ALPHA, TAU >*/
/* .. */
/* .. Array Arguments .. */
/*< REAL X( * ) >*/
/* .. */
/* Purpose */
/* ======= */
/* SLARFG generates a real elementary reflector H of order n, such */
/* that */
/* H * ( alpha ) = ( beta ), H' * H = I. */
/* ( x ) ( 0 ) */
/* where alpha and beta are scalars, and x is an (n-1)-element real */
/* vector. H is represented in the form */
/* H = I - tau * ( 1 ) * ( 1 v' ) , */
/* ( v ) */
/* where tau is a real scalar and v is a real (n-1)-element */
/* vector. */
/* If the elements of x are all zero, then tau = 0 and H is taken to be */
/* the unit matrix. */
/* Otherwise 1 <= tau <= 2. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the elementary reflector. */
/* ALPHA (input/output) REAL */
/* On entry, the value alpha. */
/* On exit, it is overwritten with the value beta. */
/* X (input/output) REAL array, dimension */
/* (1+(N-2)*abs(INCX)) */
/* On entry, the vector x. */
/* On exit, it is overwritten with the vector v. */
/* INCX (input) INTEGER */
/* The increment between elements of X. INCX > 0. */
/* TAU (output) REAL */
/* The value tau. */
/* ===================================================================== */
/* .. Parameters .. */
/*< REAL ONE, ZERO >*/
/*< PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) >*/
/* .. */
/* .. Local Scalars .. */
/*< INTEGER J, KNT >*/
/*< REAL BETA, RSAFMN, SAFMIN, XNORM >*/
/* .. */
/* .. External Functions .. */
/*< REAL SLAMCH, SLAPY2, SNRM2 >*/
/*< EXTERNAL SLAMCH, SLAPY2, SNRM2 >*/
/* .. */
/* .. Intrinsic Functions .. */
/*< INTRINSIC ABS, SIGN >*/
/* .. */
/* .. External Subroutines .. */
/*< EXTERNAL SSCAL >*/
/* .. */
/* .. Executable Statements .. */
/*< IF( N.LE.1 ) THEN >*/
/* Parameter adjustments */
--x;
/* Function Body */
if (*n <= 1) {
/*< TAU = ZERO >*/
*tau = (float)0.;
/*< RETURN >*/
return 0;
/*< END IF >*/
}
/*< XNORM = SNRM2( N-1, X, INCX ) >*/
i__1 = *n - 1;
xnorm = snrm2_(&i__1, &x[1], incx);
/*< IF( XNORM.EQ.ZERO ) THEN >*/
if (xnorm == (float)0.) {
/* H = I */
/*< TAU = ZERO >*/
*tau = (float)0.;
/*< ELSE >*/
} else {
/* general case */
/*< BETA = -SIGN( SLAPY2( ALPHA, XNORM ), ALPHA ) >*/
r__1 = slapy2_(alpha, &xnorm);
beta = -r_sign(&r__1, alpha);
/*< SAFMIN = SLAMCH( 'S' ) / SLAMCH( 'E' ) >*/
safmin = slamch_("S", (ftnlen)1) / slamch_("E", (ftnlen)1);
/*< IF( ABS( BETA ).LT.SAFMIN ) THEN >*/
if (dabs(beta) < safmin) {
/* XNORM, BETA may be inaccurate; scale X and recompute them */
/*< RSAFMN = ONE / SAFMIN >*/
rsafmn = (float)1. / safmin;
/*< KNT = 0 >*/
knt = 0;
/*< 10 CONTINUE >*/
L10:
/*< KNT = KNT + 1 >*/
++knt;
/*< CALL SSCAL( N-1, RSAFMN, X, INCX ) >*/
i__1 = *n - 1;
sscal_(&i__1, &rsafmn, &x[1], incx);
/*< BETA = BETA*RSAFMN >*/
beta *= rsafmn;
/*< ALPHA = ALPHA*RSAFMN >*/
*alpha *= rsafmn;
/*< >*/
if (dabs(beta) < safmin) {
goto L10;
}
/* New BETA is at most 1, at least SAFMIN */
/*< XNORM = SNRM2( N-1, X, INCX ) >*/
i__1 = *n - 1;
xnorm = snrm2_(&i__1, &x[1], incx);
/*< BETA = -SIGN( SLAPY2( ALPHA, XNORM ), ALPHA ) >*/
r__1 = slapy2_(alpha, &xnorm);
beta = -r_sign(&r__1, alpha);
/*< TAU = ( BETA-ALPHA ) / BETA >*/
*tau = (beta - *alpha) / beta;
/*< CALL SSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) >*/
i__1 = *n - 1;
r__1 = (float)1. / (*alpha - beta);
sscal_(&i__1, &r__1, &x[1], incx);
/* If ALPHA is subnormal, it may lose relative accuracy */
/*< ALPHA = BETA >*/
*alpha = beta;
/*< DO 20 J = 1, KNT >*/
i__1 = knt;
for (j = 1; j <= i__1; ++j) {
/*< ALPHA = ALPHA*SAFMIN >*/
*alpha *= safmin;
/*< 20 CONTINUE >*/
/* L20: */
}
/*< ELSE >*/
} else {
/*< TAU = ( BETA-ALPHA ) / BETA >*/
*tau = (beta - *alpha) / beta;
/*< CALL SSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) >*/
i__1 = *n - 1;
r__1 = (float)1. / (*alpha - beta);
sscal_(&i__1, &r__1, &x[1], incx);
/*< ALPHA = BETA >*/
*alpha = beta;
/*< END IF >*/
}
/*< END IF >*/
}
/*< RETURN >*/
return 0;
/* End of SLARFG */
/*< END >*/
} /* slarfg_ */
/* Subroutine */ int slarfg_(integer *n, real *alpha, real *x, integer *incx,
real *tau)
{
/* System generated locals */
integer i__1;
real r__1;
/* Builtin functions */
double r_sign(real *, real *);
/* Local variables */
static integer j, knt;
static real beta;
extern doublereal snrm2_(integer *, real *, integer *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static real xnorm;
extern doublereal slapy2_(real *, real *), slamch_(char *, ftnlen);
static real safmin, rsafmn;
/* -- LAPACK auxiliary routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLARFG generates a real elementary reflector H of order n, such */
/* that */
/* H * ( alpha ) = ( beta ), H' * H = I. */
/* ( x ) ( 0 ) */
/* where alpha and beta are scalars, and x is an (n-1)-element real */
/* vector. H is represented in the form */
/* H = I - tau * ( 1 ) * ( 1 v' ) , */
/* ( v ) */
/* where tau is a real scalar and v is a real (n-1)-element */
/* vector. */
/* If the elements of x are all zero, then tau = 0 and H is taken to be */
/* the unit matrix. */
/* Otherwise 1 <= tau <= 2. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the elementary reflector. */
/* ALPHA (input/output) REAL */
/* On entry, the value alpha. */
/* On exit, it is overwritten with the value beta. */
/* X (input/output) REAL array, dimension */
/* (1+(N-2)*abs(INCX)) */
/* On entry, the vector x. */
/* On exit, it is overwritten with the vector v. */
/* INCX (input) INTEGER */
/* The increment between elements of X. INCX > 0. */
/* TAU (output) REAL */
/* The value tau. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--x;
/* Function Body */
if (*n <= 1) {
*tau = 0.f;
return 0;
}
i__1 = *n - 1;
xnorm = snrm2_(&i__1, &x[1], incx);
if (xnorm == 0.f) {
/* H = I */
*tau = 0.f;
} else {
/* general case */
r__1 = slapy2_(alpha, &xnorm);
beta = -r_sign(&r__1, alpha);
safmin = slamch_("S", (ftnlen)1) / slamch_("E", (ftnlen)1);
if (dabs(beta) < safmin) {
/* XNORM, BETA may be inaccurate; scale X and recompute them */
rsafmn = 1.f / safmin;
knt = 0;
L10:
++knt;
i__1 = *n - 1;
sscal_(&i__1, &rsafmn, &x[1], incx);
beta *= rsafmn;
*alpha *= rsafmn;
if (dabs(beta) < safmin) {
goto L10;
}
/* New BETA is at most 1, at least SAFMIN */
i__1 = *n - 1;
xnorm = snrm2_(&i__1, &x[1], incx);
r__1 = slapy2_(alpha, &xnorm);
beta = -r_sign(&r__1, alpha);
*tau = (beta - *alpha) / beta;
i__1 = *n - 1;
r__1 = 1.f / (*alpha - beta);
sscal_(&i__1, &r__1, &x[1], incx);
/* If ALPHA is subnormal, it may lose relative accuracy */
*alpha = beta;
i__1 = knt;
for (j = 1; j <= i__1; ++j) {
*alpha *= safmin;
/* L20: */
}
} else {
*tau = (beta - *alpha) / beta;
i__1 = *n - 1;
r__1 = 1.f / (*alpha - beta);
sscal_(&i__1, &r__1, &x[1], incx);
*alpha = beta;
}
}
return 0;
/* End of SLARFG */
} /* slarfg_ */
/* Subroutine */
int slasd2_(integer *nl, integer *nr, integer *sqre, integer *k, real *d__, real *z__, real *alpha, real *beta, real *u, integer * ldu, real *vt, integer *ldvt, real *dsigma, real *u2, integer *ldu2, real *vt2, integer *ldvt2, integer *idxp, integer *idx, integer *idxc, integer *idxq, integer *coltyp, integer *info)
{
/* System generated locals */
integer u_dim1, u_offset, u2_dim1, u2_offset, vt_dim1, vt_offset, vt2_dim1, vt2_offset, i__1;
real r__1, r__2;
/* Local variables */
real c__;
integer i__, j, m, n;
real s;
integer k2;
real z1;
integer ct, jp;
real eps, tau, tol;
integer psm[4], nlp1, nlp2, idxi, idxj, ctot[4];
extern /* Subroutine */
int srot_(integer *, real *, integer *, real *, integer *, real *, real *);
integer idxjp, jprev;
extern /* Subroutine */
int scopy_(integer *, real *, integer *, real *, integer *);
extern real slapy2_(real *, real *), slamch_(char *);
extern /* Subroutine */
int xerbla_(char *, integer *), slamrg_( integer *, integer *, real *, integer *, integer *, integer *);
real hlftol;
extern /* Subroutine */
int slacpy_(char *, integer *, integer *, real *, integer *, real *, integer *), slaset_(char *, integer *, integer *, real *, real *, real *, integer *);
/* -- LAPACK auxiliary 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 Arrays .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--z__;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1;
vt -= vt_offset;
--dsigma;
u2_dim1 = *ldu2;
u2_offset = 1 + u2_dim1;
u2 -= u2_offset;
vt2_dim1 = *ldvt2;
vt2_offset = 1 + vt2_dim1;
vt2 -= vt2_offset;
--idxp;
--idx;
--idxc;
--idxq;
--coltyp;
/* Function Body */
*info = 0;
if (*nl < 1)
{
*info = -1;
}
else if (*nr < 1)
{
*info = -2;
}
else if (*sqre != 1 && *sqre != 0)
{
*info = -3;
}
n = *nl + *nr + 1;
m = n + *sqre;
if (*ldu < n)
{
*info = -10;
}
else if (*ldvt < m)
{
*info = -12;
}
else if (*ldu2 < n)
{
*info = -15;
}
else if (*ldvt2 < m)
{
*info = -17;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("SLASD2", &i__1);
return 0;
}
nlp1 = *nl + 1;
nlp2 = *nl + 2;
/* Generate the first part of the vector Z;
and move the singular */
/* values in the first part of D one position backward. */
z1 = *alpha * vt[nlp1 + nlp1 * vt_dim1];
z__[1] = z1;
for (i__ = *nl;
i__ >= 1;
--i__)
{
z__[i__ + 1] = *alpha * vt[i__ + nlp1 * vt_dim1];
d__[i__ + 1] = d__[i__];
idxq[i__ + 1] = idxq[i__] + 1;
/* L10: */
}
/* Generate the second part of the vector Z. */
i__1 = m;
for (i__ = nlp2;
i__ <= i__1;
++i__)
{
z__[i__] = *beta * vt[i__ + nlp2 * vt_dim1];
/* L20: */
}
/* Initialize some reference arrays. */
i__1 = nlp1;
for (i__ = 2;
i__ <= i__1;
++i__)
{
coltyp[i__] = 1;
/* L30: */
}
i__1 = n;
for (i__ = nlp2;
i__ <= i__1;
++i__)
{
coltyp[i__] = 2;
/* L40: */
}
/* Sort the singular values into increasing order */
i__1 = n;
for (i__ = nlp2;
i__ <= i__1;
++i__)
{
idxq[i__] += nlp1;
/* L50: */
}
/* DSIGMA, IDXC, IDXC, and the first column of U2 */
/* are used as storage space. */
i__1 = n;
for (i__ = 2;
i__ <= i__1;
++i__)
{
dsigma[i__] = d__[idxq[i__]];
u2[i__ + u2_dim1] = z__[idxq[i__]];
idxc[i__] = coltyp[idxq[i__]];
/* L60: */
}
slamrg_(nl, nr, &dsigma[2], &c__1, &c__1, &idx[2]);
i__1 = n;
for (i__ = 2;
i__ <= i__1;
++i__)
{
idxi = idx[i__] + 1;
d__[i__] = dsigma[idxi];
z__[i__] = u2[idxi + u2_dim1];
coltyp[i__] = idxc[idxi];
/* L70: */
}
/* Calculate the allowable deflation tolerance */
eps = slamch_("Epsilon");
/* Computing MAX */
r__1 = f2c_abs(*alpha);
r__2 = f2c_abs(*beta); // , expr subst
tol = max(r__1,r__2);
/* Computing MAX */
r__2 = (r__1 = d__[n], f2c_abs(r__1));
tol = eps * 8.f * max(r__2,tol);
/* There are 2 kinds of deflation -- first a value in the z-vector */
/* is small, second two (or more) singular values are very close */
/* together (their difference is small). */
/* If the value in the z-vector is small, we simply permute the */
/* array so that the corresponding singular value is moved to the */
/* end. */
/* If two values in the D-vector are close, we perform a two-sided */
/* rotation designed to make one of the corresponding z-vector */
/* entries zero, and then permute the array so that the deflated */
/* singular value is moved to the end. */
/* If there are multiple singular values then the problem deflates. */
/* Here the number of equal singular values are found. As each equal */
/* singular value is found, an elementary reflector is computed to */
/* rotate the corresponding singular subspace so that the */
/* corresponding components of Z are zero in this new basis. */
*k = 1;
k2 = n + 1;
i__1 = n;
for (j = 2;
j <= i__1;
++j)
{
if ((r__1 = z__[j], f2c_abs(r__1)) <= tol)
{
/* Deflate due to small z component. */
--k2;
idxp[k2] = j;
coltyp[j] = 4;
if (j == n)
{
goto L120;
}
}
else
{
jprev = j;
goto L90;
}
/* L80: */
}
L90:
j = jprev;
L100:
++j;
if (j > n)
{
goto L110;
}
if ((r__1 = z__[j], f2c_abs(r__1)) <= tol)
{
/* Deflate due to small z component. */
--k2;
idxp[k2] = j;
coltyp[j] = 4;
}
else
{
/* Check if singular values are close enough to allow deflation. */
if ((r__1 = d__[j] - d__[jprev], f2c_abs(r__1)) <= tol)
{
/* Deflation is possible. */
s = z__[jprev];
c__ = z__[j];
/* Find sqrt(a**2+b**2) without overflow or */
/* destructive underflow. */
tau = slapy2_(&c__, &s);
c__ /= tau;
s = -s / tau;
z__[j] = tau;
z__[jprev] = 0.f;
/* Apply back the Givens rotation to the left and right */
/* singular vector matrices. */
idxjp = idxq[idx[jprev] + 1];
idxj = idxq[idx[j] + 1];
if (idxjp <= nlp1)
{
--idxjp;
}
if (idxj <= nlp1)
{
--idxj;
}
srot_(&n, &u[idxjp * u_dim1 + 1], &c__1, &u[idxj * u_dim1 + 1], & c__1, &c__, &s);
srot_(&m, &vt[idxjp + vt_dim1], ldvt, &vt[idxj + vt_dim1], ldvt, & c__, &s);
if (coltyp[j] != coltyp[jprev])
{
coltyp[j] = 3;
}
coltyp[jprev] = 4;
--k2;
idxp[k2] = jprev;
jprev = j;
}
else
{
++(*k);
u2[*k + u2_dim1] = z__[jprev];
dsigma[*k] = d__[jprev];
idxp[*k] = jprev;
jprev = j;
}
}
goto L100;
L110: /* Record the last singular value. */
++(*k);
u2[*k + u2_dim1] = z__[jprev];
dsigma[*k] = d__[jprev];
idxp[*k] = jprev;
L120: /* Count up the total number of the various types of columns, then */
/* form a permutation which positions the four column types into */
/* four groups of uniform structure (although one or more of these */
/* groups may be empty). */
for (j = 1;
j <= 4;
++j)
{
ctot[j - 1] = 0;
/* L130: */
}
i__1 = n;
for (j = 2;
j <= i__1;
++j)
{
ct = coltyp[j];
++ctot[ct - 1];
/* L140: */
}
/* PSM(*) = Position in SubMatrix (of types 1 through 4) */
psm[0] = 2;
psm[1] = ctot[0] + 2;
psm[2] = psm[1] + ctot[1];
psm[3] = psm[2] + ctot[2];
/* Fill out the IDXC array so that the permutation which it induces */
/* will place all type-1 columns first, all type-2 columns next, */
/* then all type-3's, and finally all type-4's, starting from the */
/* second column. This applies similarly to the rows of VT. */
i__1 = n;
for (j = 2;
j <= i__1;
++j)
{
jp = idxp[j];
ct = coltyp[jp];
idxc[psm[ct - 1]] = j;
++psm[ct - 1];
/* L150: */
}
/* Sort the singular values and corresponding singular vectors into */
/* DSIGMA, U2, and VT2 respectively. The singular values/vectors */
/* which were not deflated go into the first K slots of DSIGMA, U2, */
/* and VT2 respectively, while those which were deflated go into the */
/* last N - K slots, except that the first column/row will be treated */
/* separately. */
i__1 = n;
for (j = 2;
j <= i__1;
++j)
{
jp = idxp[j];
dsigma[j] = d__[jp];
idxj = idxq[idx[idxp[idxc[j]]] + 1];
if (idxj <= nlp1)
{
--idxj;
}
scopy_(&n, &u[idxj * u_dim1 + 1], &c__1, &u2[j * u2_dim1 + 1], &c__1);
scopy_(&m, &vt[idxj + vt_dim1], ldvt, &vt2[j + vt2_dim1], ldvt2);
/* L160: */
}
/* Determine DSIGMA(1), DSIGMA(2) and Z(1) */
dsigma[1] = 0.f;
hlftol = tol / 2.f;
if (f2c_abs(dsigma[2]) <= hlftol)
{
dsigma[2] = hlftol;
}
if (m > n)
{
z__[1] = slapy2_(&z1, &z__[m]);
if (z__[1] <= tol)
{
c__ = 1.f;
s = 0.f;
z__[1] = tol;
}
else
{
c__ = z1 / z__[1];
s = z__[m] / z__[1];
}
}
else
{
if (f2c_abs(z1) <= tol)
{
z__[1] = tol;
}
else
{
z__[1] = z1;
}
}
/* Move the rest of the updating row to Z. */
i__1 = *k - 1;
scopy_(&i__1, &u2[u2_dim1 + 2], &c__1, &z__[2], &c__1);
/* Determine the first column of U2, the first row of VT2 and the */
/* last row of VT. */
slaset_("A", &n, &c__1, &c_b30, &c_b30, &u2[u2_offset], ldu2);
u2[nlp1 + u2_dim1] = 1.f;
if (m > n)
{
i__1 = nlp1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
vt[m + i__ * vt_dim1] = -s * vt[nlp1 + i__ * vt_dim1];
vt2[i__ * vt2_dim1 + 1] = c__ * vt[nlp1 + i__ * vt_dim1];
/* L170: */
}
i__1 = m;
for (i__ = nlp2;
i__ <= i__1;
++i__)
{
vt2[i__ * vt2_dim1 + 1] = s * vt[m + i__ * vt_dim1];
vt[m + i__ * vt_dim1] = c__ * vt[m + i__ * vt_dim1];
/* L180: */
}
}
else
{
scopy_(&m, &vt[nlp1 + vt_dim1], ldvt, &vt2[vt2_dim1 + 1], ldvt2);
}
if (m > n)
{
scopy_(&m, &vt[m + vt_dim1], ldvt, &vt2[m + vt2_dim1], ldvt2);
}
/* The deflated singular values and their corresponding vectors go */
/* into the back of D, U, and V respectively. */
if (n > *k)
{
i__1 = n - *k;
scopy_(&i__1, &dsigma[*k + 1], &c__1, &d__[*k + 1], &c__1);
i__1 = n - *k;
slacpy_("A", &n, &i__1, &u2[(*k + 1) * u2_dim1 + 1], ldu2, &u[(*k + 1) * u_dim1 + 1], ldu);
i__1 = n - *k;
slacpy_("A", &i__1, &m, &vt2[*k + 1 + vt2_dim1], ldvt2, &vt[*k + 1 + vt_dim1], ldvt);
}
/* Copy CTOT into COLTYP for referencing in SLASD3. */
for (j = 1;
j <= 4;
++j)
{
coltyp[j] = ctot[j - 1];
/* L190: */
}
return 0;
/* End of SLASD2 */
}
/* Subroutine */ int chseqr_(char *job, char *compz, integer *n, integer *ilo,
integer *ihi, complex *h__, integer *ldh, complex *w, complex *z__,
integer *ldz, complex *work, integer *lwork, integer *info)
{
/* System generated locals */
address a__1[2];
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4[2],
i__5, i__6;
real r__1, r__2, r__3, r__4;
complex q__1;
char ch__1[2];
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static integer maxb, ierr;
static real unfl;
static complex temp;
static real ovfl, opst;
static integer i__, j, k, l;
static complex s[225] /* was [15][15] */;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
static complex v[16];
extern logical lsame_(char *, char *);
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *), ccopy_(integer *, complex *, integer *,
complex *, integer *);
static integer itemp;
static real rtemp;
static integer i1, i2;
static logical initz, wantt, wantz;
static real rwork[1];
extern doublereal slapy2_(real *, real *);
static integer ii, nh;
extern /* Subroutine */ int slabad_(real *, real *), clarfg_(integer *,
complex *, complex *, integer *, complex *);
static integer nr, ns;
extern integer icamax_(integer *, complex *, integer *);
static integer nv;
extern doublereal slamch_(char *), clanhs_(char *, integer *,
complex *, integer *, real *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), clahqr_(logical *, logical *, integer *, integer *, integer *,
complex *, integer *, complex *, integer *, integer *, complex *,
integer *, integer *), clacpy_(char *, integer *, integer *,
complex *, integer *, complex *, integer *);
static complex vv[16];
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int clarfx_(char *, integer *, integer *, complex
*, complex *, complex *, integer *, complex *), xerbla_(
char *, integer *);
static real smlnum;
static logical lquery;
static integer itn;
static complex tau;
static integer its;
static real ulp, tst1;
#define h___subscr(a_1,a_2) (a_2)*h_dim1 + a_1
#define h___ref(a_1,a_2) h__[h___subscr(a_1,a_2)]
#define s_subscr(a_1,a_2) (a_2)*15 + a_1 - 16
#define s_ref(a_1,a_2) s[s_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
Common block to return operation count.
Purpose
=======
CHSEQR computes the eigenvalues of a complex upper Hessenberg
matrix H, and, optionally, the matrices T and Z from the Schur
decomposition H = Z T Z**H, where T is an upper triangular matrix
(the Schur form), and Z is the unitary matrix of Schur vectors.
Optionally Z may be postmultiplied into an input unitary matrix Q,
so that this routine can give the Schur factorization of a matrix A
which has been reduced to the Hessenberg form H by the unitary
matrix Q: A = Q*H*Q**H = (QZ)*T*(QZ)**H.
Arguments
=========
JOB (input) CHARACTER*1
= 'E': compute eigenvalues only;
= 'S': compute eigenvalues and the Schur form T.
COMPZ (input) CHARACTER*1
= 'N': no Schur vectors are computed;
= 'I': Z is initialized to the unit matrix and the matrix Z
of Schur vectors of H is returned;
= 'V': Z must contain an unitary matrix Q on entry, and
the product Q*Z is returned.
N (input) INTEGER
The order of the matrix H. N >= 0.
ILO (input) INTEGER
IHI (input) INTEGER
It is assumed that H is already upper triangular in rows
and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
set by a previous call to CGEBAL, and then passed to CGEHRD
when the matrix output by CGEBAL is reduced to Hessenberg
form. Otherwise ILO and IHI should be set to 1 and N
respectively.
1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
H (input/output) COMPLEX array, dimension (LDH,N)
On entry, the upper Hessenberg matrix H.
On exit, if JOB = 'S', H contains the upper triangular matrix
T from the Schur decomposition (the Schur form). If
JOB = 'E', the contents of H are unspecified on exit.
LDH (input) INTEGER
The leading dimension of the array H. LDH >= max(1,N).
W (output) COMPLEX array, dimension (N)
The computed eigenvalues. If JOB = 'S', the eigenvalues are
stored in the same order as on the diagonal of the Schur form
returned in H, with W(i) = H(i,i).
Z (input/output) COMPLEX array, dimension (LDZ,N)
If COMPZ = 'N': Z is not referenced.
If COMPZ = 'I': on entry, Z need not be set, and on exit, Z
contains the unitary matrix Z of the Schur vectors of H.
If COMPZ = 'V': on entry Z must contain an N-by-N matrix Q,
which is assumed to be equal to the unit matrix except for
the submatrix Z(ILO:IHI,ILO:IHI); on exit Z contains Q*Z.
Normally Q is the unitary matrix generated by CUNGHR after
the call to CGEHRD which formed the Hessenberg matrix H.
LDZ (input) INTEGER
The leading dimension of the array Z.
LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise.
WORK (workspace/output) COMPLEX 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.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, CHSEQR failed to compute all the
eigenvalues in a total of 30*(IHI-ILO+1) iterations;
elements 1:ilo-1 and i+1:n of W contain those
eigenvalues which have been successfully computed.
=====================================================================
Decode and test the input parameters
Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1 * 1;
h__ -= h_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
/* Function Body */
wantt = lsame_(job, "S");
initz = lsame_(compz, "I");
wantz = initz || lsame_(compz, "V");
*info = 0;
i__1 = max(1,*n);
work[1].r = (real) i__1, work[1].i = 0.f;
lquery = *lwork == -1;
if (! lsame_(job, "E") && ! wantt) {
*info = -1;
} else if (! lsame_(compz, "N") && ! wantz) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ilo < 1 || *ilo > max(1,*n)) {
*info = -4;
} else if (*ihi < min(*ilo,*n) || *ihi > *n) {
*info = -5;
} else if (*ldh < max(1,*n)) {
*info = -7;
} else if (*ldz < 1 || wantz && *ldz < max(1,*n)) {
*info = -10;
} else if (*lwork < max(1,*n) && ! lquery) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHSEQR", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* **
Initialize */
opst = 0.f;
/* **
Initialize Z, if necessary */
if (initz) {
claset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz);
}
/* Store the eigenvalues isolated by CGEBAL. */
i__1 = *ilo - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = h___subscr(i__, i__);
w[i__2].r = h__[i__3].r, w[i__2].i = h__[i__3].i;
/* L10: */
}
i__1 = *n;
for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = h___subscr(i__, i__);
w[i__2].r = h__[i__3].r, w[i__2].i = h__[i__3].i;
/* L20: */
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
if (*ilo == *ihi) {
i__1 = *ilo;
i__2 = h___subscr(*ilo, *ilo);
w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i;
return 0;
}
/* Set rows and columns ILO to IHI to zero below the first
subdiagonal. */
i__1 = *ihi - 2;
for (j = *ilo; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 2; i__ <= i__2; ++i__) {
i__3 = h___subscr(i__, j);
h__[i__3].r = 0.f, h__[i__3].i = 0.f;
/* L30: */
}
/* L40: */
}
nh = *ihi - *ilo + 1;
/* I1 and I2 are the indices of the first row and last column of H
to which transformations must be applied. If eigenvalues only are
being computed, I1 and I2 are re-set inside the main loop. */
if (wantt) {
i1 = 1;
i2 = *n;
} else {
i1 = *ilo;
i2 = *ihi;
}
/* Ensure that the subdiagonal elements are real. */
i__1 = *ihi;
for (i__ = *ilo + 1; i__ <= i__1; ++i__) {
i__2 = h___subscr(i__, i__ - 1);
temp.r = h__[i__2].r, temp.i = h__[i__2].i;
if (r_imag(&temp) != 0.f) {
r__1 = temp.r;
r__2 = r_imag(&temp);
rtemp = slapy2_(&r__1, &r__2);
i__2 = h___subscr(i__, i__ - 1);
h__[i__2].r = rtemp, h__[i__2].i = 0.f;
q__1.r = temp.r / rtemp, q__1.i = temp.i / rtemp;
temp.r = q__1.r, temp.i = q__1.i;
if (i2 > i__) {
i__2 = i2 - i__;
r_cnjg(&q__1, &temp);
cscal_(&i__2, &q__1, &h___ref(i__, i__ + 1), ldh);
}
i__2 = i__ - i1;
cscal_(&i__2, &temp, &h___ref(i1, i__), &c__1);
if (i__ < *ihi) {
i__2 = h___subscr(i__ + 1, i__);
i__3 = h___subscr(i__ + 1, i__);
q__1.r = temp.r * h__[i__3].r - temp.i * h__[i__3].i, q__1.i =
temp.r * h__[i__3].i + temp.i * h__[i__3].r;
h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
}
/* **
Increment op count */
opst += (i2 - i1 + 2) * 6;
/* ** */
if (wantz) {
cscal_(&nh, &temp, &z___ref(*ilo, i__), &c__1);
/* **
Increment op count */
opst += nh * 6;
/* ** */
}
}
/* L50: */
}
/* Determine the order of the multi-shift QR algorithm to be used.
Writing concatenation */
i__4[0] = 1, a__1[0] = job;
i__4[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__4, &c__2, (ftnlen)2);
ns = ilaenv_(&c__4, "CHSEQR", ch__1, n, ilo, ihi, &c_n1, (ftnlen)6, (
ftnlen)2);
/* Writing concatenation */
i__4[0] = 1, a__1[0] = job;
i__4[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__4, &c__2, (ftnlen)2);
maxb = ilaenv_(&c__8, "CHSEQR", ch__1, n, ilo, ihi, &c_n1, (ftnlen)6, (
ftnlen)2);
if (ns <= 1 || ns > nh || maxb >= nh) {
/* Use the standard double-shift algorithm */
clahqr_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &w[1], ilo,
ihi, &z__[z_offset], ldz, info);
return 0;
}
maxb = max(2,maxb);
/* Computing MIN */
i__1 = min(ns,maxb);
ns = min(i__1,15);
/* Now 1 < NS <= MAXB < NH.
Set machine-dependent constants for the stopping criterion.
If norm(H) <= sqrt(OVFL), overflow should not occur. */
unfl = slamch_("Safe minimum");
ovfl = 1.f / unfl;
slabad_(&unfl, &ovfl);
ulp = slamch_("Precision");
smlnum = unfl * (nh / ulp);
/* ITN is the total number of multiple-shift QR iterations allowed. */
itn = nh * 30;
/* The main loop begins here. I is the loop index and decreases from
IHI to ILO in steps of at most MAXB. Each iteration of the loop
works with the active submatrix in rows and columns L to I.
Eigenvalues I+1 to IHI have already converged. Either L = ILO, or
H(L,L-1) is negligible so that the matrix splits. */
i__ = *ihi;
L60:
if (i__ < *ilo) {
goto L180;
}
/* Perform multiple-shift QR iterations on rows and columns ILO to I
until a submatrix of order at most MAXB splits off at the bottom
because a subdiagonal element has become negligible. */
l = *ilo;
i__1 = itn;
for (its = 0; its <= i__1; ++its) {
/* Look for a single small subdiagonal element. */
i__2 = l + 1;
for (k = i__; k >= i__2; --k) {
i__3 = h___subscr(k - 1, k - 1);
i__5 = h___subscr(k, k);
tst1 = (r__1 = h__[i__3].r, dabs(r__1)) + (r__2 = r_imag(&h___ref(
k - 1, k - 1)), dabs(r__2)) + ((r__3 = h__[i__5].r, dabs(
r__3)) + (r__4 = r_imag(&h___ref(k, k)), dabs(r__4)));
if (tst1 == 0.f) {
i__3 = i__ - l + 1;
tst1 = clanhs_("1", &i__3, &h___ref(l, l), ldh, rwork);
/* **
Increment op count */
latime_1.ops += (i__ - l + 1) * 5 * (i__ - l) / 2;
/* ** */
}
i__3 = h___subscr(k, k - 1);
/* Computing MAX */
r__2 = ulp * tst1;
if ((r__1 = h__[i__3].r, dabs(r__1)) <= dmax(r__2,smlnum)) {
goto L80;
}
/* L70: */
}
L80:
l = k;
/* **
Increment op count */
opst += (i__ - l + 1) * 5;
/* ** */
if (l > *ilo) {
/* H(L,L-1) is negligible. */
i__2 = h___subscr(l, l - 1);
h__[i__2].r = 0.f, h__[i__2].i = 0.f;
}
/* Exit from loop if a submatrix of order <= MAXB has split off. */
if (l >= i__ - maxb + 1) {
goto L170;
}
/* Now the active submatrix is in rows and columns L to I. If
eigenvalues only are being computed, only the active submatrix
need be transformed. */
if (! wantt) {
i1 = l;
i2 = i__;
}
if (its == 20 || its == 30) {
/* Exceptional shifts. */
i__2 = i__;
for (ii = i__ - ns + 1; ii <= i__2; ++ii) {
i__3 = ii;
i__5 = h___subscr(ii, ii - 1);
i__6 = h___subscr(ii, ii);
r__3 = ((r__1 = h__[i__5].r, dabs(r__1)) + (r__2 = h__[i__6]
.r, dabs(r__2))) * 1.5f;
w[i__3].r = r__3, w[i__3].i = 0.f;
/* L90: */
}
/* **
Increment op count */
opst += ns << 1;
/* ** */
} else {
/* Use eigenvalues of trailing submatrix of order NS as shifts. */
clacpy_("Full", &ns, &ns, &h___ref(i__ - ns + 1, i__ - ns + 1),
ldh, s, &c__15);
clahqr_(&c_false, &c_false, &ns, &c__1, &ns, s, &c__15, &w[i__ -
ns + 1], &c__1, &ns, &z__[z_offset], ldz, &ierr);
if (ierr > 0) {
/* If CLAHQR failed to compute all NS eigenvalues, use the
unconverged diagonal elements as the remaining shifts. */
i__2 = ierr;
for (ii = 1; ii <= i__2; ++ii) {
i__3 = i__ - ns + ii;
i__5 = s_subscr(ii, ii);
w[i__3].r = s[i__5].r, w[i__3].i = s[i__5].i;
/* L100: */
}
}
}
/* Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns))
where G is the Hessenberg submatrix H(L:I,L:I) and w is
the vector of shifts (stored in W). The result is
stored in the local array V. */
v[0].r = 1.f, v[0].i = 0.f;
i__2 = ns + 1;
for (ii = 2; ii <= i__2; ++ii) {
i__3 = ii - 1;
v[i__3].r = 0.f, v[i__3].i = 0.f;
/* L110: */
}
nv = 1;
i__2 = i__;
for (j = i__ - ns + 1; j <= i__2; ++j) {
i__3 = nv + 1;
ccopy_(&i__3, v, &c__1, vv, &c__1);
i__3 = nv + 1;
i__5 = j;
q__1.r = -w[i__5].r, q__1.i = -w[i__5].i;
cgemv_("No transpose", &i__3, &nv, &c_b2, &h___ref(l, l), ldh, vv,
&c__1, &q__1, v, &c__1);
++nv;
/* **
Increment op count */
opst = opst + (nv << 3) * (*n + 1) + (nv + 1) * 6;
/* **
Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero,
reset it to the unit vector. */
itemp = icamax_(&nv, v, &c__1);
/* **
Increment op count */
opst += nv << 1;
/* ** */
i__3 = itemp - 1;
rtemp = (r__1 = v[i__3].r, dabs(r__1)) + (r__2 = r_imag(&v[itemp
- 1]), dabs(r__2));
if (rtemp == 0.f) {
v[0].r = 1.f, v[0].i = 0.f;
i__3 = nv;
for (ii = 2; ii <= i__3; ++ii) {
i__5 = ii - 1;
v[i__5].r = 0.f, v[i__5].i = 0.f;
/* L120: */
}
} else {
rtemp = dmax(rtemp,smlnum);
r__1 = 1.f / rtemp;
csscal_(&nv, &r__1, v, &c__1);
/* **
Increment op count */
opst += nv << 1;
/* ** */
}
/* L130: */
}
/* Multiple-shift QR step */
i__2 = i__ - 1;
for (k = l; k <= i__2; ++k) {
/* The first iteration of this loop determines a reflection G
from the vector V and applies it from left and right to H,
thus creating a nonzero bulge below the subdiagonal.
Each subsequent iteration determines a reflection G to
restore the Hessenberg form in the (K-1)th column, and thus
chases the bulge one step toward the bottom of the active
submatrix. NR is the order of G.
Computing MIN */
i__3 = ns + 1, i__5 = i__ - k + 1;
nr = min(i__3,i__5);
if (k > l) {
ccopy_(&nr, &h___ref(k, k - 1), &c__1, v, &c__1);
}
clarfg_(&nr, v, &v[1], &c__1, &tau);
/* **
Increment op count */
opst = opst + nr * 10 + 12;
/* ** */
if (k > l) {
i__3 = h___subscr(k, k - 1);
h__[i__3].r = v[0].r, h__[i__3].i = v[0].i;
i__3 = i__;
for (ii = k + 1; ii <= i__3; ++ii) {
i__5 = h___subscr(ii, k - 1);
h__[i__5].r = 0.f, h__[i__5].i = 0.f;
/* L140: */
}
}
v[0].r = 1.f, v[0].i = 0.f;
/* Apply G' from the left to transform the rows of the matrix
in columns K to I2. */
i__3 = i2 - k + 1;
r_cnjg(&q__1, &tau);
clarfx_("Left", &nr, &i__3, v, &q__1, &h___ref(k, k), ldh, &work[
1]);
/* Apply G from the right to transform the columns of the
matrix in rows I1 to min(K+NR,I).
Computing MIN */
i__5 = k + nr;
i__3 = min(i__5,i__) - i1 + 1;
clarfx_("Right", &i__3, &nr, v, &tau, &h___ref(i1, k), ldh, &work[
1]);
/* **
Increment op count
Computing MIN */
i__3 = nr, i__5 = i__ - k;
latime_1.ops += ((nr << 2) - 2 << 2) * (i2 - i1 + 2 + min(i__3,
i__5));
/* ** */
if (wantz) {
/* Accumulate transformations in the matrix Z */
clarfx_("Right", &nh, &nr, v, &tau, &z___ref(*ilo, k), ldz, &
work[1]);
/* **
Increment op count */
latime_1.ops += ((nr << 2) - 2 << 2) * nh;
/* ** */
}
/* L150: */
}
/* Ensure that H(I,I-1) is real. */
i__2 = h___subscr(i__, i__ - 1);
temp.r = h__[i__2].r, temp.i = h__[i__2].i;
if (r_imag(&temp) != 0.f) {
r__1 = temp.r;
r__2 = r_imag(&temp);
rtemp = slapy2_(&r__1, &r__2);
i__2 = h___subscr(i__, i__ - 1);
h__[i__2].r = rtemp, h__[i__2].i = 0.f;
q__1.r = temp.r / rtemp, q__1.i = temp.i / rtemp;
temp.r = q__1.r, temp.i = q__1.i;
if (i2 > i__) {
i__2 = i2 - i__;
r_cnjg(&q__1, &temp);
cscal_(&i__2, &q__1, &h___ref(i__, i__ + 1), ldh);
}
i__2 = i__ - i1;
cscal_(&i__2, &temp, &h___ref(i1, i__), &c__1);
/* **
Increment op count */
opst += (i2 - i1 + 1) * 6;
/* ** */
if (wantz) {
cscal_(&nh, &temp, &z___ref(*ilo, i__), &c__1);
/* **
Increment op count */
opst += nh * 6;
/* ** */
}
}
/* L160: */
}
/* Failure to converge in remaining number of iterations */
*info = i__;
return 0;
L170:
/* A submatrix of order <= MAXB in rows and columns L to I has split
off. Use the double-shift QR algorithm to handle it. */
clahqr_(&wantt, &wantz, n, &l, &i__, &h__[h_offset], ldh, &w[1], ilo, ihi,
&z__[z_offset], ldz, info);
if (*info > 0) {
return 0;
}
/* Decrement number of remaining iterations, and return to start of
the main loop with a new value of I. */
itn -= its;
i__ = l - 1;
goto L60;
L180:
/* **
Compute final op count */
latime_1.ops += opst;
/* ** */
i__1 = max(1,*n);
work[1].r = (real) i__1, work[1].i = 0.f;
return 0;
/* End of CHSEQR */
} /* chseqr_ */
/* Subroutine */ int chptrf_(char *uplo, integer *n, complex *ap, integer *
ipiv, integer *info, ftnlen uplo_len)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5, i__6;
real r__1, r__2, r__3, r__4;
complex q__1, q__2, q__3, q__4, q__5, q__6;
/* Builtin functions */
double sqrt(doublereal), r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
static real d__;
static integer i__, j, k;
static complex t;
static real r1, d11;
static complex d12;
static real d22;
static complex d21;
static integer kc, kk, kp;
static complex wk;
static integer kx;
static real tt;
static integer knc, kpc, npp;
static complex wkm1, wkp1;
extern /* Subroutine */ int chpr_(char *, integer *, real *, complex *,
integer *, complex *, ftnlen);
static integer imax, jmax;
static real alpha;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
complex *, integer *);
static integer kstep;
static logical upper;
extern doublereal slapy2_(real *, real *);
static real absakk;
extern integer icamax_(integer *, complex *, integer *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), xerbla_(char *, integer *, ftnlen);
static real colmax, rowmax;
/* -- 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 */
/* ======= */
/* CHPTRF computes the factorization of a complex Hermitian packed */
/* matrix A using the Bunch-Kaufman diagonal pivoting method: */
/* A = U*D*U**H or A = L*D*L**H */
/* where U (or L) is a product of permutation and unit upper (lower) */
/* triangular matrices, and D is Hermitian 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 array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the Hermitian matrix */
/* A, packed columnwise in a linear array. The j-th column of A */
/* is stored in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
/* On exit, 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", (ftnlen)1, (ftnlen)1);
if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHPTRF", &i__1, (ftnlen)6);
return 0;
}
/* Initialize ALPHA for use in choosing pivot block size. */
alpha = (sqrt(17.f) + 1.f) / 8.f;
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 = (r__1 = ap[i__1].r, dabs(r__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 = icamax_(&i__1, &ap[kc], &c__1);
i__1 = kc + imax - 1;
colmax = (r__1 = ap[i__1].r, dabs(r__1)) + (r__2 = r_imag(&ap[kc
+ imax - 1]), dabs(r__2));
} else {
colmax = 0.f;
}
if (dmax(absakk,colmax) == 0.f) {
/* Column K is zero: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
i__1 = kc + k - 1;
i__2 = kc + k - 1;
r__1 = ap[i__2].r;
ap[i__1].r = r__1, ap[i__1].i = 0.f;
} 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.f;
jmax = imax;
kx = imax * (imax + 1) / 2 + imax;
i__1 = k;
for (j = imax + 1; j <= i__1; ++j) {
i__2 = kx;
if ((r__1 = ap[i__2].r, dabs(r__1)) + (r__2 = r_imag(&ap[
kx]), dabs(r__2)) > rowmax) {
i__2 = kx;
rowmax = (r__1 = ap[i__2].r, dabs(r__1)) + (r__2 =
r_imag(&ap[kx]), dabs(r__2));
jmax = j;
}
kx += j;
/* L20: */
}
kpc = (imax - 1) * imax / 2 + 1;
if (imax > 1) {
i__1 = imax - 1;
jmax = icamax_(&i__1, &ap[kpc], &c__1);
/* Computing MAX */
i__1 = kpc + jmax - 1;
r__3 = rowmax, r__4 = (r__1 = ap[i__1].r, dabs(r__1)) + (
r__2 = r_imag(&ap[kpc + jmax - 1]), dabs(r__2));
rowmax = dmax(r__3,r__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 ((r__1 = ap[i__1].r, dabs(r__1)) >= 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;
cswap_(&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;
r_cnjg(&q__1, &ap[knc + j - 1]);
t.r = q__1.r, t.i = q__1.i;
i__2 = knc + j - 1;
r_cnjg(&q__1, &ap[kx]);
ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
i__2 = kx;
ap[i__2].r = t.r, ap[i__2].i = t.i;
/* L30: */
}
i__1 = kx + kk - 1;
r_cnjg(&q__1, &ap[kx + kk - 1]);
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
i__1 = knc + kk - 1;
r1 = ap[i__1].r;
i__1 = knc + kk - 1;
i__2 = kpc + kp - 1;
r__1 = ap[i__2].r;
ap[i__1].r = r__1, ap[i__1].i = 0.f;
i__1 = kpc + kp - 1;
ap[i__1].r = r1, ap[i__1].i = 0.f;
if (kstep == 2) {
i__1 = kc + k - 1;
i__2 = kc + k - 1;
r__1 = ap[i__2].r;
ap[i__1].r = r__1, ap[i__1].i = 0.f;
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;
}
} else {
i__1 = kc + k - 1;
i__2 = kc + k - 1;
r__1 = ap[i__2].r;
ap[i__1].r = r__1, ap[i__1].i = 0.f;
if (kstep == 2) {
i__1 = kc - 1;
i__2 = kc - 1;
r__1 = ap[i__2].r;
ap[i__1].r = r__1, ap[i__1].i = 0.f;
}
}
/* 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)' */
i__1 = kc + k - 1;
r1 = 1.f / ap[i__1].r;
i__1 = k - 1;
r__1 = -r1;
chpr_(uplo, &i__1, &r__1, &ap[kc], &c__1, &ap[1], (ftnlen)1);
/* Store U(k) in column k */
i__1 = k - 1;
csscal_(&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;
r__1 = ap[i__1].r;
r__2 = r_imag(&ap[k - 1 + (k - 1) * k / 2]);
d__ = slapy2_(&r__1, &r__2);
i__1 = k - 1 + (k - 2) * (k - 1) / 2;
d22 = ap[i__1].r / d__;
i__1 = k + (k - 1) * k / 2;
d11 = ap[i__1].r / d__;
tt = 1.f / (d11 * d22 - 1.f);
i__1 = k - 1 + (k - 1) * k / 2;
q__1.r = ap[i__1].r / d__, q__1.i = ap[i__1].i / d__;
d12.r = q__1.r, d12.i = q__1.i;
d__ = tt / d__;
for (j = k - 2; j >= 1; --j) {
i__1 = j + (k - 2) * (k - 1) / 2;
q__3.r = d11 * ap[i__1].r, q__3.i = d11 * ap[i__1].i;
r_cnjg(&q__5, &d12);
i__2 = j + (k - 1) * k / 2;
q__4.r = q__5.r * ap[i__2].r - q__5.i * ap[i__2].i,
q__4.i = q__5.r * ap[i__2].i + q__5.i * ap[
i__2].r;
q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i;
q__1.r = d__ * q__2.r, q__1.i = d__ * q__2.i;
wkm1.r = q__1.r, wkm1.i = q__1.i;
i__1 = j + (k - 1) * k / 2;
q__3.r = d22 * ap[i__1].r, q__3.i = d22 * ap[i__1].i;
i__2 = j + (k - 2) * (k - 1) / 2;
q__4.r = d12.r * ap[i__2].r - d12.i * ap[i__2].i,
q__4.i = d12.r * ap[i__2].i + d12.i * ap[i__2]
.r;
q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i;
q__1.r = d__ * q__2.r, q__1.i = d__ * q__2.i;
wk.r = q__1.r, wk.i = q__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;
r_cnjg(&q__4, &wk);
q__3.r = ap[i__3].r * q__4.r - ap[i__3].i *
q__4.i, q__3.i = ap[i__3].r * q__4.i + ap[
i__3].i * q__4.r;
q__2.r = ap[i__2].r - q__3.r, q__2.i = ap[i__2].i
- q__3.i;
i__4 = i__ + (k - 2) * (k - 1) / 2;
r_cnjg(&q__6, &wkm1);
q__5.r = ap[i__4].r * q__6.r - ap[i__4].i *
q__6.i, q__5.i = ap[i__4].r * q__6.i + ap[
i__4].i * q__6.r;
q__1.r = q__2.r - q__5.r, q__1.i = q__2.i -
q__5.i;
ap[i__1].r = q__1.r, ap[i__1].i = q__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;
i__1 = j + (j - 1) * j / 2;
i__2 = j + (j - 1) * j / 2;
r__1 = ap[i__2].r;
q__1.r = r__1, q__1.i = 0.f;
ap[i__1].r = q__1.r, ap[i__1].i = q__1.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 = (r__1 = ap[i__1].r, dabs(r__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 + icamax_(&i__1, &ap[kc + 1], &c__1);
i__1 = kc + imax - k;
colmax = (r__1 = ap[i__1].r, dabs(r__1)) + (r__2 = r_imag(&ap[kc
+ imax - k]), dabs(r__2));
} else {
colmax = 0.f;
}
if (dmax(absakk,colmax) == 0.f) {
/* Column K is zero: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
i__1 = kc;
i__2 = kc;
r__1 = ap[i__2].r;
ap[i__1].r = r__1, ap[i__1].i = 0.f;
} 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.f;
kx = kc + imax - k;
i__1 = imax - 1;
for (j = k; j <= i__1; ++j) {
i__2 = kx;
if ((r__1 = ap[i__2].r, dabs(r__1)) + (r__2 = r_imag(&ap[
kx]), dabs(r__2)) > rowmax) {
i__2 = kx;
rowmax = (r__1 = ap[i__2].r, dabs(r__1)) + (r__2 =
r_imag(&ap[kx]), dabs(r__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 + icamax_(&i__1, &ap[kpc + 1], &c__1);
/* Computing MAX */
i__1 = kpc + jmax - imax;
r__3 = rowmax, r__4 = (r__1 = ap[i__1].r, dabs(r__1)) + (
r__2 = r_imag(&ap[kpc + jmax - imax]), dabs(r__2))
;
rowmax = dmax(r__3,r__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 ((r__1 = ap[i__1].r, dabs(r__1)) >= 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;
cswap_(&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;
r_cnjg(&q__1, &ap[knc + j - kk]);
t.r = q__1.r, t.i = q__1.i;
i__2 = knc + j - kk;
r_cnjg(&q__1, &ap[kx]);
ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
i__2 = kx;
ap[i__2].r = t.r, ap[i__2].i = t.i;
/* L80: */
}
i__1 = knc + kp - kk;
r_cnjg(&q__1, &ap[knc + kp - kk]);
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
i__1 = knc;
r1 = ap[i__1].r;
i__1 = knc;
i__2 = kpc;
r__1 = ap[i__2].r;
ap[i__1].r = r__1, ap[i__1].i = 0.f;
i__1 = kpc;
ap[i__1].r = r1, ap[i__1].i = 0.f;
if (kstep == 2) {
i__1 = kc;
i__2 = kc;
r__1 = ap[i__2].r;
ap[i__1].r = r__1, ap[i__1].i = 0.f;
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;
}
} else {
i__1 = kc;
i__2 = kc;
r__1 = ap[i__2].r;
ap[i__1].r = r__1, ap[i__1].i = 0.f;
if (kstep == 2) {
i__1 = knc;
i__2 = knc;
r__1 = ap[i__2].r;
ap[i__1].r = r__1, ap[i__1].i = 0.f;
}
}
/* 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)' */
i__1 = kc;
r1 = 1.f / ap[i__1].r;
i__1 = *n - k;
r__1 = -r1;
chpr_(uplo, &i__1, &r__1, &ap[kc + 1], &c__1, &ap[kc + *n
- k + 1], (ftnlen)1);
/* Store L(k) in column K */
i__1 = *n - k;
csscal_(&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;
r__1 = ap[i__1].r;
r__2 = r_imag(&ap[k + 1 + (k - 1) * ((*n << 1) - k) / 2]);
d__ = slapy2_(&r__1, &r__2);
i__1 = k + 1 + k * ((*n << 1) - k - 1) / 2;
d11 = ap[i__1].r / d__;
i__1 = k + (k - 1) * ((*n << 1) - k) / 2;
d22 = ap[i__1].r / d__;
tt = 1.f / (d11 * d22 - 1.f);
i__1 = k + 1 + (k - 1) * ((*n << 1) - k) / 2;
q__1.r = ap[i__1].r / d__, q__1.i = ap[i__1].i / d__;
d21.r = q__1.r, d21.i = q__1.i;
d__ = tt / d__;
i__1 = *n;
for (j = k + 2; j <= i__1; ++j) {
i__2 = j + (k - 1) * ((*n << 1) - k) / 2;
q__3.r = d11 * ap[i__2].r, q__3.i = d11 * ap[i__2].i;
i__3 = j + k * ((*n << 1) - k - 1) / 2;
q__4.r = d21.r * ap[i__3].r - d21.i * ap[i__3].i,
q__4.i = d21.r * ap[i__3].i + d21.i * ap[i__3]
.r;
q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i;
q__1.r = d__ * q__2.r, q__1.i = d__ * q__2.i;
wk.r = q__1.r, wk.i = q__1.i;
i__2 = j + k * ((*n << 1) - k - 1) / 2;
q__3.r = d22 * ap[i__2].r, q__3.i = d22 * ap[i__2].i;
r_cnjg(&q__5, &d21);
i__3 = j + (k - 1) * ((*n << 1) - k) / 2;
q__4.r = q__5.r * ap[i__3].r - q__5.i * ap[i__3].i,
q__4.i = q__5.r * ap[i__3].i + q__5.i * ap[
i__3].r;
q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i;
q__1.r = d__ * q__2.r, q__1.i = d__ * q__2.i;
wkp1.r = q__1.r, wkp1.i = q__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;
r_cnjg(&q__4, &wk);
q__3.r = ap[i__5].r * q__4.r - ap[i__5].i *
q__4.i, q__3.i = ap[i__5].r * q__4.i + ap[
i__5].i * q__4.r;
q__2.r = ap[i__4].r - q__3.r, q__2.i = ap[i__4].i
- q__3.i;
i__6 = i__ + k * ((*n << 1) - k - 1) / 2;
r_cnjg(&q__6, &wkp1);
q__5.r = ap[i__6].r * q__6.r - ap[i__6].i *
q__6.i, q__5.i = ap[i__6].r * q__6.i + ap[
i__6].i * q__6.r;
q__1.r = q__2.r - q__5.r, q__1.i = q__2.i -
q__5.i;
ap[i__3].r = q__1.r, ap[i__3].i = q__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;
i__2 = j + (j - 1) * ((*n << 1) - j) / 2;
i__3 = j + (j - 1) * ((*n << 1) - j) / 2;
r__1 = ap[i__3].r;
q__1.r = r__1, q__1.i = 0.f;
ap[i__2].r = q__1.r, ap[i__2].i = q__1.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 CHPTRF */
} /* chptrf_ */
/* Subroutine */ int slaed2_(integer *k, integer *n, integer *n1, real *d__,
real *q, integer *ldq, integer *indxq, real *rho, real *z__, real *
dlamda, real *w, real *q2, integer *indx, integer *indxc, integer *
indxp, integer *coltyp, integer *info)
{
/* System generated locals */
integer q_dim1, q_offset, i__1, i__2;
real r__1, r__2, r__3, r__4;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
real c__;
integer i__, j;
real s, t;
integer k2, n2, ct, nj, pj, js, iq1, iq2, n1p1;
real eps, tau, tol;
integer psm[4], imax, jmax, ctot[4];
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *), sscal_(integer *, real *, real *,
integer *), scopy_(integer *, real *, integer *, real *, integer *
);
extern doublereal slapy2_(real *, real *), slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer isamax_(integer *, real *, integer *);
extern /* Subroutine */ int slamrg_(integer *, integer *, real *, integer
*, integer *, integer *), slacpy_(char *, integer *, integer *,
real *, integer *, real *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLAED2 merges the two sets of eigenvalues together into a single */
/* sorted set. Then it tries to deflate the size of the problem. */
/* There are two ways in which deflation can occur: when two or more */
/* eigenvalues are close together or if there is a tiny entry in the */
/* Z vector. For each such occurrence the order of the related secular */
/* equation problem is reduced by one. */
/* Arguments */
/* ========= */
/* K (output) INTEGER */
/* The number of non-deflated eigenvalues, and the order of the */
/* related secular equation. 0 <= K <=N. */
/* N (input) INTEGER */
/* The dimension of the symmetric tridiagonal matrix. N >= 0. */
/* N1 (input) INTEGER */
/* The location of the last eigenvalue in the leading sub-matrix. */
/* min(1,N) <= N1 <= N/2. */
/* D (input/output) REAL array, dimension (N) */
/* On entry, D contains the eigenvalues of the two submatrices to */
/* be combined. */
/* On exit, D contains the trailing (N-K) updated eigenvalues */
/* (those which were deflated) sorted into increasing order. */
/* Q (input/output) REAL array, dimension (LDQ, N) */
/* On entry, Q contains the eigenvectors of two submatrices in */
/* the two square blocks with corners at (1,1), (N1,N1) */
/* and (N1+1, N1+1), (N,N). */
/* On exit, Q contains the trailing (N-K) updated eigenvectors */
/* (those which were deflated) in its last N-K columns. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= max(1,N). */
/* INDXQ (input/output) INTEGER array, dimension (N) */
/* The permutation which separately sorts the two sub-problems */
/* in D into ascending order. Note that elements in the second */
/* half of this permutation must first have N1 added to their */
/* values. Destroyed on exit. */
/* RHO (input/output) REAL */
/* On entry, the off-diagonal element associated with the rank-1 */
/* cut which originally split the two submatrices which are now */
/* being recombined. */
/* On exit, RHO has been modified to the value required by */
/* SLAED3. */
/* Z (input) REAL array, dimension (N) */
/* On entry, Z contains the updating vector (the last */
/* row of the first sub-eigenvector matrix and the first row of */
/* the second sub-eigenvector matrix). */
/* On exit, the contents of Z have been destroyed by the updating */
/* process. */
/* DLAMDA (output) REAL array, dimension (N) */
/* A copy of the first K eigenvalues which will be used by */
/* SLAED3 to form the secular equation. */
/* W (output) REAL array, dimension (N) */
/* The first k values of the final deflation-altered z-vector */
/* which will be passed to SLAED3. */
/* Q2 (output) REAL array, dimension (N1**2+(N-N1)**2) */
/* A copy of the first K eigenvectors which will be used by */
/* SLAED3 in a matrix multiply (SGEMM) to solve for the new */
/* eigenvectors. */
/* INDX (workspace) INTEGER array, dimension (N) */
/* The permutation used to sort the contents of DLAMDA into */
/* ascending order. */
/* INDXC (output) INTEGER array, dimension (N) */
/* The permutation used to arrange the columns of the deflated */
/* Q matrix into three groups: the first group contains non-zero */
/* elements only at and above N1, the second contains */
/* non-zero elements only below N1, and the third is dense. */
/* INDXP (workspace) INTEGER array, dimension (N) */
/* The permutation used to place deflated values of D at the end */
/* of the array. INDXP(1:K) points to the nondeflated D-values */
/* and INDXP(K+1:N) points to the deflated eigenvalues. */
/* COLTYP (workspace/output) INTEGER array, dimension (N) */
/* During execution, a label which will indicate which of the */
/* following types a column in the Q2 matrix is: */
/* 1 : non-zero in the upper half only; */
/* 2 : dense; */
/* 3 : non-zero in the lower half only; */
/* 4 : deflated. */
/* On exit, COLTYP(i) is the number of columns of type i, */
/* for i=1 to 4 only. */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Jeff Rutter, Computer Science Division, University of California */
/* at Berkeley, USA */
/* Modified by Francoise Tisseur, University of Tennessee. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--indxq;
--z__;
--dlamda;
--w;
--q2;
--indx;
--indxc;
--indxp;
--coltyp;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -2;
} else if (*ldq < max(1,*n)) {
*info = -6;
} else { /* if(complicated condition) */
/* Computing MIN */
i__1 = 1, i__2 = *n / 2;
if (min(i__1,i__2) > *n1 || *n / 2 < *n1) {
*info = -3;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SLAED2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
n2 = *n - *n1;
n1p1 = *n1 + 1;
if (*rho < 0.f) {
sscal_(&n2, &c_b3, &z__[n1p1], &c__1);
}
/* Normalize z so that norm(z) = 1. Since z is the concatenation of */
/* two normalized vectors, norm2(z) = sqrt(2). */
t = 1.f / sqrt(2.f);
sscal_(n, &t, &z__[1], &c__1);
/* RHO = ABS( norm(z)**2 * RHO ) */
*rho = (r__1 = *rho * 2.f, dabs(r__1));
/* Sort the eigenvalues into increasing order */
i__1 = *n;
for (i__ = n1p1; i__ <= i__1; ++i__) {
indxq[i__] += *n1;
/* L10: */
}
/* re-integrate the deflated parts from the last pass */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
dlamda[i__] = d__[indxq[i__]];
/* L20: */
}
slamrg_(n1, &n2, &dlamda[1], &c__1, &c__1, &indxc[1]);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
indx[i__] = indxq[indxc[i__]];
/* L30: */
}
/* Calculate the allowable deflation tolerance */
imax = isamax_(n, &z__[1], &c__1);
jmax = isamax_(n, &d__[1], &c__1);
eps = slamch_("Epsilon");
/* Computing MAX */
r__3 = (r__1 = d__[jmax], dabs(r__1)), r__4 = (r__2 = z__[imax], dabs(
r__2));
tol = eps * 8.f * dmax(r__3,r__4);
/* If the rank-1 modifier is small enough, no more needs to be done */
/* except to reorganize Q so that its columns correspond with the */
/* elements in D. */
if (*rho * (r__1 = z__[imax], dabs(r__1)) <= tol) {
*k = 0;
iq2 = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__ = indx[j];
scopy_(n, &q[i__ * q_dim1 + 1], &c__1, &q2[iq2], &c__1);
dlamda[j] = d__[i__];
iq2 += *n;
/* L40: */
}
slacpy_("A", n, n, &q2[1], n, &q[q_offset], ldq);
scopy_(n, &dlamda[1], &c__1, &d__[1], &c__1);
goto L190;
}
/* If there are multiple eigenvalues then the problem deflates. Here */
/* the number of equal eigenvalues are found. As each equal */
/* eigenvalue is found, an elementary reflector is computed to rotate */
/* the corresponding eigensubspace so that the corresponding */
/* components of Z are zero in this new basis. */
i__1 = *n1;
for (i__ = 1; i__ <= i__1; ++i__) {
coltyp[i__] = 1;
/* L50: */
}
i__1 = *n;
for (i__ = n1p1; i__ <= i__1; ++i__) {
coltyp[i__] = 3;
/* L60: */
}
*k = 0;
k2 = *n + 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
nj = indx[j];
if (*rho * (r__1 = z__[nj], dabs(r__1)) <= tol) {
/* Deflate due to small z component. */
--k2;
coltyp[nj] = 4;
indxp[k2] = nj;
if (j == *n) {
goto L100;
}
} else {
pj = nj;
goto L80;
}
/* L70: */
}
L80:
++j;
nj = indx[j];
if (j > *n) {
goto L100;
}
if (*rho * (r__1 = z__[nj], dabs(r__1)) <= tol) {
/* Deflate due to small z component. */
--k2;
coltyp[nj] = 4;
indxp[k2] = nj;
} else {
/* Check if eigenvalues are close enough to allow deflation. */
s = z__[pj];
c__ = z__[nj];
/* Find sqrt(a**2+b**2) without overflow or */
/* destructive underflow. */
tau = slapy2_(&c__, &s);
t = d__[nj] - d__[pj];
c__ /= tau;
s = -s / tau;
if ((r__1 = t * c__ * s, dabs(r__1)) <= tol) {
/* Deflation is possible. */
z__[nj] = tau;
z__[pj] = 0.f;
if (coltyp[nj] != coltyp[pj]) {
coltyp[nj] = 2;
}
coltyp[pj] = 4;
srot_(n, &q[pj * q_dim1 + 1], &c__1, &q[nj * q_dim1 + 1], &c__1, &
c__, &s);
/* Computing 2nd power */
r__1 = c__;
/* Computing 2nd power */
r__2 = s;
t = d__[pj] * (r__1 * r__1) + d__[nj] * (r__2 * r__2);
/* Computing 2nd power */
r__1 = s;
/* Computing 2nd power */
r__2 = c__;
d__[nj] = d__[pj] * (r__1 * r__1) + d__[nj] * (r__2 * r__2);
d__[pj] = t;
--k2;
i__ = 1;
L90:
if (k2 + i__ <= *n) {
if (d__[pj] < d__[indxp[k2 + i__]]) {
indxp[k2 + i__ - 1] = indxp[k2 + i__];
indxp[k2 + i__] = pj;
++i__;
goto L90;
} else {
indxp[k2 + i__ - 1] = pj;
}
} else {
indxp[k2 + i__ - 1] = pj;
}
pj = nj;
} else {
++(*k);
dlamda[*k] = d__[pj];
w[*k] = z__[pj];
indxp[*k] = pj;
pj = nj;
}
}
goto L80;
L100:
/* Record the last eigenvalue. */
++(*k);
dlamda[*k] = d__[pj];
w[*k] = z__[pj];
indxp[*k] = pj;
/* Count up the total number of the various types of columns, then */
/* form a permutation which positions the four column types into */
/* four uniform groups (although one or more of these groups may be */
/* empty). */
for (j = 1; j <= 4; ++j) {
ctot[j - 1] = 0;
/* L110: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
ct = coltyp[j];
++ctot[ct - 1];
/* L120: */
}
/* PSM(*) = Position in SubMatrix (of types 1 through 4) */
psm[0] = 1;
psm[1] = ctot[0] + 1;
psm[2] = psm[1] + ctot[1];
psm[3] = psm[2] + ctot[2];
*k = *n - ctot[3];
/* Fill out the INDXC array so that the permutation which it induces */
/* will place all type-1 columns first, all type-2 columns next, */
/* then all type-3's, and finally all type-4's. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
js = indxp[j];
ct = coltyp[js];
indx[psm[ct - 1]] = js;
indxc[psm[ct - 1]] = j;
++psm[ct - 1];
/* L130: */
}
/* Sort the eigenvalues and corresponding eigenvectors into DLAMDA */
/* and Q2 respectively. The eigenvalues/vectors which were not */
/* deflated go into the first K slots of DLAMDA and Q2 respectively, */
/* while those which were deflated go into the last N - K slots. */
i__ = 1;
iq1 = 1;
iq2 = (ctot[0] + ctot[1]) * *n1 + 1;
i__1 = ctot[0];
for (j = 1; j <= i__1; ++j) {
js = indx[i__];
scopy_(n1, &q[js * q_dim1 + 1], &c__1, &q2[iq1], &c__1);
z__[i__] = d__[js];
++i__;
iq1 += *n1;
/* L140: */
}
i__1 = ctot[1];
for (j = 1; j <= i__1; ++j) {
js = indx[i__];
scopy_(n1, &q[js * q_dim1 + 1], &c__1, &q2[iq1], &c__1);
scopy_(&n2, &q[*n1 + 1 + js * q_dim1], &c__1, &q2[iq2], &c__1);
z__[i__] = d__[js];
++i__;
iq1 += *n1;
iq2 += n2;
/* L150: */
}
i__1 = ctot[2];
for (j = 1; j <= i__1; ++j) {
js = indx[i__];
scopy_(&n2, &q[*n1 + 1 + js * q_dim1], &c__1, &q2[iq2], &c__1);
z__[i__] = d__[js];
++i__;
iq2 += n2;
/* L160: */
}
iq1 = iq2;
i__1 = ctot[3];
for (j = 1; j <= i__1; ++j) {
js = indx[i__];
scopy_(n, &q[js * q_dim1 + 1], &c__1, &q2[iq2], &c__1);
iq2 += *n;
z__[i__] = d__[js];
++i__;
/* L170: */
}
/* The deflated eigenvalues and their corresponding vectors go back */
/* into the last N - K slots of D and Q respectively. */
slacpy_("A", n, &ctot[3], &q2[iq1], n, &q[(*k + 1) * q_dim1 + 1], ldq);
i__1 = *n - *k;
scopy_(&i__1, &z__[*k + 1], &c__1, &d__[*k + 1], &c__1);
/* Copy CTOT into COLTYP for referencing in SLAED3. */
for (j = 1; j <= 4; ++j) {
coltyp[j] = ctot[j - 1];
/* L180: */
}
L190:
return 0;
/* End of SLAED2 */
} /* slaed2_ */
int slasd2_(int *nl, int *nr, int *sqre, int
*k, float *d__, float *z__, float *alpha, float *beta, float *u, int *
ldu, float *vt, int *ldvt, float *dsigma, float *u2, int *ldu2,
float *vt2, int *ldvt2, int *idxp, int *idx, int *idxc,
int *idxq, int *coltyp, int *info)
{
/* System generated locals */
int u_dim1, u_offset, u2_dim1, u2_offset, vt_dim1, vt_offset,
vt2_dim1, vt2_offset, i__1;
float r__1, r__2;
/* Local variables */
float c__;
int i__, j, m, n;
float s;
int k2;
float z1;
int ct, jp;
float eps, tau, tol;
int psm[4], nlp1, nlp2, idxi, idxj, ctot[4];
extern int srot_(int *, float *, int *, float *,
int *, float *, float *);
int idxjp, jprev;
extern int scopy_(int *, float *, int *, float *,
int *);
extern double slapy2_(float *, float *), slamch_(char *);
extern int xerbla_(char *, int *), slamrg_(
int *, int *, float *, int *, int *, int *);
float hlftol;
extern int slacpy_(char *, int *, int *, float *,
int *, float *, int *), slaset_(char *, int *,
int *, float *, float *, float *, int *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLASD2 merges the two sets of singular values together into a single */
/* sorted set. Then it tries to deflate the size of the problem. */
/* There are two ways in which deflation can occur: when two or more */
/* singular values are close together or if there is a tiny entry in the */
/* Z vector. For each such occurrence the order of the related secular */
/* equation problem is reduced by one. */
/* SLASD2 is called from SLASD1. */
/* Arguments */
/* ========= */
/* NL (input) INTEGER */
/* The row dimension of the upper block. NL >= 1. */
/* NR (input) INTEGER */
/* The row dimension of the lower block. NR >= 1. */
/* SQRE (input) INTEGER */
/* = 0: the lower block is an NR-by-NR square matrix. */
/* = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */
/* The bidiagonal matrix has N = NL + NR + 1 rows and */
/* M = N + SQRE >= N columns. */
/* K (output) INTEGER */
/* Contains the dimension of the non-deflated matrix, */
/* This is the order of the related secular equation. 1 <= K <=N. */
/* D (input/output) REAL array, dimension (N) */
/* On entry D contains the singular values of the two submatrices */
/* to be combined. On exit D contains the trailing (N-K) updated */
/* singular values (those which were deflated) sorted into */
/* increasing order. */
/* Z (output) REAL array, dimension (N) */
/* On exit Z contains the updating row vector in the secular */
/* equation. */
/* ALPHA (input) REAL */
/* Contains the diagonal element associated with the added row. */
/* BETA (input) REAL */
/* Contains the off-diagonal element associated with the added */
/* row. */
/* U (input/output) REAL array, dimension (LDU,N) */
/* On entry U contains the left singular vectors of two */
/* submatrices in the two square blocks with corners at (1,1), */
/* (NL, NL), and (NL+2, NL+2), (N,N). */
/* On exit U contains the trailing (N-K) updated left singular */
/* vectors (those which were deflated) in its last N-K columns. */
/* LDU (input) INTEGER */
/* The leading dimension of the array U. LDU >= N. */
/* VT (input/output) REAL array, dimension (LDVT,M) */
/* On entry VT' contains the right singular vectors of two */
/* submatrices in the two square blocks with corners at (1,1), */
/* (NL+1, NL+1), and (NL+2, NL+2), (M,M). */
/* On exit VT' contains the trailing (N-K) updated right singular */
/* vectors (those which were deflated) in its last N-K columns. */
/* In case SQRE =1, the last row of VT spans the right null */
/* space. */
/* LDVT (input) INTEGER */
/* The leading dimension of the array VT. LDVT >= M. */
/* DSIGMA (output) REAL array, dimension (N) */
/* Contains a copy of the diagonal elements (K-1 singular values */
/* and one zero) in the secular equation. */
/* U2 (output) REAL array, dimension (LDU2,N) */
/* Contains a copy of the first K-1 left singular vectors which */
/* will be used by SLASD3 in a matrix multiply (SGEMM) to solve */
/* for the new left singular vectors. U2 is arranged into four */
/* blocks. The first block contains a column with 1 at NL+1 and */
/* zero everywhere else; the second block contains non-zero */
/* entries only at and above NL; the third contains non-zero */
/* entries only below NL+1; and the fourth is dense. */
/* LDU2 (input) INTEGER */
/* The leading dimension of the array U2. LDU2 >= N. */
/* VT2 (output) REAL array, dimension (LDVT2,N) */
/* VT2' contains a copy of the first K right singular vectors */
/* which will be used by SLASD3 in a matrix multiply (SGEMM) to */
/* solve for the new right singular vectors. VT2 is arranged into */
/* three blocks. The first block contains a row that corresponds */
/* to the special 0 diagonal element in SIGMA; the second block */
/* contains non-zeros only at and before NL +1; the third block */
/* contains non-zeros only at and after NL +2. */
/* LDVT2 (input) INTEGER */
/* The leading dimension of the array VT2. LDVT2 >= M. */
/* IDXP (workspace) INTEGER array, dimension (N) */
/* This will contain the permutation used to place deflated */
/* values of D at the end of the array. On output IDXP(2:K) */
/* points to the nondeflated D-values and IDXP(K+1:N) */
/* points to the deflated singular values. */
/* IDX (workspace) INTEGER array, dimension (N) */
/* This will contain the permutation used to sort the contents of */
/* D into ascending order. */
/* IDXC (output) INTEGER array, dimension (N) */
/* This will contain the permutation used to arrange the columns */
/* of the deflated U matrix into three groups: the first group */
/* contains non-zero entries only at and above NL, the second */
/* contains non-zero entries only below NL+2, and the third is */
/* dense. */
/* IDXQ (input/output) INTEGER array, dimension (N) */
/* This contains the permutation which separately sorts the two */
/* sub-problems in D into ascending order. Note that entries in */
/* the first hlaf of this permutation must first be moved one */
/* position backward; and entries in the second half */
/* must first have NL+1 added to their values. */
/* COLTYP (workspace/output) INTEGER array, dimension (N) */
/* As workspace, this will contain a label which will indicate */
/* which of the following types a column in the U2 matrix or a */
/* row in the VT2 matrix is: */
/* 1 : non-zero in the upper half only */
/* 2 : non-zero in the lower half only */
/* 3 : dense */
/* 4 : deflated */
/* On exit, it is an array of dimension 4, with COLTYP(I) being */
/* the dimension of the I-th type columns. */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Ming Gu and Huan Ren, Computer Science Division, University of */
/* California at Berkeley, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--z__;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1;
vt -= vt_offset;
--dsigma;
u2_dim1 = *ldu2;
u2_offset = 1 + u2_dim1;
u2 -= u2_offset;
vt2_dim1 = *ldvt2;
vt2_offset = 1 + vt2_dim1;
vt2 -= vt2_offset;
--idxp;
--idx;
--idxc;
--idxq;
--coltyp;
/* Function Body */
*info = 0;
if (*nl < 1) {
*info = -1;
} else if (*nr < 1) {
*info = -2;
} else if (*sqre != 1 && *sqre != 0) {
*info = -3;
}
n = *nl + *nr + 1;
m = n + *sqre;
if (*ldu < n) {
*info = -10;
} else if (*ldvt < m) {
*info = -12;
} else if (*ldu2 < n) {
*info = -15;
} else if (*ldvt2 < m) {
*info = -17;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SLASD2", &i__1);
return 0;
}
nlp1 = *nl + 1;
nlp2 = *nl + 2;
/* Generate the first part of the vector Z; and move the singular */
/* values in the first part of D one position backward. */
z1 = *alpha * vt[nlp1 + nlp1 * vt_dim1];
z__[1] = z1;
for (i__ = *nl; i__ >= 1; --i__) {
z__[i__ + 1] = *alpha * vt[i__ + nlp1 * vt_dim1];
d__[i__ + 1] = d__[i__];
idxq[i__ + 1] = idxq[i__] + 1;
/* L10: */
}
/* Generate the second part of the vector Z. */
i__1 = m;
for (i__ = nlp2; i__ <= i__1; ++i__) {
z__[i__] = *beta * vt[i__ + nlp2 * vt_dim1];
/* L20: */
}
/* Initialize some reference arrays. */
i__1 = nlp1;
for (i__ = 2; i__ <= i__1; ++i__) {
coltyp[i__] = 1;
/* L30: */
}
i__1 = n;
for (i__ = nlp2; i__ <= i__1; ++i__) {
coltyp[i__] = 2;
/* L40: */
}
/* Sort the singular values into increasing order */
i__1 = n;
for (i__ = nlp2; i__ <= i__1; ++i__) {
idxq[i__] += nlp1;
/* L50: */
}
/* DSIGMA, IDXC, IDXC, and the first column of U2 */
/* are used as storage space. */
i__1 = n;
for (i__ = 2; i__ <= i__1; ++i__) {
dsigma[i__] = d__[idxq[i__]];
u2[i__ + u2_dim1] = z__[idxq[i__]];
idxc[i__] = coltyp[idxq[i__]];
/* L60: */
}
slamrg_(nl, nr, &dsigma[2], &c__1, &c__1, &idx[2]);
i__1 = n;
for (i__ = 2; i__ <= i__1; ++i__) {
idxi = idx[i__] + 1;
d__[i__] = dsigma[idxi];
z__[i__] = u2[idxi + u2_dim1];
coltyp[i__] = idxc[idxi];
/* L70: */
}
/* Calculate the allowable deflation tolerance */
eps = slamch_("Epsilon");
/* Computing MAX */
r__1 = ABS(*alpha), r__2 = ABS(*beta);
tol = MAX(r__1,r__2);
/* Computing MAX */
r__2 = (r__1 = d__[n], ABS(r__1));
tol = eps * 8.f * MAX(r__2,tol);
/* There are 2 kinds of deflation -- first a value in the z-vector */
/* is small, second two (or more) singular values are very close */
/* together (their difference is small). */
/* If the value in the z-vector is small, we simply permute the */
/* array so that the corresponding singular value is moved to the */
/* end. */
/* If two values in the D-vector are close, we perform a two-sided */
/* rotation designed to make one of the corresponding z-vector */
/* entries zero, and then permute the array so that the deflated */
/* singular value is moved to the end. */
/* If there are multiple singular values then the problem deflates. */
/* Here the number of equal singular values are found. As each equal */
/* singular value is found, an elementary reflector is computed to */
/* rotate the corresponding singular subspace so that the */
/* corresponding components of Z are zero in this new basis. */
*k = 1;
k2 = n + 1;
i__1 = n;
for (j = 2; j <= i__1; ++j) {
if ((r__1 = z__[j], ABS(r__1)) <= tol) {
/* Deflate due to small z component. */
--k2;
idxp[k2] = j;
coltyp[j] = 4;
if (j == n) {
goto L120;
}
} else {
jprev = j;
goto L90;
}
/* L80: */
}
L90:
j = jprev;
L100:
++j;
if (j > n) {
goto L110;
}
if ((r__1 = z__[j], ABS(r__1)) <= tol) {
/* Deflate due to small z component. */
--k2;
idxp[k2] = j;
coltyp[j] = 4;
} else {
/* Check if singular values are close enough to allow deflation. */
if ((r__1 = d__[j] - d__[jprev], ABS(r__1)) <= tol) {
/* Deflation is possible. */
s = z__[jprev];
c__ = z__[j];
/* Find sqrt(a**2+b**2) without overflow or */
/* destructive underflow. */
tau = slapy2_(&c__, &s);
c__ /= tau;
s = -s / tau;
z__[j] = tau;
z__[jprev] = 0.f;
/* Apply back the Givens rotation to the left and right */
/* singular vector matrices. */
idxjp = idxq[idx[jprev] + 1];
idxj = idxq[idx[j] + 1];
if (idxjp <= nlp1) {
--idxjp;
}
if (idxj <= nlp1) {
--idxj;
}
srot_(&n, &u[idxjp * u_dim1 + 1], &c__1, &u[idxj * u_dim1 + 1], &
c__1, &c__, &s);
srot_(&m, &vt[idxjp + vt_dim1], ldvt, &vt[idxj + vt_dim1], ldvt, &
c__, &s);
if (coltyp[j] != coltyp[jprev]) {
coltyp[j] = 3;
}
coltyp[jprev] = 4;
--k2;
idxp[k2] = jprev;
jprev = j;
} else {
++(*k);
u2[*k + u2_dim1] = z__[jprev];
dsigma[*k] = d__[jprev];
idxp[*k] = jprev;
jprev = j;
}
}
goto L100;
L110:
/* Record the last singular value. */
++(*k);
u2[*k + u2_dim1] = z__[jprev];
dsigma[*k] = d__[jprev];
idxp[*k] = jprev;
L120:
/* Count up the total number of the various types of columns, then */
/* form a permutation which positions the four column types into */
/* four groups of uniform structure (although one or more of these */
/* groups may be empty). */
for (j = 1; j <= 4; ++j) {
ctot[j - 1] = 0;
/* L130: */
}
i__1 = n;
for (j = 2; j <= i__1; ++j) {
ct = coltyp[j];
++ctot[ct - 1];
/* L140: */
}
/* PSM(*) = Position in SubMatrix (of types 1 through 4) */
psm[0] = 2;
psm[1] = ctot[0] + 2;
psm[2] = psm[1] + ctot[1];
psm[3] = psm[2] + ctot[2];
/* Fill out the IDXC array so that the permutation which it induces */
/* will place all type-1 columns first, all type-2 columns next, */
/* then all type-3's, and finally all type-4's, starting from the */
/* second column. This applies similarly to the rows of VT. */
i__1 = n;
for (j = 2; j <= i__1; ++j) {
jp = idxp[j];
ct = coltyp[jp];
idxc[psm[ct - 1]] = j;
++psm[ct - 1];
/* L150: */
}
/* Sort the singular values and corresponding singular vectors into */
/* DSIGMA, U2, and VT2 respectively. The singular values/vectors */
/* which were not deflated go into the first K slots of DSIGMA, U2, */
/* and VT2 respectively, while those which were deflated go into the */
/* last N - K slots, except that the first column/row will be treated */
/* separately. */
i__1 = n;
for (j = 2; j <= i__1; ++j) {
jp = idxp[j];
dsigma[j] = d__[jp];
idxj = idxq[idx[idxp[idxc[j]]] + 1];
if (idxj <= nlp1) {
--idxj;
}
scopy_(&n, &u[idxj * u_dim1 + 1], &c__1, &u2[j * u2_dim1 + 1], &c__1);
scopy_(&m, &vt[idxj + vt_dim1], ldvt, &vt2[j + vt2_dim1], ldvt2);
/* L160: */
}
/* Determine DSIGMA(1), DSIGMA(2) and Z(1) */
dsigma[1] = 0.f;
hlftol = tol / 2.f;
if (ABS(dsigma[2]) <= hlftol) {
dsigma[2] = hlftol;
}
if (m > n) {
z__[1] = slapy2_(&z1, &z__[m]);
if (z__[1] <= tol) {
c__ = 1.f;
s = 0.f;
z__[1] = tol;
} else {
c__ = z1 / z__[1];
s = z__[m] / z__[1];
}
} else {
if (ABS(z1) <= tol) {
z__[1] = tol;
} else {
z__[1] = z1;
}
}
/* Move the rest of the updating row to Z. */
i__1 = *k - 1;
scopy_(&i__1, &u2[u2_dim1 + 2], &c__1, &z__[2], &c__1);
/* Determine the first column of U2, the first row of VT2 and the */
/* last row of VT. */
slaset_("A", &n, &c__1, &c_b30, &c_b30, &u2[u2_offset], ldu2);
u2[nlp1 + u2_dim1] = 1.f;
if (m > n) {
i__1 = nlp1;
for (i__ = 1; i__ <= i__1; ++i__) {
vt[m + i__ * vt_dim1] = -s * vt[nlp1 + i__ * vt_dim1];
vt2[i__ * vt2_dim1 + 1] = c__ * vt[nlp1 + i__ * vt_dim1];
/* L170: */
}
i__1 = m;
for (i__ = nlp2; i__ <= i__1; ++i__) {
vt2[i__ * vt2_dim1 + 1] = s * vt[m + i__ * vt_dim1];
vt[m + i__ * vt_dim1] = c__ * vt[m + i__ * vt_dim1];
/* L180: */
}
} else {
scopy_(&m, &vt[nlp1 + vt_dim1], ldvt, &vt2[vt2_dim1 + 1], ldvt2);
}
if (m > n) {
scopy_(&m, &vt[m + vt_dim1], ldvt, &vt2[m + vt2_dim1], ldvt2);
}
/* The deflated singular values and their corresponding vectors go */
/* into the back of D, U, and V respectively. */
if (n > *k) {
i__1 = n - *k;
scopy_(&i__1, &dsigma[*k + 1], &c__1, &d__[*k + 1], &c__1);
i__1 = n - *k;
slacpy_("A", &n, &i__1, &u2[(*k + 1) * u2_dim1 + 1], ldu2, &u[(*k + 1)
* u_dim1 + 1], ldu);
i__1 = n - *k;
slacpy_("A", &i__1, &m, &vt2[*k + 1 + vt2_dim1], ldvt2, &vt[*k + 1 +
vt_dim1], ldvt);
}
/* Copy CTOT into COLTYP for referencing in SLASD3. */
for (j = 1; j <= 4; ++j) {
coltyp[j] = ctot[j - 1];
/* L190: */
}
return 0;
/* End of SLASD2 */
} /* slasd2_ */
/* Subroutine */ int shseqr_(char *job, char *compz, integer *n, integer *ilo,
integer *ihi, real *h__, integer *ldh, real *wr, real *wi, real *z__,
integer *ldz, real *work, integer *lwork, integer *info, ftnlen
job_len, ftnlen compz_len)
{
/* System generated locals */
address a__1[2];
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3[2], i__4,
i__5;
real r__1, r__2;
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static integer i__, j, k, l;
static real s[225] /* was [15][15] */, v[16];
static integer i1, i2, ii, nh, nr, ns, nv;
static real vv[16];
static integer itn;
static real tau;
static integer its;
static real ulp, tst1;
static integer maxb;
static real absw;
static integer ierr;
static real unfl, temp, ovfl;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static integer itemp;
extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *,
ftnlen);
static logical initz, wantt;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
static logical wantz;
extern doublereal slapy2_(real *, real *);
extern /* Subroutine */ int slabad_(real *, real *);
extern doublereal slamch_(char *, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *,
real *);
extern integer isamax_(integer *, real *, integer *);
extern doublereal slanhs_(char *, integer *, real *, integer *, real *,
ftnlen);
extern /* Subroutine */ int slahqr_(logical *, logical *, integer *,
integer *, integer *, real *, integer *, real *, real *, integer *
, integer *, real *, integer *, integer *), slacpy_(char *,
integer *, integer *, real *, integer *, real *, integer *,
ftnlen), slaset_(char *, integer *, integer *, real *, real *,
real *, integer *, ftnlen), slarfx_(char *, integer *, integer *,
real *, real *, real *, integer *, real *, ftnlen);
static real smlnum;
static logical lquery;
/* -- 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 */
/* ======= */
/* SHSEQR computes the eigenvalues of a real upper Hessenberg matrix H */
/* and, optionally, the matrices T and Z from the Schur decomposition */
/* H = Z T Z**T, where T is an upper quasi-triangular matrix (the Schur */
/* form), and Z is the orthogonal matrix of Schur vectors. */
/* Optionally Z may be postmultiplied into an input orthogonal matrix Q, */
/* so that this routine can give the Schur factorization of a matrix A */
/* which has been reduced to the Hessenberg form H by the orthogonal */
/* matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* = 'E': compute eigenvalues only; */
/* = 'S': compute eigenvalues and the Schur form T. */
/* COMPZ (input) CHARACTER*1 */
/* = 'N': no Schur vectors are computed; */
/* = 'I': Z is initialized to the unit matrix and the matrix Z */
/* of Schur vectors of H is returned; */
/* = 'V': Z must contain an orthogonal matrix Q on entry, and */
/* the product Q*Z is returned. */
/* N (input) INTEGER */
/* The order of the matrix H. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* It is assumed that H is already upper triangular in rows */
/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */
/* set by a previous call to SGEBAL, and then passed to SGEHRD */
/* when the matrix output by SGEBAL is reduced to Hessenberg */
/* form. Otherwise ILO and IHI should be set to 1 and N */
/* respectively. */
/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
/* H (input/output) REAL array, dimension (LDH,N) */
/* On entry, the upper Hessenberg matrix H. */
/* On exit, if JOB = 'S', H contains the upper quasi-triangular */
/* matrix T from the Schur decomposition (the Schur form); */
/* 2-by-2 diagonal blocks (corresponding to complex conjugate */
/* pairs of eigenvalues) are returned in standard form, with */
/* H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0. If JOB = 'E', */
/* the contents of H are unspecified on exit. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH >= max(1,N). */
/* WR (output) REAL array, dimension (N) */
/* WI (output) REAL array, dimension (N) */
/* The real and imaginary parts, respectively, of the computed */
/* eigenvalues. If two eigenvalues are computed as a complex */
/* conjugate pair, they are stored in consecutive elements of */
/* WR and WI, say the i-th and (i+1)th, with WI(i) > 0 and */
/* WI(i+1) < 0. If JOB = 'S', the eigenvalues are stored in the */
/* same order as on the diagonal of the Schur form returned in */
/* H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 */
/* diagonal block, WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and */
/* WI(i+1) = -WI(i). */
/* Z (input/output) REAL array, dimension (LDZ,N) */
/* If COMPZ = 'N': Z is not referenced. */
/* If COMPZ = 'I': on entry, Z need not be set, and on exit, Z */
/* contains the orthogonal matrix Z of the Schur vectors of H. */
/* If COMPZ = 'V': on entry Z must contain an N-by-N matrix Q, */
/* which is assumed to be equal to the unit matrix except for */
/* the submatrix Z(ILO:IHI,ILO:IHI); on exit Z contains Q*Z. */
/* Normally Q is the orthogonal matrix generated by SORGHR after */
/* the call to SGEHRD which formed the Hessenberg matrix H. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. */
/* LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise. */
/* WORK (workspace/output) REAL 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. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, SHSEQR failed to compute all of the */
/* eigenvalues in a total of 30*(IHI-ILO+1) iterations; */
/* elements 1:ilo-1 and i+1:n of WR and WI contain those */
/* eigenvalues which have been successfully computed. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and test the input parameters */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--wr;
--wi;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
/* Function Body */
wantt = lsame_(job, "S", (ftnlen)1, (ftnlen)1);
initz = lsame_(compz, "I", (ftnlen)1, (ftnlen)1);
wantz = initz || lsame_(compz, "V", (ftnlen)1, (ftnlen)1);
*info = 0;
work[1] = (real) max(1,*n);
lquery = *lwork == -1;
if (! lsame_(job, "E", (ftnlen)1, (ftnlen)1) && ! wantt) {
*info = -1;
} else if (! lsame_(compz, "N", (ftnlen)1, (ftnlen)1) && ! wantz) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ilo < 1 || *ilo > max(1,*n)) {
*info = -4;
} else if (*ihi < min(*ilo,*n) || *ihi > *n) {
*info = -5;
} else if (*ldh < max(1,*n)) {
*info = -7;
} else if (*ldz < 1 || wantz && *ldz < max(1,*n)) {
*info = -11;
} else if (*lwork < max(1,*n) && ! lquery) {
*info = -13;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SHSEQR", &i__1, (ftnlen)6);
return 0;
} else if (lquery) {
return 0;
}
/* Initialize Z, if necessary */
if (initz) {
slaset_("Full", n, n, &c_b9, &c_b10, &z__[z_offset], ldz, (ftnlen)4);
}
/* Store the eigenvalues isolated by SGEBAL. */
i__1 = *ilo - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
wr[i__] = h__[i__ + i__ * h_dim1];
wi[i__] = 0.f;
/* L10: */
}
i__1 = *n;
for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
wr[i__] = h__[i__ + i__ * h_dim1];
wi[i__] = 0.f;
/* L20: */
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
if (*ilo == *ihi) {
wr[*ilo] = h__[*ilo + *ilo * h_dim1];
wi[*ilo] = 0.f;
return 0;
}
/* Set rows and columns ILO to IHI to zero below the first */
/* subdiagonal. */
i__1 = *ihi - 2;
for (j = *ilo; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 2; i__ <= i__2; ++i__) {
h__[i__ + j * h_dim1] = 0.f;
/* L30: */
}
/* L40: */
}
nh = *ihi - *ilo + 1;
/* Determine the order of the multi-shift QR algorithm to be used. */
/* Writing concatenation */
i__3[0] = 1, a__1[0] = job;
i__3[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
ns = ilaenv_(&c__4, "SHSEQR", ch__1, n, ilo, ihi, &c_n1, (ftnlen)6, (
ftnlen)2);
/* Writing concatenation */
i__3[0] = 1, a__1[0] = job;
i__3[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
maxb = ilaenv_(&c__8, "SHSEQR", ch__1, n, ilo, ihi, &c_n1, (ftnlen)6, (
ftnlen)2);
if (ns <= 2 || ns > nh || maxb >= nh) {
/* Use the standard double-shift algorithm */
slahqr_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &wi[
1], ilo, ihi, &z__[z_offset], ldz, info);
return 0;
}
maxb = max(3,maxb);
/* Computing MIN */
i__1 = min(ns,maxb);
ns = min(i__1,15);
/* Now 2 < NS <= MAXB < NH. */
/* Set machine-dependent constants for the stopping criterion. */
/* If norm(H) <= sqrt(OVFL), overflow should not occur. */
unfl = slamch_("Safe minimum", (ftnlen)12);
ovfl = 1.f / unfl;
slabad_(&unfl, &ovfl);
ulp = slamch_("Precision", (ftnlen)9);
smlnum = unfl * (nh / ulp);
/* I1 and I2 are the indices of the first row and last column of H */
/* to which transformations must be applied. If eigenvalues only are */
/* being computed, I1 and I2 are set inside the main loop. */
if (wantt) {
i1 = 1;
i2 = *n;
}
/* ITN is the total number of multiple-shift QR iterations allowed. */
itn = nh * 30;
/* The main loop begins here. I is the loop index and decreases from */
/* IHI to ILO in steps of at most MAXB. Each iteration of the loop */
/* works with the active submatrix in rows and columns L to I. */
/* Eigenvalues I+1 to IHI have already converged. Either L = ILO or */
/* H(L,L-1) is negligible so that the matrix splits. */
i__ = *ihi;
L50:
l = *ilo;
if (i__ < *ilo) {
goto L170;
}
/* Perform multiple-shift QR iterations on rows and columns ILO to I */
/* until a submatrix of order at most MAXB splits off at the bottom */
/* because a subdiagonal element has become negligible. */
i__1 = itn;
for (its = 0; its <= i__1; ++its) {
/* Look for a single small subdiagonal element. */
i__2 = l + 1;
for (k = i__; k >= i__2; --k) {
tst1 = (r__1 = h__[k - 1 + (k - 1) * h_dim1], dabs(r__1)) + (r__2
= h__[k + k * h_dim1], dabs(r__2));
if (tst1 == 0.f) {
i__4 = i__ - l + 1;
tst1 = slanhs_("1", &i__4, &h__[l + l * h_dim1], ldh, &work[1]
, (ftnlen)1);
}
/* Computing MAX */
r__2 = ulp * tst1;
if ((r__1 = h__[k + (k - 1) * h_dim1], dabs(r__1)) <= dmax(r__2,
smlnum)) {
goto L70;
}
/* L60: */
}
L70:
l = k;
if (l > *ilo) {
/* H(L,L-1) is negligible. */
h__[l + (l - 1) * h_dim1] = 0.f;
}
/* Exit from loop if a submatrix of order <= MAXB has split off. */
if (l >= i__ - maxb + 1) {
goto L160;
}
/* Now the active submatrix is in rows and columns L to I. If */
/* eigenvalues only are being computed, only the active submatrix */
/* need be transformed. */
if (! wantt) {
i1 = l;
i2 = i__;
}
if (its == 20 || its == 30) {
/* Exceptional shifts. */
i__2 = i__;
for (ii = i__ - ns + 1; ii <= i__2; ++ii) {
wr[ii] = ((r__1 = h__[ii + (ii - 1) * h_dim1], dabs(r__1)) + (
r__2 = h__[ii + ii * h_dim1], dabs(r__2))) * 1.5f;
wi[ii] = 0.f;
/* L80: */
}
} else {
/* Use eigenvalues of trailing submatrix of order NS as shifts. */
slacpy_("Full", &ns, &ns, &h__[i__ - ns + 1 + (i__ - ns + 1) *
h_dim1], ldh, s, &c__15, (ftnlen)4);
slahqr_(&c_false, &c_false, &ns, &c__1, &ns, s, &c__15, &wr[i__ -
ns + 1], &wi[i__ - ns + 1], &c__1, &ns, &z__[z_offset],
ldz, &ierr);
if (ierr > 0) {
/* If SLAHQR failed to compute all NS eigenvalues, use the */
/* unconverged diagonal elements as the remaining shifts. */
i__2 = ierr;
for (ii = 1; ii <= i__2; ++ii) {
wr[i__ - ns + ii] = s[ii + ii * 15 - 16];
wi[i__ - ns + ii] = 0.f;
/* L90: */
}
}
}
/* Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns)) */
/* where G is the Hessenberg submatrix H(L:I,L:I) and w is */
/* the vector of shifts (stored in WR and WI). The result is */
/* stored in the local array V. */
v[0] = 1.f;
i__2 = ns + 1;
for (ii = 2; ii <= i__2; ++ii) {
v[ii - 1] = 0.f;
/* L100: */
}
nv = 1;
i__2 = i__;
for (j = i__ - ns + 1; j <= i__2; ++j) {
if (wi[j] >= 0.f) {
if (wi[j] == 0.f) {
/* real shift */
i__4 = nv + 1;
scopy_(&i__4, v, &c__1, vv, &c__1);
i__4 = nv + 1;
r__1 = -wr[j];
sgemv_("No transpose", &i__4, &nv, &c_b10, &h__[l + l *
h_dim1], ldh, vv, &c__1, &r__1, v, &c__1, (ftnlen)
12);
++nv;
} else if (wi[j] > 0.f) {
/* complex conjugate pair of shifts */
i__4 = nv + 1;
scopy_(&i__4, v, &c__1, vv, &c__1);
i__4 = nv + 1;
r__1 = wr[j] * -2.f;
sgemv_("No transpose", &i__4, &nv, &c_b10, &h__[l + l *
h_dim1], ldh, v, &c__1, &r__1, vv, &c__1, (ftnlen)
12);
i__4 = nv + 1;
itemp = isamax_(&i__4, vv, &c__1);
/* Computing MAX */
r__2 = (r__1 = vv[itemp - 1], dabs(r__1));
temp = 1.f / dmax(r__2,smlnum);
i__4 = nv + 1;
sscal_(&i__4, &temp, vv, &c__1);
absw = slapy2_(&wr[j], &wi[j]);
temp = temp * absw * absw;
i__4 = nv + 2;
i__5 = nv + 1;
sgemv_("No transpose", &i__4, &i__5, &c_b10, &h__[l + l *
h_dim1], ldh, vv, &c__1, &temp, v, &c__1, (ftnlen)
12);
nv += 2;
}
/* Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero, */
/* reset it to the unit vector. */
itemp = isamax_(&nv, v, &c__1);
temp = (r__1 = v[itemp - 1], dabs(r__1));
if (temp == 0.f) {
v[0] = 1.f;
i__4 = nv;
for (ii = 2; ii <= i__4; ++ii) {
v[ii - 1] = 0.f;
/* L110: */
}
} else {
temp = dmax(temp,smlnum);
r__1 = 1.f / temp;
sscal_(&nv, &r__1, v, &c__1);
}
}
/* L120: */
}
/* Multiple-shift QR step */
i__2 = i__ - 1;
for (k = l; k <= i__2; ++k) {
/* The first iteration of this loop determines a reflection G */
/* from the vector V and applies it from left and right to H, */
/* thus creating a nonzero bulge below the subdiagonal. */
/* Each subsequent iteration determines a reflection G to */
/* restore the Hessenberg form in the (K-1)th column, and thus */
/* chases the bulge one step toward the bottom of the active */
/* submatrix. NR is the order of G. */
/* Computing MIN */
i__4 = ns + 1, i__5 = i__ - k + 1;
nr = min(i__4,i__5);
if (k > l) {
scopy_(&nr, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1);
}
slarfg_(&nr, v, &v[1], &c__1, &tau);
if (k > l) {
h__[k + (k - 1) * h_dim1] = v[0];
i__4 = i__;
for (ii = k + 1; ii <= i__4; ++ii) {
h__[ii + (k - 1) * h_dim1] = 0.f;
/* L130: */
}
}
v[0] = 1.f;
/* Apply G from the left to transform the rows of the matrix in */
/* columns K to I2. */
i__4 = i2 - k + 1;
slarfx_("Left", &nr, &i__4, v, &tau, &h__[k + k * h_dim1], ldh, &
work[1], (ftnlen)4);
/* Apply G from the right to transform the columns of the */
/* matrix in rows I1 to min(K+NR,I). */
/* Computing MIN */
i__5 = k + nr;
i__4 = min(i__5,i__) - i1 + 1;
slarfx_("Right", &i__4, &nr, v, &tau, &h__[i1 + k * h_dim1], ldh,
&work[1], (ftnlen)5);
if (wantz) {
/* Accumulate transformations in the matrix Z */
slarfx_("Right", &nh, &nr, v, &tau, &z__[*ilo + k * z_dim1],
ldz, &work[1], (ftnlen)5);
}
/* L140: */
}
/* L150: */
}
/* Failure to converge in remaining number of iterations */
*info = i__;
return 0;
L160:
/* A submatrix of order <= MAXB in rows and columns L to I has split */
/* off. Use the double-shift QR algorithm to handle it. */
slahqr_(&wantt, &wantz, n, &l, &i__, &h__[h_offset], ldh, &wr[1], &wi[1],
ilo, ihi, &z__[z_offset], ldz, info);
if (*info > 0) {
return 0;
}
/* Decrement number of remaining iterations, and return to start of */
/* the main loop with a new value of I. */
itn -= its;
i__ = l - 1;
goto L50;
L170:
work[1] = (real) max(1,*n);
return 0;
/* End of SHSEQR */
} /* shseqr_ */
/* Subroutine */ int ssterf_(integer *n, real *d, real *e, 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
=======
SSTERF computes all eigenvalues of a symmetric tridiagonal matrix
using the Pal-Walker-Kahan variant of the QL or QR algorithm.
Arguments
=========
N (input) INTEGER
The order of the matrix. N >= 0.
D (input/output) REAL array, dimension (N)
On entry, the n diagonal elements of the tridiagonal matrix.
On exit, if INFO = 0, the eigenvalues in ascending order.
E (input/output) REAL array, dimension (N-1)
On entry, the (n-1) subdiagonal elements of the tridiagonal
matrix.
On exit, E has been destroyed.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: the algorithm failed to find all of the eigenvalues in
a total of 30*N iterations; if INFO = i, then i
elements of E have not converged to zero.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__0 = 0;
static integer c__1 = 1;
static real c_b32 = 1.f;
/* System generated locals */
integer i__1;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal), r_sign(real *, real *);
/* Local variables */
static real oldc;
static integer lend, jtot;
extern /* Subroutine */ int slae2_(real *, real *, real *, real *, real *)
;
static real c;
static integer i, l, m;
static real p, gamma, r, s, alpha, sigma, anorm;
static integer l1, lendm1, lendp1;
static real bb;
extern doublereal slapy2_(real *, real *);
static integer iscale;
static real oldgam;
extern doublereal slamch_(char *);
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static real safmax;
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *);
static integer lendsv;
static real ssfmin;
static integer nmaxit;
static real ssfmax;
extern doublereal slanst_(char *, integer *, real *, real *);
extern /* Subroutine */ int slasrt_(char *, integer *, real *, integer *);
static integer lm1, mm1, nm1;
static real rt1, rt2, eps, rte;
static integer lsv;
static real tst, eps2;
#define E(I) e[(I)-1]
#define D(I) d[(I)-1]
*info = 0;
/* Quick return if possible */
if (*n < 0) {
*info = -1;
i__1 = -(*info);
xerbla_("SSTERF", &i__1);
return 0;
}
if (*n <= 1) {
return 0;
}
/* Determine the unit roundoff for this environment. */
eps = slamch_("E");
/* Computing 2nd power */
r__1 = eps;
eps2 = r__1 * r__1;
safmin = slamch_("S");
safmax = 1.f / safmin;
ssfmax = sqrt(safmax) / 3.f;
ssfmin = sqrt(safmin) / eps2;
/* Compute the eigenvalues of the tridiagonal matrix. */
nmaxit = *n * 30;
sigma = 0.f;
jtot = 0;
/* Determine where the matrix splits and choose QL or QR iteration
for each block, according to whether top or bottom diagonal
element is smaller. */
l1 = 1;
nm1 = *n - 1;
L10:
if (l1 > *n) {
goto L170;
}
if (l1 > 1) {
E(l1 - 1) = 0.f;
}
if (l1 <= nm1) {
i__1 = nm1;
for (m = l1; m <= nm1; ++m) {
tst = (r__1 = E(m), dabs(r__1));
if (tst == 0.f) {
goto L30;
}
if (tst <= sqrt((r__1 = D(m), dabs(r__1))) * sqrt((r__2 = D(m + 1)
, dabs(r__2))) * eps) {
E(m) = 0.f;
goto L30;
}
/* L20: */
}
}
m = *n;
L30:
l = l1;
lsv = l;
lend = m;
lendsv = lend;
l1 = m + 1;
if (lend == l) {
goto L10;
}
/* Scale submatrix in rows and columns L to LEND */
i__1 = lend - l + 1;
anorm = slanst_("I", &i__1, &D(l), &E(l));
iscale = 0;
if (anorm > ssfmax) {
iscale = 1;
i__1 = lend - l + 1;
slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &D(l), n,
info);
i__1 = lend - l;
slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &E(l), n,
info);
} else if (anorm < ssfmin) {
iscale = 2;
i__1 = lend - l + 1;
slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &D(l), n,
info);
i__1 = lend - l;
slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &E(l), n,
info);
}
i__1 = lend - 1;
for (i = l; i <= lend-1; ++i) {
/* Computing 2nd power */
r__1 = E(i);
E(i) = r__1 * r__1;
/* L40: */
}
/* Choose between QL and QR iteration */
if ((r__1 = D(lend), dabs(r__1)) < (r__2 = D(l), dabs(r__2))) {
lend = lsv;
l = lendsv;
}
if (lend >= l) {
/* QL Iteration
Look for small subdiagonal element. */
L50:
if (l != lend) {
lendm1 = lend - 1;
i__1 = lendm1;
for (m = l; m <= lendm1; ++m) {
tst = (r__1 = E(m), dabs(r__1));
if (tst <= eps2 * (r__1 = D(m) * D(m + 1), dabs(r__1))) {
goto L70;
}
/* L60: */
}
}
m = lend;
L70:
if (m < lend) {
E(m) = 0.f;
}
p = D(l);
if (m == l) {
goto L90;
}
/* If remaining matrix is 2 by 2, use SLAE2 to compute its
eigenvalues. */
if (m == l + 1) {
rte = sqrt(E(l));
slae2_(&D(l), &rte, &D(l + 1), &rt1, &rt2);
D(l) = rt1;
D(l + 1) = rt2;
E(l) = 0.f;
l += 2;
if (l <= lend) {
goto L50;
}
goto L150;
}
if (jtot == nmaxit) {
goto L150;
}
++jtot;
/* Form shift. */
rte = sqrt(E(l));
sigma = (D(l + 1) - p) / (rte * 2.f);
r = slapy2_(&sigma, &c_b32);
sigma = p - rte / (sigma + r_sign(&r, &sigma));
c = 1.f;
s = 0.f;
gamma = D(m) - sigma;
p = gamma * gamma;
/* Inner loop */
mm1 = m - 1;
i__1 = l;
for (i = mm1; i >= l; --i) {
bb = E(i);
r = p + bb;
if (i != m - 1) {
E(i + 1) = s * r;
}
oldc = c;
c = p / r;
s = bb / r;
oldgam = gamma;
alpha = D(i);
gamma = c * (alpha - sigma) - s * oldgam;
D(i + 1) = oldgam + (alpha - gamma);
if (c != 0.f) {
p = gamma * gamma / c;
} else {
p = oldc * bb;
}
/* L80: */
}
E(l) = s * p;
D(l) = sigma + gamma;
goto L50;
/* Eigenvalue found. */
L90:
D(l) = p;
++l;
if (l <= lend) {
goto L50;
}
goto L150;
} else {
/* QR Iteration
Look for small superdiagonal element. */
L100:
if (l != lend) {
lendp1 = lend + 1;
i__1 = lendp1;
for (m = l; m >= lendp1; --m) {
tst = (r__1 = E(m - 1), dabs(r__1));
if (tst <= eps2 * (r__1 = D(m) * D(m - 1), dabs(r__1))) {
goto L120;
}
/* L110: */
}
}
m = lend;
L120:
if (m > lend) {
E(m - 1) = 0.f;
}
p = D(l);
if (m == l) {
goto L140;
}
/* If remaining matrix is 2 by 2, use SLAE2 to compute its
eigenvalues. */
if (m == l - 1) {
rte = sqrt(E(l - 1));
slae2_(&D(l), &rte, &D(l - 1), &rt1, &rt2);
D(l) = rt1;
D(l - 1) = rt2;
E(l - 1) = 0.f;
l += -2;
if (l >= lend) {
goto L100;
}
goto L150;
}
if (jtot == nmaxit) {
goto L150;
}
++jtot;
/* Form shift. */
rte = sqrt(E(l - 1));
sigma = (D(l - 1) - p) / (rte * 2.f);
r = slapy2_(&sigma, &c_b32);
sigma = p - rte / (sigma + r_sign(&r, &sigma));
c = 1.f;
s = 0.f;
gamma = D(m) - sigma;
p = gamma * gamma;
/* Inner loop */
lm1 = l - 1;
i__1 = lm1;
for (i = m; i <= lm1; ++i) {
bb = E(i);
r = p + bb;
if (i != m) {
E(i - 1) = s * r;
}
oldc = c;
c = p / r;
s = bb / r;
oldgam = gamma;
alpha = D(i + 1);
gamma = c * (alpha - sigma) - s * oldgam;
D(i) = oldgam + (alpha - gamma);
if (c != 0.f) {
p = gamma * gamma / c;
} else {
p = oldc * bb;
}
/* L130: */
}
E(lm1) = s * p;
D(l) = sigma + gamma;
goto L100;
/* Eigenvalue found. */
L140:
D(l) = p;
--l;
if (l >= lend) {
goto L100;
}
goto L150;
}
/* Undo scaling if necessary */
L150:
if (iscale == 1) {
i__1 = lendsv - lsv + 1;
slascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &D(lsv), n,
info);
}
if (iscale == 2) {
i__1 = lendsv - lsv + 1;
slascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &D(lsv), n,
info);
}
/* Check for no convergence to an eigenvalue after a total
of N*MAXIT iterations. */
if (jtot == nmaxit) {
i__1 = *n - 1;
for (i = 1; i <= *n-1; ++i) {
if (E(i) != 0.f) {
++(*info);
}
/* L160: */
}
return 0;
}
goto L10;
/* Sort eigenvalues in increasing order. */
L170:
slasrt_("I", n, &D(1), info);
return 0;
/* End of SSTERF */
} /* ssterf_ */
/* Subroutine */ int sgeevx_(char *balanc, char *jobvl, char *jobvr, char *
sense, integer *n, real *a, integer *lda, real *wr, real *wi, real *
vl, integer *ldvl, real *vr, integer *ldvr, integer *ilo, integer *
ihi, real *scale, real *abnrm, real *rconde, real *rcondv, real *work,
integer *lwork, integer *iwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, k;
real r__, cs, sn;
char job[1];
real scl, dum[1], eps;
char side[1];
real anrm;
integer ierr, itau, iwrk, nout;
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *);
extern doublereal snrm2_(integer *, real *, integer *);
integer icond;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
extern doublereal slapy2_(real *, real *);
extern /* Subroutine */ int slabad_(real *, real *);
logical scalea;
real cscale;
extern /* Subroutine */ int sgebak_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, integer *, integer *), sgebal_(char *, integer *, real *, integer *,
integer *, integer *, real *, integer *);
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real
*, integer *, real *, real *, integer *, integer *), xerbla_(char
*, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
logical select[1];
real bignum;
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *);
extern integer isamax_(integer *, real *, integer *);
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), slartg_(real *, real *,
real *, real *, real *), sorghr_(integer *, integer *, integer *,
real *, integer *, real *, real *, integer *, integer *), shseqr_(
char *, char *, integer *, integer *, integer *, real *, integer *
, real *, real *, real *, integer *, real *, integer *, integer *), strevc_(char *, char *, logical *, integer *,
real *, integer *, real *, integer *, real *, integer *, integer *
, integer *, real *, integer *);
integer minwrk, maxwrk;
extern /* Subroutine */ int strsna_(char *, char *, logical *, integer *,
real *, integer *, real *, integer *, real *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *,
integer *);
logical wantvl, wntsnb;
integer hswork;
logical wntsne;
real smlnum;
logical lquery, wantvr, wntsnn, wntsnv;
/* -- LAPACK driver routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGEEVX computes for an N-by-N real nonsymmetric matrix A, the */
/* eigenvalues and, optionally, the left and/or right eigenvectors. */
/* Optionally also, it computes a balancing transformation to improve */
/* the conditioning of the eigenvalues and eigenvectors (ILO, IHI, */
/* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues */
/* (RCONDE), and reciprocal condition numbers for the right */
/* eigenvectors (RCONDV). */
/* The right eigenvector v(j) of A satisfies */
/* A * v(j) = lambda(j) * v(j) */
/* where lambda(j) is its eigenvalue. */
/* The left eigenvector u(j) of A satisfies */
/* u(j)**H * A = lambda(j) * u(j)**H */
/* where u(j)**H denotes the conjugate transpose of u(j). */
/* The computed eigenvectors are normalized to have Euclidean norm */
/* equal to 1 and largest component real. */
/* Balancing a matrix means permuting the rows and columns to make it */
/* more nearly upper triangular, and applying a diagonal similarity */
/* transformation D * A * D**(-1), where D is a diagonal matrix, to */
/* make its rows and columns closer in norm and the condition numbers */
/* of its eigenvalues and eigenvectors smaller. The computed */
/* reciprocal condition numbers correspond to the balanced matrix. */
/* Permuting rows and columns will not change the condition numbers */
/* (in exact arithmetic) but diagonal scaling will. For further */
/* explanation of balancing, see section 4.10.2 of the LAPACK */
/* Users' Guide. */
/* Arguments */
/* ========= */
/* BALANC (input) CHARACTER*1 */
/* Indicates how the input matrix should be diagonally scaled */
/* and/or permuted to improve the conditioning of its */
/* eigenvalues. */
/* = 'N': Do not diagonally scale or permute; */
/* = 'P': Perform permutations to make the matrix more nearly */
/* upper triangular. Do not diagonally scale; */
/* = 'S': Diagonally scale the matrix, i.e. replace A by */
/* D*A*D**(-1), where D is a diagonal matrix chosen */
/* to make the rows and columns of A more equal in */
/* norm. Do not permute; */
/* = 'B': Both diagonally scale and permute A. */
/* Computed reciprocal condition numbers will be for the matrix */
/* after balancing and/or permuting. Permuting does not change */
/* condition numbers (in exact arithmetic), but balancing does. */
/* JOBVL (input) CHARACTER*1 */
/* = 'N': left eigenvectors of A are not computed; */
/* = 'V': left eigenvectors of A are computed. */
/* If SENSE = 'E' or 'B', JOBVL must = 'V'. */
/* JOBVR (input) CHARACTER*1 */
/* = 'N': right eigenvectors of A are not computed; */
/* = 'V': right eigenvectors of A are computed. */
/* If SENSE = 'E' or 'B', JOBVR must = 'V'. */
/* SENSE (input) CHARACTER*1 */
/* Determines which reciprocal condition numbers are computed. */
/* = 'N': None are computed; */
/* = 'E': Computed for eigenvalues only; */
/* = 'V': Computed for right eigenvectors only; */
/* = 'B': Computed for eigenvalues and right eigenvectors. */
/* If SENSE = 'E' or 'B', both left and right eigenvectors */
/* must also be computed (JOBVL = 'V' and JOBVR = 'V'). */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the N-by-N matrix A. */
/* On exit, A has been overwritten. If JOBVL = 'V' or */
/* JOBVR = 'V', A contains the real Schur form of the balanced */
/* version of the input matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* WR (output) REAL array, dimension (N) */
/* WI (output) REAL array, dimension (N) */
/* WR and WI contain the real and imaginary parts, */
/* respectively, of the computed eigenvalues. Complex */
/* conjugate pairs of eigenvalues will appear consecutively */
/* with the eigenvalue having the positive imaginary part */
/* first. */
/* VL (output) REAL array, dimension (LDVL,N) */
/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */
/* after another in the columns of VL, in the same order */
/* as their eigenvalues. */
/* If JOBVL = 'N', VL is not referenced. */
/* If the j-th eigenvalue is real, then u(j) = VL(:,j), */
/* the j-th column of VL. */
/* If the j-th and (j+1)-st eigenvalues form a complex */
/* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and */
/* u(j+1) = VL(:,j) - i*VL(:,j+1). */
/* LDVL (input) INTEGER */
/* The leading dimension of the array VL. LDVL >= 1; if */
/* JOBVL = 'V', LDVL >= N. */
/* VR (output) REAL array, dimension (LDVR,N) */
/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */
/* after another in the columns of VR, in the same order */
/* as their eigenvalues. */
/* If JOBVR = 'N', VR is not referenced. */
/* If the j-th eigenvalue is real, then v(j) = VR(:,j), */
/* the j-th column of VR. */
/* If the j-th and (j+1)-st eigenvalues form a complex */
/* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and */
/* v(j+1) = VR(:,j) - i*VR(:,j+1). */
/* LDVR (input) INTEGER */
/* The leading dimension of the array VR. LDVR >= 1, and if */
/* JOBVR = 'V', LDVR >= N. */
/* ILO (output) INTEGER */
/* IHI (output) INTEGER */
/* ILO and IHI are integer values determined when A was */
/* balanced. The balanced A(i,j) = 0 if I > J and */
/* J = 1,...,ILO-1 or I = IHI+1,...,N. */
/* SCALE (output) REAL array, dimension (N) */
/* Details of the permutations and scaling factors applied */
/* when balancing A. If P(j) is the index of the row and column */
/* interchanged with row and column j, and D(j) is the scaling */
/* factor applied to row and column j, then */
/* SCALE(J) = P(J), for J = 1,...,ILO-1 */
/* = D(J), for J = ILO,...,IHI */
/* = P(J) for J = IHI+1,...,N. */
/* The order in which the interchanges are made is N to IHI+1, */
/* then 1 to ILO-1. */
/* ABNRM (output) REAL */
/* The one-norm of the balanced matrix (the maximum */
/* of the sum of absolute values of elements of any column). */
/* RCONDE (output) REAL array, dimension (N) */
/* RCONDE(j) is the reciprocal condition number of the j-th */
/* eigenvalue. */
/* RCONDV (output) REAL array, dimension (N) */
/* RCONDV(j) is the reciprocal condition number of the j-th */
/* right eigenvector. */
/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. If SENSE = 'N' or 'E', */
/* LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V', */
/* LWORK >= 3*N. If SENSE = 'V' or 'B', LWORK >= N*(N+6). */
/* For good performance, LWORK must generally be larger. */
/* 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. */
/* IWORK (workspace) INTEGER array, dimension (2*N-2) */
/* If SENSE = 'N' or 'E', not referenced. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = i, the QR algorithm failed to compute all the */
/* eigenvalues, and no eigenvectors or condition numbers */
/* have been computed; elements 1:ILO-1 and i+1:N of WR */
/* and WI contain eigenvalues which have converged. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--wr;
--wi;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--scale;
--rconde;
--rcondv;
--work;
--iwork;
/* Function Body */
*info = 0;
lquery = *lwork == -1;
wantvl = lsame_(jobvl, "V");
wantvr = lsame_(jobvr, "V");
wntsnn = lsame_(sense, "N");
wntsne = lsame_(sense, "E");
wntsnv = lsame_(sense, "V");
wntsnb = lsame_(sense, "B");
if (! (lsame_(balanc, "N") || lsame_(balanc, "S") || lsame_(balanc, "P")
|| lsame_(balanc, "B"))) {
*info = -1;
} else if (! wantvl && ! lsame_(jobvl, "N")) {
*info = -2;
} else if (! wantvr && ! lsame_(jobvr, "N")) {
*info = -3;
} else if (! (wntsnn || wntsne || wntsnb || wntsnv) || (wntsne || wntsnb)
&& ! (wantvl && wantvr)) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldvl < 1 || wantvl && *ldvl < *n) {
*info = -11;
} else if (*ldvr < 1 || wantvr && *ldvr < *n) {
*info = -13;
}
/* 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. */
/* HSWORK refers to the workspace preferred by SHSEQR, as */
/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
/* the worst case.) */
if (*info == 0) {
if (*n == 0) {
minwrk = 1;
maxwrk = 1;
} else {
maxwrk = *n + *n * ilaenv_(&c__1, "SGEHRD", " ", n, &c__1, n, &
c__0);
if (wantvl) {
shseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
1], &vl[vl_offset], ldvl, &work[1], &c_n1, info);
} else if (wantvr) {
shseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
1], &vr[vr_offset], ldvr, &work[1], &c_n1, info);
} else {
if (wntsnn) {
shseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &wr[1],
&wi[1], &vr[vr_offset], ldvr, &work[1], &c_n1,
info);
} else {
shseqr_("S", "N", n, &c__1, n, &a[a_offset], lda, &wr[1],
&wi[1], &vr[vr_offset], ldvr, &work[1], &c_n1,
info);
}
}
hswork = work[1];
if (! wantvl && ! wantvr) {
minwrk = *n << 1;
if (! wntsnn) {
/* Computing MAX */
i__1 = minwrk, i__2 = *n * *n + *n * 6;
minwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,hswork);
if (! wntsnn) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *n + *n * 6;
maxwrk = max(i__1,i__2);
}
} else {
minwrk = *n * 3;
if (! wntsnn && ! wntsne) {
/* Computing MAX */
i__1 = minwrk, i__2 = *n * *n + *n * 6;
minwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,hswork);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "SORGHR",
" ", n, &c__1, n, &c_n1);
maxwrk = max(i__1,i__2);
if (! wntsnn && ! wntsne) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *n + *n * 6;
maxwrk = max(i__1,i__2);
}
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * 3;
maxwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,minwrk);
}
work[1] = (real) maxwrk;
if (*lwork < minwrk && ! lquery) {
*info = -21;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGEEVX", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = slamch_("P");
smlnum = slamch_("S");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1.f / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
icond = 0;
anrm = slange_("M", n, n, &a[a_offset], lda, dum);
scalea = FALSE_;
if (anrm > 0.f && anrm < smlnum) {
scalea = TRUE_;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = TRUE_;
cscale = bignum;
}
if (scalea) {
slascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
ierr);
}
/* Balance the matrix and compute ABNRM */
sgebal_(balanc, n, &a[a_offset], lda, ilo, ihi, &scale[1], &ierr);
*abnrm = slange_("1", n, n, &a[a_offset], lda, dum);
if (scalea) {
dum[0] = *abnrm;
slascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &c__1, &
ierr);
*abnrm = dum[0];
}
/* Reduce to upper Hessenberg form */
/* (Workspace: need 2*N, prefer N+N*NB) */
itau = 1;
iwrk = itau + *n;
i__1 = *lwork - iwrk + 1;
sgehrd_(n, ilo, ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, &
ierr);
if (wantvl) {
/* Want left eigenvectors */
/* Copy Householder vectors to VL */
*(unsigned char *)side = 'L';
slacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl)
;
/* Generate orthogonal matrix in VL */
/* (Workspace: need 2*N-1, prefer N+(N-1)*NB) */
i__1 = *lwork - iwrk + 1;
sorghr_(n, ilo, ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk], &
i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VL */
/* (Workspace: need 1, prefer HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
shseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vl[
vl_offset], ldvl, &work[iwrk], &i__1, info);
if (wantvr) {
/* Want left and right eigenvectors */
/* Copy Schur vectors to VR */
*(unsigned char *)side = 'B';
slacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr);
}
} else if (wantvr) {
/* Want right eigenvectors */
/* Copy Householder vectors to VR */
*(unsigned char *)side = 'R';
slacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr)
;
/* Generate orthogonal matrix in VR */
/* (Workspace: need 2*N-1, prefer N+(N-1)*NB) */
i__1 = *lwork - iwrk + 1;
sorghr_(n, ilo, ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk], &
i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VR */
/* (Workspace: need 1, prefer HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
shseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vr[
vr_offset], ldvr, &work[iwrk], &i__1, info);
} else {
/* Compute eigenvalues only */
/* If condition numbers desired, compute Schur form */
if (wntsnn) {
*(unsigned char *)job = 'E';
} else {
*(unsigned char *)job = 'S';
}
/* (Workspace: need 1, prefer HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
shseqr_(job, "N", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vr[
vr_offset], ldvr, &work[iwrk], &i__1, info);
}
/* If INFO > 0 from SHSEQR, then quit */
if (*info > 0) {
goto L50;
}
if (wantvl || wantvr) {
/* Compute left and/or right eigenvectors */
/* (Workspace: need 3*N) */
strevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl,
&vr[vr_offset], ldvr, n, &nout, &work[iwrk], &ierr);
}
/* Compute condition numbers if desired */
/* (Workspace: need N*N+6*N unless SENSE = 'E') */
if (! wntsnn) {
strsna_(sense, "A", select, n, &a[a_offset], lda, &vl[vl_offset],
ldvl, &vr[vr_offset], ldvr, &rconde[1], &rcondv[1], n, &nout,
&work[iwrk], n, &iwork[1], &icond);
}
if (wantvl) {
/* Undo balancing of left eigenvectors */
sgebak_(balanc, "L", n, ilo, ihi, &scale[1], n, &vl[vl_offset], ldvl,
&ierr);
/* Normalize left eigenvectors and make largest component real */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (wi[i__] == 0.f) {
scl = 1.f / snrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
sscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
} else if (wi[i__] > 0.f) {
r__1 = snrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
r__2 = snrm2_(n, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
scl = 1.f / slapy2_(&r__1, &r__2);
sscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
sscal_(n, &scl, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
/* Computing 2nd power */
r__1 = vl[k + i__ * vl_dim1];
/* Computing 2nd power */
r__2 = vl[k + (i__ + 1) * vl_dim1];
work[k] = r__1 * r__1 + r__2 * r__2;
/* L10: */
}
k = isamax_(n, &work[1], &c__1);
slartg_(&vl[k + i__ * vl_dim1], &vl[k + (i__ + 1) * vl_dim1],
&cs, &sn, &r__);
srot_(n, &vl[i__ * vl_dim1 + 1], &c__1, &vl[(i__ + 1) *
vl_dim1 + 1], &c__1, &cs, &sn);
vl[k + (i__ + 1) * vl_dim1] = 0.f;
}
/* L20: */
}
}
if (wantvr) {
/* Undo balancing of right eigenvectors */
sgebak_(balanc, "R", n, ilo, ihi, &scale[1], n, &vr[vr_offset], ldvr,
&ierr);
/* Normalize right eigenvectors and make largest component real */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (wi[i__] == 0.f) {
scl = 1.f / snrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
sscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
} else if (wi[i__] > 0.f) {
r__1 = snrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
r__2 = snrm2_(n, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
scl = 1.f / slapy2_(&r__1, &r__2);
sscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
sscal_(n, &scl, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
/* Computing 2nd power */
r__1 = vr[k + i__ * vr_dim1];
/* Computing 2nd power */
r__2 = vr[k + (i__ + 1) * vr_dim1];
work[k] = r__1 * r__1 + r__2 * r__2;
/* L30: */
}
k = isamax_(n, &work[1], &c__1);
slartg_(&vr[k + i__ * vr_dim1], &vr[k + (i__ + 1) * vr_dim1],
&cs, &sn, &r__);
srot_(n, &vr[i__ * vr_dim1 + 1], &c__1, &vr[(i__ + 1) *
vr_dim1 + 1], &c__1, &cs, &sn);
vr[k + (i__ + 1) * vr_dim1] = 0.f;
}
/* L40: */
}
}
/* Undo scaling if necessary */
L50:
if (scalea) {
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = max(i__3,1);
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[*info +
1], &i__2, &ierr);
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = max(i__3,1);
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[*info +
1], &i__2, &ierr);
if (*info == 0) {
if ((wntsnv || wntsnb) && icond == 0) {
slascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &rcondv[
1], n, &ierr);
}
} else {
i__1 = *ilo - 1;
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[1],
n, &ierr);
i__1 = *ilo - 1;
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[1],
n, &ierr);
}
}
work[1] = (real) maxwrk;
return 0;
/* End of SGEEVX */
} /* sgeevx_ */
/* Subroutine */ int slaed2_(integer *k, integer *n, real *d, real *q,
integer *ldq, integer *indxq, real *rho, integer *cutpnt, real *z,
real *dlamda, real *q2, integer *ldq2, integer *indxc, real *w,
integer *indxp, integer *indx, integer *coltyp, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
Courant Institute, NAG Ltd., and Rice University
September 30, 1994
Purpose
=======
SLAED2 merges the two sets of eigenvalues together into a single
sorted set. Then it tries to deflate the size of the problem.
There are two ways in which deflation can occur: when two or more
eigenvalues are close together or if there is a tiny entry in the
Z vector. For each such occurrence the order of the related secular
equation problem is reduced by one.
Arguments
=========
K (output) INTEGER
The number of non-deflated eigenvalues, and the order of the
related secular equation. 0 <= K <=N.
N (input) INTEGER
The dimension of the symmetric tridiagonal matrix. N >= 0.
D (input/output) REAL array, dimension (N)
On entry, D contains the eigenvalues of the two submatrices to
be combined.
On exit, D contains the trailing (N-K) updated eigenvalues
(those which were deflated) sorted into increasing order.
Q (input/output) REAL array, dimension (LDQ, N)
On entry, Q contains the eigenvectors of two submatrices in
the two square blocks with corners at (1,1), (CUTPNT,CUTPNT)
and (CUTPNT+1, CUTPNT+1), (N,N).
On exit, Q contains the trailing (N-K) updated eigenvectors
(those which were deflated) in its last N-K columns.
LDQ (input) INTEGER
The leading dimension of the array Q. LDQ >= max(1,N).
INDXQ (input/output) INTEGER array, dimension (N)
The permutation which separately sorts the two sub-problems
in D into ascending order. Note that elements in the second
half of this permutation must first have CUTPNT added to their
values. Destroyed on exit.
RHO (input/output) REAL
On entry, the off-diagonal element associated with the rank-1
cut which originally split the two submatrices which are now
being recombined.
On exit, RHO has been modified to the value required by
SLAED3.
CUTPNT (input) INTEGER
The location of the last eigenvalue in the leading sub-matrix.
min(1,N) <= CUTPNT <= N.
Z (input) REAL array, dimension (N)
On entry, Z contains the updating vector (the last
row of the first sub-eigenvector matrix and the first row of
the second sub-eigenvector matrix).
On exit, the contents of Z have been destroyed by the updating
process.
DLAMDA (output) REAL array, dimension (N)
A copy of the first K eigenvalues which will be used by
SLAED3 to form the secular equation.
Q2 (output) REAL array, dimension (LDQ2, N)
A copy of the first K eigenvectors which will be used by
SLAED3 in a matrix multiply (SGEMM) to solve for the new
eigenvectors. Q2 is arranged into three blocks. The
first block contains non-zero elements only at and above
CUTPNT, the second contains non-zero elements only below
CUTPNT, and the third is dense.
LDQ2 (input) INTEGER
The leading dimension of the array Q2. LDQ2 >= max(1,N).
INDXC (output) INTEGER array, dimension (N)
The permutation used to arrange the columns of the deflated
Q matrix into three groups: the first group contains non-zero
elements only at and above CUTPNT, the second contains
non-zero elements only below CUTPNT, and the third is dense.
W (output) REAL array, dimension (N)
The first k values of the final deflation-altered z-vector
which will be passed to SLAED3.
INDXP (workspace) INTEGER array, dimension (N)
The permutation used to place deflated values of D at the end
of the array. INDXP(1:K) points to the nondeflated D-values
and INDXP(K+1:N) points to the deflated eigenvalues.
INDX (workspace) INTEGER array, dimension (N)
The permutation used to sort the contents of D into ascending
order.
COLTYP (workspace/output) INTEGER array, dimension (N)
During execution, a label which will indicate which of the
following types a column in the Q2 matrix is:
1 : non-zero in the upper half only;
2 : non-zero in the lower half only;
3 : dense;
4 : deflated.
On exit, COLTYP(i) is the number of columns of type i,
for i=1 to 4 only.
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static real c_b3 = -1.f;
static integer c__1 = 1;
/* System generated locals */
integer q_dim1, q_offset, q2_dim1, q2_offset, i__1;
real r__1, r__2, r__3, r__4;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer jlam, imax, jmax, ctot[4];
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *);
static real c;
static integer i, j;
static real s, t;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static integer k2;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
static integer n1, n2;
extern doublereal slapy2_(real *, real *);
static integer ct, jp;
extern doublereal slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer isamax_(integer *, real *, integer *);
extern /* Subroutine */ int slamrg_(integer *, integer *, real *, integer
*, integer *, integer *), slacpy_(char *, integer *, integer *,
real *, integer *, real *, integer *);
static integer n1p1;
static real eps, tau, tol;
static integer psm[4];
--d;
q_dim1 = *ldq;
q_offset = q_dim1 + 1;
q -= q_offset;
--indxq;
--z;
--dlamda;
q2_dim1 = *ldq2;
q2_offset = q2_dim1 + 1;
q2 -= q2_offset;
--indxc;
--w;
--indxp;
--indx;
--coltyp;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -2;
} else if (*ldq < max(1,*n)) {
*info = -5;
} else if (min(1,*n) > *cutpnt || *n < *cutpnt) {
*info = -8;
} else if (*ldq2 < max(1,*n)) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SLAED2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
n1 = *cutpnt;
n2 = *n - n1;
n1p1 = n1 + 1;
if (*rho < 0.f) {
sscal_(&n2, &c_b3, &z[n1p1], &c__1);
}
/* Normalize z so that norm(z) = 1. Since z is the concatenation of
two normalized vectors, norm2(z) = sqrt(2). */
t = 1.f / sqrt(2.f);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
indx[j] = j;
/* L10: */
}
sscal_(n, &t, &z[1], &c__1);
/* RHO = ABS( norm(z)**2 * RHO ) */
*rho = (r__1 = *rho * 2.f, dabs(r__1));
i__1 = *cutpnt;
for (i = 1; i <= i__1; ++i) {
coltyp[i] = 1;
/* L20: */
}
i__1 = *n;
for (i = *cutpnt + 1; i <= i__1; ++i) {
coltyp[i] = 2;
/* L30: */
}
/* Sort the eigenvalues into increasing order */
i__1 = *n;
for (i = *cutpnt + 1; i <= i__1; ++i) {
indxq[i] += *cutpnt;
/* L40: */
}
/* re-integrate the deflated parts from the last pass */
i__1 = *n;
for (i = 1; i <= i__1; ++i) {
dlamda[i] = d[indxq[i]];
w[i] = z[indxq[i]];
indxc[i] = coltyp[indxq[i]];
/* L50: */
}
slamrg_(&n1, &n2, &dlamda[1], &c__1, &c__1, &indx[1]);
i__1 = *n;
for (i = 1; i <= i__1; ++i) {
d[i] = dlamda[indx[i]];
z[i] = w[indx[i]];
coltyp[i] = indxc[indx[i]];
/* L60: */
}
/* Calculate the allowable deflation tolerance */
imax = isamax_(n, &z[1], &c__1);
jmax = isamax_(n, &d[1], &c__1);
eps = slamch_("Epsilon");
/* Computing MAX */
r__3 = (r__1 = d[jmax], dabs(r__1)), r__4 = (r__2 = z[imax], dabs(r__2));
tol = eps * 8.f * dmax(r__3,r__4);
/* If the rank-1 modifier is small enough, no more needs to be done
except to reorganize Q so that its columns correspond with the
elements in D. */
if (*rho * (r__1 = z[imax], dabs(r__1)) <= tol) {
*k = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
scopy_(n, &q[indxq[indx[j]] * q_dim1 + 1], &c__1, &q2[j * q2_dim1
+ 1], &c__1);
/* L70: */
}
slacpy_("A", n, n, &q2[q2_offset], ldq2, &q[q_offset], ldq);
goto L180;
}
/* If there are multiple eigenvalues then the problem deflates. Here
the number of equal eigenvalues are found. As each equal
eigenvalue is found, an elementary reflector is computed to rotate
the corresponding eigensubspace so that the corresponding
components of Z are zero in this new basis. */
*k = 0;
k2 = *n + 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (*rho * (r__1 = z[j], dabs(r__1)) <= tol) {
/* Deflate due to small z component. */
--k2;
indxp[k2] = j;
coltyp[j] = 4;
if (j == *n) {
goto L120;
}
} else {
jlam = j;
goto L90;
}
/* L80: */
}
L90:
++j;
if (j > *n) {
goto L110;
}
if (*rho * (r__1 = z[j], dabs(r__1)) <= tol) {
/* Deflate due to small z component. */
--k2;
indxp[k2] = j;
coltyp[j] = 4;
} else {
/* Check if eigenvalues are close enough to allow deflation. */
s = z[jlam];
c = z[j];
/* Find sqrt(a**2+b**2) without overflow or
destructive underflow. */
tau = slapy2_(&c, &s);
t = d[j] - d[jlam];
c /= tau;
s = -(doublereal)s / tau;
if ((r__1 = t * c * s, dabs(r__1)) <= tol) {
/* Deflation is possible. */
z[j] = tau;
z[jlam] = 0.f;
if (coltyp[j] != coltyp[jlam]) {
coltyp[j] = 3;
}
coltyp[jlam] = 4;
srot_(n, &q[indxq[indx[jlam]] * q_dim1 + 1], &c__1, &q[indxq[indx[
j]] * q_dim1 + 1], &c__1, &c, &s);
/* Computing 2nd power */
r__1 = c;
/* Computing 2nd power */
r__2 = s;
t = d[jlam] * (r__1 * r__1) + d[j] * (r__2 * r__2);
/* Computing 2nd power */
r__1 = s;
/* Computing 2nd power */
r__2 = c;
d[j] = d[jlam] * (r__1 * r__1) + d[j] * (r__2 * r__2);
d[jlam] = t;
--k2;
i = 1;
L100:
if (k2 + i <= *n) {
if (d[jlam] < d[indxp[k2 + i]]) {
indxp[k2 + i - 1] = indxp[k2 + i];
indxp[k2 + i] = jlam;
++i;
goto L100;
} else {
indxp[k2 + i - 1] = jlam;
}
} else {
indxp[k2 + i - 1] = jlam;
}
jlam = j;
} else {
++(*k);
w[*k] = z[jlam];
dlamda[*k] = d[jlam];
indxp[*k] = jlam;
jlam = j;
}
}
goto L90;
L110:
/* Record the last eigenvalue. */
++(*k);
w[*k] = z[jlam];
dlamda[*k] = d[jlam];
indxp[*k] = jlam;
L120:
/* Count up the total number of the various types of columns, then
form a permutation which positions the four column types into
four uniform groups (although one or more of these groups may be
empty). */
for (j = 1; j <= 4; ++j) {
ctot[j - 1] = 0;
/* L130: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
ct = coltyp[j];
++ctot[ct - 1];
/* L140: */
}
/* PSM(*) = Position in SubVISMatrix (of types 1 through 4) */
psm[0] = 1;
psm[1] = ctot[0] + 1;
psm[2] = psm[1] + ctot[1];
psm[3] = psm[2] + ctot[2];
/* Fill out the INDXC array so that the permutation which it induces
will place all type-1 columns first, all type-2 columns next,
then all type-3's, and finally all type-4's. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
jp = indxp[j];
ct = coltyp[jp];
indxc[psm[ct - 1]] = j;
++psm[ct - 1];
/* L150: */
}
/* Sort the eigenvalues and corresponding eigenvectors into DLAMDA
and Q2 respectively. The eigenvalues/vectors which were not
deflated go into the first K slots of DLAMDA and Q2 respectively,
while those which were deflated go into the last N - K slots. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
jp = indxp[j];
dlamda[j] = d[jp];
scopy_(n, &q[indxq[indx[indxp[indxc[j]]]] * q_dim1 + 1], &c__1, &q2[j
* q2_dim1 + 1], &c__1);
/* L160: */
}
/* The deflated eigenvalues and their corresponding vectors go back
into the last N - K slots of D and Q respectively. */
i__1 = *n - *k;
scopy_(&i__1, &dlamda[*k + 1], &c__1, &d[*k + 1], &c__1);
i__1 = *n - *k;
slacpy_("A", n, &i__1, &q2[(*k + 1) * q2_dim1 + 1], ldq2, &q[(*k + 1) *
q_dim1 + 1], ldq);
/* Copy CTOT into COLTYP for referencing in SLAED3. */
for (j = 1; j <= 4; ++j) {
coltyp[j] = ctot[j - 1];
/* L170: */
}
L180:
return 0;
/* End of SLAED2 */
} /* slaed2_ */
/* Subroutine */ int sgeev_(char *jobvl, char *jobvr, integer *n, real *a,
integer *lda, real *wr, real *wi, real *vl, integer *ldvl, real *vr,
integer *ldvr, real *work, integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, k;
real r__, cs, sn;
integer ihi;
real scl;
integer ilo;
real dum[1], eps;
integer ibal;
char side[1];
real anrm;
integer ierr, itau, iwrk, nout;
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *);
extern doublereal snrm2_(integer *, real *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
extern doublereal slapy2_(real *, real *);
extern /* Subroutine */ int slabad_(real *, real *);
logical scalea;
real cscale;
extern /* Subroutine */ int sgebak_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, integer *, integer *), sgebal_(char *, integer *, real *, integer *,
integer *, integer *, real *, integer *);
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real
*, integer *, real *, real *, integer *, integer *), xerbla_(char
*, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
logical select[1];
real bignum;
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *);
extern integer isamax_(integer *, real *, integer *);
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), slartg_(real *, real *,
real *, real *, real *), sorghr_(integer *, integer *, integer *,
real *, integer *, real *, real *, integer *, integer *), shseqr_(
char *, char *, integer *, integer *, integer *, real *, integer *
, real *, real *, real *, integer *, real *, integer *, integer *), strevc_(char *, char *, logical *, integer *,
real *, integer *, real *, integer *, real *, integer *, integer *
, integer *, real *, integer *);
integer minwrk, maxwrk;
logical wantvl;
real smlnum;
integer hswork;
logical lquery, wantvr;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGEEV computes for an N-by-N real nonsymmetric matrix A, the */
/* eigenvalues and, optionally, the left and/or right eigenvectors. */
/* The right eigenvector v(j) of A satisfies */
/* A * v(j) = lambda(j) * v(j) */
/* where lambda(j) is its eigenvalue. */
/* The left eigenvector u(j) of A satisfies */
/* u(j)**H * A = lambda(j) * u(j)**H */
/* where u(j)**H denotes the conjugate transpose of u(j). */
/* The computed eigenvectors are normalized to have Euclidean norm */
/* equal to 1 and largest component real. */
/* Arguments */
/* ========= */
/* JOBVL (input) CHARACTER*1 */
/* = 'N': left eigenvectors of A are not computed; */
/* = 'V': left eigenvectors of A are computed. */
/* JOBVR (input) CHARACTER*1 */
/* = 'N': right eigenvectors of A are not computed; */
/* = 'V': right eigenvectors of A are computed. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the N-by-N matrix A. */
/* On exit, A has been overwritten. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* WR (output) REAL array, dimension (N) */
/* WI (output) REAL array, dimension (N) */
/* WR and WI contain the real and imaginary parts, */
/* respectively, of the computed eigenvalues. Complex */
/* conjugate pairs of eigenvalues appear consecutively */
/* with the eigenvalue having the positive imaginary part */
/* first. */
/* VL (output) REAL array, dimension (LDVL,N) */
/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */
/* after another in the columns of VL, in the same order */
/* as their eigenvalues. */
/* If JOBVL = 'N', VL is not referenced. */
/* If the j-th eigenvalue is real, then u(j) = VL(:,j), */
/* the j-th column of VL. */
/* If the j-th and (j+1)-st eigenvalues form a complex */
/* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and */
/* u(j+1) = VL(:,j) - i*VL(:,j+1). */
/* LDVL (input) INTEGER */
/* The leading dimension of the array VL. LDVL >= 1; if */
/* JOBVL = 'V', LDVL >= N. */
/* VR (output) REAL array, dimension (LDVR,N) */
/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */
/* after another in the columns of VR, in the same order */
/* as their eigenvalues. */
/* If JOBVR = 'N', VR is not referenced. */
/* If the j-th eigenvalue is real, then v(j) = VR(:,j), */
/* the j-th column of VR. */
/* If the j-th and (j+1)-st eigenvalues form a complex */
/* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and */
/* v(j+1) = VR(:,j) - i*VR(:,j+1). */
/* LDVR (input) INTEGER */
/* The leading dimension of the array VR. LDVR >= 1; if */
/* JOBVR = 'V', LDVR >= N. */
/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,3*N), and */
/* if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good */
/* performance, LWORK must generally be larger. */
/* 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. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = i, the QR algorithm failed to compute all the */
/* eigenvalues, and no eigenvectors have been computed; */
/* elements i+1:N of WR and WI contain eigenvalues which */
/* have converged. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--wr;
--wi;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--work;
/* Function Body */
*info = 0;
lquery = *lwork == -1;
wantvl = lsame_(jobvl, "V");
wantvr = lsame_(jobvr, "V");
if (! wantvl && ! lsame_(jobvl, "N")) {
*info = -1;
} else if (! wantvr && ! lsame_(jobvr, "N")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldvl < 1 || wantvl && *ldvl < *n) {
*info = -9;
} else if (*ldvr < 1 || wantvr && *ldvr < *n) {
*info = -11;
}
/* 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. */
/* HSWORK refers to the workspace preferred by SHSEQR, as */
/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
/* the worst case.) */
if (*info == 0) {
if (*n == 0) {
minwrk = 1;
maxwrk = 1;
} else {
maxwrk = (*n << 1) + *n * ilaenv_(&c__1, "SGEHRD", " ", n, &c__1,
n, &c__0);
if (wantvl) {
minwrk = *n << 2;
/* Computing MAX */
i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
"SORGHR", " ", n, &c__1, n, &c_n1);
maxwrk = max(i__1,i__2);
shseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
1], &vl[vl_offset], ldvl, &work[1], &c_n1, info);
hswork = work[1];
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + 1, i__1 = max(i__1,i__2), i__2 = *
n + hswork;
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n << 2;
maxwrk = max(i__1,i__2);
} else if (wantvr) {
minwrk = *n << 2;
/* Computing MAX */
i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
"SORGHR", " ", n, &c__1, n, &c_n1);
maxwrk = max(i__1,i__2);
shseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
1], &vr[vr_offset], ldvr, &work[1], &c_n1, info);
hswork = work[1];
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + 1, i__1 = max(i__1,i__2), i__2 = *
n + hswork;
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n << 2;
maxwrk = max(i__1,i__2);
} else {
minwrk = *n * 3;
shseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
1], &vr[vr_offset], ldvr, &work[1], &c_n1, info);
hswork = work[1];
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + 1, i__1 = max(i__1,i__2), i__2 = *
n + hswork;
maxwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,minwrk);
}
work[1] = (real) maxwrk;
if (*lwork < minwrk && ! lquery) {
*info = -13;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGEEV ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = slamch_("P");
smlnum = slamch_("S");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1.f / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = slange_("M", n, n, &a[a_offset], lda, dum);
scalea = FALSE_;
if (anrm > 0.f && anrm < smlnum) {
scalea = TRUE_;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = TRUE_;
cscale = bignum;
}
if (scalea) {
slascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
ierr);
}
/* Balance the matrix */
/* (Workspace: need N) */
ibal = 1;
sgebal_("B", n, &a[a_offset], lda, &ilo, &ihi, &work[ibal], &ierr);
/* Reduce to upper Hessenberg form */
/* (Workspace: need 3*N, prefer 2*N+N*NB) */
itau = ibal + *n;
iwrk = itau + *n;
i__1 = *lwork - iwrk + 1;
sgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1,
&ierr);
if (wantvl) {
/* Want left eigenvectors */
/* Copy Householder vectors to VL */
*(unsigned char *)side = 'L';
slacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl)
;
/* Generate orthogonal matrix in VL */
/* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
i__1 = *lwork - iwrk + 1;
sorghr_(n, &ilo, &ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk],
&i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VL */
/* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
shseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &
vl[vl_offset], ldvl, &work[iwrk], &i__1, info);
if (wantvr) {
/* Want left and right eigenvectors */
/* Copy Schur vectors to VR */
*(unsigned char *)side = 'B';
slacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr);
}
} else if (wantvr) {
/* Want right eigenvectors */
/* Copy Householder vectors to VR */
*(unsigned char *)side = 'R';
slacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr)
;
/* Generate orthogonal matrix in VR */
/* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
i__1 = *lwork - iwrk + 1;
sorghr_(n, &ilo, &ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk],
&i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VR */
/* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
shseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &
vr[vr_offset], ldvr, &work[iwrk], &i__1, info);
} else {
/* Compute eigenvalues only */
/* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
shseqr_("E", "N", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &
vr[vr_offset], ldvr, &work[iwrk], &i__1, info);
}
/* If INFO > 0 from SHSEQR, then quit */
if (*info > 0) {
goto L50;
}
if (wantvl || wantvr) {
/* Compute left and/or right eigenvectors */
/* (Workspace: need 4*N) */
strevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl,
&vr[vr_offset], ldvr, n, &nout, &work[iwrk], &ierr);
}
if (wantvl) {
/* Undo balancing of left eigenvectors */
/* (Workspace: need N) */
sgebak_("B", "L", n, &ilo, &ihi, &work[ibal], n, &vl[vl_offset], ldvl,
&ierr);
/* Normalize left eigenvectors and make largest component real */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (wi[i__] == 0.f) {
scl = 1.f / snrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
sscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
} else if (wi[i__] > 0.f) {
r__1 = snrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
r__2 = snrm2_(n, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
scl = 1.f / slapy2_(&r__1, &r__2);
sscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
sscal_(n, &scl, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
/* Computing 2nd power */
r__1 = vl[k + i__ * vl_dim1];
/* Computing 2nd power */
r__2 = vl[k + (i__ + 1) * vl_dim1];
work[iwrk + k - 1] = r__1 * r__1 + r__2 * r__2;
/* L10: */
}
k = isamax_(n, &work[iwrk], &c__1);
slartg_(&vl[k + i__ * vl_dim1], &vl[k + (i__ + 1) * vl_dim1],
&cs, &sn, &r__);
srot_(n, &vl[i__ * vl_dim1 + 1], &c__1, &vl[(i__ + 1) *
vl_dim1 + 1], &c__1, &cs, &sn);
vl[k + (i__ + 1) * vl_dim1] = 0.f;
}
/* L20: */
}
}
if (wantvr) {
/* Undo balancing of right eigenvectors */
/* (Workspace: need N) */
sgebak_("B", "R", n, &ilo, &ihi, &work[ibal], n, &vr[vr_offset], ldvr,
&ierr);
/* Normalize right eigenvectors and make largest component real */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (wi[i__] == 0.f) {
scl = 1.f / snrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
sscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
} else if (wi[i__] > 0.f) {
r__1 = snrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
r__2 = snrm2_(n, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
scl = 1.f / slapy2_(&r__1, &r__2);
sscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
sscal_(n, &scl, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
/* Computing 2nd power */
r__1 = vr[k + i__ * vr_dim1];
/* Computing 2nd power */
r__2 = vr[k + (i__ + 1) * vr_dim1];
work[iwrk + k - 1] = r__1 * r__1 + r__2 * r__2;
/* L30: */
}
k = isamax_(n, &work[iwrk], &c__1);
slartg_(&vr[k + i__ * vr_dim1], &vr[k + (i__ + 1) * vr_dim1],
&cs, &sn, &r__);
srot_(n, &vr[i__ * vr_dim1 + 1], &c__1, &vr[(i__ + 1) *
vr_dim1 + 1], &c__1, &cs, &sn);
vr[k + (i__ + 1) * vr_dim1] = 0.f;
}
/* L40: */
}
}
/* Undo scaling if necessary */
L50:
if (scalea) {
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = max(i__3,1);
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[*info +
1], &i__2, &ierr);
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = max(i__3,1);
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[*info +
1], &i__2, &ierr);
if (*info > 0) {
i__1 = ilo - 1;
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[1],
n, &ierr);
i__1 = ilo - 1;
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[1],
n, &ierr);
}
}
work[1] = (real) maxwrk;
return 0;
/* End of SGEEV */
} /* sgeev_ */
/* Subroutine */ int snaup2_(integer *ido, char *bmat, integer *n, char *
which, integer *nev, integer *np, real *tol, real *resid, integer *
mode, integer *iupd, integer *ishift, integer *mxiter, real *v,
integer *ldv, real *h__, integer *ldh, real *ritzr, real *ritzi, real
*bounds, real *q, integer *ldq, real *workl, integer *ipntr, real *
workd, integer *info, ftnlen bmat_len, ftnlen which_len)
{
/* System generated locals */
integer h_dim1, h_offset, q_dim1, q_offset, v_dim1, v_offset, i__1, i__2;
real r__1, r__2;
doublereal d__1;
/* Builtin functions */
double pow_dd(doublereal *, doublereal *);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double sqrt(doublereal);
/* Local variables */
static integer j;
static real t0, t1, t2, t3;
static integer kp[4], np0, nev0;
static real eps23;
static integer ierr, iter;
static real temp;
extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
static logical getv0;
extern doublereal snrm2_(integer *, real *, integer *);
static logical cnorm;
static integer nconv;
static logical initv;
static real rnorm;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *), ivout_(integer *, integer *, integer *, integer *,
char *, ftnlen), smout_(integer *, integer *, integer *, real *,
integer *, integer *, char *, ftnlen), svout_(integer *, integer *
, real *, integer *, char *, ftnlen), sgetv0_(integer *, char *,
integer *, logical *, integer *, integer *, real *, integer *,
real *, real *, integer *, real *, integer *, ftnlen);
extern doublereal slapy2_(real *, real *);
static integer nevbef;
extern doublereal slamch_(char *, ftnlen);
extern /* Subroutine */ int second_(real *);
static logical update;
static char wprime[2];
static logical ushift;
static integer kplusp, msglvl, nptemp, numcnv;
extern /* Subroutine */ int snaitr_(integer *, char *, integer *, integer
*, integer *, integer *, real *, real *, real *, integer *, real *
, integer *, integer *, real *, integer *, ftnlen), snconv_(
integer *, real *, real *, real *, real *, integer *), sneigh_(
real *, integer *, real *, integer *, real *, real *, real *,
real *, integer *, real *, integer *), sngets_(integer *, char *,
integer *, integer *, real *, real *, real *, real *, real *,
ftnlen), snapps_(integer *, integer *, integer *, real *, real *,
real *, integer *, real *, integer *, real *, real *, integer *,
real *, real *), ssortc_(char *, logical *, integer *, real *,
real *, real *, ftnlen);
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %---------------% */
/* | Local Scalars | */
/* %---------------% */
/* %-----------------------% */
/* | Local array arguments | */
/* %-----------------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %---------------------% */
/* | Intrinsic Functions | */
/* %---------------------% */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
/* Parameter adjustments */
--workd;
--resid;
--workl;
--bounds;
--ritzi;
--ritzr;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--ipntr;
/* Function Body */
if (*ido == 0) {
second_(&t0);
msglvl = debug_1.mnaup2;
/* %-------------------------------------% */
/* | Get the machine dependent constant. | */
/* %-------------------------------------% */
eps23 = slamch_("Epsilon-Machine", (ftnlen)15);
d__1 = (doublereal) eps23;
eps23 = pow_dd(&d__1, &c_b3);
nev0 = *nev;
np0 = *np;
/* %-------------------------------------% */
/* | kplusp is the bound on the largest | */
/* | Lanczos factorization built. | */
/* | nconv is the current number of | */
/* | "converged" eigenvlues. | */
/* | iter is the counter on the current | */
/* | iteration step. | */
/* %-------------------------------------% */
kplusp = *nev + *np;
nconv = 0;
iter = 0;
/* %---------------------------------------% */
/* | Set flags for computing the first NEV | */
/* | steps of the Arnoldi factorization. | */
/* %---------------------------------------% */
getv0 = TRUE_;
update = FALSE_;
ushift = FALSE_;
cnorm = FALSE_;
if (*info != 0) {
/* %--------------------------------------------% */
/* | User provides the initial residual vector. | */
/* %--------------------------------------------% */
initv = TRUE_;
*info = 0;
} else {
initv = FALSE_;
}
}
/* %---------------------------------------------% */
/* | Get a possibly random starting vector and | */
/* | force it into the range of the operator OP. | */
/* %---------------------------------------------% */
/* L10: */
if (getv0) {
sgetv0_(ido, bmat, &c__1, &initv, n, &c__1, &v[v_offset], ldv, &resid[
1], &rnorm, &ipntr[1], &workd[1], info, (ftnlen)1);
if (*ido != 99) {
goto L9000;
}
if (rnorm == 0.f) {
/* %-----------------------------------------% */
/* | The initial vector is zero. Error exit. | */
/* %-----------------------------------------% */
*info = -9;
goto L1100;
}
getv0 = FALSE_;
*ido = 0;
}
/* %-----------------------------------% */
/* | Back from reverse communication : | */
/* | continue with update step | */
/* %-----------------------------------% */
if (update) {
goto L20;
}
/* %-------------------------------------------% */
/* | Back from computing user specified shifts | */
/* %-------------------------------------------% */
if (ushift) {
goto L50;
}
/* %-------------------------------------% */
/* | Back from computing residual norm | */
/* | at the end of the current iteration | */
/* %-------------------------------------% */
if (cnorm) {
goto L100;
}
/* %----------------------------------------------------------% */
/* | Compute the first NEV steps of the Arnoldi factorization | */
/* %----------------------------------------------------------% */
snaitr_(ido, bmat, n, &c__0, nev, mode, &resid[1], &rnorm, &v[v_offset],
ldv, &h__[h_offset], ldh, &ipntr[1], &workd[1], info, (ftnlen)1);
/* %---------------------------------------------------% */
/* | ido .ne. 99 implies use of reverse communication | */
/* | to compute operations involving OP and possibly B | */
/* %---------------------------------------------------% */
if (*ido != 99) {
goto L9000;
}
if (*info > 0) {
*np = *info;
*mxiter = iter;
*info = -9999;
goto L1200;
}
/* %--------------------------------------------------------------% */
/* | | */
/* | M A I N ARNOLDI I T E R A T I O N L O O P | */
/* | Each iteration implicitly restarts the Arnoldi | */
/* | factorization in place. | */
/* | | */
/* %--------------------------------------------------------------% */
L1000:
++iter;
if (msglvl > 0) {
ivout_(&debug_1.logfil, &c__1, &iter, &debug_1.ndigit, "_naup2: ****"
" Start of major iteration number ****", (ftnlen)49);
}
/* %-----------------------------------------------------------% */
/* | Compute NP additional steps of the Arnoldi factorization. | */
/* | Adjust NP since NEV might have been updated by last call | */
/* | to the shift application routine snapps. | */
/* %-----------------------------------------------------------% */
*np = kplusp - *nev;
if (msglvl > 1) {
ivout_(&debug_1.logfil, &c__1, nev, &debug_1.ndigit, "_naup2: The le"
"ngth of the current Arnoldi factorization", (ftnlen)55);
ivout_(&debug_1.logfil, &c__1, np, &debug_1.ndigit, "_naup2: Extend "
"the Arnoldi factorization by", (ftnlen)43);
}
/* %-----------------------------------------------------------% */
/* | Compute NP additional steps of the Arnoldi factorization. | */
/* %-----------------------------------------------------------% */
*ido = 0;
L20:
update = TRUE_;
snaitr_(ido, bmat, n, nev, np, mode, &resid[1], &rnorm, &v[v_offset], ldv,
&h__[h_offset], ldh, &ipntr[1], &workd[1], info, (ftnlen)1);
/* %---------------------------------------------------% */
/* | ido .ne. 99 implies use of reverse communication | */
/* | to compute operations involving OP and possibly B | */
/* %---------------------------------------------------% */
if (*ido != 99) {
goto L9000;
}
if (*info > 0) {
*np = *info;
*mxiter = iter;
*info = -9999;
goto L1200;
}
update = FALSE_;
if (msglvl > 1) {
svout_(&debug_1.logfil, &c__1, &rnorm, &debug_1.ndigit, "_naup2: Cor"
"responding B-norm of the residual", (ftnlen)44);
}
/* %--------------------------------------------------------% */
/* | Compute the eigenvalues and corresponding error bounds | */
/* | of the current upper Hessenberg matrix. | */
/* %--------------------------------------------------------% */
sneigh_(&rnorm, &kplusp, &h__[h_offset], ldh, &ritzr[1], &ritzi[1], &
bounds[1], &q[q_offset], ldq, &workl[1], &ierr);
if (ierr != 0) {
*info = -8;
goto L1200;
}
/* %----------------------------------------------------% */
/* | Make a copy of eigenvalues and corresponding error | */
/* | bounds obtained from sneigh. | */
/* %----------------------------------------------------% */
/* Computing 2nd power */
i__1 = kplusp;
scopy_(&kplusp, &ritzr[1], &c__1, &workl[i__1 * i__1 + 1], &c__1);
/* Computing 2nd power */
i__1 = kplusp;
scopy_(&kplusp, &ritzi[1], &c__1, &workl[i__1 * i__1 + kplusp + 1], &c__1)
;
/* Computing 2nd power */
i__1 = kplusp;
scopy_(&kplusp, &bounds[1], &c__1, &workl[i__1 * i__1 + (kplusp << 1) + 1]
, &c__1);
/* %---------------------------------------------------% */
/* | Select the wanted Ritz values and their bounds | */
/* | to be used in the convergence test. | */
/* | The wanted part of the spectrum and corresponding | */
/* | error bounds are in the last NEV loc. of RITZR, | */
/* | RITZI and BOUNDS respectively. The variables NEV | */
/* | and NP may be updated if the NEV-th wanted Ritz | */
/* | value has a non zero imaginary part. In this case | */
/* | NEV is increased by one and NP decreased by one. | */
/* | NOTE: The last two arguments of sngets are no | */
/* | longer used as of version 2.1. | */
/* %---------------------------------------------------% */
*nev = nev0;
*np = np0;
numcnv = *nev;
sngets_(ishift, which, nev, np, &ritzr[1], &ritzi[1], &bounds[1], &workl[
1], &workl[*np + 1], (ftnlen)2);
if (*nev == nev0 + 1) {
numcnv = nev0 + 1;
}
/* %-------------------% */
/* | Convergence test. | */
/* %-------------------% */
scopy_(nev, &bounds[*np + 1], &c__1, &workl[(*np << 1) + 1], &c__1);
snconv_(nev, &ritzr[*np + 1], &ritzi[*np + 1], &workl[(*np << 1) + 1],
tol, &nconv);
if (msglvl > 2) {
kp[0] = *nev;
kp[1] = *np;
kp[2] = numcnv;
kp[3] = nconv;
ivout_(&debug_1.logfil, &c__4, kp, &debug_1.ndigit, "_naup2: NEV, NP"
", NUMCNV, NCONV are", (ftnlen)34);
svout_(&debug_1.logfil, &kplusp, &ritzr[1], &debug_1.ndigit, "_naup2"
": Real part of the eigenvalues of H", (ftnlen)41);
svout_(&debug_1.logfil, &kplusp, &ritzi[1], &debug_1.ndigit, "_naup2"
": Imaginary part of the eigenvalues of H", (ftnlen)46);
svout_(&debug_1.logfil, &kplusp, &bounds[1], &debug_1.ndigit, "_naup"
"2: Ritz estimates of the current NCV Ritz values", (ftnlen)53)
;
}
/* %---------------------------------------------------------% */
/* | Count the number of unwanted Ritz values that have zero | */
/* | Ritz estimates. If any Ritz estimates are equal to zero | */
/* | then a leading block of H of order equal to at least | */
/* | the number of Ritz values with zero Ritz estimates has | */
/* | split off. None of these Ritz values may be removed by | */
/* | shifting. Decrease NP the number of shifts to apply. If | */
/* | no shifts may be applied, then prepare to exit | */
/* %---------------------------------------------------------% */
nptemp = *np;
i__1 = nptemp;
for (j = 1; j <= i__1; ++j) {
if (bounds[j] == 0.f) {
--(*np);
++(*nev);
}
/* L30: */
}
if (nconv >= numcnv || iter > *mxiter || *np == 0) {
if (msglvl > 4) {
/* Computing 2nd power */
i__1 = kplusp;
svout_(&debug_1.logfil, &kplusp, &workl[i__1 * i__1 + 1], &
debug_1.ndigit, "_naup2: Real part of the eig computed b"
"y _neigh:", (ftnlen)48);
/* Computing 2nd power */
i__1 = kplusp;
svout_(&debug_1.logfil, &kplusp, &workl[i__1 * i__1 + kplusp + 1],
&debug_1.ndigit, "_naup2: Imag part of the eig computed"
" by _neigh:", (ftnlen)48);
/* Computing 2nd power */
i__1 = kplusp;
svout_(&debug_1.logfil, &kplusp, &workl[i__1 * i__1 + (kplusp <<
1) + 1], &debug_1.ndigit, "_naup2: Ritz eistmates comput"
"ed by _neigh:", (ftnlen)42);
}
/* %------------------------------------------------% */
/* | Prepare to exit. Put the converged Ritz values | */
/* | and corresponding bounds in RITZ(1:NCONV) and | */
/* | BOUNDS(1:NCONV) respectively. Then sort. Be | */
/* | careful when NCONV > NP | */
/* %------------------------------------------------% */
/* %------------------------------------------% */
/* | Use h( 3,1 ) as storage to communicate | */
/* | rnorm to _neupd if needed | */
/* %------------------------------------------% */
h__[h_dim1 + 3] = rnorm;
/* %----------------------------------------------% */
/* | To be consistent with sngets, we first do a | */
/* | pre-processing sort in order to keep complex | */
/* | conjugate pairs together. This is similar | */
/* | to the pre-processing sort used in sngets | */
/* | except that the sort is done in the opposite | */
/* | order. | */
/* %----------------------------------------------% */
if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "SR", (ftnlen)2, (ftnlen)2);
}
if (s_cmp(which, "SM", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "LR", (ftnlen)2, (ftnlen)2);
}
if (s_cmp(which, "LR", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "SM", (ftnlen)2, (ftnlen)2);
}
if (s_cmp(which, "SR", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "LM", (ftnlen)2, (ftnlen)2);
}
if (s_cmp(which, "LI", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "SM", (ftnlen)2, (ftnlen)2);
}
if (s_cmp(which, "SI", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "LM", (ftnlen)2, (ftnlen)2);
}
ssortc_(wprime, &c_true, &kplusp, &ritzr[1], &ritzi[1], &bounds[1], (
ftnlen)2);
/* %----------------------------------------------% */
/* | Now sort Ritz values so that converged Ritz | */
/* | values appear within the first NEV locations | */
/* | of ritzr, ritzi and bounds, and the most | */
/* | desired one appears at the front. | */
/* %----------------------------------------------% */
if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "SM", (ftnlen)2, (ftnlen)2);
}
if (s_cmp(which, "SM", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "LM", (ftnlen)2, (ftnlen)2);
}
if (s_cmp(which, "LR", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "SR", (ftnlen)2, (ftnlen)2);
}
if (s_cmp(which, "SR", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "LR", (ftnlen)2, (ftnlen)2);
}
if (s_cmp(which, "LI", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "SI", (ftnlen)2, (ftnlen)2);
}
if (s_cmp(which, "SI", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "LI", (ftnlen)2, (ftnlen)2);
}
ssortc_(wprime, &c_true, &kplusp, &ritzr[1], &ritzi[1], &bounds[1], (
ftnlen)2);
/* %--------------------------------------------------% */
/* | Scale the Ritz estimate of each Ritz value | */
/* | by 1 / max(eps23,magnitude of the Ritz value). | */
/* %--------------------------------------------------% */
i__1 = numcnv;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__1 = eps23, r__2 = slapy2_(&ritzr[j], &ritzi[j]);
temp = dmax(r__1,r__2);
bounds[j] /= temp;
/* L35: */
}
/* %----------------------------------------------------% */
/* | Sort the Ritz values according to the scaled Ritz | */
/* | esitmates. This will push all the converged ones | */
/* | towards the front of ritzr, ritzi, bounds | */
/* | (in the case when NCONV < NEV.) | */
/* %----------------------------------------------------% */
s_copy(wprime, "LR", (ftnlen)2, (ftnlen)2);
ssortc_(wprime, &c_true, &numcnv, &bounds[1], &ritzr[1], &ritzi[1], (
ftnlen)2);
/* %----------------------------------------------% */
/* | Scale the Ritz estimate back to its original | */
/* | value. | */
/* %----------------------------------------------% */
i__1 = numcnv;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__1 = eps23, r__2 = slapy2_(&ritzr[j], &ritzi[j]);
temp = dmax(r__1,r__2);
bounds[j] *= temp;
/* L40: */
}
/* %------------------------------------------------% */
/* | Sort the converged Ritz values again so that | */
/* | the "threshold" value appears at the front of | */
/* | ritzr, ritzi and bound. | */
/* %------------------------------------------------% */
ssortc_(which, &c_true, &nconv, &ritzr[1], &ritzi[1], &bounds[1], (
ftnlen)2);
if (msglvl > 1) {
svout_(&debug_1.logfil, &kplusp, &ritzr[1], &debug_1.ndigit,
"_naup2: Sorted real part of the eigenvalues", (ftnlen)43)
;
svout_(&debug_1.logfil, &kplusp, &ritzi[1], &debug_1.ndigit,
"_naup2: Sorted imaginary part of the eigenvalues", (
ftnlen)48);
svout_(&debug_1.logfil, &kplusp, &bounds[1], &debug_1.ndigit,
"_naup2: Sorted ritz estimates.", (ftnlen)30);
}
/* %------------------------------------% */
/* | Max iterations have been exceeded. | */
/* %------------------------------------% */
if (iter > *mxiter && nconv < numcnv) {
*info = 1;
}
/* %---------------------% */
/* | No shifts to apply. | */
/* %---------------------% */
if (*np == 0 && nconv < numcnv) {
*info = 2;
}
*np = nconv;
goto L1100;
} else if (nconv < numcnv && *ishift == 1) {
/* %-------------------------------------------------% */
/* | Do not have all the requested eigenvalues yet. | */
/* | To prevent possible stagnation, adjust the size | */
/* | of NEV. | */
/* %-------------------------------------------------% */
nevbef = *nev;
/* Computing MIN */
i__1 = nconv, i__2 = *np / 2;
*nev += min(i__1,i__2);
if (*nev == 1 && kplusp >= 6) {
*nev = kplusp / 2;
} else if (*nev == 1 && kplusp > 3) {
*nev = 2;
}
*np = kplusp - *nev;
/* %---------------------------------------% */
/* | If the size of NEV was just increased | */
/* | resort the eigenvalues. | */
/* %---------------------------------------% */
if (nevbef < *nev) {
sngets_(ishift, which, nev, np, &ritzr[1], &ritzi[1], &bounds[1],
&workl[1], &workl[*np + 1], (ftnlen)2);
}
}
if (msglvl > 0) {
ivout_(&debug_1.logfil, &c__1, &nconv, &debug_1.ndigit, "_naup2: no."
" of \"converged\" Ritz values at this iter.", (ftnlen)52);
if (msglvl > 1) {
kp[0] = *nev;
kp[1] = *np;
ivout_(&debug_1.logfil, &c__2, kp, &debug_1.ndigit, "_naup2: NEV"
" and NP are", (ftnlen)22);
svout_(&debug_1.logfil, nev, &ritzr[*np + 1], &debug_1.ndigit,
"_naup2: \"wanted\" Ritz values -- real part", (ftnlen)41)
;
svout_(&debug_1.logfil, nev, &ritzi[*np + 1], &debug_1.ndigit,
"_naup2: \"wanted\" Ritz values -- imag part", (ftnlen)41)
;
svout_(&debug_1.logfil, nev, &bounds[*np + 1], &debug_1.ndigit,
"_naup2: Ritz estimates of the \"wanted\" values ", (
ftnlen)46);
}
}
if (*ishift == 0) {
/* %-------------------------------------------------------% */
/* | User specified shifts: reverse comminucation to | */
/* | compute the shifts. They are returned in the first | */
/* | 2*NP locations of WORKL. | */
/* %-------------------------------------------------------% */
ushift = TRUE_;
*ido = 3;
goto L9000;
}
L50:
/* %------------------------------------% */
/* | Back from reverse communication; | */
/* | User specified shifts are returned | */
/* | in WORKL(1:2*NP) | */
/* %------------------------------------% */
ushift = FALSE_;
if (*ishift == 0) {
/* %----------------------------------% */
/* | Move the NP shifts from WORKL to | */
/* | RITZR, RITZI to free up WORKL | */
/* | for non-exact shift case. | */
/* %----------------------------------% */
scopy_(np, &workl[1], &c__1, &ritzr[1], &c__1);
scopy_(np, &workl[*np + 1], &c__1, &ritzi[1], &c__1);
}
if (msglvl > 2) {
ivout_(&debug_1.logfil, &c__1, np, &debug_1.ndigit, "_naup2: The num"
"ber of shifts to apply ", (ftnlen)38);
svout_(&debug_1.logfil, np, &ritzr[1], &debug_1.ndigit, "_naup2: Rea"
"l part of the shifts", (ftnlen)31);
svout_(&debug_1.logfil, np, &ritzi[1], &debug_1.ndigit, "_naup2: Ima"
"ginary part of the shifts", (ftnlen)36);
if (*ishift == 1) {
svout_(&debug_1.logfil, np, &bounds[1], &debug_1.ndigit, "_naup2"
": Ritz estimates of the shifts", (ftnlen)36);
}
}
/* %---------------------------------------------------------% */
/* | Apply the NP implicit shifts by QR bulge chasing. | */
/* | Each shift is applied to the whole upper Hessenberg | */
/* | matrix H. | */
/* | The first 2*N locations of WORKD are used as workspace. | */
/* %---------------------------------------------------------% */
snapps_(n, nev, np, &ritzr[1], &ritzi[1], &v[v_offset], ldv, &h__[
h_offset], ldh, &resid[1], &q[q_offset], ldq, &workl[1], &workd[1]
);
/* %---------------------------------------------% */
/* | Compute the B-norm of the updated residual. | */
/* | Keep B*RESID in WORKD(1:N) to be used in | */
/* | the first step of the next call to snaitr. | */
/* %---------------------------------------------% */
cnorm = TRUE_;
second_(&t2);
if (*(unsigned char *)bmat == 'G') {
++timing_1.nbx;
scopy_(n, &resid[1], &c__1, &workd[*n + 1], &c__1);
ipntr[1] = *n + 1;
ipntr[2] = 1;
*ido = 2;
/* %----------------------------------% */
/* | Exit in order to compute B*RESID | */
/* %----------------------------------% */
goto L9000;
} else if (*(unsigned char *)bmat == 'I') {
scopy_(n, &resid[1], &c__1, &workd[1], &c__1);
}
L100:
/* %----------------------------------% */
/* | Back from reverse communication; | */
/* | WORKD(1:N) := B*RESID | */
/* %----------------------------------% */
if (*(unsigned char *)bmat == 'G') {
second_(&t3);
timing_1.tmvbx += t3 - t2;
}
if (*(unsigned char *)bmat == 'G') {
rnorm = sdot_(n, &resid[1], &c__1, &workd[1], &c__1);
rnorm = sqrt((dabs(rnorm)));
} else if (*(unsigned char *)bmat == 'I') {
rnorm = snrm2_(n, &resid[1], &c__1);
}
cnorm = FALSE_;
if (msglvl > 2) {
svout_(&debug_1.logfil, &c__1, &rnorm, &debug_1.ndigit, "_naup2: B-n"
"orm of residual for compressed factorization", (ftnlen)55);
smout_(&debug_1.logfil, nev, nev, &h__[h_offset], ldh, &
debug_1.ndigit, "_naup2: Compressed upper Hessenberg matrix H"
, (ftnlen)44);
}
goto L1000;
/* %---------------------------------------------------------------% */
/* | | */
/* | E N D O F M A I N I T E R A T I O N L O O P | */
/* | | */
/* %---------------------------------------------------------------% */
L1100:
*mxiter = iter;
*nev = numcnv;
L1200:
*ido = 99;
/* %------------% */
/* | Error Exit | */
/* %------------% */
second_(&t1);
timing_1.tnaup2 = t1 - t0;
L9000:
/* %---------------% */
/* | End of snaup2 | */
/* %---------------% */
return 0;
} /* snaup2_ */
/* Subroutine */ int ssterf_(integer *n, real *d__, real *e, integer *info)
{
/* System generated locals */
integer i__1;
real r__1, r__2, r__3;
/* Builtin functions */
double sqrt(doublereal), r_sign(real *, real *);
/* Local variables */
real c__;
integer i__, l, m;
real p, r__, s;
integer l1;
real bb, rt1, rt2, eps, rte;
integer lsv;
real eps2, oldc;
integer lend, jtot;
extern /* Subroutine */ int slae2_(real *, real *, real *, real *, real *)
;
real gamma, alpha, sigma, anorm;
extern doublereal slapy2_(real *, real *);
integer iscale;
real oldgam;
extern doublereal slamch_(char *);
real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
real safmax;
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *);
integer lendsv;
real ssfmin;
integer nmaxit;
real ssfmax;
extern doublereal slanst_(char *, integer *, real *, real *);
extern /* Subroutine */ int slasrt_(char *, integer *, real *, integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SSTERF computes all eigenvalues of a symmetric tridiagonal matrix */
/* using the Pal-Walker-Kahan variant of the QL or QR algorithm. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix. N >= 0. */
/* D (input/output) REAL array, dimension (N) */
/* On entry, the n diagonal elements of the tridiagonal matrix. */
/* On exit, if INFO = 0, the eigenvalues in ascending order. */
/* E (input/output) REAL array, dimension (N-1) */
/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
/* matrix. */
/* On exit, E has been destroyed. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: the algorithm failed to find all of the eigenvalues in */
/* a total of 30*N iterations; if INFO = i, then i */
/* elements of E have not converged to zero. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--e;
--d__;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n < 0) {
*info = -1;
i__1 = -(*info);
xerbla_("SSTERF", &i__1);
return 0;
}
if (*n <= 1) {
return 0;
}
/* Determine the unit roundoff for this environment. */
eps = slamch_("E");
/* Computing 2nd power */
r__1 = eps;
eps2 = r__1 * r__1;
safmin = slamch_("S");
safmax = 1.f / safmin;
ssfmax = sqrt(safmax) / 3.f;
ssfmin = sqrt(safmin) / eps2;
/* Compute the eigenvalues of the tridiagonal matrix. */
nmaxit = *n * 30;
sigma = 0.f;
jtot = 0;
/* Determine where the matrix splits and choose QL or QR iteration */
/* for each block, according to whether top or bottom diagonal */
/* element is smaller. */
l1 = 1;
L10:
if (l1 > *n) {
goto L170;
}
if (l1 > 1) {
e[l1 - 1] = 0.f;
}
i__1 = *n - 1;
for (m = l1; m <= i__1; ++m) {
if ((r__3 = e[m], dabs(r__3)) <= sqrt((r__1 = d__[m], dabs(r__1))) *
sqrt((r__2 = d__[m + 1], dabs(r__2))) * eps) {
e[m] = 0.f;
goto L30;
}
/* L20: */
}
m = *n;
L30:
l = l1;
lsv = l;
lend = m;
lendsv = lend;
l1 = m + 1;
if (lend == l) {
goto L10;
}
/* Scale submatrix in rows and columns L to LEND */
i__1 = lend - l + 1;
anorm = slanst_("I", &i__1, &d__[l], &e[l]);
iscale = 0;
if (anorm > ssfmax) {
iscale = 1;
i__1 = lend - l + 1;
slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n,
info);
i__1 = lend - l;
slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n,
info);
} else if (anorm < ssfmin) {
iscale = 2;
i__1 = lend - l + 1;
slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n,
info);
i__1 = lend - l;
slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n,
info);
}
i__1 = lend - 1;
for (i__ = l; i__ <= i__1; ++i__) {
/* Computing 2nd power */
r__1 = e[i__];
e[i__] = r__1 * r__1;
/* L40: */
}
/* Choose between QL and QR iteration */
if ((r__1 = d__[lend], dabs(r__1)) < (r__2 = d__[l], dabs(r__2))) {
lend = lsv;
l = lendsv;
}
if (lend >= l) {
/* QL Iteration */
/* Look for small subdiagonal element. */
L50:
if (l != lend) {
i__1 = lend - 1;
for (m = l; m <= i__1; ++m) {
if ((r__2 = e[m], dabs(r__2)) <= eps2 * (r__1 = d__[m] * d__[
m + 1], dabs(r__1))) {
goto L70;
}
/* L60: */
}
}
m = lend;
L70:
if (m < lend) {
e[m] = 0.f;
}
p = d__[l];
if (m == l) {
goto L90;
}
/* If remaining matrix is 2 by 2, use SLAE2 to compute its */
/* eigenvalues. */
if (m == l + 1) {
rte = sqrt(e[l]);
slae2_(&d__[l], &rte, &d__[l + 1], &rt1, &rt2);
d__[l] = rt1;
d__[l + 1] = rt2;
e[l] = 0.f;
l += 2;
if (l <= lend) {
goto L50;
}
goto L150;
}
if (jtot == nmaxit) {
goto L150;
}
++jtot;
/* Form shift. */
rte = sqrt(e[l]);
sigma = (d__[l + 1] - p) / (rte * 2.f);
r__ = slapy2_(&sigma, &c_b32);
sigma = p - rte / (sigma + r_sign(&r__, &sigma));
c__ = 1.f;
s = 0.f;
gamma = d__[m] - sigma;
p = gamma * gamma;
/* Inner loop */
i__1 = l;
for (i__ = m - 1; i__ >= i__1; --i__) {
bb = e[i__];
r__ = p + bb;
if (i__ != m - 1) {
e[i__ + 1] = s * r__;
}
oldc = c__;
c__ = p / r__;
s = bb / r__;
oldgam = gamma;
alpha = d__[i__];
gamma = c__ * (alpha - sigma) - s * oldgam;
d__[i__ + 1] = oldgam + (alpha - gamma);
if (c__ != 0.f) {
p = gamma * gamma / c__;
} else {
p = oldc * bb;
}
/* L80: */
}
e[l] = s * p;
d__[l] = sigma + gamma;
goto L50;
/* Eigenvalue found. */
L90:
d__[l] = p;
++l;
if (l <= lend) {
goto L50;
}
goto L150;
} else {
/* QR Iteration */
/* Look for small superdiagonal element. */
L100:
i__1 = lend + 1;
for (m = l; m >= i__1; --m) {
if ((r__2 = e[m - 1], dabs(r__2)) <= eps2 * (r__1 = d__[m] * d__[
m - 1], dabs(r__1))) {
goto L120;
}
/* L110: */
}
m = lend;
L120:
if (m > lend) {
e[m - 1] = 0.f;
}
p = d__[l];
if (m == l) {
goto L140;
}
/* If remaining matrix is 2 by 2, use SLAE2 to compute its */
/* eigenvalues. */
if (m == l - 1) {
rte = sqrt(e[l - 1]);
slae2_(&d__[l], &rte, &d__[l - 1], &rt1, &rt2);
d__[l] = rt1;
d__[l - 1] = rt2;
e[l - 1] = 0.f;
l += -2;
if (l >= lend) {
goto L100;
}
goto L150;
}
if (jtot == nmaxit) {
goto L150;
}
++jtot;
/* Form shift. */
rte = sqrt(e[l - 1]);
sigma = (d__[l - 1] - p) / (rte * 2.f);
r__ = slapy2_(&sigma, &c_b32);
sigma = p - rte / (sigma + r_sign(&r__, &sigma));
c__ = 1.f;
s = 0.f;
gamma = d__[m] - sigma;
p = gamma * gamma;
/* Inner loop */
i__1 = l - 1;
for (i__ = m; i__ <= i__1; ++i__) {
bb = e[i__];
r__ = p + bb;
if (i__ != m) {
e[i__ - 1] = s * r__;
}
oldc = c__;
c__ = p / r__;
s = bb / r__;
oldgam = gamma;
alpha = d__[i__ + 1];
gamma = c__ * (alpha - sigma) - s * oldgam;
d__[i__] = oldgam + (alpha - gamma);
if (c__ != 0.f) {
p = gamma * gamma / c__;
} else {
p = oldc * bb;
}
/* L130: */
}
e[l - 1] = s * p;
d__[l] = sigma + gamma;
goto L100;
/* Eigenvalue found. */
L140:
d__[l] = p;
--l;
if (l >= lend) {
goto L100;
}
goto L150;
}
/* Undo scaling if necessary */
L150:
if (iscale == 1) {
i__1 = lendsv - lsv + 1;
slascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv],
n, info);
}
if (iscale == 2) {
i__1 = lendsv - lsv + 1;
slascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv],
n, info);
}
/* Check for no convergence to an eigenvalue after a total */
/* of N*MAXIT iterations. */
if (jtot < nmaxit) {
goto L10;
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (e[i__] != 0.f) {
++(*info);
}
/* L160: */
}
goto L180;
/* Sort eigenvalues in increasing order. */
L170:
slasrt_("I", n, &d__[1], info);
L180:
return 0;
/* End of SSTERF */
} /* ssterf_ */
/* Subroutine */ int stgsna_(char *job, char *howmny, logical *select,
integer *n, real *a, integer *lda, real *b, integer *ldb, real *vl,
integer *ldvl, real *vr, integer *ldvr, real *s, real *dif, integer *
mm, integer *m, real *work, integer *lwork, integer *iwork, integer *
info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
vr_offset, i__1, i__2;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, k;
real c1, c2;
integer n1, n2, ks, iz;
real eps, beta, cond;
logical pair;
integer ierr;
real uhav, uhbv;
integer ifst;
real lnrm;
extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
integer ilst;
real rnrm;
extern /* Subroutine */ int slag2_(real *, integer *, real *, integer *,
real *, real *, real *, real *, real *, real *);
extern doublereal snrm2_(integer *, real *, integer *);
real root1, root2, scale;
extern logical lsame_(char *, char *);
real uhavi, uhbvi;
extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *);
real tmpii;
integer lwmin;
logical wants;
real tmpir, tmpri, dummy[1], tmprr;
extern doublereal slapy2_(real *, real *);
real dummy1[1], alphai, alphar;
extern doublereal slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
logical wantbh, wantdf;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), stgexc_(logical *, logical
*, integer *, real *, integer *, real *, integer *, real *,
integer *, real *, integer *, integer *, integer *, real *,
integer *, integer *);
logical somcon;
real alprqt, smlnum;
logical lquery;
extern /* Subroutine */ int stgsyl_(char *, integer *, integer *, integer
*, real *, integer *, real *, integer *, real *, integer *, real *
, integer *, real *, integer *, real *, integer *, real *, real *,
real *, integer *, integer *, integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* STGSNA estimates reciprocal condition numbers for specified */
/* eigenvalues and/or eigenvectors of a matrix pair (A, B) in */
/* generalized real Schur canonical form (or of any matrix pair */
/* (Q*A*Z', Q*B*Z') with orthogonal matrices Q and Z, where */
/* Z' denotes the transpose of Z. */
/* (A, B) must be in generalized real Schur form (as returned by SGGES), */
/* i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal */
/* blocks. B is upper triangular. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* Specifies whether condition numbers are required for */
/* eigenvalues (S) or eigenvectors (DIF): */
/* = 'E': for eigenvalues only (S); */
/* = 'V': for eigenvectors only (DIF); */
/* = 'B': for both eigenvalues and eigenvectors (S and DIF). */
/* HOWMNY (input) CHARACTER*1 */
/* = 'A': compute condition numbers for all eigenpairs; */
/* = 'S': compute condition numbers for selected eigenpairs */
/* specified by the array SELECT. */
/* SELECT (input) LOGICAL array, dimension (N) */
/* If HOWMNY = 'S', SELECT specifies the eigenpairs for which */
/* condition numbers are required. To select condition numbers */
/* for the eigenpair corresponding to a real eigenvalue w(j), */
/* SELECT(j) must be set to .TRUE.. To select condition numbers */
/* corresponding to a complex conjugate pair of eigenvalues w(j) */
/* and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be */
/* set to .TRUE.. */
/* If HOWMNY = 'A', SELECT is not referenced. */
/* N (input) INTEGER */
/* The order of the square matrix pair (A, B). N >= 0. */
/* A (input) REAL array, dimension (LDA,N) */
/* The upper quasi-triangular matrix A in the pair (A,B). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input) REAL array, dimension (LDB,N) */
/* The upper triangular matrix B in the pair (A,B). */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* VL (input) REAL array, dimension (LDVL,M) */
/* If JOB = 'E' or 'B', VL must contain left eigenvectors of */
/* (A, B), corresponding to the eigenpairs specified by HOWMNY */
/* and SELECT. The eigenvectors must be stored in consecutive */
/* columns of VL, as returned by STGEVC. */
/* If JOB = 'V', VL is not referenced. */
/* LDVL (input) INTEGER */
/* The leading dimension of the array VL. LDVL >= 1. */
/* If JOB = 'E' or 'B', LDVL >= N. */
/* VR (input) REAL array, dimension (LDVR,M) */
/* If JOB = 'E' or 'B', VR must contain right eigenvectors of */
/* (A, B), corresponding to the eigenpairs specified by HOWMNY */
/* and SELECT. The eigenvectors must be stored in consecutive */
/* columns ov VR, as returned by STGEVC. */
/* If JOB = 'V', VR is not referenced. */
/* LDVR (input) INTEGER */
/* The leading dimension of the array VR. LDVR >= 1. */
/* If JOB = 'E' or 'B', LDVR >= N. */
/* S (output) REAL array, dimension (MM) */
/* If JOB = 'E' or 'B', the reciprocal condition numbers of the */
/* selected eigenvalues, stored in consecutive elements of the */
/* array. For a complex conjugate pair of eigenvalues two */
/* consecutive elements of S are set to the same value. Thus */
/* S(j), DIF(j), and the j-th columns of VL and VR all */
/* correspond to the same eigenpair (but not in general the */
/* j-th eigenpair, unless all eigenpairs are selected). */
/* If JOB = 'V', S is not referenced. */
/* DIF (output) REAL array, dimension (MM) */
/* If JOB = 'V' or 'B', the estimated reciprocal condition */
/* numbers of the selected eigenvectors, stored in consecutive */
/* elements of the array. For a complex eigenvector two */
/* consecutive elements of DIF are set to the same value. If */
/* the eigenvalues cannot be reordered to compute DIF(j), DIF(j) */
/* is set to 0; this can only occur when the true value would be */
/* very small anyway. */
/* If JOB = 'E', DIF is not referenced. */
/* MM (input) INTEGER */
/* The number of elements in the arrays S and DIF. MM >= M. */
/* M (output) INTEGER */
/* The number of elements of the arrays S and DIF used to store */
/* the specified condition numbers; for each selected real */
/* eigenvalue one element is used, and for each selected complex */
/* conjugate pair of eigenvalues, two elements are used. */
/* If HOWMNY = 'A', M is set to N. */
/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,N). */
/* If JOB = 'V' or 'B' LWORK >= 2*N*(N+2)+16. */
/* 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. */
/* IWORK (workspace) INTEGER array, dimension (N + 6) */
/* If JOB = 'E', IWORK is not referenced. */
/* INFO (output) INTEGER */
/* =0: Successful exit */
/* <0: If INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* The reciprocal of the condition number of a generalized eigenvalue */
/* w = (a, b) is defined as */
/* S(w) = (|u'Av|**2 + |u'Bv|**2)**(1/2) / (norm(u)*norm(v)) */
/* where u and v are the left and right eigenvectors of (A, B) */
/* corresponding to w; |z| denotes the absolute value of the complex */
/* number, and norm(u) denotes the 2-norm of the vector u. */
/* The pair (a, b) corresponds to an eigenvalue w = a/b (= u'Av/u'Bv) */
/* of the matrix pair (A, B). If both a and b equal zero, then (A B) is */
/* singular and S(I) = -1 is returned. */
/* An approximate error bound on the chordal distance between the i-th */
/* computed generalized eigenvalue w and the corresponding exact */
/* eigenvalue lambda is */
/* chord(w, lambda) <= EPS * norm(A, B) / S(I) */
/* where EPS is the machine precision. */
/* The reciprocal of the condition number DIF(i) of right eigenvector u */
/* and left eigenvector v corresponding to the generalized eigenvalue w */
/* is defined as follows: */
/* a) If the i-th eigenvalue w = (a,b) is real */
/* Suppose U and V are orthogonal transformations such that */
/* U'*(A, B)*V = (S, T) = ( a * ) ( b * ) 1 */
/* ( 0 S22 ),( 0 T22 ) n-1 */
/* 1 n-1 1 n-1 */
/* Then the reciprocal condition number DIF(i) is */
/* Difl((a, b), (S22, T22)) = sigma-min( Zl ), */
/* where sigma-min(Zl) denotes the smallest singular value of the */
/* 2(n-1)-by-2(n-1) matrix */
/* Zl = [ kron(a, In-1) -kron(1, S22) ] */
/* [ kron(b, In-1) -kron(1, T22) ] . */
/* Here In-1 is the identity matrix of size n-1. kron(X, Y) is the */
/* Kronecker product between the matrices X and Y. */
/* Note that if the default method for computing DIF(i) is wanted */
/* (see SLATDF), then the parameter DIFDRI (see below) should be */
/* changed from 3 to 4 (routine SLATDF(IJOB = 2 will be used)). */
/* See STGSYL for more details. */
/* b) If the i-th and (i+1)-th eigenvalues are complex conjugate pair, */
/* Suppose U and V are orthogonal transformations such that */
/* U'*(A, B)*V = (S, T) = ( S11 * ) ( T11 * ) 2 */
/* ( 0 S22 ),( 0 T22) n-2 */
/* 2 n-2 2 n-2 */
/* and (S11, T11) corresponds to the complex conjugate eigenvalue */
/* pair (w, conjg(w)). There exist unitary matrices U1 and V1 such */
/* that */
/* U1'*S11*V1 = ( s11 s12 ) and U1'*T11*V1 = ( t11 t12 ) */
/* ( 0 s22 ) ( 0 t22 ) */
/* where the generalized eigenvalues w = s11/t11 and */
/* conjg(w) = s22/t22. */
/* Then the reciprocal condition number DIF(i) is bounded by */
/* min( d1, max( 1, |real(s11)/real(s22)| )*d2 ) */
/* where, d1 = Difl((s11, t11), (s22, t22)) = sigma-min(Z1), where */
/* Z1 is the complex 2-by-2 matrix */
/* Z1 = [ s11 -s22 ] */
/* [ t11 -t22 ], */
/* This is done by computing (using real arithmetic) the */
/* roots of the characteristical polynomial det(Z1' * Z1 - lambda I), */
/* where Z1' denotes the conjugate transpose of Z1 and det(X) denotes */
/* the determinant of X. */
/* and d2 is an upper bound on Difl((S11, T11), (S22, T22)), i.e. an */
/* upper bound on sigma-min(Z2), where Z2 is (2n-2)-by-(2n-2) */
/* Z2 = [ kron(S11', In-2) -kron(I2, S22) ] */
/* [ kron(T11', In-2) -kron(I2, T22) ] */
/* Note that if the default method for computing DIF is wanted (see */
/* SLATDF), then the parameter DIFDRI (see below) should be changed */
/* from 3 to 4 (routine SLATDF(IJOB = 2 will be used)). See STGSYL */
/* for more details. */
/* For each eigenvalue/vector specified by SELECT, DIF stores a */
/* Frobenius norm-based estimate of Difl. */
/* An approximate error bound for the i-th computed eigenvector VL(i) or */
/* VR(i) is given by */
/* EPS * norm(A, B) / DIF(i). */
/* See ref. [2-3] for more details and further references. */
/* Based on contributions by */
/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
/* Umea University, S-901 87 Umea, Sweden. */
/* References */
/* ========== */
/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */
/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */
/* Estimation: Theory, Algorithms and Software, */
/* Report UMINF - 94.04, Department of Computing Science, Umea */
/* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working */
/* Note 87. To appear in Numerical Algorithms, 1996. */
/* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */
/* for Solving the Generalized Sylvester Equation and Estimating the */
/* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */
/* Department of Computing Science, Umea University, S-901 87 Umea, */
/* Sweden, December 1993, Revised April 1994, Also as LAPACK Working */
/* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, */
/* No 1, 1996. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and test the input parameters */
/* Parameter adjustments */
--select;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--s;
--dif;
--work;
--iwork;
/* Function Body */
wantbh = lsame_(job, "B");
wants = lsame_(job, "E") || wantbh;
wantdf = lsame_(job, "V") || wantbh;
somcon = lsame_(howmny, "S");
*info = 0;
lquery = *lwork == -1;
if (! wants && ! wantdf) {
*info = -1;
} else if (! lsame_(howmny, "A") && ! somcon) {
*info = -2;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldb < max(1,*n)) {
*info = -8;
} else if (wants && *ldvl < *n) {
*info = -10;
} else if (wants && *ldvr < *n) {
*info = -12;
} else {
/* Set M to the number of eigenpairs for which condition numbers */
/* are required, and test MM. */
if (somcon) {
*m = 0;
pair = FALSE_;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (pair) {
pair = FALSE_;
} else {
if (k < *n) {
if (a[k + 1 + k * a_dim1] == 0.f) {
if (select[k]) {
++(*m);
}
} else {
pair = TRUE_;
if (select[k] || select[k + 1]) {
*m += 2;
}
}
} else {
if (select[*n]) {
++(*m);
}
}
}
/* L10: */
}
} else {
*m = *n;
}
if (*n == 0) {
lwmin = 1;
} else if (lsame_(job, "V") || lsame_(job,
"B")) {
lwmin = (*n << 1) * (*n + 2) + 16;
} else {
lwmin = *n;
}
work[1] = (real) lwmin;
if (*mm < *m) {
*info = -15;
} else if (*lwork < lwmin && ! lquery) {
*info = -18;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("STGSNA", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = slamch_("P");
smlnum = slamch_("S") / eps;
ks = 0;
pair = FALSE_;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Determine whether A(k,k) begins a 1-by-1 or 2-by-2 block. */
if (pair) {
pair = FALSE_;
goto L20;
} else {
if (k < *n) {
pair = a[k + 1 + k * a_dim1] != 0.f;
}
}
/* Determine whether condition numbers are required for the k-th */
/* eigenpair. */
if (somcon) {
if (pair) {
if (! select[k] && ! select[k + 1]) {
goto L20;
}
} else {
if (! select[k]) {
goto L20;
}
}
}
++ks;
if (wants) {
/* Compute the reciprocal condition number of the k-th */
/* eigenvalue. */
if (pair) {
/* Complex eigenvalue pair. */
r__1 = snrm2_(n, &vr[ks * vr_dim1 + 1], &c__1);
r__2 = snrm2_(n, &vr[(ks + 1) * vr_dim1 + 1], &c__1);
rnrm = slapy2_(&r__1, &r__2);
r__1 = snrm2_(n, &vl[ks * vl_dim1 + 1], &c__1);
r__2 = snrm2_(n, &vl[(ks + 1) * vl_dim1 + 1], &c__1);
lnrm = slapy2_(&r__1, &r__2);
sgemv_("N", n, n, &c_b19, &a[a_offset], lda, &vr[ks * vr_dim1
+ 1], &c__1, &c_b21, &work[1], &c__1);
tmprr = sdot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &
c__1);
tmpri = sdot_(n, &work[1], &c__1, &vl[(ks + 1) * vl_dim1 + 1],
&c__1);
sgemv_("N", n, n, &c_b19, &a[a_offset], lda, &vr[(ks + 1) *
vr_dim1 + 1], &c__1, &c_b21, &work[1], &c__1);
tmpii = sdot_(n, &work[1], &c__1, &vl[(ks + 1) * vl_dim1 + 1],
&c__1);
tmpir = sdot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &
c__1);
uhav = tmprr + tmpii;
uhavi = tmpir - tmpri;
sgemv_("N", n, n, &c_b19, &b[b_offset], ldb, &vr[ks * vr_dim1
+ 1], &c__1, &c_b21, &work[1], &c__1);
tmprr = sdot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &
c__1);
tmpri = sdot_(n, &work[1], &c__1, &vl[(ks + 1) * vl_dim1 + 1],
&c__1);
sgemv_("N", n, n, &c_b19, &b[b_offset], ldb, &vr[(ks + 1) *
vr_dim1 + 1], &c__1, &c_b21, &work[1], &c__1);
tmpii = sdot_(n, &work[1], &c__1, &vl[(ks + 1) * vl_dim1 + 1],
&c__1);
tmpir = sdot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &
c__1);
uhbv = tmprr + tmpii;
uhbvi = tmpir - tmpri;
uhav = slapy2_(&uhav, &uhavi);
uhbv = slapy2_(&uhbv, &uhbvi);
cond = slapy2_(&uhav, &uhbv);
s[ks] = cond / (rnrm * lnrm);
s[ks + 1] = s[ks];
} else {
/* Real eigenvalue. */
rnrm = snrm2_(n, &vr[ks * vr_dim1 + 1], &c__1);
lnrm = snrm2_(n, &vl[ks * vl_dim1 + 1], &c__1);
sgemv_("N", n, n, &c_b19, &a[a_offset], lda, &vr[ks * vr_dim1
+ 1], &c__1, &c_b21, &work[1], &c__1);
uhav = sdot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &c__1)
;
sgemv_("N", n, n, &c_b19, &b[b_offset], ldb, &vr[ks * vr_dim1
+ 1], &c__1, &c_b21, &work[1], &c__1);
uhbv = sdot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &c__1)
;
cond = slapy2_(&uhav, &uhbv);
if (cond == 0.f) {
s[ks] = -1.f;
} else {
s[ks] = cond / (rnrm * lnrm);
}
}
}
if (wantdf) {
if (*n == 1) {
dif[ks] = slapy2_(&a[a_dim1 + 1], &b[b_dim1 + 1]);
goto L20;
}
/* Estimate the reciprocal condition number of the k-th */
/* eigenvectors. */
if (pair) {
/* Copy the 2-by 2 pencil beginning at (A(k,k), B(k, k)). */
/* Compute the eigenvalue(s) at position K. */
work[1] = a[k + k * a_dim1];
work[2] = a[k + 1 + k * a_dim1];
work[3] = a[k + (k + 1) * a_dim1];
work[4] = a[k + 1 + (k + 1) * a_dim1];
work[5] = b[k + k * b_dim1];
work[6] = b[k + 1 + k * b_dim1];
work[7] = b[k + (k + 1) * b_dim1];
work[8] = b[k + 1 + (k + 1) * b_dim1];
r__1 = smlnum * eps;
slag2_(&work[1], &c__2, &work[5], &c__2, &r__1, &beta, dummy1,
&alphar, dummy, &alphai);
alprqt = 1.f;
c1 = (alphar * alphar + alphai * alphai + beta * beta) * 2.f;
c2 = beta * 4.f * beta * alphai * alphai;
root1 = c1 + sqrt(c1 * c1 - c2 * 4.f);
root2 = c2 / root1;
root1 /= 2.f;
/* Computing MIN */
r__1 = sqrt(root1), r__2 = sqrt(root2);
cond = dmin(r__1,r__2);
}
/* Copy the matrix (A, B) to the array WORK and swap the */
/* diagonal block beginning at A(k,k) to the (1,1) position. */
slacpy_("Full", n, n, &a[a_offset], lda, &work[1], n);
slacpy_("Full", n, n, &b[b_offset], ldb, &work[*n * *n + 1], n);
ifst = k;
ilst = 1;
i__2 = *lwork - (*n << 1) * *n;
stgexc_(&c_false, &c_false, n, &work[1], n, &work[*n * *n + 1], n,
dummy, &c__1, dummy1, &c__1, &ifst, &ilst, &work[(*n * *
n << 1) + 1], &i__2, &ierr);
if (ierr > 0) {
/* Ill-conditioned problem - swap rejected. */
dif[ks] = 0.f;
} else {
/* Reordering successful, solve generalized Sylvester */
/* equation for R and L, */
/* A22 * R - L * A11 = A12 */
/* B22 * R - L * B11 = B12, */
/* and compute estimate of Difl((A11,B11), (A22, B22)). */
n1 = 1;
if (work[2] != 0.f) {
n1 = 2;
}
n2 = *n - n1;
if (n2 == 0) {
dif[ks] = cond;
} else {
i__ = *n * *n + 1;
iz = (*n << 1) * *n + 1;
i__2 = *lwork - (*n << 1) * *n;
stgsyl_("N", &c__3, &n2, &n1, &work[*n * n1 + n1 + 1], n,
&work[1], n, &work[n1 + 1], n, &work[*n * n1 + n1
+ i__], n, &work[i__], n, &work[n1 + i__], n, &
scale, &dif[ks], &work[iz + 1], &i__2, &iwork[1],
&ierr);
if (pair) {
/* Computing MIN */
r__1 = dmax(1.f,alprqt) * dif[ks];
dif[ks] = dmin(r__1,cond);
}
}
}
if (pair) {
dif[ks + 1] = dif[ks];
}
}
if (pair) {
++ks;
}
L20:
;
}
work[1] = (real) lwmin;
return 0;
/* End of STGSNA */
} /* stgsna_ */
/* Subroutine */ int slanv2_(real *a, real *b, real *c__, real *d__, real *
rt1r, real *rt1i, real *rt2r, real *rt2i, real *cs, real *sn)
{
/* System generated locals */
real r__1;
/* Builtin functions */
double r_sign(real *, real *), sqrt(doublereal);
/* Local variables */
static real p, aa, bb, cc, dd, cs1, sn1, sab, sac, tau, temp, sigma;
extern doublereal slapy2_(real *, real *);
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric */
/* matrix in standard form: */
/* [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ] */
/* [ C D ] [ SN CS ] [ CC DD ] [-SN CS ] */
/* where either */
/* 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or */
/* 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex */
/* conjugate eigenvalues. */
/* Arguments */
/* ========= */
/* A (input/output) REAL */
/* B (input/output) REAL */
/* C (input/output) REAL */
/* D (input/output) REAL */
/* On entry, the elements of the input matrix. */
/* On exit, they are overwritten by the elements of the */
/* standardised Schur form. */
/* RT1R (output) REAL */
/* RT1I (output) REAL */
/* RT2R (output) REAL */
/* RT2I (output) REAL */
/* The real and imaginary parts of the eigenvalues. If the */
/* eigenvalues are both real, abs(RT1R) >= abs(RT2R); if the */
/* eigenvalues are a complex conjugate pair, RT1I > 0. */
/* CS (output) REAL */
/* SN (output) REAL */
/* Parameters of the rotation matrix. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Initialize CS and SN */
*cs = 1.f;
*sn = 0.f;
if (*c__ == 0.f) {
goto L10;
} else if (*b == 0.f) {
/* Swap rows and columns */
*cs = 0.f;
*sn = 1.f;
temp = *d__;
*d__ = *a;
*a = temp;
*b = -(*c__);
*c__ = 0.f;
goto L10;
} else if (*a - *d__ == 0.f && r_sign(&c_b3, b) != r_sign(&c_b3, c__)) {
goto L10;
} else {
/* Make diagonal elements equal */
temp = *a - *d__;
p = temp * .5f;
sigma = *b + *c__;
tau = slapy2_(&sigma, &temp);
cs1 = sqrt((dabs(sigma) / tau + 1.f) * .5f);
sn1 = -(p / (tau * cs1)) * r_sign(&c_b3, &sigma);
/* Compute [ AA BB ] = [ A B ] [ CS1 -SN1 ] */
/* [ CC DD ] [ C D ] [ SN1 CS1 ] */
aa = *a * cs1 + *b * sn1;
bb = -(*a) * sn1 + *b * cs1;
cc = *c__ * cs1 + *d__ * sn1;
dd = -(*c__) * sn1 + *d__ * cs1;
/* Compute [ A B ] = [ CS1 SN1 ] [ AA BB ] */
/* [ C D ] [-SN1 CS1 ] [ CC DD ] */
*a = aa * cs1 + cc * sn1;
*b = bb * cs1 + dd * sn1;
*c__ = -aa * sn1 + cc * cs1;
*d__ = -bb * sn1 + dd * cs1;
/* Accumulate transformation */
temp = *cs * cs1 - *sn * sn1;
*sn = *cs * sn1 + *sn * cs1;
*cs = temp;
temp = (*a + *d__) * .5f;
*a = temp;
*d__ = temp;
if (*c__ != 0.f) {
if (*b != 0.f) {
if (r_sign(&c_b3, b) == r_sign(&c_b3, c__)) {
/* Real eigenvalues: reduce to upper triangular form */
sab = sqrt((dabs(*b)));
sac = sqrt((dabs(*c__)));
r__1 = sab * sac;
p = r_sign(&r__1, c__);
tau = 1.f / sqrt((r__1 = *b + *c__, dabs(r__1)));
*a = temp + p;
*d__ = temp - p;
*b -= *c__;
*c__ = 0.f;
cs1 = sab * tau;
sn1 = sac * tau;
temp = *cs * cs1 - *sn * sn1;
*sn = *cs * sn1 + *sn * cs1;
*cs = temp;
}
} else {
*b = -(*c__);
*c__ = 0.f;
temp = *cs;
*cs = -(*sn);
*sn = temp;
}
}
}
L10:
/* Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I). */
*rt1r = *a;
*rt2r = *d__;
if (*c__ == 0.f) {
*rt1i = 0.f;
*rt2i = 0.f;
} else {
*rt1i = sqrt((dabs(*b))) * sqrt((dabs(*c__)));
*rt2i = -(*rt1i);
}
return 0;
/* End of SLANV2 */
} /* slanv2_ */
int slaein_(int *rightv, int *noinit, int *n,
float *h__, int *ldh, float *wr, float *wi, float *vr, float *vi, float
*b, int *ldb, float *work, float *eps3, float *smlnum, float *bignum,
int *info)
{
/* System generated locals */
int b_dim1, b_offset, h_dim1, h_offset, i__1, i__2, i__3, i__4;
float r__1, r__2, r__3, r__4;
/* Builtin functions */
double sqrt(double);
/* Local variables */
int i__, j;
float w, x, y;
int i1, i2, i3;
float w1, ei, ej, xi, xr, rec;
int its, ierr;
float temp, norm, vmax;
extern double snrm2_(int *, float *, int *);
float scale;
extern int sscal_(int *, float *, float *, int *);
char trans[1];
float vcrit;
extern double sasum_(int *, float *, int *);
float rootn, vnorm;
extern double slapy2_(float *, float *);
float absbii, absbjj;
extern int isamax_(int *, float *, int *);
extern int sladiv_(float *, float *, float *, float *, float *
, float *);
char normin[1];
float nrmsml;
extern int slatrs_(char *, char *, char *, char *,
int *, float *, int *, float *, float *, float *, int *);
float growto;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLAEIN uses inverse iteration to find a right or left eigenvector */
/* corresponding to the eigenvalue (WR,WI) of a float upper Hessenberg */
/* matrix H. */
/* Arguments */
/* ========= */
/* RIGHTV (input) LOGICAL */
/* = .TRUE. : compute right eigenvector; */
/* = .FALSE.: compute left eigenvector. */
/* NOINIT (input) LOGICAL */
/* = .TRUE. : no initial vector supplied in (VR,VI). */
/* = .FALSE.: initial vector supplied in (VR,VI). */
/* N (input) INTEGER */
/* The order of the matrix H. N >= 0. */
/* H (input) REAL array, dimension (LDH,N) */
/* The upper Hessenberg matrix H. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH >= MAX(1,N). */
/* WR (input) REAL */
/* WI (input) REAL */
/* The float and imaginary parts of the eigenvalue of H whose */
/* corresponding right or left eigenvector is to be computed. */
/* VR (input/output) REAL array, dimension (N) */
/* VI (input/output) REAL array, dimension (N) */
/* On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain */
/* a float starting vector for inverse iteration using the float */
/* eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI */
/* must contain the float and imaginary parts of a complex */
/* starting vector for inverse iteration using the complex */
/* eigenvalue (WR,WI); otherwise VR and VI need not be set. */
/* On exit, if WI = 0.0 (float eigenvalue), VR contains the */
/* computed float eigenvector; if WI.ne.0.0 (complex eigenvalue), */
/* VR and VI contain the float and imaginary parts of the */
/* computed complex eigenvector. The eigenvector is normalized */
/* so that the component of largest magnitude has magnitude 1; */
/* here the magnitude of a complex number (x,y) is taken to be */
/* |x| + |y|. */
/* VI is not referenced if WI = 0.0. */
/* B (workspace) REAL array, dimension (LDB,N) */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= N+1. */
/* WORK (workspace) REAL array, dimension (N) */
/* EPS3 (input) REAL */
/* A small machine-dependent value which is used to perturb */
/* close eigenvalues, and to replace zero pivots. */
/* SMLNUM (input) REAL */
/* A machine-dependent value close to the underflow threshold. */
/* BIGNUM (input) REAL */
/* A machine-dependent value close to the overflow threshold. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* = 1: inverse iteration did not converge; VR is set to the */
/* last iterate, and so is VI if WI.ne.0.0. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--vr;
--vi;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--work;
/* Function Body */
*info = 0;
/* GROWTO is the threshold used in the acceptance test for an */
/* eigenvector. */
rootn = sqrt((float) (*n));
growto = .1f / rootn;
/* Computing MAX */
r__1 = 1.f, r__2 = *eps3 * rootn;
nrmsml = MAX(r__1,r__2) * *smlnum;
/* Form B = H - (WR,WI)*I (except that the subdiagonal elements and */
/* the imaginary parts of the diagonal elements are not stored). */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
b[i__ + j * b_dim1] = h__[i__ + j * h_dim1];
/* L10: */
}
b[j + j * b_dim1] = h__[j + j * h_dim1] - *wr;
/* L20: */
}
if (*wi == 0.f) {
/* Real eigenvalue. */
if (*noinit) {
/* Set initial vector. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
vr[i__] = *eps3;
/* L30: */
}
} else {
/* Scale supplied initial vector. */
vnorm = snrm2_(n, &vr[1], &c__1);
r__1 = *eps3 * rootn / MAX(vnorm,nrmsml);
sscal_(n, &r__1, &vr[1], &c__1);
}
if (*rightv) {
/* LU decomposition with partial pivoting of B, replacing zero */
/* pivots by EPS3. */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
ei = h__[i__ + 1 + i__ * h_dim1];
if ((r__1 = b[i__ + i__ * b_dim1], ABS(r__1)) < ABS(ei)) {
/* Interchange rows and eliminate. */
x = b[i__ + i__ * b_dim1] / ei;
b[i__ + i__ * b_dim1] = ei;
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
temp = b[i__ + 1 + j * b_dim1];
b[i__ + 1 + j * b_dim1] = b[i__ + j * b_dim1] - x *
temp;
b[i__ + j * b_dim1] = temp;
/* L40: */
}
} else {
/* Eliminate without interchange. */
if (b[i__ + i__ * b_dim1] == 0.f) {
b[i__ + i__ * b_dim1] = *eps3;
}
x = ei / b[i__ + i__ * b_dim1];
if (x != 0.f) {
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
b[i__ + 1 + j * b_dim1] -= x * b[i__ + j * b_dim1]
;
/* L50: */
}
}
}
/* L60: */
}
if (b[*n + *n * b_dim1] == 0.f) {
b[*n + *n * b_dim1] = *eps3;
}
*(unsigned char *)trans = 'N';
} else {
/* UL decomposition with partial pivoting of B, replacing zero */
/* pivots by EPS3. */
for (j = *n; j >= 2; --j) {
ej = h__[j + (j - 1) * h_dim1];
if ((r__1 = b[j + j * b_dim1], ABS(r__1)) < ABS(ej)) {
/* Interchange columns and eliminate. */
x = b[j + j * b_dim1] / ej;
b[j + j * b_dim1] = ej;
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = b[i__ + (j - 1) * b_dim1];
b[i__ + (j - 1) * b_dim1] = b[i__ + j * b_dim1] - x *
temp;
b[i__ + j * b_dim1] = temp;
/* L70: */
}
} else {
/* Eliminate without interchange. */
if (b[j + j * b_dim1] == 0.f) {
b[j + j * b_dim1] = *eps3;
}
x = ej / b[j + j * b_dim1];
if (x != 0.f) {
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
b[i__ + (j - 1) * b_dim1] -= x * b[i__ + j *
b_dim1];
/* L80: */
}
}
}
/* L90: */
}
if (b[b_dim1 + 1] == 0.f) {
b[b_dim1 + 1] = *eps3;
}
*(unsigned char *)trans = 'T';
}
*(unsigned char *)normin = 'N';
i__1 = *n;
for (its = 1; its <= i__1; ++its) {
/* Solve U*x = scale*v for a right eigenvector */
/* or U'*x = scale*v for a left eigenvector, */
/* overwriting x on v. */
slatrs_("Upper", trans, "Nonunit", normin, n, &b[b_offset], ldb, &
vr[1], &scale, &work[1], &ierr);
*(unsigned char *)normin = 'Y';
/* Test for sufficient growth in the norm of v. */
vnorm = sasum_(n, &vr[1], &c__1);
if (vnorm >= growto * scale) {
goto L120;
}
/* Choose new orthogonal starting vector and try again. */
temp = *eps3 / (rootn + 1.f);
vr[1] = *eps3;
i__2 = *n;
for (i__ = 2; i__ <= i__2; ++i__) {
vr[i__] = temp;
/* L100: */
}
vr[*n - its + 1] -= *eps3 * rootn;
/* L110: */
}
/* Failure to find eigenvector in N iterations. */
*info = 1;
L120:
/* Normalize eigenvector. */
i__ = isamax_(n, &vr[1], &c__1);
r__2 = 1.f / (r__1 = vr[i__], ABS(r__1));
sscal_(n, &r__2, &vr[1], &c__1);
} else {
/* Complex eigenvalue. */
if (*noinit) {
/* Set initial vector. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
vr[i__] = *eps3;
vi[i__] = 0.f;
/* L130: */
}
} else {
/* Scale supplied initial vector. */
r__1 = snrm2_(n, &vr[1], &c__1);
r__2 = snrm2_(n, &vi[1], &c__1);
norm = slapy2_(&r__1, &r__2);
rec = *eps3 * rootn / MAX(norm,nrmsml);
sscal_(n, &rec, &vr[1], &c__1);
sscal_(n, &rec, &vi[1], &c__1);
}
if (*rightv) {
/* LU decomposition with partial pivoting of B, replacing zero */
/* pivots by EPS3. */
/* The imaginary part of the (i,j)-th element of U is stored in */
/* B(j+1,i). */
b[b_dim1 + 2] = -(*wi);
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
b[i__ + 1 + b_dim1] = 0.f;
/* L140: */
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
absbii = slapy2_(&b[i__ + i__ * b_dim1], &b[i__ + 1 + i__ *
b_dim1]);
ei = h__[i__ + 1 + i__ * h_dim1];
if (absbii < ABS(ei)) {
/* Interchange rows and eliminate. */
xr = b[i__ + i__ * b_dim1] / ei;
xi = b[i__ + 1 + i__ * b_dim1] / ei;
b[i__ + i__ * b_dim1] = ei;
b[i__ + 1 + i__ * b_dim1] = 0.f;
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
temp = b[i__ + 1 + j * b_dim1];
b[i__ + 1 + j * b_dim1] = b[i__ + j * b_dim1] - xr *
temp;
b[j + 1 + (i__ + 1) * b_dim1] = b[j + 1 + i__ *
b_dim1] - xi * temp;
b[i__ + j * b_dim1] = temp;
b[j + 1 + i__ * b_dim1] = 0.f;
/* L150: */
}
b[i__ + 2 + i__ * b_dim1] = -(*wi);
b[i__ + 1 + (i__ + 1) * b_dim1] -= xi * *wi;
b[i__ + 2 + (i__ + 1) * b_dim1] += xr * *wi;
} else {
/* Eliminate without interchanging rows. */
if (absbii == 0.f) {
b[i__ + i__ * b_dim1] = *eps3;
b[i__ + 1 + i__ * b_dim1] = 0.f;
absbii = *eps3;
}
ei = ei / absbii / absbii;
xr = b[i__ + i__ * b_dim1] * ei;
xi = -b[i__ + 1 + i__ * b_dim1] * ei;
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
b[i__ + 1 + j * b_dim1] = b[i__ + 1 + j * b_dim1] -
xr * b[i__ + j * b_dim1] + xi * b[j + 1 + i__
* b_dim1];
b[j + 1 + (i__ + 1) * b_dim1] = -xr * b[j + 1 + i__ *
b_dim1] - xi * b[i__ + j * b_dim1];
/* L160: */
}
b[i__ + 2 + (i__ + 1) * b_dim1] -= *wi;
}
/* Compute 1-norm of offdiagonal elements of i-th row. */
i__2 = *n - i__;
i__3 = *n - i__;
work[i__] = sasum_(&i__2, &b[i__ + (i__ + 1) * b_dim1], ldb)
+ sasum_(&i__3, &b[i__ + 2 + i__ * b_dim1], &c__1);
/* L170: */
}
if (b[*n + *n * b_dim1] == 0.f && b[*n + 1 + *n * b_dim1] == 0.f)
{
b[*n + *n * b_dim1] = *eps3;
}
work[*n] = 0.f;
i1 = *n;
i2 = 1;
i3 = -1;
} else {
/* UL decomposition with partial pivoting of conjg(B), */
/* replacing zero pivots by EPS3. */
/* The imaginary part of the (i,j)-th element of U is stored in */
/* B(j+1,i). */
b[*n + 1 + *n * b_dim1] = *wi;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
b[*n + 1 + j * b_dim1] = 0.f;
/* L180: */
}
for (j = *n; j >= 2; --j) {
ej = h__[j + (j - 1) * h_dim1];
absbjj = slapy2_(&b[j + j * b_dim1], &b[j + 1 + j * b_dim1]);
if (absbjj < ABS(ej)) {
/* Interchange columns and eliminate */
xr = b[j + j * b_dim1] / ej;
xi = b[j + 1 + j * b_dim1] / ej;
b[j + j * b_dim1] = ej;
b[j + 1 + j * b_dim1] = 0.f;
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = b[i__ + (j - 1) * b_dim1];
b[i__ + (j - 1) * b_dim1] = b[i__ + j * b_dim1] - xr *
temp;
b[j + i__ * b_dim1] = b[j + 1 + i__ * b_dim1] - xi *
temp;
b[i__ + j * b_dim1] = temp;
b[j + 1 + i__ * b_dim1] = 0.f;
/* L190: */
}
b[j + 1 + (j - 1) * b_dim1] = *wi;
b[j - 1 + (j - 1) * b_dim1] += xi * *wi;
b[j + (j - 1) * b_dim1] -= xr * *wi;
} else {
/* Eliminate without interchange. */
if (absbjj == 0.f) {
b[j + j * b_dim1] = *eps3;
b[j + 1 + j * b_dim1] = 0.f;
absbjj = *eps3;
}
ej = ej / absbjj / absbjj;
xr = b[j + j * b_dim1] * ej;
xi = -b[j + 1 + j * b_dim1] * ej;
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
b[i__ + (j - 1) * b_dim1] = b[i__ + (j - 1) * b_dim1]
- xr * b[i__ + j * b_dim1] + xi * b[j + 1 +
i__ * b_dim1];
b[j + i__ * b_dim1] = -xr * b[j + 1 + i__ * b_dim1] -
xi * b[i__ + j * b_dim1];
/* L200: */
}
b[j + (j - 1) * b_dim1] += *wi;
}
/* Compute 1-norm of offdiagonal elements of j-th column. */
i__1 = j - 1;
i__2 = j - 1;
work[j] = sasum_(&i__1, &b[j * b_dim1 + 1], &c__1) + sasum_(&
i__2, &b[j + 1 + b_dim1], ldb);
/* L210: */
}
if (b[b_dim1 + 1] == 0.f && b[b_dim1 + 2] == 0.f) {
b[b_dim1 + 1] = *eps3;
}
work[1] = 0.f;
i1 = 1;
i2 = *n;
i3 = 1;
}
i__1 = *n;
for (its = 1; its <= i__1; ++its) {
scale = 1.f;
vmax = 1.f;
vcrit = *bignum;
/* Solve U*(xr,xi) = scale*(vr,vi) for a right eigenvector, */
/* or U'*(xr,xi) = scale*(vr,vi) for a left eigenvector, */
/* overwriting (xr,xi) on (vr,vi). */
i__2 = i2;
i__3 = i3;
for (i__ = i1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3)
{
if (work[i__] > vcrit) {
rec = 1.f / vmax;
sscal_(n, &rec, &vr[1], &c__1);
sscal_(n, &rec, &vi[1], &c__1);
scale *= rec;
vmax = 1.f;
vcrit = *bignum;
}
xr = vr[i__];
xi = vi[i__];
if (*rightv) {
i__4 = *n;
for (j = i__ + 1; j <= i__4; ++j) {
xr = xr - b[i__ + j * b_dim1] * vr[j] + b[j + 1 + i__
* b_dim1] * vi[j];
xi = xi - b[i__ + j * b_dim1] * vi[j] - b[j + 1 + i__
* b_dim1] * vr[j];
/* L220: */
}
} else {
i__4 = i__ - 1;
for (j = 1; j <= i__4; ++j) {
xr = xr - b[j + i__ * b_dim1] * vr[j] + b[i__ + 1 + j
* b_dim1] * vi[j];
xi = xi - b[j + i__ * b_dim1] * vi[j] - b[i__ + 1 + j
* b_dim1] * vr[j];
/* L230: */
}
}
w = (r__1 = b[i__ + i__ * b_dim1], ABS(r__1)) + (r__2 = b[
i__ + 1 + i__ * b_dim1], ABS(r__2));
if (w > *smlnum) {
if (w < 1.f) {
w1 = ABS(xr) + ABS(xi);
if (w1 > w * *bignum) {
rec = 1.f / w1;
sscal_(n, &rec, &vr[1], &c__1);
sscal_(n, &rec, &vi[1], &c__1);
xr = vr[i__];
xi = vi[i__];
scale *= rec;
vmax *= rec;
}
}
/* Divide by diagonal element of B. */
sladiv_(&xr, &xi, &b[i__ + i__ * b_dim1], &b[i__ + 1 +
i__ * b_dim1], &vr[i__], &vi[i__]);
/* Computing MAX */
r__3 = (r__1 = vr[i__], ABS(r__1)) + (r__2 = vi[i__],
ABS(r__2));
vmax = MAX(r__3,vmax);
vcrit = *bignum / vmax;
} else {
i__4 = *n;
for (j = 1; j <= i__4; ++j) {
vr[j] = 0.f;
vi[j] = 0.f;
/* L240: */
}
vr[i__] = 1.f;
vi[i__] = 1.f;
scale = 0.f;
vmax = 1.f;
vcrit = *bignum;
}
/* L250: */
}
/* Test for sufficient growth in the norm of (VR,VI). */
vnorm = sasum_(n, &vr[1], &c__1) + sasum_(n, &vi[1], &c__1);
if (vnorm >= growto * scale) {
goto L280;
}
/* Choose a new orthogonal starting vector and try again. */
y = *eps3 / (rootn + 1.f);
vr[1] = *eps3;
vi[1] = 0.f;
i__3 = *n;
for (i__ = 2; i__ <= i__3; ++i__) {
vr[i__] = y;
vi[i__] = 0.f;
/* L260: */
}
vr[*n - its + 1] -= *eps3 * rootn;
/* L270: */
}
/* Failure to find eigenvector in N iterations */
*info = 1;
L280:
/* Normalize eigenvector. */
vnorm = 0.f;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__3 = vnorm, r__4 = (r__1 = vr[i__], ABS(r__1)) + (r__2 = vi[
i__], ABS(r__2));
vnorm = MAX(r__3,r__4);
/* L290: */
}
r__1 = 1.f / vnorm;
sscal_(n, &r__1, &vr[1], &c__1);
r__1 = 1.f / vnorm;
sscal_(n, &r__1, &vi[1], &c__1);
}
return 0;
/* End of SLAEIN */
} /* slaein_ */
/* Subroutine */ int claed8_(integer *k, integer *n, integer *qsiz, complex *
q, integer *ldq, real *d__, real *rho, integer *cutpnt, real *z__,
real *dlamda, complex *q2, integer *ldq2, real *w, integer *indxp,
integer *indx, integer *indxq, integer *perm, integer *givptr,
integer *givcol, real *givnum, integer *info)
{
/* System generated locals */
integer q_dim1, q_offset, q2_dim1, q2_offset, i__1;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
real c__;
integer i__, j;
real s, t;
integer k2, n1, n2, jp, n1p1;
real eps, tau, tol;
integer jlam, imax, jmax;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
ccopy_(integer *, complex *, integer *, complex *, integer *),
csrot_(integer *, complex *, integer *, complex *, integer *,
real *, real *), scopy_(integer *, real *, integer *, real *,
integer *);
extern doublereal slapy2_(real *, real *), slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), xerbla_(char *,
integer *);
extern integer isamax_(integer *, real *, integer *);
extern /* Subroutine */ int slamrg_(integer *, integer *, real *, integer
*, integer *, integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLAED8 merges the two sets of eigenvalues together into a single */
/* sorted set. Then it tries to deflate the size of the problem. */
/* There are two ways in which deflation can occur: when two or more */
/* eigenvalues are close together or if there is a tiny element in the */
/* Z vector. For each such occurrence the order of the related secular */
/* equation problem is reduced by one. */
/* Arguments */
/* ========= */
/* K (output) INTEGER */
/* Contains the number of non-deflated eigenvalues. */
/* This is the order of the related secular equation. */
/* N (input) INTEGER */
/* The dimension of the symmetric tridiagonal matrix. N >= 0. */
/* QSIZ (input) INTEGER */
/* The dimension of the unitary matrix used to reduce */
/* the dense or band matrix to tridiagonal form. */
/* QSIZ >= N if ICOMPQ = 1. */
/* Q (input/output) COMPLEX array, dimension (LDQ,N) */
/* On entry, Q contains the eigenvectors of the partially solved */
/* system which has been previously updated in matrix */
/* multiplies with other partially solved eigensystems. */
/* On exit, Q contains the trailing (N-K) updated eigenvectors */
/* (those which were deflated) in its last N-K columns. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= max( 1, N ). */
/* D (input/output) REAL array, dimension (N) */
/* On entry, D contains the eigenvalues of the two submatrices to */
/* be combined. On exit, D contains the trailing (N-K) updated */
/* eigenvalues (those which were deflated) sorted into increasing */
/* order. */
/* RHO (input/output) REAL */
/* Contains the off diagonal element associated with the rank-1 */
/* cut which originally split the two submatrices which are now */
/* being recombined. RHO is modified during the computation to */
/* the value required by SLAED3. */
/* CUTPNT (input) INTEGER */
/* Contains the location of the last eigenvalue in the leading */
/* sub-matrix. MIN(1,N) <= CUTPNT <= N. */
/* Z (input) REAL array, dimension (N) */
/* On input this vector contains the updating vector (the last */
/* row of the first sub-eigenvector matrix and the first row of */
/* the second sub-eigenvector matrix). The contents of Z are */
/* destroyed during the updating process. */
/* DLAMDA (output) REAL array, dimension (N) */
/* Contains a copy of the first K eigenvalues which will be used */
/* by SLAED3 to form the secular equation. */
/* Q2 (output) COMPLEX array, dimension (LDQ2,N) */
/* If ICOMPQ = 0, Q2 is not referenced. Otherwise, */
/* Contains a copy of the first K eigenvectors which will be used */
/* by SLAED7 in a matrix multiply (SGEMM) to update the new */
/* eigenvectors. */
/* LDQ2 (input) INTEGER */
/* The leading dimension of the array Q2. LDQ2 >= max( 1, N ). */
/* W (output) REAL array, dimension (N) */
/* This will hold the first k values of the final */
/* deflation-altered z-vector and will be passed to SLAED3. */
/* INDXP (workspace) INTEGER array, dimension (N) */
/* This will contain the permutation used to place deflated */
/* values of D at the end of the array. On output INDXP(1:K) */
/* points to the nondeflated D-values and INDXP(K+1:N) */
/* points to the deflated eigenvalues. */
/* INDX (workspace) INTEGER array, dimension (N) */
/* This will contain the permutation used to sort the contents of */
/* D into ascending order. */
/* INDXQ (input) INTEGER array, dimension (N) */
/* This contains the permutation which separately sorts the two */
/* sub-problems in D into ascending order. Note that elements in */
/* the second half of this permutation must first have CUTPNT */
/* added to their values in order to be accurate. */
/* PERM (output) INTEGER array, dimension (N) */
/* Contains the permutations (from deflation and sorting) to be */
/* applied to each eigenblock. */
/* GIVPTR (output) INTEGER */
/* Contains the number of Givens rotations which took place in */
/* this subproblem. */
/* GIVCOL (output) INTEGER array, dimension (2, N) */
/* Each pair of numbers indicates a pair of columns to take place */
/* in a Givens rotation. */
/* GIVNUM (output) REAL array, dimension (2, N) */
/* Each number indicates the S value to be used in the */
/* corresponding Givens rotation. */
/* 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 .. */
/* Test the input parameters. */
/* Parameter adjustments */
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--d__;
--z__;
--dlamda;
q2_dim1 = *ldq2;
q2_offset = 1 + q2_dim1;
q2 -= q2_offset;
--w;
--indxp;
--indx;
--indxq;
--perm;
givcol -= 3;
givnum -= 3;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -2;
} else if (*qsiz < *n) {
*info = -3;
} else if (*ldq < max(1,*n)) {
*info = -5;
} else if (*cutpnt < min(1,*n) || *cutpnt > *n) {
*info = -8;
} else if (*ldq2 < max(1,*n)) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CLAED8", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
n1 = *cutpnt;
n2 = *n - n1;
n1p1 = n1 + 1;
if (*rho < 0.f) {
sscal_(&n2, &c_b3, &z__[n1p1], &c__1);
}
/* Normalize z so that norm(z) = 1 */
t = 1.f / sqrt(2.f);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
indx[j] = j;
/* L10: */
}
sscal_(n, &t, &z__[1], &c__1);
*rho = (r__1 = *rho * 2.f, dabs(r__1));
/* Sort the eigenvalues into increasing order */
i__1 = *n;
for (i__ = *cutpnt + 1; i__ <= i__1; ++i__) {
indxq[i__] += *cutpnt;
/* L20: */
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
dlamda[i__] = d__[indxq[i__]];
w[i__] = z__[indxq[i__]];
/* L30: */
}
i__ = 1;
j = *cutpnt + 1;
slamrg_(&n1, &n2, &dlamda[1], &c__1, &c__1, &indx[1]);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = dlamda[indx[i__]];
z__[i__] = w[indx[i__]];
/* L40: */
}
/* Calculate the allowable deflation tolerance */
imax = isamax_(n, &z__[1], &c__1);
jmax = isamax_(n, &d__[1], &c__1);
eps = slamch_("Epsilon");
tol = eps * 8.f * (r__1 = d__[jmax], dabs(r__1));
/* If the rank-1 modifier is small enough, no more needs to be done */
/* -- except to reorganize Q so that its columns correspond with the */
/* elements in D. */
if (*rho * (r__1 = z__[imax], dabs(r__1)) <= tol) {
*k = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
perm[j] = indxq[indx[j]];
ccopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1]
, &c__1);
/* L50: */
}
clacpy_("A", qsiz, n, &q2[q2_dim1 + 1], ldq2, &q[q_dim1 + 1], ldq);
return 0;
}
/* If there are multiple eigenvalues then the problem deflates. Here */
/* the number of equal eigenvalues are found. As each equal */
/* eigenvalue is found, an elementary reflector is computed to rotate */
/* the corresponding eigensubspace so that the corresponding */
/* components of Z are zero in this new basis. */
*k = 0;
*givptr = 0;
k2 = *n + 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (*rho * (r__1 = z__[j], dabs(r__1)) <= tol) {
/* Deflate due to small z component. */
--k2;
indxp[k2] = j;
if (j == *n) {
goto L100;
}
} else {
jlam = j;
goto L70;
}
/* L60: */
}
L70:
++j;
if (j > *n) {
goto L90;
}
if (*rho * (r__1 = z__[j], dabs(r__1)) <= tol) {
/* Deflate due to small z component. */
--k2;
indxp[k2] = j;
} else {
/* Check if eigenvalues are close enough to allow deflation. */
s = z__[jlam];
c__ = z__[j];
/* Find sqrt(a**2+b**2) without overflow or */
/* destructive underflow. */
tau = slapy2_(&c__, &s);
t = d__[j] - d__[jlam];
c__ /= tau;
s = -s / tau;
if ((r__1 = t * c__ * s, dabs(r__1)) <= tol) {
/* Deflation is possible. */
z__[j] = tau;
z__[jlam] = 0.f;
/* Record the appropriate Givens rotation */
++(*givptr);
givcol[(*givptr << 1) + 1] = indxq[indx[jlam]];
givcol[(*givptr << 1) + 2] = indxq[indx[j]];
givnum[(*givptr << 1) + 1] = c__;
givnum[(*givptr << 1) + 2] = s;
csrot_(qsiz, &q[indxq[indx[jlam]] * q_dim1 + 1], &c__1, &q[indxq[
indx[j]] * q_dim1 + 1], &c__1, &c__, &s);
t = d__[jlam] * c__ * c__ + d__[j] * s * s;
d__[j] = d__[jlam] * s * s + d__[j] * c__ * c__;
d__[jlam] = t;
--k2;
i__ = 1;
L80:
if (k2 + i__ <= *n) {
if (d__[jlam] < d__[indxp[k2 + i__]]) {
indxp[k2 + i__ - 1] = indxp[k2 + i__];
indxp[k2 + i__] = jlam;
++i__;
goto L80;
} else {
indxp[k2 + i__ - 1] = jlam;
}
} else {
indxp[k2 + i__ - 1] = jlam;
}
jlam = j;
} else {
++(*k);
w[*k] = z__[jlam];
dlamda[*k] = d__[jlam];
indxp[*k] = jlam;
jlam = j;
}
}
goto L70;
L90:
/* Record the last eigenvalue. */
++(*k);
w[*k] = z__[jlam];
dlamda[*k] = d__[jlam];
indxp[*k] = jlam;
L100:
/* Sort the eigenvalues and corresponding eigenvectors into DLAMDA */
/* and Q2 respectively. The eigenvalues/vectors which were not */
/* deflated go into the first K slots of DLAMDA and Q2 respectively, */
/* while those which were deflated go into the last N - K slots. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
jp = indxp[j];
dlamda[j] = d__[jp];
perm[j] = indxq[indx[jp]];
ccopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1], &
c__1);
/* L110: */
}
/* The deflated eigenvalues and their corresponding vectors go back */
/* into the last N - K slots of D and Q respectively. */
if (*k < *n) {
i__1 = *n - *k;
scopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1);
i__1 = *n - *k;
clacpy_("A", qsiz, &i__1, &q2[(*k + 1) * q2_dim1 + 1], ldq2, &q[(*k +
1) * q_dim1 + 1], ldq);
}
return 0;
/* End of CLAED8 */
} /* claed8_ */
/* Subroutine */ int clarfp_(integer *n, complex *alpha, complex *x, integer *
incx, complex *tau)
{
/* System generated locals */
integer i__1, i__2;
real r__1, r__2;
complex q__1, q__2;
/* Builtin functions */
double r_imag(complex *), r_sign(real *, real *);
/* Local variables */
integer j, knt;
real beta;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
real alphi, alphr, xnorm;
extern doublereal scnrm2_(integer *, complex *, integer *), slapy2_(real *
, real *), slapy3_(real *, real *, real *);
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*);
real safmin, rsafmn;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLARFP generates a complex elementary reflector H of order n, such */
/* that */
/* H' * ( alpha ) = ( beta ), H' * H = I. */
/* ( x ) ( 0 ) */
/* where alpha and beta are scalars, beta is real and non-negative, and */
/* x is an (n-1)-element complex vector. H is represented in the form */
/* H = I - tau * ( 1 ) * ( 1 v' ) , */
/* ( v ) */
/* where tau is a complex scalar and v is a complex (n-1)-element */
/* vector. Note that H is not hermitian. */
/* If the elements of x are all zero and alpha is real, then tau = 0 */
/* and H is taken to be the unit matrix. */
/* Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 . */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the elementary reflector. */
/* ALPHA (input/output) COMPLEX */
/* On entry, the value alpha. */
/* On exit, it is overwritten with the value beta. */
/* X (input/output) COMPLEX array, dimension */
/* (1+(N-2)*abs(INCX)) */
/* On entry, the vector x. */
/* On exit, it is overwritten with the vector v. */
/* INCX (input) INTEGER */
/* The increment between elements of X. INCX > 0. */
/* TAU (output) COMPLEX */
/* The value tau. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--x;
/* Function Body */
if (*n <= 0) {
tau->r = 0.f, tau->i = 0.f;
return 0;
}
i__1 = *n - 1;
xnorm = scnrm2_(&i__1, &x[1], incx);
alphr = alpha->r;
alphi = r_imag(alpha);
if (xnorm == 0.f && alphi == 0.f) {
/* H = [1-alpha/abs(alpha) 0; 0 I], sign chosen so ALPHA >= 0. */
if (alphi == 0.f) {
if (alphr >= 0.f) {
/* When TAU.eq.ZERO, the vector is special-cased to be */
/* all zeros in the application routines. We do not need */
/* to clear it. */
tau->r = 0.f, tau->i = 0.f;
} else {
/* However, the application routines rely on explicit */
/* zero checks when TAU.ne.ZERO, and we must clear X. */
tau->r = 2.f, tau->i = 0.f;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.f, x[i__2].i = 0.f;
}
q__1.r = -alpha->r, q__1.i = -alpha->i;
alpha->r = q__1.r, alpha->i = q__1.i;
}
} else {
/* Only "reflecting" the diagonal entry to be real and non-negative. */
xnorm = slapy2_(&alphr, &alphi);
r__1 = 1.f - alphr / xnorm;
r__2 = -alphi / xnorm;
q__1.r = r__1, q__1.i = r__2;
tau->r = q__1.r, tau->i = q__1.i;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.f, x[i__2].i = 0.f;
}
alpha->r = xnorm, alpha->i = 0.f;
}
} else {
/* general case */
r__1 = slapy3_(&alphr, &alphi, &xnorm);
beta = r_sign(&r__1, &alphr);
safmin = slamch_("S") / slamch_("E");
rsafmn = 1.f / safmin;
knt = 0;
if (dabs(beta) < safmin) {
/* XNORM, BETA may be inaccurate; scale X and recompute them */
L10:
++knt;
i__1 = *n - 1;
csscal_(&i__1, &rsafmn, &x[1], incx);
beta *= rsafmn;
alphi *= rsafmn;
alphr *= rsafmn;
if (dabs(beta) < safmin) {
goto L10;
}
/* New BETA is at most 1, at least SAFMIN */
i__1 = *n - 1;
xnorm = scnrm2_(&i__1, &x[1], incx);
q__1.r = alphr, q__1.i = alphi;
alpha->r = q__1.r, alpha->i = q__1.i;
r__1 = slapy3_(&alphr, &alphi, &xnorm);
beta = r_sign(&r__1, &alphr);
}
q__1.r = alpha->r + beta, q__1.i = alpha->i;
alpha->r = q__1.r, alpha->i = q__1.i;
if (beta < 0.f) {
beta = -beta;
q__2.r = -alpha->r, q__2.i = -alpha->i;
q__1.r = q__2.r / beta, q__1.i = q__2.i / beta;
tau->r = q__1.r, tau->i = q__1.i;
} else {
alphr = alphi * (alphi / alpha->r);
alphr += xnorm * (xnorm / alpha->r);
r__1 = alphr / beta;
r__2 = -alphi / beta;
q__1.r = r__1, q__1.i = r__2;
tau->r = q__1.r, tau->i = q__1.i;
r__1 = -alphr;
q__1.r = r__1, q__1.i = alphi;
alpha->r = q__1.r, alpha->i = q__1.i;
}
cladiv_(&q__1, &c_b5, alpha);
alpha->r = q__1.r, alpha->i = q__1.i;
i__1 = *n - 1;
cscal_(&i__1, alpha, &x[1], incx);
/* If BETA is subnormal, it may lose relative accuracy */
i__1 = knt;
for (j = 1; j <= i__1; ++j) {
beta *= safmin;
/* L20: */
}
alpha->r = beta, alpha->i = 0.f;
}
return 0;
/* End of CLARFP */
} /* clarfp_ */
/* Subroutine */ int clartg_(complex *f, complex *g, real *cs, complex *sn,
complex *r__)
{
/* System generated locals */
integer i__1;
real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10;
complex q__1, q__2, q__3;
/* Builtin functions */
double log(doublereal), pow_ri(real *, integer *), r_imag(complex *),
sqrt(doublereal);
void r_cnjg(complex *, complex *);
/* Local variables */
real d__;
integer i__;
real f2, g2;
complex ff;
real di, dr;
complex fs, gs;
real f2s, g2s, eps, scale;
integer count;
real safmn2, safmx2;
extern doublereal slapy2_(real *, real *), slamch_(char *);
real safmin;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLARTG generates a plane rotation so that */
/* [ CS SN ] [ F ] [ R ] */
/* [ __ ] . [ ] = [ ] where CS**2 + |SN|**2 = 1. */
/* [ -SN CS ] [ G ] [ 0 ] */
/* This is a faster version of the BLAS1 routine CROTG, except for */
/* the following differences: */
/* F and G are unchanged on return. */
/* If G=0, then CS=1 and SN=0. */
/* If F=0, then CS=0 and SN is chosen so that R is real. */
/* Arguments */
/* ========= */
/* F (input) COMPLEX */
/* The first component of vector to be rotated. */
/* G (input) COMPLEX */
/* The second component of vector to be rotated. */
/* CS (output) REAL */
/* The cosine of the rotation. */
/* SN (output) COMPLEX */
/* The sine of the rotation. */
/* R (output) COMPLEX */
/* The nonzero component of the rotated vector. */
/* Further Details */
/* ======= ======= */
/* 3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel */
/* This version has a few statements commented out for thread safety */
/* (machine parameters are computed on each entry). 10 feb 03, SJH. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* LOGICAL FIRST */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Save statement .. */
/* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 */
/* .. */
/* .. Data statements .. */
/* DATA FIRST / .TRUE. / */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* IF( FIRST ) THEN */
safmin = slamch_("S");
eps = slamch_("E");
r__1 = slamch_("B");
i__1 = (integer) (log(safmin / eps) / log(slamch_("B")) / 2.f);
safmn2 = pow_ri(&r__1, &i__1);
safmx2 = 1.f / safmn2;
/* FIRST = .FALSE. */
/* END IF */
/* Computing MAX */
/* Computing MAX */
r__7 = (r__1 = f->r, dabs(r__1)), r__8 = (r__2 = r_imag(f), dabs(r__2));
/* Computing MAX */
r__9 = (r__3 = g->r, dabs(r__3)), r__10 = (r__4 = r_imag(g), dabs(r__4));
r__5 = dmax(r__7,r__8), r__6 = dmax(r__9,r__10);
scale = dmax(r__5,r__6);
fs.r = f->r, fs.i = f->i;
gs.r = g->r, gs.i = g->i;
count = 0;
if (scale >= safmx2) {
L10:
++count;
q__1.r = safmn2 * fs.r, q__1.i = safmn2 * fs.i;
fs.r = q__1.r, fs.i = q__1.i;
q__1.r = safmn2 * gs.r, q__1.i = safmn2 * gs.i;
gs.r = q__1.r, gs.i = q__1.i;
scale *= safmn2;
if (scale >= safmx2) {
goto L10;
}
} else if (scale <= safmn2) {
if (g->r == 0.f && g->i == 0.f) {
*cs = 1.f;
sn->r = 0.f, sn->i = 0.f;
r__->r = f->r, r__->i = f->i;
return 0;
}
L20:
--count;
q__1.r = safmx2 * fs.r, q__1.i = safmx2 * fs.i;
fs.r = q__1.r, fs.i = q__1.i;
q__1.r = safmx2 * gs.r, q__1.i = safmx2 * gs.i;
gs.r = q__1.r, gs.i = q__1.i;
scale *= safmx2;
if (scale <= safmn2) {
goto L20;
}
}
/* Computing 2nd power */
r__1 = fs.r;
/* Computing 2nd power */
r__2 = r_imag(&fs);
f2 = r__1 * r__1 + r__2 * r__2;
/* Computing 2nd power */
r__1 = gs.r;
/* Computing 2nd power */
r__2 = r_imag(&gs);
g2 = r__1 * r__1 + r__2 * r__2;
if (f2 <= dmax(g2,1.f) * safmin) {
/* This is a rare case: F is very small. */
if (f->r == 0.f && f->i == 0.f) {
*cs = 0.f;
r__2 = g->r;
r__3 = r_imag(g);
r__1 = slapy2_(&r__2, &r__3);
r__->r = r__1, r__->i = 0.f;
/* Do complex/real division explicitly with two real divisions */
r__1 = gs.r;
r__2 = r_imag(&gs);
d__ = slapy2_(&r__1, &r__2);
r__1 = gs.r / d__;
r__2 = -r_imag(&gs) / d__;
q__1.r = r__1, q__1.i = r__2;
sn->r = q__1.r, sn->i = q__1.i;
return 0;
}
r__1 = fs.r;
r__2 = r_imag(&fs);
f2s = slapy2_(&r__1, &r__2);
/* G2 and G2S are accurate */
/* G2 is at least SAFMIN, and G2S is at least SAFMN2 */
g2s = sqrt(g2);
/* Error in CS from underflow in F2S is at most */
/* UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS */
/* If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN, */
/* and so CS .lt. sqrt(SAFMIN) */
/* If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN */
/* and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS) */
/* Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S */
*cs = f2s / g2s;
/* Make sure abs(FF) = 1 */
/* Do complex/real division explicitly with 2 real divisions */
/* Computing MAX */
r__3 = (r__1 = f->r, dabs(r__1)), r__4 = (r__2 = r_imag(f), dabs(r__2)
);
if (dmax(r__3,r__4) > 1.f) {
r__1 = f->r;
r__2 = r_imag(f);
d__ = slapy2_(&r__1, &r__2);
r__1 = f->r / d__;
r__2 = r_imag(f) / d__;
q__1.r = r__1, q__1.i = r__2;
ff.r = q__1.r, ff.i = q__1.i;
} else {
dr = safmx2 * f->r;
di = safmx2 * r_imag(f);
d__ = slapy2_(&dr, &di);
r__1 = dr / d__;
r__2 = di / d__;
q__1.r = r__1, q__1.i = r__2;
ff.r = q__1.r, ff.i = q__1.i;
}
r__1 = gs.r / g2s;
r__2 = -r_imag(&gs) / g2s;
q__2.r = r__1, q__2.i = r__2;
q__1.r = ff.r * q__2.r - ff.i * q__2.i, q__1.i = ff.r * q__2.i + ff.i
* q__2.r;
sn->r = q__1.r, sn->i = q__1.i;
q__2.r = *cs * f->r, q__2.i = *cs * f->i;
q__3.r = sn->r * g->r - sn->i * g->i, q__3.i = sn->r * g->i + sn->i *
g->r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
r__->r = q__1.r, r__->i = q__1.i;
} else {
/* This is the most common case. */
/* Neither F2 nor F2/G2 are less than SAFMIN */
/* F2S cannot overflow, and it is accurate */
f2s = sqrt(g2 / f2 + 1.f);
/* Do the F2S(real)*FS(complex) multiply with two real multiplies */
r__1 = f2s * fs.r;
r__2 = f2s * r_imag(&fs);
q__1.r = r__1, q__1.i = r__2;
r__->r = q__1.r, r__->i = q__1.i;
*cs = 1.f / f2s;
d__ = f2 + g2;
/* Do complex/real division explicitly with two real divisions */
r__1 = r__->r / d__;
r__2 = r_imag(r__) / d__;
q__1.r = r__1, q__1.i = r__2;
sn->r = q__1.r, sn->i = q__1.i;
r_cnjg(&q__2, &gs);
q__1.r = sn->r * q__2.r - sn->i * q__2.i, q__1.i = sn->r * q__2.i +
sn->i * q__2.r;
sn->r = q__1.r, sn->i = q__1.i;
if (count != 0) {
if (count > 0) {
i__1 = count;
for (i__ = 1; i__ <= i__1; ++i__) {
q__1.r = safmx2 * r__->r, q__1.i = safmx2 * r__->i;
r__->r = q__1.r, r__->i = q__1.i;
/* L30: */
}
} else {
i__1 = -count;
for (i__ = 1; i__ <= i__1; ++i__) {
q__1.r = safmn2 * r__->r, q__1.i = safmn2 * r__->i;
r__->r = q__1.r, r__->i = q__1.i;
/* L40: */
}
}
}
}
return 0;
/* End of CLARTG */
} /* clartg_ */
/* Subroutine */ int slaed8_(integer *icompq, integer *k, integer *n, integer
*qsiz, real *d, real *q, integer *ldq, integer *indxq, real *rho,
integer *cutpnt, real *z, real *dlamda, real *q2, integer *ldq2, real
*w, integer *perm, integer *givptr, integer *givcol, real *givnum,
integer *indxp, integer *indx, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
Courant Institute, NAG Ltd., and Rice University
September 30, 1994
Purpose
=======
SLAED8 merges the two sets of eigenvalues together into a single
sorted set. Then it tries to deflate the size of the problem.
There are two ways in which deflation can occur: when two or more
eigenvalues are close together or if there is a tiny element in the
Z vector. For each such occurrence the order of the related secular
equation problem is reduced by one.
Arguments
=========
ICOMPQ (input) INTEGER
= 0: Compute eigenvalues only.
= 1: Compute eigenvectors of original dense symmetric matrix
also. On entry, Q contains the orthogonal matrix used
to reduce the original matrix to tridiagonal form.
K (output) INTEGER
The number of non-deflated eigenvalues, and the order of the
related secular equation.
N (input) INTEGER
The dimension of the symmetric tridiagonal matrix. N >= 0.
QSIZ (input) INTEGER
The dimension of the orthogonal matrix used to reduce
the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.
D (input/output) REAL array, dimension (N)
On entry, the eigenvalues of the two submatrices to be
combined. On exit, the trailing (N-K) updated eigenvalues
(those which were deflated) sorted into increasing order.
Q (input/output) REAL array, dimension (LDQ,N)
If ICOMPQ = 0, Q is not referenced. Otherwise,
on entry, Q contains the eigenvectors of the partially solved
system which has been previously updated in matrix
multiplies with other partially solved eigensystems.
On exit, Q contains the trailing (N-K) updated eigenvectors
(those which were deflated) in its last N-K columns.
LDQ (input) INTEGER
The leading dimension of the array Q. LDQ >= max(1,N).
INDXQ (input) INTEGER array, dimension (N)
The permutation which separately sorts the two sub-problems
in D into ascending order. Note that elements in the second
half of this permutation must first have CUTPNT added to
their values in order to be accurate.
RHO (input/output) REAL
On entry, the off-diagonal element associated with the rank-1
cut which originally split the two submatrices which are now
being recombined.
On exit, RHO has been modified to the value required by
SLAED3.
CUTPNT (input) INTEGER
The location of the last eigenvalue in the leading
sub-matrix. min(1,N) <= CUTPNT <= N.
Z (input) REAL array, dimension (N)
On entry, Z contains the updating vector (the last row of
the first sub-eigenvector matrix and the first row of the
second sub-eigenvector matrix).
On exit, the contents of Z are destroyed by the updating
process.
DLAMDA (output) REAL array, dimension (N)
A copy of the first K eigenvalues which will be used by
SLAED3 to form the secular equation.
Q2 (output) REAL array, dimension (LDQ2,N)
If ICOMPQ = 0, Q2 is not referenced. Otherwise,
a copy of the first K eigenvectors which will be used by
SLAED7 in a matrix multiply (SGEMM) to update the new
eigenvectors.
LDQ2 (input) INTEGER
The leading dimension of the array Q2. LDQ2 >= max(1,N).
W (output) REAL array, dimension (N)
The first k values of the final deflation-altered z-vector and
will be passed to SLAED3.
PERM (output) INTEGER array, dimension (N)
The permutations (from deflation and sorting) to be applied
to each eigenblock.
GIVPTR (output) INTEGER
The number of Givens rotations which took place in this
subproblem.
GIVCOL (output) INTEGER array, dimension (2, N)
Each pair of numbers indicates a pair of columns to take place
in a Givens rotation.
GIVNUM (output) REAL array, dimension (2, N)
Each number indicates the S value to be used in the
corresponding Givens rotation.
INDXP (workspace) INTEGER array, dimension (N)
The permutation used to place deflated values of D at the end
of the array. INDXP(1:K) points to the nondeflated D-values
and INDXP(K+1:N) points to the deflated eigenvalues.
INDX (workspace) INTEGER array, dimension (N)
The permutation used to sort the contents of D into ascending
order.
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static real c_b3 = -1.f;
static integer c__1 = 1;
/* System generated locals */
integer q_dim1, q_offset, q2_dim1, q2_offset, i__1;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer jlam, imax, jmax;
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *);
static real c;
static integer i, j;
static real s, t;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static integer k2;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
static integer n1, n2;
extern doublereal slapy2_(real *, real *);
static integer jp;
extern doublereal slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer isamax_(integer *, real *, integer *);
extern /* Subroutine */ int slamrg_(integer *, integer *, real *, integer
*, integer *, integer *), slacpy_(char *, integer *, integer *,
real *, integer *, real *, integer *);
static integer n1p1;
static real eps, tau, tol;
--d;
q_dim1 = *ldq;
q_offset = q_dim1 + 1;
q -= q_offset;
--indxq;
--z;
--dlamda;
q2_dim1 = *ldq2;
q2_offset = q2_dim1 + 1;
q2 -= q2_offset;
--w;
--perm;
givcol -= 3;
givnum -= 3;
--indxp;
--indx;
/* Function Body */
*info = 0;
if (*icompq < 0 || *icompq > 1) {
*info = -1;
} else if (*n < 0) {
*info = -3;
} else if (*icompq == 1 && *qsiz < *n) {
*info = -4;
} else if (*ldq < max(1,*n)) {
*info = -7;
} else if (*cutpnt < min(1,*n) || *cutpnt > *n) {
*info = -10;
} else if (*ldq2 < max(1,*n)) {
*info = -14;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SLAED8", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
n1 = *cutpnt;
n2 = *n - n1;
n1p1 = n1 + 1;
if (*rho < 0.f) {
sscal_(&n2, &c_b3, &z[n1p1], &c__1);
}
/* Normalize z so that norm(z) = 1 */
t = 1.f / sqrt(2.f);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
indx[j] = j;
/* L10: */
}
sscal_(n, &t, &z[1], &c__1);
*rho = (r__1 = *rho * 2.f, dabs(r__1));
/* Sort the eigenvalues into increasing order */
i__1 = *n;
for (i = *cutpnt + 1; i <= i__1; ++i) {
indxq[i] += *cutpnt;
/* L20: */
}
i__1 = *n;
for (i = 1; i <= i__1; ++i) {
dlamda[i] = d[indxq[i]];
w[i] = z[indxq[i]];
/* L30: */
}
i = 1;
j = *cutpnt + 1;
slamrg_(&n1, &n2, &dlamda[1], &c__1, &c__1, &indx[1]);
i__1 = *n;
for (i = 1; i <= i__1; ++i) {
d[i] = dlamda[indx[i]];
z[i] = w[indx[i]];
/* L40: */
}
/* Calculate the allowable deflation tolerence */
imax = isamax_(n, &z[1], &c__1);
jmax = isamax_(n, &d[1], &c__1);
eps = slamch_("Epsilon");
tol = eps * 8.f * (r__1 = d[jmax], dabs(r__1));
/* If the rank-1 modifier is small enough, no more needs to be done
except to reorganize Q so that its columns correspond with the
elements in D. */
if (*rho * (r__1 = z[imax], dabs(r__1)) <= tol) {
*k = 0;
if (*icompq == 0) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
perm[j] = indxq[indx[j]];
/* L50: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
perm[j] = indxq[indx[j]];
scopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1
+ 1], &c__1);
/* L60: */
}
slacpy_("A", qsiz, n, &q2[q2_dim1 + 1], ldq2, &q[q_dim1 + 1], ldq);
}
return 0;
}
/* If there are multiple eigenvalues then the problem deflates. Here
the number of equal eigenvalues are found. As each equal
eigenvalue is found, an elementary reflector is computed to rotate
the corresponding eigensubspace so that the corresponding
components of Z are zero in this new basis. */
*k = 0;
*givptr = 0;
k2 = *n + 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (*rho * (r__1 = z[j], dabs(r__1)) <= tol) {
/* Deflate due to small z component. */
--k2;
indxp[k2] = j;
if (j == *n) {
goto L110;
}
} else {
jlam = j;
goto L80;
}
/* L70: */
}
L80:
++j;
if (j > *n) {
goto L100;
}
if (*rho * (r__1 = z[j], dabs(r__1)) <= tol) {
/* Deflate due to small z component. */
--k2;
indxp[k2] = j;
} else {
/* Check if eigenvalues are close enough to allow deflation. */
s = z[jlam];
c = z[j];
/* Find sqrt(a**2+b**2) without overflow or
destructive underflow. */
tau = slapy2_(&c, &s);
t = d[j] - d[jlam];
c /= tau;
s = -(doublereal)s / tau;
if ((r__1 = t * c * s, dabs(r__1)) <= tol) {
/* Deflation is possible. */
z[j] = tau;
z[jlam] = 0.f;
/* Record the appropriate Givens rotation */
++(*givptr);
givcol[(*givptr << 1) + 1] = indxq[indx[jlam]];
givcol[(*givptr << 1) + 2] = indxq[indx[j]];
givnum[(*givptr << 1) + 1] = c;
givnum[(*givptr << 1) + 2] = s;
if (*icompq == 1) {
srot_(qsiz, &q[indxq[indx[jlam]] * q_dim1 + 1], &c__1, &q[
indxq[indx[j]] * q_dim1 + 1], &c__1, &c, &s);
}
t = d[jlam] * c * c + d[j] * s * s;
d[j] = d[jlam] * s * s + d[j] * c * c;
d[jlam] = t;
--k2;
i = 1;
L90:
if (k2 + i <= *n) {
if (d[jlam] < d[indxp[k2 + i]]) {
indxp[k2 + i - 1] = indxp[k2 + i];
indxp[k2 + i] = jlam;
++i;
goto L90;
} else {
indxp[k2 + i - 1] = jlam;
}
} else {
indxp[k2 + i - 1] = jlam;
}
jlam = j;
} else {
++(*k);
w[*k] = z[jlam];
dlamda[*k] = d[jlam];
indxp[*k] = jlam;
jlam = j;
}
}
goto L80;
L100:
/* Record the last eigenvalue. */
++(*k);
w[*k] = z[jlam];
dlamda[*k] = d[jlam];
indxp[*k] = jlam;
L110:
/* Sort the eigenvalues and corresponding eigenvectors into DLAMDA
and Q2 respectively. The eigenvalues/vectors which were not
deflated go into the first K slots of DLAMDA and Q2 respectively,
while those which were deflated go into the last N - K slots. */
if (*icompq == 0) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
jp = indxp[j];
dlamda[j] = d[jp];
perm[j] = indxq[indx[jp]];
/* L120: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
jp = indxp[j];
dlamda[j] = d[jp];
perm[j] = indxq[indx[jp]];
scopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1]
, &c__1);
/* L130: */
}
}
/* The deflated eigenvalues and their corresponding vectors go back
into the last N - K slots of D and Q respectively. */
if (*k < *n) {
if (*icompq == 0) {
i__1 = *n - *k;
scopy_(&i__1, &dlamda[*k + 1], &c__1, &d[*k + 1], &c__1);
} else {
i__1 = *n - *k;
scopy_(&i__1, &dlamda[*k + 1], &c__1, &d[*k + 1], &c__1);
i__1 = *n - *k;
slacpy_("A", qsiz, &i__1, &q2[(*k + 1) * q2_dim1 + 1], ldq2, &q[(*
k + 1) * q_dim1 + 1], ldq);
}
}
return 0;
/* End of SLAED8 */
} /* slaed8_ */
int ctgsna_(char *job, char *howmny, int *select,
int *n, complex *a, int *lda, complex *b, int *ldb,
complex *vl, int *ldvl, complex *vr, int *ldvr, float *s, float
*dif, int *mm, int *m, complex *work, int *lwork, int
*iwork, int *info)
{
/* System generated locals */
int a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
vr_offset, i__1;
float r__1, r__2;
complex q__1;
/* Builtin functions */
double c_abs(complex *);
/* Local variables */
int i__, k, n1, n2, ks;
float eps, cond;
int ierr, ifst;
float lnrm;
complex yhax, yhbx;
int ilst;
float rnrm, scale;
extern /* Complex */ VOID cdotc_(complex *, int *, complex *, int
*, complex *, int *);
extern int lsame_(char *, char *);
extern int cgemv_(char *, int *, int *, complex *
, complex *, int *, complex *, int *, complex *, complex *
, int *);
int lwmin;
int wants;
complex dummy[1];
extern double scnrm2_(int *, complex *, int *), slapy2_(float *
, float *);
complex dummy1[1];
extern int slabad_(float *, float *);
extern double slamch_(char *);
extern int clacpy_(char *, int *, int *, complex
*, int *, complex *, int *), ctgexc_(int *,
int *, int *, complex *, int *, complex *, int *,
complex *, int *, complex *, int *, int *, int *,
int *), xerbla_(char *, int *);
float bignum;
int wantbh, wantdf, somcon;
extern int ctgsyl_(char *, int *, int *, int
*, complex *, int *, complex *, int *, complex *, int
*, complex *, int *, complex *, int *, complex *, int
*, float *, float *, complex *, int *, int *, int *);
float smlnum;
int lquery;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CTGSNA estimates reciprocal condition numbers for specified */
/* eigenvalues and/or eigenvectors of a matrix pair (A, B). */
/* (A, B) must be in generalized Schur canonical form, that is, A and */
/* B are both upper triangular. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* Specifies whether condition numbers are required for */
/* eigenvalues (S) or eigenvectors (DIF): */
/* = 'E': for eigenvalues only (S); */
/* = 'V': for eigenvectors only (DIF); */
/* = 'B': for both eigenvalues and eigenvectors (S and DIF). */
/* HOWMNY (input) CHARACTER*1 */
/* = 'A': compute condition numbers for all eigenpairs; */
/* = 'S': compute condition numbers for selected eigenpairs */
/* specified by the array SELECT. */
/* SELECT (input) LOGICAL array, dimension (N) */
/* If HOWMNY = 'S', SELECT specifies the eigenpairs for which */
/* condition numbers are required. To select condition numbers */
/* for the corresponding j-th eigenvalue and/or eigenvector, */
/* SELECT(j) must be set to .TRUE.. */
/* If HOWMNY = 'A', SELECT is not referenced. */
/* N (input) INTEGER */
/* The order of the square matrix pair (A, B). N >= 0. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The upper triangular matrix A in the pair (A,B). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,N). */
/* B (input) COMPLEX array, dimension (LDB,N) */
/* The upper triangular matrix B in the pair (A, B). */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= MAX(1,N). */
/* VL (input) COMPLEX array, dimension (LDVL,M) */
/* IF JOB = 'E' or 'B', VL must contain left eigenvectors of */
/* (A, B), corresponding to the eigenpairs specified by HOWMNY */
/* and SELECT. The eigenvectors must be stored in consecutive */
/* columns of VL, as returned by CTGEVC. */
/* If JOB = 'V', VL is not referenced. */
/* LDVL (input) INTEGER */
/* The leading dimension of the array VL. LDVL >= 1; and */
/* If JOB = 'E' or 'B', LDVL >= N. */
/* VR (input) COMPLEX array, dimension (LDVR,M) */
/* IF JOB = 'E' or 'B', VR must contain right eigenvectors of */
/* (A, B), corresponding to the eigenpairs specified by HOWMNY */
/* and SELECT. The eigenvectors must be stored in consecutive */
/* columns of VR, as returned by CTGEVC. */
/* If JOB = 'V', VR is not referenced. */
/* LDVR (input) INTEGER */
/* The leading dimension of the array VR. LDVR >= 1; */
/* If JOB = 'E' or 'B', LDVR >= N. */
/* S (output) REAL array, dimension (MM) */
/* If JOB = 'E' or 'B', the reciprocal condition numbers of the */
/* selected eigenvalues, stored in consecutive elements of the */
/* array. */
/* If JOB = 'V', S is not referenced. */
/* DIF (output) REAL array, dimension (MM) */
/* If JOB = 'V' or 'B', the estimated reciprocal condition */
/* numbers of the selected eigenvectors, stored in consecutive */
/* elements of the array. */
/* If the eigenvalues cannot be reordered to compute DIF(j), */
/* DIF(j) is set to 0; this can only occur when the true value */
/* would be very small anyway. */
/* For each eigenvalue/vector specified by SELECT, DIF stores */
/* a Frobenius norm-based estimate of Difl. */
/* If JOB = 'E', DIF is not referenced. */
/* MM (input) INTEGER */
/* The number of elements in the arrays S and DIF. MM >= M. */
/* M (output) INTEGER */
/* The number of elements of the arrays S and DIF used to store */
/* the specified condition numbers; for each selected eigenvalue */
/* one element is used. If HOWMNY = 'A', M is set to N. */
/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= MAX(1,N). */
/* If JOB = 'V' or 'B', LWORK >= MAX(1,2*N*N). */
/* IWORK (workspace) INTEGER array, dimension (N+2) */
/* If JOB = 'E', IWORK is not referenced. */
/* INFO (output) INTEGER */
/* = 0: Successful exit */
/* < 0: If INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* The reciprocal of the condition number of the i-th generalized */
/* eigenvalue w = (a, b) is defined as */
/* S(I) = (|v'Au|**2 + |v'Bu|**2)**(1/2) / (norm(u)*norm(v)) */
/* where u and v are the right and left eigenvectors of (A, B) */
/* corresponding to w; |z| denotes the absolute value of the complex */
/* number, and norm(u) denotes the 2-norm of the vector u. The pair */
/* (a, b) corresponds to an eigenvalue w = a/b (= v'Au/v'Bu) of the */
/* matrix pair (A, B). If both a and b equal zero, then (A,B) is */
/* singular and S(I) = -1 is returned. */
/* An approximate error bound on the chordal distance between the i-th */
/* computed generalized eigenvalue w and the corresponding exact */
/* eigenvalue lambda is */
/* chord(w, lambda) <= EPS * norm(A, B) / S(I), */
/* where EPS is the machine precision. */
/* The reciprocal of the condition number of the right eigenvector u */
/* and left eigenvector v corresponding to the generalized eigenvalue w */
/* is defined as follows. Suppose */
/* (A, B) = ( a * ) ( b * ) 1 */
/* ( 0 A22 ),( 0 B22 ) n-1 */
/* 1 n-1 1 n-1 */
/* Then the reciprocal condition number DIF(I) is */
/* Difl[(a, b), (A22, B22)] = sigma-MIN( Zl ) */
/* where sigma-MIN(Zl) denotes the smallest singular value of */
/* Zl = [ kron(a, In-1) -kron(1, A22) ] */
/* [ kron(b, In-1) -kron(1, B22) ]. */
/* Here In-1 is the identity matrix of size n-1 and X' is the conjugate */
/* transpose of X. kron(X, Y) is the Kronecker product between the */
/* matrices X and Y. */
/* We approximate the smallest singular value of Zl with an upper */
/* bound. This is done by CLATDF. */
/* An approximate error bound for a computed eigenvector VL(i) or */
/* VR(i) is given by */
/* EPS * norm(A, B) / DIF(i). */
/* See ref. [2-3] for more details and further references. */
/* Based on contributions by */
/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
/* Umea University, S-901 87 Umea, Sweden. */
/* References */
/* ========== */
/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */
/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */
/* Estimation: Theory, Algorithms and Software, Report */
/* UMINF - 94.04, Department of Computing Science, Umea University, */
/* S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87. */
/* To appear in Numerical Algorithms, 1996. */
/* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */
/* for Solving the Generalized Sylvester Equation and Estimating the */
/* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */
/* Department of Computing Science, Umea University, S-901 87 Umea, */
/* Sweden, December 1993, Revised April 1994, Also as LAPACK Working */
/* Note 75. */
/* To appear in ACM Trans. on Math. Software, Vol 22, No 1, 1996. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and test the input parameters */
/* Parameter adjustments */
--select;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--s;
--dif;
--work;
--iwork;
/* Function Body */
wantbh = lsame_(job, "B");
wants = lsame_(job, "E") || wantbh;
wantdf = lsame_(job, "V") || wantbh;
somcon = lsame_(howmny, "S");
*info = 0;
lquery = *lwork == -1;
if (! wants && ! wantdf) {
*info = -1;
} else if (! lsame_(howmny, "A") && ! somcon) {
*info = -2;
} else if (*n < 0) {
*info = -4;
} else if (*lda < MAX(1,*n)) {
*info = -6;
} else if (*ldb < MAX(1,*n)) {
*info = -8;
} else if (wants && *ldvl < *n) {
*info = -10;
} else if (wants && *ldvr < *n) {
*info = -12;
} else {
/* Set M to the number of eigenpairs for which condition numbers */
/* are required, and test MM. */
if (somcon) {
*m = 0;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (select[k]) {
++(*m);
}
/* L10: */
}
} else {
*m = *n;
}
if (*n == 0) {
lwmin = 1;
} else if (lsame_(job, "V") || lsame_(job,
"B")) {
lwmin = (*n << 1) * *n;
} else {
lwmin = *n;
}
work[1].r = (float) lwmin, work[1].i = 0.f;
if (*mm < *m) {
*info = -15;
} else if (*lwork < lwmin && ! lquery) {
*info = -18;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTGSNA", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = slamch_("P");
smlnum = slamch_("S") / eps;
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
ks = 0;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Determine whether condition numbers are required for the k-th */
/* eigenpair. */
if (somcon) {
if (! select[k]) {
goto L20;
}
}
++ks;
if (wants) {
/* Compute the reciprocal condition number of the k-th */
/* eigenvalue. */
rnrm = scnrm2_(n, &vr[ks * vr_dim1 + 1], &c__1);
lnrm = scnrm2_(n, &vl[ks * vl_dim1 + 1], &c__1);
cgemv_("N", n, n, &c_b19, &a[a_offset], lda, &vr[ks * vr_dim1 + 1]
, &c__1, &c_b20, &work[1], &c__1);
cdotc_(&q__1, n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &c__1);
yhax.r = q__1.r, yhax.i = q__1.i;
cgemv_("N", n, n, &c_b19, &b[b_offset], ldb, &vr[ks * vr_dim1 + 1]
, &c__1, &c_b20, &work[1], &c__1);
cdotc_(&q__1, n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &c__1);
yhbx.r = q__1.r, yhbx.i = q__1.i;
r__1 = c_abs(&yhax);
r__2 = c_abs(&yhbx);
cond = slapy2_(&r__1, &r__2);
if (cond == 0.f) {
s[ks] = -1.f;
} else {
s[ks] = cond / (rnrm * lnrm);
}
}
if (wantdf) {
if (*n == 1) {
r__1 = c_abs(&a[a_dim1 + 1]);
r__2 = c_abs(&b[b_dim1 + 1]);
dif[ks] = slapy2_(&r__1, &r__2);
} else {
/* Estimate the reciprocal condition number of the k-th */
/* eigenvectors. */
/* Copy the matrix (A, B) to the array WORK and move the */
/* (k,k)th pair to the (1,1) position. */
clacpy_("Full", n, n, &a[a_offset], lda, &work[1], n);
clacpy_("Full", n, n, &b[b_offset], ldb, &work[*n * *n + 1],
n);
ifst = k;
ilst = 1;
ctgexc_(&c_false, &c_false, n, &work[1], n, &work[*n * *n + 1]
, n, dummy, &c__1, dummy1, &c__1, &ifst, &ilst, &ierr)
;
if (ierr > 0) {
/* Ill-conditioned problem - swap rejected. */
dif[ks] = 0.f;
} else {
/* Reordering successful, solve generalized Sylvester */
/* equation for R and L, */
/* A22 * R - L * A11 = A12 */
/* B22 * R - L * B11 = B12, */
/* and compute estimate of Difl[(A11,B11), (A22, B22)]. */
n1 = 1;
n2 = *n - n1;
i__ = *n * *n + 1;
ctgsyl_("N", &c__3, &n2, &n1, &work[*n * n1 + n1 + 1], n,
&work[1], n, &work[n1 + 1], n, &work[*n * n1 + n1
+ i__], n, &work[i__], n, &work[n1 + i__], n, &
scale, &dif[ks], dummy, &c__1, &iwork[1], &ierr);
}
}
}
L20:
;
}
work[1].r = (float) lwmin, work[1].i = 0.f;
return 0;
/* End of CTGSNA */
} /* ctgsna_ */
/* ----------------------------------------------------------------------- */
/* Subroutine */ int sneupd_(logical *rvec, char *howmny, logical *select,
real *dr, real *di, real *z__, integer *ldz, real *sigmar, real *
sigmai, real *workev, char *bmat, integer *n, char *which, integer *
nev, real *tol, real *resid, integer *ncv, real *v, integer *ldv,
integer *iparam, integer *ipntr, real *workd, real *workl, integer *
lworkl, integer *info, ftnlen howmny_len, ftnlen bmat_len, ftnlen
which_len)
{
/* System generated locals */
integer v_dim1, v_offset, z_dim1, z_offset, i__1;
real r__1, r__2;
doublereal d__1;
/* Local variables */
static integer j, k, ih, jj, np;
static real vl[1] /* was [1][1] */;
static integer ibd, ldh, ldq, iri;
static real sep;
static integer irr, wri, wrr, mode;
static real eps23;
extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
integer *, real *, integer *, real *, integer *);
static integer ierr;
static real temp;
static integer iwev;
static char type__[6];
static real temp1;
extern doublereal snrm2_(integer *, real *, integer *);
static integer ihbds, iconj;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static real conds;
static logical reord;
extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *,
ftnlen);
static integer nconv, iwork[1];
static real rnorm;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
static integer ritzi;
extern /* Subroutine */ int strmm_(char *, char *, char *, char *,
integer *, integer *, real *, real *, integer *, real *, integer *
, ftnlen, ftnlen, ftnlen, ftnlen), ivout_(integer *, integer *,
integer *, integer *, char *, ftnlen), smout_(integer *, integer *
, integer *, real *, integer *, integer *, char *, ftnlen);
static integer ritzr;
extern /* Subroutine */ int svout_(integer *, integer *, real *, integer *
, char *, ftnlen), sgeqr2_(integer *, integer *, real *, integer *
, real *, real *, integer *);
static integer nconv2;
extern doublereal slapy2_(real *, real *);
extern /* Subroutine */ int sorm2r_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, real *, integer *, real *,
integer *, ftnlen, ftnlen);
static integer iheigi, iheigr, bounds, invsub, iuptri, msglvl, outncv,
ishift, numcnv;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *, ftnlen), slahqr_(logical *, logical
*, integer *, integer *, integer *, real *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *),
slaset_(char *, integer *, integer *, real *, real *, real *,
integer *, ftnlen), strevc_(char *, char *, logical *, integer *,
real *, integer *, real *, integer *, real *, integer *, integer *
, integer *, real *, integer *, ftnlen, ftnlen), strsen_(char *,
char *, logical *, integer *, real *, integer *, real *, integer *
, real *, real *, integer *, real *, real *, real *, integer *,
integer *, integer *, integer *, ftnlen, ftnlen);
extern doublereal slamch_(char *, ftnlen);
extern /* Subroutine */ int sngets_(integer *, char *, integer *, integer
*, real *, real *, real *, real *, real *, ftnlen);
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %---------------% */
/* | Local Scalars | */
/* %---------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %---------------------% */
/* | Intrinsic Functions | */
/* %---------------------% */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
/* %------------------------% */
/* | Set default parameters | */
/* %------------------------% */
/* Parameter adjustments */
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--workd;
--resid;
--di;
--dr;
--workev;
--select;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--iparam;
--ipntr;
--workl;
/* Function Body */
msglvl = debug_1.mneupd;
mode = iparam[7];
nconv = iparam[5];
*info = 0;
/* %---------------------------------% */
/* | Get machine dependent constant. | */
/* %---------------------------------% */
eps23 = slamch_("Epsilon-Machine", (ftnlen)15);
d__1 = (doublereal) eps23;
eps23 = pow_dd(&d__1, &c_b3);
/* %--------------% */
/* | Quick return | */
/* %--------------% */
ierr = 0;
if (nconv <= 0) {
ierr = -14;
} else if (*n <= 0) {
ierr = -1;
} else if (*nev <= 0) {
ierr = -2;
} else if (*ncv <= *nev + 1 || *ncv > *n) {
ierr = -3;
} else if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which,
"SM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "LR", (ftnlen)2,
(ftnlen)2) != 0 && s_cmp(which, "SR", (ftnlen)2, (ftnlen)2) != 0
&& s_cmp(which, "LI", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which,
"SI", (ftnlen)2, (ftnlen)2) != 0) {
ierr = -5;
} else if (*(unsigned char *)bmat != 'I' && *(unsigned char *)bmat != 'G')
{
ierr = -6;
} else /* if(complicated condition) */ {
/* Computing 2nd power */
i__1 = *ncv;
if (*lworkl < i__1 * i__1 * 3 + *ncv * 6) {
ierr = -7;
} else if (*(unsigned char *)howmny != 'A' && *(unsigned char *)
howmny != 'P' && *(unsigned char *)howmny != 'S' && *rvec) {
ierr = -13;
} else if (*(unsigned char *)howmny == 'S') {
ierr = -12;
}
}
if (mode == 1 || mode == 2) {
s_copy(type__, "REGULR", (ftnlen)6, (ftnlen)6);
} else if (mode == 3 && *sigmai == 0.f) {
s_copy(type__, "SHIFTI", (ftnlen)6, (ftnlen)6);
} else if (mode == 3) {
s_copy(type__, "REALPT", (ftnlen)6, (ftnlen)6);
} else if (mode == 4) {
s_copy(type__, "IMAGPT", (ftnlen)6, (ftnlen)6);
} else {
ierr = -10;
}
if (mode == 1 && *(unsigned char *)bmat == 'G') {
ierr = -11;
}
/* %------------% */
/* | Error Exit | */
/* %------------% */
if (ierr != 0) {
*info = ierr;
goto L9000;
}
/* %--------------------------------------------------------% */
/* | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | */
/* | etc... and the remaining workspace. | */
/* | Also update pointer to be used on output. | */
/* | Memory is laid out as follows: | */
/* | workl(1:ncv*ncv) := generated Hessenberg matrix | */
/* | workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary | */
/* | parts of ritz values | */
/* | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds | */
/* %--------------------------------------------------------% */
/* %-----------------------------------------------------------% */
/* | The following is used and set by SNEUPD. | */
/* | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed | */
/* | real part of the Ritz values. | */
/* | workl(ncv*ncv+4*ncv+1:ncv*ncv+5*ncv) := The untransformed | */
/* | imaginary part of the Ritz values. | */
/* | workl(ncv*ncv+5*ncv+1:ncv*ncv+6*ncv) := The untransformed | */
/* | error bounds of the Ritz values | */
/* | workl(ncv*ncv+6*ncv+1:2*ncv*ncv+6*ncv) := Holds the upper | */
/* | quasi-triangular matrix for H | */
/* | workl(2*ncv*ncv+6*ncv+1: 3*ncv*ncv+6*ncv) := Holds the | */
/* | associated matrix representation of the invariant | */
/* | subspace for H. | */
/* | GRAND total of NCV * ( 3 * NCV + 6 ) locations. | */
/* %-----------------------------------------------------------% */
ih = ipntr[5];
ritzr = ipntr[6];
ritzi = ipntr[7];
bounds = ipntr[8];
ldh = *ncv;
ldq = *ncv;
iheigr = bounds + ldh;
iheigi = iheigr + ldh;
ihbds = iheigi + ldh;
iuptri = ihbds + ldh;
invsub = iuptri + ldh * *ncv;
ipntr[9] = iheigr;
ipntr[10] = iheigi;
ipntr[11] = ihbds;
ipntr[12] = iuptri;
ipntr[13] = invsub;
wrr = 1;
wri = *ncv + 1;
iwev = wri + *ncv;
/* %-----------------------------------------% */
/* | irr points to the REAL part of the Ritz | */
/* | values computed by _neigh before | */
/* | exiting _naup2. | */
/* | iri points to the IMAGINARY part of the | */
/* | Ritz values computed by _neigh | */
/* | before exiting _naup2. | */
/* | ibd points to the Ritz estimates | */
/* | computed by _neigh before exiting | */
/* | _naup2. | */
/* %-----------------------------------------% */
irr = ipntr[14] + *ncv * *ncv;
iri = irr + *ncv;
ibd = iri + *ncv;
/* %------------------------------------% */
/* | RNORM is B-norm of the RESID(1:N). | */
/* %------------------------------------% */
rnorm = workl[ih + 2];
workl[ih + 2] = 0.f;
if (msglvl > 2) {
svout_(&debug_1.logfil, ncv, &workl[irr], &debug_1.ndigit, "_neupd: "
"Real part of Ritz values passed in from _NAUPD.", (ftnlen)55);
svout_(&debug_1.logfil, ncv, &workl[iri], &debug_1.ndigit, "_neupd: "
"Imag part of Ritz values passed in from _NAUPD.", (ftnlen)55);
svout_(&debug_1.logfil, ncv, &workl[ibd], &debug_1.ndigit, "_neupd: "
"Ritz estimates passed in from _NAUPD.", (ftnlen)45);
}
if (*rvec) {
reord = FALSE_;
/* %---------------------------------------------------% */
/* | Use the temporary bounds array to store indices | */
/* | These will be used to mark the select array later | */
/* %---------------------------------------------------% */
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
workl[bounds + j - 1] = (real) j;
select[j] = FALSE_;
/* L10: */
}
/* %-------------------------------------% */
/* | Select the wanted Ritz values. | */
/* | Sort the Ritz values so that the | */
/* | wanted ones appear at the tailing | */
/* | NEV positions of workl(irr) and | */
/* | workl(iri). Move the corresponding | */
/* | error estimates in workl(bound) | */
/* | accordingly. | */
/* %-------------------------------------% */
np = *ncv - *nev;
ishift = 0;
sngets_(&ishift, which, nev, &np, &workl[irr], &workl[iri], &workl[
bounds], &workl[1], &workl[np + 1], (ftnlen)2);
if (msglvl > 2) {
svout_(&debug_1.logfil, ncv, &workl[irr], &debug_1.ndigit, "_neu"
"pd: Real part of Ritz values after calling _NGETS.", (
ftnlen)54);
svout_(&debug_1.logfil, ncv, &workl[iri], &debug_1.ndigit, "_neu"
"pd: Imag part of Ritz values after calling _NGETS.", (
ftnlen)54);
svout_(&debug_1.logfil, ncv, &workl[bounds], &debug_1.ndigit,
"_neupd: Ritz value indices after calling _NGETS.", (
ftnlen)48);
}
/* %-----------------------------------------------------% */
/* | Record indices of the converged wanted Ritz values | */
/* | Mark the select array for possible reordering | */
/* %-----------------------------------------------------% */
numcnv = 0;
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__1 = eps23, r__2 = slapy2_(&workl[irr + *ncv - j], &workl[iri +
*ncv - j]);
temp1 = dmax(r__1,r__2);
jj = workl[bounds + *ncv - j];
if (numcnv < nconv && workl[ibd + jj - 1] <= *tol * temp1) {
select[jj] = TRUE_;
++numcnv;
if (jj > nconv) {
reord = TRUE_;
}
}
/* L11: */
}
/* %-----------------------------------------------------------% */
/* | Check the count (numcnv) of converged Ritz values with | */
/* | the number (nconv) reported by dnaupd. If these two | */
/* | are different then there has probably been an error | */
/* | caused by incorrect passing of the dnaupd data. | */
/* %-----------------------------------------------------------% */
if (msglvl > 2) {
ivout_(&debug_1.logfil, &c__1, &numcnv, &debug_1.ndigit, "_neupd"
": Number of specified eigenvalues", (ftnlen)39);
ivout_(&debug_1.logfil, &c__1, &nconv, &debug_1.ndigit, "_neupd:"
" Number of \"converged\" eigenvalues", (ftnlen)41);
}
if (numcnv != nconv) {
*info = -15;
goto L9000;
}
/* %-----------------------------------------------------------% */
/* | Call LAPACK routine slahqr to compute the real Schur form | */
/* | of the upper Hessenberg matrix returned by SNAUPD. | */
/* | Make a copy of the upper Hessenberg matrix. | */
/* | Initialize the Schur vector matrix Q to the identity. | */
/* %-----------------------------------------------------------% */
i__1 = ldh * *ncv;
scopy_(&i__1, &workl[ih], &c__1, &workl[iuptri], &c__1);
slaset_("All", ncv, ncv, &c_b37, &c_b38, &workl[invsub], &ldq, (
ftnlen)3);
slahqr_(&c_true, &c_true, ncv, &c__1, ncv, &workl[iuptri], &ldh, &
workl[iheigr], &workl[iheigi], &c__1, ncv, &workl[invsub], &
ldq, &ierr);
scopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], &c__1);
if (ierr != 0) {
*info = -8;
goto L9000;
}
if (msglvl > 1) {
svout_(&debug_1.logfil, ncv, &workl[iheigr], &debug_1.ndigit,
"_neupd: Real part of the eigenvalues of H", (ftnlen)41);
svout_(&debug_1.logfil, ncv, &workl[iheigi], &debug_1.ndigit,
"_neupd: Imaginary part of the Eigenvalues of H", (ftnlen)
46);
svout_(&debug_1.logfil, ncv, &workl[ihbds], &debug_1.ndigit,
"_neupd: Last row of the Schur vector matrix", (ftnlen)43)
;
if (msglvl > 3) {
smout_(&debug_1.logfil, ncv, ncv, &workl[iuptri], &ldh, &
debug_1.ndigit, "_neupd: The upper quasi-triangular "
"matrix ", (ftnlen)42);
}
}
if (reord) {
/* %-----------------------------------------------------% */
/* | Reorder the computed upper quasi-triangular matrix. | */
/* %-----------------------------------------------------% */
strsen_("None", "V", &select[1], ncv, &workl[iuptri], &ldh, &
workl[invsub], &ldq, &workl[iheigr], &workl[iheigi], &
nconv2, &conds, &sep, &workl[ihbds], ncv, iwork, &c__1, &
ierr, (ftnlen)4, (ftnlen)1);
if (nconv2 < nconv) {
nconv = nconv2;
}
if (ierr == 1) {
*info = 1;
goto L9000;
}
if (msglvl > 2) {
svout_(&debug_1.logfil, ncv, &workl[iheigr], &debug_1.ndigit,
"_neupd: Real part of the eigenvalues of H--reordered"
, (ftnlen)52);
svout_(&debug_1.logfil, ncv, &workl[iheigi], &debug_1.ndigit,
"_neupd: Imag part of the eigenvalues of H--reordered"
, (ftnlen)52);
if (msglvl > 3) {
smout_(&debug_1.logfil, ncv, ncv, &workl[iuptri], &ldq, &
debug_1.ndigit, "_neupd: Quasi-triangular matrix"
" after re-ordering", (ftnlen)49);
}
}
}
/* %---------------------------------------% */
/* | Copy the last row of the Schur vector | */
/* | into workl(ihbds). This will be used | */
/* | to compute the Ritz estimates of | */
/* | converged Ritz values. | */
/* %---------------------------------------% */
scopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], &c__1);
/* %----------------------------------------------------% */
/* | Place the computed eigenvalues of H into DR and DI | */
/* | if a spectral transformation was not used. | */
/* %----------------------------------------------------% */
if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0) {
scopy_(&nconv, &workl[iheigr], &c__1, &dr[1], &c__1);
scopy_(&nconv, &workl[iheigi], &c__1, &di[1], &c__1);
}
/* %----------------------------------------------------------% */
/* | Compute the QR factorization of the matrix representing | */
/* | the wanted invariant subspace located in the first NCONV | */
/* | columns of workl(invsub,ldq). | */
/* %----------------------------------------------------------% */
sgeqr2_(ncv, &nconv, &workl[invsub], &ldq, &workev[1], &workev[*ncv +
1], &ierr);
/* %---------------------------------------------------------% */
/* | * Postmultiply V by Q using sorm2r. | */
/* | * Copy the first NCONV columns of VQ into Z. | */
/* | * Postmultiply Z by R. | */
/* | The N by NCONV matrix Z is now a matrix representation | */
/* | of the approximate invariant subspace associated with | */
/* | the Ritz values in workl(iheigr) and workl(iheigi) | */
/* | The first NCONV columns of V are now approximate Schur | */
/* | vectors associated with the real upper quasi-triangular | */
/* | matrix of order NCONV in workl(iuptri) | */
/* %---------------------------------------------------------% */
sorm2r_("Right", "Notranspose", n, ncv, &nconv, &workl[invsub], &ldq,
&workev[1], &v[v_offset], ldv, &workd[*n + 1], &ierr, (ftnlen)
5, (ftnlen)11);
slacpy_("All", n, &nconv, &v[v_offset], ldv, &z__[z_offset], ldz, (
ftnlen)3);
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
/* %---------------------------------------------------% */
/* | Perform both a column and row scaling if the | */
/* | diagonal element of workl(invsub,ldq) is negative | */
/* | I'm lazy and don't take advantage of the upper | */
/* | quasi-triangular form of workl(iuptri,ldq) | */
/* | Note that since Q is orthogonal, R is a diagonal | */
/* | matrix consisting of plus or minus ones | */
/* %---------------------------------------------------% */
if (workl[invsub + (j - 1) * ldq + j - 1] < 0.f) {
sscal_(&nconv, &c_b64, &workl[iuptri + j - 1], &ldq);
sscal_(&nconv, &c_b64, &workl[iuptri + (j - 1) * ldq], &c__1);
}
/* L20: */
}
if (*(unsigned char *)howmny == 'A') {
/* %--------------------------------------------% */
/* | Compute the NCONV wanted eigenvectors of T | */
/* | located in workl(iuptri,ldq). | */
/* %--------------------------------------------% */
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
if (j <= nconv) {
select[j] = TRUE_;
} else {
select[j] = FALSE_;
}
/* L30: */
}
strevc_("Right", "Select", &select[1], ncv, &workl[iuptri], &ldq,
vl, &c__1, &workl[invsub], &ldq, ncv, &outncv, &workev[1],
&ierr, (ftnlen)5, (ftnlen)6);
if (ierr != 0) {
*info = -9;
goto L9000;
}
/* %------------------------------------------------% */
/* | Scale the returning eigenvectors so that their | */
/* | Euclidean norms are all one. LAPACK subroutine | */
/* | strevc returns each eigenvector normalized so | */
/* | that the element of largest magnitude has | */
/* | magnitude 1; | */
/* %------------------------------------------------% */
iconj = 0;
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
if (workl[iheigi + j - 1] == 0.f) {
/* %----------------------% */
/* | real eigenvalue case | */
/* %----------------------% */
temp = snrm2_(ncv, &workl[invsub + (j - 1) * ldq], &c__1);
r__1 = 1.f / temp;
sscal_(ncv, &r__1, &workl[invsub + (j - 1) * ldq], &c__1);
} else {
/* %-------------------------------------------% */
/* | Complex conjugate pair case. Note that | */
/* | since the real and imaginary part of | */
/* | the eigenvector are stored in consecutive | */
/* | columns, we further normalize by the | */
/* | square root of two. | */
/* %-------------------------------------------% */
if (iconj == 0) {
r__1 = snrm2_(ncv, &workl[invsub + (j - 1) * ldq], &
c__1);
r__2 = snrm2_(ncv, &workl[invsub + j * ldq], &c__1);
temp = slapy2_(&r__1, &r__2);
r__1 = 1.f / temp;
sscal_(ncv, &r__1, &workl[invsub + (j - 1) * ldq], &
c__1);
r__1 = 1.f / temp;
sscal_(ncv, &r__1, &workl[invsub + j * ldq], &c__1);
iconj = 1;
} else {
iconj = 0;
}
}
/* L40: */
}
sgemv_("T", ncv, &nconv, &c_b38, &workl[invsub], &ldq, &workl[
ihbds], &c__1, &c_b37, &workev[1], &c__1, (ftnlen)1);
iconj = 0;
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
if (workl[iheigi + j - 1] != 0.f) {
/* %-------------------------------------------% */
/* | Complex conjugate pair case. Note that | */
/* | since the real and imaginary part of | */
/* | the eigenvector are stored in consecutive | */
/* %-------------------------------------------% */
if (iconj == 0) {
workev[j] = slapy2_(&workev[j], &workev[j + 1]);
workev[j + 1] = workev[j];
iconj = 1;
} else {
iconj = 0;
}
}
/* L45: */
}
if (msglvl > 2) {
scopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], &
c__1);
svout_(&debug_1.logfil, ncv, &workl[ihbds], &debug_1.ndigit,
"_neupd: Last row of the eigenvector matrix for T", (
ftnlen)48);
if (msglvl > 3) {
smout_(&debug_1.logfil, ncv, ncv, &workl[invsub], &ldq, &
debug_1.ndigit, "_neupd: The eigenvector matrix "
"for T", (ftnlen)36);
}
}
/* %---------------------------------------% */
/* | Copy Ritz estimates into workl(ihbds) | */
/* %---------------------------------------% */
scopy_(&nconv, &workev[1], &c__1, &workl[ihbds], &c__1);
/* %---------------------------------------------------------% */
/* | Compute the QR factorization of the eigenvector matrix | */
/* | associated with leading portion of T in the first NCONV | */
/* | columns of workl(invsub,ldq). | */
/* %---------------------------------------------------------% */
sgeqr2_(ncv, &nconv, &workl[invsub], &ldq, &workev[1], &workev[*
ncv + 1], &ierr);
/* %----------------------------------------------% */
/* | * Postmultiply Z by Q. | */
/* | * Postmultiply Z by R. | */
/* | The N by NCONV matrix Z is now contains the | */
/* | Ritz vectors associated with the Ritz values | */
/* | in workl(iheigr) and workl(iheigi). | */
/* %----------------------------------------------% */
sorm2r_("Right", "Notranspose", n, ncv, &nconv, &workl[invsub], &
ldq, &workev[1], &z__[z_offset], ldz, &workd[*n + 1], &
ierr, (ftnlen)5, (ftnlen)11);
strmm_("Right", "Upper", "No transpose", "Non-unit", n, &nconv, &
c_b38, &workl[invsub], &ldq, &z__[z_offset], ldz, (ftnlen)
5, (ftnlen)5, (ftnlen)12, (ftnlen)8);
}
} else {
/* %------------------------------------------------------% */
/* | An approximate invariant subspace is not needed. | */
/* | Place the Ritz values computed SNAUPD into DR and DI | */
/* %------------------------------------------------------% */
scopy_(&nconv, &workl[ritzr], &c__1, &dr[1], &c__1);
scopy_(&nconv, &workl[ritzi], &c__1, &di[1], &c__1);
scopy_(&nconv, &workl[ritzr], &c__1, &workl[iheigr], &c__1);
scopy_(&nconv, &workl[ritzi], &c__1, &workl[iheigi], &c__1);
scopy_(&nconv, &workl[bounds], &c__1, &workl[ihbds], &c__1);
}
/* %------------------------------------------------% */
/* | Transform the Ritz values and possibly vectors | */
/* | and corresponding error bounds of OP to those | */
/* | of A*x = lambda*B*x. | */
/* %------------------------------------------------% */
if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0) {
if (*rvec) {
sscal_(ncv, &rnorm, &workl[ihbds], &c__1);
}
} else {
/* %---------------------------------------% */
/* | A spectral transformation was used. | */
/* | * Determine the Ritz estimates of the | */
/* | Ritz values in the original system. | */
/* %---------------------------------------% */
if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) {
if (*rvec) {
sscal_(ncv, &rnorm, &workl[ihbds], &c__1);
}
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
temp = slapy2_(&workl[iheigr + k - 1], &workl[iheigi + k - 1])
;
workl[ihbds + k - 1] = (r__1 = workl[ihbds + k - 1], dabs(
r__1)) / temp / temp;
/* L50: */
}
} else if (s_cmp(type__, "REALPT", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
/* L60: */
}
} else if (s_cmp(type__, "IMAGPT", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
/* L70: */
}
}
/* %-----------------------------------------------------------% */
/* | * Transform the Ritz values back to the original system. | */
/* | For TYPE = 'SHIFTI' the transformation is | */
/* | lambda = 1/theta + sigma | */
/* | For TYPE = 'REALPT' or 'IMAGPT' the user must from | */
/* | Rayleigh quotients or a projection. See remark 3 above.| */
/* | NOTES: | */
/* | *The Ritz vectors are not affected by the transformation. | */
/* %-----------------------------------------------------------% */
if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
temp = slapy2_(&workl[iheigr + k - 1], &workl[iheigi + k - 1])
;
workl[iheigr + k - 1] = workl[iheigr + k - 1] / temp / temp +
*sigmar;
workl[iheigi + k - 1] = -workl[iheigi + k - 1] / temp / temp
+ *sigmai;
/* L80: */
}
scopy_(&nconv, &workl[iheigr], &c__1, &dr[1], &c__1);
scopy_(&nconv, &workl[iheigi], &c__1, &di[1], &c__1);
} else if (s_cmp(type__, "REALPT", (ftnlen)6, (ftnlen)6) == 0 ||
s_cmp(type__, "IMAGPT", (ftnlen)6, (ftnlen)6) == 0) {
scopy_(&nconv, &workl[iheigr], &c__1, &dr[1], &c__1);
scopy_(&nconv, &workl[iheigi], &c__1, &di[1], &c__1);
}
}
if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0 && msglvl > 1) {
svout_(&debug_1.logfil, &nconv, &dr[1], &debug_1.ndigit, "_neupd: Un"
"transformed real part of the Ritz valuess.", (ftnlen)52);
svout_(&debug_1.logfil, &nconv, &di[1], &debug_1.ndigit, "_neupd: Un"
"transformed imag part of the Ritz valuess.", (ftnlen)52);
svout_(&debug_1.logfil, &nconv, &workl[ihbds], &debug_1.ndigit, "_ne"
"upd: Ritz estimates of untransformed Ritz values.", (ftnlen)
52);
} else if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0 && msglvl >
1) {
svout_(&debug_1.logfil, &nconv, &dr[1], &debug_1.ndigit, "_neupd: Re"
"al parts of converged Ritz values.", (ftnlen)44);
svout_(&debug_1.logfil, &nconv, &di[1], &debug_1.ndigit, "_neupd: Im"
"ag parts of converged Ritz values.", (ftnlen)44);
svout_(&debug_1.logfil, &nconv, &workl[ihbds], &debug_1.ndigit, "_ne"
"upd: Associated Ritz estimates.", (ftnlen)34);
}
/* %-------------------------------------------------% */
/* | Eigenvector Purification step. Formally perform | */
/* | one of inverse subspace iteration. Only used | */
/* | for MODE = 2. | */
/* %-------------------------------------------------% */
if (*rvec && *(unsigned char *)howmny == 'A' && s_cmp(type__, "SHIFTI", (
ftnlen)6, (ftnlen)6) == 0) {
/* %------------------------------------------------% */
/* | Purify the computed Ritz vectors by adding a | */
/* | little bit of the residual vector: | */
/* | T | */
/* | resid(:)*( e s ) / theta | */
/* | NCV | */
/* | where H s = s theta. Remember that when theta | */
/* | has nonzero imaginary part, the corresponding | */
/* | Ritz vector is stored across two columns of Z. | */
/* %------------------------------------------------% */
iconj = 0;
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
if (workl[iheigi + j - 1] == 0.f) {
workev[j] = workl[invsub + (j - 1) * ldq + *ncv - 1] / workl[
iheigr + j - 1];
} else if (iconj == 0) {
temp = slapy2_(&workl[iheigr + j - 1], &workl[iheigi + j - 1])
;
workev[j] = (workl[invsub + (j - 1) * ldq + *ncv - 1] * workl[
iheigr + j - 1] + workl[invsub + j * ldq + *ncv - 1] *
workl[iheigi + j - 1]) / temp / temp;
workev[j + 1] = (workl[invsub + j * ldq + *ncv - 1] * workl[
iheigr + j - 1] - workl[invsub + (j - 1) * ldq + *ncv
- 1] * workl[iheigi + j - 1]) / temp / temp;
iconj = 1;
} else {
iconj = 0;
}
/* L110: */
}
/* %---------------------------------------% */
/* | Perform a rank one update to Z and | */
/* | purify all the Ritz vectors together. | */
/* %---------------------------------------% */
sger_(n, &nconv, &c_b38, &resid[1], &c__1, &workev[1], &c__1, &z__[
z_offset], ldz);
}
L9000:
return 0;
/* %---------------% */
/* | End of SNEUPD | */
/* %---------------% */
} /* sneupd_ */
/* Subroutine */
int slaein_(logical *rightv, logical *noinit, integer *n, real *h__, integer *ldh, real *wr, real *wi, real *vr, real *vi, real *b, integer *ldb, real *work, real *eps3, real *smlnum, real *bignum, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, h_dim1, h_offset, i__1, i__2, i__3, i__4;
real r__1, r__2, r__3, r__4;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j;
real w, x, y;
integer i1, i2, i3;
real w1, ei, ej, xi, xr, rec;
integer its, ierr;
real temp, norm, vmax;
extern real snrm2_(integer *, real *, integer *);
real scale;
extern /* Subroutine */
int sscal_(integer *, real *, real *, integer *);
char trans[1];
real vcrit;
extern real sasum_(integer *, real *, integer *);
real rootn, vnorm;
extern real slapy2_(real *, real *);
real absbii, absbjj;
extern integer isamax_(integer *, real *, integer *);
extern /* Subroutine */
int sladiv_(real *, real *, real *, real *, real * , real *);
char normin[1];
real nrmsml;
extern /* Subroutine */
int slatrs_(char *, char *, char *, char *, integer *, real *, integer *, real *, real *, real *, integer *);
real growto;
/* -- LAPACK auxiliary 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 .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--vr;
--vi;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--work;
/* Function Body */
*info = 0;
/* GROWTO is the threshold used in the acceptance test for an */
/* eigenvector. */
rootn = sqrt((real) (*n));
growto = .1f / rootn;
/* Computing MAX */
r__1 = 1.f;
r__2 = *eps3 * rootn; // , expr subst
nrmsml = max(r__1,r__2) * *smlnum;
/* Form B = H - (WR,WI)*I (except that the subdiagonal elements and */
/* the imaginary parts of the diagonal elements are not stored). */
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = j - 1;
for (i__ = 1;
i__ <= i__2;
++i__)
{
b[i__ + j * b_dim1] = h__[i__ + j * h_dim1];
/* L10: */
}
b[j + j * b_dim1] = h__[j + j * h_dim1] - *wr;
/* L20: */
}
if (*wi == 0.f)
{
/* Real eigenvalue. */
if (*noinit)
{
/* Set initial vector. */
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
vr[i__] = *eps3;
/* L30: */
}
}
else
{
/* Scale supplied initial vector. */
vnorm = snrm2_(n, &vr[1], &c__1);
r__1 = *eps3 * rootn / max(vnorm,nrmsml);
sscal_(n, &r__1, &vr[1], &c__1);
}
if (*rightv)
{
/* LU decomposition with partial pivoting of B, replacing zero */
/* pivots by EPS3. */
i__1 = *n - 1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
ei = h__[i__ + 1 + i__ * h_dim1];
if ((r__1 = b[i__ + i__ * b_dim1], f2c_abs(r__1)) < f2c_abs(ei))
{
/* Interchange rows and eliminate. */
x = b[i__ + i__ * b_dim1] / ei;
b[i__ + i__ * b_dim1] = ei;
i__2 = *n;
for (j = i__ + 1;
j <= i__2;
++j)
{
temp = b[i__ + 1 + j * b_dim1];
b[i__ + 1 + j * b_dim1] = b[i__ + j * b_dim1] - x * temp;
b[i__ + j * b_dim1] = temp;
/* L40: */
}
}
else
{
/* Eliminate without interchange. */
if (b[i__ + i__ * b_dim1] == 0.f)
{
b[i__ + i__ * b_dim1] = *eps3;
}
x = ei / b[i__ + i__ * b_dim1];
if (x != 0.f)
{
i__2 = *n;
for (j = i__ + 1;
j <= i__2;
++j)
{
b[i__ + 1 + j * b_dim1] -= x * b[i__ + j * b_dim1] ;
/* L50: */
}
}
}
/* L60: */
}
if (b[*n + *n * b_dim1] == 0.f)
{
b[*n + *n * b_dim1] = *eps3;
}
*(unsigned char *)trans = 'N';
}
else
{
/* UL decomposition with partial pivoting of B, replacing zero */
/* pivots by EPS3. */
for (j = *n;
j >= 2;
--j)
{
ej = h__[j + (j - 1) * h_dim1];
if ((r__1 = b[j + j * b_dim1], f2c_abs(r__1)) < f2c_abs(ej))
{
/* Interchange columns and eliminate. */
x = b[j + j * b_dim1] / ej;
b[j + j * b_dim1] = ej;
i__1 = j - 1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
temp = b[i__ + (j - 1) * b_dim1];
b[i__ + (j - 1) * b_dim1] = b[i__ + j * b_dim1] - x * temp;
b[i__ + j * b_dim1] = temp;
/* L70: */
}
}
else
{
/* Eliminate without interchange. */
if (b[j + j * b_dim1] == 0.f)
{
b[j + j * b_dim1] = *eps3;
}
x = ej / b[j + j * b_dim1];
if (x != 0.f)
{
i__1 = j - 1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
b[i__ + (j - 1) * b_dim1] -= x * b[i__ + j * b_dim1];
/* L80: */
}
}
}
/* L90: */
}
if (b[b_dim1 + 1] == 0.f)
{
b[b_dim1 + 1] = *eps3;
}
*(unsigned char *)trans = 'T';
}
*(unsigned char *)normin = 'N';
i__1 = *n;
for (its = 1;
its <= i__1;
++its)
{
/* Solve U*x = scale*v for a right eigenvector */
/* or U**T*x = scale*v for a left eigenvector, */
/* overwriting x on v. */
slatrs_("Upper", trans, "Nonunit", normin, n, &b[b_offset], ldb, & vr[1], &scale, &work[1], &ierr);
*(unsigned char *)normin = 'Y';
/* Test for sufficient growth in the norm of v. */
vnorm = sasum_(n, &vr[1], &c__1);
if (vnorm >= growto * scale)
{
goto L120;
}
/* Choose new orthogonal starting vector and try again. */
temp = *eps3 / (rootn + 1.f);
vr[1] = *eps3;
i__2 = *n;
for (i__ = 2;
i__ <= i__2;
++i__)
{
vr[i__] = temp;
/* L100: */
}
vr[*n - its + 1] -= *eps3 * rootn;
/* L110: */
}
/* Failure to find eigenvector in N iterations. */
*info = 1;
L120: /* Normalize eigenvector. */
i__ = isamax_(n, &vr[1], &c__1);
r__2 = 1.f / (r__1 = vr[i__], f2c_abs(r__1));
sscal_(n, &r__2, &vr[1], &c__1);
}
else
{
/* Complex eigenvalue. */
if (*noinit)
{
/* Set initial vector. */
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
vr[i__] = *eps3;
vi[i__] = 0.f;
/* L130: */
}
}
else
{
/* Scale supplied initial vector. */
r__1 = snrm2_(n, &vr[1], &c__1);
r__2 = snrm2_(n, &vi[1], &c__1);
norm = slapy2_(&r__1, &r__2);
rec = *eps3 * rootn / max(norm,nrmsml);
sscal_(n, &rec, &vr[1], &c__1);
sscal_(n, &rec, &vi[1], &c__1);
}
if (*rightv)
{
/* LU decomposition with partial pivoting of B, replacing zero */
/* pivots by EPS3. */
/* The imaginary part of the (i,j)-th element of U is stored in */
/* B(j+1,i). */
b[b_dim1 + 2] = -(*wi);
i__1 = *n;
for (i__ = 2;
i__ <= i__1;
++i__)
{
b[i__ + 1 + b_dim1] = 0.f;
/* L140: */
}
i__1 = *n - 1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
absbii = slapy2_(&b[i__ + i__ * b_dim1], &b[i__ + 1 + i__ * b_dim1]);
ei = h__[i__ + 1 + i__ * h_dim1];
if (absbii < f2c_abs(ei))
{
/* Interchange rows and eliminate. */
xr = b[i__ + i__ * b_dim1] / ei;
xi = b[i__ + 1 + i__ * b_dim1] / ei;
b[i__ + i__ * b_dim1] = ei;
b[i__ + 1 + i__ * b_dim1] = 0.f;
i__2 = *n;
for (j = i__ + 1;
j <= i__2;
++j)
{
temp = b[i__ + 1 + j * b_dim1];
b[i__ + 1 + j * b_dim1] = b[i__ + j * b_dim1] - xr * temp;
b[j + 1 + (i__ + 1) * b_dim1] = b[j + 1 + i__ * b_dim1] - xi * temp;
b[i__ + j * b_dim1] = temp;
b[j + 1 + i__ * b_dim1] = 0.f;
/* L150: */
}
b[i__ + 2 + i__ * b_dim1] = -(*wi);
b[i__ + 1 + (i__ + 1) * b_dim1] -= xi * *wi;
b[i__ + 2 + (i__ + 1) * b_dim1] += xr * *wi;
}
else
{
/* Eliminate without interchanging rows. */
if (absbii == 0.f)
{
b[i__ + i__ * b_dim1] = *eps3;
b[i__ + 1 + i__ * b_dim1] = 0.f;
absbii = *eps3;
}
ei = ei / absbii / absbii;
xr = b[i__ + i__ * b_dim1] * ei;
xi = -b[i__ + 1 + i__ * b_dim1] * ei;
i__2 = *n;
for (j = i__ + 1;
j <= i__2;
++j)
{
b[i__ + 1 + j * b_dim1] = b[i__ + 1 + j * b_dim1] - xr * b[i__ + j * b_dim1] + xi * b[j + 1 + i__ * b_dim1];
b[j + 1 + (i__ + 1) * b_dim1] = -xr * b[j + 1 + i__ * b_dim1] - xi * b[i__ + j * b_dim1];
/* L160: */
}
b[i__ + 2 + (i__ + 1) * b_dim1] -= *wi;
}
/* Compute 1-norm of offdiagonal elements of i-th row. */
i__2 = *n - i__;
i__3 = *n - i__;
work[i__] = sasum_(&i__2, &b[i__ + (i__ + 1) * b_dim1], ldb) + sasum_(&i__3, &b[i__ + 2 + i__ * b_dim1], &c__1);
/* L170: */
}
if (b[*n + *n * b_dim1] == 0.f && b[*n + 1 + *n * b_dim1] == 0.f)
{
b[*n + *n * b_dim1] = *eps3;
}
work[*n] = 0.f;
i1 = *n;
i2 = 1;
i3 = -1;
}
else
{
/* UL decomposition with partial pivoting of conjg(B), */
/* replacing zero pivots by EPS3. */
/* The imaginary part of the (i,j)-th element of U is stored in */
/* B(j+1,i). */
b[*n + 1 + *n * b_dim1] = *wi;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
b[*n + 1 + j * b_dim1] = 0.f;
/* L180: */
}
for (j = *n;
j >= 2;
--j)
{
ej = h__[j + (j - 1) * h_dim1];
absbjj = slapy2_(&b[j + j * b_dim1], &b[j + 1 + j * b_dim1]);
if (absbjj < f2c_abs(ej))
{
/* Interchange columns and eliminate */
xr = b[j + j * b_dim1] / ej;
xi = b[j + 1 + j * b_dim1] / ej;
b[j + j * b_dim1] = ej;
b[j + 1 + j * b_dim1] = 0.f;
i__1 = j - 1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
temp = b[i__ + (j - 1) * b_dim1];
b[i__ + (j - 1) * b_dim1] = b[i__ + j * b_dim1] - xr * temp;
b[j + i__ * b_dim1] = b[j + 1 + i__ * b_dim1] - xi * temp;
b[i__ + j * b_dim1] = temp;
b[j + 1 + i__ * b_dim1] = 0.f;
/* L190: */
}
b[j + 1 + (j - 1) * b_dim1] = *wi;
b[j - 1 + (j - 1) * b_dim1] += xi * *wi;
b[j + (j - 1) * b_dim1] -= xr * *wi;
}
else
{
/* Eliminate without interchange. */
if (absbjj == 0.f)
{
b[j + j * b_dim1] = *eps3;
b[j + 1 + j * b_dim1] = 0.f;
absbjj = *eps3;
}
ej = ej / absbjj / absbjj;
xr = b[j + j * b_dim1] * ej;
xi = -b[j + 1 + j * b_dim1] * ej;
i__1 = j - 1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
b[i__ + (j - 1) * b_dim1] = b[i__ + (j - 1) * b_dim1] - xr * b[i__ + j * b_dim1] + xi * b[j + 1 + i__ * b_dim1];
b[j + i__ * b_dim1] = -xr * b[j + 1 + i__ * b_dim1] - xi * b[i__ + j * b_dim1];
/* L200: */
}
b[j + (j - 1) * b_dim1] += *wi;
}
/* Compute 1-norm of offdiagonal elements of j-th column. */
i__1 = j - 1;
i__2 = j - 1;
work[j] = sasum_(&i__1, &b[j * b_dim1 + 1], &c__1) + sasum_(& i__2, &b[j + 1 + b_dim1], ldb);
/* L210: */
}
if (b[b_dim1 + 1] == 0.f && b[b_dim1 + 2] == 0.f)
{
b[b_dim1 + 1] = *eps3;
}
work[1] = 0.f;
i1 = 1;
i2 = *n;
i3 = 1;
}
i__1 = *n;
for (its = 1;
its <= i__1;
++its)
{
scale = 1.f;
vmax = 1.f;
vcrit = *bignum;
/* Solve U*(xr,xi) = scale*(vr,vi) for a right eigenvector, */
/* or U**T*(xr,xi) = scale*(vr,vi) for a left eigenvector, */
/* overwriting (xr,xi) on (vr,vi). */
i__2 = i2;
i__3 = i3;
for (i__ = i1;
i__3 < 0 ? i__ >= i__2 : i__ <= i__2;
i__ += i__3)
{
if (work[i__] > vcrit)
{
rec = 1.f / vmax;
sscal_(n, &rec, &vr[1], &c__1);
sscal_(n, &rec, &vi[1], &c__1);
scale *= rec;
vmax = 1.f;
vcrit = *bignum;
}
xr = vr[i__];
xi = vi[i__];
if (*rightv)
{
i__4 = *n;
for (j = i__ + 1;
j <= i__4;
++j)
{
xr = xr - b[i__ + j * b_dim1] * vr[j] + b[j + 1 + i__ * b_dim1] * vi[j];
xi = xi - b[i__ + j * b_dim1] * vi[j] - b[j + 1 + i__ * b_dim1] * vr[j];
/* L220: */
}
}
else
{
i__4 = i__ - 1;
for (j = 1;
j <= i__4;
++j)
{
xr = xr - b[j + i__ * b_dim1] * vr[j] + b[i__ + 1 + j * b_dim1] * vi[j];
xi = xi - b[j + i__ * b_dim1] * vi[j] - b[i__ + 1 + j * b_dim1] * vr[j];
/* L230: */
}
}
w = (r__1 = b[i__ + i__ * b_dim1], f2c_abs(r__1)) + (r__2 = b[i__ + 1 + i__ * b_dim1], f2c_abs(r__2));
if (w > *smlnum)
{
if (w < 1.f)
{
w1 = f2c_abs(xr) + f2c_abs(xi);
if (w1 > w * *bignum)
{
rec = 1.f / w1;
sscal_(n, &rec, &vr[1], &c__1);
sscal_(n, &rec, &vi[1], &c__1);
xr = vr[i__];
xi = vi[i__];
scale *= rec;
vmax *= rec;
}
}
/* Divide by diagonal element of B. */
sladiv_(&xr, &xi, &b[i__ + i__ * b_dim1], &b[i__ + 1 + i__ * b_dim1], &vr[i__], &vi[i__]);
/* Computing MAX */
r__3 = (r__1 = vr[i__], f2c_abs(r__1)) + (r__2 = vi[i__], f2c_abs( r__2));
vmax = max(r__3,vmax);
vcrit = *bignum / vmax;
}
else
{
i__4 = *n;
for (j = 1;
j <= i__4;
++j)
{
vr[j] = 0.f;
vi[j] = 0.f;
/* L240: */
}
vr[i__] = 1.f;
vi[i__] = 1.f;
scale = 0.f;
vmax = 1.f;
vcrit = *bignum;
}
/* L250: */
}
/* Test for sufficient growth in the norm of (VR,VI). */
vnorm = sasum_(n, &vr[1], &c__1) + sasum_(n, &vi[1], &c__1);
if (vnorm >= growto * scale)
{
goto L280;
}
/* Choose a new orthogonal starting vector and try again. */
y = *eps3 / (rootn + 1.f);
vr[1] = *eps3;
vi[1] = 0.f;
i__3 = *n;
for (i__ = 2;
i__ <= i__3;
++i__)
{
vr[i__] = y;
vi[i__] = 0.f;
/* L260: */
}
vr[*n - its + 1] -= *eps3 * rootn;
/* L270: */
}
/* Failure to find eigenvector in N iterations */
*info = 1;
L280: /* Normalize eigenvector. */
vnorm = 0.f;
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
/* Computing MAX */
r__3 = vnorm;
r__4 = (r__1 = vr[i__], f2c_abs(r__1)) + (r__2 = vi[i__] , f2c_abs(r__2)); // , expr subst
vnorm = max(r__3,r__4);
/* L290: */
}
r__1 = 1.f / vnorm;
sscal_(n, &r__1, &vr[1], &c__1);
r__1 = 1.f / vnorm;
sscal_(n, &r__1, &vi[1], &c__1);
}
return 0;
/* End of SLAEIN */
}
/* Subroutine */
int clarfgp_(integer *n, complex *alpha, complex *x, integer *incx, complex *tau)
{
/* System generated locals */
integer i__1, i__2;
real r__1, r__2;
complex q__1, q__2;
/* Builtin functions */
double r_imag(complex *), r_sign(real *, real *), c_abs(complex *);
/* Local variables */
integer j;
complex savealpha;
integer knt;
real beta;
extern /* Subroutine */
int cscal_(integer *, complex *, complex *, integer *);
real alphi, alphr, xnorm;
extern real scnrm2_(integer *, complex *, integer *), slapy2_(real *, real *), slapy3_(real *, real *, real *);
extern /* Complex */
VOID cladiv_(complex *, complex *, complex *);
extern real slamch_(char *);
extern /* Subroutine */
int csscal_(integer *, real *, complex *, integer *);
real bignum, smlnum;
/* -- LAPACK auxiliary 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 .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--x;
/* Function Body */
if (*n <= 0)
{
tau->r = 0.f, tau->i = 0.f;
return 0;
}
i__1 = *n - 1;
xnorm = scnrm2_(&i__1, &x[1], incx);
alphr = alpha->r;
alphi = r_imag(alpha);
if (xnorm == 0.f)
{
/* H = [1-alpha/f2c_abs(alpha) 0;
0 I], sign chosen so ALPHA >= 0. */
if (alphi == 0.f)
{
if (alphr >= 0.f)
{
/* When TAU.eq.ZERO, the vector is special-cased to be */
/* all zeros in the application routines. We do not need */
/* to clear it. */
tau->r = 0.f, tau->i = 0.f;
}
else
{
/* However, the application routines rely on explicit */
/* zero checks when TAU.ne.ZERO, and we must clear X. */
tau->r = 2.f, tau->i = 0.f;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.f;
x[i__2].i = 0.f; // , expr subst
}
q__1.r = -alpha->r;
q__1.i = -alpha->i; // , expr subst
alpha->r = q__1.r, alpha->i = q__1.i;
}
}
else
{
/* Only "reflecting" the diagonal entry to be real and non-negative. */
xnorm = slapy2_(&alphr, &alphi);
r__1 = 1.f - alphr / xnorm;
r__2 = -alphi / xnorm;
q__1.r = r__1;
q__1.i = r__2; // , expr subst
tau->r = q__1.r, tau->i = q__1.i;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.f;
x[i__2].i = 0.f; // , expr subst
}
alpha->r = xnorm, alpha->i = 0.f;
}
}
else
{
/* general case */
r__1 = slapy3_(&alphr, &alphi, &xnorm);
beta = r_sign(&r__1, &alphr);
smlnum = slamch_("S") / slamch_("E");
bignum = 1.f / smlnum;
knt = 0;
if (f2c_abs(beta) < smlnum)
{
/* XNORM, BETA may be inaccurate;
scale X and recompute them */
L10:
++knt;
i__1 = *n - 1;
csscal_(&i__1, &bignum, &x[1], incx);
beta *= bignum;
alphi *= bignum;
alphr *= bignum;
if (f2c_abs(beta) < smlnum)
{
goto L10;
}
/* New BETA is at most 1, at least SMLNUM */
i__1 = *n - 1;
xnorm = scnrm2_(&i__1, &x[1], incx);
q__1.r = alphr;
q__1.i = alphi; // , expr subst
alpha->r = q__1.r, alpha->i = q__1.i;
r__1 = slapy3_(&alphr, &alphi, &xnorm);
beta = r_sign(&r__1, &alphr);
}
savealpha.r = alpha->r;
savealpha.i = alpha->i; // , expr subst
q__1.r = alpha->r + beta;
q__1.i = alpha->i; // , expr subst
alpha->r = q__1.r, alpha->i = q__1.i;
if (beta < 0.f)
{
beta = -beta;
q__2.r = -alpha->r;
q__2.i = -alpha->i; // , expr subst
q__1.r = q__2.r / beta;
q__1.i = q__2.i / beta; // , expr subst
tau->r = q__1.r, tau->i = q__1.i;
}
else
{
alphr = alphi * (alphi / alpha->r);
alphr += xnorm * (xnorm / alpha->r);
r__1 = alphr / beta;
r__2 = -alphi / beta;
q__1.r = r__1;
q__1.i = r__2; // , expr subst
tau->r = q__1.r, tau->i = q__1.i;
r__1 = -alphr;
q__1.r = r__1;
q__1.i = alphi; // , expr subst
alpha->r = q__1.r, alpha->i = q__1.i;
}
cladiv_(&q__1, &c_b5, alpha);
alpha->r = q__1.r, alpha->i = q__1.i;
if (c_abs(tau) <= smlnum)
{
/* In the case where the computed TAU ends up being a denormalized number, */
/* it loses relative accuracy. This is a BIG problem. Solution: flush TAU */
/* to ZERO (or TWO or whatever makes a nonnegative real number for BETA). */
/* (Bug report provided by Pat Quillen from MathWorks on Jul 29, 2009.) */
/* (Thanks Pat. Thanks MathWorks.) */
alphr = savealpha.r;
alphi = r_imag(&savealpha);
if (alphi == 0.f)
{
if (alphr >= 0.f)
{
tau->r = 0.f, tau->i = 0.f;
}
else
{
tau->r = 2.f, tau->i = 0.f;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.f;
x[i__2].i = 0.f; // , expr subst
}
q__1.r = -savealpha.r;
q__1.i = -savealpha.i; // , expr subst
beta = q__1.r;
}
}
else
{
xnorm = slapy2_(&alphr, &alphi);
r__1 = 1.f - alphr / xnorm;
r__2 = -alphi / xnorm;
q__1.r = r__1;
q__1.i = r__2; // , expr subst
tau->r = q__1.r, tau->i = q__1.i;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.f;
x[i__2].i = 0.f; // , expr subst
}
beta = xnorm;
}
}
else
{
/* This is the general case. */
i__1 = *n - 1;
cscal_(&i__1, alpha, &x[1], incx);
}
/* If BETA is subnormal, it may lose relative accuracy */
i__1 = knt;
for (j = 1;
j <= i__1;
++j)
{
beta *= smlnum;
/* L20: */
}
alpha->r = beta, alpha->i = 0.f;
}
return 0;
/* End of CLARFGP */
}
/* Subroutine */ int slarfp_(integer *n, real *alpha, real *x, integer *incx,
real *tau)
{
/* System generated locals */
integer i__1;
real r__1;
/* Local variables */
integer j, knt;
real beta;
real xnorm;
real safmin, rsafmn;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* SLARFP generates a real elementary reflector H of order n, such */
/* that */
/* H * ( alpha ) = ( beta ), H' * H = I. */
/* ( x ) ( 0 ) */
/* where alpha and beta are scalars, beta is non-negative, and x is */
/* an (n-1)-element real vector. H is represented in the form */
/* H = I - tau * ( 1 ) * ( 1 v' ) , */
/* ( v ) */
/* where tau is a real scalar and v is a real (n-1)-element */
/* vector. */
/* If the elements of x are all zero, then tau = 0 and H is taken to be */
/* the unit matrix. */
/* Otherwise 1 <= tau <= 2. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the elementary reflector. */
/* ALPHA (input/output) REAL */
/* On entry, the value alpha. */
/* On exit, it is overwritten with the value beta. */
/* X (input/output) REAL array, dimension */
/* (1+(N-2)*abs(INCX)) */
/* On entry, the vector x. */
/* On exit, it is overwritten with the vector v. */
/* INCX (input) INTEGER */
/* The increment between elements of X. INCX > 0. */
/* TAU (output) REAL */
/* The value tau. */
/* ===================================================================== */
/* Parameter adjustments */
--x;
/* Function Body */
if (*n <= 0) {
*tau = 0.f;
return 0;
}
i__1 = *n - 1;
xnorm = snrm2_(&i__1, &x[1], incx);
if (xnorm == 0.f) {
/* H = [+/-1, 0; I], sign chosen so ALPHA >= 0. */
if (*alpha >= 0.f) {
/* When TAU.eq.ZERO, the vector is special-cased to be */
/* all zeros in the application routines. We do not need */
/* to clear it. */
*tau = 0.f;
} else {
/* However, the application routines rely on explicit */
/* zero checks when TAU.ne.ZERO, and we must clear X. */
*tau = 2.f;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
x[(j - 1) * *incx + 1] = 0.f;
}
*alpha = -(*alpha);
}
} else {
/* general case */
r__1 = slapy2_(alpha, &xnorm);
beta = r_sign(&r__1, alpha);
safmin = slamch_("S") / slamch_("E");
knt = 0;
if (dabs(beta) < safmin) {
/* XNORM, BETA may be inaccurate; scale X and recompute them */
rsafmn = 1.f / safmin;
L10:
++knt;
i__1 = *n - 1;
sscal_(&i__1, &rsafmn, &x[1], incx);
beta *= rsafmn;
*alpha *= rsafmn;
if (dabs(beta) < safmin) {
goto L10;
}
/* New BETA is at most 1, at least SAFMIN */
i__1 = *n - 1;
xnorm = snrm2_(&i__1, &x[1], incx);
r__1 = slapy2_(alpha, &xnorm);
beta = r_sign(&r__1, alpha);
}
*alpha += beta;
if (beta < 0.f) {
beta = -beta;
*tau = -(*alpha) / beta;
} else {
*alpha = xnorm * (xnorm / *alpha);
*tau = *alpha / beta;
*alpha = -(*alpha);
}
i__1 = *n - 1;
r__1 = 1.f / *alpha;
sscal_(&i__1, &r__1, &x[1], incx);
/* If BETA is subnormal, it may lose relative accuracy */
i__1 = knt;
for (j = 1; j <= i__1; ++j) {
beta *= safmin;
}
*alpha = beta;
}
return 0;
/* End of SLARFP */
} /* slarfp_ */
/* Subroutine */ int ssteqr_(char *compz, integer *n, real *d__, real *e,
real *z__, integer *ldz, real *work, integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
real r__1, r__2;
/* Local variables */
real b, c__, f, g;
integer i__, j, k, l, m;
real p, r__, s;
integer l1, ii, mm, lm1, mm1, nm1;
real rt1, rt2, eps;
integer lsv;
real tst, eps2;
integer lend, jtot;
real anorm;
integer lendm1, lendp1;
integer iscale;
real safmin;
real safmax;
integer lendsv;
real ssfmin;
integer nmaxit, icompz;
real ssfmax;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* SSTEQR computes all eigenvalues and, optionally, eigenvectors of a */
/* symmetric tridiagonal matrix using the implicit QL or QR method. */
/* The eigenvectors of a full or band symmetric matrix can also be found */
/* if SSYTRD or SSPTRD or SSBTRD has been used to reduce this matrix to */
/* tridiagonal form. */
/* Arguments */
/* ========= */
/* COMPZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only. */
/* = 'V': Compute eigenvalues and eigenvectors of the original */
/* symmetric matrix. On entry, Z must contain the */
/* orthogonal matrix used to reduce the original matrix */
/* to tridiagonal form. */
/* = 'I': Compute eigenvalues and eigenvectors of the */
/* tridiagonal matrix. Z is initialized to the identity */
/* matrix. */
/* N (input) INTEGER */
/* The order of the matrix. N >= 0. */
/* D (input/output) REAL array, dimension (N) */
/* On entry, the diagonal elements of the tridiagonal matrix. */
/* On exit, if INFO = 0, the eigenvalues in ascending order. */
/* E (input/output) REAL array, dimension (N-1) */
/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
/* matrix. */
/* On exit, E has been destroyed. */
/* Z (input/output) REAL array, dimension (LDZ, N) */
/* On entry, if COMPZ = 'V', then Z contains the orthogonal */
/* matrix used in the reduction to tridiagonal form. */
/* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the */
/* orthonormal eigenvectors of the original symmetric matrix, */
/* and if COMPZ = 'I', Z contains the orthonormal eigenvectors */
/* of the symmetric tridiagonal matrix. */
/* If COMPZ = 'N', then Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* eigenvectors are desired, then LDZ >= max(1,N). */
/* WORK (workspace) REAL array, dimension (max(1,2*N-2)) */
/* If COMPZ = 'N', then WORK is not referenced. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: the algorithm has failed to find all the eigenvalues in */
/* a total of 30*N iterations; if INFO = i, then i */
/* elements of E have not converged to zero; on exit, D */
/* and E contain the elements of a symmetric tridiagonal */
/* matrix which is orthogonally similar to the original */
/* matrix. */
/* ===================================================================== */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
/* Function Body */
*info = 0;
if (lsame_(compz, "N")) {
icompz = 0;
} else if (lsame_(compz, "V")) {
icompz = 1;
} else if (lsame_(compz, "I")) {
icompz = 2;
} else {
icompz = -1;
}
if (icompz < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SSTEQR", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (icompz == 2) {
z__[z_dim1 + 1] = 1.f;
}
return 0;
}
/* Determine the unit roundoff and over/underflow thresholds. */
eps = slamch_("E");
/* Computing 2nd power */
r__1 = eps;
eps2 = r__1 * r__1;
safmin = slamch_("S");
safmax = 1.f / safmin;
ssfmax = sqrt(safmax) / 3.f;
ssfmin = sqrt(safmin) / eps2;
/* Compute the eigenvalues and eigenvectors of the tridiagonal */
/* matrix. */
if (icompz == 2) {
slaset_("Full", n, n, &c_b9, &c_b10, &z__[z_offset], ldz);
}
nmaxit = *n * 30;
jtot = 0;
/* Determine where the matrix splits and choose QL or QR iteration */
/* for each block, according to whether top or bottom diagonal */
/* element is smaller. */
l1 = 1;
nm1 = *n - 1;
L10:
if (l1 > *n) {
goto L160;
}
if (l1 > 1) {
e[l1 - 1] = 0.f;
}
if (l1 <= nm1) {
i__1 = nm1;
for (m = l1; m <= i__1; ++m) {
tst = (r__1 = e[m], dabs(r__1));
if (tst == 0.f) {
goto L30;
}
if (tst <= sqrt((r__1 = d__[m], dabs(r__1))) * sqrt((r__2 = d__[m
+ 1], dabs(r__2))) * eps) {
e[m] = 0.f;
goto L30;
}
}
}
m = *n;
L30:
l = l1;
lsv = l;
lend = m;
lendsv = lend;
l1 = m + 1;
if (lend == l) {
goto L10;
}
/* Scale submatrix in rows and columns L to LEND */
i__1 = lend - l + 1;
anorm = slanst_("I", &i__1, &d__[l], &e[l]);
iscale = 0;
if (anorm == 0.f) {
goto L10;
}
if (anorm > ssfmax) {
iscale = 1;
i__1 = lend - l + 1;
slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n,
info);
i__1 = lend - l;
slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n,
info);
} else if (anorm < ssfmin) {
iscale = 2;
i__1 = lend - l + 1;
slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n,
info);
i__1 = lend - l;
slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n,
info);
}
/* Choose between QL and QR iteration */
if ((r__1 = d__[lend], dabs(r__1)) < (r__2 = d__[l], dabs(r__2))) {
lend = lsv;
l = lendsv;
}
if (lend > l) {
/* QL Iteration */
/* Look for small subdiagonal element. */
L40:
if (l != lend) {
lendm1 = lend - 1;
i__1 = lendm1;
for (m = l; m <= i__1; ++m) {
/* Computing 2nd power */
r__2 = (r__1 = e[m], dabs(r__1));
tst = r__2 * r__2;
if (tst <= eps2 * (r__1 = d__[m], dabs(r__1)) * (r__2 = d__[m
+ 1], dabs(r__2)) + safmin) {
goto L60;
}
}
}
m = lend;
L60:
if (m < lend) {
e[m] = 0.f;
}
p = d__[l];
if (m == l) {
goto L80;
}
/* If remaining matrix is 2-by-2, use SLAE2 or SLAEV2 */
/* to compute its eigensystem. */
if (m == l + 1) {
if (icompz > 0) {
slaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s);
work[l] = c__;
work[*n - 1 + l] = s;
slasr_("R", "V", "B", n, &c__2, &work[l], &work[*n - 1 + l], &
z__[l * z_dim1 + 1], ldz);
} else {
slae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2);
}
d__[l] = rt1;
d__[l + 1] = rt2;
e[l] = 0.f;
l += 2;
if (l <= lend) {
goto L40;
}
goto L140;
}
if (jtot == nmaxit) {
goto L140;
}
++jtot;
/* Form shift. */
g = (d__[l + 1] - p) / (e[l] * 2.f);
r__ = slapy2_(&g, &c_b10);
g = d__[m] - p + e[l] / (g + r_sign(&r__, &g));
s = 1.f;
c__ = 1.f;
p = 0.f;
/* Inner loop */
mm1 = m - 1;
i__1 = l;
for (i__ = mm1; i__ >= i__1; --i__) {
f = s * e[i__];
b = c__ * e[i__];
slartg_(&g, &f, &c__, &s, &r__);
if (i__ != m - 1) {
e[i__ + 1] = r__;
}
g = d__[i__ + 1] - p;
r__ = (d__[i__] - g) * s + c__ * 2.f * b;
p = s * r__;
d__[i__ + 1] = g + p;
g = c__ * r__ - b;
/* If eigenvectors are desired, then save rotations. */
if (icompz > 0) {
work[i__] = c__;
work[*n - 1 + i__] = -s;
}
}
/* If eigenvectors are desired, then apply saved rotations. */
if (icompz > 0) {
mm = m - l + 1;
slasr_("R", "V", "B", n, &mm, &work[l], &work[*n - 1 + l], &z__[l
* z_dim1 + 1], ldz);
}
d__[l] -= p;
e[l] = g;
goto L40;
/* Eigenvalue found. */
L80:
d__[l] = p;
++l;
if (l <= lend) {
goto L40;
}
goto L140;
} else {
/* QR Iteration */
/* Look for small superdiagonal element. */
L90:
if (l != lend) {
lendp1 = lend + 1;
i__1 = lendp1;
for (m = l; m >= i__1; --m) {
/* Computing 2nd power */
r__2 = (r__1 = e[m - 1], dabs(r__1));
tst = r__2 * r__2;
if (tst <= eps2 * (r__1 = d__[m], dabs(r__1)) * (r__2 = d__[m
- 1], dabs(r__2)) + safmin) {
goto L110;
}
}
}
m = lend;
L110:
if (m > lend) {
e[m - 1] = 0.f;
}
p = d__[l];
if (m == l) {
goto L130;
}
/* If remaining matrix is 2-by-2, use SLAE2 or SLAEV2 */
/* to compute its eigensystem. */
if (m == l - 1) {
if (icompz > 0) {
slaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s)
;
work[m] = c__;
work[*n - 1 + m] = s;
slasr_("R", "V", "F", n, &c__2, &work[m], &work[*n - 1 + m], &
z__[(l - 1) * z_dim1 + 1], ldz);
} else {
slae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2);
}
d__[l - 1] = rt1;
d__[l] = rt2;
e[l - 1] = 0.f;
l += -2;
if (l >= lend) {
goto L90;
}
goto L140;
}
if (jtot == nmaxit) {
goto L140;
}
++jtot;
/* Form shift. */
g = (d__[l - 1] - p) / (e[l - 1] * 2.f);
r__ = slapy2_(&g, &c_b10);
g = d__[m] - p + e[l - 1] / (g + r_sign(&r__, &g));
s = 1.f;
c__ = 1.f;
p = 0.f;
/* Inner loop */
lm1 = l - 1;
i__1 = lm1;
for (i__ = m; i__ <= i__1; ++i__) {
f = s * e[i__];
b = c__ * e[i__];
slartg_(&g, &f, &c__, &s, &r__);
if (i__ != m) {
e[i__ - 1] = r__;
}
g = d__[i__] - p;
r__ = (d__[i__ + 1] - g) * s + c__ * 2.f * b;
p = s * r__;
d__[i__] = g + p;
g = c__ * r__ - b;
/* If eigenvectors are desired, then save rotations. */
if (icompz > 0) {
work[i__] = c__;
work[*n - 1 + i__] = s;
}
}
/* If eigenvectors are desired, then apply saved rotations. */
if (icompz > 0) {
mm = l - m + 1;
slasr_("R", "V", "F", n, &mm, &work[m], &work[*n - 1 + m], &z__[m
* z_dim1 + 1], ldz);
}
d__[l] -= p;
e[lm1] = g;
goto L90;
/* Eigenvalue found. */
L130:
d__[l] = p;
--l;
if (l >= lend) {
goto L90;
}
goto L140;
}
/* Undo scaling if necessary */
L140:
if (iscale == 1) {
i__1 = lendsv - lsv + 1;
slascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv],
n, info);
i__1 = lendsv - lsv;
slascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n,
info);
} else if (iscale == 2) {
i__1 = lendsv - lsv + 1;
slascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv],
n, info);
i__1 = lendsv - lsv;
slascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n,
info);
}
/* Check for no convergence to an eigenvalue after a total */
/* of N*MAXIT iterations. */
if (jtot < nmaxit) {
goto L10;
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (e[i__] != 0.f) {
++(*info);
}
}
goto L190;
/* Order eigenvalues and eigenvectors. */
L160:
if (icompz == 0) {
/* Use Quick Sort */
slasrt_("I", n, &d__[1], info);
} else {
/* Use Selection Sort to minimize swaps of eigenvectors */
i__1 = *n;
for (ii = 2; ii <= i__1; ++ii) {
i__ = ii - 1;
k = i__;
p = d__[i__];
i__2 = *n;
for (j = ii; j <= i__2; ++j) {
if (d__[j] < p) {
k = j;
p = d__[j];
}
}
if (k != i__) {
d__[k] = d__[i__];
d__[i__] = p;
sswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1],
&c__1);
}
}
}
L190:
return 0;
/* End of SSTEQR */
} /* ssteqr_ */
/* Subroutine */ int slanv2_(real *a, real *b, real *c__, real *d__, real *
rt1r, real *rt1i, real *rt2r, real *rt2i, real *cs, real *sn)
{
/* -- LAPACK driver routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
SLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric
matrix in standard form:
[ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ]
[ C D ] [ SN CS ] [ CC DD ] [-SN CS ]
where either
1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or
2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex
conjugate eigenvalues.
Arguments
=========
A (input/output) REAL
B (input/output) REAL
C (input/output) REAL
D (input/output) REAL
On entry, the elements of the input matrix.
On exit, they are overwritten by the elements of the
standardised Schur form.
RT1R (output) REAL
RT1I (output) REAL
RT2R (output) REAL
RT2I (output) REAL
The real and imaginary parts of the eigenvalues. If the
eigenvalues are a complex conjugate pair, RT1I > 0.
CS (output) REAL
SN (output) REAL
Parameters of the rotation matrix.
Further Details
===============
Modified by V. Sima, Research Institute for Informatics, Bucharest,
Romania, to reduce the risk of cancellation errors,
when computing real eigenvalues, and to ensure, if possible, that
abs(RT1R) >= abs(RT2R).
===================================================================== */
/* Table of constant values */
static real c_b4 = 1.f;
/* System generated locals */
real r__1, r__2;
/* Builtin functions */
double r_sign(real *, real *), sqrt(doublereal);
/* Local variables */
static real temp, p, scale, bcmax, z__, bcmis, sigma, aa, bb, cc, dd;
extern doublereal slapy2_(real *, real *), slamch_(char *);
static real cs1, sn1, sab, sac, eps, tau;
eps = slamch_("P");
if (*c__ == 0.f) {
*cs = 1.f;
*sn = 0.f;
goto L10;
} else if (*b == 0.f) {
/* Swap rows and columns */
*cs = 0.f;
*sn = 1.f;
temp = *d__;
*d__ = *a;
*a = temp;
*b = -(*c__);
*c__ = 0.f;
goto L10;
} else if (*a - *d__ == 0.f && r_sign(&c_b4, b) != r_sign(&c_b4, c__)) {
*cs = 1.f;
*sn = 0.f;
goto L10;
} else {
temp = *a - *d__;
p = temp * .5f;
/* Computing MAX */
r__1 = dabs(*b), r__2 = dabs(*c__);
bcmax = dmax(r__1,r__2);
/* Computing MIN */
r__1 = dabs(*b), r__2 = dabs(*c__);
bcmis = dmin(r__1,r__2) * r_sign(&c_b4, b) * r_sign(&c_b4, c__);
/* Computing MAX */
r__1 = dabs(p);
scale = dmax(r__1,bcmax);
z__ = p / scale * p + bcmax / scale * bcmis;
/* If Z is of the order of the machine accuracy, postpone the
decision on the nature of eigenvalues */
if (z__ >= eps * 4.f) {
/* Real eigenvalues. Compute A and D. */
r__1 = sqrt(scale) * sqrt(z__);
z__ = p + r_sign(&r__1, &p);
*a = *d__ + z__;
*d__ -= bcmax / z__ * bcmis;
/* Compute B and the rotation matrix */
tau = slapy2_(c__, &z__);
*cs = z__ / tau;
*sn = *c__ / tau;
*b -= *c__;
*c__ = 0.f;
} else {
/* Complex eigenvalues, or real (almost) equal eigenvalues.
Make diagonal elements equal. */
sigma = *b + *c__;
tau = slapy2_(&sigma, &temp);
*cs = sqrt((dabs(sigma) / tau + 1.f) * .5f);
*sn = -(p / (tau * *cs)) * r_sign(&c_b4, &sigma);
/* Compute [ AA BB ] = [ A B ] [ CS -SN ]
[ CC DD ] [ C D ] [ SN CS ] */
aa = *a * *cs + *b * *sn;
bb = -(*a) * *sn + *b * *cs;
cc = *c__ * *cs + *d__ * *sn;
dd = -(*c__) * *sn + *d__ * *cs;
/* Compute [ A B ] = [ CS SN ] [ AA BB ]
[ C D ] [-SN CS ] [ CC DD ] */
*a = aa * *cs + cc * *sn;
*b = bb * *cs + dd * *sn;
*c__ = -aa * *sn + cc * *cs;
*d__ = -bb * *sn + dd * *cs;
temp = (*a + *d__) * .5f;
*a = temp;
*d__ = temp;
if (*c__ != 0.f) {
if (*b != 0.f) {
if (r_sign(&c_b4, b) == r_sign(&c_b4, c__)) {
/* Real eigenvalues: reduce to upper triangular form */
sab = sqrt((dabs(*b)));
sac = sqrt((dabs(*c__)));
r__1 = sab * sac;
p = r_sign(&r__1, c__);
tau = 1.f / sqrt((r__1 = *b + *c__, dabs(r__1)));
*a = temp + p;
*d__ = temp - p;
*b -= *c__;
*c__ = 0.f;
cs1 = sab * tau;
sn1 = sac * tau;
temp = *cs * cs1 - *sn * sn1;
*sn = *cs * sn1 + *sn * cs1;
*cs = temp;
}
} else {
*b = -(*c__);
*c__ = 0.f;
temp = *cs;
*cs = -(*sn);
*sn = temp;
}
}
}
}
L10:
/* Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I). */
*rt1r = *a;
*rt2r = *d__;
if (*c__ == 0.f) {
*rt1i = 0.f;
*rt2i = 0.f;
} else {
*rt1i = sqrt((dabs(*b))) * sqrt((dabs(*c__)));
*rt2i = -(*rt1i);
}
return 0;
/* End of SLANV2 */
} /* slanv2_ */
/* Subroutine */ int slagv2_(real *a, integer *lda, real *b, integer *ldb,
real *alphar, real *alphai, real *beta, real *csl, real *snl, real *
csr, real *snr)
{
/* -- 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
Purpose
=======
SLAGV2 computes the Generalized Schur factorization of a real 2-by-2
matrix pencil (A,B) where B is upper triangular. This routine
computes orthogonal (rotation) matrices given by CSL, SNL and CSR,
SNR such that
1) if the pencil (A,B) has two real eigenvalues (include 0/0 or 1/0
types), then
[ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ]
[ 0 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ]
[ b11 b12 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ]
[ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ],
2) if the pencil (A,B) has a pair of complex conjugate eigenvalues,
then
[ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ]
[ a21 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ]
[ b11 0 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ]
[ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ]
where b11 >= b22 > 0.
Arguments
=========
A (input/output) REAL array, dimension (LDA, 2)
On entry, the 2 x 2 matrix A.
On exit, A is overwritten by the ``A-part'' of the
generalized Schur form.
LDA (input) INTEGER
THe leading dimension of the array A. LDA >= 2.
B (input/output) REAL array, dimension (LDB, 2)
On entry, the upper triangular 2 x 2 matrix B.
On exit, B is overwritten by the ``B-part'' of the
generalized Schur form.
LDB (input) INTEGER
THe leading dimension of the array B. LDB >= 2.
ALPHAR (output) REAL array, dimension (2)
ALPHAI (output) REAL array, dimension (2)
BETA (output) REAL array, dimension (2)
(ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the
pencil (A,B), k=1,2, i = sqrt(-1). Note that BETA(k) may
be zero.
CSL (output) REAL
The cosine of the left rotation matrix.
SNL (output) REAL
The sine of the left rotation matrix.
CSR (output) REAL
The cosine of the right rotation matrix.
SNR (output) REAL
The sine of the right rotation matrix.
Further Details
===============
Based on contributions by
Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__2 = 2;
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset;
real r__1, r__2, r__3, r__4, r__5, r__6;
/* Local variables */
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *), slag2_(real *, integer *, real *,
integer *, real *, real *, real *, real *, real *, real *);
static real r__, t, anorm, bnorm, h1, h2, h3, scale1, scale2;
extern /* Subroutine */ int slasv2_(real *, real *, real *, real *, real *
, real *, real *, real *, real *);
extern doublereal slapy2_(real *, real *);
static real ascale, bscale, wi, qq, rr;
extern doublereal slamch_(char *);
static real safmin;
extern /* Subroutine */ int slartg_(real *, real *, real *, real *, real *
);
static real wr1, wr2, ulp;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--alphar;
--alphai;
--beta;
/* Function Body */
safmin = slamch_("S");
ulp = slamch_("P");
/* Scale A
Computing MAX */
r__5 = (r__1 = a_ref(1, 1), dabs(r__1)) + (r__2 = a_ref(2, 1), dabs(r__2))
, r__6 = (r__3 = a_ref(1, 2), dabs(r__3)) + (r__4 = a_ref(2, 2),
dabs(r__4)), r__5 = max(r__5,r__6);
anorm = dmax(r__5,safmin);
ascale = 1.f / anorm;
a_ref(1, 1) = ascale * a_ref(1, 1);
a_ref(1, 2) = ascale * a_ref(1, 2);
a_ref(2, 1) = ascale * a_ref(2, 1);
a_ref(2, 2) = ascale * a_ref(2, 2);
/* Scale B
Computing MAX */
r__4 = (r__3 = b_ref(1, 1), dabs(r__3)), r__5 = (r__1 = b_ref(1, 2), dabs(
r__1)) + (r__2 = b_ref(2, 2), dabs(r__2)), r__4 = max(r__4,r__5);
bnorm = dmax(r__4,safmin);
bscale = 1.f / bnorm;
b_ref(1, 1) = bscale * b_ref(1, 1);
b_ref(1, 2) = bscale * b_ref(1, 2);
b_ref(2, 2) = bscale * b_ref(2, 2);
/* Check if A can be deflated */
if ((r__1 = a_ref(2, 1), dabs(r__1)) <= ulp) {
*csl = 1.f;
*snl = 0.f;
*csr = 1.f;
*snr = 0.f;
a_ref(2, 1) = 0.f;
b_ref(2, 1) = 0.f;
/* Check if B is singular */
} else if ((r__1 = b_ref(1, 1), dabs(r__1)) <= ulp) {
slartg_(&a_ref(1, 1), &a_ref(2, 1), csl, snl, &r__);
*csr = 1.f;
*snr = 0.f;
srot_(&c__2, &a_ref(1, 1), lda, &a_ref(2, 1), lda, csl, snl);
srot_(&c__2, &b_ref(1, 1), ldb, &b_ref(2, 1), ldb, csl, snl);
a_ref(2, 1) = 0.f;
b_ref(1, 1) = 0.f;
b_ref(2, 1) = 0.f;
} else if ((r__1 = b_ref(2, 2), dabs(r__1)) <= ulp) {
slartg_(&a_ref(2, 2), &a_ref(2, 1), csr, snr, &t);
*snr = -(*snr);
srot_(&c__2, &a_ref(1, 1), &c__1, &a_ref(1, 2), &c__1, csr, snr);
srot_(&c__2, &b_ref(1, 1), &c__1, &b_ref(1, 2), &c__1, csr, snr);
*csl = 1.f;
*snl = 0.f;
a_ref(2, 1) = 0.f;
b_ref(2, 1) = 0.f;
b_ref(2, 2) = 0.f;
} else {
/* B is nonsingular, first compute the eigenvalues of (A,B) */
slag2_(&a[a_offset], lda, &b[b_offset], ldb, &safmin, &scale1, &
scale2, &wr1, &wr2, &wi);
if (wi == 0.f) {
/* two real eigenvalues, compute s*A-w*B */
h1 = scale1 * a_ref(1, 1) - wr1 * b_ref(1, 1);
h2 = scale1 * a_ref(1, 2) - wr1 * b_ref(1, 2);
h3 = scale1 * a_ref(2, 2) - wr1 * b_ref(2, 2);
rr = slapy2_(&h1, &h2);
r__1 = scale1 * a_ref(2, 1);
qq = slapy2_(&r__1, &h3);
if (rr > qq) {
/* find right rotation matrix to zero 1,1 element of
(sA - wB) */
slartg_(&h2, &h1, csr, snr, &t);
} else {
/* find right rotation matrix to zero 2,1 element of
(sA - wB) */
r__1 = scale1 * a_ref(2, 1);
slartg_(&h3, &r__1, csr, snr, &t);
}
*snr = -(*snr);
srot_(&c__2, &a_ref(1, 1), &c__1, &a_ref(1, 2), &c__1, csr, snr);
srot_(&c__2, &b_ref(1, 1), &c__1, &b_ref(1, 2), &c__1, csr, snr);
/* compute inf norms of A and B
Computing MAX */
r__5 = (r__1 = a_ref(1, 1), dabs(r__1)) + (r__2 = a_ref(1, 2),
dabs(r__2)), r__6 = (r__3 = a_ref(2, 1), dabs(r__3)) + (
r__4 = a_ref(2, 2), dabs(r__4));
h1 = dmax(r__5,r__6);
/* Computing MAX */
r__5 = (r__1 = b_ref(1, 1), dabs(r__1)) + (r__2 = b_ref(1, 2),
dabs(r__2)), r__6 = (r__3 = b_ref(2, 1), dabs(r__3)) + (
r__4 = b_ref(2, 2), dabs(r__4));
h2 = dmax(r__5,r__6);
if (scale1 * h1 >= dabs(wr1) * h2) {
/* find left rotation matrix Q to zero out B(2,1) */
slartg_(&b_ref(1, 1), &b_ref(2, 1), csl, snl, &r__);
} else {
/* find left rotation matrix Q to zero out A(2,1) */
slartg_(&a_ref(1, 1), &a_ref(2, 1), csl, snl, &r__);
}
srot_(&c__2, &a_ref(1, 1), lda, &a_ref(2, 1), lda, csl, snl);
srot_(&c__2, &b_ref(1, 1), ldb, &b_ref(2, 1), ldb, csl, snl);
a_ref(2, 1) = 0.f;
b_ref(2, 1) = 0.f;
} else {
/* a pair of complex conjugate eigenvalues
first compute the SVD of the matrix B */
slasv2_(&b_ref(1, 1), &b_ref(1, 2), &b_ref(2, 2), &r__, &t, snr,
csr, snl, csl);
/* Form (A,B) := Q(A,B)Z' where Q is left rotation matrix and
Z is right rotation matrix computed from SLASV2 */
srot_(&c__2, &a_ref(1, 1), lda, &a_ref(2, 1), lda, csl, snl);
srot_(&c__2, &b_ref(1, 1), ldb, &b_ref(2, 1), ldb, csl, snl);
srot_(&c__2, &a_ref(1, 1), &c__1, &a_ref(1, 2), &c__1, csr, snr);
srot_(&c__2, &b_ref(1, 1), &c__1, &b_ref(1, 2), &c__1, csr, snr);
b_ref(2, 1) = 0.f;
b_ref(1, 2) = 0.f;
}
}
/* Unscaling */
a_ref(1, 1) = anorm * a_ref(1, 1);
a_ref(2, 1) = anorm * a_ref(2, 1);
a_ref(1, 2) = anorm * a_ref(1, 2);
a_ref(2, 2) = anorm * a_ref(2, 2);
b_ref(1, 1) = bnorm * b_ref(1, 1);
b_ref(2, 1) = bnorm * b_ref(2, 1);
b_ref(1, 2) = bnorm * b_ref(1, 2);
b_ref(2, 2) = bnorm * b_ref(2, 2);
if (wi == 0.f) {
alphar[1] = a_ref(1, 1);
alphar[2] = a_ref(2, 2);
alphai[1] = 0.f;
alphai[2] = 0.f;
beta[1] = b_ref(1, 1);
beta[2] = b_ref(2, 2);
} else {
alphar[1] = anorm * wr1 / scale1 / bnorm;
alphai[1] = anorm * wi / scale1 / bnorm;
alphar[2] = alphar[1];
alphai[2] = -alphai[1];
beta[1] = 1.f;
beta[2] = 1.f;
}
/* L10: */
return 0;
/* End of SLAGV2 */
} /* slagv2_ */
