/* Subroutine */ int sgtt01_(integer *n, real *dl, real *d__, real *du, real *
dlf, real *df, real *duf, real *du2, integer *ipiv, real *work,
integer *ldwork, real *rwork, real *resid)
{
/* System generated locals */
integer work_dim1, work_offset, i__1, i__2;
/* Local variables */
integer i__, j;
real li;
integer ip;
real eps, anorm;
integer lastj;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGTT01 reconstructs a tridiagonal matrix A from its LU factorization */
/* and computes the residual */
/* norm(L*U - A) / ( norm(A) * EPS ), */
/* where EPS is the machine epsilon. */
/* Arguments */
/* ========= */
/* N (input) INTEGTER */
/* The order of the matrix A. N >= 0. */
/* DL (input) REAL array, dimension (N-1) */
/* The (n-1) sub-diagonal elements of A. */
/* D (input) REAL array, dimension (N) */
/* The diagonal elements of A. */
/* DU (input) REAL array, dimension (N-1) */
/* The (n-1) super-diagonal elements of A. */
/* DLF (input) REAL array, dimension (N-1) */
/* The (n-1) multipliers that define the matrix L from the */
/* LU factorization of A. */
/* DF (input) REAL array, dimension (N) */
/* The n diagonal elements of the upper triangular matrix U from */
/* the LU factorization of A. */
/* DUF (input) REAL array, dimension (N-1) */
/* The (n-1) elements of the first super-diagonal of U. */
/* DU2F (input) REAL array, dimension (N-2) */
/* The (n-2) elements of the second super-diagonal of U. */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices; for 1 <= i <= n, row i of the matrix was */
/* interchanged with row IPIV(i). IPIV(i) will always be either */
/* i or i+1; IPIV(i) = i indicates a row interchange was not */
/* required. */
/* WORK (workspace) REAL array, dimension (LDWORK,N) */
/* LDWORK (input) INTEGER */
/* The leading dimension of the array WORK. LDWORK >= max(1,N). */
/* RWORK (workspace) REAL array, dimension (N) */
/* RESID (output) REAL */
/* The scaled residual: norm(L*U - A) / (norm(A) * EPS) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
--dl;
--d__;
--du;
--dlf;
--df;
--duf;
--du2;
--ipiv;
work_dim1 = *ldwork;
work_offset = 1 + work_dim1;
work -= work_offset;
--rwork;
/* Function Body */
if (*n <= 0) {
*resid = 0.f;
return 0;
}
eps = slamch_("Epsilon");
/* Copy the matrix U to WORK. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__ + j * work_dim1] = 0.f;
/* L10: */
}
/* L20: */
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ == 1) {
work[i__ + i__ * work_dim1] = df[i__];
if (*n >= 2) {
work[i__ + (i__ + 1) * work_dim1] = duf[i__];
}
if (*n >= 3) {
work[i__ + (i__ + 2) * work_dim1] = du2[i__];
}
} else if (i__ == *n) {
work[i__ + i__ * work_dim1] = df[i__];
} else {
work[i__ + i__ * work_dim1] = df[i__];
work[i__ + (i__ + 1) * work_dim1] = duf[i__];
if (i__ < *n - 1) {
work[i__ + (i__ + 2) * work_dim1] = du2[i__];
}
}
/* L30: */
}
/* Multiply on the left by L. */
lastj = *n;
for (i__ = *n - 1; i__ >= 1; --i__) {
li = dlf[i__];
i__1 = lastj - i__ + 1;
saxpy_(&i__1, &li, &work[i__ + i__ * work_dim1], ldwork, &work[i__ +
1 + i__ * work_dim1], ldwork);
ip = ipiv[i__];
if (ip == i__) {
/* Computing MIN */
i__1 = i__ + 2;
lastj = min(i__1,*n);
} else {
i__1 = lastj - i__ + 1;
sswap_(&i__1, &work[i__ + i__ * work_dim1], ldwork, &work[i__ + 1
+ i__ * work_dim1], ldwork);
}
/* L40: */
}
/* Subtract the matrix A. */
work[work_dim1 + 1] -= d__[1];
if (*n > 1) {
work[(work_dim1 << 1) + 1] -= du[1];
work[*n + (*n - 1) * work_dim1] -= dl[*n - 1];
work[*n + *n * work_dim1] -= d__[*n];
i__1 = *n - 1;
for (i__ = 2; i__ <= i__1; ++i__) {
work[i__ + (i__ - 1) * work_dim1] -= dl[i__ - 1];
work[i__ + i__ * work_dim1] -= d__[i__];
work[i__ + (i__ + 1) * work_dim1] -= du[i__];
/* L50: */
}
}
/* Compute the 1-norm of the tridiagonal matrix A. */
anorm = slangt_("1", n, &dl[1], &d__[1], &du[1]);
/* Compute the 1-norm of WORK, which is only guaranteed to be */
/* upper Hessenberg. */
*resid = slanhs_("1", n, &work[work_offset], ldwork, &rwork[1])
;
/* Compute norm(L*U - A) / (norm(A) * EPS) */
if (anorm <= 0.f) {
if (*resid != 0.f) {
*resid = 1.f / eps;
}
} else {
*resid = *resid / anorm / eps;
}
return 0;
/* End of SGTT01 */
} /* sgtt01_ */
/* Subroutine */ int shsein_(char *side, char *eigsrc, char *initv, logical *
select, integer *n, real *h__, integer *ldh, real *wr, real *wi, real
*vl, integer *ldvl, real *vr, integer *ldvr, integer *mm, integer *m,
real *work, integer *ifaill, integer *ifailr, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
SHSEIN uses inverse iteration to find specified right and/or left
eigenvectors of a real upper Hessenberg matrix H.
The right eigenvector x and the left eigenvector y of the matrix H
corresponding to an eigenvalue w are defined by:
H * x = w * x, y**h * H = w * y**h
where y**h denotes the conjugate transpose of the vector y.
Arguments
=========
SIDE (input) CHARACTER*1
= 'R': compute right eigenvectors only;
= 'L': compute left eigenvectors only;
= 'B': compute both right and left eigenvectors.
EIGSRC (input) CHARACTER*1
Specifies the source of eigenvalues supplied in (WR,WI):
= 'Q': the eigenvalues were found using SHSEQR; thus, if
H has zero subdiagonal elements, and so is
block-triangular, then the j-th eigenvalue can be
assumed to be an eigenvalue of the block containing
the j-th row/column. This property allows SHSEIN to
perform inverse iteration on just one diagonal block.
= 'N': no assumptions are made on the correspondence
between eigenvalues and diagonal blocks. In this
case, SHSEIN must always perform inverse iteration
using the whole matrix H.
INITV (input) CHARACTER*1
= 'N': no initial vectors are supplied;
= 'U': user-supplied initial vectors are stored in the arrays
VL and/or VR.
SELECT (input/output) LOGICAL array, dimension (N)
Specifies the eigenvectors to be computed. To select the
real eigenvector corresponding to a real eigenvalue WR(j),
SELECT(j) must be set to .TRUE.. To select the complex
eigenvector corresponding to a complex eigenvalue
(WR(j),WI(j)), with complex conjugate (WR(j+1),WI(j+1)),
either SELECT(j) or SELECT(j+1) or both must be set to
.TRUE.; then on exit SELECT(j) is .TRUE. and SELECT(j+1) is
.FALSE..
N (input) INTEGER
The order of the matrix H. N >= 0.
H (input) REAL array, dimension (LDH,N)
The upper Hessenberg matrix H.
LDH (input) INTEGER
The leading dimension of the array H. LDH >= max(1,N).
WR (input/output) REAL array, dimension (N)
WI (input) REAL array, dimension (N)
On entry, the real and imaginary parts of the eigenvalues of
H; a complex conjugate pair of eigenvalues must be stored in
consecutive elements of WR and WI.
On exit, WR may have been altered since close eigenvalues
are perturbed slightly in searching for independent
eigenvectors.
VL (input/output) REAL array, dimension (LDVL,MM)
On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must
contain starting vectors for the inverse iteration for the
left eigenvectors; the starting vector for each eigenvector
must be in the same column(s) in which the eigenvector will
be stored.
On exit, if SIDE = 'L' or 'B', the left eigenvectors
specified by SELECT will be stored consecutively in the
columns of VL, in the same order as their eigenvalues. A
complex eigenvector corresponding to a complex eigenvalue is
stored in two consecutive columns, the first holding the real
part and the second the imaginary part.
If SIDE = 'R', VL is not referenced.
LDVL (input) INTEGER
The leading dimension of the array VL.
LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
VR (input/output) REAL array, dimension (LDVR,MM)
On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must
contain starting vectors for the inverse iteration for the
right eigenvectors; the starting vector for each eigenvector
must be in the same column(s) in which the eigenvector will
be stored.
On exit, if SIDE = 'R' or 'B', the right eigenvectors
specified by SELECT will be stored consecutively in the
columns of VR, in the same order as their eigenvalues. A
complex eigenvector corresponding to a complex eigenvalue is
stored in two consecutive columns, the first holding the real
part and the second the imaginary part.
If SIDE = 'L', VR is not referenced.
LDVR (input) INTEGER
The leading dimension of the array VR.
LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.
MM (input) INTEGER
The number of columns in the arrays VL and/or VR. MM >= M.
M (output) INTEGER
The number of columns in the arrays VL and/or VR required to
store the eigenvectors; each selected real eigenvector
occupies one column and each selected complex eigenvector
occupies two columns.
WORK (workspace) REAL array, dimension ((N+2)*N)
IFAILL (output) INTEGER array, dimension (MM)
If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left
eigenvector in the i-th column of VL (corresponding to the
eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the
eigenvector converged satisfactorily. If the i-th and (i+1)th
columns of VL hold a complex eigenvector, then IFAILL(i) and
IFAILL(i+1) are set to the same value.
If SIDE = 'R', IFAILL is not referenced.
IFAILR (output) INTEGER array, dimension (MM)
If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right
eigenvector in the i-th column of VR (corresponding to the
eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the
eigenvector converged satisfactorily. If the i-th and (i+1)th
columns of VR hold a complex eigenvector, then IFAILR(i) and
IFAILR(i+1) are set to the same value.
If SIDE = 'L', IFAILR is not referenced.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, i is the number of eigenvectors which
failed to converge; see IFAILL and IFAILR for further
details.
Further Details
===============
Each eigenvector is normalized so that the element of largest
magnitude has magnitude 1; here the magnitude of a complex number
(x,y) is taken to be |x|+|y|.
=====================================================================
Decode and test the input parameters.
Parameter adjustments */
/* Table of constant values */
static logical c_false = FALSE_;
static logical c_true = TRUE_;
/* System generated locals */
integer h_dim1, h_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2;
real r__1, r__2;
/* Local variables */
static logical pair;
static real unfl;
static integer i__, k;
extern logical lsame_(char *, char *);
static integer iinfo;
static logical leftv, bothv;
static real hnorm;
static integer kl, kr;
extern doublereal slamch_(char *);
extern /* Subroutine */ int slaein_(logical *, logical *, integer *, real
*, integer *, real *, real *, real *, real *, real *, integer *,
real *, real *, real *, real *, integer *), xerbla_(char *,
integer *);
static real bignum;
extern doublereal slanhs_(char *, integer *, real *, integer *, real *);
static logical noinit;
static integer ldwork;
static logical rightv, fromqr;
static real smlnum;
static integer kln, ksi;
static real wki;
static integer ksr;
static real ulp, wkr, eps3;
#define h___ref(a_1,a_2) h__[(a_2)*h_dim1 + a_1]
#define vl_ref(a_1,a_2) vl[(a_2)*vl_dim1 + a_1]
#define vr_ref(a_1,a_2) vr[(a_2)*vr_dim1 + a_1]
--select;
h_dim1 = *ldh;
h_offset = 1 + h_dim1 * 1;
h__ -= h_offset;
--wr;
--wi;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1 * 1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1 * 1;
vr -= vr_offset;
--work;
--ifaill;
--ifailr;
/* Function Body */
bothv = lsame_(side, "B");
rightv = lsame_(side, "R") || bothv;
leftv = lsame_(side, "L") || bothv;
fromqr = lsame_(eigsrc, "Q");
noinit = lsame_(initv, "N");
/* Set M to the number of columns required to store the selected
eigenvectors, and standardize the array SELECT. */
*m = 0;
pair = FALSE_;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (pair) {
pair = FALSE_;
select[k] = FALSE_;
} else {
if (wi[k] == 0.f) {
if (select[k]) {
++(*m);
}
} else {
pair = TRUE_;
if (select[k] || select[k + 1]) {
select[k] = TRUE_;
*m += 2;
}
}
}
/* L10: */
}
*info = 0;
if (! rightv && ! leftv) {
*info = -1;
} else if (! fromqr && ! lsame_(eigsrc, "N")) {
*info = -2;
} else if (! noinit && ! lsame_(initv, "U")) {
*info = -3;
} else if (*n < 0) {
*info = -5;
} else if (*ldh < max(1,*n)) {
*info = -7;
} else if (*ldvl < 1 || leftv && *ldvl < *n) {
*info = -11;
} else if (*ldvr < 1 || rightv && *ldvr < *n) {
*info = -13;
} else if (*mm < *m) {
*info = -14;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SHSEIN", &i__1);
return 0;
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
/* Set machine-dependent constants. */
unfl = slamch_("Safe minimum");
ulp = slamch_("Precision");
smlnum = unfl * (*n / ulp);
bignum = (1.f - ulp) / smlnum;
ldwork = *n + 1;
kl = 1;
kln = 0;
if (fromqr) {
kr = 0;
} else {
kr = *n;
}
ksr = 1;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (select[k]) {
/* Compute eigenvector(s) corresponding to W(K). */
if (fromqr) {
/* If affiliation of eigenvalues is known, check whether
the matrix splits.
Determine KL and KR such that 1 <= KL <= K <= KR <= N
and H(KL,KL-1) and H(KR+1,KR) are zero (or KL = 1 or
KR = N).
Then inverse iteration can be performed with the
submatrix H(KL:N,KL:N) for a left eigenvector, and with
the submatrix H(1:KR,1:KR) for a right eigenvector. */
i__2 = kl + 1;
for (i__ = k; i__ >= i__2; --i__) {
if (h___ref(i__, i__ - 1) == 0.f) {
goto L30;
}
/* L20: */
}
L30:
kl = i__;
if (k > kr) {
i__2 = *n - 1;
for (i__ = k; i__ <= i__2; ++i__) {
if (h___ref(i__ + 1, i__) == 0.f) {
goto L50;
}
/* L40: */
}
L50:
kr = i__;
}
}
if (kl != kln) {
kln = kl;
/* Compute infinity-norm of submatrix H(KL:KR,KL:KR) if it
has not ben computed before. */
i__2 = kr - kl + 1;
hnorm = slanhs_("I", &i__2, &h___ref(kl, kl), ldh, &work[1]);
if (hnorm > 0.f) {
eps3 = hnorm * ulp;
} else {
eps3 = smlnum;
}
}
/* Perturb eigenvalue if it is close to any previous
selected eigenvalues affiliated to the submatrix
H(KL:KR,KL:KR). Close roots are modified by EPS3. */
wkr = wr[k];
wki = wi[k];
L60:
i__2 = kl;
for (i__ = k - 1; i__ >= i__2; --i__) {
if (select[i__] && (r__1 = wr[i__] - wkr, dabs(r__1)) + (r__2
= wi[i__] - wki, dabs(r__2)) < eps3) {
wkr += eps3;
goto L60;
}
/* L70: */
}
wr[k] = wkr;
pair = wki != 0.f;
if (pair) {
ksi = ksr + 1;
} else {
ksi = ksr;
}
if (leftv) {
/* Compute left eigenvector. */
i__2 = *n - kl + 1;
slaein_(&c_false, &noinit, &i__2, &h___ref(kl, kl), ldh, &wkr,
&wki, &vl_ref(kl, ksr), &vl_ref(kl, ksi), &work[1], &
ldwork, &work[*n * *n + *n + 1], &eps3, &smlnum, &
bignum, &iinfo);
if (iinfo > 0) {
if (pair) {
*info += 2;
} else {
++(*info);
}
ifaill[ksr] = k;
ifaill[ksi] = k;
} else {
ifaill[ksr] = 0;
ifaill[ksi] = 0;
}
i__2 = kl - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
vl_ref(i__, ksr) = 0.f;
/* L80: */
}
if (pair) {
i__2 = kl - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
vl_ref(i__, ksi) = 0.f;
/* L90: */
}
}
}
if (rightv) {
/* Compute right eigenvector. */
slaein_(&c_true, &noinit, &kr, &h__[h_offset], ldh, &wkr, &
wki, &vr_ref(1, ksr), &vr_ref(1, ksi), &work[1], &
ldwork, &work[*n * *n + *n + 1], &eps3, &smlnum, &
bignum, &iinfo);
if (iinfo > 0) {
if (pair) {
*info += 2;
} else {
++(*info);
}
ifailr[ksr] = k;
ifailr[ksi] = k;
} else {
ifailr[ksr] = 0;
ifailr[ksi] = 0;
}
i__2 = *n;
for (i__ = kr + 1; i__ <= i__2; ++i__) {
vr_ref(i__, ksr) = 0.f;
/* L100: */
}
if (pair) {
i__2 = *n;
for (i__ = kr + 1; i__ <= i__2; ++i__) {
vr_ref(i__, ksi) = 0.f;
/* L110: */
}
}
}
if (pair) {
ksr += 2;
} else {
++ksr;
}
}
/* L120: */
}
return 0;
/* End of SHSEIN */
} /* shsein_ */
/* Subroutine */ int snaitr_(integer *ido, char *bmat, integer *n, integer *k,
integer *np, integer *nb, real *resid, real *rnorm, real *v, integer
*ldv, real *h__, integer *ldh, integer *ipntr, real *workd, integer *
info, ftnlen bmat_len)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer h_dim1, h_offset, v_dim1, v_offset, i__1, i__2;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer i__, j;
static real t0, t1, t2, t3, t4, t5;
static integer jj, ipj, irj, ivj;
static real ulp, tst1;
static integer ierr, iter;
static real unfl, ovfl;
extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
static integer itry;
static real temp1;
static logical orth1, orth2, step3, step4;
extern doublereal snrm2_(integer *, real *, integer *);
static real betaj;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static integer infol;
extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *,
ftnlen);
static real xtemp[2];
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
static real wnorm;
extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
real *, integer *), ivout_(integer *, integer *, integer *,
integer *, char *, ftnlen), smout_(integer *, integer *, integer *
, real *, integer *, integer *, char *, ftnlen), svout_(integer *,
integer *, real *, integer *, char *, ftnlen), sgetv0_(integer *,
char *, integer *, logical *, integer *, integer *, real *,
integer *, real *, real *, integer *, real *, integer *, ftnlen);
static real rnorm1;
extern /* Subroutine */ int slabad_(real *, real *);
extern doublereal slamch_(char *, ftnlen);
extern /* Subroutine */ int second_(real *), slascl_(char *, integer *,
integer *, real *, real *, integer *, integer *, real *, integer *
, integer *, ftnlen);
static logical rstart;
static integer msglvl;
static real smlnum;
extern doublereal slanhs_(char *, integer *, real *, integer *, real *,
ftnlen);
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %---------------% */
/* | Local Scalars | */
/* %---------------% */
/* %-----------------------% */
/* | Local Array Arguments | */
/* %-----------------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %---------------------% */
/* | Intrinsic Functions | */
/* %---------------------% */
/* %-----------------% */
/* | Data statements | */
/* %-----------------% */
/* Parameter adjustments */
--workd;
--resid;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--ipntr;
/* Function Body */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
if (first) {
/* %-----------------------------------------% */
/* | Set machine-dependent constants for the | */
/* | the splitting and deflation criterion. | */
/* | If norm(H) <= sqrt(OVFL), | */
/* | overflow should not occur. | */
/* | REFERENCE: LAPACK subroutine slahqr | */
/* %-----------------------------------------% */
unfl = slamch_("safe minimum", (ftnlen)12);
ovfl = 1.f / unfl;
slabad_(&unfl, &ovfl);
ulp = slamch_("precision", (ftnlen)9);
smlnum = unfl * (*n / ulp);
first = FALSE_;
}
if (*ido == 0) {
/* %-------------------------------% */
/* | Initialize timing statistics | */
/* | & message level for debugging | */
/* %-------------------------------% */
second_(&t0);
msglvl = debug_1.mnaitr;
/* %------------------------------% */
/* | Initial call to this routine | */
/* %------------------------------% */
*info = 0;
step3 = FALSE_;
step4 = FALSE_;
rstart = FALSE_;
orth1 = FALSE_;
orth2 = FALSE_;
j = *k + 1;
ipj = 1;
irj = ipj + *n;
ivj = irj + *n;
}
/* %-------------------------------------------------% */
/* | When in reverse communication mode one of: | */
/* | STEP3, STEP4, ORTH1, ORTH2, RSTART | */
/* | will be .true. when .... | */
/* | STEP3: return from computing OP*v_{j}. | */
/* | STEP4: return from computing B-norm of OP*v_{j} | */
/* | ORTH1: return from computing B-norm of r_{j+1} | */
/* | ORTH2: return from computing B-norm of | */
/* | correction to the residual vector. | */
/* | RSTART: return from OP computations needed by | */
/* | sgetv0. | */
/* %-------------------------------------------------% */
if (step3) {
goto L50;
}
if (step4) {
goto L60;
}
if (orth1) {
goto L70;
}
if (orth2) {
goto L90;
}
if (rstart) {
goto L30;
}
/* %-----------------------------% */
/* | Else this is the first step | */
/* %-----------------------------% */
/* %--------------------------------------------------------------% */
/* | | */
/* | A R N O L D I I T E R A T I O N L O O P | */
/* | | */
/* | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | */
/* %--------------------------------------------------------------% */
L1000:
if (msglvl > 1) {
ivout_(&debug_1.logfil, &c__1, &j, &debug_1.ndigit, "_naitr: generat"
"ing Arnoldi vector number", (ftnlen)40);
svout_(&debug_1.logfil, &c__1, rnorm, &debug_1.ndigit, "_naitr: B-no"
"rm of the current residual is", (ftnlen)41);
}
/* %---------------------------------------------------% */
/* | STEP 1: Check if the B norm of j-th residual | */
/* | vector is zero. Equivalent to determing whether | */
/* | an exact j-step Arnoldi factorization is present. | */
/* %---------------------------------------------------% */
betaj = *rnorm;
if (*rnorm > 0.f) {
goto L40;
}
/* %---------------------------------------------------% */
/* | Invariant subspace found, generate a new starting | */
/* | vector which is orthogonal to the current Arnoldi | */
/* | basis and continue the iteration. | */
/* %---------------------------------------------------% */
if (msglvl > 0) {
ivout_(&debug_1.logfil, &c__1, &j, &debug_1.ndigit, "_naitr: ****** "
"RESTART AT STEP ******", (ftnlen)37);
}
/* %---------------------------------------------% */
/* | ITRY is the loop variable that controls the | */
/* | maximum amount of times that a restart is | */
/* | attempted. NRSTRT is used by stat.h | */
/* %---------------------------------------------% */
betaj = 0.f;
++timing_1.nrstrt;
itry = 1;
L20:
rstart = TRUE_;
*ido = 0;
L30:
/* %--------------------------------------% */
/* | If in reverse communication mode and | */
/* | RSTART = .true. flow returns here. | */
/* %--------------------------------------% */
sgetv0_(ido, bmat, &itry, &c_false, n, &j, &v[v_offset], ldv, &resid[1],
rnorm, &ipntr[1], &workd[1], &ierr, (ftnlen)1);
if (*ido != 99) {
goto L9000;
}
if (ierr < 0) {
++itry;
if (itry <= 3) {
goto L20;
}
/* %------------------------------------------------% */
/* | Give up after several restart attempts. | */
/* | Set INFO to the size of the invariant subspace | */
/* | which spans OP and exit. | */
/* %------------------------------------------------% */
*info = j - 1;
second_(&t1);
timing_1.tnaitr += t1 - t0;
*ido = 99;
goto L9000;
}
L40:
/* %---------------------------------------------------------% */
/* | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | */
/* | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | */
/* | when reciprocating a small RNORM, test against lower | */
/* | machine bound. | */
/* %---------------------------------------------------------% */
scopy_(n, &resid[1], &c__1, &v[j * v_dim1 + 1], &c__1);
if (*rnorm >= unfl) {
temp1 = 1.f / *rnorm;
sscal_(n, &temp1, &v[j * v_dim1 + 1], &c__1);
sscal_(n, &temp1, &workd[ipj], &c__1);
} else {
/* %-----------------------------------------% */
/* | To scale both v_{j} and p_{j} carefully | */
/* | use LAPACK routine SLASCL | */
/* %-----------------------------------------% */
slascl_("General", &i__, &i__, rnorm, &c_b25, n, &c__1, &v[j * v_dim1
+ 1], n, &infol, (ftnlen)7);
slascl_("General", &i__, &i__, rnorm, &c_b25, n, &c__1, &workd[ipj],
n, &infol, (ftnlen)7);
}
/* %------------------------------------------------------% */
/* | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | */
/* | Note that this is not quite yet r_{j}. See STEP 4 | */
/* %------------------------------------------------------% */
step3 = TRUE_;
++timing_1.nopx;
second_(&t2);
scopy_(n, &v[j * v_dim1 + 1], &c__1, &workd[ivj], &c__1);
ipntr[1] = ivj;
ipntr[2] = irj;
ipntr[3] = ipj;
*ido = 1;
/* %-----------------------------------% */
/* | Exit in order to compute OP*v_{j} | */
/* %-----------------------------------% */
goto L9000;
L50:
/* %----------------------------------% */
/* | Back from reverse communication; | */
/* | WORKD(IRJ:IRJ+N-1) := OP*v_{j} | */
/* | if step3 = .true. | */
/* %----------------------------------% */
second_(&t3);
timing_1.tmvopx += t3 - t2;
step3 = FALSE_;
/* %------------------------------------------% */
/* | Put another copy of OP*v_{j} into RESID. | */
/* %------------------------------------------% */
scopy_(n, &workd[irj], &c__1, &resid[1], &c__1);
/* %---------------------------------------% */
/* | STEP 4: Finish extending the Arnoldi | */
/* | factorization to length j. | */
/* %---------------------------------------% */
second_(&t2);
if (*(unsigned char *)bmat == 'G') {
++timing_1.nbx;
step4 = TRUE_;
ipntr[1] = irj;
ipntr[2] = ipj;
*ido = 2;
/* %-------------------------------------% */
/* | Exit in order to compute B*OP*v_{j} | */
/* %-------------------------------------% */
goto L9000;
} else if (*(unsigned char *)bmat == 'I') {
scopy_(n, &resid[1], &c__1, &workd[ipj], &c__1);
}
L60:
/* %----------------------------------% */
/* | Back from reverse communication; | */
/* | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} | */
/* | if step4 = .true. | */
/* %----------------------------------% */
if (*(unsigned char *)bmat == 'G') {
second_(&t3);
timing_1.tmvbx += t3 - t2;
}
step4 = FALSE_;
/* %-------------------------------------% */
/* | The following is needed for STEP 5. | */
/* | Compute the B-norm of OP*v_{j}. | */
/* %-------------------------------------% */
if (*(unsigned char *)bmat == 'G') {
wnorm = sdot_(n, &resid[1], &c__1, &workd[ipj], &c__1);
wnorm = sqrt((dabs(wnorm)));
} else if (*(unsigned char *)bmat == 'I') {
wnorm = snrm2_(n, &resid[1], &c__1);
}
/* %-----------------------------------------% */
/* | Compute the j-th residual corresponding | */
/* | to the j step factorization. | */
/* | Use Classical Gram Schmidt and compute: | */
/* | w_{j} <- V_{j}^T * B * OP * v_{j} | */
/* | r_{j} <- OP*v_{j} - V_{j} * w_{j} | */
/* %-----------------------------------------% */
/* %------------------------------------------% */
/* | Compute the j Fourier coefficients w_{j} | */
/* | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | */
/* %------------------------------------------% */
sgemv_("T", n, &j, &c_b25, &v[v_offset], ldv, &workd[ipj], &c__1, &c_b47,
&h__[j * h_dim1 + 1], &c__1, (ftnlen)1);
/* %--------------------------------------% */
/* | Orthogonalize r_{j} against V_{j}. | */
/* | RESID contains OP*v_{j}. See STEP 3. | */
/* %--------------------------------------% */
sgemv_("N", n, &j, &c_b50, &v[v_offset], ldv, &h__[j * h_dim1 + 1], &c__1,
&c_b25, &resid[1], &c__1, (ftnlen)1);
if (j > 1) {
h__[j + (j - 1) * h_dim1] = betaj;
}
second_(&t4);
orth1 = TRUE_;
second_(&t2);
if (*(unsigned char *)bmat == 'G') {
++timing_1.nbx;
scopy_(n, &resid[1], &c__1, &workd[irj], &c__1);
ipntr[1] = irj;
ipntr[2] = ipj;
*ido = 2;
/* %----------------------------------% */
/* | Exit in order to compute B*r_{j} | */
/* %----------------------------------% */
goto L9000;
} else if (*(unsigned char *)bmat == 'I') {
scopy_(n, &resid[1], &c__1, &workd[ipj], &c__1);
}
L70:
/* %---------------------------------------------------% */
/* | Back from reverse communication if ORTH1 = .true. | */
/* | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | */
/* %---------------------------------------------------% */
if (*(unsigned char *)bmat == 'G') {
second_(&t3);
timing_1.tmvbx += t3 - t2;
}
orth1 = FALSE_;
/* %------------------------------% */
/* | Compute the B-norm of r_{j}. | */
/* %------------------------------% */
if (*(unsigned char *)bmat == 'G') {
*rnorm = sdot_(n, &resid[1], &c__1, &workd[ipj], &c__1);
*rnorm = sqrt((dabs(*rnorm)));
} else if (*(unsigned char *)bmat == 'I') {
*rnorm = snrm2_(n, &resid[1], &c__1);
}
/* %-----------------------------------------------------------% */
/* | STEP 5: Re-orthogonalization / Iterative refinement phase | */
/* | Maximum NITER_ITREF tries. | */
/* | | */
/* | s = V_{j}^T * B * r_{j} | */
/* | r_{j} = r_{j} - V_{j}*s | */
/* | alphaj = alphaj + s_{j} | */
/* | | */
/* | The stopping criteria used for iterative refinement is | */
/* | discussed in Parlett's book SEP, page 107 and in Gragg & | */
/* | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | */
/* | Determine if we need to correct the residual. The goal is | */
/* | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | */
/* | The following test determines whether the sine of the | */
/* | angle between OP*x and the computed residual is less | */
/* | than or equal to 0.717. | */
/* %-----------------------------------------------------------% */
if (*rnorm > wnorm * .717f) {
goto L100;
}
iter = 0;
++timing_1.nrorth;
/* %---------------------------------------------------% */
/* | Enter the Iterative refinement phase. If further | */
/* | refinement is necessary, loop back here. The loop | */
/* | variable is ITER. Perform a step of Classical | */
/* | Gram-Schmidt using all the Arnoldi vectors V_{j} | */
/* %---------------------------------------------------% */
L80:
if (msglvl > 2) {
xtemp[0] = wnorm;
xtemp[1] = *rnorm;
svout_(&debug_1.logfil, &c__2, xtemp, &debug_1.ndigit, "_naitr: re-o"
"rthonalization; wnorm and rnorm are", (ftnlen)47);
svout_(&debug_1.logfil, &j, &h__[j * h_dim1 + 1], &debug_1.ndigit,
"_naitr: j-th column of H", (ftnlen)24);
}
/* %----------------------------------------------------% */
/* | Compute V_{j}^T * B * r_{j}. | */
/* | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | */
/* %----------------------------------------------------% */
sgemv_("T", n, &j, &c_b25, &v[v_offset], ldv, &workd[ipj], &c__1, &c_b47,
&workd[irj], &c__1, (ftnlen)1);
/* %---------------------------------------------% */
/* | Compute the correction to the residual: | */
/* | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | */
/* | The correction to H is v(:,1:J)*H(1:J,1:J) | */
/* | + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. | */
/* %---------------------------------------------% */
sgemv_("N", n, &j, &c_b50, &v[v_offset], ldv, &workd[irj], &c__1, &c_b25,
&resid[1], &c__1, (ftnlen)1);
saxpy_(&j, &c_b25, &workd[irj], &c__1, &h__[j * h_dim1 + 1], &c__1);
orth2 = TRUE_;
second_(&t2);
if (*(unsigned char *)bmat == 'G') {
++timing_1.nbx;
scopy_(n, &resid[1], &c__1, &workd[irj], &c__1);
ipntr[1] = irj;
ipntr[2] = ipj;
*ido = 2;
/* %-----------------------------------% */
/* | Exit in order to compute B*r_{j}. | */
/* | r_{j} is the corrected residual. | */
/* %-----------------------------------% */
goto L9000;
} else if (*(unsigned char *)bmat == 'I') {
scopy_(n, &resid[1], &c__1, &workd[ipj], &c__1);
}
L90:
/* %---------------------------------------------------% */
/* | Back from reverse communication if ORTH2 = .true. | */
/* %---------------------------------------------------% */
if (*(unsigned char *)bmat == 'G') {
second_(&t3);
timing_1.tmvbx += t3 - t2;
}
/* %-----------------------------------------------------% */
/* | Compute the B-norm of the corrected residual r_{j}. | */
/* %-----------------------------------------------------% */
if (*(unsigned char *)bmat == 'G') {
rnorm1 = sdot_(n, &resid[1], &c__1, &workd[ipj], &c__1);
rnorm1 = sqrt((dabs(rnorm1)));
} else if (*(unsigned char *)bmat == 'I') {
rnorm1 = snrm2_(n, &resid[1], &c__1);
}
if (msglvl > 0 && iter > 0) {
ivout_(&debug_1.logfil, &c__1, &j, &debug_1.ndigit, "_naitr: Iterati"
"ve refinement for Arnoldi residual", (ftnlen)49);
if (msglvl > 2) {
xtemp[0] = *rnorm;
xtemp[1] = rnorm1;
svout_(&debug_1.logfil, &c__2, xtemp, &debug_1.ndigit, "_naitr: "
"iterative refinement ; rnorm and rnorm1 are", (ftnlen)51);
}
}
/* %-----------------------------------------% */
/* | Determine if we need to perform another | */
/* | step of re-orthogonalization. | */
/* %-----------------------------------------% */
if (rnorm1 > *rnorm * .717f) {
/* %---------------------------------------% */
/* | No need for further refinement. | */
/* | The cosine of the angle between the | */
/* | corrected residual vector and the old | */
/* | residual vector is greater than 0.717 | */
/* | In other words the corrected residual | */
/* | and the old residual vector share an | */
/* | angle of less than arcCOS(0.717) | */
/* %---------------------------------------% */
*rnorm = rnorm1;
} else {
/* %-------------------------------------------% */
/* | Another step of iterative refinement step | */
/* | is required. NITREF is used by stat.h | */
/* %-------------------------------------------% */
++timing_1.nitref;
*rnorm = rnorm1;
++iter;
if (iter <= 1) {
goto L80;
}
/* %-------------------------------------------------% */
/* | Otherwise RESID is numerically in the span of V | */
/* %-------------------------------------------------% */
i__1 = *n;
for (jj = 1; jj <= i__1; ++jj) {
resid[jj] = 0.f;
/* L95: */
}
*rnorm = 0.f;
}
/* %----------------------------------------------% */
/* | Branch here directly if iterative refinement | */
/* | wasn't necessary or after at most NITER_REF | */
/* | steps of iterative refinement. | */
/* %----------------------------------------------% */
L100:
rstart = FALSE_;
orth2 = FALSE_;
second_(&t5);
timing_1.titref += t5 - t4;
/* %------------------------------------% */
/* | STEP 6: Update j = j+1; Continue | */
/* %------------------------------------% */
++j;
if (j > *k + *np) {
second_(&t1);
timing_1.tnaitr += t1 - t0;
*ido = 99;
i__1 = *k + *np - 1;
for (i__ = max(1,*k); i__ <= i__1; ++i__) {
/* %--------------------------------------------% */
/* | Check for splitting and deflation. | */
/* | Use a standard test as in the QR algorithm | */
/* | REFERENCE: LAPACK subroutine slahqr | */
/* %--------------------------------------------% */
tst1 = (r__1 = h__[i__ + i__ * h_dim1], dabs(r__1)) + (r__2 = h__[
i__ + 1 + (i__ + 1) * h_dim1], dabs(r__2));
if (tst1 == 0.f) {
i__2 = *k + *np;
tst1 = slanhs_("1", &i__2, &h__[h_offset], ldh, &workd[*n + 1]
, (ftnlen)1);
}
/* Computing MAX */
r__2 = ulp * tst1;
if ((r__1 = h__[i__ + 1 + i__ * h_dim1], dabs(r__1)) <= dmax(r__2,
smlnum)) {
h__[i__ + 1 + i__ * h_dim1] = 0.f;
}
/* L110: */
}
if (msglvl > 2) {
i__1 = *k + *np;
i__2 = *k + *np;
smout_(&debug_1.logfil, &i__1, &i__2, &h__[h_offset], ldh, &
debug_1.ndigit, "_naitr: Final upper Hessenberg matrix H"
" of order K+NP", (ftnlen)53);
}
goto L9000;
}
/* %--------------------------------------------------------% */
/* | Loop back to extend the factorization by another step. | */
/* %--------------------------------------------------------% */
goto L1000;
/* %---------------------------------------------------------------% */
/* | | */
/* | E N D O F M A I N I T E R A T I O N L O O P | */
/* | | */
/* %---------------------------------------------------------------% */
L9000:
return 0;
/* %---------------% */
/* | End of snaitr | */
/* %---------------% */
} /* snaitr_ */
/* Subroutine */ int sgtt01_(integer *n, real *dl, real *d__, real *du, real *
dlf, real *df, real *duf, real *du2, integer *ipiv, real *work,
integer *ldwork, real *rwork, real *resid)
{
/* System generated locals */
integer work_dim1, work_offset, i__1, i__2;
/* Local variables */
static integer i__, j;
static real anorm;
static integer lastj;
extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
integer *), saxpy_(integer *, real *, real *, integer *, real *,
integer *);
static real li;
static integer ip;
extern doublereal slamch_(char *), slangt_(char *, integer *,
real *, real *, real *), slanhs_(char *, integer *, real *
, integer *, real *);
static real eps;
#define work_ref(a_1,a_2) work[(a_2)*work_dim1 + a_1]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
SGTT01 reconstructs a tridiagonal matrix A from its LU factorization
and computes the residual
norm(L*U - A) / ( norm(A) * EPS ),
where EPS is the machine epsilon.
Arguments
=========
N (input) INTEGTER
The order of the matrix A. N >= 0.
DL (input) REAL array, dimension (N-1)
The (n-1) sub-diagonal elements of A.
D (input) REAL array, dimension (N)
The diagonal elements of A.
DU (input) REAL array, dimension (N-1)
The (n-1) super-diagonal elements of A.
DLF (input) REAL array, dimension (N-1)
The (n-1) multipliers that define the matrix L from the
LU factorization of A.
DF (input) REAL array, dimension (N)
The n diagonal elements of the upper triangular matrix U from
the LU factorization of A.
DUF (input) REAL array, dimension (N-1)
The (n-1) elements of the first super-diagonal of U.
DU2F (input) REAL array, dimension (N-2)
The (n-2) elements of the second super-diagonal of U.
IPIV (input) INTEGER array, dimension (N)
The pivot indices; for 1 <= i <= n, row i of the matrix was
interchanged with row IPIV(i). IPIV(i) will always be either
i or i+1; IPIV(i) = i indicates a row interchange was not
required.
WORK (workspace) REAL array, dimension (LDWORK,N)
LDWORK (input) INTEGER
The leading dimension of the array WORK. LDWORK >= max(1,N).
RWORK (workspace) REAL array, dimension (N)
RESID (output) REAL
The scaled residual: norm(L*U - A) / (norm(A) * EPS)
=====================================================================
Quick return if possible
Parameter adjustments */
--dl;
--d__;
--du;
--dlf;
--df;
--duf;
--du2;
--ipiv;
work_dim1 = *ldwork;
work_offset = 1 + work_dim1 * 1;
work -= work_offset;
--rwork;
/* Function Body */
if (*n <= 0) {
*resid = 0.f;
return 0;
}
eps = slamch_("Epsilon");
/* Copy the matrix U to WORK. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work_ref(i__, j) = 0.f;
/* L10: */
}
/* L20: */
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ == 1) {
work_ref(i__, i__) = df[i__];
if (*n >= 2) {
work_ref(i__, i__ + 1) = duf[i__];
}
if (*n >= 3) {
work_ref(i__, i__ + 2) = du2[i__];
}
} else if (i__ == *n) {
work_ref(i__, i__) = df[i__];
} else {
work_ref(i__, i__) = df[i__];
work_ref(i__, i__ + 1) = duf[i__];
if (i__ < *n - 1) {
work_ref(i__, i__ + 2) = du2[i__];
}
}
/* L30: */
}
/* Multiply on the left by L. */
lastj = *n;
for (i__ = *n - 1; i__ >= 1; --i__) {
li = dlf[i__];
i__1 = lastj - i__ + 1;
saxpy_(&i__1, &li, &work_ref(i__, i__), ldwork, &work_ref(i__ + 1,
i__), ldwork);
ip = ipiv[i__];
if (ip == i__) {
/* Computing MIN */
i__1 = i__ + 2;
lastj = min(i__1,*n);
} else {
i__1 = lastj - i__ + 1;
sswap_(&i__1, &work_ref(i__, i__), ldwork, &work_ref(i__ + 1, i__)
, ldwork);
}
/* L40: */
}
/* Subtract the matrix A. */
work_ref(1, 1) = work_ref(1, 1) - d__[1];
if (*n > 1) {
work_ref(1, 2) = work_ref(1, 2) - du[1];
work_ref(*n, *n - 1) = work_ref(*n, *n - 1) - dl[*n - 1];
work_ref(*n, *n) = work_ref(*n, *n) - d__[*n];
i__1 = *n - 1;
for (i__ = 2; i__ <= i__1; ++i__) {
work_ref(i__, i__ - 1) = work_ref(i__, i__ - 1) - dl[i__ - 1];
work_ref(i__, i__) = work_ref(i__, i__) - d__[i__];
work_ref(i__, i__ + 1) = work_ref(i__, i__ + 1) - du[i__];
/* L50: */
}
}
/* Compute the 1-norm of the tridiagonal matrix A. */
anorm = slangt_("1", n, &dl[1], &d__[1], &du[1]);
/* Compute the 1-norm of WORK, which is only guaranteed to be
upper Hessenberg. */
*resid = slanhs_("1", n, &work[work_offset], ldwork, &rwork[1])
;
/* Compute norm(L*U - A) / (norm(A) * EPS) */
if (anorm <= 0.f) {
if (*resid != 0.f) {
*resid = 1.f / eps;
}
} else {
*resid = *resid / anorm / eps;
}
return 0;
/* End of SGTT01 */
} /* sgtt01_ */
/* Subroutine */ int shseqr_(char *job, char *compz, integer *n, integer *ilo,
integer *ihi, real *h__, integer *ldh, real *wr, real *wi, real *z__,
integer *ldz, real *work, integer *lwork, integer *info, ftnlen
job_len, ftnlen compz_len)
{
/* System generated locals */
address a__1[2];
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3[2], i__4,
i__5;
real r__1, r__2;
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static integer i__, j, k, l;
static real s[225] /* was [15][15] */, v[16];
static integer i1, i2, ii, nh, nr, ns, nv;
static real vv[16];
static integer itn;
static real tau;
static integer its;
static real ulp, tst1;
static integer maxb;
static real absw;
static integer ierr;
static real unfl, temp, ovfl;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static integer itemp;
extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *,
ftnlen);
static logical initz, wantt;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
static logical wantz;
extern doublereal slapy2_(real *, real *);
extern /* Subroutine */ int slabad_(real *, real *);
extern doublereal slamch_(char *, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *,
real *);
extern integer isamax_(integer *, real *, integer *);
extern doublereal slanhs_(char *, integer *, real *, integer *, real *,
ftnlen);
extern /* Subroutine */ int slahqr_(logical *, logical *, integer *,
integer *, integer *, real *, integer *, real *, real *, integer *
, integer *, real *, integer *, integer *), slacpy_(char *,
integer *, integer *, real *, integer *, real *, integer *,
ftnlen), slaset_(char *, integer *, integer *, real *, real *,
real *, integer *, ftnlen), slarfx_(char *, integer *, integer *,
real *, real *, real *, integer *, real *, ftnlen);
static real smlnum;
static logical lquery;
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* June 30, 1999 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SHSEQR computes the eigenvalues of a real upper Hessenberg matrix H */
/* and, optionally, the matrices T and Z from the Schur decomposition */
/* H = Z T Z**T, where T is an upper quasi-triangular matrix (the Schur */
/* form), and Z is the orthogonal matrix of Schur vectors. */
/* Optionally Z may be postmultiplied into an input orthogonal matrix Q, */
/* so that this routine can give the Schur factorization of a matrix A */
/* which has been reduced to the Hessenberg form H by the orthogonal */
/* matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* = 'E': compute eigenvalues only; */
/* = 'S': compute eigenvalues and the Schur form T. */
/* COMPZ (input) CHARACTER*1 */
/* = 'N': no Schur vectors are computed; */
/* = 'I': Z is initialized to the unit matrix and the matrix Z */
/* of Schur vectors of H is returned; */
/* = 'V': Z must contain an orthogonal matrix Q on entry, and */
/* the product Q*Z is returned. */
/* N (input) INTEGER */
/* The order of the matrix H. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* It is assumed that H is already upper triangular in rows */
/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */
/* set by a previous call to SGEBAL, and then passed to SGEHRD */
/* when the matrix output by SGEBAL is reduced to Hessenberg */
/* form. Otherwise ILO and IHI should be set to 1 and N */
/* respectively. */
/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
/* H (input/output) REAL array, dimension (LDH,N) */
/* On entry, the upper Hessenberg matrix H. */
/* On exit, if JOB = 'S', H contains the upper quasi-triangular */
/* matrix T from the Schur decomposition (the Schur form); */
/* 2-by-2 diagonal blocks (corresponding to complex conjugate */
/* pairs of eigenvalues) are returned in standard form, with */
/* H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0. If JOB = 'E', */
/* the contents of H are unspecified on exit. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH >= max(1,N). */
/* WR (output) REAL array, dimension (N) */
/* WI (output) REAL array, dimension (N) */
/* The real and imaginary parts, respectively, of the computed */
/* eigenvalues. If two eigenvalues are computed as a complex */
/* conjugate pair, they are stored in consecutive elements of */
/* WR and WI, say the i-th and (i+1)th, with WI(i) > 0 and */
/* WI(i+1) < 0. If JOB = 'S', the eigenvalues are stored in the */
/* same order as on the diagonal of the Schur form returned in */
/* H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 */
/* diagonal block, WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and */
/* WI(i+1) = -WI(i). */
/* Z (input/output) REAL array, dimension (LDZ,N) */
/* If COMPZ = 'N': Z is not referenced. */
/* If COMPZ = 'I': on entry, Z need not be set, and on exit, Z */
/* contains the orthogonal matrix Z of the Schur vectors of H. */
/* If COMPZ = 'V': on entry Z must contain an N-by-N matrix Q, */
/* which is assumed to be equal to the unit matrix except for */
/* the submatrix Z(ILO:IHI,ILO:IHI); on exit Z contains Q*Z. */
/* Normally Q is the orthogonal matrix generated by SORGHR after */
/* the call to SGEHRD which formed the Hessenberg matrix H. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. */
/* LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise. */
/* WORK (workspace/output) REAL array, dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,N). */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, SHSEQR failed to compute all of the */
/* eigenvalues in a total of 30*(IHI-ILO+1) iterations; */
/* elements 1:ilo-1 and i+1:n of WR and WI contain those */
/* eigenvalues which have been successfully computed. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and test the input parameters */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--wr;
--wi;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
/* Function Body */
wantt = lsame_(job, "S", (ftnlen)1, (ftnlen)1);
initz = lsame_(compz, "I", (ftnlen)1, (ftnlen)1);
wantz = initz || lsame_(compz, "V", (ftnlen)1, (ftnlen)1);
*info = 0;
work[1] = (real) max(1,*n);
lquery = *lwork == -1;
if (! lsame_(job, "E", (ftnlen)1, (ftnlen)1) && ! wantt) {
*info = -1;
} else if (! lsame_(compz, "N", (ftnlen)1, (ftnlen)1) && ! wantz) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ilo < 1 || *ilo > max(1,*n)) {
*info = -4;
} else if (*ihi < min(*ilo,*n) || *ihi > *n) {
*info = -5;
} else if (*ldh < max(1,*n)) {
*info = -7;
} else if (*ldz < 1 || wantz && *ldz < max(1,*n)) {
*info = -11;
} else if (*lwork < max(1,*n) && ! lquery) {
*info = -13;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SHSEQR", &i__1, (ftnlen)6);
return 0;
} else if (lquery) {
return 0;
}
/* Initialize Z, if necessary */
if (initz) {
slaset_("Full", n, n, &c_b9, &c_b10, &z__[z_offset], ldz, (ftnlen)4);
}
/* Store the eigenvalues isolated by SGEBAL. */
i__1 = *ilo - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
wr[i__] = h__[i__ + i__ * h_dim1];
wi[i__] = 0.f;
/* L10: */
}
i__1 = *n;
for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
wr[i__] = h__[i__ + i__ * h_dim1];
wi[i__] = 0.f;
/* L20: */
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
if (*ilo == *ihi) {
wr[*ilo] = h__[*ilo + *ilo * h_dim1];
wi[*ilo] = 0.f;
return 0;
}
/* Set rows and columns ILO to IHI to zero below the first */
/* subdiagonal. */
i__1 = *ihi - 2;
for (j = *ilo; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 2; i__ <= i__2; ++i__) {
h__[i__ + j * h_dim1] = 0.f;
/* L30: */
}
/* L40: */
}
nh = *ihi - *ilo + 1;
/* Determine the order of the multi-shift QR algorithm to be used. */
/* Writing concatenation */
i__3[0] = 1, a__1[0] = job;
i__3[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
ns = ilaenv_(&c__4, "SHSEQR", ch__1, n, ilo, ihi, &c_n1, (ftnlen)6, (
ftnlen)2);
/* Writing concatenation */
i__3[0] = 1, a__1[0] = job;
i__3[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
maxb = ilaenv_(&c__8, "SHSEQR", ch__1, n, ilo, ihi, &c_n1, (ftnlen)6, (
ftnlen)2);
if (ns <= 2 || ns > nh || maxb >= nh) {
/* Use the standard double-shift algorithm */
slahqr_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &wi[
1], ilo, ihi, &z__[z_offset], ldz, info);
return 0;
}
maxb = max(3,maxb);
/* Computing MIN */
i__1 = min(ns,maxb);
ns = min(i__1,15);
/* Now 2 < NS <= MAXB < NH. */
/* Set machine-dependent constants for the stopping criterion. */
/* If norm(H) <= sqrt(OVFL), overflow should not occur. */
unfl = slamch_("Safe minimum", (ftnlen)12);
ovfl = 1.f / unfl;
slabad_(&unfl, &ovfl);
ulp = slamch_("Precision", (ftnlen)9);
smlnum = unfl * (nh / ulp);
/* I1 and I2 are the indices of the first row and last column of H */
/* to which transformations must be applied. If eigenvalues only are */
/* being computed, I1 and I2 are set inside the main loop. */
if (wantt) {
i1 = 1;
i2 = *n;
}
/* ITN is the total number of multiple-shift QR iterations allowed. */
itn = nh * 30;
/* The main loop begins here. I is the loop index and decreases from */
/* IHI to ILO in steps of at most MAXB. Each iteration of the loop */
/* works with the active submatrix in rows and columns L to I. */
/* Eigenvalues I+1 to IHI have already converged. Either L = ILO or */
/* H(L,L-1) is negligible so that the matrix splits. */
i__ = *ihi;
L50:
l = *ilo;
if (i__ < *ilo) {
goto L170;
}
/* Perform multiple-shift QR iterations on rows and columns ILO to I */
/* until a submatrix of order at most MAXB splits off at the bottom */
/* because a subdiagonal element has become negligible. */
i__1 = itn;
for (its = 0; its <= i__1; ++its) {
/* Look for a single small subdiagonal element. */
i__2 = l + 1;
for (k = i__; k >= i__2; --k) {
tst1 = (r__1 = h__[k - 1 + (k - 1) * h_dim1], dabs(r__1)) + (r__2
= h__[k + k * h_dim1], dabs(r__2));
if (tst1 == 0.f) {
i__4 = i__ - l + 1;
tst1 = slanhs_("1", &i__4, &h__[l + l * h_dim1], ldh, &work[1]
, (ftnlen)1);
}
/* Computing MAX */
r__2 = ulp * tst1;
if ((r__1 = h__[k + (k - 1) * h_dim1], dabs(r__1)) <= dmax(r__2,
smlnum)) {
goto L70;
}
/* L60: */
}
L70:
l = k;
if (l > *ilo) {
/* H(L,L-1) is negligible. */
h__[l + (l - 1) * h_dim1] = 0.f;
}
/* Exit from loop if a submatrix of order <= MAXB has split off. */
if (l >= i__ - maxb + 1) {
goto L160;
}
/* Now the active submatrix is in rows and columns L to I. If */
/* eigenvalues only are being computed, only the active submatrix */
/* need be transformed. */
if (! wantt) {
i1 = l;
i2 = i__;
}
if (its == 20 || its == 30) {
/* Exceptional shifts. */
i__2 = i__;
for (ii = i__ - ns + 1; ii <= i__2; ++ii) {
wr[ii] = ((r__1 = h__[ii + (ii - 1) * h_dim1], dabs(r__1)) + (
r__2 = h__[ii + ii * h_dim1], dabs(r__2))) * 1.5f;
wi[ii] = 0.f;
/* L80: */
}
} else {
/* Use eigenvalues of trailing submatrix of order NS as shifts. */
slacpy_("Full", &ns, &ns, &h__[i__ - ns + 1 + (i__ - ns + 1) *
h_dim1], ldh, s, &c__15, (ftnlen)4);
slahqr_(&c_false, &c_false, &ns, &c__1, &ns, s, &c__15, &wr[i__ -
ns + 1], &wi[i__ - ns + 1], &c__1, &ns, &z__[z_offset],
ldz, &ierr);
if (ierr > 0) {
/* If SLAHQR failed to compute all NS eigenvalues, use the */
/* unconverged diagonal elements as the remaining shifts. */
i__2 = ierr;
for (ii = 1; ii <= i__2; ++ii) {
wr[i__ - ns + ii] = s[ii + ii * 15 - 16];
wi[i__ - ns + ii] = 0.f;
/* L90: */
}
}
}
/* Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns)) */
/* where G is the Hessenberg submatrix H(L:I,L:I) and w is */
/* the vector of shifts (stored in WR and WI). The result is */
/* stored in the local array V. */
v[0] = 1.f;
i__2 = ns + 1;
for (ii = 2; ii <= i__2; ++ii) {
v[ii - 1] = 0.f;
/* L100: */
}
nv = 1;
i__2 = i__;
for (j = i__ - ns + 1; j <= i__2; ++j) {
if (wi[j] >= 0.f) {
if (wi[j] == 0.f) {
/* real shift */
i__4 = nv + 1;
scopy_(&i__4, v, &c__1, vv, &c__1);
i__4 = nv + 1;
r__1 = -wr[j];
sgemv_("No transpose", &i__4, &nv, &c_b10, &h__[l + l *
h_dim1], ldh, vv, &c__1, &r__1, v, &c__1, (ftnlen)
12);
++nv;
} else if (wi[j] > 0.f) {
/* complex conjugate pair of shifts */
i__4 = nv + 1;
scopy_(&i__4, v, &c__1, vv, &c__1);
i__4 = nv + 1;
r__1 = wr[j] * -2.f;
sgemv_("No transpose", &i__4, &nv, &c_b10, &h__[l + l *
h_dim1], ldh, v, &c__1, &r__1, vv, &c__1, (ftnlen)
12);
i__4 = nv + 1;
itemp = isamax_(&i__4, vv, &c__1);
/* Computing MAX */
r__2 = (r__1 = vv[itemp - 1], dabs(r__1));
temp = 1.f / dmax(r__2,smlnum);
i__4 = nv + 1;
sscal_(&i__4, &temp, vv, &c__1);
absw = slapy2_(&wr[j], &wi[j]);
temp = temp * absw * absw;
i__4 = nv + 2;
i__5 = nv + 1;
sgemv_("No transpose", &i__4, &i__5, &c_b10, &h__[l + l *
h_dim1], ldh, vv, &c__1, &temp, v, &c__1, (ftnlen)
12);
nv += 2;
}
/* Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero, */
/* reset it to the unit vector. */
itemp = isamax_(&nv, v, &c__1);
temp = (r__1 = v[itemp - 1], dabs(r__1));
if (temp == 0.f) {
v[0] = 1.f;
i__4 = nv;
for (ii = 2; ii <= i__4; ++ii) {
v[ii - 1] = 0.f;
/* L110: */
}
} else {
temp = dmax(temp,smlnum);
r__1 = 1.f / temp;
sscal_(&nv, &r__1, v, &c__1);
}
}
/* L120: */
}
/* Multiple-shift QR step */
i__2 = i__ - 1;
for (k = l; k <= i__2; ++k) {
/* The first iteration of this loop determines a reflection G */
/* from the vector V and applies it from left and right to H, */
/* thus creating a nonzero bulge below the subdiagonal. */
/* Each subsequent iteration determines a reflection G to */
/* restore the Hessenberg form in the (K-1)th column, and thus */
/* chases the bulge one step toward the bottom of the active */
/* submatrix. NR is the order of G. */
/* Computing MIN */
i__4 = ns + 1, i__5 = i__ - k + 1;
nr = min(i__4,i__5);
if (k > l) {
scopy_(&nr, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1);
}
slarfg_(&nr, v, &v[1], &c__1, &tau);
if (k > l) {
h__[k + (k - 1) * h_dim1] = v[0];
i__4 = i__;
for (ii = k + 1; ii <= i__4; ++ii) {
h__[ii + (k - 1) * h_dim1] = 0.f;
/* L130: */
}
}
v[0] = 1.f;
/* Apply G from the left to transform the rows of the matrix in */
/* columns K to I2. */
i__4 = i2 - k + 1;
slarfx_("Left", &nr, &i__4, v, &tau, &h__[k + k * h_dim1], ldh, &
work[1], (ftnlen)4);
/* Apply G from the right to transform the columns of the */
/* matrix in rows I1 to min(K+NR,I). */
/* Computing MIN */
i__5 = k + nr;
i__4 = min(i__5,i__) - i1 + 1;
slarfx_("Right", &i__4, &nr, v, &tau, &h__[i1 + k * h_dim1], ldh,
&work[1], (ftnlen)5);
if (wantz) {
/* Accumulate transformations in the matrix Z */
slarfx_("Right", &nh, &nr, v, &tau, &z__[*ilo + k * z_dim1],
ldz, &work[1], (ftnlen)5);
}
/* L140: */
}
/* L150: */
}
/* Failure to converge in remaining number of iterations */
*info = i__;
return 0;
L160:
/* A submatrix of order <= MAXB in rows and columns L to I has split */
/* off. Use the double-shift QR algorithm to handle it. */
slahqr_(&wantt, &wantz, n, &l, &i__, &h__[h_offset], ldh, &wr[1], &wi[1],
ilo, ihi, &z__[z_offset], ldz, info);
if (*info > 0) {
return 0;
}
/* Decrement number of remaining iterations, and return to start of */
/* the main loop with a new value of I. */
itn -= its;
i__ = l - 1;
goto L50;
L170:
work[1] = (real) max(1,*n);
return 0;
/* End of SHSEQR */
} /* shseqr_ */
/* Subroutine */ int slaqrb_(logical *wantt, integer *n, integer *ilo,
integer *ihi, real *h__, integer *ldh, real *wr, real *wi, real *z__,
integer *info)
{
/* System generated locals */
integer h_dim1, h_offset, i__1, i__2, i__3, i__4;
real r__1, r__2;
/* Local variables */
static integer i__, j, k, l, m;
static real s, v[3];
static integer i1, i2;
static real t1, t2, t3, v1, v2, v3, h00, h10, h11, h12, h21, h22, h33,
h44;
static integer nh;
static real cs;
static integer nr;
static real sn, h33s, h44s;
static integer itn, its;
static real ulp, sum, tst1, h43h34, unfl, ovfl, work[1];
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *), scopy_(integer *, real *, integer *,
real *, integer *), slanv2_(real *, real *, real *, real *, real *
, real *, real *, real *, real *, real *), slabad_(real *, real *)
;
extern doublereal slamch_(char *, ftnlen);
extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *,
real *);
extern doublereal slanhs_(char *, integer *, real *, integer *, real *,
ftnlen);
static real smlnum;
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %------------------------% */
/* | Local Scalars & Arrays | */
/* %------------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--wr;
--wi;
--z__;
/* Function Body */
*info = 0;
/* %--------------------------% */
/* | Quick return if possible | */
/* %--------------------------% */
if (*n == 0) {
return 0;
}
if (*ilo == *ihi) {
wr[*ilo] = h__[*ilo + *ilo * h_dim1];
wi[*ilo] = 0.f;
return 0;
}
/* %---------------------------------------------% */
/* | Initialize the vector of last components of | */
/* | the Schur vectors for accumulation. | */
/* %---------------------------------------------% */
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
z__[j] = 0.f;
/* L5: */
}
z__[*n] = 1.f;
nh = *ihi - *ilo + 1;
/* %-------------------------------------------------------------% */
/* | Set machine-dependent constants for the stopping criterion. | */
/* | If norm(H) <= sqrt(OVFL), overflow should not occur. | */
/* %-------------------------------------------------------------% */
unfl = slamch_("safe minimum", (ftnlen)12);
ovfl = 1.f / unfl;
slabad_(&unfl, &ovfl);
ulp = slamch_("precision", (ftnlen)9);
smlnum = unfl * (nh / ulp);
/* %---------------------------------------------------------------% */
/* | I1 and I2 are the indices of the first row and last column | */
/* | of H to which transformations must be applied. If eigenvalues | */
/* | only are computed, I1 and I2 are set inside the main loop. | */
/* | Zero out H(J+2,J) = ZERO for J=1:N if WANTT = .TRUE. | */
/* | else H(J+2,J) for J=ILO:IHI-ILO-1 if WANTT = .FALSE. | */
/* %---------------------------------------------------------------% */
if (*wantt) {
i1 = 1;
i2 = *n;
i__1 = i2 - 2;
for (i__ = 1; i__ <= i__1; ++i__) {
h__[i1 + i__ + 1 + i__ * h_dim1] = 0.f;
/* L8: */
}
} else {
i__1 = *ihi - *ilo - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
h__[*ilo + i__ + 1 + (*ilo + i__ - 1) * h_dim1] = 0.f;
/* L9: */
}
}
/* %---------------------------------------------------% */
/* | ITN is the total number of QR iterations allowed. | */
/* %---------------------------------------------------% */
itn = nh * 30;
/* ------------------------------------------------------------------ */
/* The main loop begins here. I is the loop index and decreases from */
/* IHI to ILO in steps of 1 or 2. Each iteration of the loop works */
/* with the active submatrix in rows and columns L to I. */
/* Eigenvalues I+1 to IHI have already converged. Either L = ILO or */
/* H(L,L-1) is negligible so that the matrix splits. */
/* ------------------------------------------------------------------ */
i__ = *ihi;
L10:
l = *ilo;
if (i__ < *ilo) {
goto L150;
}
/* %--------------------------------------------------------------% */
/* | Perform QR iterations on rows and columns ILO to I until a | */
/* | submatrix of order 1 or 2 splits off at the bottom because a | */
/* | subdiagonal element has become negligible. | */
/* %--------------------------------------------------------------% */
i__1 = itn;
for (its = 0; its <= i__1; ++its) {
/* %----------------------------------------------% */
/* | Look for a single small subdiagonal element. | */
/* %----------------------------------------------% */
i__2 = l + 1;
for (k = i__; k >= i__2; --k) {
tst1 = (r__1 = h__[k - 1 + (k - 1) * h_dim1], dabs(r__1)) + (r__2
= h__[k + k * h_dim1], dabs(r__2));
if (tst1 == 0.f) {
i__3 = i__ - l + 1;
tst1 = slanhs_("1", &i__3, &h__[l + l * h_dim1], ldh, work, (
ftnlen)1);
}
/* Computing MAX */
r__2 = ulp * tst1;
if ((r__1 = h__[k + (k - 1) * h_dim1], dabs(r__1)) <= dmax(r__2,
smlnum)) {
goto L30;
}
/* L20: */
}
L30:
l = k;
if (l > *ilo) {
/* %------------------------% */
/* | H(L,L-1) is negligible | */
/* %------------------------% */
h__[l + (l - 1) * h_dim1] = 0.f;
}
/* %-------------------------------------------------------------% */
/* | Exit from loop if a submatrix of order 1 or 2 has split off | */
/* %-------------------------------------------------------------% */
if (l >= i__ - 1) {
goto L140;
}
/* %---------------------------------------------------------% */
/* | Now the active submatrix is in rows and columns L to I. | */
/* | If eigenvalues only are being computed, only the active | */
/* | submatrix need be transformed. | */
/* %---------------------------------------------------------% */
if (! (*wantt)) {
i1 = l;
i2 = i__;
}
if (its == 10 || its == 20) {
/* %-------------------% */
/* | Exceptional shift | */
/* %-------------------% */
s = (r__1 = h__[i__ + (i__ - 1) * h_dim1], dabs(r__1)) + (r__2 =
h__[i__ - 1 + (i__ - 2) * h_dim1], dabs(r__2));
h44 = s * .75f;
h33 = h44;
h43h34 = s * -.4375f * s;
} else {
/* %-----------------------------------------% */
/* | Prepare to use Wilkinson's double shift | */
/* %-----------------------------------------% */
h44 = h__[i__ + i__ * h_dim1];
h33 = h__[i__ - 1 + (i__ - 1) * h_dim1];
h43h34 = h__[i__ + (i__ - 1) * h_dim1] * h__[i__ - 1 + i__ *
h_dim1];
}
/* %-----------------------------------------------------% */
/* | Look for two consecutive small subdiagonal elements | */
/* %-----------------------------------------------------% */
i__2 = l;
for (m = i__ - 2; m >= i__2; --m) {
/* %---------------------------------------------------------% */
/* | Determine the effect of starting the double-shift QR | */
/* | iteration at row M, and see if this would make H(M,M-1) | */
/* | negligible. | */
/* %---------------------------------------------------------% */
h11 = h__[m + m * h_dim1];
h22 = h__[m + 1 + (m + 1) * h_dim1];
h21 = h__[m + 1 + m * h_dim1];
h12 = h__[m + (m + 1) * h_dim1];
h44s = h44 - h11;
h33s = h33 - h11;
v1 = (h33s * h44s - h43h34) / h21 + h12;
v2 = h22 - h11 - h33s - h44s;
v3 = h__[m + 2 + (m + 1) * h_dim1];
s = dabs(v1) + dabs(v2) + dabs(v3);
v1 /= s;
v2 /= s;
v3 /= s;
v[0] = v1;
v[1] = v2;
v[2] = v3;
if (m == l) {
goto L50;
}
h00 = h__[m - 1 + (m - 1) * h_dim1];
h10 = h__[m + (m - 1) * h_dim1];
tst1 = dabs(v1) * (dabs(h00) + dabs(h11) + dabs(h22));
if (dabs(h10) * (dabs(v2) + dabs(v3)) <= ulp * tst1) {
goto L50;
}
/* L40: */
}
L50:
/* %----------------------% */
/* | Double-shift QR step | */
/* %----------------------% */
i__2 = i__ - 1;
for (k = m; k <= i__2; ++k) {
/* ------------------------------------------------------------ */
/* The first iteration of this loop determines a reflection G */
/* from the vector V and applies it from left and right to H, */
/* thus creating a nonzero bulge below the subdiagonal. */
/* Each subsequent iteration determines a reflection G to */
/* restore the Hessenberg form in the (K-1)th column, and thus */
/* chases the bulge one step toward the bottom of the active */
/* submatrix. NR is the order of G. */
/* ------------------------------------------------------------ */
/* Computing MIN */
i__3 = 3, i__4 = i__ - k + 1;
nr = min(i__3,i__4);
if (k > m) {
scopy_(&nr, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1);
}
slarfg_(&nr, v, &v[1], &c__1, &t1);
if (k > m) {
h__[k + (k - 1) * h_dim1] = v[0];
h__[k + 1 + (k - 1) * h_dim1] = 0.f;
if (k < i__ - 1) {
h__[k + 2 + (k - 1) * h_dim1] = 0.f;
}
} else if (m > l) {
h__[k + (k - 1) * h_dim1] = -h__[k + (k - 1) * h_dim1];
}
v2 = v[1];
t2 = t1 * v2;
if (nr == 3) {
v3 = v[2];
t3 = t1 * v3;
/* %------------------------------------------------% */
/* | Apply G from the left to transform the rows of | */
/* | the matrix in columns K to I2. | */
/* %------------------------------------------------% */
i__3 = i2;
for (j = k; j <= i__3; ++j) {
sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1]
+ v3 * h__[k + 2 + j * h_dim1];
h__[k + j * h_dim1] -= sum * t1;
h__[k + 1 + j * h_dim1] -= sum * t2;
h__[k + 2 + j * h_dim1] -= sum * t3;
/* L60: */
}
/* %----------------------------------------------------% */
/* | Apply G from the right to transform the columns of | */
/* | the matrix in rows I1 to min(K+3,I). | */
/* %----------------------------------------------------% */
/* Computing MIN */
i__4 = k + 3;
i__3 = min(i__4,i__);
for (j = i1; j <= i__3; ++j) {
sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1]
+ v3 * h__[j + (k + 2) * h_dim1];
h__[j + k * h_dim1] -= sum * t1;
h__[j + (k + 1) * h_dim1] -= sum * t2;
h__[j + (k + 2) * h_dim1] -= sum * t3;
/* L70: */
}
/* %----------------------------------% */
/* | Accumulate transformations for Z | */
/* %----------------------------------% */
sum = z__[k] + v2 * z__[k + 1] + v3 * z__[k + 2];
z__[k] -= sum * t1;
z__[k + 1] -= sum * t2;
z__[k + 2] -= sum * t3;
} else if (nr == 2) {
/* %------------------------------------------------% */
/* | Apply G from the left to transform the rows of | */
/* | the matrix in columns K to I2. | */
/* %------------------------------------------------% */
i__3 = i2;
for (j = k; j <= i__3; ++j) {
sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1];
h__[k + j * h_dim1] -= sum * t1;
h__[k + 1 + j * h_dim1] -= sum * t2;
/* L90: */
}
/* %----------------------------------------------------% */
/* | Apply G from the right to transform the columns of | */
/* | the matrix in rows I1 to min(K+3,I). | */
/* %----------------------------------------------------% */
i__3 = i__;
for (j = i1; j <= i__3; ++j) {
sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1]
;
h__[j + k * h_dim1] -= sum * t1;
h__[j + (k + 1) * h_dim1] -= sum * t2;
/* L100: */
}
/* %----------------------------------% */
/* | Accumulate transformations for Z | */
/* %----------------------------------% */
sum = z__[k] + v2 * z__[k + 1];
z__[k] -= sum * t1;
z__[k + 1] -= sum * t2;
}
/* L120: */
}
/* L130: */
}
/* %-------------------------------------------------------% */
/* | Failure to converge in remaining number of iterations | */
/* %-------------------------------------------------------% */
*info = i__;
return 0;
L140:
if (l == i__) {
/* %------------------------------------------------------% */
/* | H(I,I-1) is negligible: one eigenvalue has converged | */
/* %------------------------------------------------------% */
wr[i__] = h__[i__ + i__ * h_dim1];
wi[i__] = 0.f;
} else if (l == i__ - 1) {
/* %--------------------------------------------------------% */
/* | H(I-1,I-2) is negligible; | */
/* | a pair of eigenvalues have converged. | */
/* | | */
/* | Transform the 2-by-2 submatrix to standard Schur form, | */
/* | and compute and store the eigenvalues. | */
/* %--------------------------------------------------------% */
slanv2_(&h__[i__ - 1 + (i__ - 1) * h_dim1], &h__[i__ - 1 + i__ *
h_dim1], &h__[i__ + (i__ - 1) * h_dim1], &h__[i__ + i__ *
h_dim1], &wr[i__ - 1], &wi[i__ - 1], &wr[i__], &wi[i__], &cs,
&sn);
if (*wantt) {
/* %-----------------------------------------------------% */
/* | Apply the transformation to the rest of H and to Z, | */
/* | as required. | */
/* %-----------------------------------------------------% */
if (i2 > i__) {
i__1 = i2 - i__;
srot_(&i__1, &h__[i__ - 1 + (i__ + 1) * h_dim1], ldh, &h__[
i__ + (i__ + 1) * h_dim1], ldh, &cs, &sn);
}
i__1 = i__ - i1 - 1;
srot_(&i__1, &h__[i1 + (i__ - 1) * h_dim1], &c__1, &h__[i1 + i__ *
h_dim1], &c__1, &cs, &sn);
sum = cs * z__[i__ - 1] + sn * z__[i__];
z__[i__] = cs * z__[i__] - sn * z__[i__ - 1];
z__[i__ - 1] = sum;
}
}
/* %---------------------------------------------------------% */
/* | Decrement number of remaining iterations, and return to | */
/* | start of the main loop with new value of I. | */
/* %---------------------------------------------------------% */
itn -= its;
i__ = l - 1;
goto L10;
L150:
return 0;
/* %---------------% */
/* | End of slaqrb | */
/* %---------------% */
} /* slaqrb_ */
/* Subroutine */ int snapps_(integer *n, integer *kev, integer *np, real *
shiftr, real *shifti, real *v, integer *ldv, real *h__, integer *ldh,
real *resid, real *q, integer *ldq, real *workl, real *workd)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer h_dim1, h_offset, v_dim1, v_offset, q_dim1, q_offset, i__1, i__2,
i__3, i__4;
real r__1, r__2;
/* Local variables */
static real c__, f, g;
static integer i__, j;
static real r__, s, t, u[3], t0, t1, h11, h12, h21, h22, h32;
static integer jj, ir, nr;
static real tau, ulp, tst1;
static integer iend;
static real unfl, ovfl;
static logical cconj;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
slarf_(char *, integer *, integer *, real *, integer *, real *,
real *, integer *, real *, ftnlen), sgemv_(char *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *, ftnlen), scopy_(integer *, real *, integer *,
real *, integer *), saxpy_(integer *, real *, real *, integer *,
real *, integer *), ivout_(integer *, integer *, integer *,
integer *, char *, ftnlen), smout_(integer *, integer *, integer *
, real *, integer *, integer *, char *, ftnlen), svout_(integer *,
integer *, real *, integer *, char *, ftnlen);
extern doublereal slapy2_(real *, real *);
extern /* Subroutine */ int slabad_(real *, real *);
extern doublereal slamch_(char *, ftnlen);
static real sigmai;
extern /* Subroutine */ int second_(real *);
static real sigmar;
static integer istart, kplusp, msglvl;
static real smlnum;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *, ftnlen), slarfg_(integer *, real *,
real *, integer *, real *), slaset_(char *, integer *, integer *,
real *, real *, real *, integer *, ftnlen), slartg_(real *, real *
, real *, real *, real *);
extern doublereal slanhs_(char *, integer *, real *, integer *, real *,
ftnlen);
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %------------------------% */
/* | Local Scalars & Arrays | */
/* %------------------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %----------------------% */
/* | Intrinsics Functions | */
/* %----------------------% */
/* %----------------% */
/* | Data statments | */
/* %----------------% */
/* Parameter adjustments */
--workd;
--resid;
--workl;
--shifti;
--shiftr;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
/* Function Body */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
if (first) {
/* %-----------------------------------------------% */
/* | Set machine-dependent constants for the | */
/* | stopping criterion. If norm(H) <= sqrt(OVFL), | */
/* | overflow should not occur. | */
/* | REFERENCE: LAPACK subroutine slahqr | */
/* %-----------------------------------------------% */
unfl = slamch_("safe minimum", (ftnlen)12);
ovfl = 1.f / unfl;
slabad_(&unfl, &ovfl);
ulp = slamch_("precision", (ftnlen)9);
smlnum = unfl * (*n / ulp);
first = FALSE_;
}
/* %-------------------------------% */
/* | Initialize timing statistics | */
/* | & message level for debugging | */
/* %-------------------------------% */
second_(&t0);
msglvl = debug_1.mnapps;
kplusp = *kev + *np;
/* %--------------------------------------------% */
/* | Initialize Q to the identity to accumulate | */
/* | the rotations and reflections | */
/* %--------------------------------------------% */
slaset_("All", &kplusp, &kplusp, &c_b5, &c_b6, &q[q_offset], ldq, (ftnlen)
3);
/* %----------------------------------------------% */
/* | Quick return if there are no shifts to apply | */
/* %----------------------------------------------% */
if (*np == 0) {
goto L9000;
}
/* %----------------------------------------------% */
/* | Chase the bulge with the application of each | */
/* | implicit shift. Each shift is applied to the | */
/* | whole matrix including each block. | */
/* %----------------------------------------------% */
cconj = FALSE_;
i__1 = *np;
for (jj = 1; jj <= i__1; ++jj) {
sigmar = shiftr[jj];
sigmai = shifti[jj];
if (msglvl > 2) {
ivout_(&debug_1.logfil, &c__1, &jj, &debug_1.ndigit, "_napps: sh"
"ift number.", (ftnlen)21);
svout_(&debug_1.logfil, &c__1, &sigmar, &debug_1.ndigit, "_napps"
": The real part of the shift ", (ftnlen)35);
svout_(&debug_1.logfil, &c__1, &sigmai, &debug_1.ndigit, "_napps"
": The imaginary part of the shift ", (ftnlen)40);
}
/* %-------------------------------------------------% */
/* | The following set of conditionals is necessary | */
/* | in order that complex conjugate pairs of shifts | */
/* | are applied together or not at all. | */
/* %-------------------------------------------------% */
if (cconj) {
/* %-----------------------------------------% */
/* | cconj = .true. means the previous shift | */
/* | had non-zero imaginary part. | */
/* %-----------------------------------------% */
cconj = FALSE_;
goto L110;
} else if (jj < *np && dabs(sigmai) > 0.f) {
/* %------------------------------------% */
/* | Start of a complex conjugate pair. | */
/* %------------------------------------% */
cconj = TRUE_;
} else if (jj == *np && dabs(sigmai) > 0.f) {
/* %----------------------------------------------% */
/* | The last shift has a nonzero imaginary part. | */
/* | Don't apply it; thus the order of the | */
/* | compressed H is order KEV+1 since only np-1 | */
/* | were applied. | */
/* %----------------------------------------------% */
++(*kev);
goto L110;
}
istart = 1;
L20:
/* %--------------------------------------------------% */
/* | if sigmai = 0 then | */
/* | Apply the jj-th shift ... | */
/* | else | */
/* | Apply the jj-th and (jj+1)-th together ... | */
/* | (Note that jj < np at this point in the code) | */
/* | end | */
/* | to the current block of H. The next do loop | */
/* | determines the current block ; | */
/* %--------------------------------------------------% */
i__2 = kplusp - 1;
for (i__ = istart; i__ <= i__2; ++i__) {
/* %----------------------------------------% */
/* | Check for splitting and deflation. Use | */
/* | a standard test as in the QR algorithm | */
/* | REFERENCE: LAPACK subroutine slahqr | */
/* %----------------------------------------% */
tst1 = (r__1 = h__[i__ + i__ * h_dim1], dabs(r__1)) + (r__2 = h__[
i__ + 1 + (i__ + 1) * h_dim1], dabs(r__2));
if (tst1 == 0.f) {
i__3 = kplusp - jj + 1;
tst1 = slanhs_("1", &i__3, &h__[h_offset], ldh, &workl[1], (
ftnlen)1);
}
/* Computing MAX */
r__2 = ulp * tst1;
if ((r__1 = h__[i__ + 1 + i__ * h_dim1], dabs(r__1)) <= dmax(r__2,
smlnum)) {
if (msglvl > 0) {
ivout_(&debug_1.logfil, &c__1, &i__, &debug_1.ndigit,
"_napps: matrix splitting at row/column no.", (
ftnlen)42);
ivout_(&debug_1.logfil, &c__1, &jj, &debug_1.ndigit,
"_napps: matrix splitting with shift number.", (
ftnlen)43);
svout_(&debug_1.logfil, &c__1, &h__[i__ + 1 + i__ *
h_dim1], &debug_1.ndigit, "_napps: off diagonal "
"element.", (ftnlen)29);
}
iend = i__;
h__[i__ + 1 + i__ * h_dim1] = 0.f;
goto L40;
}
/* L30: */
}
iend = kplusp;
L40:
if (msglvl > 2) {
ivout_(&debug_1.logfil, &c__1, &istart, &debug_1.ndigit, "_napps"
": Start of current block ", (ftnlen)31);
ivout_(&debug_1.logfil, &c__1, &iend, &debug_1.ndigit, "_napps: "
"End of current block ", (ftnlen)29);
}
/* %------------------------------------------------% */
/* | No reason to apply a shift to block of order 1 | */
/* %------------------------------------------------% */
if (istart == iend) {
goto L100;
}
/* %------------------------------------------------------% */
/* | If istart + 1 = iend then no reason to apply a | */
/* | complex conjugate pair of shifts on a 2 by 2 matrix. | */
/* %------------------------------------------------------% */
if (istart + 1 == iend && dabs(sigmai) > 0.f) {
goto L100;
}
h11 = h__[istart + istart * h_dim1];
h21 = h__[istart + 1 + istart * h_dim1];
if (dabs(sigmai) <= 0.f) {
/* %---------------------------------------------% */
/* | Real-valued shift ==> apply single shift QR | */
/* %---------------------------------------------% */
f = h11 - sigmar;
g = h21;
i__2 = iend - 1;
for (i__ = istart; i__ <= i__2; ++i__) {
/* %-----------------------------------------------------% */
/* | Contruct the plane rotation G to zero out the bulge | */
/* %-----------------------------------------------------% */
slartg_(&f, &g, &c__, &s, &r__);
if (i__ > istart) {
/* %-------------------------------------------% */
/* | The following ensures that h(1:iend-1,1), | */
/* | the first iend-2 off diagonal of elements | */
/* | H, remain non negative. | */
/* %-------------------------------------------% */
if (r__ < 0.f) {
r__ = -r__;
c__ = -c__;
s = -s;
}
h__[i__ + (i__ - 1) * h_dim1] = r__;
h__[i__ + 1 + (i__ - 1) * h_dim1] = 0.f;
}
/* %---------------------------------------------% */
/* | Apply rotation to the left of H; H <- G'*H | */
/* %---------------------------------------------% */
i__3 = kplusp;
for (j = i__; j <= i__3; ++j) {
t = c__ * h__[i__ + j * h_dim1] + s * h__[i__ + 1 + j *
h_dim1];
h__[i__ + 1 + j * h_dim1] = -s * h__[i__ + j * h_dim1] +
c__ * h__[i__ + 1 + j * h_dim1];
h__[i__ + j * h_dim1] = t;
/* L50: */
}
/* %---------------------------------------------% */
/* | Apply rotation to the right of H; H <- H*G | */
/* %---------------------------------------------% */
/* Computing MIN */
i__4 = i__ + 2;
i__3 = min(i__4,iend);
for (j = 1; j <= i__3; ++j) {
t = c__ * h__[j + i__ * h_dim1] + s * h__[j + (i__ + 1) *
h_dim1];
h__[j + (i__ + 1) * h_dim1] = -s * h__[j + i__ * h_dim1]
+ c__ * h__[j + (i__ + 1) * h_dim1];
h__[j + i__ * h_dim1] = t;
/* L60: */
}
/* %----------------------------------------------------% */
/* | Accumulate the rotation in the matrix Q; Q <- Q*G | */
/* %----------------------------------------------------% */
/* Computing MIN */
i__4 = i__ + jj;
i__3 = min(i__4,kplusp);
for (j = 1; j <= i__3; ++j) {
t = c__ * q[j + i__ * q_dim1] + s * q[j + (i__ + 1) *
q_dim1];
q[j + (i__ + 1) * q_dim1] = -s * q[j + i__ * q_dim1] +
c__ * q[j + (i__ + 1) * q_dim1];
q[j + i__ * q_dim1] = t;
/* L70: */
}
/* %---------------------------% */
/* | Prepare for next rotation | */
/* %---------------------------% */
if (i__ < iend - 1) {
f = h__[i__ + 1 + i__ * h_dim1];
g = h__[i__ + 2 + i__ * h_dim1];
}
/* L80: */
}
/* %-----------------------------------% */
/* | Finished applying the real shift. | */
/* %-----------------------------------% */
} else {
/* %----------------------------------------------------% */
/* | Complex conjugate shifts ==> apply double shift QR | */
/* %----------------------------------------------------% */
h12 = h__[istart + (istart + 1) * h_dim1];
h22 = h__[istart + 1 + (istart + 1) * h_dim1];
h32 = h__[istart + 2 + (istart + 1) * h_dim1];
/* %---------------------------------------------------------% */
/* | Compute 1st column of (H - shift*I)*(H - conj(shift)*I) | */
/* %---------------------------------------------------------% */
s = sigmar * 2.f;
t = slapy2_(&sigmar, &sigmai);
u[0] = (h11 * (h11 - s) + t * t) / h21 + h12;
u[1] = h11 + h22 - s;
u[2] = h32;
i__2 = iend - 1;
for (i__ = istart; i__ <= i__2; ++i__) {
/* Computing MIN */
i__3 = 3, i__4 = iend - i__ + 1;
nr = min(i__3,i__4);
/* %-----------------------------------------------------% */
/* | Construct Householder reflector G to zero out u(1). | */
/* | G is of the form I - tau*( 1 u )' * ( 1 u' ). | */
/* %-----------------------------------------------------% */
slarfg_(&nr, u, &u[1], &c__1, &tau);
if (i__ > istart) {
h__[i__ + (i__ - 1) * h_dim1] = u[0];
h__[i__ + 1 + (i__ - 1) * h_dim1] = 0.f;
if (i__ < iend - 1) {
h__[i__ + 2 + (i__ - 1) * h_dim1] = 0.f;
}
}
u[0] = 1.f;
/* %--------------------------------------% */
/* | Apply the reflector to the left of H | */
/* %--------------------------------------% */
i__3 = kplusp - i__ + 1;
slarf_("Left", &nr, &i__3, u, &c__1, &tau, &h__[i__ + i__ *
h_dim1], ldh, &workl[1], (ftnlen)4);
/* %---------------------------------------% */
/* | Apply the reflector to the right of H | */
/* %---------------------------------------% */
/* Computing MIN */
i__3 = i__ + 3;
ir = min(i__3,iend);
slarf_("Right", &ir, &nr, u, &c__1, &tau, &h__[i__ * h_dim1 +
1], ldh, &workl[1], (ftnlen)5);
/* %-----------------------------------------------------% */
/* | Accumulate the reflector in the matrix Q; Q <- Q*G | */
/* %-----------------------------------------------------% */
slarf_("Right", &kplusp, &nr, u, &c__1, &tau, &q[i__ * q_dim1
+ 1], ldq, &workl[1], (ftnlen)5);
/* %----------------------------% */
/* | Prepare for next reflector | */
/* %----------------------------% */
if (i__ < iend - 1) {
u[0] = h__[i__ + 1 + i__ * h_dim1];
u[1] = h__[i__ + 2 + i__ * h_dim1];
if (i__ < iend - 2) {
u[2] = h__[i__ + 3 + i__ * h_dim1];
}
}
/* L90: */
}
/* %--------------------------------------------% */
/* | Finished applying a complex pair of shifts | */
/* | to the current block | */
/* %--------------------------------------------% */
}
L100:
/* %---------------------------------------------------------% */
/* | Apply the same shift to the next block if there is any. | */
/* %---------------------------------------------------------% */
istart = iend + 1;
if (iend < kplusp) {
goto L20;
}
/* %---------------------------------------------% */
/* | Loop back to the top to get the next shift. | */
/* %---------------------------------------------% */
L110:
;
}
/* %--------------------------------------------------% */
/* | Perform a similarity transformation that makes | */
/* | sure that H will have non negative sub diagonals | */
/* %--------------------------------------------------% */
i__1 = *kev;
for (j = 1; j <= i__1; ++j) {
if (h__[j + 1 + j * h_dim1] < 0.f) {
i__2 = kplusp - j + 1;
sscal_(&i__2, &c_b43, &h__[j + 1 + j * h_dim1], ldh);
/* Computing MIN */
i__3 = j + 2;
i__2 = min(i__3,kplusp);
sscal_(&i__2, &c_b43, &h__[(j + 1) * h_dim1 + 1], &c__1);
/* Computing MIN */
i__3 = j + *np + 1;
i__2 = min(i__3,kplusp);
sscal_(&i__2, &c_b43, &q[(j + 1) * q_dim1 + 1], &c__1);
}
/* L120: */
}
i__1 = *kev;
for (i__ = 1; i__ <= i__1; ++i__) {
/* %--------------------------------------------% */
/* | Final check for splitting and deflation. | */
/* | Use a standard test as in the QR algorithm | */
/* | REFERENCE: LAPACK subroutine slahqr | */
/* %--------------------------------------------% */
tst1 = (r__1 = h__[i__ + i__ * h_dim1], dabs(r__1)) + (r__2 = h__[i__
+ 1 + (i__ + 1) * h_dim1], dabs(r__2));
if (tst1 == 0.f) {
tst1 = slanhs_("1", kev, &h__[h_offset], ldh, &workl[1], (ftnlen)
1);
}
/* Computing MAX */
r__1 = ulp * tst1;
if (h__[i__ + 1 + i__ * h_dim1] <= dmax(r__1,smlnum)) {
h__[i__ + 1 + i__ * h_dim1] = 0.f;
}
/* L130: */
}
/* %-------------------------------------------------% */
/* | Compute the (kev+1)-st column of (V*Q) and | */
/* | temporarily store the result in WORKD(N+1:2*N). | */
/* | This is needed in the residual update since we | */
/* | cannot GUARANTEE that the corresponding entry | */
/* | of H would be zero as in exact arithmetic. | */
/* %-------------------------------------------------% */
if (h__[*kev + 1 + *kev * h_dim1] > 0.f) {
sgemv_("N", n, &kplusp, &c_b6, &v[v_offset], ldv, &q[(*kev + 1) *
q_dim1 + 1], &c__1, &c_b5, &workd[*n + 1], &c__1, (ftnlen)1);
}
/* %----------------------------------------------------------% */
/* | Compute column 1 to kev of (V*Q) in backward order | */
/* | taking advantage of the upper Hessenberg structure of Q. | */
/* %----------------------------------------------------------% */
i__1 = *kev;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = kplusp - i__ + 1;
sgemv_("N", n, &i__2, &c_b6, &v[v_offset], ldv, &q[(*kev - i__ + 1) *
q_dim1 + 1], &c__1, &c_b5, &workd[1], &c__1, (ftnlen)1);
scopy_(n, &workd[1], &c__1, &v[(kplusp - i__ + 1) * v_dim1 + 1], &
c__1);
/* L140: */
}
/* %-------------------------------------------------% */
/* | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | */
/* %-------------------------------------------------% */
slacpy_("A", n, kev, &v[(kplusp - *kev + 1) * v_dim1 + 1], ldv, &v[
v_offset], ldv, (ftnlen)1);
/* %--------------------------------------------------------------% */
/* | Copy the (kev+1)-st column of (V*Q) in the appropriate place | */
/* %--------------------------------------------------------------% */
if (h__[*kev + 1 + *kev * h_dim1] > 0.f) {
scopy_(n, &workd[*n + 1], &c__1, &v[(*kev + 1) * v_dim1 + 1], &c__1);
}
/* %-------------------------------------% */
/* | Update the residual vector: | */
/* | r <- sigmak*r + betak*v(:,kev+1) | */
/* | where | */
/* | sigmak = (e_{kplusp}'*Q)*e_{kev} | */
/* | betak = e_{kev+1}'*H*e_{kev} | */
/* %-------------------------------------% */
sscal_(n, &q[kplusp + *kev * q_dim1], &resid[1], &c__1);
if (h__[*kev + 1 + *kev * h_dim1] > 0.f) {
saxpy_(n, &h__[*kev + 1 + *kev * h_dim1], &v[(*kev + 1) * v_dim1 + 1],
&c__1, &resid[1], &c__1);
}
if (msglvl > 1) {
svout_(&debug_1.logfil, &c__1, &q[kplusp + *kev * q_dim1], &
debug_1.ndigit, "_napps: sigmak = (e_{kev+p}^T*Q)*e_{kev}", (
ftnlen)40);
svout_(&debug_1.logfil, &c__1, &h__[*kev + 1 + *kev * h_dim1], &
debug_1.ndigit, "_napps: betak = e_{kev+1}^T*H*e_{kev}", (
ftnlen)37);
ivout_(&debug_1.logfil, &c__1, kev, &debug_1.ndigit, "_napps: Order "
"of the final Hessenberg matrix ", (ftnlen)45);
if (msglvl > 2) {
smout_(&debug_1.logfil, kev, kev, &h__[h_offset], ldh, &
debug_1.ndigit, "_napps: updated Hessenberg matrix H for"
" next iteration", (ftnlen)54);
}
}
L9000:
second_(&t1);
timing_1.tnapps += t1 - t0;
return 0;
/* %---------------% */
/* | End of snapps | */
/* %---------------% */
} /* snapps_ */
/* Subroutine */ int slahqr_(logical *wantt, logical *wantz, integer *n,
integer *ilo, integer *ihi, real *h__, integer *ldh, real *wr, real *
wi, integer *iloz, integer *ihiz, real *z__, integer *ldz, integer *
info)
{
/* System generated locals */
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal), r_sign(real *, real *);
/* Local variables */
static integer i__, j, k, l, m;
static real s, v[3];
static integer i1, i2;
static real t1, t2, t3, v1, v2, v3, h00, h10, h11, h12, h21, h22, h33,
h44;
static integer nh;
static real cs;
static integer nr;
static real sn;
static integer nz;
static real ave, h33s, h44s;
static integer itn, its;
static real ulp, sum, tst1, h43h34, disc, unfl, ovfl, work[1];
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *), scopy_(integer *, real *, integer *,
real *, integer *), slanv2_(real *, real *, real *, real *, real *
, real *, real *, real *, real *, real *), slabad_(real *, real *)
;
extern doublereal slamch_(char *, ftnlen);
extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *,
real *);
extern doublereal slanhs_(char *, integer *, real *, integer *, real *,
ftnlen);
static real smlnum;
/* -- LAPACK auxiliary routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* June 30, 1999 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLAHQR is an auxiliary routine called by SHSEQR to update the */
/* eigenvalues and Schur decomposition already computed by SHSEQR, by */
/* dealing with the Hessenberg submatrix in rows and columns ILO to IHI. */
/* Arguments */
/* ========= */
/* WANTT (input) LOGICAL */
/* = .TRUE. : the full Schur form T is required; */
/* = .FALSE.: only eigenvalues are required. */
/* WANTZ (input) LOGICAL */
/* = .TRUE. : the matrix of Schur vectors Z is required; */
/* = .FALSE.: Schur vectors are not required. */
/* N (input) INTEGER */
/* The order of the matrix H. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* It is assumed that H is already upper quasi-triangular in */
/* rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless */
/* ILO = 1). SLAHQR works primarily with the Hessenberg */
/* submatrix in rows and columns ILO to IHI, but applies */
/* transformations to all of H if WANTT is .TRUE.. */
/* 1 <= ILO <= max(1,IHI); IHI <= N. */
/* H (input/output) REAL array, dimension (LDH,N) */
/* On entry, the upper Hessenberg matrix H. */
/* On exit, if WANTT is .TRUE., H is upper quasi-triangular in */
/* rows and columns ILO:IHI, with any 2-by-2 diagonal blocks in */
/* standard form. If WANTT is .FALSE., the contents of H are */
/* unspecified on exit. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH >= max(1,N). */
/* WR (output) REAL array, dimension (N) */
/* WI (output) REAL array, dimension (N) */
/* The real and imaginary parts, respectively, of the computed */
/* eigenvalues ILO to IHI are stored in the corresponding */
/* elements of WR and WI. If two eigenvalues are computed as a */
/* complex conjugate pair, they are stored in consecutive */
/* elements of WR and WI, say the i-th and (i+1)th, with */
/* WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the */
/* eigenvalues are stored in the same order as on the diagonal */
/* of the Schur form returned in H, with WR(i) = H(i,i), and, if */
/* H(i:i+1,i:i+1) is a 2-by-2 diagonal block, */
/* WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i). */
/* ILOZ (input) INTEGER */
/* IHIZ (input) INTEGER */
/* Specify the rows of Z to which transformations must be */
/* applied if WANTZ is .TRUE.. */
/* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. */
/* Z (input/output) REAL array, dimension (LDZ,N) */
/* If WANTZ is .TRUE., on entry Z must contain the current */
/* matrix Z of transformations accumulated by SHSEQR, and on */
/* exit Z has been updated; transformations are applied only to */
/* the submatrix Z(ILOZ:IHIZ,ILO:IHI). */
/* If WANTZ is .FALSE., Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* > 0: SLAHQR failed to compute all the eigenvalues ILO to IHI */
/* in a total of 30*(IHI-ILO+1) iterations; if INFO = i, */
/* elements i+1:ihi of WR and WI contain those eigenvalues */
/* which have been successfully computed. */
/* Further Details */
/* =============== */
/* 2-96 Based on modifications by */
/* David Day, Sandia National Laboratory, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--wr;
--wi;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*ilo == *ihi) {
wr[*ilo] = h__[*ilo + *ilo * h_dim1];
wi[*ilo] = 0.f;
return 0;
}
nh = *ihi - *ilo + 1;
nz = *ihiz - *iloz + 1;
/* Set machine-dependent constants for the stopping criterion. */
/* If norm(H) <= sqrt(OVFL), overflow should not occur. */
unfl = slamch_("Safe minimum", (ftnlen)12);
ovfl = 1.f / unfl;
slabad_(&unfl, &ovfl);
ulp = slamch_("Precision", (ftnlen)9);
smlnum = unfl * (nh / ulp);
/* I1 and I2 are the indices of the first row and last column of H */
/* to which transformations must be applied. If eigenvalues only are */
/* being computed, I1 and I2 are set inside the main loop. */
if (*wantt) {
i1 = 1;
i2 = *n;
}
/* ITN is the total number of QR iterations allowed. */
itn = nh * 30;
/* The main loop begins here. I is the loop index and decreases from */
/* IHI to ILO in steps of 1 or 2. Each iteration of the loop works */
/* with the active submatrix in rows and columns L to I. */
/* Eigenvalues I+1 to IHI have already converged. Either L = ILO or */
/* H(L,L-1) is negligible so that the matrix splits. */
i__ = *ihi;
L10:
l = *ilo;
if (i__ < *ilo) {
goto L150;
}
/* Perform QR iterations on rows and columns ILO to I until a */
/* submatrix of order 1 or 2 splits off at the bottom because a */
/* subdiagonal element has become negligible. */
i__1 = itn;
for (its = 0; its <= i__1; ++its) {
/* Look for a single small subdiagonal element. */
i__2 = l + 1;
for (k = i__; k >= i__2; --k) {
tst1 = (r__1 = h__[k - 1 + (k - 1) * h_dim1], dabs(r__1)) + (r__2
= h__[k + k * h_dim1], dabs(r__2));
if (tst1 == 0.f) {
i__3 = i__ - l + 1;
tst1 = slanhs_("1", &i__3, &h__[l + l * h_dim1], ldh, work, (
ftnlen)1);
}
/* Computing MAX */
r__2 = ulp * tst1;
if ((r__1 = h__[k + (k - 1) * h_dim1], dabs(r__1)) <= dmax(r__2,
smlnum)) {
goto L30;
}
/* L20: */
}
L30:
l = k;
if (l > *ilo) {
/* H(L,L-1) is negligible */
h__[l + (l - 1) * h_dim1] = 0.f;
}
/* Exit from loop if a submatrix of order 1 or 2 has split off. */
if (l >= i__ - 1) {
goto L140;
}
/* Now the active submatrix is in rows and columns L to I. If */
/* eigenvalues only are being computed, only the active submatrix */
/* need be transformed. */
if (! (*wantt)) {
i1 = l;
i2 = i__;
}
if (its == 10 || its == 20) {
/* Exceptional shift. */
s = (r__1 = h__[i__ + (i__ - 1) * h_dim1], dabs(r__1)) + (r__2 =
h__[i__ - 1 + (i__ - 2) * h_dim1], dabs(r__2));
h44 = s * .75f + h__[i__ + i__ * h_dim1];
h33 = h44;
h43h34 = s * -.4375f * s;
} else {
/* Prepare to use Francis' double shift */
/* (i.e. 2nd degree generalized Rayleigh quotient) */
h44 = h__[i__ + i__ * h_dim1];
h33 = h__[i__ - 1 + (i__ - 1) * h_dim1];
h43h34 = h__[i__ + (i__ - 1) * h_dim1] * h__[i__ - 1 + i__ *
h_dim1];
s = h__[i__ - 1 + (i__ - 2) * h_dim1] * h__[i__ - 1 + (i__ - 2) *
h_dim1];
disc = (h33 - h44) * .5f;
disc = disc * disc + h43h34;
if (disc > 0.f) {
/* Real roots: use Wilkinson's shift twice */
disc = sqrt(disc);
ave = (h33 + h44) * .5f;
if (dabs(h33) - dabs(h44) > 0.f) {
h33 = h33 * h44 - h43h34;
h44 = h33 / (r_sign(&disc, &ave) + ave);
} else {
h44 = r_sign(&disc, &ave) + ave;
}
h33 = h44;
h43h34 = 0.f;
}
}
/* Look for two consecutive small subdiagonal elements. */
i__2 = l;
for (m = i__ - 2; m >= i__2; --m) {
/* Determine the effect of starting the double-shift QR */
/* iteration at row M, and see if this would make H(M,M-1) */
/* negligible. */
h11 = h__[m + m * h_dim1];
h22 = h__[m + 1 + (m + 1) * h_dim1];
h21 = h__[m + 1 + m * h_dim1];
h12 = h__[m + (m + 1) * h_dim1];
h44s = h44 - h11;
h33s = h33 - h11;
v1 = (h33s * h44s - h43h34) / h21 + h12;
v2 = h22 - h11 - h33s - h44s;
v3 = h__[m + 2 + (m + 1) * h_dim1];
s = dabs(v1) + dabs(v2) + dabs(v3);
v1 /= s;
v2 /= s;
v3 /= s;
v[0] = v1;
v[1] = v2;
v[2] = v3;
if (m == l) {
goto L50;
}
h00 = h__[m - 1 + (m - 1) * h_dim1];
h10 = h__[m + (m - 1) * h_dim1];
tst1 = dabs(v1) * (dabs(h00) + dabs(h11) + dabs(h22));
if (dabs(h10) * (dabs(v2) + dabs(v3)) <= ulp * tst1) {
goto L50;
}
/* L40: */
}
L50:
/* Double-shift QR step */
i__2 = i__ - 1;
for (k = m; k <= i__2; ++k) {
/* The first iteration of this loop determines a reflection G */
/* from the vector V and applies it from left and right to H, */
/* thus creating a nonzero bulge below the subdiagonal. */
/* Each subsequent iteration determines a reflection G to */
/* restore the Hessenberg form in the (K-1)th column, and thus */
/* chases the bulge one step toward the bottom of the active */
/* submatrix. NR is the order of G. */
/* Computing MIN */
i__3 = 3, i__4 = i__ - k + 1;
nr = min(i__3,i__4);
if (k > m) {
scopy_(&nr, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1);
}
slarfg_(&nr, v, &v[1], &c__1, &t1);
if (k > m) {
h__[k + (k - 1) * h_dim1] = v[0];
h__[k + 1 + (k - 1) * h_dim1] = 0.f;
if (k < i__ - 1) {
h__[k + 2 + (k - 1) * h_dim1] = 0.f;
}
} else if (m > l) {
h__[k + (k - 1) * h_dim1] = -h__[k + (k - 1) * h_dim1];
}
v2 = v[1];
t2 = t1 * v2;
if (nr == 3) {
v3 = v[2];
t3 = t1 * v3;
/* Apply G from the left to transform the rows of the matrix */
/* in columns K to I2. */
i__3 = i2;
for (j = k; j <= i__3; ++j) {
sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1]
+ v3 * h__[k + 2 + j * h_dim1];
h__[k + j * h_dim1] -= sum * t1;
h__[k + 1 + j * h_dim1] -= sum * t2;
h__[k + 2 + j * h_dim1] -= sum * t3;
/* L60: */
}
/* Apply G from the right to transform the columns of the */
/* matrix in rows I1 to min(K+3,I). */
/* Computing MIN */
i__4 = k + 3;
i__3 = min(i__4,i__);
for (j = i1; j <= i__3; ++j) {
sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1]
+ v3 * h__[j + (k + 2) * h_dim1];
h__[j + k * h_dim1] -= sum * t1;
h__[j + (k + 1) * h_dim1] -= sum * t2;
h__[j + (k + 2) * h_dim1] -= sum * t3;
/* L70: */
}
if (*wantz) {
/* Accumulate transformations in the matrix Z */
i__3 = *ihiz;
for (j = *iloz; j <= i__3; ++j) {
sum = z__[j + k * z_dim1] + v2 * z__[j + (k + 1) *
z_dim1] + v3 * z__[j + (k + 2) * z_dim1];
z__[j + k * z_dim1] -= sum * t1;
z__[j + (k + 1) * z_dim1] -= sum * t2;
z__[j + (k + 2) * z_dim1] -= sum * t3;
/* L80: */
}
}
} else if (nr == 2) {
/* Apply G from the left to transform the rows of the matrix */
/* in columns K to I2. */
i__3 = i2;
for (j = k; j <= i__3; ++j) {
sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1];
h__[k + j * h_dim1] -= sum * t1;
h__[k + 1 + j * h_dim1] -= sum * t2;
/* L90: */
}
/* Apply G from the right to transform the columns of the */
/* matrix in rows I1 to min(K+3,I). */
i__3 = i__;
for (j = i1; j <= i__3; ++j) {
sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1]
;
h__[j + k * h_dim1] -= sum * t1;
h__[j + (k + 1) * h_dim1] -= sum * t2;
/* L100: */
}
if (*wantz) {
/* Accumulate transformations in the matrix Z */
i__3 = *ihiz;
for (j = *iloz; j <= i__3; ++j) {
sum = z__[j + k * z_dim1] + v2 * z__[j + (k + 1) *
z_dim1];
z__[j + k * z_dim1] -= sum * t1;
z__[j + (k + 1) * z_dim1] -= sum * t2;
/* L110: */
}
}
}
/* L120: */
}
/* L130: */
}
/* Failure to converge in remaining number of iterations */
*info = i__;
return 0;
L140:
if (l == i__) {
/* H(I,I-1) is negligible: one eigenvalue has converged. */
wr[i__] = h__[i__ + i__ * h_dim1];
wi[i__] = 0.f;
} else if (l == i__ - 1) {
/* H(I-1,I-2) is negligible: a pair of eigenvalues have converged. */
/* Transform the 2-by-2 submatrix to standard Schur form, */
/* and compute and store the eigenvalues. */
slanv2_(&h__[i__ - 1 + (i__ - 1) * h_dim1], &h__[i__ - 1 + i__ *
h_dim1], &h__[i__ + (i__ - 1) * h_dim1], &h__[i__ + i__ *
h_dim1], &wr[i__ - 1], &wi[i__ - 1], &wr[i__], &wi[i__], &cs,
&sn);
if (*wantt) {
/* Apply the transformation to the rest of H. */
if (i2 > i__) {
i__1 = i2 - i__;
srot_(&i__1, &h__[i__ - 1 + (i__ + 1) * h_dim1], ldh, &h__[
i__ + (i__ + 1) * h_dim1], ldh, &cs, &sn);
}
i__1 = i__ - i1 - 1;
srot_(&i__1, &h__[i1 + (i__ - 1) * h_dim1], &c__1, &h__[i1 + i__ *
h_dim1], &c__1, &cs, &sn);
}
if (*wantz) {
/* Apply the transformation to Z. */
srot_(&nz, &z__[*iloz + (i__ - 1) * z_dim1], &c__1, &z__[*iloz +
i__ * z_dim1], &c__1, &cs, &sn);
}
}
/* Decrement number of remaining iterations, and return to start of */
/* the main loop with new value of I. */
itn -= its;
i__ = l - 1;
goto L10;
L150:
return 0;
/* End of SLAHQR */
} /* slahqr_ */
