/* 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 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 stimhr_(char *line, integer *nm, integer *mval, integer *
nn, integer *nval, integer *nnb, integer *nbval, integer *nxval,
integer *nlda, integer *ldaval, real *timmin, real *a, real *tau,
real *b, real *work, real *reslts, integer *ldr1, integer *ldr2,
integer *ldr3, integer *nout, ftnlen line_len)
{
/* Initialized data */
static char subnam[6*4] = "SGEHRD" "ORTHES" "SORGHR" "SORMHR";
static char sides[1*2] = "L" "R";
static char transs[1*2] = "N" "T";
static integer iseed[4] = { 0,0,0,1 };
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002 timing run not attempted\002,/)";
static char fmt_9998[] = "(/\002 *** Speed of \002,a6,\002 in megaflops "
"*** \002)";
static char fmt_9997[] = "(5x,\002line \002,i2,\002 with LDA = \002,i5)";
static char fmt_9995[] = "(/5x,\002ILO = 1, IHI = N\002,/)";
static char fmt_9994[] = "(/5x,\002ILO = 1, IHI = M if SIDE = 'L'\002,/5"
"x,\002 = N if SIDE = 'R'\002)";
static char fmt_9996[] = "(/5x,a6,\002 with SIDE = '\002,a1,\002', TRANS"
" = '\002,a1,\002', \002,a1,\002 =\002,i6,/)";
/* System generated locals */
integer reslts_dim1, reslts_dim2, reslts_dim3, reslts_offset, i__1, i__2,
i__3, i__4, i__5, i__6;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer ilda;
static char side[1];
static integer info;
static char path[3];
static real time;
static integer isub, i__, m, n;
static char cname[6];
static integer iside, itoff, itran;
extern doublereal sopla_(char *, integer *, integer *, integer *, integer
*, integer *);
extern /* Subroutine */ int icopy_(integer *, integer *, integer *,
integer *, integer *);
static char trans[1];
static integer i4, m1, n1;
static real s1, s2;
static integer ic;
extern /* Subroutine */ int sprtb3_(char *, char *, integer *, integer *,
integer *, integer *, integer *, integer *, real *, integer *,
integer *, integer *, ftnlen, ftnlen);
static integer nb, im, in, lw, nx, reseed[4];
extern /* Subroutine */ int atimck_(integer *, char *, integer *, integer
*, integer *, integer *, integer *, integer *, ftnlen);
extern doublereal second_(void);
extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real
*, integer *, real *, real *, integer *, integer *), atimin_(char
*, char *, integer *, char *, logical *, integer *, integer *,
ftnlen, ftnlen, ftnlen), slacpy_(char *, integer *, integer *,
real *, integer *, real *, integer *), xlaenv_(integer *,
integer *);
extern doublereal smflop_(real *, real *, integer *);
static real untime;
extern /* Subroutine */ int stimmg_(integer *, integer *, integer *, real
*, integer *, integer *, integer *);
static logical timsub[4];
extern /* Subroutine */ int orthes_(integer *, integer *, integer *,
integer *, real *, real *), slatms_(integer *, integer *, char *,
integer *, char *, real *, integer *, real *, real *, integer *,
integer *, char *, real *, integer *, real *, integer *), sorghr_(integer *, integer *, integer *, real *,
integer *, real *, real *, integer *, integer *), sprtbl_(char *,
char *, integer *, integer *, integer *, integer *, integer *,
real *, integer *, integer *, integer *, ftnlen, ftnlen), sormhr_(
char *, char *, integer *, integer *, integer *, integer *, real *
, integer *, real *, real *, integer *, real *, integer *,
integer *);
static integer lda, icl, inb, ihi, ilo;
static real ops;
static char lab1[1], lab2[1];
/* Fortran I/O blocks */
static cilist io___9 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___10 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9996, 0 };
#define subnam_ref(a_0,a_1) &subnam[(a_1)*6 + a_0 - 6]
#define reslts_ref(a_1,a_2,a_3,a_4) reslts[(((a_4)*reslts_dim3 + (a_3))*\
reslts_dim2 + (a_2))*reslts_dim1 + a_1]
/* -- LAPACK timing routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
STIMHR times the LAPACK routines SGEHRD, SORGHR, and SORMHR and the
EISPACK routine ORTHES.
Arguments
=========
LINE (input) CHARACTER*80
The input line that requested this routine. The first six
characters contain either the name of a subroutine or a
generic path name. The remaining characters may be used to
specify the individual routines to be timed. See ATIMIN for
a full description of the format of the input line.
NM (input) INTEGER
The number of values of M contained in the vector MVAL.
MVAL (input) INTEGER array, dimension (NM)
The values of the matrix size M.
NN (input) INTEGER
The number of values of N contained in the vector NVAL.
NVAL (input) INTEGER array, dimension (NN)
The values of the matrix column dimension N.
NNB (input) INTEGER
The number of values of NB and NX contained in the
vectors NBVAL and NXVAL. The blocking parameters are used
in pairs (NB,NX).
NBVAL (input) INTEGER array, dimension (NNB)
The values of the blocksize NB.
NXVAL (input) INTEGER array, dimension (NNB)
The values of the crossover point NX.
NLDA (input) INTEGER
The number of values of LDA contained in the vector LDAVAL.
LDAVAL (input) INTEGER array, dimension (NLDA)
The values of the leading dimension of the array A.
TIMMIN (input) REAL
The minimum time a subroutine will be timed.
A (workspace) REAL array, dimension (LDAMAX*NMAX)
where LDAMAX and NMAX are the maximum values of LDA and N.
TAU (workspace) REAL array, dimension (min(M,N))
B (workspace) REAL array, dimension (LDAMAX*NMAX)
WORK (workspace) REAL array, dimension (LDAMAX*NBMAX)
where NBMAX is the maximum value of NB.
RESLTS (workspace) REAL array, dimension
(LDR1,LDR2,LDR3,4*NN+3)
The timing results for each subroutine over the relevant
values of M, (NB,NX), LDA, and N.
LDR1 (input) INTEGER
The first dimension of RESLTS. LDR1 >= max(1,NNB).
LDR2 (input) INTEGER
The second dimension of RESLTS. LDR2 >= max(1,NM).
LDR3 (input) INTEGER
The third dimension of RESLTS. LDR3 >= max(1,NLDA).
NOUT (input) INTEGER
The unit number for output.
Internal Parameters
===================
MODE INTEGER
The matrix type. MODE = 3 is a geometric distribution of
eigenvalues. See CLATMS for further details.
COND REAL
The condition number of the matrix. The singular values are
set to values from DMAX to DMAX/COND.
DMAX REAL
The magnitude of the largest singular value.
=====================================================================
Parameter adjustments */
--mval;
--nval;
--nbval;
--nxval;
--ldaval;
--a;
--tau;
--b;
--work;
reslts_dim1 = *ldr1;
reslts_dim2 = *ldr2;
reslts_dim3 = *ldr3;
reslts_offset = 1 + reslts_dim1 * (1 + reslts_dim2 * (1 + reslts_dim3 * 1)
);
reslts -= reslts_offset;
/* Function Body
Extract the timing request from the input line. */
s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "HR", (ftnlen)2, (ftnlen)2);
atimin_(path, line, &c__4, subnam, timsub, nout, &info, (ftnlen)3, (
ftnlen)80, (ftnlen)6);
if (info != 0) {
goto L210;
}
/* Check that N <= LDA for the input values. */
s_copy(cname, line, (ftnlen)6, (ftnlen)6);
atimck_(&c__2, cname, nm, &mval[1], nlda, &ldaval[1], nout, &info, (
ftnlen)6);
if (info > 0) {
io___9.ciunit = *nout;
s_wsfe(&io___9);
do_fio(&c__1, cname, (ftnlen)6);
e_wsfe();
goto L210;
}
/* Check that K <= LDA for SORMHR */
if (timsub[3]) {
atimck_(&c__3, cname, nn, &nval[1], nlda, &ldaval[1], nout, &info, (
ftnlen)6);
if (info > 0) {
io___10.ciunit = *nout;
s_wsfe(&io___10);
do_fio(&c__1, subnam_ref(0, 4), (ftnlen)6);
e_wsfe();
timsub[3] = FALSE_;
}
}
/* Do for each value of M: */
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
m = mval[im];
ilo = 1;
ihi = m;
icopy_(&c__4, iseed, &c__1, reseed, &c__1);
/* Do for each value of LDA: */
i__2 = *nlda;
for (ilda = 1; ilda <= i__2; ++ilda) {
lda = ldaval[ilda];
/* Do for each pair of values (NB, NX) in NBVAL and NXVAL. */
i__3 = *nnb;
for (inb = 1; inb <= i__3; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
nx = nxval[inb];
xlaenv_(&c__3, &nx);
/* Computing MAX */
i__4 = 1, i__5 = m * max(1,nb);
lw = max(i__4,i__5);
/* Generate a test matrix of size M by M. */
icopy_(&c__4, reseed, &c__1, iseed, &c__1);
slatms_(&m, &m, "Uniform", iseed, "Nonsym", &tau[1], &c__3, &
c_b26, &c_b27, &m, &m, "No packing", &b[1], &lda, &
work[1], &info);
if (timsub[1] && inb == 1) {
/* ORTHES: Eispack reduction using orthogonal
transformations. */
slacpy_("Full", &m, &m, &b[1], &lda, &a[1], &lda);
ic = 0;
s1 = second_();
L10:
orthes_(&lda, &m, &c__1, &ihi, &a[1], &tau[1]);
s2 = second_();
time = s2 - s1;
++ic;
if (time < *timmin) {
slacpy_("Full", &m, &m, &b[1], &lda, &a[1], &lda);
goto L10;
}
/* Subtract the time used in SLACPY. */
icl = 1;
s1 = second_();
L20:
s2 = second_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
slacpy_("Full", &m, &m, &b[1], &lda, &a[1], &lda);
goto L20;
}
time = (time - untime) / (real) ic;
ops = sopla_("SGEHRD", &m, &ilo, &ihi, &c__0, &nb);
reslts_ref(inb, im, ilda, 2) = smflop_(&ops, &time, &info)
;
}
if (timsub[0]) {
/* SGEHRD: Reduction to Hesenberg form */
slacpy_("Full", &m, &m, &b[1], &lda, &a[1], &lda);
ic = 0;
s1 = second_();
L30:
sgehrd_(&m, &ilo, &ihi, &a[1], &lda, &tau[1], &work[1], &
lw, &info);
s2 = second_();
time = s2 - s1;
++ic;
if (time < *timmin) {
slacpy_("Full", &m, &m, &b[1], &lda, &a[1], &lda);
goto L30;
}
/* Subtract the time used in SLACPY. */
icl = 1;
s1 = second_();
L40:
s2 = second_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
slacpy_("Full", &m, &m, &a[1], &lda, &b[1], &lda);
goto L40;
}
time = (time - untime) / (real) ic;
ops = sopla_("SGEHRD", &m, &ilo, &ihi, &c__0, &nb);
reslts_ref(inb, im, ilda, 1) = smflop_(&ops, &time, &info)
;
} else {
/* If SGEHRD was not timed, generate a matrix and factor
it using SGEHRD anyway so that the factored form of
the matrix can be used in timing the other routines. */
slacpy_("Full", &m, &m, &b[1], &lda, &a[1], &lda);
sgehrd_(&m, &ilo, &ihi, &a[1], &lda, &tau[1], &work[1], &
lw, &info);
}
if (timsub[2]) {
/* SORGHR: Generate the orthogonal matrix Q from the
reduction to Hessenberg form A = Q*H*Q' */
slacpy_("Full", &m, &m, &a[1], &lda, &b[1], &lda);
ic = 0;
s1 = second_();
L50:
sorghr_(&m, &ilo, &ihi, &b[1], &lda, &tau[1], &work[1], &
lw, &info);
s2 = second_();
time = s2 - s1;
++ic;
if (time < *timmin) {
slacpy_("Full", &m, &m, &a[1], &lda, &b[1], &lda);
goto L50;
}
/* Subtract the time used in SLACPY. */
icl = 1;
s1 = second_();
L60:
s2 = second_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
slacpy_("Full", &m, &m, &a[1], &lda, &b[1], &lda);
goto L60;
}
time = (time - untime) / (real) ic;
/* Op count for SORGHR: same as
SORGQR( IHI-ILO, IHI-ILO, IHI-ILO, ... ) */
i__4 = ihi - ilo;
i__5 = ihi - ilo;
i__6 = ihi - ilo;
ops = sopla_("SORGQR", &i__4, &i__5, &i__6, &c__0, &nb);
reslts_ref(inb, im, ilda, 3) = smflop_(&ops, &time, &info)
;
}
if (timsub[3]) {
/* SORMHR: Multiply by Q stored as a product of
elementary transformations */
i4 = 3;
for (iside = 1; iside <= 2; ++iside) {
*(unsigned char *)side = *(unsigned char *)&sides[
iside - 1];
i__4 = *nn;
for (in = 1; in <= i__4; ++in) {
n = nval[in];
/* Computing MAX */
i__5 = 1, i__6 = max(1,nb) * n;
lw = max(i__5,i__6);
if (iside == 1) {
m1 = m;
n1 = n;
} else {
m1 = n;
n1 = m;
}
itoff = 0;
for (itran = 1; itran <= 2; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&
transs[itran - 1];
stimmg_(&c__0, &m1, &n1, &b[1], &lda, &c__0, &
c__0);
ic = 0;
s1 = second_();
L70:
sormhr_(side, trans, &m1, &n1, &ilo, &ihi, &a[
1], &lda, &tau[1], &b[1], &lda, &work[
1], &lw, &info);
s2 = second_();
time = s2 - s1;
++ic;
if (time < *timmin) {
stimmg_(&c__0, &m1, &n1, &b[1], &lda, &
c__0, &c__0);
goto L70;
}
/* Subtract the time used in STIMMG. */
icl = 1;
s1 = second_();
L80:
s2 = second_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
stimmg_(&c__0, &m1, &n1, &b[1], &lda, &
c__0, &c__0);
goto L80;
}
time = (time - untime) / (real) ic;
/* Op count for SORMHR, SIDE='L': same as
SORMQR( 'L', TRANS, IHI-ILO, N, IHI-ILO, ...)
Op count for SORMHR, SIDE='R': same as
SORMQR( 'R', TRANS, M, IHI-ILO, IHI-ILO, ...) */
if (iside == 1) {
i__5 = ihi - ilo;
i__6 = ihi - ilo;
ops = sopla_("SORMQR", &i__5, &n1, &i__6,
&c_n1, &nb);
} else {
i__5 = ihi - ilo;
i__6 = ihi - ilo;
ops = sopla_("SORMQR", &m1, &i__5, &i__6,
&c__1, &nb);
}
reslts_ref(inb, im, ilda, i4 + itoff + in) =
smflop_(&ops, &time, &info);
itoff = *nn;
/* L90: */
}
/* L100: */
}
i4 += *nn << 1;
/* L110: */
}
}
/* L120: */
}
/* L130: */
}
/* L140: */
}
/* Print tables of results for SGEHRD, ORTHES, and SORGHR */
for (isub = 1; isub <= 3; ++isub) {
if (! timsub[isub - 1]) {
goto L160;
}
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, subnam_ref(0, isub), (ftnlen)6);
e_wsfe();
if (*nlda > 1) {
i__1 = *nlda;
for (i__ = 1; i__ <= i__1; ++i__) {
io___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ldaval[i__], (ftnlen)sizeof(integer));
e_wsfe();
/* L150: */
}
}
io___43.ciunit = *nout;
s_wsfe(&io___43);
e_wsfe();
if (isub == 2) {
sprtb3_(" ", "N", &c__1, &nbval[1], &nxval[1], nm, &mval[1], nlda,
&reslts_ref(1, 1, 1, isub), ldr1, ldr2, nout, (ftnlen)1,
(ftnlen)1);
} else {
sprtb3_("( NB, NX)", "N", nnb, &nbval[1], &nxval[1], nm, &mval[
1], nlda, &reslts_ref(1, 1, 1, isub), ldr1, ldr2, nout, (
ftnlen)11, (ftnlen)1);
}
L160:
;
}
/* Print tables of results for SORMHR */
isub = 4;
if (timsub[isub - 1]) {
i4 = 3;
for (iside = 1; iside <= 2; ++iside) {
if (iside == 1) {
*(unsigned char *)lab1 = 'M';
*(unsigned char *)lab2 = 'N';
if (*nlda > 1) {
io___46.ciunit = *nout;
s_wsfe(&io___46);
do_fio(&c__1, subnam_ref(0, isub), (ftnlen)6);
e_wsfe();
i__1 = *nlda;
for (i__ = 1; i__ <= i__1; ++i__) {
io___47.ciunit = *nout;
s_wsfe(&io___47);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ldaval[i__], (ftnlen)sizeof(
integer));
e_wsfe();
/* L170: */
}
io___48.ciunit = *nout;
s_wsfe(&io___48);
e_wsfe();
}
} else {
*(unsigned char *)lab1 = 'N';
*(unsigned char *)lab2 = 'M';
}
for (itran = 1; itran <= 2; ++itran) {
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
io___49.ciunit = *nout;
s_wsfe(&io___49);
do_fio(&c__1, subnam_ref(0, isub), (ftnlen)6);
do_fio(&c__1, sides + (iside - 1), (ftnlen)1);
do_fio(&c__1, transs + (itran - 1), (ftnlen)1);
do_fio(&c__1, lab2, (ftnlen)1);
do_fio(&c__1, (char *)&nval[in], (ftnlen)sizeof(integer));
e_wsfe();
sprtbl_("NB", lab1, nnb, &nbval[1], nm, &mval[1], nlda, &
reslts_ref(1, 1, 1, i4 + in), ldr1, ldr2, nout, (
ftnlen)2, (ftnlen)1);
/* L180: */
}
i4 += *nn;
/* L190: */
}
/* L200: */
}
}
L210:
/* Print a table of results for each timed routine. */
return 0;
/* End of STIMHR */
} /* stimhr_ */
/* Subroutine */ int sgeevx_(char *balanc, char *jobvl, char *jobvr, char *
sense, integer *n, real *a, integer *lda, real *wr, real *wi, real *
vl, integer *ldvl, real *vr, integer *ldvr, integer *ilo, integer *
ihi, real *scale, real *abnrm, real *rconde, real *rcondv, real *work,
integer *lwork, integer *iwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, k;
real r__, cs, sn;
char job[1];
real scl, dum[1], eps;
char side[1];
real anrm;
integer ierr, itau, iwrk, nout;
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *);
extern doublereal snrm2_(integer *, real *, integer *);
integer icond;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
extern doublereal slapy2_(real *, real *);
extern /* Subroutine */ int slabad_(real *, real *);
logical scalea;
real cscale;
extern /* Subroutine */ int sgebak_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, integer *, integer *), sgebal_(char *, integer *, real *, integer *,
integer *, integer *, real *, integer *);
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real
*, integer *, real *, real *, integer *, integer *), xerbla_(char
*, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
logical select[1];
real bignum;
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *);
extern integer isamax_(integer *, real *, integer *);
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), slartg_(real *, real *,
real *, real *, real *), sorghr_(integer *, integer *, integer *,
real *, integer *, real *, real *, integer *, integer *), shseqr_(
char *, char *, integer *, integer *, integer *, real *, integer *
, real *, real *, real *, integer *, real *, integer *, integer *), strevc_(char *, char *, logical *, integer *,
real *, integer *, real *, integer *, real *, integer *, integer *
, integer *, real *, integer *);
integer minwrk, maxwrk;
extern /* Subroutine */ int strsna_(char *, char *, logical *, integer *,
real *, integer *, real *, integer *, real *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *,
integer *);
logical wantvl, wntsnb;
integer hswork;
logical wntsne;
real smlnum;
logical lquery, wantvr, wntsnn, wntsnv;
/* -- LAPACK driver routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGEEVX computes for an N-by-N real nonsymmetric matrix A, the */
/* eigenvalues and, optionally, the left and/or right eigenvectors. */
/* Optionally also, it computes a balancing transformation to improve */
/* the conditioning of the eigenvalues and eigenvectors (ILO, IHI, */
/* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues */
/* (RCONDE), and reciprocal condition numbers for the right */
/* eigenvectors (RCONDV). */
/* The right eigenvector v(j) of A satisfies */
/* A * v(j) = lambda(j) * v(j) */
/* where lambda(j) is its eigenvalue. */
/* The left eigenvector u(j) of A satisfies */
/* u(j)**H * A = lambda(j) * u(j)**H */
/* where u(j)**H denotes the conjugate transpose of u(j). */
/* The computed eigenvectors are normalized to have Euclidean norm */
/* equal to 1 and largest component real. */
/* Balancing a matrix means permuting the rows and columns to make it */
/* more nearly upper triangular, and applying a diagonal similarity */
/* transformation D * A * D**(-1), where D is a diagonal matrix, to */
/* make its rows and columns closer in norm and the condition numbers */
/* of its eigenvalues and eigenvectors smaller. The computed */
/* reciprocal condition numbers correspond to the balanced matrix. */
/* Permuting rows and columns will not change the condition numbers */
/* (in exact arithmetic) but diagonal scaling will. For further */
/* explanation of balancing, see section 4.10.2 of the LAPACK */
/* Users' Guide. */
/* Arguments */
/* ========= */
/* BALANC (input) CHARACTER*1 */
/* Indicates how the input matrix should be diagonally scaled */
/* and/or permuted to improve the conditioning of its */
/* eigenvalues. */
/* = 'N': Do not diagonally scale or permute; */
/* = 'P': Perform permutations to make the matrix more nearly */
/* upper triangular. Do not diagonally scale; */
/* = 'S': Diagonally scale the matrix, i.e. replace A by */
/* D*A*D**(-1), where D is a diagonal matrix chosen */
/* to make the rows and columns of A more equal in */
/* norm. Do not permute; */
/* = 'B': Both diagonally scale and permute A. */
/* Computed reciprocal condition numbers will be for the matrix */
/* after balancing and/or permuting. Permuting does not change */
/* condition numbers (in exact arithmetic), but balancing does. */
/* JOBVL (input) CHARACTER*1 */
/* = 'N': left eigenvectors of A are not computed; */
/* = 'V': left eigenvectors of A are computed. */
/* If SENSE = 'E' or 'B', JOBVL must = 'V'. */
/* JOBVR (input) CHARACTER*1 */
/* = 'N': right eigenvectors of A are not computed; */
/* = 'V': right eigenvectors of A are computed. */
/* If SENSE = 'E' or 'B', JOBVR must = 'V'. */
/* SENSE (input) CHARACTER*1 */
/* Determines which reciprocal condition numbers are computed. */
/* = 'N': None are computed; */
/* = 'E': Computed for eigenvalues only; */
/* = 'V': Computed for right eigenvectors only; */
/* = 'B': Computed for eigenvalues and right eigenvectors. */
/* If SENSE = 'E' or 'B', both left and right eigenvectors */
/* must also be computed (JOBVL = 'V' and JOBVR = 'V'). */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the N-by-N matrix A. */
/* On exit, A has been overwritten. If JOBVL = 'V' or */
/* JOBVR = 'V', A contains the real Schur form of the balanced */
/* version of the input matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* WR (output) REAL array, dimension (N) */
/* WI (output) REAL array, dimension (N) */
/* WR and WI contain the real and imaginary parts, */
/* respectively, of the computed eigenvalues. Complex */
/* conjugate pairs of eigenvalues will appear consecutively */
/* with the eigenvalue having the positive imaginary part */
/* first. */
/* VL (output) REAL array, dimension (LDVL,N) */
/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */
/* after another in the columns of VL, in the same order */
/* as their eigenvalues. */
/* If JOBVL = 'N', VL is not referenced. */
/* If the j-th eigenvalue is real, then u(j) = VL(:,j), */
/* the j-th column of VL. */
/* If the j-th and (j+1)-st eigenvalues form a complex */
/* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and */
/* u(j+1) = VL(:,j) - i*VL(:,j+1). */
/* LDVL (input) INTEGER */
/* The leading dimension of the array VL. LDVL >= 1; if */
/* JOBVL = 'V', LDVL >= N. */
/* VR (output) REAL array, dimension (LDVR,N) */
/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */
/* after another in the columns of VR, in the same order */
/* as their eigenvalues. */
/* If JOBVR = 'N', VR is not referenced. */
/* If the j-th eigenvalue is real, then v(j) = VR(:,j), */
/* the j-th column of VR. */
/* If the j-th and (j+1)-st eigenvalues form a complex */
/* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and */
/* v(j+1) = VR(:,j) - i*VR(:,j+1). */
/* LDVR (input) INTEGER */
/* The leading dimension of the array VR. LDVR >= 1, and if */
/* JOBVR = 'V', LDVR >= N. */
/* ILO (output) INTEGER */
/* IHI (output) INTEGER */
/* ILO and IHI are integer values determined when A was */
/* balanced. The balanced A(i,j) = 0 if I > J and */
/* J = 1,...,ILO-1 or I = IHI+1,...,N. */
/* SCALE (output) REAL array, dimension (N) */
/* Details of the permutations and scaling factors applied */
/* when balancing A. If P(j) is the index of the row and column */
/* interchanged with row and column j, and D(j) is the scaling */
/* factor applied to row and column j, then */
/* SCALE(J) = P(J), for J = 1,...,ILO-1 */
/* = D(J), for J = ILO,...,IHI */
/* = P(J) for J = IHI+1,...,N. */
/* The order in which the interchanges are made is N to IHI+1, */
/* then 1 to ILO-1. */
/* ABNRM (output) REAL */
/* The one-norm of the balanced matrix (the maximum */
/* of the sum of absolute values of elements of any column). */
/* RCONDE (output) REAL array, dimension (N) */
/* RCONDE(j) is the reciprocal condition number of the j-th */
/* eigenvalue. */
/* RCONDV (output) REAL array, dimension (N) */
/* RCONDV(j) is the reciprocal condition number of the j-th */
/* right eigenvector. */
/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. If SENSE = 'N' or 'E', */
/* LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V', */
/* LWORK >= 3*N. If SENSE = 'V' or 'B', LWORK >= N*(N+6). */
/* For good performance, LWORK must generally be larger. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* IWORK (workspace) INTEGER array, dimension (2*N-2) */
/* If SENSE = 'N' or 'E', not referenced. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = i, the QR algorithm failed to compute all the */
/* eigenvalues, and no eigenvectors or condition numbers */
/* have been computed; elements 1:ILO-1 and i+1:N of WR */
/* and WI contain eigenvalues which have converged. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--wr;
--wi;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--scale;
--rconde;
--rcondv;
--work;
--iwork;
/* Function Body */
*info = 0;
lquery = *lwork == -1;
wantvl = lsame_(jobvl, "V");
wantvr = lsame_(jobvr, "V");
wntsnn = lsame_(sense, "N");
wntsne = lsame_(sense, "E");
wntsnv = lsame_(sense, "V");
wntsnb = lsame_(sense, "B");
if (! (lsame_(balanc, "N") || lsame_(balanc, "S") || lsame_(balanc, "P")
|| lsame_(balanc, "B"))) {
*info = -1;
} else if (! wantvl && ! lsame_(jobvl, "N")) {
*info = -2;
} else if (! wantvr && ! lsame_(jobvr, "N")) {
*info = -3;
} else if (! (wntsnn || wntsne || wntsnb || wntsnv) || (wntsne || wntsnb)
&& ! (wantvl && wantvr)) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldvl < 1 || wantvl && *ldvl < *n) {
*info = -11;
} else if (*ldvr < 1 || wantvr && *ldvr < *n) {
*info = -13;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "Workspace:" describe the */
/* minimal amount of workspace needed at that point in the code, */
/* as well as the preferred amount for good performance. */
/* NB refers to the optimal block size for the immediately */
/* following subroutine, as returned by ILAENV. */
/* HSWORK refers to the workspace preferred by SHSEQR, as */
/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
/* the worst case.) */
if (*info == 0) {
if (*n == 0) {
minwrk = 1;
maxwrk = 1;
} else {
maxwrk = *n + *n * ilaenv_(&c__1, "SGEHRD", " ", n, &c__1, n, &
c__0);
if (wantvl) {
shseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
1], &vl[vl_offset], ldvl, &work[1], &c_n1, info);
} else if (wantvr) {
shseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
1], &vr[vr_offset], ldvr, &work[1], &c_n1, info);
} else {
if (wntsnn) {
shseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &wr[1],
&wi[1], &vr[vr_offset], ldvr, &work[1], &c_n1,
info);
} else {
shseqr_("S", "N", n, &c__1, n, &a[a_offset], lda, &wr[1],
&wi[1], &vr[vr_offset], ldvr, &work[1], &c_n1,
info);
}
}
hswork = work[1];
if (! wantvl && ! wantvr) {
minwrk = *n << 1;
if (! wntsnn) {
/* Computing MAX */
i__1 = minwrk, i__2 = *n * *n + *n * 6;
minwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,hswork);
if (! wntsnn) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *n + *n * 6;
maxwrk = max(i__1,i__2);
}
} else {
minwrk = *n * 3;
if (! wntsnn && ! wntsne) {
/* Computing MAX */
i__1 = minwrk, i__2 = *n * *n + *n * 6;
minwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,hswork);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "SORGHR",
" ", n, &c__1, n, &c_n1);
maxwrk = max(i__1,i__2);
if (! wntsnn && ! wntsne) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *n + *n * 6;
maxwrk = max(i__1,i__2);
}
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * 3;
maxwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,minwrk);
}
work[1] = (real) maxwrk;
if (*lwork < minwrk && ! lquery) {
*info = -21;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGEEVX", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = slamch_("P");
smlnum = slamch_("S");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1.f / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
icond = 0;
anrm = slange_("M", n, n, &a[a_offset], lda, dum);
scalea = FALSE_;
if (anrm > 0.f && anrm < smlnum) {
scalea = TRUE_;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = TRUE_;
cscale = bignum;
}
if (scalea) {
slascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
ierr);
}
/* Balance the matrix and compute ABNRM */
sgebal_(balanc, n, &a[a_offset], lda, ilo, ihi, &scale[1], &ierr);
*abnrm = slange_("1", n, n, &a[a_offset], lda, dum);
if (scalea) {
dum[0] = *abnrm;
slascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &c__1, &
ierr);
*abnrm = dum[0];
}
/* Reduce to upper Hessenberg form */
/* (Workspace: need 2*N, prefer N+N*NB) */
itau = 1;
iwrk = itau + *n;
i__1 = *lwork - iwrk + 1;
sgehrd_(n, ilo, ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, &
ierr);
if (wantvl) {
/* Want left eigenvectors */
/* Copy Householder vectors to VL */
*(unsigned char *)side = 'L';
slacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl)
;
/* Generate orthogonal matrix in VL */
/* (Workspace: need 2*N-1, prefer N+(N-1)*NB) */
i__1 = *lwork - iwrk + 1;
sorghr_(n, ilo, ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk], &
i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VL */
/* (Workspace: need 1, prefer HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
shseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vl[
vl_offset], ldvl, &work[iwrk], &i__1, info);
if (wantvr) {
/* Want left and right eigenvectors */
/* Copy Schur vectors to VR */
*(unsigned char *)side = 'B';
slacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr);
}
} else if (wantvr) {
/* Want right eigenvectors */
/* Copy Householder vectors to VR */
*(unsigned char *)side = 'R';
slacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr)
;
/* Generate orthogonal matrix in VR */
/* (Workspace: need 2*N-1, prefer N+(N-1)*NB) */
i__1 = *lwork - iwrk + 1;
sorghr_(n, ilo, ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk], &
i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VR */
/* (Workspace: need 1, prefer HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
shseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vr[
vr_offset], ldvr, &work[iwrk], &i__1, info);
} else {
/* Compute eigenvalues only */
/* If condition numbers desired, compute Schur form */
if (wntsnn) {
*(unsigned char *)job = 'E';
} else {
*(unsigned char *)job = 'S';
}
/* (Workspace: need 1, prefer HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
shseqr_(job, "N", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vr[
vr_offset], ldvr, &work[iwrk], &i__1, info);
}
/* If INFO > 0 from SHSEQR, then quit */
if (*info > 0) {
goto L50;
}
if (wantvl || wantvr) {
/* Compute left and/or right eigenvectors */
/* (Workspace: need 3*N) */
strevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl,
&vr[vr_offset], ldvr, n, &nout, &work[iwrk], &ierr);
}
/* Compute condition numbers if desired */
/* (Workspace: need N*N+6*N unless SENSE = 'E') */
if (! wntsnn) {
strsna_(sense, "A", select, n, &a[a_offset], lda, &vl[vl_offset],
ldvl, &vr[vr_offset], ldvr, &rconde[1], &rcondv[1], n, &nout,
&work[iwrk], n, &iwork[1], &icond);
}
if (wantvl) {
/* Undo balancing of left eigenvectors */
sgebak_(balanc, "L", n, ilo, ihi, &scale[1], n, &vl[vl_offset], ldvl,
&ierr);
/* Normalize left eigenvectors and make largest component real */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (wi[i__] == 0.f) {
scl = 1.f / snrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
sscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
} else if (wi[i__] > 0.f) {
r__1 = snrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
r__2 = snrm2_(n, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
scl = 1.f / slapy2_(&r__1, &r__2);
sscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
sscal_(n, &scl, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
/* Computing 2nd power */
r__1 = vl[k + i__ * vl_dim1];
/* Computing 2nd power */
r__2 = vl[k + (i__ + 1) * vl_dim1];
work[k] = r__1 * r__1 + r__2 * r__2;
/* L10: */
}
k = isamax_(n, &work[1], &c__1);
slartg_(&vl[k + i__ * vl_dim1], &vl[k + (i__ + 1) * vl_dim1],
&cs, &sn, &r__);
srot_(n, &vl[i__ * vl_dim1 + 1], &c__1, &vl[(i__ + 1) *
vl_dim1 + 1], &c__1, &cs, &sn);
vl[k + (i__ + 1) * vl_dim1] = 0.f;
}
/* L20: */
}
}
if (wantvr) {
/* Undo balancing of right eigenvectors */
sgebak_(balanc, "R", n, ilo, ihi, &scale[1], n, &vr[vr_offset], ldvr,
&ierr);
/* Normalize right eigenvectors and make largest component real */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (wi[i__] == 0.f) {
scl = 1.f / snrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
sscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
} else if (wi[i__] > 0.f) {
r__1 = snrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
r__2 = snrm2_(n, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
scl = 1.f / slapy2_(&r__1, &r__2);
sscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
sscal_(n, &scl, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
/* Computing 2nd power */
r__1 = vr[k + i__ * vr_dim1];
/* Computing 2nd power */
r__2 = vr[k + (i__ + 1) * vr_dim1];
work[k] = r__1 * r__1 + r__2 * r__2;
/* L30: */
}
k = isamax_(n, &work[1], &c__1);
slartg_(&vr[k + i__ * vr_dim1], &vr[k + (i__ + 1) * vr_dim1],
&cs, &sn, &r__);
srot_(n, &vr[i__ * vr_dim1 + 1], &c__1, &vr[(i__ + 1) *
vr_dim1 + 1], &c__1, &cs, &sn);
vr[k + (i__ + 1) * vr_dim1] = 0.f;
}
/* L40: */
}
}
/* Undo scaling if necessary */
L50:
if (scalea) {
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = max(i__3,1);
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[*info +
1], &i__2, &ierr);
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = max(i__3,1);
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[*info +
1], &i__2, &ierr);
if (*info == 0) {
if ((wntsnv || wntsnb) && icond == 0) {
slascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &rcondv[
1], n, &ierr);
}
} else {
i__1 = *ilo - 1;
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[1],
n, &ierr);
i__1 = *ilo - 1;
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[1],
n, &ierr);
}
}
work[1] = (real) maxwrk;
return 0;
/* End of SGEEVX */
} /* sgeevx_ */
/* Subroutine */ int sget37_(real *rmax, integer *lmax, integer *ninfo,
integer *knt, integer *nin)
{
/* System generated locals */
integer i__1, i__2;
real r__1, r__2;
/* Local variables */
integer i__, j, m, n;
real s[20], t[400] /* was [20][20] */, v, le[400] /* was [20][20] */,
re[400] /* was [20][20] */, wi[20], wr[20], val[3], dum[1],
eps, sep[20], sin__[20], tol, tmp[400] /* was [20][20] */;
integer ifnd, icmp, iscl, info, lcmp[3], kmin;
real wiin[20], vmax, tnrm, wrin[20], work[1200], vmul, stmp[20];
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
real sepin[20], vimin, tolin, vrmin;
integer iwork[40];
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
real witmp[20], wrtmp[20];
extern /* Subroutine */ int slabad_(real *, real *);
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real
*, integer *, real *, real *, integer *, integer *);
logical select[20];
real bignum;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), shseqr_(char *, char *,
integer *, integer *, integer *, real *, integer *, real *, real *
, real *, integer *, real *, integer *, integer *)
, strevc_(char *, char *, logical *, integer *, real *, integer *,
real *, integer *, real *, integer *, integer *, integer *, real
*, integer *);
real septmp[20];
extern /* Subroutine */ int strsna_(char *, char *, logical *, integer *,
real *, integer *, real *, integer *, real *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *,
integer *);
real smlnum;
/* Fortran I/O blocks */
static cilist io___5 = { 0, 0, 0, 0, 0 };
static cilist io___8 = { 0, 0, 0, 0, 0 };
static cilist io___11 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGET37 tests STRSNA, a routine for estimating condition numbers of */
/* eigenvalues and/or right eigenvectors of a matrix. */
/* The test matrices are read from a file with logical unit number NIN. */
/* Arguments */
/* ========== */
/* RMAX (output) REAL array, dimension (3) */
/* Value of the largest test ratio. */
/* RMAX(1) = largest ratio comparing different calls to STRSNA */
/* RMAX(2) = largest error in reciprocal condition */
/* numbers taking their conditioning into account */
/* RMAX(3) = largest error in reciprocal condition */
/* numbers not taking their conditioning into */
/* account (may be larger than RMAX(2)) */
/* LMAX (output) INTEGER array, dimension (3) */
/* LMAX(i) is example number where largest test ratio */
/* RMAX(i) is achieved. Also: */
/* If SGEHRD returns INFO nonzero on example i, LMAX(1)=i */
/* If SHSEQR returns INFO nonzero on example i, LMAX(2)=i */
/* If STRSNA returns INFO nonzero on example i, LMAX(3)=i */
/* NINFO (output) INTEGER array, dimension (3) */
/* NINFO(1) = No. of times SGEHRD returned INFO nonzero */
/* NINFO(2) = No. of times SHSEQR returned INFO nonzero */
/* NINFO(3) = No. of times STRSNA returned INFO nonzero */
/* KNT (output) INTEGER */
/* Total number of examples tested. */
/* NIN (input) INTEGER */
/* Input logical unit number */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--ninfo;
--lmax;
--rmax;
/* Function Body */
eps = slamch_("P");
smlnum = slamch_("S") / eps;
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
/* EPSIN = 2**(-24) = precision to which input data computed */
eps = dmax(eps,5.9605e-8f);
rmax[1] = 0.f;
rmax[2] = 0.f;
rmax[3] = 0.f;
lmax[1] = 0;
lmax[2] = 0;
lmax[3] = 0;
*knt = 0;
ninfo[1] = 0;
ninfo[2] = 0;
ninfo[3] = 0;
val[0] = sqrt(smlnum);
val[1] = 1.f;
val[2] = sqrt(bignum);
/* Read input data until N=0. Assume input eigenvalues are sorted */
/* lexicographically (increasing by real part, then decreasing by */
/* imaginary part) */
L10:
io___5.ciunit = *nin;
s_rsle(&io___5);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
return 0;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___8.ciunit = *nin;
s_rsle(&io___8);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__4, &c__1, (char *)&tmp[i__ + j * 20 - 21], (ftnlen)
sizeof(real));
}
e_rsle();
/* L20: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___11.ciunit = *nin;
s_rsle(&io___11);
do_lio(&c__4, &c__1, (char *)&wrin[i__ - 1], (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&wiin[i__ - 1], (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&sin__[i__ - 1], (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&sepin[i__ - 1], (ftnlen)sizeof(real));
e_rsle();
/* L30: */
}
tnrm = slange_("M", &n, &n, tmp, &c__20, work);
/* Begin test */
for (iscl = 1; iscl <= 3; ++iscl) {
/* Scale input matrix */
++(*knt);
slacpy_("F", &n, &n, tmp, &c__20, t, &c__20);
vmul = val[iscl - 1];
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
sscal_(&n, &vmul, &t[i__ * 20 - 20], &c__1);
/* L40: */
}
if (tnrm == 0.f) {
vmul = 1.f;
}
/* Compute eigenvalues and eigenvectors */
i__1 = 1200 - n;
sgehrd_(&n, &c__1, &n, t, &c__20, work, &work[n], &i__1, &info);
if (info != 0) {
lmax[1] = *knt;
++ninfo[1];
goto L240;
}
i__1 = n - 2;
for (j = 1; j <= i__1; ++j) {
i__2 = n;
for (i__ = j + 2; i__ <= i__2; ++i__) {
t[i__ + j * 20 - 21] = 0.f;
/* L50: */
}
/* L60: */
}
/* Compute Schur form */
shseqr_("S", "N", &n, &c__1, &n, t, &c__20, wr, wi, dum, &c__1, work,
&c__1200, &info);
if (info != 0) {
lmax[2] = *knt;
++ninfo[2];
goto L240;
}
/* Compute eigenvectors */
strevc_("Both", "All", select, &n, t, &c__20, le, &c__20, re, &c__20,
&n, &m, work, &info);
/* Compute condition numbers */
strsna_("Both", "All", select, &n, t, &c__20, le, &c__20, re, &c__20,
s, sep, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
/* Sort eigenvalues and condition numbers lexicographically */
/* to compare with inputs */
scopy_(&n, wr, &c__1, wrtmp, &c__1);
scopy_(&n, wi, &c__1, witmp, &c__1);
scopy_(&n, s, &c__1, stmp, &c__1);
scopy_(&n, sep, &c__1, septmp, &c__1);
r__1 = 1.f / vmul;
sscal_(&n, &r__1, septmp, &c__1);
i__1 = n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
kmin = i__;
vrmin = wrtmp[i__ - 1];
vimin = witmp[i__ - 1];
i__2 = n;
for (j = i__ + 1; j <= i__2; ++j) {
if (wrtmp[j - 1] < vrmin) {
kmin = j;
vrmin = wrtmp[j - 1];
vimin = witmp[j - 1];
}
/* L70: */
}
wrtmp[kmin - 1] = wrtmp[i__ - 1];
witmp[kmin - 1] = witmp[i__ - 1];
wrtmp[i__ - 1] = vrmin;
witmp[i__ - 1] = vimin;
vrmin = stmp[kmin - 1];
stmp[kmin - 1] = stmp[i__ - 1];
stmp[i__ - 1] = vrmin;
vrmin = septmp[kmin - 1];
septmp[kmin - 1] = septmp[i__ - 1];
septmp[i__ - 1] = vrmin;
/* L80: */
}
/* Compare condition numbers for eigenvalues */
/* taking their condition numbers into account */
/* Computing MAX */
r__1 = (real) n * 2.f * eps * tnrm;
v = dmax(r__1,smlnum);
if (tnrm == 0.f) {
v = 1.f;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (v > septmp[i__ - 1]) {
tol = 1.f;
} else {
tol = v / septmp[i__ - 1];
}
if (v > sepin[i__ - 1]) {
tolin = 1.f;
} else {
tolin = v / sepin[i__ - 1];
}
/* Computing MAX */
r__1 = tol, r__2 = smlnum / eps;
tol = dmax(r__1,r__2);
/* Computing MAX */
r__1 = tolin, r__2 = smlnum / eps;
tolin = dmax(r__1,r__2);
if (eps * (sin__[i__ - 1] - tolin) > stmp[i__ - 1] + tol) {
vmax = 1.f / eps;
} else if (sin__[i__ - 1] - tolin > stmp[i__ - 1] + tol) {
vmax = (sin__[i__ - 1] - tolin) / (stmp[i__ - 1] + tol);
} else if (sin__[i__ - 1] + tolin < eps * (stmp[i__ - 1] - tol)) {
vmax = 1.f / eps;
} else if (sin__[i__ - 1] + tolin < stmp[i__ - 1] - tol) {
vmax = (stmp[i__ - 1] - tol) / (sin__[i__ - 1] + tolin);
} else {
vmax = 1.f;
}
if (vmax > rmax[2]) {
rmax[2] = vmax;
if (ninfo[2] == 0) {
lmax[2] = *knt;
}
}
/* L90: */
}
/* Compare condition numbers for eigenvectors */
/* taking their condition numbers into account */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (v > septmp[i__ - 1] * stmp[i__ - 1]) {
tol = septmp[i__ - 1];
} else {
tol = v / stmp[i__ - 1];
}
if (v > sepin[i__ - 1] * sin__[i__ - 1]) {
tolin = sepin[i__ - 1];
} else {
tolin = v / sin__[i__ - 1];
}
/* Computing MAX */
r__1 = tol, r__2 = smlnum / eps;
tol = dmax(r__1,r__2);
/* Computing MAX */
r__1 = tolin, r__2 = smlnum / eps;
tolin = dmax(r__1,r__2);
if (eps * (sepin[i__ - 1] - tolin) > septmp[i__ - 1] + tol) {
vmax = 1.f / eps;
} else if (sepin[i__ - 1] - tolin > septmp[i__ - 1] + tol) {
vmax = (sepin[i__ - 1] - tolin) / (septmp[i__ - 1] + tol);
} else if (sepin[i__ - 1] + tolin < eps * (septmp[i__ - 1] - tol))
{
vmax = 1.f / eps;
} else if (sepin[i__ - 1] + tolin < septmp[i__ - 1] - tol) {
vmax = (septmp[i__ - 1] - tol) / (sepin[i__ - 1] + tolin);
} else {
vmax = 1.f;
}
if (vmax > rmax[2]) {
rmax[2] = vmax;
if (ninfo[2] == 0) {
lmax[2] = *knt;
}
}
/* L100: */
}
/* Compare condition numbers for eigenvalues */
/* without taking their condition numbers into account */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (sin__[i__ - 1] <= (real) (n << 1) * eps && stmp[i__ - 1] <= (
real) (n << 1) * eps) {
vmax = 1.f;
} else if (eps * sin__[i__ - 1] > stmp[i__ - 1]) {
vmax = 1.f / eps;
} else if (sin__[i__ - 1] > stmp[i__ - 1]) {
vmax = sin__[i__ - 1] / stmp[i__ - 1];
} else if (sin__[i__ - 1] < eps * stmp[i__ - 1]) {
vmax = 1.f / eps;
} else if (sin__[i__ - 1] < stmp[i__ - 1]) {
vmax = stmp[i__ - 1] / sin__[i__ - 1];
} else {
vmax = 1.f;
}
if (vmax > rmax[3]) {
rmax[3] = vmax;
if (ninfo[3] == 0) {
lmax[3] = *knt;
}
}
/* L110: */
}
/* Compare condition numbers for eigenvectors */
/* without taking their condition numbers into account */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (sepin[i__ - 1] <= v && septmp[i__ - 1] <= v) {
vmax = 1.f;
} else if (eps * sepin[i__ - 1] > septmp[i__ - 1]) {
vmax = 1.f / eps;
} else if (sepin[i__ - 1] > septmp[i__ - 1]) {
vmax = sepin[i__ - 1] / septmp[i__ - 1];
} else if (sepin[i__ - 1] < eps * septmp[i__ - 1]) {
vmax = 1.f / eps;
} else if (sepin[i__ - 1] < septmp[i__ - 1]) {
vmax = septmp[i__ - 1] / sepin[i__ - 1];
} else {
vmax = 1.f;
}
if (vmax > rmax[3]) {
rmax[3] = vmax;
if (ninfo[3] == 0) {
lmax[3] = *knt;
}
}
/* L120: */
}
/* Compute eigenvalue condition numbers only and compare */
vmax = 0.f;
dum[0] = -1.f;
scopy_(&n, dum, &c__0, stmp, &c__1);
scopy_(&n, dum, &c__0, septmp, &c__1);
strsna_("Eigcond", "All", select, &n, t, &c__20, le, &c__20, re, &
c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (stmp[i__ - 1] != s[i__ - 1]) {
vmax = 1.f / eps;
}
if (septmp[i__ - 1] != dum[0]) {
vmax = 1.f / eps;
}
/* L130: */
}
/* Compute eigenvector condition numbers only and compare */
scopy_(&n, dum, &c__0, stmp, &c__1);
scopy_(&n, dum, &c__0, septmp, &c__1);
strsna_("Veccond", "All", select, &n, t, &c__20, le, &c__20, re, &
c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (stmp[i__ - 1] != dum[0]) {
vmax = 1.f / eps;
}
if (septmp[i__ - 1] != sep[i__ - 1]) {
vmax = 1.f / eps;
}
/* L140: */
}
/* Compute all condition numbers using SELECT and compare */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
select[i__ - 1] = TRUE_;
/* L150: */
}
scopy_(&n, dum, &c__0, stmp, &c__1);
scopy_(&n, dum, &c__0, septmp, &c__1);
strsna_("Bothcond", "Some", select, &n, t, &c__20, le, &c__20, re, &
c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (septmp[i__ - 1] != sep[i__ - 1]) {
vmax = 1.f / eps;
}
if (stmp[i__ - 1] != s[i__ - 1]) {
vmax = 1.f / eps;
}
/* L160: */
}
/* Compute eigenvalue condition numbers using SELECT and compare */
scopy_(&n, dum, &c__0, stmp, &c__1);
scopy_(&n, dum, &c__0, septmp, &c__1);
strsna_("Eigcond", "Some", select, &n, t, &c__20, le, &c__20, re, &
c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (stmp[i__ - 1] != s[i__ - 1]) {
vmax = 1.f / eps;
}
if (septmp[i__ - 1] != dum[0]) {
vmax = 1.f / eps;
}
/* L170: */
}
/* Compute eigenvector condition numbers using SELECT and compare */
scopy_(&n, dum, &c__0, stmp, &c__1);
scopy_(&n, dum, &c__0, septmp, &c__1);
strsna_("Veccond", "Some", select, &n, t, &c__20, le, &c__20, re, &
c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (stmp[i__ - 1] != dum[0]) {
vmax = 1.f / eps;
}
if (septmp[i__ - 1] != sep[i__ - 1]) {
vmax = 1.f / eps;
}
/* L180: */
}
if (vmax > rmax[1]) {
rmax[1] = vmax;
if (ninfo[1] == 0) {
lmax[1] = *knt;
}
}
/* Select first real and first complex eigenvalue */
if (wi[0] == 0.f) {
lcmp[0] = 1;
ifnd = 0;
i__1 = n;
for (i__ = 2; i__ <= i__1; ++i__) {
if (ifnd == 1 || wi[i__ - 1] == 0.f) {
select[i__ - 1] = FALSE_;
} else {
ifnd = 1;
lcmp[1] = i__;
lcmp[2] = i__ + 1;
scopy_(&n, &re[i__ * 20 - 20], &c__1, &re[20], &c__1);
scopy_(&n, &re[(i__ + 1) * 20 - 20], &c__1, &re[40], &
c__1);
scopy_(&n, &le[i__ * 20 - 20], &c__1, &le[20], &c__1);
scopy_(&n, &le[(i__ + 1) * 20 - 20], &c__1, &le[40], &
c__1);
}
/* L190: */
}
if (ifnd == 0) {
icmp = 1;
} else {
icmp = 3;
}
} else {
lcmp[0] = 1;
lcmp[1] = 2;
ifnd = 0;
i__1 = n;
for (i__ = 3; i__ <= i__1; ++i__) {
if (ifnd == 1 || wi[i__ - 1] != 0.f) {
select[i__ - 1] = FALSE_;
} else {
lcmp[2] = i__;
ifnd = 1;
scopy_(&n, &re[i__ * 20 - 20], &c__1, &re[40], &c__1);
scopy_(&n, &le[i__ * 20 - 20], &c__1, &le[40], &c__1);
}
/* L200: */
}
if (ifnd == 0) {
icmp = 2;
} else {
icmp = 3;
}
}
/* Compute all selected condition numbers */
scopy_(&icmp, dum, &c__0, stmp, &c__1);
scopy_(&icmp, dum, &c__0, septmp, &c__1);
strsna_("Bothcond", "Some", select, &n, t, &c__20, le, &c__20, re, &
c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
i__1 = icmp;
for (i__ = 1; i__ <= i__1; ++i__) {
j = lcmp[i__ - 1];
if (septmp[i__ - 1] != sep[j - 1]) {
vmax = 1.f / eps;
}
if (stmp[i__ - 1] != s[j - 1]) {
vmax = 1.f / eps;
}
/* L210: */
}
/* Compute selected eigenvalue condition numbers */
scopy_(&icmp, dum, &c__0, stmp, &c__1);
scopy_(&icmp, dum, &c__0, septmp, &c__1);
strsna_("Eigcond", "Some", select, &n, t, &c__20, le, &c__20, re, &
c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
i__1 = icmp;
for (i__ = 1; i__ <= i__1; ++i__) {
j = lcmp[i__ - 1];
if (stmp[i__ - 1] != s[j - 1]) {
vmax = 1.f / eps;
}
if (septmp[i__ - 1] != dum[0]) {
vmax = 1.f / eps;
}
/* L220: */
}
/* Compute selected eigenvector condition numbers */
scopy_(&icmp, dum, &c__0, stmp, &c__1);
scopy_(&icmp, dum, &c__0, septmp, &c__1);
strsna_("Veccond", "Some", select, &n, t, &c__20, le, &c__20, re, &
c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
i__1 = icmp;
for (i__ = 1; i__ <= i__1; ++i__) {
j = lcmp[i__ - 1];
if (stmp[i__ - 1] != dum[0]) {
vmax = 1.f / eps;
}
if (septmp[i__ - 1] != sep[j - 1]) {
vmax = 1.f / eps;
}
/* L230: */
}
if (vmax > rmax[1]) {
rmax[1] = vmax;
if (ninfo[1] == 0) {
lmax[1] = *knt;
}
}
L240:
;
}
goto L10;
/* End of SGET37 */
} /* sget37_ */
/* Subroutine */ int sgeev_(char *jobvl, char *jobvr, integer *n, real *a,
integer *lda, real *wr, real *wi, real *vl, integer *ldvl, real *vr,
integer *ldvr, real *work, integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, k;
real r__, cs, sn;
integer ihi;
real scl;
integer ilo;
real dum[1], eps;
integer ibal;
char side[1];
real anrm;
integer ierr, itau, iwrk, nout;
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *);
extern doublereal snrm2_(integer *, real *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
extern doublereal slapy2_(real *, real *);
extern /* Subroutine */ int slabad_(real *, real *);
logical scalea;
real cscale;
extern /* Subroutine */ int sgebak_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, integer *, integer *), sgebal_(char *, integer *, real *, integer *,
integer *, integer *, real *, integer *);
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real
*, integer *, real *, real *, integer *, integer *), xerbla_(char
*, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
logical select[1];
real bignum;
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *);
extern integer isamax_(integer *, real *, integer *);
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), slartg_(real *, real *,
real *, real *, real *), sorghr_(integer *, integer *, integer *,
real *, integer *, real *, real *, integer *, integer *), shseqr_(
char *, char *, integer *, integer *, integer *, real *, integer *
, real *, real *, real *, integer *, real *, integer *, integer *), strevc_(char *, char *, logical *, integer *,
real *, integer *, real *, integer *, real *, integer *, integer *
, integer *, real *, integer *);
integer minwrk, maxwrk;
logical wantvl;
real smlnum;
integer hswork;
logical lquery, wantvr;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGEEV computes for an N-by-N real nonsymmetric matrix A, the */
/* eigenvalues and, optionally, the left and/or right eigenvectors. */
/* The right eigenvector v(j) of A satisfies */
/* A * v(j) = lambda(j) * v(j) */
/* where lambda(j) is its eigenvalue. */
/* The left eigenvector u(j) of A satisfies */
/* u(j)**H * A = lambda(j) * u(j)**H */
/* where u(j)**H denotes the conjugate transpose of u(j). */
/* The computed eigenvectors are normalized to have Euclidean norm */
/* equal to 1 and largest component real. */
/* Arguments */
/* ========= */
/* JOBVL (input) CHARACTER*1 */
/* = 'N': left eigenvectors of A are not computed; */
/* = 'V': left eigenvectors of A are computed. */
/* JOBVR (input) CHARACTER*1 */
/* = 'N': right eigenvectors of A are not computed; */
/* = 'V': right eigenvectors of A are computed. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the N-by-N matrix A. */
/* On exit, A has been overwritten. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* WR (output) REAL array, dimension (N) */
/* WI (output) REAL array, dimension (N) */
/* WR and WI contain the real and imaginary parts, */
/* respectively, of the computed eigenvalues. Complex */
/* conjugate pairs of eigenvalues appear consecutively */
/* with the eigenvalue having the positive imaginary part */
/* first. */
/* VL (output) REAL array, dimension (LDVL,N) */
/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */
/* after another in the columns of VL, in the same order */
/* as their eigenvalues. */
/* If JOBVL = 'N', VL is not referenced. */
/* If the j-th eigenvalue is real, then u(j) = VL(:,j), */
/* the j-th column of VL. */
/* If the j-th and (j+1)-st eigenvalues form a complex */
/* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and */
/* u(j+1) = VL(:,j) - i*VL(:,j+1). */
/* LDVL (input) INTEGER */
/* The leading dimension of the array VL. LDVL >= 1; if */
/* JOBVL = 'V', LDVL >= N. */
/* VR (output) REAL array, dimension (LDVR,N) */
/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */
/* after another in the columns of VR, in the same order */
/* as their eigenvalues. */
/* If JOBVR = 'N', VR is not referenced. */
/* If the j-th eigenvalue is real, then v(j) = VR(:,j), */
/* the j-th column of VR. */
/* If the j-th and (j+1)-st eigenvalues form a complex */
/* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and */
/* v(j+1) = VR(:,j) - i*VR(:,j+1). */
/* LDVR (input) INTEGER */
/* The leading dimension of the array VR. LDVR >= 1; if */
/* JOBVR = 'V', LDVR >= N. */
/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,3*N), and */
/* if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good */
/* performance, LWORK must generally be larger. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = i, the QR algorithm failed to compute all the */
/* eigenvalues, and no eigenvectors have been computed; */
/* elements i+1:N of WR and WI contain eigenvalues which */
/* have converged. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--wr;
--wi;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--work;
/* Function Body */
*info = 0;
lquery = *lwork == -1;
wantvl = lsame_(jobvl, "V");
wantvr = lsame_(jobvr, "V");
if (! wantvl && ! lsame_(jobvl, "N")) {
*info = -1;
} else if (! wantvr && ! lsame_(jobvr, "N")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldvl < 1 || wantvl && *ldvl < *n) {
*info = -9;
} else if (*ldvr < 1 || wantvr && *ldvr < *n) {
*info = -11;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "Workspace:" describe the */
/* minimal amount of workspace needed at that point in the code, */
/* as well as the preferred amount for good performance. */
/* NB refers to the optimal block size for the immediately */
/* following subroutine, as returned by ILAENV. */
/* HSWORK refers to the workspace preferred by SHSEQR, as */
/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
/* the worst case.) */
if (*info == 0) {
if (*n == 0) {
minwrk = 1;
maxwrk = 1;
} else {
maxwrk = (*n << 1) + *n * ilaenv_(&c__1, "SGEHRD", " ", n, &c__1,
n, &c__0);
if (wantvl) {
minwrk = *n << 2;
/* Computing MAX */
i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
"SORGHR", " ", n, &c__1, n, &c_n1);
maxwrk = max(i__1,i__2);
shseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
1], &vl[vl_offset], ldvl, &work[1], &c_n1, info);
hswork = work[1];
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + 1, i__1 = max(i__1,i__2), i__2 = *
n + hswork;
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n << 2;
maxwrk = max(i__1,i__2);
} else if (wantvr) {
minwrk = *n << 2;
/* Computing MAX */
i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
"SORGHR", " ", n, &c__1, n, &c_n1);
maxwrk = max(i__1,i__2);
shseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
1], &vr[vr_offset], ldvr, &work[1], &c_n1, info);
hswork = work[1];
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + 1, i__1 = max(i__1,i__2), i__2 = *
n + hswork;
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n << 2;
maxwrk = max(i__1,i__2);
} else {
minwrk = *n * 3;
shseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
1], &vr[vr_offset], ldvr, &work[1], &c_n1, info);
hswork = work[1];
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + 1, i__1 = max(i__1,i__2), i__2 = *
n + hswork;
maxwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,minwrk);
}
work[1] = (real) maxwrk;
if (*lwork < minwrk && ! lquery) {
*info = -13;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGEEV ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = slamch_("P");
smlnum = slamch_("S");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1.f / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = slange_("M", n, n, &a[a_offset], lda, dum);
scalea = FALSE_;
if (anrm > 0.f && anrm < smlnum) {
scalea = TRUE_;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = TRUE_;
cscale = bignum;
}
if (scalea) {
slascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
ierr);
}
/* Balance the matrix */
/* (Workspace: need N) */
ibal = 1;
sgebal_("B", n, &a[a_offset], lda, &ilo, &ihi, &work[ibal], &ierr);
/* Reduce to upper Hessenberg form */
/* (Workspace: need 3*N, prefer 2*N+N*NB) */
itau = ibal + *n;
iwrk = itau + *n;
i__1 = *lwork - iwrk + 1;
sgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1,
&ierr);
if (wantvl) {
/* Want left eigenvectors */
/* Copy Householder vectors to VL */
*(unsigned char *)side = 'L';
slacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl)
;
/* Generate orthogonal matrix in VL */
/* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
i__1 = *lwork - iwrk + 1;
sorghr_(n, &ilo, &ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk],
&i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VL */
/* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
shseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &
vl[vl_offset], ldvl, &work[iwrk], &i__1, info);
if (wantvr) {
/* Want left and right eigenvectors */
/* Copy Schur vectors to VR */
*(unsigned char *)side = 'B';
slacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr);
}
} else if (wantvr) {
/* Want right eigenvectors */
/* Copy Householder vectors to VR */
*(unsigned char *)side = 'R';
slacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr)
;
/* Generate orthogonal matrix in VR */
/* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
i__1 = *lwork - iwrk + 1;
sorghr_(n, &ilo, &ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk],
&i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VR */
/* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
shseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &
vr[vr_offset], ldvr, &work[iwrk], &i__1, info);
} else {
/* Compute eigenvalues only */
/* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
shseqr_("E", "N", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &
vr[vr_offset], ldvr, &work[iwrk], &i__1, info);
}
/* If INFO > 0 from SHSEQR, then quit */
if (*info > 0) {
goto L50;
}
if (wantvl || wantvr) {
/* Compute left and/or right eigenvectors */
/* (Workspace: need 4*N) */
strevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl,
&vr[vr_offset], ldvr, n, &nout, &work[iwrk], &ierr);
}
if (wantvl) {
/* Undo balancing of left eigenvectors */
/* (Workspace: need N) */
sgebak_("B", "L", n, &ilo, &ihi, &work[ibal], n, &vl[vl_offset], ldvl,
&ierr);
/* Normalize left eigenvectors and make largest component real */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (wi[i__] == 0.f) {
scl = 1.f / snrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
sscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
} else if (wi[i__] > 0.f) {
r__1 = snrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
r__2 = snrm2_(n, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
scl = 1.f / slapy2_(&r__1, &r__2);
sscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
sscal_(n, &scl, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
/* Computing 2nd power */
r__1 = vl[k + i__ * vl_dim1];
/* Computing 2nd power */
r__2 = vl[k + (i__ + 1) * vl_dim1];
work[iwrk + k - 1] = r__1 * r__1 + r__2 * r__2;
/* L10: */
}
k = isamax_(n, &work[iwrk], &c__1);
slartg_(&vl[k + i__ * vl_dim1], &vl[k + (i__ + 1) * vl_dim1],
&cs, &sn, &r__);
srot_(n, &vl[i__ * vl_dim1 + 1], &c__1, &vl[(i__ + 1) *
vl_dim1 + 1], &c__1, &cs, &sn);
vl[k + (i__ + 1) * vl_dim1] = 0.f;
}
/* L20: */
}
}
if (wantvr) {
/* Undo balancing of right eigenvectors */
/* (Workspace: need N) */
sgebak_("B", "R", n, &ilo, &ihi, &work[ibal], n, &vr[vr_offset], ldvr,
&ierr);
/* Normalize right eigenvectors and make largest component real */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (wi[i__] == 0.f) {
scl = 1.f / snrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
sscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
} else if (wi[i__] > 0.f) {
r__1 = snrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
r__2 = snrm2_(n, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
scl = 1.f / slapy2_(&r__1, &r__2);
sscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
sscal_(n, &scl, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
/* Computing 2nd power */
r__1 = vr[k + i__ * vr_dim1];
/* Computing 2nd power */
r__2 = vr[k + (i__ + 1) * vr_dim1];
work[iwrk + k - 1] = r__1 * r__1 + r__2 * r__2;
/* L30: */
}
k = isamax_(n, &work[iwrk], &c__1);
slartg_(&vr[k + i__ * vr_dim1], &vr[k + (i__ + 1) * vr_dim1],
&cs, &sn, &r__);
srot_(n, &vr[i__ * vr_dim1 + 1], &c__1, &vr[(i__ + 1) *
vr_dim1 + 1], &c__1, &cs, &sn);
vr[k + (i__ + 1) * vr_dim1] = 0.f;
}
/* L40: */
}
}
/* Undo scaling if necessary */
L50:
if (scalea) {
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = max(i__3,1);
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[*info +
1], &i__2, &ierr);
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = max(i__3,1);
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[*info +
1], &i__2, &ierr);
if (*info > 0) {
i__1 = ilo - 1;
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[1],
n, &ierr);
i__1 = ilo - 1;
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[1],
n, &ierr);
}
}
work[1] = (real) maxwrk;
return 0;
/* End of SGEEV */
} /* sgeev_ */
/* Subroutine */ int serrhs_(char *path, integer *nunit)
{
/* Format strings */
static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
"rror exits\002,\002 (\002,i3,\002 tests done)\002)";
static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
"ts of the error \002,\002exits ***\002)";
/* Local variables */
real a[9] /* was [3][3] */, c__[9] /* was [3][3] */;
integer i__, j, m;
real s[3], w[28];
char c2[2];
real wi[3];
integer nt;
real vl[9] /* was [3][3] */, vr[9] /* was [3][3] */, wr[3];
integer ihi, ilo;
logical sel[3];
real tau[3];
integer info;
extern /* Subroutine */ int sgebak_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, integer *, integer *), sgebal_(char *, integer *, real *, integer *,
integer *, integer *, real *, integer *);
integer ifaill[3], ifailr[3];
extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real
*, integer *, real *, real *, integer *, integer *);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
*, logical *), shsein_(char *, char *, char *, logical *,
integer *, real *, integer *, real *, real *, real *, integer *,
real *, integer *, integer *, integer *, real *, integer *,
integer *, integer *), sorghr_(integer *,
integer *, integer *, real *, integer *, real *, real *, integer *
, integer *), shseqr_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, real *, real *, integer *,
real *, integer *, integer *), strevc_(char *,
char *, logical *, integer *, real *, integer *, real *, integer *
, real *, integer *, integer *, integer *, real *, integer *), sormhr_(char *, char *, integer *, integer *,
integer *, integer *, real *, integer *, real *, real *, integer *
, real *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___23 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SERRHS tests the error exits for SGEBAK, SGEBAL, SGEHRD, SORGHR, */
/* SORMHR, SHSEQR, SHSEIN, and STREVC. */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The LAPACK path name for the routines to be tested. */
/* NUNIT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
/* Set the variables to innocuous values. */
for (j = 1; j <= 3; ++j) {
for (i__ = 1; i__ <= 3; ++i__) {
a[i__ + j * 3 - 4] = 1.f / (real) (i__ + j);
/* L10: */
}
wi[j - 1] = (real) j;
sel[j - 1] = TRUE_;
/* L20: */
}
infoc_1.ok = TRUE_;
nt = 0;
/* Test error exits of the nonsymmetric eigenvalue routines. */
if (lsamen_(&c__2, c2, "HS")) {
/* SGEBAL */
s_copy(srnamc_1.srnamt, "SGEBAL", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sgebal_("/", &c__0, a, &c__1, &ilo, &ihi, s, &info);
chkxer_("SGEBAL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgebal_("N", &c_n1, a, &c__1, &ilo, &ihi, s, &info);
chkxer_("SGEBAL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
sgebal_("N", &c__2, a, &c__1, &ilo, &ihi, s, &info);
chkxer_("SGEBAL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 3;
/* SGEBAK */
s_copy(srnamc_1.srnamt, "SGEBAK", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sgebak_("/", "R", &c__0, &c__1, &c__0, s, &c__0, a, &c__1, &info);
chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgebak_("N", "/", &c__0, &c__1, &c__0, s, &c__0, a, &c__1, &info);
chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sgebak_("N", "R", &c_n1, &c__1, &c__0, s, &c__0, a, &c__1, &info);
chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
sgebak_("N", "R", &c__0, &c__0, &c__0, s, &c__0, a, &c__1, &info);
chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
sgebak_("N", "R", &c__0, &c__2, &c__0, s, &c__0, a, &c__1, &info);
chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sgebak_("N", "R", &c__2, &c__2, &c__1, s, &c__0, a, &c__2, &info);
chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sgebak_("N", "R", &c__0, &c__1, &c__1, s, &c__0, a, &c__1, &info);
chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
sgebak_("N", "R", &c__0, &c__1, &c__0, s, &c_n1, a, &c__1, &info);
chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
sgebak_("N", "R", &c__2, &c__1, &c__2, s, &c__0, a, &c__1, &info);
chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 9;
/* SGEHRD */
s_copy(srnamc_1.srnamt, "SGEHRD", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sgehrd_(&c_n1, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
chkxer_("SGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgehrd_(&c__0, &c__0, &c__0, a, &c__1, tau, w, &c__1, &info);
chkxer_("SGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgehrd_(&c__0, &c__2, &c__0, a, &c__1, tau, w, &c__1, &info);
chkxer_("SGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sgehrd_(&c__1, &c__1, &c__0, a, &c__1, tau, w, &c__1, &info);
chkxer_("SGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sgehrd_(&c__0, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
chkxer_("SGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sgehrd_(&c__2, &c__1, &c__1, a, &c__1, tau, w, &c__2, &info);
chkxer_("SGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
sgehrd_(&c__2, &c__1, &c__2, a, &c__2, tau, w, &c__1, &info);
chkxer_("SGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 7;
/* SORGHR */
s_copy(srnamc_1.srnamt, "SORGHR", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sorghr_(&c_n1, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
chkxer_("SORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sorghr_(&c__0, &c__0, &c__0, a, &c__1, tau, w, &c__1, &info);
chkxer_("SORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sorghr_(&c__0, &c__2, &c__0, a, &c__1, tau, w, &c__1, &info);
chkxer_("SORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sorghr_(&c__1, &c__1, &c__0, a, &c__1, tau, w, &c__1, &info);
chkxer_("SORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sorghr_(&c__0, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
chkxer_("SORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sorghr_(&c__2, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
chkxer_("SORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
sorghr_(&c__3, &c__1, &c__3, a, &c__3, tau, w, &c__1, &info);
chkxer_("SORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 7;
/* SORMHR */
s_copy(srnamc_1.srnamt, "SORMHR", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sormhr_("/", "N", &c__0, &c__0, &c__1, &c__0, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sormhr_("L", "/", &c__0, &c__0, &c__1, &c__0, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sormhr_("L", "N", &c_n1, &c__0, &c__1, &c__0, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
sormhr_("L", "N", &c__0, &c_n1, &c__1, &c__0, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sormhr_("L", "N", &c__0, &c__0, &c__0, &c__0, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sormhr_("L", "N", &c__0, &c__0, &c__2, &c__0, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sormhr_("L", "N", &c__1, &c__2, &c__2, &c__1, a, &c__1, tau, c__, &
c__1, w, &c__2, &info);
chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sormhr_("R", "N", &c__2, &c__1, &c__2, &c__1, a, &c__1, tau, c__, &
c__2, w, &c__2, &info);
chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
sormhr_("L", "N", &c__1, &c__1, &c__1, &c__0, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
sormhr_("L", "N", &c__0, &c__1, &c__1, &c__1, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
sormhr_("R", "N", &c__1, &c__0, &c__1, &c__1, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
sormhr_("L", "N", &c__2, &c__1, &c__1, &c__1, a, &c__1, tau, c__, &
c__2, w, &c__1, &info);
chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
sormhr_("R", "N", &c__1, &c__2, &c__1, &c__1, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
sormhr_("L", "N", &c__2, &c__1, &c__1, &c__1, a, &c__2, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
sormhr_("L", "N", &c__1, &c__2, &c__1, &c__1, a, &c__1, tau, c__, &
c__1, w, &c__1, &info);
chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
sormhr_("R", "N", &c__2, &c__1, &c__1, &c__1, a, &c__1, tau, c__, &
c__2, w, &c__1, &info);
chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 16;
/* SHSEQR */
s_copy(srnamc_1.srnamt, "SHSEQR", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
shseqr_("/", "N", &c__0, &c__1, &c__0, a, &c__1, wr, wi, c__, &c__1,
w, &c__1, &info);
chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
shseqr_("E", "/", &c__0, &c__1, &c__0, a, &c__1, wr, wi, c__, &c__1,
w, &c__1, &info);
chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
shseqr_("E", "N", &c_n1, &c__1, &c__0, a, &c__1, wr, wi, c__, &c__1,
w, &c__1, &info);
chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
shseqr_("E", "N", &c__0, &c__0, &c__0, a, &c__1, wr, wi, c__, &c__1,
w, &c__1, &info);
chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
shseqr_("E", "N", &c__0, &c__2, &c__0, a, &c__1, wr, wi, c__, &c__1,
w, &c__1, &info);
chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
shseqr_("E", "N", &c__1, &c__1, &c__0, a, &c__1, wr, wi, c__, &c__1,
w, &c__1, &info);
chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
shseqr_("E", "N", &c__1, &c__1, &c__2, a, &c__1, wr, wi, c__, &c__1,
w, &c__1, &info);
chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
shseqr_("E", "N", &c__2, &c__1, &c__2, a, &c__1, wr, wi, c__, &c__2,
w, &c__1, &info);
chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
shseqr_("E", "V", &c__2, &c__1, &c__2, a, &c__2, wr, wi, c__, &c__1,
w, &c__1, &info);
chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 9;
/* SHSEIN */
s_copy(srnamc_1.srnamt, "SHSEIN", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
shsein_("/", "N", "N", sel, &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &c__0, &m, w, ifaill, ifailr, &info);
chkxer_("SHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
shsein_("R", "/", "N", sel, &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &c__0, &m, w, ifaill, ifailr, &info);
chkxer_("SHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
shsein_("R", "N", "/", sel, &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &c__0, &m, w, ifaill, ifailr, &info);
chkxer_("SHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
shsein_("R", "N", "N", sel, &c_n1, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &c__0, &m, w, ifaill, ifailr, &info);
chkxer_("SHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
shsein_("R", "N", "N", sel, &c__2, a, &c__1, wr, wi, vl, &c__1, vr, &
c__2, &c__4, &m, w, ifaill, ifailr, &info);
chkxer_("SHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
shsein_("L", "N", "N", sel, &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &
c__1, &c__4, &m, w, ifaill, ifailr, &info);
chkxer_("SHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
shsein_("R", "N", "N", sel, &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &
c__1, &c__4, &m, w, ifaill, ifailr, &info);
chkxer_("SHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 14;
shsein_("R", "N", "N", sel, &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &
c__2, &c__1, &m, w, ifaill, ifailr, &info);
chkxer_("SHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 8;
/* STREVC */
s_copy(srnamc_1.srnamt, "STREVC", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
strevc_("/", "A", sel, &c__0, a, &c__1, vl, &c__1, vr, &c__1, &c__0, &
m, w, &info);
chkxer_("STREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
strevc_("L", "/", sel, &c__0, a, &c__1, vl, &c__1, vr, &c__1, &c__0, &
m, w, &info);
chkxer_("STREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
strevc_("L", "A", sel, &c_n1, a, &c__1, vl, &c__1, vr, &c__1, &c__0, &
m, w, &info);
chkxer_("STREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
strevc_("L", "A", sel, &c__2, a, &c__1, vl, &c__2, vr, &c__1, &c__4, &
m, w, &info);
chkxer_("STREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
strevc_("L", "A", sel, &c__2, a, &c__2, vl, &c__1, vr, &c__1, &c__4, &
m, w, &info);
chkxer_("STREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
strevc_("R", "A", sel, &c__2, a, &c__2, vl, &c__1, vr, &c__1, &c__4, &
m, w, &info);
chkxer_("STREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
strevc_("L", "A", sel, &c__2, a, &c__2, vl, &c__2, vr, &c__1, &c__1, &
m, w, &info);
chkxer_("STREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 7;
}
/* Print a summary line. */
if (infoc_1.ok) {
io___22.ciunit = infoc_1.nout;
s_wsfe(&io___22);
do_fio(&c__1, path, (ftnlen)3);
do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___23.ciunit = infoc_1.nout;
s_wsfe(&io___23);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
return 0;
/* End of SERRHS */
} /* serrhs_ */
int sgeesx_(char *jobvs, char *sort, L_fp select, char *
sense, int *n, float *a, int *lda, int *sdim, float *wr,
float *wi, float *vs, int *ldvs, float *rconde, float *rcondv, float *
work, int *lwork, int *iwork, int *liwork, int *bwork,
int *info)
{
/* System generated locals */
int a_dim1, a_offset, vs_dim1, vs_offset, i__1, i__2, i__3;
/* Builtin functions */
double sqrt(double);
/* Local variables */
int i__, i1, i2, ip, ihi, ilo;
float dum[1], eps;
int ibal;
float anrm;
int ierr, itau, iwrk, lwrk, inxt, icond, ieval;
extern int lsame_(char *, char *);
int cursl;
int liwrk;
extern int scopy_(int *, float *, int *, float *,
int *), sswap_(int *, float *, int *, float *, int *
);
int lst2sl;
extern int slabad_(float *, float *);
int scalea;
float cscale;
extern int sgebak_(char *, char *, int *, int *,
int *, float *, int *, float *, int *, int *), sgebal_(char *, int *, float *, int *,
int *, int *, float *, int *);
extern double slamch_(char *), slange_(char *, int *,
int *, float *, int *, float *);
extern int sgehrd_(int *, int *, int *, float
*, int *, float *, float *, int *, int *), xerbla_(char
*, int *);
extern int ilaenv_(int *, char *, char *, int *, int *,
int *, int *);
float bignum;
extern int slascl_(char *, int *, int *, float *,
float *, int *, int *, float *, int *, int *), slacpy_(char *, int *, int *, float *, int *,
float *, int *);
int wantsb, wantse, lastsl;
extern int sorghr_(int *, int *, int *, float
*, int *, float *, float *, int *, int *), shseqr_(char
*, char *, int *, int *, int *, float *, int *,
float *, float *, float *, int *, float *, int *, int *);
int minwrk, maxwrk;
int wantsn;
float smlnum;
int hswork;
extern int strsen_(char *, char *, int *, int *,
float *, int *, float *, int *, float *, float *, int *,
float *, float *, float *, int *, int *, int *, int *
);
int wantst, lquery, wantsv, wantvs;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* .. Function Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGEESX computes for an N-by-N float nonsymmetric matrix A, the */
/* eigenvalues, the float Schur form T, and, optionally, the matrix of */
/* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T). */
/* Optionally, it also orders the eigenvalues on the diagonal of the */
/* float Schur form so that selected eigenvalues are at the top left; */
/* computes a reciprocal condition number for the average of the */
/* selected eigenvalues (RCONDE); and computes a reciprocal condition */
/* number for the right invariant subspace corresponding to the */
/* selected eigenvalues (RCONDV). The leading columns of Z form an */
/* orthonormal basis for this invariant subspace. */
/* For further explanation of the reciprocal condition numbers RCONDE */
/* and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where */
/* these quantities are called s and sep respectively). */
/* A float matrix is in float Schur form if it is upper quasi-triangular */
/* with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in */
/* the form */
/* [ a b ] */
/* [ c a ] */
/* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc). */
/* Arguments */
/* ========= */
/* JOBVS (input) CHARACTER*1 */
/* = 'N': Schur vectors are not computed; */
/* = 'V': Schur vectors are computed. */
/* SORT (input) CHARACTER*1 */
/* Specifies whether or not to order the eigenvalues on the */
/* diagonal of the Schur form. */
/* = 'N': Eigenvalues are not ordered; */
/* = 'S': Eigenvalues are ordered (see SELECT). */
/* SELECT (external procedure) LOGICAL FUNCTION of two REAL arguments */
/* SELECT must be declared EXTERNAL in the calling subroutine. */
/* If SORT = 'S', SELECT is used to select eigenvalues to sort */
/* to the top left of the Schur form. */
/* If SORT = 'N', SELECT is not referenced. */
/* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if */
/* SELECT(WR(j),WI(j)) is true; i.e., if either one of a */
/* complex conjugate pair of eigenvalues is selected, then both */
/* are. Note that a selected complex eigenvalue may no longer */
/* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since */
/* ordering may change the value of complex eigenvalues */
/* (especially if the eigenvalue is ill-conditioned); in this */
/* case INFO may be set to N+3 (see INFO below). */
/* SENSE (input) CHARACTER*1 */
/* Determines which reciprocal condition numbers are computed. */
/* = 'N': None are computed; */
/* = 'E': Computed for average of selected eigenvalues only; */
/* = 'V': Computed for selected right invariant subspace only; */
/* = 'B': Computed for both. */
/* If SENSE = 'E', 'V' or 'B', SORT must equal 'S'. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) REAL array, dimension (LDA, N) */
/* On entry, the N-by-N matrix A. */
/* On exit, A is overwritten by its float Schur form T. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,N). */
/* SDIM (output) INTEGER */
/* If SORT = 'N', SDIM = 0. */
/* If SORT = 'S', SDIM = number of eigenvalues (after sorting) */
/* for which SELECT is true. (Complex conjugate */
/* pairs for which SELECT is true for either */
/* eigenvalue count as 2.) */
/* WR (output) REAL array, dimension (N) */
/* WI (output) REAL array, dimension (N) */
/* WR and WI contain the float and imaginary parts, respectively, */
/* of the computed eigenvalues, in the same order that they */
/* appear on the diagonal of the output Schur form T. Complex */
/* conjugate pairs of eigenvalues appear consecutively with the */
/* eigenvalue having the positive imaginary part first. */
/* VS (output) REAL array, dimension (LDVS,N) */
/* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur */
/* vectors. */
/* If JOBVS = 'N', VS is not referenced. */
/* LDVS (input) INTEGER */
/* The leading dimension of the array VS. LDVS >= 1, and if */
/* JOBVS = 'V', LDVS >= N. */
/* RCONDE (output) REAL */
/* If SENSE = 'E' or 'B', RCONDE contains the reciprocal */
/* condition number for the average of the selected eigenvalues. */
/* Not referenced if SENSE = 'N' or 'V'. */
/* RCONDV (output) REAL */
/* If SENSE = 'V' or 'B', RCONDV contains the reciprocal */
/* condition number for the selected right invariant subspace. */
/* Not referenced if SENSE = 'N' or 'E'. */
/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= MAX(1,3*N). */
/* Also, if SENSE = 'E' or 'V' or 'B', */
/* LWORK >= N+2*SDIM*(N-SDIM), where SDIM is the number of */
/* selected eigenvalues computed by this routine. Note that */
/* N+2*SDIM*(N-SDIM) <= N+N*N/2. Note also that an error is only */
/* returned if LWORK < MAX(1,3*N), but if SENSE = 'E' or 'V' or */
/* 'B' this may not be large enough. */
/* For good performance, LWORK must generally be larger. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates upper bounds on the optimal sizes of the */
/* arrays WORK and IWORK, returns these values as the first */
/* entries of the WORK and IWORK arrays, and no error messages */
/* related to LWORK or LIWORK are issued by XERBLA. */
/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
/* LIWORK (input) INTEGER */
/* The dimension of the array IWORK. */
/* LIWORK >= 1; if SENSE = 'V' or 'B', LIWORK >= SDIM*(N-SDIM). */
/* Note that SDIM*(N-SDIM) <= N*N/4. Note also that an error is */
/* only returned if LIWORK < 1, but if SENSE = 'V' or 'B' this */
/* may not be large enough. */
/* If LIWORK = -1, then a workspace query is assumed; the */
/* routine only calculates upper bounds on the optimal sizes of */
/* the arrays WORK and IWORK, returns these values as the first */
/* entries of the WORK and IWORK arrays, and no error messages */
/* related to LWORK or LIWORK are issued by XERBLA. */
/* BWORK (workspace) LOGICAL array, dimension (N) */
/* Not referenced if SORT = 'N'. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = i, and i is */
/* <= N: the QR algorithm failed to compute all the */
/* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI */
/* contain those eigenvalues which have converged; if */
/* JOBVS = 'V', VS contains the transformation which */
/* reduces A to its partially converged Schur form. */
/* = N+1: the eigenvalues could not be reordered because some */
/* eigenvalues were too close to separate (the problem */
/* is very ill-conditioned); */
/* = N+2: after reordering, roundoff changed values of some */
/* complex eigenvalues so that leading eigenvalues in */
/* the Schur form no longer satisfy SELECT=.TRUE. This */
/* could also be caused by underflow due to scaling. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--wr;
--wi;
vs_dim1 = *ldvs;
vs_offset = 1 + vs_dim1;
vs -= vs_offset;
--work;
--iwork;
--bwork;
/* Function Body */
*info = 0;
wantvs = lsame_(jobvs, "V");
wantst = lsame_(sort, "S");
wantsn = lsame_(sense, "N");
wantse = lsame_(sense, "E");
wantsv = lsame_(sense, "V");
wantsb = lsame_(sense, "B");
lquery = *lwork == -1 || *liwork == -1;
if (! wantvs && ! lsame_(jobvs, "N")) {
*info = -1;
} else if (! wantst && ! lsame_(sort, "N")) {
*info = -2;
} else if (! (wantsn || wantse || wantsv || wantsb) || ! wantst && !
wantsn) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < MAX(1,*n)) {
*info = -7;
} else if (*ldvs < 1 || wantvs && *ldvs < *n) {
*info = -12;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "RWorkspace:" describe the */
/* minimal amount of float workspace needed at that point in the */
/* code, as well as the preferred amount for good performance. */
/* IWorkspace refers to int workspace. */
/* NB refers to the optimal block size for the immediately */
/* following subroutine, as returned by ILAENV. */
/* HSWORK refers to the workspace preferred by SHSEQR, as */
/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
/* the worst case. */
/* If SENSE = 'E', 'V' or 'B', then the amount of workspace needed */
/* depends on SDIM, which is computed by the routine STRSEN later */
/* in the code.) */
if (*info == 0) {
liwrk = 1;
if (*n == 0) {
minwrk = 1;
lwrk = 1;
} else {
maxwrk = (*n << 1) + *n * ilaenv_(&c__1, "SGEHRD", " ", n, &c__1,
n, &c__0);
minwrk = *n * 3;
shseqr_("S", jobvs, n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[1]
, &vs[vs_offset], ldvs, &work[1], &c_n1, &ieval);
hswork = work[1];
if (! wantvs) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + hswork;
maxwrk = MAX(i__1,i__2);
} else {
/* Computing MAX */
i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
"SORGHR", " ", n, &c__1, n, &c_n1);
maxwrk = MAX(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + hswork;
maxwrk = MAX(i__1,i__2);
}
lwrk = maxwrk;
if (! wantsn) {
/* Computing MAX */
i__1 = lwrk, i__2 = *n + *n * *n / 2;
lwrk = MAX(i__1,i__2);
}
if (wantsv || wantsb) {
liwrk = *n * *n / 4;
}
}
iwork[1] = liwrk;
work[1] = (float) lwrk;
if (*lwork < minwrk && ! lquery) {
*info = -16;
} else if (*liwork < 1 && ! lquery) {
*info = -18;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGEESX", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*sdim = 0;
return 0;
}
/* Get machine constants */
eps = slamch_("P");
smlnum = slamch_("S");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1.f / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = slange_("M", n, n, &a[a_offset], lda, dum);
scalea = FALSE;
if (anrm > 0.f && anrm < smlnum) {
scalea = TRUE;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = TRUE;
cscale = bignum;
}
if (scalea) {
slascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
ierr);
}
/* Permute the matrix to make it more nearly triangular */
/* (RWorkspace: need N) */
ibal = 1;
sgebal_("P", n, &a[a_offset], lda, &ilo, &ihi, &work[ibal], &ierr);
/* Reduce to upper Hessenberg form */
/* (RWorkspace: need 3*N, prefer 2*N+N*NB) */
itau = *n + ibal;
iwrk = *n + itau;
i__1 = *lwork - iwrk + 1;
sgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1,
&ierr);
if (wantvs) {
/* Copy Householder vectors to VS */
slacpy_("L", n, n, &a[a_offset], lda, &vs[vs_offset], ldvs)
;
/* Generate orthogonal matrix in VS */
/* (RWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
i__1 = *lwork - iwrk + 1;
sorghr_(n, &ilo, &ihi, &vs[vs_offset], ldvs, &work[itau], &work[iwrk],
&i__1, &ierr);
}
*sdim = 0;
/* Perform QR iteration, accumulating Schur vectors in VS if desired */
/* (RWorkspace: need N+1, prefer N+HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
shseqr_("S", jobvs, n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &vs[
vs_offset], ldvs, &work[iwrk], &i__1, &ieval);
if (ieval > 0) {
*info = ieval;
}
/* Sort eigenvalues if desired */
if (wantst && *info == 0) {
if (scalea) {
slascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &wr[1], n, &
ierr);
slascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &wi[1], n, &
ierr);
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
bwork[i__] = (*select)(&wr[i__], &wi[i__]);
/* L10: */
}
/* Reorder eigenvalues, transform Schur vectors, and compute */
/* reciprocal condition numbers */
/* (RWorkspace: if SENSE is not 'N', need N+2*SDIM*(N-SDIM) */
/* otherwise, need N ) */
/* (IWorkspace: if SENSE is 'V' or 'B', need SDIM*(N-SDIM) */
/* otherwise, need 0 ) */
i__1 = *lwork - iwrk + 1;
strsen_(sense, jobvs, &bwork[1], n, &a[a_offset], lda, &vs[vs_offset],
ldvs, &wr[1], &wi[1], sdim, rconde, rcondv, &work[iwrk], &
i__1, &iwork[1], liwork, &icond);
if (! wantsn) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + (*sdim << 1) * (*n - *sdim);
maxwrk = MAX(i__1,i__2);
}
if (icond == -15) {
/* Not enough float workspace */
*info = -16;
} else if (icond == -17) {
/* Not enough int workspace */
*info = -18;
} else if (icond > 0) {
/* STRSEN failed to reorder or to restore standard Schur form */
*info = icond + *n;
}
}
if (wantvs) {
/* Undo balancing */
/* (RWorkspace: need N) */
sgebak_("P", "R", n, &ilo, &ihi, &work[ibal], n, &vs[vs_offset], ldvs,
&ierr);
}
if (scalea) {
/* Undo scaling for the Schur form of A */
slascl_("H", &c__0, &c__0, &cscale, &anrm, n, n, &a[a_offset], lda, &
ierr);
i__1 = *lda + 1;
scopy_(n, &a[a_offset], &i__1, &wr[1], &c__1);
if ((wantsv || wantsb) && *info == 0) {
dum[0] = *rcondv;
slascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &
c__1, &ierr);
*rcondv = dum[0];
}
if (cscale == smlnum) {
/* If scaling back towards underflow, adjust WI if an */
/* offdiagonal element of a 2-by-2 block in the Schur form */
/* underflows. */
if (ieval > 0) {
i1 = ieval + 1;
i2 = ihi - 1;
i__1 = ilo - 1;
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[
1], n, &ierr);
} else if (wantst) {
i1 = 1;
i2 = *n - 1;
} else {
i1 = ilo;
i2 = ihi - 1;
}
inxt = i1 - 1;
i__1 = i2;
for (i__ = i1; i__ <= i__1; ++i__) {
if (i__ < inxt) {
goto L20;
}
if (wi[i__] == 0.f) {
inxt = i__ + 1;
} else {
if (a[i__ + 1 + i__ * a_dim1] == 0.f) {
wi[i__] = 0.f;
wi[i__ + 1] = 0.f;
} else if (a[i__ + 1 + i__ * a_dim1] != 0.f && a[i__ + (
i__ + 1) * a_dim1] == 0.f) {
wi[i__] = 0.f;
wi[i__ + 1] = 0.f;
if (i__ > 1) {
i__2 = i__ - 1;
sswap_(&i__2, &a[i__ * a_dim1 + 1], &c__1, &a[(
i__ + 1) * a_dim1 + 1], &c__1);
}
if (*n > i__ + 1) {
i__2 = *n - i__ - 1;
sswap_(&i__2, &a[i__ + (i__ + 2) * a_dim1], lda, &
a[i__ + 1 + (i__ + 2) * a_dim1], lda);
}
sswap_(n, &vs[i__ * vs_dim1 + 1], &c__1, &vs[(i__ + 1)
* vs_dim1 + 1], &c__1);
a[i__ + (i__ + 1) * a_dim1] = a[i__ + 1 + i__ *
a_dim1];
a[i__ + 1 + i__ * a_dim1] = 0.f;
}
inxt = i__ + 2;
}
L20:
;
}
}
i__1 = *n - ieval;
/* Computing MAX */
i__3 = *n - ieval;
i__2 = MAX(i__3,1);
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[ieval +
1], &i__2, &ierr);
}
if (wantst && *info == 0) {
/* Check if reordering successful */
lastsl = TRUE;
lst2sl = TRUE;
*sdim = 0;
ip = 0;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
cursl = (*select)(&wr[i__], &wi[i__]);
if (wi[i__] == 0.f) {
if (cursl) {
++(*sdim);
}
ip = 0;
if (cursl && ! lastsl) {
*info = *n + 2;
}
} else {
if (ip == 1) {
/* Last eigenvalue of conjugate pair */
cursl = cursl || lastsl;
lastsl = cursl;
if (cursl) {
*sdim += 2;
}
ip = -1;
if (cursl && ! lst2sl) {
*info = *n + 2;
}
} else {
/* First eigenvalue of conjugate pair */
ip = 1;
}
}
lst2sl = lastsl;
lastsl = cursl;
/* L30: */
}
}
work[1] = (float) maxwrk;
if (wantsv || wantsb) {
iwork[1] = *sdim * (*n - *sdim);
} else {
iwork[1] = 1;
}
return 0;
/* End of SGEESX */
} /* sgeesx_ */
