/* Subroutine */
int slaqr2_(logical *wantt, logical *wantz, integer *n, integer *ktop, integer *kbot, integer *nw, real *h__, integer *ldh, integer *iloz, integer *ihiz, real *z__, integer *ldz, integer *ns, integer *nd, real *sr, real *si, real *v, integer *ldv, integer *nh, real *t, integer *ldt, integer *nv, real *wv, integer *ldwv, real * work, integer *lwork)
{
/* System generated locals */
integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1, wv_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
real r__1, r__2, r__3, r__4, r__5, r__6;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, k;
real s, aa, bb, cc, dd, cs, sn;
integer jw;
real evi, evk, foo;
integer kln;
real tau, ulp;
integer lwk1, lwk2;
real beta;
integer kend, kcol, info, ifst, ilst, ltop, krow;
logical bulge;
extern /* Subroutine */
int slarf_(char *, integer *, integer *, real *, integer *, real *, real *, integer *, real *), sgemm_( char *, char *, integer *, integer *, integer *, real *, real *, integer *, real *, integer *, real *, real *, integer *);
integer infqr;
extern /* Subroutine */
int scopy_(integer *, real *, integer *, real *, integer *);
integer kwtop;
extern /* Subroutine */
int slanv2_(real *, real *, real *, real *, real * , real *, real *, real *, real *, real *), slabad_(real *, real *) ;
extern real slamch_(char *);
extern /* Subroutine */
int sgehrd_(integer *, integer *, integer *, real *, integer *, real *, real *, integer *, integer *);
real safmin;
extern /* Subroutine */
int slarfg_(integer *, real *, real *, integer *, real *);
real safmax;
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 *), slaset_(char *, integer *, integer *, real *, real *, real *, integer *);
logical sorted;
extern /* Subroutine */
int strexc_(char *, integer *, real *, integer *, real *, integer *, integer *, integer *, real *, integer *), sormhr_(char *, char *, integer *, integer *, integer *, integer *, real *, integer *, real *, real *, integer *, real *, integer *, integer *);
real smlnum;
integer lwkopt;
/* -- 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 .. */
/* ==== Estimate optimal workspace. ==== */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--sr;
--si;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
wv_dim1 = *ldwv;
wv_offset = 1 + wv_dim1;
wv -= wv_offset;
--work;
/* Function Body */
/* Computing MIN */
i__1 = *nw;
i__2 = *kbot - *ktop + 1; // , expr subst
jw = min(i__1,i__2);
if (jw <= 2)
{
lwkopt = 1;
}
else
{
/* ==== Workspace query call to SGEHRD ==== */
i__1 = jw - 1;
sgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], & c_n1, &info);
lwk1 = (integer) work[1];
/* ==== Workspace query call to SORMHR ==== */
i__1 = jw - 1;
sormhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &v[v_offset], ldv, &work[1], &c_n1, &info);
lwk2 = (integer) work[1];
/* ==== Optimal workspace ==== */
lwkopt = jw + max(lwk1,lwk2);
}
/* ==== Quick return in case of workspace query. ==== */
if (*lwork == -1)
{
work[1] = (real) lwkopt;
return 0;
}
/* ==== Nothing to do ... */
/* ... for an empty active block ... ==== */
*ns = 0;
*nd = 0;
work[1] = 1.f;
if (*ktop > *kbot)
{
return 0;
}
/* ... nor for an empty deflation window. ==== */
if (*nw < 1)
{
return 0;
}
/* ==== Machine constants ==== */
safmin = slamch_("SAFE MINIMUM");
safmax = 1.f / safmin;
slabad_(&safmin, &safmax);
ulp = slamch_("PRECISION");
smlnum = safmin * ((real) (*n) / ulp);
/* ==== Setup deflation window ==== */
/* Computing MIN */
i__1 = *nw;
i__2 = *kbot - *ktop + 1; // , expr subst
jw = min(i__1,i__2);
kwtop = *kbot - jw + 1;
if (kwtop == *ktop)
{
s = 0.f;
}
else
{
s = h__[kwtop + (kwtop - 1) * h_dim1];
}
if (*kbot == kwtop)
{
/* ==== 1-by-1 deflation window: not much to do ==== */
sr[kwtop] = h__[kwtop + kwtop * h_dim1];
si[kwtop] = 0.f;
*ns = 1;
*nd = 0;
/* Computing MAX */
r__2 = smlnum;
r__3 = ulp * (r__1 = h__[kwtop + kwtop * h_dim1], abs( r__1)); // , expr subst
if (abs(s) <= max(r__2,r__3))
{
*ns = 0;
*nd = 1;
if (kwtop > *ktop)
{
h__[kwtop + (kwtop - 1) * h_dim1] = 0.f;
}
}
work[1] = 1.f;
return 0;
}
/* ==== Convert to spike-triangular form. (In case of a */
/* . rare QR failure, this routine continues to do */
/* . aggressive early deflation using that part of */
/* . the deflation window that converged using INFQR */
/* . here and there to keep track.) ==== */
slacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset], ldt);
i__1 = jw - 1;
i__2 = *ldh + 1;
i__3 = *ldt + 1;
scopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], & i__3);
slaset_("A", &jw, &jw, &c_b12, &c_b13, &v[v_offset], ldv);
slahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[kwtop], &si[kwtop], &c__1, &jw, &v[v_offset], ldv, &infqr);
/* ==== STREXC needs a clean margin near the diagonal ==== */
i__1 = jw - 3;
for (j = 1;
j <= i__1;
++j)
{
t[j + 2 + j * t_dim1] = 0.f;
t[j + 3 + j * t_dim1] = 0.f;
/* L10: */
}
if (jw > 2)
{
t[jw + (jw - 2) * t_dim1] = 0.f;
}
/* ==== Deflation detection loop ==== */
*ns = jw;
ilst = infqr + 1;
L20:
if (ilst <= *ns)
{
if (*ns == 1)
{
bulge = FALSE_;
}
else
{
bulge = t[*ns + (*ns - 1) * t_dim1] != 0.f;
}
/* ==== Small spike tip test for deflation ==== */
if (! bulge)
{
/* ==== Real eigenvalue ==== */
foo = (r__1 = t[*ns + *ns * t_dim1], abs(r__1));
if (foo == 0.f)
{
foo = abs(s);
}
/* Computing MAX */
r__2 = smlnum;
r__3 = ulp * foo; // , expr subst
if ((r__1 = s * v[*ns * v_dim1 + 1], abs(r__1)) <= max(r__2,r__3))
{
/* ==== Deflatable ==== */
--(*ns);
}
else
{
/* ==== Undeflatable. Move it up out of the way. */
/* . (STREXC can not fail in this case.) ==== */
ifst = *ns;
strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &ilst, &work[1], &info);
++ilst;
}
}
else
{
/* ==== Complex conjugate pair ==== */
foo = (r__3 = t[*ns + *ns * t_dim1], abs(r__3)) + sqrt((r__1 = t[* ns + (*ns - 1) * t_dim1], abs(r__1))) * sqrt((r__2 = t[* ns - 1 + *ns * t_dim1], abs(r__2)));
if (foo == 0.f)
{
foo = abs(s);
}
/* Computing MAX */
r__3 = (r__1 = s * v[*ns * v_dim1 + 1], abs(r__1));
r__4 = (r__2 = s * v[(*ns - 1) * v_dim1 + 1], abs(r__2)); // , expr subst
/* Computing MAX */
r__5 = smlnum;
r__6 = ulp * foo; // , expr subst
if (max(r__3,r__4) <= max(r__5,r__6))
{
/* ==== Deflatable ==== */
*ns += -2;
}
else
{
/* ==== Undeflatable. Move them up out of the way. */
/* . Fortunately, STREXC does the right thing with */
/* . ILST in case of a rare exchange failure. ==== */
ifst = *ns;
strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &ilst, &work[1], &info);
ilst += 2;
}
}
/* ==== End deflation detection loop ==== */
goto L20;
}
/* ==== Return to Hessenberg form ==== */
if (*ns == 0)
{
s = 0.f;
}
if (*ns < jw)
{
/* ==== sorting diagonal blocks of T improves accuracy for */
/* . graded matrices. Bubble sort deals well with */
/* . exchange failures. ==== */
sorted = FALSE_;
i__ = *ns + 1;
L30:
if (sorted)
{
goto L50;
}
sorted = TRUE_;
kend = i__ - 1;
i__ = infqr + 1;
if (i__ == *ns)
{
k = i__ + 1;
}
else if (t[i__ + 1 + i__ * t_dim1] == 0.f)
{
k = i__ + 1;
}
else
{
k = i__ + 2;
}
L40:
if (k <= kend)
{
if (k == i__ + 1)
{
evi = (r__1 = t[i__ + i__ * t_dim1], abs(r__1));
}
else
{
evi = (r__3 = t[i__ + i__ * t_dim1], abs(r__3)) + sqrt((r__1 = t[i__ + 1 + i__ * t_dim1], abs(r__1))) * sqrt((r__2 = t[i__ + (i__ + 1) * t_dim1], abs(r__2)));
}
if (k == kend)
{
evk = (r__1 = t[k + k * t_dim1], abs(r__1));
}
else if (t[k + 1 + k * t_dim1] == 0.f)
{
evk = (r__1 = t[k + k * t_dim1], abs(r__1));
}
else
{
evk = (r__3 = t[k + k * t_dim1], abs(r__3)) + sqrt((r__1 = t[ k + 1 + k * t_dim1], abs(r__1))) * sqrt((r__2 = t[k + (k + 1) * t_dim1], abs(r__2)));
}
if (evi >= evk)
{
i__ = k;
}
else
{
sorted = FALSE_;
ifst = i__;
ilst = k;
strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &ilst, &work[1], &info);
if (info == 0)
{
i__ = ilst;
}
else
{
i__ = k;
}
}
if (i__ == kend)
{
k = i__ + 1;
}
else if (t[i__ + 1 + i__ * t_dim1] == 0.f)
{
k = i__ + 1;
}
else
{
k = i__ + 2;
}
goto L40;
}
goto L30;
L50:
;
}
/* ==== Restore shift/eigenvalue array from T ==== */
i__ = jw;
L60:
if (i__ >= infqr + 1)
{
if (i__ == infqr + 1)
{
sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1];
si[kwtop + i__ - 1] = 0.f;
--i__;
}
else if (t[i__ + (i__ - 1) * t_dim1] == 0.f)
{
sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1];
si[kwtop + i__ - 1] = 0.f;
--i__;
}
else
{
aa = t[i__ - 1 + (i__ - 1) * t_dim1];
cc = t[i__ + (i__ - 1) * t_dim1];
bb = t[i__ - 1 + i__ * t_dim1];
dd = t[i__ + i__ * t_dim1];
slanv2_(&aa, &bb, &cc, &dd, &sr[kwtop + i__ - 2], &si[kwtop + i__ - 2], &sr[kwtop + i__ - 1], &si[kwtop + i__ - 1], &cs, & sn);
i__ += -2;
}
goto L60;
}
if (*ns < jw || s == 0.f)
{
if (*ns > 1 && s != 0.f)
{
/* ==== Reflect spike back into lower triangle ==== */
scopy_(ns, &v[v_offset], ldv, &work[1], &c__1);
beta = work[1];
slarfg_(ns, &beta, &work[2], &c__1, &tau);
work[1] = 1.f;
i__1 = jw - 2;
i__2 = jw - 2;
slaset_("L", &i__1, &i__2, &c_b12, &c_b12, &t[t_dim1 + 3], ldt);
slarf_("L", ns, &jw, &work[1], &c__1, &tau, &t[t_offset], ldt, & work[jw + 1]);
slarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, & work[jw + 1]);
slarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, & work[jw + 1]);
i__1 = *lwork - jw;
sgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1] , &i__1, &info);
}
/* ==== Copy updated reduced window into place ==== */
if (kwtop > 1)
{
h__[kwtop + (kwtop - 1) * h_dim1] = s * v[v_dim1 + 1];
}
slacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1] , ldh);
i__1 = jw - 1;
i__2 = *ldt + 1;
i__3 = *ldh + 1;
scopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1], &i__3);
/* ==== Accumulate orthogonal matrix in order update */
/* . H and Z, if requested. ==== */
if (*ns > 1 && s != 0.f)
{
i__1 = *lwork - jw;
sormhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1], &v[v_offset], ldv, &work[jw + 1], &i__1, &info);
}
/* ==== Update vertical slab in H ==== */
if (*wantt)
{
ltop = 1;
}
else
{
ltop = *ktop;
}
i__1 = kwtop - 1;
i__2 = *nv;
for (krow = ltop;
i__2 < 0 ? krow >= i__1 : krow <= i__1;
krow += i__2)
{
/* Computing MIN */
i__3 = *nv;
i__4 = kwtop - krow; // , expr subst
kln = min(i__3,i__4);
sgemm_("N", "N", &kln, &jw, &jw, &c_b13, &h__[krow + kwtop * h_dim1], ldh, &v[v_offset], ldv, &c_b12, &wv[wv_offset], ldwv);
slacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop * h_dim1], ldh);
/* L70: */
}
/* ==== Update horizontal slab in H ==== */
if (*wantt)
{
i__2 = *n;
i__1 = *nh;
for (kcol = *kbot + 1;
i__1 < 0 ? kcol >= i__2 : kcol <= i__2;
kcol += i__1)
{
/* Computing MIN */
i__3 = *nh;
i__4 = *n - kcol + 1; // , expr subst
kln = min(i__3,i__4);
sgemm_("C", "N", &jw, &kln, &jw, &c_b13, &v[v_offset], ldv, & h__[kwtop + kcol * h_dim1], ldh, &c_b12, &t[t_offset], ldt);
slacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol * h_dim1], ldh);
/* L80: */
}
}
/* ==== Update vertical slab in Z ==== */
if (*wantz)
{
i__1 = *ihiz;
i__2 = *nv;
for (krow = *iloz;
i__2 < 0 ? krow >= i__1 : krow <= i__1;
krow += i__2)
{
/* Computing MIN */
i__3 = *nv;
i__4 = *ihiz - krow + 1; // , expr subst
kln = min(i__3,i__4);
sgemm_("N", "N", &kln, &jw, &jw, &c_b13, &z__[krow + kwtop * z_dim1], ldz, &v[v_offset], ldv, &c_b12, &wv[ wv_offset], ldwv);
slacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow + kwtop * z_dim1], ldz);
/* L90: */
}
}
}
/* ==== Return the number of deflations ... ==== */
*nd = jw - *ns;
/* ==== ... and the number of shifts. (Subtracting */
/* . INFQR from the spike length takes care */
/* . of the case of a rare QR failure while */
/* . calculating eigenvalues of the deflation */
/* . window.) ==== */
*ns -= infqr;
/* ==== Return optimal workspace. ==== */
work[1] = (real) lwkopt;
/* ==== End of SLAQR2 ==== */
return 0;
}
/* Subroutine */ int slahqr_(logical *wantt, logical *wantz, integer *n,
integer *ilo, integer *ihi, real *h__, integer *ldh, real *wr, real *
wi, integer *iloz, integer *ihiz, real *z__, integer *ldz, integer *
info)
{
/* System generated locals */
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3;
real r__1, r__2, r__3, r__4;
/* Local variables */
integer i__, j, k, l, m;
real s, v[3];
integer i1, i2;
real t1, t2, t3, v2, v3, aa, ab, ba, bb, h11, h12, h21, h22, cs;
integer nh;
real sn;
integer nr;
real tr;
integer nz;
real det, h21s;
integer its;
real ulp, sum, tst, rt1i, rt2i, rt1r, rt2r;
real safmin;
real safmax, rtdisc, smlnum;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* SLAHQR is an auxiliary routine called by SHSEQR to update the */
/* eigenvalues and Schur decomposition already computed by SHSEQR, by */
/* dealing with the Hessenberg submatrix in rows and columns ILO to */
/* IHI. */
/* Arguments */
/* ========= */
/* WANTT (input) LOGICAL */
/* = .TRUE. : the full Schur form T is required; */
/* = .FALSE.: only eigenvalues are required. */
/* WANTZ (input) LOGICAL */
/* = .TRUE. : the matrix of Schur vectors Z is required; */
/* = .FALSE.: Schur vectors are not required. */
/* 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 quasi-triangular in */
/* rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless */
/* ILO = 1). SLAHQR works primarily with the Hessenberg */
/* submatrix in rows and columns ILO to IHI, but applies */
/* 1 <= ILO <= max(1,IHI); IHI <= N. */
/* H (input/output) REAL array, dimension (LDH,N) */
/* On entry, the upper Hessenberg matrix H. */
/* On exit, if INFO is zero and if WANTT is .TRUE., H is upper */
/* quasi-triangular in rows and columns ILO:IHI, with any */
/* 2-by-2 diagonal blocks in standard form. If INFO is zero */
/* and WANTT is .FALSE., the contents of H are unspecified on */
/* exit. The output state of H if INFO is nonzero is given */
/* below under the description of INFO. */
/* 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 ILO to IHI are stored in the corresponding */
/* elements of WR and WI. 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 WANTT is .TRUE., 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). */
/* ILOZ (input) INTEGER */
/* IHIZ (input) INTEGER */
/* Specify the rows of Z to which transformations must be */
/* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. */
/* Z (input/output) REAL array, dimension (LDZ,N) */
/* If WANTZ is .TRUE., on entry Z must contain the current */
/* matrix Z of transformations accumulated by SHSEQR, and on */
/* exit Z has been updated; transformations are applied only to */
/* the submatrix Z(ILOZ:IHIZ,ILO:IHI). */
/* If WANTZ is .FALSE., Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* .GT. 0: If INFO = i, SLAHQR failed to compute all the */
/* eigenvalues ILO to IHI in a total of 30 iterations */
/* per eigenvalue; elements i+1:ihi of WR and WI */
/* contain those eigenvalues which have been */
/* successfully computed. */
/* If INFO .GT. 0 and WANTT is .FALSE., then on exit, */
/* the remaining unconverged eigenvalues are the */
/* eigenvalues of the upper Hessenberg matrix rows */
/* and columns ILO thorugh INFO of the final, output */
/* value of H. */
/* If INFO .GT. 0 and WANTT is .TRUE., then on exit */
/* (*) (initial value of H)*U = U*(final value of H) */
/* where U is an orthognal matrix. The final */
/* value of H is upper Hessenberg and triangular in */
/* rows and columns INFO+1 through IHI. */
/* If INFO .GT. 0 and WANTZ is .TRUE., then on exit */
/* (final value of Z) = (initial value of Z)*U */
/* where U is the orthogonal matrix in (*) */
/* (regardless of the value of WANTT.) */
/* Further Details */
/* =============== */
/* 02-96 Based on modifications by */
/* David Day, Sandia National Laboratory, USA */
/* 12-04 Further modifications by */
/* Ralph Byers, University of Kansas, USA */
/* This is a modified version of SLAHQR from LAPACK version 3.0. */
/* It is (1) more robust against overflow and underflow and */
/* (2) adopts the more conservative Ahues & Tisseur stopping */
/* criterion (LAWN 122, 1997). */
/* ========================================================= */
/* 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;
/* Function Body */
*info = 0;
/* 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;
}
/* ==== clear out the trash ==== */
i__1 = *ihi - 3;
for (j = *ilo; j <= i__1; ++j) {
h__[j + 2 + j * h_dim1] = 0.f;
h__[j + 3 + j * h_dim1] = 0.f;
}
if (*ilo <= *ihi - 2) {
h__[*ihi + (*ihi - 2) * h_dim1] = 0.f;
}
nh = *ihi - *ilo + 1;
nz = *ihiz - *iloz + 1;
/* Set machine-dependent constants for the stopping criterion. */
safmin = slamch_("SAFE MINIMUM");
safmax = 1.f / safmin;
slabad_(&safmin, &safmax);
ulp = slamch_("PRECISION");
smlnum = safmin * ((real) 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;
}
/* The main loop begins here. I is the loop index and decreases from */
/* IHI to ILO in steps of 1 or 2. 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;
L20:
l = *ilo;
if (i__ < *ilo) {
goto L160;
}
/* Perform QR iterations on rows and columns ILO to I until a */
/* submatrix of order 1 or 2 splits off at the bottom because a */
/* subdiagonal element has become negligible. */
for (its = 0; its <= 30; ++its) {
/* Look for a single small subdiagonal element. */
i__1 = l + 1;
for (k = i__; k >= i__1; --k) {
if ((r__1 = h__[k + (k - 1) * h_dim1], dabs(r__1)) <= smlnum) {
goto L40;
}
tst = (r__1 = h__[k - 1 + (k - 1) * h_dim1], dabs(r__1)) + (r__2 =
h__[k + k * h_dim1], dabs(r__2));
if (tst == 0.f) {
if (k - 2 >= *ilo) {
tst += (r__1 = h__[k - 1 + (k - 2) * h_dim1], dabs(r__1));
}
if (k + 1 <= *ihi) {
tst += (r__1 = h__[k + 1 + k * h_dim1], dabs(r__1));
}
}
/* ==== The following is a conservative small subdiagonal */
/* . deflation criterion due to Ahues & Tisseur (LAWN 122, */
/* . 1997). It has better mathematical foundation and */
/* . improves accuracy in some cases. ==== */
if ((r__1 = h__[k + (k - 1) * h_dim1], dabs(r__1)) <= ulp * tst) {
/* Computing MAX */
r__3 = (r__1 = h__[k + (k - 1) * h_dim1], dabs(r__1)), r__4 =
(r__2 = h__[k - 1 + k * h_dim1], dabs(r__2));
ab = dmax(r__3,r__4);
/* Computing MIN */
r__3 = (r__1 = h__[k + (k - 1) * h_dim1], dabs(r__1)), r__4 =
(r__2 = h__[k - 1 + k * h_dim1], dabs(r__2));
ba = dmin(r__3,r__4);
/* Computing MAX */
r__3 = (r__1 = h__[k + k * h_dim1], dabs(r__1)), r__4 = (r__2
= h__[k - 1 + (k - 1) * h_dim1] - h__[k + k * h_dim1],
dabs(r__2));
aa = dmax(r__3,r__4);
/* Computing MIN */
r__3 = (r__1 = h__[k + k * h_dim1], dabs(r__1)), r__4 = (r__2
= h__[k - 1 + (k - 1) * h_dim1] - h__[k + k * h_dim1],
dabs(r__2));
bb = dmin(r__3,r__4);
s = aa + ab;
/* Computing MAX */
r__1 = smlnum, r__2 = ulp * (bb * (aa / s));
if (ba * (ab / s) <= dmax(r__1,r__2)) {
goto L40;
}
}
}
L40:
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 1 or 2 has split off. */
if (l >= i__ - 1) {
goto L150;
}
/* 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 == 10) {
/* Exceptional shift. */
s = (r__1 = h__[l + 1 + l * h_dim1], dabs(r__1)) + (r__2 = h__[l
+ 2 + (l + 1) * h_dim1], dabs(r__2));
h11 = s * .75f + h__[l + l * h_dim1];
h12 = s * -.4375f;
h21 = s;
h22 = h11;
} else if (its == 20) {
/* Exceptional shift. */
s = (r__1 = h__[i__ + (i__ - 1) * h_dim1], dabs(r__1)) + (r__2 =
h__[i__ - 1 + (i__ - 2) * h_dim1], dabs(r__2));
h11 = s * .75f + h__[i__ + i__ * h_dim1];
h12 = s * -.4375f;
h21 = s;
h22 = h11;
} else {
/* Prepare to use Francis' double shift */
/* (i.e. 2nd degree generalized Rayleigh quotient) */
h11 = h__[i__ - 1 + (i__ - 1) * h_dim1];
h21 = h__[i__ + (i__ - 1) * h_dim1];
h12 = h__[i__ - 1 + i__ * h_dim1];
h22 = h__[i__ + i__ * h_dim1];
}
s = dabs(h11) + dabs(h12) + dabs(h21) + dabs(h22);
if (s == 0.f) {
rt1r = 0.f;
rt1i = 0.f;
rt2r = 0.f;
rt2i = 0.f;
} else {
h11 /= s;
h21 /= s;
h12 /= s;
h22 /= s;
tr = (h11 + h22) / 2.f;
det = (h11 - tr) * (h22 - tr) - h12 * h21;
rtdisc = sqrt((dabs(det)));
if (det >= 0.f) {
/* ==== complex conjugate shifts ==== */
rt1r = tr * s;
rt2r = rt1r;
rt1i = rtdisc * s;
rt2i = -rt1i;
} else {
/* ==== real shifts (use only one of them) ==== */
rt1r = tr + rtdisc;
rt2r = tr - rtdisc;
if ((r__1 = rt1r - h22, dabs(r__1)) <= (r__2 = rt2r - h22,
dabs(r__2))) {
rt1r *= s;
rt2r = rt1r;
} else {
rt2r *= s;
rt1r = rt2r;
}
rt1i = 0.f;
rt2i = 0.f;
}
}
/* Look for two consecutive small subdiagonal elements. */
i__1 = l;
for (m = i__ - 2; m >= i__1; --m) {
/* Determine the effect of starting the double-shift QR */
/* iteration at row M, and see if this would make H(M,M-1) */
/* negligible. (The following uses scaling to avoid */
/* overflows and most underflows.) */
h21s = h__[m + 1 + m * h_dim1];
s = (r__1 = h__[m + m * h_dim1] - rt2r, dabs(r__1)) + dabs(rt2i)
+ dabs(h21s);
h21s = h__[m + 1 + m * h_dim1] / s;
v[0] = h21s * h__[m + (m + 1) * h_dim1] + (h__[m + m * h_dim1] -
rt1r) * ((h__[m + m * h_dim1] - rt2r) / s) - rt1i * (rt2i
/ s);
v[1] = h21s * (h__[m + m * h_dim1] + h__[m + 1 + (m + 1) * h_dim1]
- rt1r - rt2r);
v[2] = h21s * h__[m + 2 + (m + 1) * h_dim1];
s = dabs(v[0]) + dabs(v[1]) + dabs(v[2]);
v[0] /= s;
v[1] /= s;
v[2] /= s;
if (m == l) {
goto L60;
}
if ((r__1 = h__[m + (m - 1) * h_dim1], dabs(r__1)) * (dabs(v[1])
+ dabs(v[2])) <= ulp * dabs(v[0]) * ((r__2 = h__[m - 1 + (
m - 1) * h_dim1], dabs(r__2)) + (r__3 = h__[m + m *
h_dim1], dabs(r__3)) + (r__4 = h__[m + 1 + (m + 1) *
h_dim1], dabs(r__4)))) {
goto L60;
}
}
L60:
/* Double-shift QR step */
i__1 = i__ - 1;
for (k = m; k <= i__1; ++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__2 = 3, i__3 = i__ - k + 1;
nr = min(i__2,i__3);
if (k > m) {
scopy_(&nr, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1);
}
slarfg_(&nr, v, &v[1], &c__1, &t1);
if (k > m) {
h__[k + (k - 1) * h_dim1] = v[0];
h__[k + 1 + (k - 1) * h_dim1] = 0.f;
if (k < i__ - 1) {
h__[k + 2 + (k - 1) * h_dim1] = 0.f;
}
} else if (m > l) {
/* ==== Use the following instead of */
/* . H( K, K-1 ) = -H( K, K-1 ) to */
/* . avoid a bug when v(2) and v(3) */
/* . underflow. ==== */
h__[k + (k - 1) * h_dim1] *= 1.f - t1;
}
v2 = v[1];
t2 = t1 * v2;
if (nr == 3) {
v3 = v[2];
t3 = t1 * v3;
/* Apply G from the left to transform the rows of the matrix */
/* in columns K to I2. */
i__2 = i2;
for (j = k; j <= i__2; ++j) {
sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1]
+ v3 * h__[k + 2 + j * h_dim1];
h__[k + j * h_dim1] -= sum * t1;
h__[k + 1 + j * h_dim1] -= sum * t2;
h__[k + 2 + j * h_dim1] -= sum * t3;
}
/* Apply G from the right to transform the columns of the */
/* matrix in rows I1 to min(K+3,I). */
/* Computing MIN */
i__3 = k + 3;
i__2 = min(i__3,i__);
for (j = i1; j <= i__2; ++j) {
sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1]
+ v3 * h__[j + (k + 2) * h_dim1];
h__[j + k * h_dim1] -= sum * t1;
h__[j + (k + 1) * h_dim1] -= sum * t2;
h__[j + (k + 2) * h_dim1] -= sum * t3;
}
if (*wantz) {
/* Accumulate transformations in the matrix Z */
i__2 = *ihiz;
for (j = *iloz; j <= i__2; ++j) {
sum = z__[j + k * z_dim1] + v2 * z__[j + (k + 1) *
z_dim1] + v3 * z__[j + (k + 2) * z_dim1];
z__[j + k * z_dim1] -= sum * t1;
z__[j + (k + 1) * z_dim1] -= sum * t2;
z__[j + (k + 2) * z_dim1] -= sum * t3;
}
}
} else if (nr == 2) {
/* Apply G from the left to transform the rows of the matrix */
/* in columns K to I2. */
i__2 = i2;
for (j = k; j <= i__2; ++j) {
sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1];
h__[k + j * h_dim1] -= sum * t1;
h__[k + 1 + j * h_dim1] -= sum * t2;
}
/* Apply G from the right to transform the columns of the */
/* matrix in rows I1 to min(K+3,I). */
i__2 = i__;
for (j = i1; j <= i__2; ++j) {
sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1]
;
h__[j + k * h_dim1] -= sum * t1;
h__[j + (k + 1) * h_dim1] -= sum * t2;
}
if (*wantz) {
/* Accumulate transformations in the matrix Z */
i__2 = *ihiz;
for (j = *iloz; j <= i__2; ++j) {
sum = z__[j + k * z_dim1] + v2 * z__[j + (k + 1) *
z_dim1];
z__[j + k * z_dim1] -= sum * t1;
z__[j + (k + 1) * z_dim1] -= sum * t2;
}
}
}
}
}
/* Failure to converge in remaining number of iterations */
*info = i__;
return 0;
L150:
if (l == i__) {
/* H(I,I-1) is negligible: one eigenvalue has converged. */
wr[i__] = h__[i__ + i__ * h_dim1];
wi[i__] = 0.f;
} else if (l == i__ - 1) {
/* H(I-1,I-2) is negligible: a pair of eigenvalues have converged. */
/* Transform the 2-by-2 submatrix to standard Schur form, */
/* and compute and store the eigenvalues. */
slanv2_(&h__[i__ - 1 + (i__ - 1) * h_dim1], &h__[i__ - 1 + i__ *
h_dim1], &h__[i__ + (i__ - 1) * h_dim1], &h__[i__ + i__ *
h_dim1], &wr[i__ - 1], &wi[i__ - 1], &wr[i__], &wi[i__], &cs,
&sn);
if (*wantt) {
/* Apply the transformation to the rest of H. */
if (i2 > i__) {
i__1 = i2 - i__;
srot_(&i__1, &h__[i__ - 1 + (i__ + 1) * h_dim1], ldh, &h__[
i__ + (i__ + 1) * h_dim1], ldh, &cs, &sn);
}
i__1 = i__ - i1 - 1;
srot_(&i__1, &h__[i1 + (i__ - 1) * h_dim1], &c__1, &h__[i1 + i__ *
h_dim1], &c__1, &cs, &sn);
}
if (*wantz) {
/* Apply the transformation to Z. */
srot_(&nz, &z__[*iloz + (i__ - 1) * z_dim1], &c__1, &z__[*iloz +
i__ * z_dim1], &c__1, &cs, &sn);
}
}
/* return to start of the main loop with new value of I. */
i__ = l - 1;
goto L20;
L160:
return 0;
/* End of SLAHQR */
} /* slahqr_ */
/* Subroutine */ int slaqr2_(logical *wantt, logical *wantz, integer *n,
integer *ktop, integer *kbot, integer *nw, real *h__, integer *ldh,
integer *iloz, integer *ihiz, real *z__, integer *ldz, integer *ns,
integer *nd, real *sr, real *si, real *v, integer *ldv, integer *nh,
real *t, integer *ldt, integer *nv, real *wv, integer *ldwv, real *
work, integer *lwork)
{
/* System generated locals */
integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1,
wv_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
real r__1, r__2, r__3, r__4, r__5, r__6;
/* Local variables */
integer i__, j, k;
real s, aa, bb, cc, dd, cs, sn;
integer jw;
real evi, evk, foo;
integer kln;
real tau, ulp;
integer lwk1, lwk2;
real beta;
integer kend, kcol, info, ifst, ilst, ltop, krow;
logical bulge;
integer infqr;
integer kwtop;
real safmin;
real safmax;
logical sorted;
real smlnum;
integer lwkopt;
/* -- LAPACK auxiliary routine (version 3.2.1) -- */
/* -- April 2009 -- */
/* This subroutine is identical to SLAQR3 except that it avoids */
/* recursion by calling SLAHQR instead of SLAQR4. */
/* ****************************************************************** */
/* Aggressive early deflation: */
/* This subroutine accepts as input an upper Hessenberg matrix */
/* H and performs an orthogonal similarity transformation */
/* designed to detect and deflate fully converged eigenvalues from */
/* a trailing principal submatrix. On output H has been over- */
/* written by a new Hessenberg matrix that is a perturbation of */
/* an orthogonal similarity transformation of H. It is to be */
/* hoped that the final version of H has many zero subdiagonal */
/* entries. */
/* ****************************************************************** */
/* WANTT (input) LOGICAL */
/* If .TRUE., then the Hessenberg matrix H is fully updated */
/* so that the quasi-triangular Schur factor may be */
/* computed (in cooperation with the calling subroutine). */
/* If .FALSE., then only enough of H is updated to preserve */
/* the eigenvalues. */
/* WANTZ (input) LOGICAL */
/* If .TRUE., then the orthogonal matrix Z is updated so */
/* so that the orthogonal Schur factor may be computed */
/* (in cooperation with the calling subroutine). */
/* If .FALSE., then Z is not referenced. */
/* N (input) INTEGER */
/* The order of the matrix H and (if WANTZ is .TRUE.) the */
/* order of the orthogonal matrix Z. */
/* KTOP (input) INTEGER */
/* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. */
/* KBOT and KTOP together determine an isolated block */
/* along the diagonal of the Hessenberg matrix. */
/* KBOT (input) INTEGER */
/* It is assumed without a check that either */
/* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together */
/* determine an isolated block along the diagonal of the */
/* Hessenberg matrix. */
/* NW (input) INTEGER */
/* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). */
/* H (input/output) REAL array, dimension (LDH,N) */
/* On input the initial N-by-N section of H stores the */
/* Hessenberg matrix undergoing aggressive early deflation. */
/* On output H has been transformed by an orthogonal */
/* similarity transformation, perturbed, and the returned */
/* to Hessenberg form that (it is to be hoped) has some */
/* zero subdiagonal entries. */
/* LDH (input) integer */
/* Leading dimension of H just as declared in the calling */
/* subroutine. N .LE. LDH */
/* ILOZ (input) INTEGER */
/* IHIZ (input) INTEGER */
/* Specify the rows of Z to which transformations must be */
/* Z (input/output) REAL array, dimension (LDZ,N) */
/* IF WANTZ is .TRUE., then on output, the orthogonal */
/* similarity transformation mentioned above has been */
/* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. */
/* If WANTZ is .FALSE., then Z is unreferenced. */
/* LDZ (input) integer */
/* The leading dimension of Z just as declared in the */
/* calling subroutine. 1 .LE. LDZ. */
/* NS (output) integer */
/* The number of unconverged (ie approximate) eigenvalues */
/* returned in SR and SI that may be used as shifts by the */
/* calling subroutine. */
/* ND (output) integer */
/* The number of converged eigenvalues uncovered by this */
/* subroutine. */
/* SR (output) REAL array, dimension KBOT */
/* SI (output) REAL array, dimension KBOT */
/* On output, the real and imaginary parts of approximate */
/* eigenvalues that may be used for shifts are stored in */
/* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and */
/* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. */
/* The real and imaginary parts of converged eigenvalues */
/* are stored in SR(KBOT-ND+1) through SR(KBOT) and */
/* SI(KBOT-ND+1) through SI(KBOT), respectively. */
/* V (workspace) REAL array, dimension (LDV,NW) */
/* An NW-by-NW work array. */
/* LDV (input) integer scalar */
/* The leading dimension of V just as declared in the */
/* calling subroutine. NW .LE. LDV */
/* NH (input) integer scalar */
/* The number of columns of T. NH.GE.NW. */
/* T (workspace) REAL array, dimension (LDT,NW) */
/* LDT (input) integer */
/* The leading dimension of T just as declared in the */
/* calling subroutine. NW .LE. LDT */
/* NV (input) integer */
/* The number of rows of work array WV available for */
/* workspace. NV.GE.NW. */
/* WV (workspace) REAL array, dimension (LDWV,NW) */
/* LDWV (input) integer */
/* The leading dimension of W just as declared in the */
/* calling subroutine. NW .LE. LDV */
/* WORK (workspace) REAL array, dimension LWORK. */
/* On exit, WORK(1) is set to an estimate of the optimal value */
/* of LWORK for the given values of N, NW, KTOP and KBOT. */
/* LWORK (input) integer */
/* The dimension of the work array WORK. LWORK = 2*NW */
/* suffices, but greater efficiency may result from larger */
/* values of LWORK. */
/* If LWORK = -1, then a workspace query is assumed; SLAQR2 */
/* only estimates the optimal workspace size for the given */
/* values of N, NW, KTOP and KBOT. The estimate is returned */
/* in WORK(1). No error message related to LWORK is issued */
/* by XERBLA. Neither H nor Z are accessed. */
/* ================================================================ */
/* Based on contributions by */
/* Karen Braman and Ralph Byers, Department of Mathematics, */
/* University of Kansas, USA */
/* ================================================================ */
/* ==== Estimate optimal workspace. ==== */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--sr;
--si;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
wv_dim1 = *ldwv;
wv_offset = 1 + wv_dim1;
wv -= wv_offset;
--work;
/* Function Body */
/* Computing MIN */
i__1 = *nw, i__2 = *kbot - *ktop + 1;
jw = min(i__1,i__2);
if (jw <= 2) {
lwkopt = 1;
} else {
/* ==== Workspace query call to SGEHRD ==== */
i__1 = jw - 1;
sgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], &
c_n1, &info);
lwk1 = (integer) work[1];
/* ==== Workspace query call to SORMHR ==== */
i__1 = jw - 1;
sormhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1],
&v[v_offset], ldv, &work[1], &c_n1, &info);
lwk2 = (integer) work[1];
/* ==== Optimal workspace ==== */
lwkopt = jw + max(lwk1,lwk2);
}
/* ==== Quick return in case of workspace query. ==== */
if (*lwork == -1) {
work[1] = (real) lwkopt;
return 0;
}
*ns = 0;
*nd = 0;
work[1] = 1.f;
if (*ktop > *kbot) {
return 0;
}
if (*nw < 1) {
return 0;
}
/* ==== Machine constants ==== */
safmin = slamch_("SAFE MINIMUM");
safmax = 1.f / safmin;
slabad_(&safmin, &safmax);
ulp = slamch_("PRECISION");
smlnum = safmin * ((real) (*n) / ulp);
/* ==== Setup deflation window ==== */
/* Computing MIN */
i__1 = *nw, i__2 = *kbot - *ktop + 1;
jw = min(i__1,i__2);
kwtop = *kbot - jw + 1;
if (kwtop == *ktop) {
s = 0.f;
} else {
s = h__[kwtop + (kwtop - 1) * h_dim1];
}
if (*kbot == kwtop) {
/* ==== 1-by-1 deflation window: not much to do ==== */
sr[kwtop] = h__[kwtop + kwtop * h_dim1];
si[kwtop] = 0.f;
*ns = 1;
*nd = 0;
/* Computing MAX */
r__2 = smlnum, r__3 = ulp * (r__1 = h__[kwtop + kwtop * h_dim1], dabs(
r__1));
if (dabs(s) <= dmax(r__2,r__3)) {
*ns = 0;
*nd = 1;
if (kwtop > *ktop) {
h__[kwtop + (kwtop - 1) * h_dim1] = 0.f;
}
}
work[1] = 1.f;
return 0;
}
/* ==== Convert to spike-triangular form. (In case of a */
/* . rare QR failure, this routine continues to do */
/* . aggressive early deflation using that part of */
/* . the deflation window that converged using INFQR */
/* . here and there to keep track.) ==== */
slacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset],
ldt);
i__1 = jw - 1;
i__2 = *ldh + 1;
i__3 = *ldt + 1;
scopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], &
i__3);
slaset_("A", &jw, &jw, &c_b12, &c_b13, &v[v_offset], ldv);
slahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[kwtop],
&si[kwtop], &c__1, &jw, &v[v_offset], ldv, &infqr);
/* ==== STREXC needs a clean margin near the diagonal ==== */
i__1 = jw - 3;
for (j = 1; j <= i__1; ++j) {
t[j + 2 + j * t_dim1] = 0.f;
t[j + 3 + j * t_dim1] = 0.f;
}
if (jw > 2) {
t[jw + (jw - 2) * t_dim1] = 0.f;
}
/* ==== Deflation detection loop ==== */
*ns = jw;
ilst = infqr + 1;
L20:
if (ilst <= *ns) {
if (*ns == 1) {
bulge = FALSE_;
} else {
bulge = t[*ns + (*ns - 1) * t_dim1] != 0.f;
}
/* ==== Small spike tip test for deflation ==== */
if (! bulge) {
/* ==== Real eigenvalue ==== */
foo = (r__1 = t[*ns + *ns * t_dim1], dabs(r__1));
if (foo == 0.f) {
foo = dabs(s);
}
/* Computing MAX */
r__2 = smlnum, r__3 = ulp * foo;
if ((r__1 = s * v[*ns * v_dim1 + 1], dabs(r__1)) <= dmax(r__2,
r__3)) {
/* ==== Deflatable ==== */
--(*ns);
} else {
/* ==== Undeflatable. Move it up out of the way. */
/* . (STREXC can not fail in this case.) ==== */
ifst = *ns;
strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst,
&ilst, &work[1], &info);
++ilst;
}
} else {
/* ==== Complex conjugate pair ==== */
foo = (r__3 = t[*ns + *ns * t_dim1], dabs(r__3)) + sqrt((r__1 = t[
*ns + (*ns - 1) * t_dim1], dabs(r__1))) * sqrt((r__2 = t[*
ns - 1 + *ns * t_dim1], dabs(r__2)));
if (foo == 0.f) {
foo = dabs(s);
}
/* Computing MAX */
r__3 = (r__1 = s * v[*ns * v_dim1 + 1], dabs(r__1)), r__4 = (r__2
= s * v[(*ns - 1) * v_dim1 + 1], dabs(r__2));
/* Computing MAX */
r__5 = smlnum, r__6 = ulp * foo;
if (dmax(r__3,r__4) <= dmax(r__5,r__6)) {
/* ==== Deflatable ==== */
*ns += -2;
} else {
/* ==== Undeflatable. Move them up out of the way. */
/* . Fortunately, STREXC does the right thing with */
/* . ILST in case of a rare exchange failure. ==== */
ifst = *ns;
strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst,
&ilst, &work[1], &info);
ilst += 2;
}
}
/* ==== End deflation detection loop ==== */
goto L20;
}
/* ==== Return to Hessenberg form ==== */
if (*ns == 0) {
s = 0.f;
}
if (*ns < jw) {
/* ==== sorting diagonal blocks of T improves accuracy for */
/* . graded matrices. Bubble sort deals well with */
/* . exchange failures. ==== */
sorted = FALSE_;
i__ = *ns + 1;
L30:
if (sorted) {
goto L50;
}
sorted = TRUE_;
kend = i__ - 1;
i__ = infqr + 1;
if (i__ == *ns) {
k = i__ + 1;
} else if (t[i__ + 1 + i__ * t_dim1] == 0.f) {
k = i__ + 1;
} else {
k = i__ + 2;
}
L40:
if (k <= kend) {
if (k == i__ + 1) {
evi = (r__1 = t[i__ + i__ * t_dim1], dabs(r__1));
} else {
evi = (r__3 = t[i__ + i__ * t_dim1], dabs(r__3)) + sqrt((r__1
= t[i__ + 1 + i__ * t_dim1], dabs(r__1))) * sqrt((
r__2 = t[i__ + (i__ + 1) * t_dim1], dabs(r__2)));
}
if (k == kend) {
evk = (r__1 = t[k + k * t_dim1], dabs(r__1));
} else if (t[k + 1 + k * t_dim1] == 0.f) {
evk = (r__1 = t[k + k * t_dim1], dabs(r__1));
} else {
evk = (r__3 = t[k + k * t_dim1], dabs(r__3)) + sqrt((r__1 = t[
k + 1 + k * t_dim1], dabs(r__1))) * sqrt((r__2 = t[k
+ (k + 1) * t_dim1], dabs(r__2)));
}
if (evi >= evk) {
i__ = k;
} else {
sorted = FALSE_;
ifst = i__;
ilst = k;
strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst,
&ilst, &work[1], &info);
if (info == 0) {
i__ = ilst;
} else {
i__ = k;
}
}
if (i__ == kend) {
k = i__ + 1;
} else if (t[i__ + 1 + i__ * t_dim1] == 0.f) {
k = i__ + 1;
} else {
k = i__ + 2;
}
goto L40;
}
goto L30;
L50:
;
}
/* ==== Restore shift/eigenvalue array from T ==== */
i__ = jw;
L60:
if (i__ >= infqr + 1) {
if (i__ == infqr + 1) {
sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1];
si[kwtop + i__ - 1] = 0.f;
--i__;
} else if (t[i__ + (i__ - 1) * t_dim1] == 0.f) {
sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1];
si[kwtop + i__ - 1] = 0.f;
--i__;
} else {
aa = t[i__ - 1 + (i__ - 1) * t_dim1];
cc = t[i__ + (i__ - 1) * t_dim1];
bb = t[i__ - 1 + i__ * t_dim1];
dd = t[i__ + i__ * t_dim1];
slanv2_(&aa, &bb, &cc, &dd, &sr[kwtop + i__ - 2], &si[kwtop + i__
- 2], &sr[kwtop + i__ - 1], &si[kwtop + i__ - 1], &cs, &
sn);
i__ += -2;
}
goto L60;
}
if (*ns < jw || s == 0.f) {
if (*ns > 1 && s != 0.f) {
/* ==== Reflect spike back into lower triangle ==== */
scopy_(ns, &v[v_offset], ldv, &work[1], &c__1);
beta = work[1];
slarfg_(ns, &beta, &work[2], &c__1, &tau);
work[1] = 1.f;
i__1 = jw - 2;
i__2 = jw - 2;
slaset_("L", &i__1, &i__2, &c_b12, &c_b12, &t[t_dim1 + 3], ldt);
slarf_("L", ns, &jw, &work[1], &c__1, &tau, &t[t_offset], ldt, &
work[jw + 1]);
slarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, &
work[jw + 1]);
slarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, &
work[jw + 1]);
i__1 = *lwork - jw;
sgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1]
, &i__1, &info);
}
/* ==== Copy updated reduced window into place ==== */
if (kwtop > 1) {
h__[kwtop + (kwtop - 1) * h_dim1] = s * v[v_dim1 + 1];
}
slacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1]
, ldh);
i__1 = jw - 1;
i__2 = *ldt + 1;
i__3 = *ldh + 1;
scopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1],
&i__3);
/* ==== Accumulate orthogonal matrix in order update */
/* . H and Z, if requested. ==== */
if (*ns > 1 && s != 0.f) {
i__1 = *lwork - jw;
sormhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1],
&v[v_offset], ldv, &work[jw + 1], &i__1, &info);
}
/* ==== Update vertical slab in H ==== */
if (*wantt) {
ltop = 1;
} else {
ltop = *ktop;
}
i__1 = kwtop - 1;
i__2 = *nv;
for (krow = ltop; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow +=
i__2) {
/* Computing MIN */
i__3 = *nv, i__4 = kwtop - krow;
kln = min(i__3,i__4);
sgemm_("N", "N", &kln, &jw, &jw, &c_b13, &h__[krow + kwtop *
h_dim1], ldh, &v[v_offset], ldv, &c_b12, &wv[wv_offset],
ldwv);
slacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop *
h_dim1], ldh);
}
/* ==== Update horizontal slab in H ==== */
if (*wantt) {
i__2 = *n;
i__1 = *nh;
for (kcol = *kbot + 1; i__1 < 0 ? kcol >= i__2 : kcol <= i__2;
kcol += i__1) {
/* Computing MIN */
i__3 = *nh, i__4 = *n - kcol + 1;
kln = min(i__3,i__4);
sgemm_("C", "N", &jw, &kln, &jw, &c_b13, &v[v_offset], ldv, &
h__[kwtop + kcol * h_dim1], ldh, &c_b12, &t[t_offset],
ldt);
slacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol *
h_dim1], ldh);
}
}
/* ==== Update vertical slab in Z ==== */
if (*wantz) {
i__1 = *ihiz;
i__2 = *nv;
for (krow = *iloz; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow +=
i__2) {
/* Computing MIN */
i__3 = *nv, i__4 = *ihiz - krow + 1;
kln = min(i__3,i__4);
sgemm_("N", "N", &kln, &jw, &jw, &c_b13, &z__[krow + kwtop *
z_dim1], ldz, &v[v_offset], ldv, &c_b12, &wv[
wv_offset], ldwv);
slacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow +
kwtop * z_dim1], ldz);
}
}
}
*nd = jw - *ns;
/* . INFQR from the spike length takes care */
/* . of the case of a rare QR failure while */
/* . calculating eigenvalues of the deflation */
/* . window.) ==== */
*ns -= infqr;
/* ==== Return optimal workspace. ==== */
work[1] = (real) lwkopt;
/* ==== End of SLAQR2 ==== */
return 0;
} /* slaqr2_ */
/* Subroutine */ int slaqr0_(logical *wantt, logical *wantz, integer *n,
integer *ilo, integer *ihi, real *h__, integer *ldh, real *wr, real *
wi, integer *iloz, integer *ihiz, real *z__, integer *ldz, real *work,
integer *lwork, integer *info)
{
/* System generated locals */
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
/* Local variables */
integer i__, k;
real aa, bb, cc, dd;
integer ld;
real cs;
integer nh, it, ks, kt;
real sn;
integer ku, kv, ls, ns;
real ss;
integer nw, inf, kdu, nho, nve, kwh, nsr, nwr, kwv, ndec, ndfl, kbot,
nmin;
real swap;
integer ktop;
real zdum[1] /* was [1][1] */;
integer kacc22, itmax, nsmax, nwmax, kwtop;
extern /* Subroutine */ int slanv2_(real *, real *, real *, real *, real *
, real *, real *, real *, real *, real *), slaqr3_(logical *,
logical *, integer *, integer *, integer *, integer *, real *,
integer *, integer *, integer *, real *, integer *, integer *,
integer *, real *, real *, real *, integer *, integer *, real *,
integer *, integer *, real *, integer *, real *, integer *),
slaqr4_(logical *, logical *, integer *, integer *, integer *,
real *, integer *, real *, real *, integer *, integer *, real *,
integer *, real *, integer *, integer *), slaqr5_(logical *,
logical *, integer *, integer *, integer *, integer *, integer *,
real *, real *, real *, integer *, integer *, integer *, real *,
integer *, real *, integer *, real *, integer *, integer *, real *
, integer *, integer *, real *, integer *);
integer nibble;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
char jbcmpz[2];
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 *);
integer nwupbd;
logical sorted;
integer lwkopt;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLAQR0 computes the eigenvalues of a 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 */
/* ========= */
/* WANTT (input) LOGICAL */
/* = .TRUE. : the full Schur form T is required; */
/* = .FALSE.: only eigenvalues are required. */
/* WANTZ (input) LOGICAL */
/* = .TRUE. : the matrix of Schur vectors Z is required; */
/* = .FALSE.: Schur vectors are not required. */
/* N (input) INTEGER */
/* The order of the matrix H. N .GE. 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 and, if ILO.GT.1, */
/* H(ILO,ILO-1) is zero. 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. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. */
/* If N = 0, then ILO = 1 and IHI = 0. */
/* H (input/output) REAL array, dimension (LDH,N) */
/* On entry, the upper Hessenberg matrix H. */
/* On exit, if INFO = 0 and WANTT is .TRUE., then 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).LT.0. If INFO = 0 and WANTT is */
/* .FALSE., then the contents of H are unspecified on exit. */
/* (The output value of H when INFO.GT.0 is given under the */
/* description of INFO below.) */
/* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and */
/* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH .GE. max(1,N). */
/* WR (output) REAL array, dimension (IHI) */
/* WI (output) REAL array, dimension (IHI) */
/* The real and imaginary parts, respectively, of the computed */
/* eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI) */
/* and WI(ILO:IHI). 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) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then */
/* 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). */
/* ILOZ (input) INTEGER */
/* IHIZ (input) INTEGER */
/* Specify the rows of Z to which transformations must be */
/* applied if WANTZ is .TRUE.. */
/* 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. */
/* Z (input/output) REAL array, dimension (LDZ,IHI) */
/* If WANTZ is .FALSE., then Z is not referenced. */
/* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is */
/* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the */
/* orthogonal Schur factor of H(ILO:IHI,ILO:IHI). */
/* (The output value of Z when INFO.GT.0 is given under */
/* the description of INFO below.) */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. if WANTZ is .TRUE. */
/* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. */
/* WORK (workspace/output) REAL array, dimension LWORK */
/* On exit, if LWORK = -1, WORK(1) returns an estimate of */
/* the optimal value for LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK .GE. max(1,N) */
/* is sufficient, but LWORK typically as large as 6*N may */
/* be required for optimal performance. A workspace query */
/* to determine the optimal workspace size is recommended. */
/* If LWORK = -1, then SLAQR0 does a workspace query. */
/* In this case, SLAQR0 checks the input parameters and */
/* estimates the optimal workspace size for the given */
/* values of N, ILO and IHI. The estimate is returned */
/* in WORK(1). No error message related to LWORK is */
/* issued by XERBLA. Neither H nor Z are accessed. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* .GT. 0: if INFO = i, SLAQR0 failed to compute all of */
/* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */
/* and WI contain those eigenvalues which have been */
/* successfully computed. (Failures are rare.) */
/* If INFO .GT. 0 and WANT is .FALSE., then on exit, */
/* the remaining unconverged eigenvalues are the eigen- */
/* values of the upper Hessenberg matrix rows and */
/* columns ILO through INFO of the final, output */
/* value of H. */
/* If INFO .GT. 0 and WANTT is .TRUE., then on exit */
/* (*) (initial value of H)*U = U*(final value of H) */
/* where U is an orthogonal matrix. The final */
/* value of H is upper Hessenberg and quasi-triangular */
/* in rows and columns INFO+1 through IHI. */
/* If INFO .GT. 0 and WANTZ is .TRUE., then on exit */
/* (final value of Z(ILO:IHI,ILOZ:IHIZ) */
/* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U */
/* where U is the orthogonal matrix in (*) (regard- */
/* less of the value of WANTT.) */
/* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not */
/* accessed. */
/* ================================================================ */
/* Based on contributions by */
/* Karen Braman and Ralph Byers, Department of Mathematics, */
/* University of Kansas, USA */
/* ================================================================ */
/* References: */
/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
/* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */
/* Performance, SIAM Journal of Matrix Analysis, volume 23, pages */
/* 929--947, 2002. */
/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
/* Algorithm Part II: Aggressive Early Deflation, SIAM Journal */
/* of Matrix Analysis, volume 23, pages 948--973, 2002. */
/* ================================================================ */
/* .. Parameters .. */
/* ==== Matrices of order NTINY or smaller must be processed by */
/* . SLAHQR because of insufficient subdiagonal scratch space. */
/* . (This is a hard limit.) ==== */
/* ==== Exceptional deflation windows: try to cure rare */
/* . slow convergence by varying the size of the */
/* . deflation window after KEXNW iterations. ==== */
/* ==== Exceptional shifts: try to cure rare slow convergence */
/* . with ad-hoc exceptional shifts every KEXSH iterations. */
/* . ==== */
/* ==== The constants WILK1 and WILK2 are used to form the */
/* . exceptional shifts. ==== */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* 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 */
*info = 0;
/* ==== Quick return for N = 0: nothing to do. ==== */
if (*n == 0) {
work[1] = 1.f;
return 0;
}
if (*n <= 11) {
/* ==== Tiny matrices must use SLAHQR. ==== */
lwkopt = 1;
if (*lwork != -1) {
slahqr_(wantt, wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &
wi[1], iloz, ihiz, &z__[z_offset], ldz, info);
}
} else {
/* ==== Use small bulge multi-shift QR with aggressive early */
/* . deflation on larger-than-tiny matrices. ==== */
/* ==== Hope for the best. ==== */
*info = 0;
/* ==== Set up job flags for ILAENV. ==== */
if (*wantt) {
*(unsigned char *)jbcmpz = 'S';
} else {
*(unsigned char *)jbcmpz = 'E';
}
if (*wantz) {
*(unsigned char *)&jbcmpz[1] = 'V';
} else {
*(unsigned char *)&jbcmpz[1] = 'N';
}
/* ==== NWR = recommended deflation window size. At this */
/* . point, N .GT. NTINY = 11, so there is enough */
/* . subdiagonal workspace for NWR.GE.2 as required. */
/* . (In fact, there is enough subdiagonal space for */
/* . NWR.GE.3.) ==== */
nwr = ilaenv_(&c__13, "SLAQR0", jbcmpz, n, ilo, ihi, lwork);
nwr = max(2,nwr);
/* Computing MIN */
i__1 = *ihi - *ilo + 1, i__2 = (*n - 1) / 3, i__1 = min(i__1,i__2);
nwr = min(i__1,nwr);
/* ==== NSR = recommended number of simultaneous shifts. */
/* . At this point N .GT. NTINY = 11, so there is at */
/* . enough subdiagonal workspace for NSR to be even */
/* . and greater than or equal to two as required. ==== */
nsr = ilaenv_(&c__15, "SLAQR0", jbcmpz, n, ilo, ihi, lwork);
/* Computing MIN */
i__1 = nsr, i__2 = (*n + 6) / 9, i__1 = min(i__1,i__2), i__2 = *ihi -
*ilo;
nsr = min(i__1,i__2);
/* Computing MAX */
i__1 = 2, i__2 = nsr - nsr % 2;
nsr = max(i__1,i__2);
/* ==== Estimate optimal workspace ==== */
/* ==== Workspace query call to SLAQR3 ==== */
i__1 = nwr + 1;
slaqr3_(wantt, wantz, n, ilo, ihi, &i__1, &h__[h_offset], ldh, iloz,
ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], &h__[
h_offset], ldh, n, &h__[h_offset], ldh, n, &h__[h_offset],
ldh, &work[1], &c_n1);
/* ==== Optimal workspace = MAX(SLAQR5, SLAQR3) ==== */
/* Computing MAX */
i__1 = nsr * 3 / 2, i__2 = (integer) work[1];
lwkopt = max(i__1,i__2);
/* ==== Quick return in case of workspace query. ==== */
if (*lwork == -1) {
work[1] = (real) lwkopt;
return 0;
}
/* ==== SLAHQR/SLAQR0 crossover point ==== */
nmin = ilaenv_(&c__12, "SLAQR0", jbcmpz, n, ilo, ihi, lwork);
nmin = max(11,nmin);
/* ==== Nibble crossover point ==== */
nibble = ilaenv_(&c__14, "SLAQR0", jbcmpz, n, ilo, ihi, lwork);
nibble = max(0,nibble);
/* ==== Accumulate reflections during ttswp? Use block */
/* . 2-by-2 structure during matrix-matrix multiply? ==== */
kacc22 = ilaenv_(&c__16, "SLAQR0", jbcmpz, n, ilo, ihi, lwork);
kacc22 = max(0,kacc22);
kacc22 = min(2,kacc22);
/* ==== NWMAX = the largest possible deflation window for */
/* . which there is sufficient workspace. ==== */
/* Computing MIN */
i__1 = (*n - 1) / 3, i__2 = *lwork / 2;
nwmax = min(i__1,i__2);
nw = nwmax;
/* ==== NSMAX = the Largest number of simultaneous shifts */
/* . for which there is sufficient workspace. ==== */
/* Computing MIN */
i__1 = (*n + 6) / 9, i__2 = (*lwork << 1) / 3;
nsmax = min(i__1,i__2);
nsmax -= nsmax % 2;
/* ==== NDFL: an iteration count restarted at deflation. ==== */
ndfl = 1;
/* ==== ITMAX = iteration limit ==== */
/* Computing MAX */
i__1 = 10, i__2 = *ihi - *ilo + 1;
itmax = max(i__1,i__2) * 30;
/* ==== Last row and column in the active block ==== */
kbot = *ihi;
/* ==== Main Loop ==== */
i__1 = itmax;
for (it = 1; it <= i__1; ++it) {
/* ==== Done when KBOT falls below ILO ==== */
if (kbot < *ilo) {
goto L90;
}
/* ==== Locate active block ==== */
i__2 = *ilo + 1;
for (k = kbot; k >= i__2; --k) {
if (h__[k + (k - 1) * h_dim1] == 0.f) {
goto L20;
}
/* L10: */
}
k = *ilo;
L20:
ktop = k;
/* ==== Select deflation window size: */
/* . Typical Case: */
/* . If possible and advisable, nibble the entire */
/* . active block. If not, use size MIN(NWR,NWMAX) */
/* . or MIN(NWR+1,NWMAX) depending upon which has */
/* . the smaller corresponding subdiagonal entry */
/* . (a heuristic). */
/* . */
/* . Exceptional Case: */
/* . If there have been no deflations in KEXNW or */
/* . more iterations, then vary the deflation window */
/* . size. At first, because, larger windows are, */
/* . in general, more powerful than smaller ones, */
/* . rapidly increase the window to the maximum possible. */
/* . Then, gradually reduce the window size. ==== */
nh = kbot - ktop + 1;
nwupbd = min(nh,nwmax);
if (ndfl < 5) {
nw = min(nwupbd,nwr);
} else {
/* Computing MIN */
i__2 = nwupbd, i__3 = nw << 1;
nw = min(i__2,i__3);
}
if (nw < nwmax) {
if (nw >= nh - 1) {
nw = nh;
} else {
kwtop = kbot - nw + 1;
if ((r__1 = h__[kwtop + (kwtop - 1) * h_dim1], dabs(r__1))
> (r__2 = h__[kwtop - 1 + (kwtop - 2) * h_dim1],
dabs(r__2))) {
++nw;
}
}
}
if (ndfl < 5) {
ndec = -1;
} else if (ndec >= 0 || nw >= nwupbd) {
++ndec;
if (nw - ndec < 2) {
ndec = 0;
}
nw -= ndec;
}
/* ==== Aggressive early deflation: */
/* . split workspace under the subdiagonal into */
/* . - an nw-by-nw work array V in the lower */
/* . left-hand-corner, */
/* . - an NW-by-at-least-NW-but-more-is-better */
/* . (NW-by-NHO) horizontal work array along */
/* . the bottom edge, */
/* . - an at-least-NW-but-more-is-better (NHV-by-NW) */
/* . vertical work array along the left-hand-edge. */
/* . ==== */
kv = *n - nw + 1;
kt = nw + 1;
nho = *n - nw - 1 - kt + 1;
kwv = nw + 2;
nve = *n - nw - kwv + 1;
/* ==== Aggressive early deflation ==== */
slaqr3_(wantt, wantz, n, &ktop, &kbot, &nw, &h__[h_offset], ldh,
iloz, ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1],
&h__[kv + h_dim1], ldh, &nho, &h__[kv + kt * h_dim1],
ldh, &nve, &h__[kwv + h_dim1], ldh, &work[1], lwork);
/* ==== Adjust KBOT accounting for new deflations. ==== */
kbot -= ld;
/* ==== KS points to the shifts. ==== */
ks = kbot - ls + 1;
/* ==== Skip an expensive QR sweep if there is a (partly */
/* . heuristic) reason to expect that many eigenvalues */
/* . will deflate without it. Here, the QR sweep is */
/* . skipped if many eigenvalues have just been deflated */
/* . or if the remaining active block is small. */
if (ld == 0 || ld * 100 <= nw * nibble && kbot - ktop + 1 > min(
nmin,nwmax)) {
/* ==== NS = nominal number of simultaneous shifts. */
/* . This may be lowered (slightly) if SLAQR3 */
/* . did not provide that many shifts. ==== */
/* Computing MIN */
/* Computing MAX */
i__4 = 2, i__5 = kbot - ktop;
i__2 = min(nsmax,nsr), i__3 = max(i__4,i__5);
ns = min(i__2,i__3);
ns -= ns % 2;
/* ==== If there have been no deflations */
/* . in a multiple of KEXSH iterations, */
/* . then try exceptional shifts. */
/* . Otherwise use shifts provided by */
/* . SLAQR3 above or from the eigenvalues */
/* . of a trailing principal submatrix. ==== */
if (ndfl % 6 == 0) {
ks = kbot - ns + 1;
/* Computing MAX */
i__3 = ks + 1, i__4 = ktop + 2;
i__2 = max(i__3,i__4);
for (i__ = kbot; i__ >= i__2; i__ += -2) {
ss = (r__1 = h__[i__ + (i__ - 1) * h_dim1], dabs(r__1)
) + (r__2 = h__[i__ - 1 + (i__ - 2) * h_dim1],
dabs(r__2));
aa = ss * .75f + h__[i__ + i__ * h_dim1];
bb = ss;
cc = ss * -.4375f;
dd = aa;
slanv2_(&aa, &bb, &cc, &dd, &wr[i__ - 1], &wi[i__ - 1]
, &wr[i__], &wi[i__], &cs, &sn);
/* L30: */
}
if (ks == ktop) {
wr[ks + 1] = h__[ks + 1 + (ks + 1) * h_dim1];
wi[ks + 1] = 0.f;
wr[ks] = wr[ks + 1];
wi[ks] = wi[ks + 1];
}
} else {
/* ==== Got NS/2 or fewer shifts? Use SLAQR4 or */
/* . SLAHQR on a trailing principal submatrix to */
/* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, */
/* . there is enough space below the subdiagonal */
/* . to fit an NS-by-NS scratch array.) ==== */
if (kbot - ks + 1 <= ns / 2) {
ks = kbot - ns + 1;
kt = *n - ns + 1;
slacpy_("A", &ns, &ns, &h__[ks + ks * h_dim1], ldh, &
h__[kt + h_dim1], ldh);
if (ns > nmin) {
slaqr4_(&c_false, &c_false, &ns, &c__1, &ns, &h__[
kt + h_dim1], ldh, &wr[ks], &wi[ks], &
c__1, &c__1, zdum, &c__1, &work[1], lwork,
&inf);
} else {
slahqr_(&c_false, &c_false, &ns, &c__1, &ns, &h__[
kt + h_dim1], ldh, &wr[ks], &wi[ks], &
c__1, &c__1, zdum, &c__1, &inf);
}
ks += inf;
/* ==== In case of a rare QR failure use */
/* . eigenvalues of the trailing 2-by-2 */
/* . principal submatrix. ==== */
if (ks >= kbot) {
aa = h__[kbot - 1 + (kbot - 1) * h_dim1];
cc = h__[kbot + (kbot - 1) * h_dim1];
bb = h__[kbot - 1 + kbot * h_dim1];
dd = h__[kbot + kbot * h_dim1];
slanv2_(&aa, &bb, &cc, &dd, &wr[kbot - 1], &wi[
kbot - 1], &wr[kbot], &wi[kbot], &cs, &sn)
;
ks = kbot - 1;
}
}
if (kbot - ks + 1 > ns) {
/* ==== Sort the shifts (Helps a little) */
/* . Bubble sort keeps complex conjugate */
/* . pairs together. ==== */
sorted = FALSE_;
i__2 = ks + 1;
for (k = kbot; k >= i__2; --k) {
if (sorted) {
goto L60;
}
sorted = TRUE_;
i__3 = k - 1;
for (i__ = ks; i__ <= i__3; ++i__) {
if ((r__1 = wr[i__], dabs(r__1)) + (r__2 = wi[
i__], dabs(r__2)) < (r__3 = wr[i__ +
1], dabs(r__3)) + (r__4 = wi[i__ + 1],
dabs(r__4))) {
sorted = FALSE_;
swap = wr[i__];
wr[i__] = wr[i__ + 1];
wr[i__ + 1] = swap;
swap = wi[i__];
wi[i__] = wi[i__ + 1];
wi[i__ + 1] = swap;
}
/* L40: */
}
/* L50: */
}
L60:
;
}
/* ==== Shuffle shifts into pairs of real shifts */
/* . and pairs of complex conjugate shifts */
/* . assuming complex conjugate shifts are */
/* . already adjacent to one another. (Yes, */
/* . they are.) ==== */
i__2 = ks + 2;
for (i__ = kbot; i__ >= i__2; i__ += -2) {
if (wi[i__] != -wi[i__ - 1]) {
swap = wr[i__];
wr[i__] = wr[i__ - 1];
wr[i__ - 1] = wr[i__ - 2];
wr[i__ - 2] = swap;
swap = wi[i__];
wi[i__] = wi[i__ - 1];
wi[i__ - 1] = wi[i__ - 2];
wi[i__ - 2] = swap;
}
/* L70: */
}
}
/* ==== If there are only two shifts and both are */
/* . real, then use only one. ==== */
if (kbot - ks + 1 == 2) {
if (wi[kbot] == 0.f) {
if ((r__1 = wr[kbot] - h__[kbot + kbot * h_dim1],
dabs(r__1)) < (r__2 = wr[kbot - 1] - h__[kbot
+ kbot * h_dim1], dabs(r__2))) {
wr[kbot - 1] = wr[kbot];
} else {
wr[kbot] = wr[kbot - 1];
}
}
}
/* ==== Use up to NS of the the smallest magnatiude */
/* . shifts. If there aren't NS shifts available, */
/* . then use them all, possibly dropping one to */
/* . make the number of shifts even. ==== */
/* Computing MIN */
i__2 = ns, i__3 = kbot - ks + 1;
ns = min(i__2,i__3);
ns -= ns % 2;
ks = kbot - ns + 1;
/* ==== Small-bulge multi-shift QR sweep: */
/* . split workspace under the subdiagonal into */
/* . - a KDU-by-KDU work array U in the lower */
/* . left-hand-corner, */
/* . - a KDU-by-at-least-KDU-but-more-is-better */
/* . (KDU-by-NHo) horizontal work array WH along */
/* . the bottom edge, */
/* . - and an at-least-KDU-but-more-is-better-by-KDU */
/* . (NVE-by-KDU) vertical work WV arrow along */
/* . the left-hand-edge. ==== */
kdu = ns * 3 - 3;
ku = *n - kdu + 1;
kwh = kdu + 1;
nho = *n - kdu - 3 - (kdu + 1) + 1;
kwv = kdu + 4;
nve = *n - kdu - kwv + 1;
/* ==== Small-bulge multi-shift QR sweep ==== */
slaqr5_(wantt, wantz, &kacc22, n, &ktop, &kbot, &ns, &wr[ks],
&wi[ks], &h__[h_offset], ldh, iloz, ihiz, &z__[
z_offset], ldz, &work[1], &c__3, &h__[ku + h_dim1],
ldh, &nve, &h__[kwv + h_dim1], ldh, &nho, &h__[ku +
kwh * h_dim1], ldh);
}
/* ==== Note progress (or the lack of it). ==== */
if (ld > 0) {
ndfl = 1;
} else {
++ndfl;
}
/* ==== End of main loop ==== */
/* L80: */
}
/* ==== Iteration limit exceeded. Set INFO to show where */
/* . the problem occurred and exit. ==== */
*info = kbot;
L90:
;
}
/* ==== Return the optimal value of LWORK. ==== */
work[1] = (real) lwkopt;
/* ==== End of SLAQR0 ==== */
return 0;
} /* slaqr0_ */
/* Subroutine */
int slaqr0_(logical *wantt, logical *wantz, integer *n, integer *ilo, integer *ihi, real *h__, integer *ldh, real *wr, real * wi, integer *iloz, integer *ihiz, real *z__, integer *ldz, real *work, integer *lwork, integer *info)
{
/* System generated locals */
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
/* Local variables */
integer i__, k;
real aa, bb, cc, dd;
integer ld;
real cs;
integer nh, it, ks, kt;
real sn;
integer ku, kv, ls, ns;
real ss;
integer nw, inf, kdu, nho, nve, kwh, nsr, nwr, kwv, ndec, ndfl, kbot, nmin;
real swap;
integer ktop;
real zdum[1] /* was [1][1] */
;
integer kacc22, itmax, nsmax, nwmax, kwtop;
extern /* Subroutine */
int slanv2_(real *, real *, real *, real *, real * , real *, real *, real *, real *, real *), slaqr3_(logical *, logical *, integer *, integer *, integer *, integer *, real *, integer *, integer *, integer *, real *, integer *, integer *, integer *, real *, real *, real *, integer *, integer *, real *, integer *, integer *, real *, integer *, real *, integer *), slaqr4_(logical *, logical *, integer *, integer *, integer *, real *, integer *, real *, real *, integer *, integer *, real *, integer *, real *, integer *, integer *), slaqr5_(logical *, logical *, integer *, integer *, integer *, integer *, integer *, real *, real *, real *, integer *, integer *, integer *, real *, integer *, real *, integer *, real *, integer *, integer *, real * , integer *, integer *, real *, integer *);
integer nibble;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);
char jbcmpz[2];
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 *);
integer nwupbd;
logical sorted;
integer lwkopt;
/* -- 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 .. */
/* ==== Matrices of order NTINY or smaller must be processed by */
/* . SLAHQR because of insufficient subdiagonal scratch space. */
/* . (This is a hard limit.) ==== */
/* ==== Exceptional deflation windows: try to cure rare */
/* . slow convergence by varying the size of the */
/* . deflation window after KEXNW iterations. ==== */
/* ==== Exceptional shifts: try to cure rare slow convergence */
/* . with ad-hoc exceptional shifts every KEXSH iterations. */
/* . ==== */
/* ==== The constants WILK1 and WILK2 are used to form the */
/* . exceptional shifts. ==== */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* 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 */
*info = 0;
/* ==== Quick return for N = 0: nothing to do. ==== */
if (*n == 0)
{
work[1] = 1.f;
return 0;
}
if (*n <= 11)
{
/* ==== Tiny matrices must use SLAHQR. ==== */
lwkopt = 1;
if (*lwork != -1)
{
slahqr_(wantt, wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], & wi[1], iloz, ihiz, &z__[z_offset], ldz, info);
}
}
else
{
/* ==== Use small bulge multi-shift QR with aggressive early */
/* . deflation on larger-than-tiny matrices. ==== */
/* ==== Hope for the best. ==== */
*info = 0;
/* ==== Set up job flags for ILAENV. ==== */
if (*wantt)
{
*(unsigned char *)jbcmpz = 'S';
}
else
{
*(unsigned char *)jbcmpz = 'E';
}
if (*wantz)
{
*(unsigned char *)&jbcmpz[1] = 'V';
}
else
{
*(unsigned char *)&jbcmpz[1] = 'N';
}
/* ==== NWR = recommended deflation window size. At this */
/* . point, N .GT. NTINY = 11, so there is enough */
/* . subdiagonal workspace for NWR.GE.2 as required. */
/* . (In fact, there is enough subdiagonal space for */
/* . NWR.GE.3.) ==== */
nwr = ilaenv_(&c__13, "SLAQR0", jbcmpz, n, ilo, ihi, lwork);
nwr = max(2,nwr);
/* Computing MIN */
i__1 = *ihi - *ilo + 1;
i__2 = (*n - 1) / 3;
i__1 = min(i__1,i__2); // ; expr subst
nwr = min(i__1,nwr);
/* ==== NSR = recommended number of simultaneous shifts. */
/* . At this point N .GT. NTINY = 11, so there is at */
/* . enough subdiagonal workspace for NSR to be even */
/* . and greater than or equal to two as required. ==== */
nsr = ilaenv_(&c__15, "SLAQR0", jbcmpz, n, ilo, ihi, lwork);
/* Computing MIN */
i__1 = nsr, i__2 = (*n + 6) / 9;
i__1 = min(i__1,i__2);
i__2 = *ihi - *ilo; // ; expr subst
nsr = min(i__1,i__2);
/* Computing MAX */
i__1 = 2;
i__2 = nsr - nsr % 2; // , expr subst
nsr = max(i__1,i__2);
/* ==== Estimate optimal workspace ==== */
/* ==== Workspace query call to SLAQR3 ==== */
i__1 = nwr + 1;
slaqr3_(wantt, wantz, n, ilo, ihi, &i__1, &h__[h_offset], ldh, iloz, ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], &h__[ h_offset], ldh, n, &h__[h_offset], ldh, n, &h__[h_offset], ldh, &work[1], &c_n1);
/* ==== Optimal workspace = MAX(SLAQR5, SLAQR3) ==== */
/* Computing MAX */
i__1 = nsr * 3 / 2;
i__2 = (integer) work[1]; // , expr subst
lwkopt = max(i__1,i__2);
/* ==== Quick return in case of workspace query. ==== */
if (*lwork == -1)
{
work[1] = (real) lwkopt;
return 0;
}
/* ==== SLAHQR/SLAQR0 crossover point ==== */
nmin = ilaenv_(&c__12, "SLAQR0", jbcmpz, n, ilo, ihi, lwork);
nmin = max(11,nmin);
/* ==== Nibble crossover point ==== */
nibble = ilaenv_(&c__14, "SLAQR0", jbcmpz, n, ilo, ihi, lwork);
nibble = max(0,nibble);
/* ==== Accumulate reflections during ttswp? Use block */
/* . 2-by-2 structure during matrix-matrix multiply? ==== */
kacc22 = ilaenv_(&c__16, "SLAQR0", jbcmpz, n, ilo, ihi, lwork);
kacc22 = max(0,kacc22);
kacc22 = min(2,kacc22);
/* ==== NWMAX = the largest possible deflation window for */
/* . which there is sufficient workspace. ==== */
/* Computing MIN */
i__1 = (*n - 1) / 3;
i__2 = *lwork / 2; // , expr subst
nwmax = min(i__1,i__2);
nw = nwmax;
/* ==== NSMAX = the Largest number of simultaneous shifts */
/* . for which there is sufficient workspace. ==== */
/* Computing MIN */
i__1 = (*n + 6) / 9;
i__2 = (*lwork << 1) / 3; // , expr subst
nsmax = min(i__1,i__2);
nsmax -= nsmax % 2;
/* ==== NDFL: an iteration count restarted at deflation. ==== */
ndfl = 1;
/* ==== ITMAX = iteration limit ==== */
/* Computing MAX */
i__1 = 10;
i__2 = *ihi - *ilo + 1; // , expr subst
itmax = max(i__1,i__2) * 30;
/* ==== Last row and column in the active block ==== */
kbot = *ihi;
/* ==== Main Loop ==== */
i__1 = itmax;
for (it = 1;
it <= i__1;
++it)
{
/* ==== Done when KBOT falls below ILO ==== */
if (kbot < *ilo)
{
goto L90;
}
/* ==== Locate active block ==== */
i__2 = *ilo + 1;
for (k = kbot;
k >= i__2;
--k)
{
if (h__[k + (k - 1) * h_dim1] == 0.f)
{
goto L20;
}
/* L10: */
}
k = *ilo;
L20:
ktop = k;
/* ==== Select deflation window size: */
/* . Typical Case: */
/* . If possible and advisable, nibble the entire */
/* . active block. If not, use size MIN(NWR,NWMAX) */
/* . or MIN(NWR+1,NWMAX) depending upon which has */
/* . the smaller corresponding subdiagonal entry */
/* . (a heuristic). */
/* . */
/* . Exceptional Case: */
/* . If there have been no deflations in KEXNW or */
/* . more iterations, then vary the deflation window */
/* . size. At first, because, larger windows are, */
/* . in general, more powerful than smaller ones, */
/* . rapidly increase the window to the maximum possible. */
/* . Then, gradually reduce the window size. ==== */
nh = kbot - ktop + 1;
nwupbd = min(nh,nwmax);
if (ndfl < 5)
{
nw = min(nwupbd,nwr);
}
else
{
/* Computing MIN */
i__2 = nwupbd;
i__3 = nw << 1; // , expr subst
nw = min(i__2,i__3);
}
if (nw < nwmax)
{
if (nw >= nh - 1)
{
nw = nh;
}
else
{
kwtop = kbot - nw + 1;
if ((r__1 = h__[kwtop + (kwtop - 1) * h_dim1], f2c_abs(r__1)) > (r__2 = h__[kwtop - 1 + (kwtop - 2) * h_dim1], f2c_abs(r__2)))
{
++nw;
}
}
}
if (ndfl < 5)
{
ndec = -1;
}
else if (ndec >= 0 || nw >= nwupbd)
{
++ndec;
if (nw - ndec < 2)
{
ndec = 0;
}
nw -= ndec;
}
/* ==== Aggressive early deflation: */
/* . split workspace under the subdiagonal into */
/* . - an nw-by-nw work array V in the lower */
/* . left-hand-corner, */
/* . - an NW-by-at-least-NW-but-more-is-better */
/* . (NW-by-NHO) horizontal work array along */
/* . the bottom edge, */
/* . - an at-least-NW-but-more-is-better (NHV-by-NW) */
/* . vertical work array along the left-hand-edge. */
/* . ==== */
kv = *n - nw + 1;
kt = nw + 1;
nho = *n - nw - 1 - kt + 1;
kwv = nw + 2;
nve = *n - nw - kwv + 1;
/* ==== Aggressive early deflation ==== */
slaqr3_(wantt, wantz, n, &ktop, &kbot, &nw, &h__[h_offset], ldh, iloz, ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], &h__[kv + h_dim1], ldh, &nho, &h__[kv + kt * h_dim1], ldh, &nve, &h__[kwv + h_dim1], ldh, &work[1], lwork);
/* ==== Adjust KBOT accounting for new deflations. ==== */
kbot -= ld;
/* ==== KS points to the shifts. ==== */
ks = kbot - ls + 1;
/* ==== Skip an expensive QR sweep if there is a (partly */
/* . heuristic) reason to expect that many eigenvalues */
/* . will deflate without it. Here, the QR sweep is */
/* . skipped if many eigenvalues have just been deflated */
/* . or if the remaining active block is small. */
if (ld == 0 || ld * 100 <= nw * nibble && kbot - ktop + 1 > min( nmin,nwmax))
{
/* ==== NS = nominal number of simultaneous shifts. */
/* . This may be lowered (slightly) if SLAQR3 */
/* . did not provide that many shifts. ==== */
/* Computing MIN */
/* Computing MAX */
i__4 = 2;
i__5 = kbot - ktop; // , expr subst
i__2 = min(nsmax,nsr);
i__3 = max(i__4,i__5); // , expr subst
ns = min(i__2,i__3);
ns -= ns % 2;
/* ==== If there have been no deflations */
/* . in a multiple of KEXSH iterations, */
/* . then try exceptional shifts. */
/* . Otherwise use shifts provided by */
/* . SLAQR3 above or from the eigenvalues */
/* . of a trailing principal submatrix. ==== */
if (ndfl % 6 == 0)
{
ks = kbot - ns + 1;
/* Computing MAX */
i__3 = ks + 1;
i__4 = ktop + 2; // , expr subst
i__2 = max(i__3,i__4);
for (i__ = kbot;
i__ >= i__2;
i__ += -2)
{
ss = (r__1 = h__[i__ + (i__ - 1) * h_dim1], f2c_abs(r__1)) + (r__2 = h__[i__ - 1 + (i__ - 2) * h_dim1], f2c_abs(r__2));
aa = ss * .75f + h__[i__ + i__ * h_dim1];
bb = ss;
cc = ss * -.4375f;
dd = aa;
slanv2_(&aa, &bb, &cc, &dd, &wr[i__ - 1], &wi[i__ - 1] , &wr[i__], &wi[i__], &cs, &sn);
/* L30: */
}
if (ks == ktop)
{
wr[ks + 1] = h__[ks + 1 + (ks + 1) * h_dim1];
wi[ks + 1] = 0.f;
wr[ks] = wr[ks + 1];
wi[ks] = wi[ks + 1];
}
}
else
{
/* ==== Got NS/2 or fewer shifts? Use SLAQR4 or */
/* . SLAHQR on a trailing principal submatrix to */
/* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, */
/* . there is enough space below the subdiagonal */
/* . to fit an NS-by-NS scratch array.) ==== */
if (kbot - ks + 1 <= ns / 2)
{
ks = kbot - ns + 1;
kt = *n - ns + 1;
slacpy_("A", &ns, &ns, &h__[ks + ks * h_dim1], ldh, & h__[kt + h_dim1], ldh);
if (ns > nmin)
{
slaqr4_(&c_false, &c_false, &ns, &c__1, &ns, &h__[ kt + h_dim1], ldh, &wr[ks], &wi[ks], & c__1, &c__1, zdum, &c__1, &work[1], lwork, &inf);
}
else
{
slahqr_(&c_false, &c_false, &ns, &c__1, &ns, &h__[ kt + h_dim1], ldh, &wr[ks], &wi[ks], & c__1, &c__1, zdum, &c__1, &inf);
}
ks += inf;
/* ==== In case of a rare QR failure use */
/* . eigenvalues of the trailing 2-by-2 */
/* . principal submatrix. ==== */
if (ks >= kbot)
{
aa = h__[kbot - 1 + (kbot - 1) * h_dim1];
cc = h__[kbot + (kbot - 1) * h_dim1];
bb = h__[kbot - 1 + kbot * h_dim1];
dd = h__[kbot + kbot * h_dim1];
slanv2_(&aa, &bb, &cc, &dd, &wr[kbot - 1], &wi[ kbot - 1], &wr[kbot], &wi[kbot], &cs, &sn) ;
ks = kbot - 1;
}
}
if (kbot - ks + 1 > ns)
{
/* ==== Sort the shifts (Helps a little) */
/* . Bubble sort keeps complex conjugate */
/* . pairs together. ==== */
sorted = FALSE_;
i__2 = ks + 1;
for (k = kbot;
k >= i__2;
--k)
{
if (sorted)
{
goto L60;
}
sorted = TRUE_;
i__3 = k - 1;
for (i__ = ks;
i__ <= i__3;
++i__)
{
if ((r__1 = wr[i__], f2c_abs(r__1)) + (r__2 = wi[ i__], f2c_abs(r__2)) < (r__3 = wr[i__ + 1] , f2c_abs(r__3)) + (r__4 = wi[i__ + 1], f2c_abs(r__4)))
{
sorted = FALSE_;
swap = wr[i__];
wr[i__] = wr[i__ + 1];
wr[i__ + 1] = swap;
swap = wi[i__];
wi[i__] = wi[i__ + 1];
wi[i__ + 1] = swap;
}
/* L40: */
}
/* L50: */
}
L60:
;
}
/* ==== Shuffle shifts into pairs of real shifts */
/* . and pairs of complex conjugate shifts */
/* . assuming complex conjugate shifts are */
/* . already adjacent to one another. (Yes, */
/* . they are.) ==== */
i__2 = ks + 2;
for (i__ = kbot;
i__ >= i__2;
i__ += -2)
{
if (wi[i__] != -wi[i__ - 1])
{
swap = wr[i__];
wr[i__] = wr[i__ - 1];
wr[i__ - 1] = wr[i__ - 2];
wr[i__ - 2] = swap;
swap = wi[i__];
wi[i__] = wi[i__ - 1];
wi[i__ - 1] = wi[i__ - 2];
wi[i__ - 2] = swap;
}
/* L70: */
}
}
/* ==== If there are only two shifts and both are */
/* . real, then use only one. ==== */
if (kbot - ks + 1 == 2)
{
if (wi[kbot] == 0.f)
{
if ((r__1 = wr[kbot] - h__[kbot + kbot * h_dim1], f2c_abs( r__1)) < (r__2 = wr[kbot - 1] - h__[kbot + kbot * h_dim1], f2c_abs(r__2)))
{
wr[kbot - 1] = wr[kbot];
}
else
{
wr[kbot] = wr[kbot - 1];
}
}
}
/* ==== Use up to NS of the the smallest magnatiude */
/* . shifts. If there aren't NS shifts available, */
/* . then use them all, possibly dropping one to */
/* . make the number of shifts even. ==== */
/* Computing MIN */
i__2 = ns;
i__3 = kbot - ks + 1; // , expr subst
ns = min(i__2,i__3);
ns -= ns % 2;
ks = kbot - ns + 1;
/* ==== Small-bulge multi-shift QR sweep: */
/* . split workspace under the subdiagonal into */
/* . - a KDU-by-KDU work array U in the lower */
/* . left-hand-corner, */
/* . - a KDU-by-at-least-KDU-but-more-is-better */
/* . (KDU-by-NHo) horizontal work array WH along */
/* . the bottom edge, */
/* . - and an at-least-KDU-but-more-is-better-by-KDU */
/* . (NVE-by-KDU) vertical work WV arrow along */
/* . the left-hand-edge. ==== */
kdu = ns * 3 - 3;
ku = *n - kdu + 1;
kwh = kdu + 1;
nho = *n - kdu - 3 - (kdu + 1) + 1;
kwv = kdu + 4;
nve = *n - kdu - kwv + 1;
/* ==== Small-bulge multi-shift QR sweep ==== */
slaqr5_(wantt, wantz, &kacc22, n, &ktop, &kbot, &ns, &wr[ks], &wi[ks], &h__[h_offset], ldh, iloz, ihiz, &z__[ z_offset], ldz, &work[1], &c__3, &h__[ku + h_dim1], ldh, &nve, &h__[kwv + h_dim1], ldh, &nho, &h__[ku + kwh * h_dim1], ldh);
}
/* ==== Note progress (or the lack of it). ==== */
if (ld > 0)
{
ndfl = 1;
}
else
{
++ndfl;
}
/* ==== End of main loop ==== */
/* L80: */
}
/* ==== Iteration limit exceeded. Set INFO to show where */
/* . the problem occurred and exit. ==== */
*info = kbot;
L90:
;
}
/* ==== Return the optimal value of LWORK. ==== */
work[1] = (real) lwkopt;
/* ==== End of SLAQR0 ==== */
return 0;
}
/* Subroutine */ int sget33_(real *rmax, integer *lmax, integer *ninfo,
integer *knt)
{
/* System generated locals */
real r__1, r__2, r__3;
/* Local variables */
real q[4] /* was [2][2] */, t[4] /* was [2][2] */;
integer i1, i2, i3, i4, j1, j2, j3;
real t1[4] /* was [2][2] */, t2[4] /* was [2][2] */, cs, sn, vm[3];
integer im1, im2, im3, im4;
real wi1, wi2, wr1, wr2, val[4], eps, res, sum, tnrm;
extern /* Subroutine */ int slanv2_(real *, real *, real *, real *, real *
, real *, real *, real *, real *, real *), slabad_(real *, real *)
;
extern doublereal slamch_(char *);
real bignum, smlnum;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGET33 tests SLANV2, a routine for putting 2 by 2 blocks into */
/* standard form. In other words, it computes a two by two rotation */
/* [[C,S];[-S,C]] where in */
/* [ C S ][T(1,1) T(1,2)][ C -S ] = [ T11 T12 ] */
/* [-S C ][T(2,1) T(2,2)][ S C ] [ T21 T22 ] */
/* either */
/* 1) T21=0 (real eigenvalues), or */
/* 2) T11=T22 and T21*T12<0 (complex conjugate eigenvalues). */
/* We also verify that the residual is small. */
/* Arguments */
/* ========== */
/* RMAX (output) REAL */
/* Value of the largest test ratio. */
/* LMAX (output) INTEGER */
/* Example number where largest test ratio achieved. */
/* NINFO (output) INTEGER */
/* Number of examples returned with INFO .NE. 0. */
/* KNT (output) INTEGER */
/* Total number of examples tested. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Get machine parameters */
eps = slamch_("P");
smlnum = slamch_("S") / eps;
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
/* Set up test case parameters */
val[0] = 1.f;
val[1] = eps * 2.f + 1.f;
val[2] = 2.f;
val[3] = 2.f - eps * 4.f;
vm[0] = smlnum;
vm[1] = 1.f;
vm[2] = bignum;
*knt = 0;
*ninfo = 0;
*lmax = 0;
*rmax = 0.f;
/* Begin test loop */
for (i1 = 1; i1 <= 4; ++i1) {
for (i2 = 1; i2 <= 4; ++i2) {
for (i3 = 1; i3 <= 4; ++i3) {
for (i4 = 1; i4 <= 4; ++i4) {
for (im1 = 1; im1 <= 3; ++im1) {
for (im2 = 1; im2 <= 3; ++im2) {
for (im3 = 1; im3 <= 3; ++im3) {
for (im4 = 1; im4 <= 3; ++im4) {
t[0] = val[i1 - 1] * vm[im1 - 1];
t[2] = val[i2 - 1] * vm[im2 - 1];
t[1] = -val[i3 - 1] * vm[im3 - 1];
t[3] = val[i4 - 1] * vm[im4 - 1];
/* Computing MAX */
r__1 = dabs(t[0]), r__2 = dabs(t[2]),
r__1 = max(r__1,r__2), r__2 =
dabs(t[1]), r__1 = max(r__1,r__2),
r__2 = dabs(t[3]);
tnrm = dmax(r__1,r__2);
t1[0] = t[0];
t1[2] = t[2];
t1[1] = t[1];
t1[3] = t[3];
q[0] = 1.f;
q[2] = 0.f;
q[1] = 0.f;
q[3] = 1.f;
slanv2_(t, &t[2], &t[1], &t[3], &wr1, &
wi1, &wr2, &wi2, &cs, &sn);
for (j1 = 1; j1 <= 2; ++j1) {
res = q[j1 - 1] * cs + q[j1 + 1] * sn;
q[j1 + 1] = -q[j1 - 1] * sn + q[j1 +
1] * cs;
q[j1 - 1] = res;
/* L10: */
}
res = 0.f;
/* Computing 2nd power */
r__2 = q[0];
/* Computing 2nd power */
r__3 = q[2];
res += (r__1 = r__2 * r__2 + r__3 * r__3
- 1.f, dabs(r__1)) / eps;
/* Computing 2nd power */
r__2 = q[3];
/* Computing 2nd power */
r__3 = q[1];
res += (r__1 = r__2 * r__2 + r__3 * r__3
- 1.f, dabs(r__1)) / eps;
res += (r__1 = q[0] * q[1] + q[2] * q[3],
dabs(r__1)) / eps;
for (j1 = 1; j1 <= 2; ++j1) {
for (j2 = 1; j2 <= 2; ++j2) {
t2[j1 + (j2 << 1) - 3] = 0.f;
for (j3 = 1; j3 <= 2; ++j3) {
t2[j1 + (j2 << 1) - 3] += t1[j1 + (j3 << 1) - 3] *
q[j3 + (j2 << 1) - 3];
/* L20: */
}
/* L30: */
}
/* L40: */
}
for (j1 = 1; j1 <= 2; ++j1) {
for (j2 = 1; j2 <= 2; ++j2) {
sum = t[j1 + (j2 << 1) - 3];
for (j3 = 1; j3 <= 2; ++j3) {
sum -= q[j3 + (j1 << 1) - 3] * t2[j3 + (j2 << 1) -
3];
/* L50: */
}
res += dabs(sum) / eps / tnrm;
/* L60: */
}
/* L70: */
}
if (t[1] != 0.f && (t[0] != t[3] ||
r_sign(&c_b19, &t[2]) * r_sign(&
c_b19, &t[1]) > 0.f)) {
res += 1.f / eps;
}
++(*knt);
if (res > *rmax) {
*lmax = *knt;
*rmax = res;
}
/* L80: */
}
/* L90: */
}
/* L100: */
}
/* L110: */
}
/* L120: */
}
/* L130: */
}
/* L140: */
}
/* L150: */
}
return 0;
/* End of SGET33 */
} /* sget33_ */
/* Subroutine */ int slaqrb_(logical *wantt, integer *n, integer *ilo,
integer *ihi, real *h__, integer *ldh, real *wr, real *wi, real *z__,
integer *info)
{
/* System generated locals */
integer h_dim1, h_offset, i__1, i__2, i__3, i__4;
real r__1, r__2;
/* Local variables */
static integer i__, j, k, l, m;
static real s, v[3];
static integer i1, i2;
static real t1, t2, t3, v1, v2, v3, h00, h10, h11, h12, h21, h22, h33,
h44;
static integer nh;
static real cs;
static integer nr;
static real sn, h33s, h44s;
static integer itn, its;
static real ulp, sum, tst1, h43h34, unfl, ovfl, work[1];
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *), scopy_(integer *, real *, integer *,
real *, integer *), slanv2_(real *, real *, real *, real *, real *
, real *, real *, real *, real *, real *), slabad_(real *, real *)
;
extern doublereal slamch_(char *, ftnlen);
extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *,
real *);
extern doublereal slanhs_(char *, integer *, real *, integer *, real *,
ftnlen);
static real smlnum;
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %------------------------% */
/* | Local Scalars & Arrays | */
/* %------------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--wr;
--wi;
--z__;
/* Function Body */
*info = 0;
/* %--------------------------% */
/* | 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;
}
/* %---------------------------------------------% */
/* | Initialize the vector of last components of | */
/* | the Schur vectors for accumulation. | */
/* %---------------------------------------------% */
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
z__[j] = 0.f;
/* L5: */
}
z__[*n] = 1.f;
nh = *ihi - *ilo + 1;
/* %-------------------------------------------------------------% */
/* | 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 computed, I1 and I2 are set inside the main loop. | */
/* | Zero out H(J+2,J) = ZERO for J=1:N if WANTT = .TRUE. | */
/* | else H(J+2,J) for J=ILO:IHI-ILO-1 if WANTT = .FALSE. | */
/* %---------------------------------------------------------------% */
if (*wantt) {
i1 = 1;
i2 = *n;
i__1 = i2 - 2;
for (i__ = 1; i__ <= i__1; ++i__) {
h__[i1 + i__ + 1 + i__ * h_dim1] = 0.f;
/* L8: */
}
} else {
i__1 = *ihi - *ilo - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
h__[*ilo + i__ + 1 + (*ilo + i__ - 1) * h_dim1] = 0.f;
/* L9: */
}
}
/* %---------------------------------------------------% */
/* | ITN is the total number of 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 1 or 2. 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;
L10:
l = *ilo;
if (i__ < *ilo) {
goto L150;
}
/* %--------------------------------------------------------------% */
/* | Perform QR iterations on rows and columns ILO to I until a | */
/* | submatrix of order 1 or 2 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__3 = i__ - l + 1;
tst1 = slanhs_("1", &i__3, &h__[l + l * h_dim1], ldh, work, (
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 L30;
}
/* L20: */
}
L30:
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 1 or 2 has split off | */
/* %-------------------------------------------------------------% */
if (l >= i__ - 1) {
goto L140;
}
/* %---------------------------------------------------------% */
/* | 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 == 10 || its == 20) {
/* %-------------------% */
/* | Exceptional shift | */
/* %-------------------% */
s = (r__1 = h__[i__ + (i__ - 1) * h_dim1], dabs(r__1)) + (r__2 =
h__[i__ - 1 + (i__ - 2) * h_dim1], dabs(r__2));
h44 = s * .75f;
h33 = h44;
h43h34 = s * -.4375f * s;
} else {
/* %-----------------------------------------% */
/* | Prepare to use Wilkinson's double shift | */
/* %-----------------------------------------% */
h44 = h__[i__ + i__ * h_dim1];
h33 = h__[i__ - 1 + (i__ - 1) * h_dim1];
h43h34 = h__[i__ + (i__ - 1) * h_dim1] * h__[i__ - 1 + i__ *
h_dim1];
}
/* %-----------------------------------------------------% */
/* | Look for two consecutive small subdiagonal elements | */
/* %-----------------------------------------------------% */
i__2 = l;
for (m = i__ - 2; m >= i__2; --m) {
/* %---------------------------------------------------------% */
/* | Determine the effect of starting the double-shift QR | */
/* | iteration at row M, and see if this would make H(M,M-1) | */
/* | negligible. | */
/* %---------------------------------------------------------% */
h11 = h__[m + m * h_dim1];
h22 = h__[m + 1 + (m + 1) * h_dim1];
h21 = h__[m + 1 + m * h_dim1];
h12 = h__[m + (m + 1) * h_dim1];
h44s = h44 - h11;
h33s = h33 - h11;
v1 = (h33s * h44s - h43h34) / h21 + h12;
v2 = h22 - h11 - h33s - h44s;
v3 = h__[m + 2 + (m + 1) * h_dim1];
s = dabs(v1) + dabs(v2) + dabs(v3);
v1 /= s;
v2 /= s;
v3 /= s;
v[0] = v1;
v[1] = v2;
v[2] = v3;
if (m == l) {
goto L50;
}
h00 = h__[m - 1 + (m - 1) * h_dim1];
h10 = h__[m + (m - 1) * h_dim1];
tst1 = dabs(v1) * (dabs(h00) + dabs(h11) + dabs(h22));
if (dabs(h10) * (dabs(v2) + dabs(v3)) <= ulp * tst1) {
goto L50;
}
/* L40: */
}
L50:
/* %----------------------% */
/* | Double-shift QR step | */
/* %----------------------% */
i__2 = i__ - 1;
for (k = m; 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 = 3, i__4 = i__ - k + 1;
nr = min(i__3,i__4);
if (k > m) {
scopy_(&nr, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1);
}
slarfg_(&nr, v, &v[1], &c__1, &t1);
if (k > m) {
h__[k + (k - 1) * h_dim1] = v[0];
h__[k + 1 + (k - 1) * h_dim1] = 0.f;
if (k < i__ - 1) {
h__[k + 2 + (k - 1) * h_dim1] = 0.f;
}
} else if (m > l) {
h__[k + (k - 1) * h_dim1] = -h__[k + (k - 1) * h_dim1];
}
v2 = v[1];
t2 = t1 * v2;
if (nr == 3) {
v3 = v[2];
t3 = t1 * v3;
/* %------------------------------------------------% */
/* | Apply G from the left to transform the rows of | */
/* | the matrix in columns K to I2. | */
/* %------------------------------------------------% */
i__3 = i2;
for (j = k; j <= i__3; ++j) {
sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1]
+ v3 * h__[k + 2 + j * h_dim1];
h__[k + j * h_dim1] -= sum * t1;
h__[k + 1 + j * h_dim1] -= sum * t2;
h__[k + 2 + j * h_dim1] -= sum * t3;
/* L60: */
}
/* %----------------------------------------------------% */
/* | Apply G from the right to transform the columns of | */
/* | the matrix in rows I1 to min(K+3,I). | */
/* %----------------------------------------------------% */
/* Computing MIN */
i__4 = k + 3;
i__3 = min(i__4,i__);
for (j = i1; j <= i__3; ++j) {
sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1]
+ v3 * h__[j + (k + 2) * h_dim1];
h__[j + k * h_dim1] -= sum * t1;
h__[j + (k + 1) * h_dim1] -= sum * t2;
h__[j + (k + 2) * h_dim1] -= sum * t3;
/* L70: */
}
/* %----------------------------------% */
/* | Accumulate transformations for Z | */
/* %----------------------------------% */
sum = z__[k] + v2 * z__[k + 1] + v3 * z__[k + 2];
z__[k] -= sum * t1;
z__[k + 1] -= sum * t2;
z__[k + 2] -= sum * t3;
} else if (nr == 2) {
/* %------------------------------------------------% */
/* | Apply G from the left to transform the rows of | */
/* | the matrix in columns K to I2. | */
/* %------------------------------------------------% */
i__3 = i2;
for (j = k; j <= i__3; ++j) {
sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1];
h__[k + j * h_dim1] -= sum * t1;
h__[k + 1 + j * h_dim1] -= sum * t2;
/* L90: */
}
/* %----------------------------------------------------% */
/* | Apply G from the right to transform the columns of | */
/* | the matrix in rows I1 to min(K+3,I). | */
/* %----------------------------------------------------% */
i__3 = i__;
for (j = i1; j <= i__3; ++j) {
sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1]
;
h__[j + k * h_dim1] -= sum * t1;
h__[j + (k + 1) * h_dim1] -= sum * t2;
/* L100: */
}
/* %----------------------------------% */
/* | Accumulate transformations for Z | */
/* %----------------------------------% */
sum = z__[k] + v2 * z__[k + 1];
z__[k] -= sum * t1;
z__[k + 1] -= sum * t2;
}
/* L120: */
}
/* L130: */
}
/* %-------------------------------------------------------% */
/* | Failure to converge in remaining number of iterations | */
/* %-------------------------------------------------------% */
*info = i__;
return 0;
L140:
if (l == i__) {
/* %------------------------------------------------------% */
/* | H(I,I-1) is negligible: one eigenvalue has converged | */
/* %------------------------------------------------------% */
wr[i__] = h__[i__ + i__ * h_dim1];
wi[i__] = 0.f;
} else if (l == i__ - 1) {
/* %--------------------------------------------------------% */
/* | H(I-1,I-2) is negligible; | */
/* | a pair of eigenvalues have converged. | */
/* | | */
/* | Transform the 2-by-2 submatrix to standard Schur form, | */
/* | and compute and store the eigenvalues. | */
/* %--------------------------------------------------------% */
slanv2_(&h__[i__ - 1 + (i__ - 1) * h_dim1], &h__[i__ - 1 + i__ *
h_dim1], &h__[i__ + (i__ - 1) * h_dim1], &h__[i__ + i__ *
h_dim1], &wr[i__ - 1], &wi[i__ - 1], &wr[i__], &wi[i__], &cs,
&sn);
if (*wantt) {
/* %-----------------------------------------------------% */
/* | Apply the transformation to the rest of H and to Z, | */
/* | as required. | */
/* %-----------------------------------------------------% */
if (i2 > i__) {
i__1 = i2 - i__;
srot_(&i__1, &h__[i__ - 1 + (i__ + 1) * h_dim1], ldh, &h__[
i__ + (i__ + 1) * h_dim1], ldh, &cs, &sn);
}
i__1 = i__ - i1 - 1;
srot_(&i__1, &h__[i1 + (i__ - 1) * h_dim1], &c__1, &h__[i1 + i__ *
h_dim1], &c__1, &cs, &sn);
sum = cs * z__[i__ - 1] + sn * z__[i__];
z__[i__] = cs * z__[i__] - sn * z__[i__ - 1];
z__[i__ - 1] = sum;
}
}
/* %---------------------------------------------------------% */
/* | Decrement number of remaining iterations, and return to | */
/* | start of the main loop with new value of I. | */
/* %---------------------------------------------------------% */
itn -= its;
i__ = l - 1;
goto L10;
L150:
return 0;
/* %---------------% */
/* | End of slaqrb | */
/* %---------------% */
} /* slaqrb_ */
/* Subroutine */ int slaexc_(logical *wantq, integer *n, real *t, integer *
ldt, real *q, integer *ldq, integer *j1, integer *n1, integer *n2,
real *work, integer *info)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
SLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in
an upper quasi-triangular matrix T by an orthogonal similarity
transformation.
T must be in Schur canonical form, that is, block upper triangular
with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block
has its diagonal elemnts equal and its off-diagonal elements of
opposite sign.
Arguments
=========
WANTQ (input) LOGICAL
= .TRUE. : accumulate the transformation in the matrix Q;
= .FALSE.: do not accumulate the transformation.
N (input) INTEGER
The order of the matrix T. N >= 0.
T (input/output) REAL array, dimension (LDT,N)
On entry, the upper quasi-triangular matrix T, in Schur
canonical form.
On exit, the updated matrix T, again in Schur canonical form.
LDT (input) INTEGER
The leading dimension of the array T. LDT >= max(1,N).
Q (input/output) REAL array, dimension (LDQ,N)
On entry, if WANTQ is .TRUE., the orthogonal matrix Q.
On exit, if WANTQ is .TRUE., the updated matrix Q.
If WANTQ is .FALSE., Q is not referenced.
LDQ (input) INTEGER
The leading dimension of the array Q.
LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N.
J1 (input) INTEGER
The index of the first row of the first block T11.
N1 (input) INTEGER
The order of the first block T11. N1 = 0, 1 or 2.
N2 (input) INTEGER
The order of the second block T22. N2 = 0, 1 or 2.
WORK (workspace) REAL array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
= 1: the transformed matrix T would be too far from Schur
form; the blocks are not swapped and T and Q are
unchanged.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static integer c__4 = 4;
static logical c_false = FALSE_;
static integer c_n1 = -1;
static integer c__2 = 2;
static integer c__3 = 3;
/* System generated locals */
integer q_dim1, q_offset, t_dim1, t_offset, i__1;
real r__1, r__2, r__3, r__4, r__5, r__6;
/* Local variables */
static integer ierr;
static real temp;
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *);
static real d__[16] /* was [4][4] */;
static integer k;
static real u[3], scale, x[4] /* was [2][2] */, dnorm;
static integer j2, j3, j4;
static real xnorm, u1[3], u2[3];
extern /* Subroutine */ int slanv2_(real *, real *, real *, real *, real *
, real *, real *, real *, real *, real *), slasy2_(logical *,
logical *, integer *, integer *, integer *, real *, integer *,
real *, integer *, real *, integer *, real *, real *, integer *,
real *, integer *);
static integer nd;
static real cs, t11, t22, t33, sn;
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *,
real *), slacpy_(char *, integer *, integer *, real *, integer *,
real *, integer *), slartg_(real *, real *, real *, real *
, real *);
static real thresh;
extern /* Subroutine */ int slarfx_(char *, integer *, integer *, real *,
real *, real *, integer *, real *);
static real smlnum, wi1, wi2, wr1, wr2, eps, tau, tau1, tau2;
#define d___ref(a_1,a_2) d__[(a_2)*4 + a_1 - 5]
#define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1]
#define t_ref(a_1,a_2) t[(a_2)*t_dim1 + a_1]
#define x_ref(a_1,a_2) x[(a_2)*2 + a_1 - 3]
t_dim1 = *ldt;
t_offset = 1 + t_dim1 * 1;
t -= t_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
--work;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n == 0 || *n1 == 0 || *n2 == 0) {
return 0;
}
if (*j1 + *n1 > *n) {
return 0;
}
j2 = *j1 + 1;
j3 = *j1 + 2;
j4 = *j1 + 3;
if (*n1 == 1 && *n2 == 1) {
/* Swap two 1-by-1 blocks. */
t11 = t_ref(*j1, *j1);
t22 = t_ref(j2, j2);
/* Determine the transformation to perform the interchange. */
r__1 = t22 - t11;
slartg_(&t_ref(*j1, j2), &r__1, &cs, &sn, &temp);
/* Apply transformation to the matrix T. */
if (j3 <= *n) {
i__1 = *n - *j1 - 1;
srot_(&i__1, &t_ref(*j1, j3), ldt, &t_ref(j2, j3), ldt, &cs, &sn);
}
i__1 = *j1 - 1;
srot_(&i__1, &t_ref(1, *j1), &c__1, &t_ref(1, j2), &c__1, &cs, &sn);
t_ref(*j1, *j1) = t22;
t_ref(j2, j2) = t11;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
srot_(n, &q_ref(1, *j1), &c__1, &q_ref(1, j2), &c__1, &cs, &sn);
}
} else {
/* Swapping involves at least one 2-by-2 block.
Copy the diagonal block of order N1+N2 to the local array D
and compute its norm. */
nd = *n1 + *n2;
slacpy_("Full", &nd, &nd, &t_ref(*j1, *j1), ldt, d__, &c__4);
dnorm = slange_("Max", &nd, &nd, d__, &c__4, &work[1]);
/* Compute machine-dependent threshold for test for accepting
swap. */
eps = slamch_("P");
smlnum = slamch_("S") / eps;
/* Computing MAX */
r__1 = eps * 10.f * dnorm;
thresh = dmax(r__1,smlnum);
/* Solve T11*X - X*T22 = scale*T12 for X. */
slasy2_(&c_false, &c_false, &c_n1, n1, n2, d__, &c__4, &d___ref(*n1 +
1, *n1 + 1), &c__4, &d___ref(1, *n1 + 1), &c__4, &scale, x, &
c__2, &xnorm, &ierr);
/* Swap the adjacent diagonal blocks. */
k = *n1 + *n1 + *n2 - 3;
switch (k) {
case 1: goto L10;
case 2: goto L20;
case 3: goto L30;
}
L10:
/* N1 = 1, N2 = 2: generate elementary reflector H so that:
( scale, X11, X12 ) H = ( 0, 0, * ) */
u[0] = scale;
u[1] = x_ref(1, 1);
u[2] = x_ref(1, 2);
slarfg_(&c__3, &u[2], u, &c__1, &tau);
u[2] = 1.f;
t11 = t_ref(*j1, *j1);
/* Perform swap provisionally on diagonal block in D. */
slarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
slarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
/* Test whether to reject swap.
Computing MAX */
r__4 = (r__1 = d___ref(3, 1), dabs(r__1)), r__5 = (r__2 = d___ref(3,
2), dabs(r__2)), r__4 = max(r__4,r__5), r__5 = (r__3 =
d___ref(3, 3) - t11, dabs(r__3));
if (dmax(r__4,r__5) > thresh) {
goto L50;
}
/* Accept swap: apply transformation to the entire matrix T. */
i__1 = *n - *j1 + 1;
slarfx_("L", &c__3, &i__1, u, &tau, &t_ref(*j1, *j1), ldt, &work[1]);
slarfx_("R", &j2, &c__3, u, &tau, &t_ref(1, *j1), ldt, &work[1]);
t_ref(j3, *j1) = 0.f;
t_ref(j3, j2) = 0.f;
t_ref(j3, j3) = t11;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
slarfx_("R", n, &c__3, u, &tau, &q_ref(1, *j1), ldq, &work[1]);
}
goto L40;
L20:
/* N1 = 2, N2 = 1: generate elementary reflector H so that:
H ( -X11 ) = ( * )
( -X21 ) = ( 0 )
( scale ) = ( 0 ) */
u[0] = -x_ref(1, 1);
u[1] = -x_ref(2, 1);
u[2] = scale;
slarfg_(&c__3, u, &u[1], &c__1, &tau);
u[0] = 1.f;
t33 = t_ref(j3, j3);
/* Perform swap provisionally on diagonal block in D. */
slarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
slarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
/* Test whether to reject swap.
Computing MAX */
r__4 = (r__1 = d___ref(2, 1), dabs(r__1)), r__5 = (r__2 = d___ref(3,
1), dabs(r__2)), r__4 = max(r__4,r__5), r__5 = (r__3 =
d___ref(1, 1) - t33, dabs(r__3));
if (dmax(r__4,r__5) > thresh) {
goto L50;
}
/* Accept swap: apply transformation to the entire matrix T. */
slarfx_("R", &j3, &c__3, u, &tau, &t_ref(1, *j1), ldt, &work[1]);
i__1 = *n - *j1;
slarfx_("L", &c__3, &i__1, u, &tau, &t_ref(*j1, j2), ldt, &work[1]);
t_ref(*j1, *j1) = t33;
t_ref(j2, *j1) = 0.f;
t_ref(j3, *j1) = 0.f;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
slarfx_("R", n, &c__3, u, &tau, &q_ref(1, *j1), ldq, &work[1]);
}
goto L40;
L30:
/* N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so
that:
H(2) H(1) ( -X11 -X12 ) = ( * * )
( -X21 -X22 ) ( 0 * )
( scale 0 ) ( 0 0 )
( 0 scale ) ( 0 0 ) */
u1[0] = -x_ref(1, 1);
u1[1] = -x_ref(2, 1);
u1[2] = scale;
slarfg_(&c__3, u1, &u1[1], &c__1, &tau1);
u1[0] = 1.f;
temp = -tau1 * (x_ref(1, 2) + u1[1] * x_ref(2, 2));
u2[0] = -temp * u1[1] - x_ref(2, 2);
u2[1] = -temp * u1[2];
u2[2] = scale;
slarfg_(&c__3, u2, &u2[1], &c__1, &tau2);
u2[0] = 1.f;
/* Perform swap provisionally on diagonal block in D. */
slarfx_("L", &c__3, &c__4, u1, &tau1, d__, &c__4, &work[1])
;
slarfx_("R", &c__4, &c__3, u1, &tau1, d__, &c__4, &work[1])
;
slarfx_("L", &c__3, &c__4, u2, &tau2, &d___ref(2, 1), &c__4, &work[1]);
slarfx_("R", &c__4, &c__3, u2, &tau2, &d___ref(1, 2), &c__4, &work[1]);
/* Test whether to reject swap.
Computing MAX */
r__5 = (r__1 = d___ref(3, 1), dabs(r__1)), r__6 = (r__2 = d___ref(3,
2), dabs(r__2)), r__5 = max(r__5,r__6), r__6 = (r__3 =
d___ref(4, 1), dabs(r__3)), r__5 = max(r__5,r__6), r__6 = (
r__4 = d___ref(4, 2), dabs(r__4));
if (dmax(r__5,r__6) > thresh) {
goto L50;
}
/* Accept swap: apply transformation to the entire matrix T. */
i__1 = *n - *j1 + 1;
slarfx_("L", &c__3, &i__1, u1, &tau1, &t_ref(*j1, *j1), ldt, &work[1]);
slarfx_("R", &j4, &c__3, u1, &tau1, &t_ref(1, *j1), ldt, &work[1]);
i__1 = *n - *j1 + 1;
slarfx_("L", &c__3, &i__1, u2, &tau2, &t_ref(j2, *j1), ldt, &work[1]);
slarfx_("R", &j4, &c__3, u2, &tau2, &t_ref(1, j2), ldt, &work[1]);
t_ref(j3, *j1) = 0.f;
t_ref(j3, j2) = 0.f;
t_ref(j4, *j1) = 0.f;
t_ref(j4, j2) = 0.f;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
slarfx_("R", n, &c__3, u1, &tau1, &q_ref(1, *j1), ldq, &work[1]);
slarfx_("R", n, &c__3, u2, &tau2, &q_ref(1, j2), ldq, &work[1]);
}
L40:
if (*n2 == 2) {
/* Standardize new 2-by-2 block T11 */
slanv2_(&t_ref(*j1, *j1), &t_ref(*j1, j2), &t_ref(j2, *j1), &
t_ref(j2, j2), &wr1, &wi1, &wr2, &wi2, &cs, &sn);
i__1 = *n - *j1 - 1;
srot_(&i__1, &t_ref(*j1, *j1 + 2), ldt, &t_ref(j2, *j1 + 2), ldt,
&cs, &sn);
i__1 = *j1 - 1;
srot_(&i__1, &t_ref(1, *j1), &c__1, &t_ref(1, j2), &c__1, &cs, &
sn);
if (*wantq) {
srot_(n, &q_ref(1, *j1), &c__1, &q_ref(1, j2), &c__1, &cs, &
sn);
}
}
if (*n1 == 2) {
/* Standardize new 2-by-2 block T22 */
j3 = *j1 + *n2;
j4 = j3 + 1;
slanv2_(&t_ref(j3, j3), &t_ref(j3, j4), &t_ref(j4, j3), &t_ref(j4,
j4), &wr1, &wi1, &wr2, &wi2, &cs, &sn);
if (j3 + 2 <= *n) {
i__1 = *n - j3 - 1;
srot_(&i__1, &t_ref(j3, j3 + 2), ldt, &t_ref(j4, j3 + 2), ldt,
&cs, &sn);
}
i__1 = j3 - 1;
srot_(&i__1, &t_ref(1, j3), &c__1, &t_ref(1, j4), &c__1, &cs, &sn)
;
if (*wantq) {
srot_(n, &q_ref(1, j3), &c__1, &q_ref(1, j4), &c__1, &cs, &sn)
;
}
}
}
return 0;
/* Exit with INFO = 1 if swap was rejected. */
L50:
*info = 1;
return 0;
/* End of SLAEXC */
} /* slaexc_ */
/* Subroutine */ int slahqr_(logical *wantt, logical *wantz, integer *n,
integer *ilo, integer *ihi, real *h__, integer *ldh, real *wr, real *
wi, integer *iloz, integer *ihiz, real *z__, integer *ldz, integer *
info)
{
/* System generated locals */
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal), r_sign(real *, real *);
/* Local variables */
static integer i__, j, k, l, m;
static real s, v[3];
static integer i1, i2;
static real t1, t2, t3, v1, v2, v3, h00, h10, h11, h12, h21, h22, h33,
h44;
static integer nh;
static real cs;
static integer nr;
static real sn;
static integer nz;
static real ave, h33s, h44s;
static integer itn, its;
static real ulp, sum, tst1, h43h34, disc, unfl, ovfl, work[1];
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *), scopy_(integer *, real *, integer *,
real *, integer *), slanv2_(real *, real *, real *, real *, real *
, real *, real *, real *, real *, real *), slabad_(real *, real *)
;
extern doublereal slamch_(char *, ftnlen);
extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *,
real *);
extern doublereal slanhs_(char *, integer *, real *, integer *, real *,
ftnlen);
static real smlnum;
/* -- LAPACK auxiliary routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* June 30, 1999 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLAHQR is an auxiliary routine called by SHSEQR to update the */
/* eigenvalues and Schur decomposition already computed by SHSEQR, by */
/* dealing with the Hessenberg submatrix in rows and columns ILO to IHI. */
/* Arguments */
/* ========= */
/* WANTT (input) LOGICAL */
/* = .TRUE. : the full Schur form T is required; */
/* = .FALSE.: only eigenvalues are required. */
/* WANTZ (input) LOGICAL */
/* = .TRUE. : the matrix of Schur vectors Z is required; */
/* = .FALSE.: Schur vectors are not required. */
/* 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 quasi-triangular in */
/* rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless */
/* ILO = 1). SLAHQR works primarily with the Hessenberg */
/* submatrix in rows and columns ILO to IHI, but applies */
/* transformations to all of H if WANTT is .TRUE.. */
/* 1 <= ILO <= max(1,IHI); IHI <= N. */
/* H (input/output) REAL array, dimension (LDH,N) */
/* On entry, the upper Hessenberg matrix H. */
/* On exit, if WANTT is .TRUE., H is upper quasi-triangular in */
/* rows and columns ILO:IHI, with any 2-by-2 diagonal blocks in */
/* standard form. If WANTT is .FALSE., 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 ILO to IHI are stored in the corresponding */
/* elements of WR and WI. 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 WANTT is .TRUE., 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). */
/* ILOZ (input) INTEGER */
/* IHIZ (input) INTEGER */
/* Specify the rows of Z to which transformations must be */
/* applied if WANTZ is .TRUE.. */
/* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. */
/* Z (input/output) REAL array, dimension (LDZ,N) */
/* If WANTZ is .TRUE., on entry Z must contain the current */
/* matrix Z of transformations accumulated by SHSEQR, and on */
/* exit Z has been updated; transformations are applied only to */
/* the submatrix Z(ILOZ:IHIZ,ILO:IHI). */
/* If WANTZ is .FALSE., Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* > 0: SLAHQR failed to compute all the eigenvalues ILO to IHI */
/* in a total of 30*(IHI-ILO+1) iterations; if INFO = i, */
/* elements i+1:ihi of WR and WI contain those eigenvalues */
/* which have been successfully computed. */
/* Further Details */
/* =============== */
/* 2-96 Based on modifications by */
/* David Day, Sandia National Laboratory, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* 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;
/* Function Body */
*info = 0;
/* 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;
}
nh = *ihi - *ilo + 1;
nz = *ihiz - *iloz + 1;
/* 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 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 1 or 2. 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;
L10:
l = *ilo;
if (i__ < *ilo) {
goto L150;
}
/* Perform QR iterations on rows and columns ILO to I until a */
/* submatrix of order 1 or 2 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__3 = i__ - l + 1;
tst1 = slanhs_("1", &i__3, &h__[l + l * h_dim1], ldh, work, (
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 L30;
}
/* L20: */
}
L30:
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 1 or 2 has split off. */
if (l >= i__ - 1) {
goto L140;
}
/* 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 == 10 || its == 20) {
/* Exceptional shift. */
s = (r__1 = h__[i__ + (i__ - 1) * h_dim1], dabs(r__1)) + (r__2 =
h__[i__ - 1 + (i__ - 2) * h_dim1], dabs(r__2));
h44 = s * .75f + h__[i__ + i__ * h_dim1];
h33 = h44;
h43h34 = s * -.4375f * s;
} else {
/* Prepare to use Francis' double shift */
/* (i.e. 2nd degree generalized Rayleigh quotient) */
h44 = h__[i__ + i__ * h_dim1];
h33 = h__[i__ - 1 + (i__ - 1) * h_dim1];
h43h34 = h__[i__ + (i__ - 1) * h_dim1] * h__[i__ - 1 + i__ *
h_dim1];
s = h__[i__ - 1 + (i__ - 2) * h_dim1] * h__[i__ - 1 + (i__ - 2) *
h_dim1];
disc = (h33 - h44) * .5f;
disc = disc * disc + h43h34;
if (disc > 0.f) {
/* Real roots: use Wilkinson's shift twice */
disc = sqrt(disc);
ave = (h33 + h44) * .5f;
if (dabs(h33) - dabs(h44) > 0.f) {
h33 = h33 * h44 - h43h34;
h44 = h33 / (r_sign(&disc, &ave) + ave);
} else {
h44 = r_sign(&disc, &ave) + ave;
}
h33 = h44;
h43h34 = 0.f;
}
}
/* Look for two consecutive small subdiagonal elements. */
i__2 = l;
for (m = i__ - 2; m >= i__2; --m) {
/* Determine the effect of starting the double-shift QR */
/* iteration at row M, and see if this would make H(M,M-1) */
/* negligible. */
h11 = h__[m + m * h_dim1];
h22 = h__[m + 1 + (m + 1) * h_dim1];
h21 = h__[m + 1 + m * h_dim1];
h12 = h__[m + (m + 1) * h_dim1];
h44s = h44 - h11;
h33s = h33 - h11;
v1 = (h33s * h44s - h43h34) / h21 + h12;
v2 = h22 - h11 - h33s - h44s;
v3 = h__[m + 2 + (m + 1) * h_dim1];
s = dabs(v1) + dabs(v2) + dabs(v3);
v1 /= s;
v2 /= s;
v3 /= s;
v[0] = v1;
v[1] = v2;
v[2] = v3;
if (m == l) {
goto L50;
}
h00 = h__[m - 1 + (m - 1) * h_dim1];
h10 = h__[m + (m - 1) * h_dim1];
tst1 = dabs(v1) * (dabs(h00) + dabs(h11) + dabs(h22));
if (dabs(h10) * (dabs(v2) + dabs(v3)) <= ulp * tst1) {
goto L50;
}
/* L40: */
}
L50:
/* Double-shift QR step */
i__2 = i__ - 1;
for (k = m; 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 = 3, i__4 = i__ - k + 1;
nr = min(i__3,i__4);
if (k > m) {
scopy_(&nr, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1);
}
slarfg_(&nr, v, &v[1], &c__1, &t1);
if (k > m) {
h__[k + (k - 1) * h_dim1] = v[0];
h__[k + 1 + (k - 1) * h_dim1] = 0.f;
if (k < i__ - 1) {
h__[k + 2 + (k - 1) * h_dim1] = 0.f;
}
} else if (m > l) {
h__[k + (k - 1) * h_dim1] = -h__[k + (k - 1) * h_dim1];
}
v2 = v[1];
t2 = t1 * v2;
if (nr == 3) {
v3 = v[2];
t3 = t1 * v3;
/* Apply G from the left to transform the rows of the matrix */
/* in columns K to I2. */
i__3 = i2;
for (j = k; j <= i__3; ++j) {
sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1]
+ v3 * h__[k + 2 + j * h_dim1];
h__[k + j * h_dim1] -= sum * t1;
h__[k + 1 + j * h_dim1] -= sum * t2;
h__[k + 2 + j * h_dim1] -= sum * t3;
/* L60: */
}
/* Apply G from the right to transform the columns of the */
/* matrix in rows I1 to min(K+3,I). */
/* Computing MIN */
i__4 = k + 3;
i__3 = min(i__4,i__);
for (j = i1; j <= i__3; ++j) {
sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1]
+ v3 * h__[j + (k + 2) * h_dim1];
h__[j + k * h_dim1] -= sum * t1;
h__[j + (k + 1) * h_dim1] -= sum * t2;
h__[j + (k + 2) * h_dim1] -= sum * t3;
/* L70: */
}
if (*wantz) {
/* Accumulate transformations in the matrix Z */
i__3 = *ihiz;
for (j = *iloz; j <= i__3; ++j) {
sum = z__[j + k * z_dim1] + v2 * z__[j + (k + 1) *
z_dim1] + v3 * z__[j + (k + 2) * z_dim1];
z__[j + k * z_dim1] -= sum * t1;
z__[j + (k + 1) * z_dim1] -= sum * t2;
z__[j + (k + 2) * z_dim1] -= sum * t3;
/* L80: */
}
}
} else if (nr == 2) {
/* Apply G from the left to transform the rows of the matrix */
/* in columns K to I2. */
i__3 = i2;
for (j = k; j <= i__3; ++j) {
sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1];
h__[k + j * h_dim1] -= sum * t1;
h__[k + 1 + j * h_dim1] -= sum * t2;
/* L90: */
}
/* Apply G from the right to transform the columns of the */
/* matrix in rows I1 to min(K+3,I). */
i__3 = i__;
for (j = i1; j <= i__3; ++j) {
sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1]
;
h__[j + k * h_dim1] -= sum * t1;
h__[j + (k + 1) * h_dim1] -= sum * t2;
/* L100: */
}
if (*wantz) {
/* Accumulate transformations in the matrix Z */
i__3 = *ihiz;
for (j = *iloz; j <= i__3; ++j) {
sum = z__[j + k * z_dim1] + v2 * z__[j + (k + 1) *
z_dim1];
z__[j + k * z_dim1] -= sum * t1;
z__[j + (k + 1) * z_dim1] -= sum * t2;
/* L110: */
}
}
}
/* L120: */
}
/* L130: */
}
/* Failure to converge in remaining number of iterations */
*info = i__;
return 0;
L140:
if (l == i__) {
/* H(I,I-1) is negligible: one eigenvalue has converged. */
wr[i__] = h__[i__ + i__ * h_dim1];
wi[i__] = 0.f;
} else if (l == i__ - 1) {
/* H(I-1,I-2) is negligible: a pair of eigenvalues have converged. */
/* Transform the 2-by-2 submatrix to standard Schur form, */
/* and compute and store the eigenvalues. */
slanv2_(&h__[i__ - 1 + (i__ - 1) * h_dim1], &h__[i__ - 1 + i__ *
h_dim1], &h__[i__ + (i__ - 1) * h_dim1], &h__[i__ + i__ *
h_dim1], &wr[i__ - 1], &wi[i__ - 1], &wr[i__], &wi[i__], &cs,
&sn);
if (*wantt) {
/* Apply the transformation to the rest of H. */
if (i2 > i__) {
i__1 = i2 - i__;
srot_(&i__1, &h__[i__ - 1 + (i__ + 1) * h_dim1], ldh, &h__[
i__ + (i__ + 1) * h_dim1], ldh, &cs, &sn);
}
i__1 = i__ - i1 - 1;
srot_(&i__1, &h__[i1 + (i__ - 1) * h_dim1], &c__1, &h__[i1 + i__ *
h_dim1], &c__1, &cs, &sn);
}
if (*wantz) {
/* Apply the transformation to Z. */
srot_(&nz, &z__[*iloz + (i__ - 1) * z_dim1], &c__1, &z__[*iloz +
i__ * z_dim1], &c__1, &cs, &sn);
}
}
/* Decrement number of remaining iterations, and return to start of */
/* the main loop with new value of I. */
itn -= its;
i__ = l - 1;
goto L10;
L150:
return 0;
/* End of SLAHQR */
} /* slahqr_ */
