/* 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 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_ */
