/* Subroutine */ int zhseqr_(char *job, char *compz, integer *n, integer *ilo,
integer *ihi, doublecomplex *h__, integer *ldh, doublecomplex *w,
doublecomplex *z__, integer *ldz, doublecomplex *work, integer *lwork,
integer *info)
{
/* -- 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
Purpose
=======
ZHSEQR computes the eigenvalues of a complex upper Hessenberg
matrix H, and, optionally, the matrices T and Z from the Schur
decomposition H = Z T Z**H, where T is an upper triangular matrix
(the Schur form), and Z is the unitary matrix of Schur vectors.
Optionally Z may be postmultiplied into an input unitary matrix Q,
so that this routine can give the Schur factorization of a matrix A
which has been reduced to the Hessenberg form H by the unitary
matrix Q: A = Q*H*Q**H = (QZ)*T*(QZ)**H.
Arguments
=========
JOB (input) CHARACTER*1
= 'E': compute eigenvalues only;
= 'S': compute eigenvalues and the Schur form T.
COMPZ (input) CHARACTER*1
= 'N': no Schur vectors are computed;
= 'I': Z is initialized to the unit matrix and the matrix Z
of Schur vectors of H is returned;
= 'V': Z must contain an unitary matrix Q on entry, and
the product Q*Z is returned.
N (input) INTEGER
The order of the matrix H. N >= 0.
ILO (input) INTEGER
IHI (input) INTEGER
It is assumed that H is already upper triangular in rows
and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
set by a previous call to ZGEBAL, and then passed to CGEHRD
when the matrix output by ZGEBAL is reduced to Hessenberg
form. Otherwise ILO and IHI should be set to 1 and N
respectively.
1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
H (input/output) COMPLEX*16 array, dimension (LDH,N)
On entry, the upper Hessenberg matrix H.
On exit, if JOB = 'S', H contains the upper triangular matrix
T from the Schur decomposition (the Schur form). If
JOB = 'E', the contents of H are unspecified on exit.
LDH (input) INTEGER
The leading dimension of the array H. LDH >= max(1,N).
W (output) COMPLEX*16 array, dimension (N)
The computed eigenvalues. If JOB = 'S', the eigenvalues are
stored in the same order as on the diagonal of the Schur form
returned in H, with W(i) = H(i,i).
Z (input/output) COMPLEX*16 array, dimension (LDZ,N)
If COMPZ = 'N': Z is not referenced.
If COMPZ = 'I': on entry, Z need not be set, and on exit, Z
contains the unitary matrix Z of the Schur vectors of H.
If COMPZ = 'V': on entry Z must contain an N-by-N matrix Q,
which is assumed to be equal to the unit matrix except for
the submatrix Z(ILO:IHI,ILO:IHI); on exit Z contains Q*Z.
Normally Q is the unitary matrix generated by ZUNGHR after
the call to ZGEHRD which formed the Hessenberg matrix H.
LDZ (input) INTEGER
The leading dimension of the array Z.
LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise.
WORK (workspace/output) COMPLEX*16 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, ZHSEQR failed to compute all the
eigenvalues in a total of 30*(IHI-ILO+1) iterations;
elements 1:ilo-1 and i+1:n of W contain those
eigenvalues which have been successfully computed.
=====================================================================
Decode and test the input parameters
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b1 = {0.,0.};
static doublecomplex c_b2 = {1.,0.};
static integer c__1 = 1;
static integer c__4 = 4;
static integer c_n1 = -1;
static integer c__2 = 2;
static integer c__8 = 8;
static integer c__15 = 15;
static logical c_false = FALSE_;
/* System generated locals */
address a__1[2];
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4[2],
i__5, i__6;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1;
char ch__1[2];
/* Builtin functions */
double d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static integer maxb, ierr;
static doublereal unfl;
static doublecomplex temp;
static doublereal ovfl;
static integer i__, j, k, l;
static doublecomplex s[225] /* was [15][15] */, v[16];
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
static integer itemp;
static doublereal rtemp;
static integer i1, i2;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static logical initz, wantt, wantz;
static doublereal rwork[1];
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
extern doublereal dlapy2_(doublereal *, doublereal *);
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
static integer ii, nh;
extern doublereal dlamch_(char *);
static integer nr, ns, nv;
static doublecomplex vv[16];
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *), zlarfg_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *);
extern integer izamax_(integer *, doublecomplex *, integer *);
extern doublereal zlanhs_(char *, integer *, doublecomplex *, integer *,
doublereal *);
extern /* Subroutine */ int zlahqr_(logical *, logical *, integer *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *, integer *, doublecomplex *, integer *, integer *),
zlacpy_(char *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zlaset_(char *, integer *,
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
integer *), zlarfx_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *);
static doublereal smlnum;
static logical lquery;
static integer itn;
static doublecomplex tau;
static integer its;
static doublereal ulp, tst1;
#define h___subscr(a_1,a_2) (a_2)*h_dim1 + a_1
#define h___ref(a_1,a_2) h__[h___subscr(a_1,a_2)]
#define s_subscr(a_1,a_2) (a_2)*15 + a_1 - 16
#define s_ref(a_1,a_2) s[s_subscr(a_1,a_2)]
#define z___subscr(a_1,a_2) (a_2)*z_dim1 + a_1
#define z___ref(a_1,a_2) z__[z___subscr(a_1,a_2)]
h_dim1 = *ldh;
h_offset = 1 + h_dim1 * 1;
h__ -= h_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
/* Function Body */
wantt = lsame_(job, "S");
initz = lsame_(compz, "I");
wantz = initz || lsame_(compz, "V");
*info = 0;
i__1 = max(1,*n);
work[1].r = (doublereal) i__1, work[1].i = 0.;
lquery = *lwork == -1;
if (! lsame_(job, "E") && ! wantt) {
*info = -1;
} else if (! lsame_(compz, "N") && ! wantz) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ilo < 1 || *ilo > max(1,*n)) {
*info = -4;
} else if (*ihi < min(*ilo,*n) || *ihi > *n) {
*info = -5;
} else if (*ldh < max(1,*n)) {
*info = -7;
} else if (*ldz < 1 || wantz && *ldz < max(1,*n)) {
*info = -10;
} else if (*lwork < max(1,*n) && ! lquery) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHSEQR", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Initialize Z, if necessary */
if (initz) {
zlaset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz);
}
/* Store the eigenvalues isolated by ZGEBAL. */
i__1 = *ilo - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = h___subscr(i__, i__);
w[i__2].r = h__[i__3].r, w[i__2].i = h__[i__3].i;
/* L10: */
}
i__1 = *n;
for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = h___subscr(i__, i__);
w[i__2].r = h__[i__3].r, w[i__2].i = h__[i__3].i;
/* L20: */
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
if (*ilo == *ihi) {
i__1 = *ilo;
i__2 = h___subscr(*ilo, *ilo);
w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i;
return 0;
}
/* Set rows and columns ILO to IHI to zero below the first
subdiagonal. */
i__1 = *ihi - 2;
for (j = *ilo; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 2; i__ <= i__2; ++i__) {
i__3 = h___subscr(i__, j);
h__[i__3].r = 0., h__[i__3].i = 0.;
/* L30: */
}
/* L40: */
}
nh = *ihi - *ilo + 1;
/* I1 and I2 are the indices of the first row and last column of H
to which transformations must be applied. If eigenvalues only are
being computed, I1 and I2 are re-set inside the main loop. */
if (wantt) {
i1 = 1;
i2 = *n;
} else {
i1 = *ilo;
i2 = *ihi;
}
/* Ensure that the subdiagonal elements are real. */
i__1 = *ihi;
for (i__ = *ilo + 1; i__ <= i__1; ++i__) {
i__2 = h___subscr(i__, i__ - 1);
temp.r = h__[i__2].r, temp.i = h__[i__2].i;
if (d_imag(&temp) != 0.) {
d__1 = temp.r;
d__2 = d_imag(&temp);
rtemp = dlapy2_(&d__1, &d__2);
i__2 = h___subscr(i__, i__ - 1);
h__[i__2].r = rtemp, h__[i__2].i = 0.;
z__1.r = temp.r / rtemp, z__1.i = temp.i / rtemp;
temp.r = z__1.r, temp.i = z__1.i;
if (i2 > i__) {
i__2 = i2 - i__;
d_cnjg(&z__1, &temp);
zscal_(&i__2, &z__1, &h___ref(i__, i__ + 1), ldh);
}
i__2 = i__ - i1;
zscal_(&i__2, &temp, &h___ref(i1, i__), &c__1);
if (i__ < *ihi) {
i__2 = h___subscr(i__ + 1, i__);
i__3 = h___subscr(i__ + 1, i__);
z__1.r = temp.r * h__[i__3].r - temp.i * h__[i__3].i, z__1.i =
temp.r * h__[i__3].i + temp.i * h__[i__3].r;
h__[i__2].r = z__1.r, h__[i__2].i = z__1.i;
}
if (wantz) {
zscal_(&nh, &temp, &z___ref(*ilo, i__), &c__1);
}
}
/* L50: */
}
/* Determine the order of the multi-shift QR algorithm to be used.
Writing concatenation */
i__4[0] = 1, a__1[0] = job;
i__4[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__4, &c__2, (ftnlen)2);
ns = ilaenv_(&c__4, "ZHSEQR", ch__1, n, ilo, ihi, &c_n1, (ftnlen)6, (
ftnlen)2);
/* Writing concatenation */
i__4[0] = 1, a__1[0] = job;
i__4[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__4, &c__2, (ftnlen)2);
maxb = ilaenv_(&c__8, "ZHSEQR", ch__1, n, ilo, ihi, &c_n1, (ftnlen)6, (
ftnlen)2);
if (ns <= 1 || ns > nh || maxb >= nh) {
/* Use the standard double-shift algorithm */
zlahqr_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &w[1], ilo,
ihi, &z__[z_offset], ldz, info);
return 0;
}
maxb = max(2,maxb);
/* Computing MIN */
i__1 = min(ns,maxb);
ns = min(i__1,15);
/* Now 1 < NS <= MAXB < NH.
Set machine-dependent constants for the stopping criterion.
If norm(H) <= sqrt(OVFL), overflow should not occur. */
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
dlabad_(&unfl, &ovfl);
ulp = dlamch_("Precision");
smlnum = unfl * (nh / ulp);
/* ITN is the total number of multiple-shift QR iterations allowed. */
itn = nh * 30;
/* The main loop begins here. I is the loop index and decreases from
IHI to ILO in steps of at most MAXB. Each iteration of the loop
works with the active submatrix in rows and columns L to I.
Eigenvalues I+1 to IHI have already converged. Either L = ILO, or
H(L,L-1) is negligible so that the matrix splits. */
i__ = *ihi;
L60:
if (i__ < *ilo) {
goto L180;
}
/* Perform multiple-shift QR iterations on rows and columns ILO to I
until a submatrix of order at most MAXB splits off at the bottom
because a subdiagonal element has become negligible. */
l = *ilo;
i__1 = itn;
for (its = 0; its <= i__1; ++its) {
/* Look for a single small subdiagonal element. */
i__2 = l + 1;
for (k = i__; k >= i__2; --k) {
i__3 = h___subscr(k - 1, k - 1);
i__5 = h___subscr(k, k);
tst1 = (d__1 = h__[i__3].r, abs(d__1)) + (d__2 = d_imag(&h___ref(
k - 1, k - 1)), abs(d__2)) + ((d__3 = h__[i__5].r, abs(
d__3)) + (d__4 = d_imag(&h___ref(k, k)), abs(d__4)));
if (tst1 == 0.) {
i__3 = i__ - l + 1;
tst1 = zlanhs_("1", &i__3, &h___ref(l, l), ldh, rwork);
}
i__3 = h___subscr(k, k - 1);
/* Computing MAX */
d__2 = ulp * tst1;
if ((d__1 = h__[i__3].r, abs(d__1)) <= max(d__2,smlnum)) {
goto L80;
}
/* L70: */
}
L80:
l = k;
if (l > *ilo) {
/* H(L,L-1) is negligible. */
i__2 = h___subscr(l, l - 1);
h__[i__2].r = 0., h__[i__2].i = 0.;
}
/* Exit from loop if a submatrix of order <= MAXB has split off. */
if (l >= i__ - maxb + 1) {
goto L170;
}
/* Now the active submatrix is in rows and columns L to I. If
eigenvalues only are being computed, only the active submatrix
need be transformed. */
if (! wantt) {
i1 = l;
i2 = i__;
}
if (its == 20 || its == 30) {
/* Exceptional shifts. */
i__2 = i__;
for (ii = i__ - ns + 1; ii <= i__2; ++ii) {
i__3 = ii;
i__5 = h___subscr(ii, ii - 1);
i__6 = h___subscr(ii, ii);
d__3 = ((d__1 = h__[i__5].r, abs(d__1)) + (d__2 = h__[i__6].r,
abs(d__2))) * 1.5;
w[i__3].r = d__3, w[i__3].i = 0.;
/* L90: */
}
} else {
/* Use eigenvalues of trailing submatrix of order NS as shifts. */
zlacpy_("Full", &ns, &ns, &h___ref(i__ - ns + 1, i__ - ns + 1),
ldh, s, &c__15);
zlahqr_(&c_false, &c_false, &ns, &c__1, &ns, s, &c__15, &w[i__ -
ns + 1], &c__1, &ns, &z__[z_offset], ldz, &ierr);
if (ierr > 0) {
/* If ZLAHQR failed to compute all NS eigenvalues, use the
unconverged diagonal elements as the remaining shifts. */
i__2 = ierr;
for (ii = 1; ii <= i__2; ++ii) {
i__3 = i__ - ns + ii;
i__5 = s_subscr(ii, ii);
w[i__3].r = s[i__5].r, w[i__3].i = s[i__5].i;
/* L100: */
}
}
}
/* Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns))
where G is the Hessenberg submatrix H(L:I,L:I) and w is
the vector of shifts (stored in W). The result is
stored in the local array V. */
v[0].r = 1., v[0].i = 0.;
i__2 = ns + 1;
for (ii = 2; ii <= i__2; ++ii) {
i__3 = ii - 1;
v[i__3].r = 0., v[i__3].i = 0.;
/* L110: */
}
nv = 1;
i__2 = i__;
for (j = i__ - ns + 1; j <= i__2; ++j) {
i__3 = nv + 1;
zcopy_(&i__3, v, &c__1, vv, &c__1);
i__3 = nv + 1;
i__5 = j;
z__1.r = -w[i__5].r, z__1.i = -w[i__5].i;
zgemv_("No transpose", &i__3, &nv, &c_b2, &h___ref(l, l), ldh, vv,
&c__1, &z__1, v, &c__1);
++nv;
/* Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero,
reset it to the unit vector. */
itemp = izamax_(&nv, v, &c__1);
i__3 = itemp - 1;
rtemp = (d__1 = v[i__3].r, abs(d__1)) + (d__2 = d_imag(&v[itemp -
1]), abs(d__2));
if (rtemp == 0.) {
v[0].r = 1., v[0].i = 0.;
i__3 = nv;
for (ii = 2; ii <= i__3; ++ii) {
i__5 = ii - 1;
v[i__5].r = 0., v[i__5].i = 0.;
/* L120: */
}
} else {
rtemp = max(rtemp,smlnum);
d__1 = 1. / rtemp;
zdscal_(&nv, &d__1, v, &c__1);
}
/* L130: */
}
/* Multiple-shift QR step */
i__2 = i__ - 1;
for (k = l; k <= i__2; ++k) {
/* The first iteration of this loop determines a reflection G
from the vector V and applies it from left and right to H,
thus creating a nonzero bulge below the subdiagonal.
Each subsequent iteration determines a reflection G to
restore the Hessenberg form in the (K-1)th column, and thus
chases the bulge one step toward the bottom of the active
submatrix. NR is the order of G.
Computing MIN */
i__3 = ns + 1, i__5 = i__ - k + 1;
nr = min(i__3,i__5);
if (k > l) {
zcopy_(&nr, &h___ref(k, k - 1), &c__1, v, &c__1);
}
zlarfg_(&nr, v, &v[1], &c__1, &tau);
if (k > l) {
i__3 = h___subscr(k, k - 1);
h__[i__3].r = v[0].r, h__[i__3].i = v[0].i;
i__3 = i__;
for (ii = k + 1; ii <= i__3; ++ii) {
i__5 = h___subscr(ii, k - 1);
h__[i__5].r = 0., h__[i__5].i = 0.;
/* L140: */
}
}
v[0].r = 1., v[0].i = 0.;
/* Apply G' from the left to transform the rows of the matrix
in columns K to I2. */
i__3 = i2 - k + 1;
d_cnjg(&z__1, &tau);
zlarfx_("Left", &nr, &i__3, v, &z__1, &h___ref(k, k), ldh, &work[
1]);
/* Apply G from the right to transform the columns of the
matrix in rows I1 to min(K+NR,I).
Computing MIN */
i__5 = k + nr;
i__3 = min(i__5,i__) - i1 + 1;
zlarfx_("Right", &i__3, &nr, v, &tau, &h___ref(i1, k), ldh, &work[
1]);
if (wantz) {
/* Accumulate transformations in the matrix Z */
zlarfx_("Right", &nh, &nr, v, &tau, &z___ref(*ilo, k), ldz, &
work[1]);
}
/* L150: */
}
/* Ensure that H(I,I-1) is real. */
i__2 = h___subscr(i__, i__ - 1);
temp.r = h__[i__2].r, temp.i = h__[i__2].i;
if (d_imag(&temp) != 0.) {
d__1 = temp.r;
d__2 = d_imag(&temp);
rtemp = dlapy2_(&d__1, &d__2);
i__2 = h___subscr(i__, i__ - 1);
h__[i__2].r = rtemp, h__[i__2].i = 0.;
z__1.r = temp.r / rtemp, z__1.i = temp.i / rtemp;
temp.r = z__1.r, temp.i = z__1.i;
if (i2 > i__) {
i__2 = i2 - i__;
d_cnjg(&z__1, &temp);
zscal_(&i__2, &z__1, &h___ref(i__, i__ + 1), ldh);
}
i__2 = i__ - i1;
zscal_(&i__2, &temp, &h___ref(i1, i__), &c__1);
if (wantz) {
zscal_(&nh, &temp, &z___ref(*ilo, i__), &c__1);
}
}
/* L160: */
}
/* Failure to converge in remaining number of iterations */
*info = i__;
return 0;
L170:
/* A submatrix of order <= MAXB in rows and columns L to I has split
off. Use the double-shift QR algorithm to handle it. */
zlahqr_(&wantt, &wantz, n, &l, &i__, &h__[h_offset], ldh, &w[1], ilo, ihi,
&z__[z_offset], ldz, info);
if (*info > 0) {
return 0;
}
/* Decrement number of remaining iterations, and return to start of
the main loop with a new value of I. */
itn -= its;
i__ = l - 1;
goto L60;
L180:
i__1 = max(1,*n);
work[1].r = (doublereal) i__1, work[1].i = 0.;
return 0;
/* End of ZHSEQR */
} /* zhseqr_ */
/* Subroutine */ int zneigh_(doublereal *rnorm, integer *n, doublecomplex *
h__, integer *ldh, doublecomplex *ritz, doublecomplex *bounds,
doublecomplex *q, integer *ldq, doublecomplex *workl, doublereal *
rwork, integer *ierr)
{
/* System generated locals */
integer h_dim1, h_offset, q_dim1, q_offset, i__1;
doublereal d__1;
/* Local variables */
static integer j;
static real t0, t1;
static doublecomplex vl[1];
static doublereal temp;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zmout_(integer *, integer *, integer
*, doublecomplex *, integer *, integer *, char *, ftnlen), zvout_(
integer *, integer *, doublecomplex *, integer *, char *, ftnlen);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
extern /* Subroutine */ int second_(real *);
static logical select[1];
static integer msglvl;
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, ftnlen),
zlahqr_(logical *, logical *, integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *,
doublecomplex *, integer *, integer *), ztrevc_(char *, char *,
logical *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, integer *, integer *,
doublecomplex *, doublereal *, integer *, ftnlen, ftnlen),
zdscal_(integer *, doublereal *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *, 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 | */
/* %--------------------% */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
/* %-------------------------------% */
/* | Initialize timing statistics | */
/* | & message level for debugging | */
/* %-------------------------------% */
/* Parameter adjustments */
--rwork;
--workl;
--bounds;
--ritz;
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
/* Function Body */
second_(&t0);
msglvl = debug_1.mceigh;
if (msglvl > 2) {
zmout_(&debug_1.logfil, n, n, &h__[h_offset], ldh, &debug_1.ndigit,
"_neigh: Entering upper Hessenberg matrix H ", (ftnlen)43);
}
/* %----------------------------------------------------------% */
/* | 1. Compute the eigenvalues, the last components of the | */
/* | corresponding Schur vectors and the full Schur form T | */
/* | of the current upper Hessenberg matrix H. | */
/* | zlahqr returns the full Schur form of H | */
/* | in WORKL(1:N**2), and the Schur vectors in q. | */
/* %----------------------------------------------------------% */
zlacpy_("All", n, n, &h__[h_offset], ldh, &workl[1], n, (ftnlen)3);
zlaset_("All", n, n, &c_b2, &c_b1, &q[q_offset], ldq, (ftnlen)3);
zlahqr_(&c_true, &c_true, n, &c__1, n, &workl[1], ldh, &ritz[1], &c__1, n,
&q[q_offset], ldq, ierr);
if (*ierr != 0) {
goto L9000;
}
zcopy_(n, &q[*n - 1 + q_dim1], ldq, &bounds[1], &c__1);
if (msglvl > 1) {
zvout_(&debug_1.logfil, n, &bounds[1], &debug_1.ndigit, "_neigh: las"
"t row of the Schur matrix for H", (ftnlen)42);
}
/* %----------------------------------------------------------% */
/* | 2. Compute the eigenvectors of the full Schur form T and | */
/* | apply the Schur vectors to get the corresponding | */
/* | eigenvectors. | */
/* %----------------------------------------------------------% */
ztrevc_("Right", "Back", select, n, &workl[1], n, vl, n, &q[q_offset],
ldq, n, n, &workl[*n * *n + 1], &rwork[1], ierr, (ftnlen)5, (
ftnlen)4);
if (*ierr != 0) {
goto L9000;
}
/* %------------------------------------------------% */
/* | Scale the returning eigenvectors so that their | */
/* | Euclidean norms are all one. LAPACK subroutine | */
/* | ztrevc returns each eigenvector 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|. | */
/* %------------------------------------------------% */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
temp = dznrm2_(n, &q[j * q_dim1 + 1], &c__1);
d__1 = 1. / temp;
zdscal_(n, &d__1, &q[j * q_dim1 + 1], &c__1);
/* L10: */
}
if (msglvl > 1) {
zcopy_(n, &q[*n + q_dim1], ldq, &workl[1], &c__1);
zvout_(&debug_1.logfil, n, &workl[1], &debug_1.ndigit, "_neigh: Last"
" row of the eigenvector matrix for H", (ftnlen)48);
}
/* %----------------------------% */
/* | Compute the Ritz estimates | */
/* %----------------------------% */
zcopy_(n, &q[*n + q_dim1], n, &bounds[1], &c__1);
zdscal_(n, rnorm, &bounds[1], &c__1);
if (msglvl > 2) {
zvout_(&debug_1.logfil, n, &ritz[1], &debug_1.ndigit, "_neigh: The e"
"igenvalues of H", (ftnlen)28);
zvout_(&debug_1.logfil, n, &bounds[1], &debug_1.ndigit, "_neigh: Rit"
"z estimates for the eigenvalues of H", (ftnlen)47);
}
second_(&t1);
timing_1.tceigh += t1 - t0;
L9000:
return 0;
/* %---------------% */
/* | End of zneigh | */
/* %---------------% */
} /* zneigh_ */
/* Subroutine */
int zlaqr2_(logical *wantt, logical *wantz, integer *n, integer *ktop, integer *kbot, integer *nw, doublecomplex *h__, integer *ldh, integer *iloz, integer *ihiz, doublecomplex *z__, integer *ldz, integer *ns, integer *nd, doublecomplex *sh, doublecomplex *v, integer *ldv, integer *nh, doublecomplex *t, integer *ldt, integer *nv, doublecomplex *wv, integer *ldwv, doublecomplex *work, integer *lwork)
{
/* System generated locals */
integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1, wv_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j;
doublecomplex s;
integer jw;
doublereal foo;
integer kln;
doublecomplex tau;
integer knt;
doublereal ulp;
integer lwk1, lwk2;
doublecomplex beta;
integer kcol, info, ifst, ilst, ltop, krow;
extern /* Subroutine */
int zlarf_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *);
integer infqr;
extern /* Subroutine */
int zgemm_(char *, char *, integer *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *);
integer kwtop;
extern /* Subroutine */
int zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *);
doublereal safmin, safmax;
extern /* Subroutine */
int zgehrd_(integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer *), zlarfg_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *), zlahqr_(logical *, logical *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *, doublecomplex *, integer *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *), zlaset_(char *, integer *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *);
doublereal smlnum;
extern /* Subroutine */
int ztrexc_(char *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *, integer *, integer *);
integer lwkopt;
extern /* Subroutine */
int zunmhr_(char *, char *, integer *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer * );
/* -- LAPACK auxiliary routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ================================================================ */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* ==== Estimate optimal workspace. ==== */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--sh;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
wv_dim1 = *ldwv;
wv_offset = 1 + wv_dim1;
wv -= wv_offset;
--work;
/* Function Body */
/* Computing MIN */
i__1 = *nw;
i__2 = *kbot - *ktop + 1; // , expr subst
jw = min(i__1,i__2);
if (jw <= 2)
{
lwkopt = 1;
}
else
{
/* ==== Workspace query call to ZGEHRD ==== */
i__1 = jw - 1;
zgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], & c_n1, &info);
lwk1 = (integer) work[1].r;
/* ==== Workspace query call to ZUNMHR ==== */
i__1 = jw - 1;
zunmhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &v[v_offset], ldv, &work[1], &c_n1, &info);
lwk2 = (integer) work[1].r;
/* ==== Optimal workspace ==== */
lwkopt = jw + max(lwk1,lwk2);
}
/* ==== Quick return in case of workspace query. ==== */
if (*lwork == -1)
{
d__1 = (doublereal) lwkopt;
z__1.r = d__1;
z__1.i = 0.; // , expr subst
work[1].r = z__1.r;
work[1].i = z__1.i; // , expr subst
return 0;
}
/* ==== Nothing to do ... */
/* ... for an empty active block ... ==== */
*ns = 0;
*nd = 0;
work[1].r = 1.;
work[1].i = 0.; // , expr subst
if (*ktop > *kbot)
{
return 0;
}
/* ... nor for an empty deflation window. ==== */
if (*nw < 1)
{
return 0;
}
/* ==== Machine constants ==== */
safmin = dlamch_("SAFE MINIMUM");
safmax = 1. / safmin;
dlabad_(&safmin, &safmax);
ulp = dlamch_("PRECISION");
smlnum = safmin * ((doublereal) (*n) / ulp);
/* ==== Setup deflation window ==== */
/* Computing MIN */
i__1 = *nw;
i__2 = *kbot - *ktop + 1; // , expr subst
jw = min(i__1,i__2);
kwtop = *kbot - jw + 1;
if (kwtop == *ktop)
{
s.r = 0.;
s.i = 0.; // , expr subst
}
else
{
i__1 = kwtop + (kwtop - 1) * h_dim1;
s.r = h__[i__1].r;
s.i = h__[i__1].i; // , expr subst
}
if (*kbot == kwtop)
{
/* ==== 1-by-1 deflation window: not much to do ==== */
i__1 = kwtop;
i__2 = kwtop + kwtop * h_dim1;
sh[i__1].r = h__[i__2].r;
sh[i__1].i = h__[i__2].i; // , expr subst
*ns = 1;
*nd = 0;
/* Computing MAX */
i__1 = kwtop + kwtop * h_dim1;
d__5 = smlnum;
d__6 = ulp * ((d__1 = h__[i__1].r, f2c_abs(d__1)) + (d__2 = d_imag(&h__[kwtop + kwtop * h_dim1]), f2c_abs(d__2))); // , expr subst
if ((d__3 = s.r, f2c_abs(d__3)) + (d__4 = d_imag(&s), f2c_abs(d__4)) <= max( d__5,d__6))
{
*ns = 0;
*nd = 1;
if (kwtop > *ktop)
{
i__1 = kwtop + (kwtop - 1) * h_dim1;
h__[i__1].r = 0.;
h__[i__1].i = 0.; // , expr subst
}
}
work[1].r = 1.;
work[1].i = 0.; // , expr subst
return 0;
}
/* ==== Convert to spike-triangular form. (In case of a */
/* . rare QR failure, this routine continues to do */
/* . aggressive early deflation using that part of */
/* . the deflation window that converged using INFQR */
/* . here and there to keep track.) ==== */
zlacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset], ldt);
i__1 = jw - 1;
i__2 = *ldh + 1;
i__3 = *ldt + 1;
zcopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], & i__3);
zlaset_("A", &jw, &jw, &c_b1, &c_b2, &v[v_offset], ldv);
zlahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sh[kwtop], &c__1, &jw, &v[v_offset], ldv, &infqr);
/* ==== Deflation detection loop ==== */
*ns = jw;
ilst = infqr + 1;
i__1 = jw;
for (knt = infqr + 1;
knt <= i__1;
++knt)
{
/* ==== Small spike tip deflation test ==== */
i__2 = *ns + *ns * t_dim1;
foo = (d__1 = t[i__2].r, f2c_abs(d__1)) + (d__2 = d_imag(&t[*ns + *ns * t_dim1]), f2c_abs(d__2));
if (foo == 0.)
{
foo = (d__1 = s.r, f2c_abs(d__1)) + (d__2 = d_imag(&s), f2c_abs(d__2));
}
i__2 = *ns * v_dim1 + 1;
/* Computing MAX */
d__5 = smlnum;
d__6 = ulp * foo; // , expr subst
if (((d__1 = s.r, f2c_abs(d__1)) + (d__2 = d_imag(&s), f2c_abs(d__2))) * (( d__3 = v[i__2].r, f2c_abs(d__3)) + (d__4 = d_imag(&v[*ns * v_dim1 + 1]), f2c_abs(d__4))) <= max(d__5,d__6))
{
/* ==== One more converged eigenvalue ==== */
--(*ns);
}
else
{
/* ==== One undeflatable eigenvalue. Move it up out of the */
/* . way. (ZTREXC can not fail in this case.) ==== */
ifst = *ns;
ztrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, & ilst, &info);
++ilst;
}
/* L10: */
}
/* ==== Return to Hessenberg form ==== */
if (*ns == 0)
{
s.r = 0.;
s.i = 0.; // , expr subst
}
if (*ns < jw)
{
/* ==== sorting the diagonal of T improves accuracy for */
/* . graded matrices. ==== */
i__1 = *ns;
for (i__ = infqr + 1;
i__ <= i__1;
++i__)
{
ifst = i__;
i__2 = *ns;
for (j = i__ + 1;
j <= i__2;
++j)
{
i__3 = j + j * t_dim1;
i__4 = ifst + ifst * t_dim1;
if ((d__1 = t[i__3].r, f2c_abs(d__1)) + (d__2 = d_imag(&t[j + j * t_dim1]), f2c_abs(d__2)) > (d__3 = t[i__4].r, f2c_abs(d__3)) + (d__4 = d_imag(&t[ifst + ifst * t_dim1]), f2c_abs(d__4)) )
{
ifst = j;
}
/* L20: */
}
ilst = i__;
if (ifst != ilst)
{
ztrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &ilst, &info);
}
/* L30: */
}
}
/* ==== Restore shift/eigenvalue array from T ==== */
i__1 = jw;
for (i__ = infqr + 1;
i__ <= i__1;
++i__)
{
i__2 = kwtop + i__ - 1;
i__3 = i__ + i__ * t_dim1;
sh[i__2].r = t[i__3].r;
sh[i__2].i = t[i__3].i; // , expr subst
/* L40: */
}
if (*ns < jw || s.r == 0. && s.i == 0.)
{
if (*ns > 1 && (s.r != 0. || s.i != 0.))
{
/* ==== Reflect spike back into lower triangle ==== */
zcopy_(ns, &v[v_offset], ldv, &work[1], &c__1);
i__1 = *ns;
for (i__ = 1;
i__ <= i__1;
++i__)
{
i__2 = i__;
d_cnjg(&z__1, &work[i__]);
work[i__2].r = z__1.r;
work[i__2].i = z__1.i; // , expr subst
/* L50: */
}
beta.r = work[1].r;
beta.i = work[1].i; // , expr subst
zlarfg_(ns, &beta, &work[2], &c__1, &tau);
work[1].r = 1.;
work[1].i = 0.; // , expr subst
i__1 = jw - 2;
i__2 = jw - 2;
zlaset_("L", &i__1, &i__2, &c_b1, &c_b1, &t[t_dim1 + 3], ldt);
d_cnjg(&z__1, &tau);
zlarf_("L", ns, &jw, &work[1], &c__1, &z__1, &t[t_offset], ldt, & work[jw + 1]);
zlarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, & work[jw + 1]);
zlarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, & work[jw + 1]);
i__1 = *lwork - jw;
zgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1] , &i__1, &info);
}
/* ==== Copy updated reduced window into place ==== */
if (kwtop > 1)
{
i__1 = kwtop + (kwtop - 1) * h_dim1;
d_cnjg(&z__2, &v[v_dim1 + 1]);
z__1.r = s.r * z__2.r - s.i * z__2.i;
z__1.i = s.r * z__2.i + s.i * z__2.r; // , expr subst
h__[i__1].r = z__1.r;
h__[i__1].i = z__1.i; // , expr subst
}
zlacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1] , ldh);
i__1 = jw - 1;
i__2 = *ldt + 1;
i__3 = *ldh + 1;
zcopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1], &i__3);
/* ==== Accumulate orthogonal matrix in order update */
/* . H and Z, if requested. ==== */
if (*ns > 1 && (s.r != 0. || s.i != 0.))
{
i__1 = *lwork - jw;
zunmhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1], &v[v_offset], ldv, &work[jw + 1], &i__1, &info);
}
/* ==== Update vertical slab in H ==== */
if (*wantt)
{
ltop = 1;
}
else
{
ltop = *ktop;
}
i__1 = kwtop - 1;
i__2 = *nv;
for (krow = ltop;
i__2 < 0 ? krow >= i__1 : krow <= i__1;
krow += i__2)
{
/* Computing MIN */
i__3 = *nv;
i__4 = kwtop - krow; // , expr subst
kln = min(i__3,i__4);
zgemm_("N", "N", &kln, &jw, &jw, &c_b2, &h__[krow + kwtop * h_dim1], ldh, &v[v_offset], ldv, &c_b1, &wv[wv_offset], ldwv);
zlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop * h_dim1], ldh);
/* L60: */
}
/* ==== Update horizontal slab in H ==== */
if (*wantt)
{
i__2 = *n;
i__1 = *nh;
for (kcol = *kbot + 1;
i__1 < 0 ? kcol >= i__2 : kcol <= i__2;
kcol += i__1)
{
/* Computing MIN */
i__3 = *nh;
i__4 = *n - kcol + 1; // , expr subst
kln = min(i__3,i__4);
zgemm_("C", "N", &jw, &kln, &jw, &c_b2, &v[v_offset], ldv, & h__[kwtop + kcol * h_dim1], ldh, &c_b1, &t[t_offset], ldt);
zlacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol * h_dim1], ldh);
/* L70: */
}
}
/* ==== Update vertical slab in Z ==== */
if (*wantz)
{
i__1 = *ihiz;
i__2 = *nv;
for (krow = *iloz;
i__2 < 0 ? krow >= i__1 : krow <= i__1;
krow += i__2)
{
/* Computing MIN */
i__3 = *nv;
i__4 = *ihiz - krow + 1; // , expr subst
kln = min(i__3,i__4);
zgemm_("N", "N", &kln, &jw, &jw, &c_b2, &z__[krow + kwtop * z_dim1], ldz, &v[v_offset], ldv, &c_b1, &wv[wv_offset] , ldwv);
zlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow + kwtop * z_dim1], ldz);
/* L80: */
}
}
}
/* ==== Return the number of deflations ... ==== */
*nd = jw - *ns;
/* ==== ... and the number of shifts. (Subtracting */
/* . INFQR from the spike length takes care */
/* . of the case of a rare QR failure while */
/* . calculating eigenvalues of the deflation */
/* . window.) ==== */
*ns -= infqr;
/* ==== Return optimal workspace. ==== */
d__1 = (doublereal) lwkopt;
z__1.r = d__1;
z__1.i = 0.; // , expr subst
work[1].r = z__1.r;
work[1].i = z__1.i; // , expr subst
/* ==== End of ZLAQR2 ==== */
return 0;
}
/* Subroutine */ int zlaqr4_(logical *wantt, logical *wantz, integer *n,
integer *ilo, integer *ihi, doublecomplex *h__, integer *ldh,
doublecomplex *w, integer *iloz, integer *ihiz, doublecomplex *z__,
integer *ldz, doublecomplex *work, integer *lwork, integer *info)
{
/* System generated locals */
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8;
doublecomplex z__1, z__2, z__3, z__4, z__5;
/* Builtin functions */
double d_imag(doublecomplex *);
void z_sqrt(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, k;
doublereal s;
doublecomplex aa, bb, cc, dd;
integer ld, nh, it, ks, kt, ku, kv, ls, ns, nw;
doublecomplex tr2, det;
integer inf, kdu, nho, nve, kwh, nsr, nwr, kwv, ndec, ndfl, kbot, nmin;
doublecomplex swap;
integer ktop;
doublecomplex zdum[1] /* was [1][1] */;
integer kacc22, itmax, nsmax, nwmax, kwtop;
extern /* Subroutine */ int zlaqr2_(logical *, logical *, integer *,
integer *, integer *, integer *, doublecomplex *, integer *,
integer *, integer *, doublecomplex *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *, integer *,
doublecomplex *, integer *, integer *, doublecomplex *, integer *
, doublecomplex *, integer *), zlaqr5_(logical *, logical *,
integer *, integer *, integer *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, doublecomplex *, integer *,
integer *, doublecomplex *, integer *);
integer nibble;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
char jbcmpz[1];
doublecomplex rtdisc;
integer nwupbd;
logical sorted;
extern /* Subroutine */ int zlahqr_(logical *, logical *, integer *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *, integer *, doublecomplex *, integer *, integer *),
zlacpy_(char *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
integer lwkopt;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* This subroutine implements one level of recursion for ZLAQR0. */
/* It is a complete implementation of the small bulge multi-shift */
/* QR algorithm. It may be called by ZLAQR0 and, for large enough */
/* deflation window size, it may be called by ZLAQR3. This */
/* subroutine is identical to ZLAQR0 except that it calls ZLAQR2 */
/* instead of ZLAQR3. */
/* Purpose */
/* ======= */
/* ZLAQR4 computes the eigenvalues of a Hessenberg matrix H */
/* and, optionally, the matrices T and Z from the Schur decomposition */
/* H = Z T Z**H, where T is an upper triangular matrix (the */
/* Schur form), and Z is the unitary matrix of Schur vectors. */
/* Optionally Z may be postmultiplied into an input unitary */
/* matrix Q so that this routine can give the Schur factorization */
/* of a matrix A which has been reduced to the Hessenberg form H */
/* by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. */
/* Arguments */
/* ========= */
/* WANTT (input) LOGICAL */
/* = .TRUE. : the full Schur form T is required; */
/* = .FALSE.: only eigenvalues are required. */
/* WANTZ (input) LOGICAL */
/* = .TRUE. : the matrix of Schur vectors Z is required; */
/* = .FALSE.: Schur vectors are not required. */
/* N (input) INTEGER */
/* The order of the matrix H. N .GE. 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* It is assumed that H is already upper triangular in rows */
/* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, */
/* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a */
/* previous call to ZGEBAL, and then passed to ZGEHRD when the */
/* matrix output by ZGEBAL is reduced to Hessenberg form. */
/* Otherwise, ILO and IHI should be set to 1 and N, */
/* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. */
/* If N = 0, then ILO = 1 and IHI = 0. */
/* H (input/output) COMPLEX*16 array, dimension (LDH,N) */
/* On entry, the upper Hessenberg matrix H. */
/* On exit, if INFO = 0 and WANTT is .TRUE., then H */
/* contains the upper triangular matrix T from the Schur */
/* decomposition (the Schur form). If INFO = 0 and WANT is */
/* .FALSE., then the contents of H are unspecified on exit. */
/* (The output value of H when INFO.GT.0 is given under the */
/* description of INFO below.) */
/* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and */
/* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH .GE. max(1,N). */
/* W (output) COMPLEX*16 array, dimension (N) */
/* The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored */
/* in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are */
/* stored in the same order as on the diagonal of the Schur */
/* form returned in H, with W(i) = H(i,i). */
/* Z (input/output) COMPLEX*16 array, dimension (LDZ,IHI) */
/* If WANTZ is .FALSE., then Z is not referenced. */
/* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is */
/* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the */
/* orthogonal Schur factor of H(ILO:IHI,ILO:IHI). */
/* (The output value of Z when INFO.GT.0 is given under */
/* the description of INFO below.) */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. if WANTZ is .TRUE. */
/* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. */
/* WORK (workspace/output) COMPLEX*16 array, dimension LWORK */
/* On exit, if LWORK = -1, WORK(1) returns an estimate of */
/* the optimal value for LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK .GE. max(1,N) */
/* is sufficient, but LWORK typically as large as 6*N may */
/* be required for optimal performance. A workspace query */
/* to determine the optimal workspace size is recommended. */
/* If LWORK = -1, then ZLAQR4 does a workspace query. */
/* In this case, ZLAQR4 checks the input parameters and */
/* estimates the optimal workspace size for the given */
/* values of N, ILO and IHI. The estimate is returned */
/* in WORK(1). No error message related to LWORK is */
/* issued by XERBLA. Neither H nor Z are accessed. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* .GT. 0: if INFO = i, ZLAQR4 failed to compute all of */
/* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */
/* and WI contain those eigenvalues which have been */
/* successfully computed. (Failures are rare.) */
/* If INFO .GT. 0 and WANT is .FALSE., then on exit, */
/* the remaining unconverged eigenvalues are the eigen- */
/* values of the upper Hessenberg matrix rows and */
/* columns ILO through INFO of the final, output */
/* value of H. */
/* If INFO .GT. 0 and WANTT is .TRUE., then on exit */
/* (*) (initial value of H)*U = U*(final value of H) */
/* where U is a unitary matrix. The final */
/* value of H is upper Hessenberg and triangular in */
/* rows and columns INFO+1 through IHI. */
/* If INFO .GT. 0 and WANTZ is .TRUE., then on exit */
/* (final value of Z(ILO:IHI,ILOZ:IHIZ) */
/* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U */
/* where U is the unitary matrix in (*) (regard- */
/* less of the value of WANTT.) */
/* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not */
/* accessed. */
/* ================================================================ */
/* Based on contributions by */
/* Karen Braman and Ralph Byers, Department of Mathematics, */
/* University of Kansas, USA */
/* ================================================================ */
/* References: */
/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
/* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */
/* Performance, SIAM Journal of Matrix Analysis, volume 23, pages */
/* 929--947, 2002. */
/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
/* Algorithm Part II: Aggressive Early Deflation, SIAM Journal */
/* of Matrix Analysis, volume 23, pages 948--973, 2002. */
/* ================================================================ */
/* .. Parameters .. */
/* ==== Matrices of order NTINY or smaller must be processed by */
/* . ZLAHQR because of insufficient subdiagonal scratch space. */
/* . (This is a hard limit.) ==== */
/* ==== Exceptional deflation windows: try to cure rare */
/* . slow convergence by varying the size of the */
/* . deflation window after KEXNW iterations. ==== */
/* ==== Exceptional shifts: try to cure rare slow convergence */
/* . with ad-hoc exceptional shifts every KEXSH iterations. */
/* . ==== */
/* ==== The constant WILK1 is used to form the exceptional */
/* . shifts. ==== */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
/* Function Body */
*info = 0;
/* ==== Quick return for N = 0: nothing to do. ==== */
if (*n == 0) {
work[1].r = 1., work[1].i = 0.;
return 0;
}
if (*n <= 11) {
/* ==== Tiny matrices must use ZLAHQR. ==== */
lwkopt = 1;
if (*lwork != -1) {
zlahqr_(wantt, wantz, n, ilo, ihi, &h__[h_offset], ldh, &w[1],
iloz, ihiz, &z__[z_offset], ldz, info);
}
} else {
/* ==== Use small bulge multi-shift QR with aggressive early */
/* . deflation on larger-than-tiny matrices. ==== */
/* ==== Hope for the best. ==== */
*info = 0;
/* ==== Set up job flags for ILAENV. ==== */
if (*wantt) {
*(unsigned char *)jbcmpz = 'S';
} else {
*(unsigned char *)jbcmpz = 'E';
}
if (*wantz) {
*(unsigned char *)&jbcmpz[1] = 'V';
} else {
*(unsigned char *)&jbcmpz[1] = 'N';
}
/* ==== NWR = recommended deflation window size. At this */
/* . point, N .GT. NTINY = 11, so there is enough */
/* . subdiagonal workspace for NWR.GE.2 as required. */
/* . (In fact, there is enough subdiagonal space for */
/* . NWR.GE.3.) ==== */
nwr = ilaenv_(&c__13, "ZLAQR4", jbcmpz, n, ilo, ihi, lwork);
nwr = max(2,nwr);
/* Computing MIN */
i__1 = *ihi - *ilo + 1, i__2 = (*n - 1) / 3, i__1 = min(i__1,i__2);
nwr = min(i__1,nwr);
/* ==== NSR = recommended number of simultaneous shifts. */
/* . At this point N .GT. NTINY = 11, so there is at */
/* . enough subdiagonal workspace for NSR to be even */
/* . and greater than or equal to two as required. ==== */
nsr = ilaenv_(&c__15, "ZLAQR4", jbcmpz, n, ilo, ihi, lwork);
/* Computing MIN */
i__1 = nsr, i__2 = (*n + 6) / 9, i__1 = min(i__1,i__2), i__2 = *ihi -
*ilo;
nsr = min(i__1,i__2);
/* Computing MAX */
i__1 = 2, i__2 = nsr - nsr % 2;
nsr = max(i__1,i__2);
/* ==== Estimate optimal workspace ==== */
/* ==== Workspace query call to ZLAQR2 ==== */
i__1 = nwr + 1;
zlaqr2_(wantt, wantz, n, ilo, ihi, &i__1, &h__[h_offset], ldh, iloz,
ihiz, &z__[z_offset], ldz, &ls, &ld, &w[1], &h__[h_offset],
ldh, n, &h__[h_offset], ldh, n, &h__[h_offset], ldh, &work[1],
&c_n1);
/* ==== Optimal workspace = MAX(ZLAQR5, ZLAQR2) ==== */
/* Computing MAX */
i__1 = nsr * 3 / 2, i__2 = (integer) work[1].r;
lwkopt = max(i__1,i__2);
/* ==== Quick return in case of workspace query. ==== */
if (*lwork == -1) {
d__1 = (doublereal) lwkopt;
z__1.r = d__1, z__1.i = 0.;
work[1].r = z__1.r, work[1].i = z__1.i;
return 0;
}
/* ==== ZLAHQR/ZLAQR0 crossover point ==== */
nmin = ilaenv_(&c__12, "ZLAQR4", jbcmpz, n, ilo, ihi, lwork);
nmin = max(11,nmin);
/* ==== Nibble crossover point ==== */
nibble = ilaenv_(&c__14, "ZLAQR4", jbcmpz, n, ilo, ihi, lwork);
nibble = max(0,nibble);
/* ==== Accumulate reflections during ttswp? Use block */
/* . 2-by-2 structure during matrix-matrix multiply? ==== */
kacc22 = ilaenv_(&c__16, "ZLAQR4", jbcmpz, n, ilo, ihi, lwork);
kacc22 = max(0,kacc22);
kacc22 = min(2,kacc22);
/* ==== NWMAX = the largest possible deflation window for */
/* . which there is sufficient workspace. ==== */
/* Computing MIN */
i__1 = (*n - 1) / 3, i__2 = *lwork / 2;
nwmax = min(i__1,i__2);
nw = nwmax;
/* ==== NSMAX = the Largest number of simultaneous shifts */
/* . for which there is sufficient workspace. ==== */
/* Computing MIN */
i__1 = (*n + 6) / 9, i__2 = (*lwork << 1) / 3;
nsmax = min(i__1,i__2);
nsmax -= nsmax % 2;
/* ==== NDFL: an iteration count restarted at deflation. ==== */
ndfl = 1;
/* ==== ITMAX = iteration limit ==== */
/* Computing MAX */
i__1 = 10, i__2 = *ihi - *ilo + 1;
itmax = max(i__1,i__2) * 30;
/* ==== Last row and column in the active block ==== */
kbot = *ihi;
/* ==== Main Loop ==== */
i__1 = itmax;
for (it = 1; it <= i__1; ++it) {
/* ==== Done when KBOT falls below ILO ==== */
if (kbot < *ilo) {
goto L80;
}
/* ==== Locate active block ==== */
i__2 = *ilo + 1;
for (k = kbot; k >= i__2; --k) {
i__3 = k + (k - 1) * h_dim1;
if (h__[i__3].r == 0. && h__[i__3].i == 0.) {
goto L20;
}
/* L10: */
}
k = *ilo;
L20:
ktop = k;
/* ==== Select deflation window size: */
/* . Typical Case: */
/* . If possible and advisable, nibble the entire */
/* . active block. If not, use size MIN(NWR,NWMAX) */
/* . or MIN(NWR+1,NWMAX) depending upon which has */
/* . the smaller corresponding subdiagonal entry */
/* . (a heuristic). */
/* . */
/* . Exceptional Case: */
/* . If there have been no deflations in KEXNW or */
/* . more iterations, then vary the deflation window */
/* . size. At first, because, larger windows are, */
/* . in general, more powerful than smaller ones, */
/* . rapidly increase the window to the maximum possible. */
/* . Then, gradually reduce the window size. ==== */
nh = kbot - ktop + 1;
nwupbd = min(nh,nwmax);
if (ndfl < 5) {
nw = min(nwupbd,nwr);
} else {
/* Computing MIN */
i__2 = nwupbd, i__3 = nw << 1;
nw = min(i__2,i__3);
}
if (nw < nwmax) {
if (nw >= nh - 1) {
nw = nh;
} else {
kwtop = kbot - nw + 1;
i__2 = kwtop + (kwtop - 1) * h_dim1;
i__3 = kwtop - 1 + (kwtop - 2) * h_dim1;
if ((d__1 = h__[i__2].r, abs(d__1)) + (d__2 = d_imag(&h__[
kwtop + (kwtop - 1) * h_dim1]), abs(d__2)) > (
d__3 = h__[i__3].r, abs(d__3)) + (d__4 = d_imag(&
h__[kwtop - 1 + (kwtop - 2) * h_dim1]), abs(d__4))
) {
++nw;
}
}
}
if (ndfl < 5) {
ndec = -1;
} else if (ndec >= 0 || nw >= nwupbd) {
++ndec;
if (nw - ndec < 2) {
ndec = 0;
}
nw -= ndec;
}
/* ==== Aggressive early deflation: */
/* . split workspace under the subdiagonal into */
/* . - an nw-by-nw work array V in the lower */
/* . left-hand-corner, */
/* . - an NW-by-at-least-NW-but-more-is-better */
/* . (NW-by-NHO) horizontal work array along */
/* . the bottom edge, */
/* . - an at-least-NW-but-more-is-better (NHV-by-NW) */
/* . vertical work array along the left-hand-edge. */
/* . ==== */
kv = *n - nw + 1;
kt = nw + 1;
nho = *n - nw - 1 - kt + 1;
kwv = nw + 2;
nve = *n - nw - kwv + 1;
/* ==== Aggressive early deflation ==== */
zlaqr2_(wantt, wantz, n, &ktop, &kbot, &nw, &h__[h_offset], ldh,
iloz, ihiz, &z__[z_offset], ldz, &ls, &ld, &w[1], &h__[kv
+ h_dim1], ldh, &nho, &h__[kv + kt * h_dim1], ldh, &nve, &
h__[kwv + h_dim1], ldh, &work[1], lwork);
/* ==== Adjust KBOT accounting for new deflations. ==== */
kbot -= ld;
/* ==== KS points to the shifts. ==== */
ks = kbot - ls + 1;
/* ==== Skip an expensive QR sweep if there is a (partly */
/* . heuristic) reason to expect that many eigenvalues */
/* . will deflate without it. Here, the QR sweep is */
/* . skipped if many eigenvalues have just been deflated */
/* . or if the remaining active block is small. */
if (ld == 0 || ld * 100 <= nw * nibble && kbot - ktop + 1 > min(
nmin,nwmax)) {
/* ==== NS = nominal number of simultaneous shifts. */
/* . This may be lowered (slightly) if ZLAQR2 */
/* . did not provide that many shifts. ==== */
/* Computing MIN */
/* Computing MAX */
i__4 = 2, i__5 = kbot - ktop;
i__2 = min(nsmax,nsr), i__3 = max(i__4,i__5);
ns = min(i__2,i__3);
ns -= ns % 2;
/* ==== If there have been no deflations */
/* . in a multiple of KEXSH iterations, */
/* . then try exceptional shifts. */
/* . Otherwise use shifts provided by */
/* . ZLAQR2 above or from the eigenvalues */
/* . of a trailing principal submatrix. ==== */
if (ndfl % 6 == 0) {
ks = kbot - ns + 1;
i__2 = ks + 1;
for (i__ = kbot; i__ >= i__2; i__ += -2) {
i__3 = i__;
i__4 = i__ + i__ * h_dim1;
i__5 = i__ + (i__ - 1) * h_dim1;
d__3 = ((d__1 = h__[i__5].r, abs(d__1)) + (d__2 =
d_imag(&h__[i__ + (i__ - 1) * h_dim1]), abs(
d__2))) * .75;
z__1.r = h__[i__4].r + d__3, z__1.i = h__[i__4].i;
w[i__3].r = z__1.r, w[i__3].i = z__1.i;
i__3 = i__ - 1;
i__4 = i__;
w[i__3].r = w[i__4].r, w[i__3].i = w[i__4].i;
/* L30: */
}
} else {
/* ==== Got NS/2 or fewer shifts? Use ZLAHQR */
/* . on a trailing principal submatrix to */
/* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, */
/* . there is enough space below the subdiagonal */
/* . to fit an NS-by-NS scratch array.) ==== */
if (kbot - ks + 1 <= ns / 2) {
ks = kbot - ns + 1;
kt = *n - ns + 1;
zlacpy_("A", &ns, &ns, &h__[ks + ks * h_dim1], ldh, &
h__[kt + h_dim1], ldh);
zlahqr_(&c_false, &c_false, &ns, &c__1, &ns, &h__[kt
+ h_dim1], ldh, &w[ks], &c__1, &c__1, zdum, &
c__1, &inf);
ks += inf;
/* ==== In case of a rare QR failure use */
/* . eigenvalues of the trailing 2-by-2 */
/* . principal submatrix. Scale to avoid */
/* . overflows, underflows and subnormals. */
/* . (The scale factor S can not be zero, */
/* . because H(KBOT,KBOT-1) is nonzero.) ==== */
if (ks >= kbot) {
i__2 = kbot - 1 + (kbot - 1) * h_dim1;
i__3 = kbot + (kbot - 1) * h_dim1;
i__4 = kbot - 1 + kbot * h_dim1;
i__5 = kbot + kbot * h_dim1;
s = (d__1 = h__[i__2].r, abs(d__1)) + (d__2 =
d_imag(&h__[kbot - 1 + (kbot - 1) *
h_dim1]), abs(d__2)) + ((d__3 = h__[i__3]
.r, abs(d__3)) + (d__4 = d_imag(&h__[kbot
+ (kbot - 1) * h_dim1]), abs(d__4))) + ((
d__5 = h__[i__4].r, abs(d__5)) + (d__6 =
d_imag(&h__[kbot - 1 + kbot * h_dim1]),
abs(d__6))) + ((d__7 = h__[i__5].r, abs(
d__7)) + (d__8 = d_imag(&h__[kbot + kbot *
h_dim1]), abs(d__8)));
i__2 = kbot - 1 + (kbot - 1) * h_dim1;
z__1.r = h__[i__2].r / s, z__1.i = h__[i__2].i /
s;
aa.r = z__1.r, aa.i = z__1.i;
i__2 = kbot + (kbot - 1) * h_dim1;
z__1.r = h__[i__2].r / s, z__1.i = h__[i__2].i /
s;
cc.r = z__1.r, cc.i = z__1.i;
i__2 = kbot - 1 + kbot * h_dim1;
z__1.r = h__[i__2].r / s, z__1.i = h__[i__2].i /
s;
bb.r = z__1.r, bb.i = z__1.i;
i__2 = kbot + kbot * h_dim1;
z__1.r = h__[i__2].r / s, z__1.i = h__[i__2].i /
s;
dd.r = z__1.r, dd.i = z__1.i;
z__2.r = aa.r + dd.r, z__2.i = aa.i + dd.i;
z__1.r = z__2.r / 2., z__1.i = z__2.i / 2.;
tr2.r = z__1.r, tr2.i = z__1.i;
z__3.r = aa.r - tr2.r, z__3.i = aa.i - tr2.i;
z__4.r = dd.r - tr2.r, z__4.i = dd.i - tr2.i;
z__2.r = z__3.r * z__4.r - z__3.i * z__4.i,
z__2.i = z__3.r * z__4.i + z__3.i *
z__4.r;
z__5.r = bb.r * cc.r - bb.i * cc.i, z__5.i = bb.r
* cc.i + bb.i * cc.r;
z__1.r = z__2.r - z__5.r, z__1.i = z__2.i -
z__5.i;
det.r = z__1.r, det.i = z__1.i;
z__2.r = -det.r, z__2.i = -det.i;
z_sqrt(&z__1, &z__2);
rtdisc.r = z__1.r, rtdisc.i = z__1.i;
i__2 = kbot - 1;
z__2.r = tr2.r + rtdisc.r, z__2.i = tr2.i +
rtdisc.i;
z__1.r = s * z__2.r, z__1.i = s * z__2.i;
w[i__2].r = z__1.r, w[i__2].i = z__1.i;
i__2 = kbot;
z__2.r = tr2.r - rtdisc.r, z__2.i = tr2.i -
rtdisc.i;
z__1.r = s * z__2.r, z__1.i = s * z__2.i;
w[i__2].r = z__1.r, w[i__2].i = z__1.i;
ks = kbot - 1;
}
}
if (kbot - ks + 1 > ns) {
/* ==== Sort the shifts (Helps a little) ==== */
sorted = FALSE_;
i__2 = ks + 1;
for (k = kbot; k >= i__2; --k) {
if (sorted) {
goto L60;
}
sorted = TRUE_;
i__3 = k - 1;
for (i__ = ks; i__ <= i__3; ++i__) {
i__4 = i__;
i__5 = i__ + 1;
if ((d__1 = w[i__4].r, abs(d__1)) + (d__2 =
d_imag(&w[i__]), abs(d__2)) < (d__3 =
w[i__5].r, abs(d__3)) + (d__4 =
d_imag(&w[i__ + 1]), abs(d__4))) {
sorted = FALSE_;
i__4 = i__;
swap.r = w[i__4].r, swap.i = w[i__4].i;
i__4 = i__;
i__5 = i__ + 1;
w[i__4].r = w[i__5].r, w[i__4].i = w[i__5]
.i;
i__4 = i__ + 1;
w[i__4].r = swap.r, w[i__4].i = swap.i;
}
/* L40: */
}
/* L50: */
}
L60:
;
}
}
/* ==== If there are only two shifts, then use */
/* . only one. ==== */
if (kbot - ks + 1 == 2) {
i__2 = kbot;
i__3 = kbot + kbot * h_dim1;
z__2.r = w[i__2].r - h__[i__3].r, z__2.i = w[i__2].i -
h__[i__3].i;
z__1.r = z__2.r, z__1.i = z__2.i;
i__4 = kbot - 1;
i__5 = kbot + kbot * h_dim1;
z__4.r = w[i__4].r - h__[i__5].r, z__4.i = w[i__4].i -
h__[i__5].i;
z__3.r = z__4.r, z__3.i = z__4.i;
if ((d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1),
abs(d__2)) < (d__3 = z__3.r, abs(d__3)) + (d__4 =
d_imag(&z__3), abs(d__4))) {
i__2 = kbot - 1;
i__3 = kbot;
w[i__2].r = w[i__3].r, w[i__2].i = w[i__3].i;
} else {
i__2 = kbot;
i__3 = kbot - 1;
w[i__2].r = w[i__3].r, w[i__2].i = w[i__3].i;
}
}
/* ==== Use up to NS of the the smallest magnatiude */
/* . shifts. If there aren't NS shifts available, */
/* . then use them all, possibly dropping one to */
/* . make the number of shifts even. ==== */
/* Computing MIN */
i__2 = ns, i__3 = kbot - ks + 1;
ns = min(i__2,i__3);
ns -= ns % 2;
ks = kbot - ns + 1;
/* ==== Small-bulge multi-shift QR sweep: */
/* . split workspace under the subdiagonal into */
/* . - a KDU-by-KDU work array U in the lower */
/* . left-hand-corner, */
/* . - a KDU-by-at-least-KDU-but-more-is-better */
/* . (KDU-by-NHo) horizontal work array WH along */
/* . the bottom edge, */
/* . - and an at-least-KDU-but-more-is-better-by-KDU */
/* . (NVE-by-KDU) vertical work WV arrow along */
/* . the left-hand-edge. ==== */
kdu = ns * 3 - 3;
ku = *n - kdu + 1;
kwh = kdu + 1;
nho = *n - kdu - 3 - (kdu + 1) + 1;
kwv = kdu + 4;
nve = *n - kdu - kwv + 1;
/* ==== Small-bulge multi-shift QR sweep ==== */
zlaqr5_(wantt, wantz, &kacc22, n, &ktop, &kbot, &ns, &w[ks], &
h__[h_offset], ldh, iloz, ihiz, &z__[z_offset], ldz, &
work[1], &c__3, &h__[ku + h_dim1], ldh, &nve, &h__[
kwv + h_dim1], ldh, &nho, &h__[ku + kwh * h_dim1],
ldh);
}
/* ==== Note progress (or the lack of it). ==== */
if (ld > 0) {
ndfl = 1;
} else {
++ndfl;
}
/* ==== End of main loop ==== */
/* L70: */
}
/* ==== Iteration limit exceeded. Set INFO to show where */
/* . the problem occurred and exit. ==== */
*info = kbot;
L80:
;
}
/* ==== Return the optimal value of LWORK. ==== */
d__1 = (doublereal) lwkopt;
z__1.r = d__1, z__1.i = 0.;
work[1].r = z__1.r, work[1].i = z__1.i;
/* ==== End of ZLAQR4 ==== */
return 0;
} /* zlaqr4_ */
/* ----------------------------------------------------------------------- */
/* Subroutine */ int zneupd_(logical *rvec, char *howmny, logical *select,
doublecomplex *d__, doublecomplex *z__, integer *ldz, doublecomplex *
sigma, doublecomplex *workev, char *bmat, integer *n, char *which,
integer *nev, doublereal *tol, doublecomplex *resid, integer *ncv,
doublecomplex *v, integer *ldv, integer *iparam, integer *ipntr,
doublecomplex *workd, doublecomplex *workl, integer *lworkl,
doublereal *rwork, integer *info, ftnlen howmny_len, ftnlen bmat_len,
ftnlen which_len)
{
/* System generated locals */
integer v_dim1, v_offset, z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2;
/* Builtin functions */
double pow_dd(doublereal *, doublereal *);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double d_imag(doublecomplex *);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
/* Local variables */
static integer j, k, ih, jj, iq, np;
static doublecomplex vl[1];
static integer wr, ibd, ldh, ldq;
static doublereal sep;
static integer irz, mode;
static doublereal eps23;
static integer ierr;
static doublecomplex temp;
static integer iwev;
static char type__[6];
static integer ritz, iheig, ihbds;
static doublereal conds;
static logical reord;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
static integer nconv;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static doublereal rtemp;
static doublecomplex rnorm;
extern /* Subroutine */ int zgeru_(integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zcopy_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *), ivout_(integer *, integer
*, integer *, integer *, char *, ftnlen), ztrmm_(char *, char *,
char *, char *, integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, ftnlen,
ftnlen, ftnlen, ftnlen), zmout_(integer *, integer *, integer *,
doublecomplex *, integer *, integer *, char *, ftnlen), zvout_(
integer *, integer *, doublecomplex *, integer *, char *, ftnlen);
extern doublereal dlapy2_(doublereal *, doublereal *);
extern /* Subroutine */ int zgeqr2_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_(
char *, ftnlen);
extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, ftnlen,
ftnlen);
static integer bounds, invsub, iuptri, msglvl, outncv, numcnv, ishift;
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, ftnlen),
zlahqr_(logical *, logical *, integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *,
doublecomplex *, integer *, integer *), zngets_(integer *, char *
, integer *, integer *, doublecomplex *, doublecomplex *, ftnlen),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *, ftnlen), ztrsen_(
char *, char *, logical *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublecomplex *, integer *, integer *,
ftnlen, ftnlen), ztrevc_(char *, char *, logical *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, integer *, doublecomplex *,
doublereal *, integer *, ftnlen, ftnlen), zdscal_(integer *,
doublereal *, doublecomplex *, integer *);
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %---------------% */
/* | Local Scalars | */
/* %---------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
/* %------------------------% */
/* | Set default parameters | */
/* %------------------------% */
/* Parameter adjustments */
--workd;
--resid;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--d__;
--rwork;
--workev;
--select;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--iparam;
--ipntr;
--workl;
/* Function Body */
msglvl = debug_1.mceupd;
mode = iparam[7];
nconv = iparam[5];
*info = 0;
/* %---------------------------------% */
/* | Get machine dependent constant. | */
/* %---------------------------------% */
eps23 = dlamch_("Epsilon-Machine", (ftnlen)15);
eps23 = pow_dd(&eps23, &c_b5);
/* %-------------------------------% */
/* | Quick return | */
/* | Check for incompatible input | */
/* %-------------------------------% */
ierr = 0;
if (nconv <= 0) {
ierr = -14;
} else if (*n <= 0) {
ierr = -1;
} else if (*nev <= 0) {
ierr = -2;
} else if (*ncv <= *nev || *ncv > *n) {
ierr = -3;
} else if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which,
"SM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "LR", (ftnlen)2,
(ftnlen)2) != 0 && s_cmp(which, "SR", (ftnlen)2, (ftnlen)2) != 0
&& s_cmp(which, "LI", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which,
"SI", (ftnlen)2, (ftnlen)2) != 0) {
ierr = -5;
} else if (*(unsigned char *)bmat != 'I' && *(unsigned char *)bmat != 'G')
{
ierr = -6;
} else /* if(complicated condition) */ {
/* Computing 2nd power */
i__1 = *ncv;
if (*lworkl < i__1 * i__1 * 3 + (*ncv << 2)) {
ierr = -7;
} else if (*(unsigned char *)howmny != 'A' && *(unsigned char *)
howmny != 'P' && *(unsigned char *)howmny != 'S' && *rvec) {
ierr = -13;
} else if (*(unsigned char *)howmny == 'S') {
ierr = -12;
}
}
if (mode == 1 || mode == 2) {
s_copy(type__, "REGULR", (ftnlen)6, (ftnlen)6);
} else if (mode == 3) {
s_copy(type__, "SHIFTI", (ftnlen)6, (ftnlen)6);
} else {
ierr = -10;
}
if (mode == 1 && *(unsigned char *)bmat == 'G') {
ierr = -11;
}
/* %------------% */
/* | Error Exit | */
/* %------------% */
if (ierr != 0) {
*info = ierr;
goto L9000;
}
/* %--------------------------------------------------------% */
/* | Pointer into WORKL for address of H, RITZ, WORKEV, Q | */
/* | etc... and the remaining workspace. | */
/* | Also update pointer to be used on output. | */
/* | Memory is laid out as follows: | */
/* | workl(1:ncv*ncv) := generated Hessenberg matrix | */
/* | workl(ncv*ncv+1:ncv*ncv+ncv) := ritz values | */
/* | workl(ncv*ncv+ncv+1:ncv*ncv+2*ncv) := error bounds | */
/* %--------------------------------------------------------% */
/* %-----------------------------------------------------------% */
/* | The following is used and set by ZNEUPD. | */
/* | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := The untransformed | */
/* | Ritz values. | */
/* | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed | */
/* | error bounds of | */
/* | the Ritz values | */
/* | workl(ncv*ncv+4*ncv+1:2*ncv*ncv+4*ncv) := Holds the upper | */
/* | triangular matrix | */
/* | for H. | */
/* | workl(2*ncv*ncv+4*ncv+1: 3*ncv*ncv+4*ncv) := Holds the | */
/* | associated matrix | */
/* | representation of | */
/* | the invariant | */
/* | subspace for H. | */
/* | GRAND total of NCV * ( 3 * NCV + 4 ) locations. | */
/* %-----------------------------------------------------------% */
ih = ipntr[5];
ritz = ipntr[6];
iq = ipntr[7];
bounds = ipntr[8];
ldh = *ncv;
ldq = *ncv;
iheig = bounds + ldh;
ihbds = iheig + ldh;
iuptri = ihbds + ldh;
invsub = iuptri + ldh * *ncv;
ipntr[9] = iheig;
ipntr[11] = ihbds;
ipntr[12] = iuptri;
ipntr[13] = invsub;
wr = 1;
iwev = wr + *ncv;
/* %-----------------------------------------% */
/* | irz points to the Ritz values computed | */
/* | by _neigh before exiting _naup2. | */
/* | ibd points to the Ritz estimates | */
/* | computed by _neigh before exiting | */
/* | _naup2. | */
/* %-----------------------------------------% */
irz = ipntr[14] + *ncv * *ncv;
ibd = irz + *ncv;
/* %------------------------------------% */
/* | RNORM is B-norm of the RESID(1:N). | */
/* %------------------------------------% */
i__1 = ih + 2;
rnorm.r = workl[i__1].r, rnorm.i = workl[i__1].i;
i__1 = ih + 2;
workl[i__1].r = 0., workl[i__1].i = 0.;
if (msglvl > 2) {
zvout_(&debug_1.logfil, ncv, &workl[irz], &debug_1.ndigit, "_neupd: "
"Ritz values passed in from _NAUPD.", (ftnlen)42);
zvout_(&debug_1.logfil, ncv, &workl[ibd], &debug_1.ndigit, "_neupd: "
"Ritz estimates passed in from _NAUPD.", (ftnlen)45);
}
if (*rvec) {
reord = FALSE_;
/* %---------------------------------------------------% */
/* | Use the temporary bounds array to store indices | */
/* | These will be used to mark the select array later | */
/* %---------------------------------------------------% */
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
i__2 = bounds + j - 1;
workl[i__2].r = (doublereal) j, workl[i__2].i = 0.;
select[j] = FALSE_;
/* L10: */
}
/* %-------------------------------------% */
/* | Select the wanted Ritz values. | */
/* | Sort the Ritz values so that the | */
/* | wanted ones appear at the tailing | */
/* | NEV positions of workl(irr) and | */
/* | workl(iri). Move the corresponding | */
/* | error estimates in workl(ibd) | */
/* | accordingly. | */
/* %-------------------------------------% */
np = *ncv - *nev;
ishift = 0;
zngets_(&ishift, which, nev, &np, &workl[irz], &workl[bounds], (
ftnlen)2);
if (msglvl > 2) {
zvout_(&debug_1.logfil, ncv, &workl[irz], &debug_1.ndigit, "_neu"
"pd: Ritz values after calling _NGETS.", (ftnlen)41);
zvout_(&debug_1.logfil, ncv, &workl[bounds], &debug_1.ndigit,
"_neupd: Ritz value indices after calling _NGETS.", (
ftnlen)48);
}
/* %-----------------------------------------------------% */
/* | Record indices of the converged wanted Ritz values | */
/* | Mark the select array for possible reordering | */
/* %-----------------------------------------------------% */
numcnv = 0;
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = irz + *ncv - j;
d__3 = workl[i__2].r;
d__4 = d_imag(&workl[irz + *ncv - j]);
d__1 = eps23, d__2 = dlapy2_(&d__3, &d__4);
rtemp = max(d__1,d__2);
i__2 = bounds + *ncv - j;
jj = (integer) workl[i__2].r;
i__2 = ibd + jj - 1;
d__1 = workl[i__2].r;
d__2 = d_imag(&workl[ibd + jj - 1]);
if (numcnv < nconv && dlapy2_(&d__1, &d__2) <= *tol * rtemp) {
select[jj] = TRUE_;
++numcnv;
if (jj > *nev) {
reord = TRUE_;
}
}
/* L11: */
}
/* %-----------------------------------------------------------% */
/* | Check the count (numcnv) of converged Ritz values with | */
/* | the number (nconv) reported by dnaupd. If these two | */
/* | are different then there has probably been an error | */
/* | caused by incorrect passing of the dnaupd data. | */
/* %-----------------------------------------------------------% */
if (msglvl > 2) {
ivout_(&debug_1.logfil, &c__1, &numcnv, &debug_1.ndigit, "_neupd"
": Number of specified eigenvalues", (ftnlen)39);
ivout_(&debug_1.logfil, &c__1, &nconv, &debug_1.ndigit, "_neupd:"
" Number of \"converged\" eigenvalues", (ftnlen)41);
}
if (numcnv != nconv) {
*info = -15;
goto L9000;
}
/* %-------------------------------------------------------% */
/* | Call LAPACK routine zlahqr to compute the Schur form | */
/* | of the upper Hessenberg matrix returned by ZNAUPD. | */
/* | Make a copy of the upper Hessenberg matrix. | */
/* | Initialize the Schur vector matrix Q to the identity. | */
/* %-------------------------------------------------------% */
i__1 = ldh * *ncv;
zcopy_(&i__1, &workl[ih], &c__1, &workl[iuptri], &c__1);
zlaset_("All", ncv, ncv, &c_b2, &c_b1, &workl[invsub], &ldq, (ftnlen)
3);
zlahqr_(&c_true, &c_true, ncv, &c__1, ncv, &workl[iuptri], &ldh, &
workl[iheig], &c__1, ncv, &workl[invsub], &ldq, &ierr);
zcopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], &c__1);
if (ierr != 0) {
*info = -8;
goto L9000;
}
if (msglvl > 1) {
zvout_(&debug_1.logfil, ncv, &workl[iheig], &debug_1.ndigit,
"_neupd: Eigenvalues of H", (ftnlen)24);
zvout_(&debug_1.logfil, ncv, &workl[ihbds], &debug_1.ndigit,
"_neupd: Last row of the Schur vector matrix", (ftnlen)43)
;
if (msglvl > 3) {
zmout_(&debug_1.logfil, ncv, ncv, &workl[iuptri], &ldh, &
debug_1.ndigit, "_neupd: The upper triangular matrix "
, (ftnlen)36);
}
}
if (reord) {
/* %-----------------------------------------------% */
/* | Reorder the computed upper triangular matrix. | */
/* %-----------------------------------------------% */
ztrsen_("None", "V", &select[1], ncv, &workl[iuptri], &ldh, &
workl[invsub], &ldq, &workl[iheig], &nconv, &conds, &sep,
&workev[1], ncv, &ierr, (ftnlen)4, (ftnlen)1);
if (ierr == 1) {
*info = 1;
goto L9000;
}
if (msglvl > 2) {
zvout_(&debug_1.logfil, ncv, &workl[iheig], &debug_1.ndigit,
"_neupd: Eigenvalues of H--reordered", (ftnlen)35);
if (msglvl > 3) {
zmout_(&debug_1.logfil, ncv, ncv, &workl[iuptri], &ldq, &
debug_1.ndigit, "_neupd: Triangular matrix after"
" re-ordering", (ftnlen)43);
}
}
}
/* %---------------------------------------------% */
/* | Copy the last row of the Schur basis matrix | */
/* | to workl(ihbds). This vector will be used | */
/* | to compute the Ritz estimates of converged | */
/* | Ritz values. | */
/* %---------------------------------------------% */
zcopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], &c__1);
/* %--------------------------------------------% */
/* | Place the computed eigenvalues of H into D | */
/* | if a spectral transformation was not used. | */
/* %--------------------------------------------% */
if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0) {
zcopy_(&nconv, &workl[iheig], &c__1, &d__[1], &c__1);
}
/* %----------------------------------------------------------% */
/* | Compute the QR factorization of the matrix representing | */
/* | the wanted invariant subspace located in the first NCONV | */
/* | columns of workl(invsub,ldq). | */
/* %----------------------------------------------------------% */
zgeqr2_(ncv, &nconv, &workl[invsub], &ldq, &workev[1], &workev[*ncv +
1], &ierr);
/* %--------------------------------------------------------% */
/* | * Postmultiply V by Q using zunm2r. | */
/* | * Copy the first NCONV columns of VQ into Z. | */
/* | * Postmultiply Z by R. | */
/* | The N by NCONV matrix Z is now a matrix representation | */
/* | of the approximate invariant subspace associated with | */
/* | the Ritz values in workl(iheig). The first NCONV | */
/* | columns of V are now approximate Schur vectors | */
/* | associated with the upper triangular matrix of order | */
/* | NCONV in workl(iuptri). | */
/* %--------------------------------------------------------% */
zunm2r_("Right", "Notranspose", n, ncv, &nconv, &workl[invsub], &ldq,
&workev[1], &v[v_offset], ldv, &workd[*n + 1], &ierr, (ftnlen)
5, (ftnlen)11);
zlacpy_("All", n, &nconv, &v[v_offset], ldv, &z__[z_offset], ldz, (
ftnlen)3);
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
/* %---------------------------------------------------% */
/* | Perform both a column and row scaling if the | */
/* | diagonal element of workl(invsub,ldq) is negative | */
/* | I'm lazy and don't take advantage of the upper | */
/* | triangular form of workl(iuptri,ldq). | */
/* | Note that since Q is orthogonal, R is a diagonal | */
/* | matrix consisting of plus or minus ones. | */
/* %---------------------------------------------------% */
i__2 = invsub + (j - 1) * ldq + j - 1;
if (workl[i__2].r < 0.) {
z__1.r = -1., z__1.i = -0.;
zscal_(&nconv, &z__1, &workl[iuptri + j - 1], &ldq);
z__1.r = -1., z__1.i = -0.;
zscal_(&nconv, &z__1, &workl[iuptri + (j - 1) * ldq], &c__1);
}
/* L20: */
}
if (*(unsigned char *)howmny == 'A') {
/* %--------------------------------------------% */
/* | Compute the NCONV wanted eigenvectors of T | */
/* | located in workl(iuptri,ldq). | */
/* %--------------------------------------------% */
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
if (j <= nconv) {
select[j] = TRUE_;
} else {
select[j] = FALSE_;
}
/* L30: */
}
ztrevc_("Right", "Select", &select[1], ncv, &workl[iuptri], &ldq,
vl, &c__1, &workl[invsub], &ldq, ncv, &outncv, &workev[1],
&rwork[1], &ierr, (ftnlen)5, (ftnlen)6);
if (ierr != 0) {
*info = -9;
goto L9000;
}
/* %------------------------------------------------% */
/* | Scale the returning eigenvectors so that their | */
/* | Euclidean norms are all one. LAPACK subroutine | */
/* | ztrevc returns each eigenvector normalized so | */
/* | that the element of largest magnitude has | */
/* | magnitude 1. | */
/* %------------------------------------------------% */
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
rtemp = dznrm2_(ncv, &workl[invsub + (j - 1) * ldq], &c__1);
rtemp = 1. / rtemp;
zdscal_(ncv, &rtemp, &workl[invsub + (j - 1) * ldq], &c__1);
/* %------------------------------------------% */
/* | Ritz estimates can be obtained by taking | */
/* | the inner product of the last row of the | */
/* | Schur basis of H with eigenvectors of T. | */
/* | Note that the eigenvector matrix of T is | */
/* | upper triangular, thus the length of the | */
/* | inner product can be set to j. | */
/* %------------------------------------------% */
i__2 = j;
zdotc_(&z__1, &j, &workl[ihbds], &c__1, &workl[invsub + (j -
1) * ldq], &c__1);
workev[i__2].r = z__1.r, workev[i__2].i = z__1.i;
/* L40: */
}
if (msglvl > 2) {
zcopy_(&nconv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds],
&c__1);
zvout_(&debug_1.logfil, &nconv, &workl[ihbds], &
debug_1.ndigit, "_neupd: Last row of the eigenvector"
" matrix for T", (ftnlen)48);
if (msglvl > 3) {
zmout_(&debug_1.logfil, ncv, ncv, &workl[invsub], &ldq, &
debug_1.ndigit, "_neupd: The eigenvector matrix "
"for T", (ftnlen)36);
}
}
/* %---------------------------------------% */
/* | Copy Ritz estimates into workl(ihbds) | */
/* %---------------------------------------% */
zcopy_(&nconv, &workev[1], &c__1, &workl[ihbds], &c__1);
/* %----------------------------------------------% */
/* | The eigenvector matrix Q of T is triangular. | */
/* | Form Z*Q. | */
/* %----------------------------------------------% */
ztrmm_("Right", "Upper", "No transpose", "Non-unit", n, &nconv, &
c_b1, &workl[invsub], &ldq, &z__[z_offset], ldz, (ftnlen)
5, (ftnlen)5, (ftnlen)12, (ftnlen)8);
}
} else {
/* %--------------------------------------------------% */
/* | An approximate invariant subspace is not needed. | */
/* | Place the Ritz values computed ZNAUPD into D. | */
/* %--------------------------------------------------% */
zcopy_(&nconv, &workl[ritz], &c__1, &d__[1], &c__1);
zcopy_(&nconv, &workl[ritz], &c__1, &workl[iheig], &c__1);
zcopy_(&nconv, &workl[bounds], &c__1, &workl[ihbds], &c__1);
}
/* %------------------------------------------------% */
/* | Transform the Ritz values and possibly vectors | */
/* | and corresponding error bounds of OP to those | */
/* | of A*x = lambda*B*x. | */
/* %------------------------------------------------% */
if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0) {
if (*rvec) {
zscal_(ncv, &rnorm, &workl[ihbds], &c__1);
}
} else {
/* %---------------------------------------% */
/* | A spectral transformation was used. | */
/* | * Determine the Ritz estimates of the | */
/* | Ritz values in the original system. | */
/* %---------------------------------------% */
if (*rvec) {
zscal_(ncv, &rnorm, &workl[ihbds], &c__1);
}
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
i__2 = iheig + k - 1;
temp.r = workl[i__2].r, temp.i = workl[i__2].i;
i__2 = ihbds + k - 1;
z_div(&z__2, &workl[ihbds + k - 1], &temp);
z_div(&z__1, &z__2, &temp);
workl[i__2].r = z__1.r, workl[i__2].i = z__1.i;
/* L50: */
}
}
/* %-----------------------------------------------------------% */
/* | * Transform the Ritz values back to the original system. | */
/* | For TYPE = 'SHIFTI' the transformation is | */
/* | lambda = 1/theta + sigma | */
/* | NOTES: | */
/* | *The Ritz vectors are not affected by the transformation. | */
/* %-----------------------------------------------------------% */
if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = nconv;
for (k = 1; k <= i__1; ++k) {
i__2 = k;
z_div(&z__2, &c_b1, &workl[iheig + k - 1]);
z__1.r = z__2.r + sigma->r, z__1.i = z__2.i + sigma->i;
d__[i__2].r = z__1.r, d__[i__2].i = z__1.i;
/* L60: */
}
}
if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) != 0 && msglvl > 1) {
zvout_(&debug_1.logfil, &nconv, &d__[1], &debug_1.ndigit, "_neupd: U"
"ntransformed Ritz values.", (ftnlen)34);
zvout_(&debug_1.logfil, &nconv, &workl[ihbds], &debug_1.ndigit, "_ne"
"upd: Ritz estimates of the untransformed Ritz values.", (
ftnlen)56);
} else if (msglvl > 1) {
zvout_(&debug_1.logfil, &nconv, &d__[1], &debug_1.ndigit, "_neupd: C"
"onverged Ritz values.", (ftnlen)30);
zvout_(&debug_1.logfil, &nconv, &workl[ihbds], &debug_1.ndigit, "_ne"
"upd: Associated Ritz estimates.", (ftnlen)34);
}
/* %-------------------------------------------------% */
/* | Eigenvector Purification step. Formally perform | */
/* | one of inverse subspace iteration. Only used | */
/* | for MODE = 3. See reference 3. | */
/* %-------------------------------------------------% */
if (*rvec && *(unsigned char *)howmny == 'A' && s_cmp(type__, "SHIFTI", (
ftnlen)6, (ftnlen)6) == 0) {
/* %------------------------------------------------% */
/* | Purify the computed Ritz vectors by adding a | */
/* | little bit of the residual vector: | */
/* | T | */
/* | resid(:)*( e s ) / theta | */
/* | NCV | */
/* | where H s = s theta. | */
/* %------------------------------------------------% */
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
i__2 = iheig + j - 1;
if (workl[i__2].r != 0. || workl[i__2].i != 0.) {
i__2 = j;
z_div(&z__1, &workl[invsub + (j - 1) * ldq + *ncv - 1], &
workl[iheig + j - 1]);
workev[i__2].r = z__1.r, workev[i__2].i = z__1.i;
}
/* L100: */
}
/* %---------------------------------------% */
/* | Perform a rank one update to Z and | */
/* | purify all the Ritz vectors together. | */
/* %---------------------------------------% */
zgeru_(n, &nconv, &c_b1, &resid[1], &c__1, &workev[1], &c__1, &z__[
z_offset], ldz);
}
L9000:
return 0;
/* %---------------% */
/* | End of zneupd| */
/* %---------------% */
} /* zneupd_ */
/* Subroutine */ int zlaqr3_(logical *wantt, logical *wantz, integer *n,
integer *ktop, integer *kbot, integer *nw, doublecomplex *h__,
integer *ldh, integer *iloz, integer *ihiz, doublecomplex *z__,
integer *ldz, integer *ns, integer *nd, doublecomplex *sh,
doublecomplex *v, integer *ldv, integer *nh, doublecomplex *t,
integer *ldt, integer *nv, doublecomplex *wv, integer *ldwv,
doublecomplex *work, integer *lwork)
{
/* System generated locals */
integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1,
wv_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j;
doublecomplex s;
integer jw;
doublereal foo;
integer kln;
doublecomplex tau;
integer knt;
doublereal ulp;
integer lwk1, lwk2, lwk3;
doublecomplex beta;
integer kcol, info, nmin, ifst, ilst, ltop, krow;
extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *);
integer infqr;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
integer kwtop;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), dlabad_(doublereal *, doublereal *),
zlaqr4_(logical *, logical *, integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *
);
extern doublereal dlamch_(char *);
doublereal safmin;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
doublereal safmax;
extern /* Subroutine */ int zgehrd_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *), zlarfg_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *), zlahqr_(logical *,
logical *, integer *, integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, integer *, doublecomplex *,
integer *, integer *), zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *);
doublereal smlnum;
extern /* Subroutine */ int ztrexc_(char *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, integer *, integer *,
integer *);
integer lwkopt;
extern /* Subroutine */ int zunmhr_(char *, char *, integer *, integer *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *
);
/* -- LAPACK auxiliary routine (version 3.2.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
/* -- April 2009 -- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ****************************************************************** */
/* Aggressive early deflation: */
/* This subroutine accepts as input an upper Hessenberg matrix */
/* H and performs an unitary similarity transformation */
/* designed to detect and deflate fully converged eigenvalues from */
/* a trailing principal submatrix. On output H has been over- */
/* written by a new Hessenberg matrix that is a perturbation of */
/* an unitary similarity transformation of H. It is to be */
/* hoped that the final version of H has many zero subdiagonal */
/* entries. */
/* ****************************************************************** */
/* WANTT (input) LOGICAL */
/* If .TRUE., then the Hessenberg matrix H is fully updated */
/* so that the triangular Schur factor may be */
/* computed (in cooperation with the calling subroutine). */
/* If .FALSE., then only enough of H is updated to preserve */
/* the eigenvalues. */
/* WANTZ (input) LOGICAL */
/* If .TRUE., then the unitary matrix Z is updated so */
/* so that the unitary Schur factor may be computed */
/* (in cooperation with the calling subroutine). */
/* If .FALSE., then Z is not referenced. */
/* N (input) INTEGER */
/* The order of the matrix H and (if WANTZ is .TRUE.) the */
/* order of the unitary matrix Z. */
/* KTOP (input) INTEGER */
/* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. */
/* KBOT and KTOP together determine an isolated block */
/* along the diagonal of the Hessenberg matrix. */
/* KBOT (input) INTEGER */
/* It is assumed without a check that either */
/* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together */
/* determine an isolated block along the diagonal of the */
/* Hessenberg matrix. */
/* NW (input) INTEGER */
/* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). */
/* H (input/output) COMPLEX*16 array, dimension (LDH,N) */
/* On input the initial N-by-N section of H stores the */
/* Hessenberg matrix undergoing aggressive early deflation. */
/* On output H has been transformed by a unitary */
/* similarity transformation, perturbed, and the returned */
/* to Hessenberg form that (it is to be hoped) has some */
/* zero subdiagonal entries. */
/* LDH (input) integer */
/* Leading dimension of H just as declared in the calling */
/* subroutine. N .LE. LDH */
/* ILOZ (input) INTEGER */
/* IHIZ (input) INTEGER */
/* Specify the rows of Z to which transformations must be */
/* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. */
/* Z (input/output) COMPLEX*16 array, dimension (LDZ,N) */
/* IF WANTZ is .TRUE., then on output, the unitary */
/* similarity transformation mentioned above has been */
/* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. */
/* If WANTZ is .FALSE., then Z is unreferenced. */
/* LDZ (input) integer */
/* The leading dimension of Z just as declared in the */
/* calling subroutine. 1 .LE. LDZ. */
/* NS (output) integer */
/* The number of unconverged (ie approximate) eigenvalues */
/* returned in SR and SI that may be used as shifts by the */
/* calling subroutine. */
/* ND (output) integer */
/* The number of converged eigenvalues uncovered by this */
/* subroutine. */
/* SH (output) COMPLEX*16 array, dimension KBOT */
/* On output, approximate eigenvalues that may */
/* be used for shifts are stored in SH(KBOT-ND-NS+1) */
/* through SR(KBOT-ND). Converged eigenvalues are */
/* stored in SH(KBOT-ND+1) through SH(KBOT). */
/* V (workspace) COMPLEX*16 array, dimension (LDV,NW) */
/* An NW-by-NW work array. */
/* LDV (input) integer scalar */
/* The leading dimension of V just as declared in the */
/* calling subroutine. NW .LE. LDV */
/* NH (input) integer scalar */
/* The number of columns of T. NH.GE.NW. */
/* T (workspace) COMPLEX*16 array, dimension (LDT,NW) */
/* LDT (input) integer */
/* The leading dimension of T just as declared in the */
/* calling subroutine. NW .LE. LDT */
/* NV (input) integer */
/* The number of rows of work array WV available for */
/* workspace. NV.GE.NW. */
/* WV (workspace) COMPLEX*16 array, dimension (LDWV,NW) */
/* LDWV (input) integer */
/* The leading dimension of W just as declared in the */
/* calling subroutine. NW .LE. LDV */
/* WORK (workspace) COMPLEX*16 array, dimension LWORK. */
/* On exit, WORK(1) is set to an estimate of the optimal value */
/* of LWORK for the given values of N, NW, KTOP and KBOT. */
/* LWORK (input) integer */
/* The dimension of the work array WORK. LWORK = 2*NW */
/* suffices, but greater efficiency may result from larger */
/* values of LWORK. */
/* If LWORK = -1, then a workspace query is assumed; ZLAQR3 */
/* only estimates the optimal workspace size for the given */
/* values of N, NW, KTOP and KBOT. The estimate is returned */
/* in WORK(1). No error message related to LWORK is issued */
/* by XERBLA. Neither H nor Z are accessed. */
/* ================================================================ */
/* Based on contributions by */
/* Karen Braman and Ralph Byers, Department of Mathematics, */
/* University of Kansas, USA */
/* ================================================================ */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* ==== Estimate optimal workspace. ==== */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--sh;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
wv_dim1 = *ldwv;
wv_offset = 1 + wv_dim1;
wv -= wv_offset;
--work;
/* Function Body */
/* Computing MIN */
i__1 = *nw, i__2 = *kbot - *ktop + 1;
jw = min(i__1,i__2);
if (jw <= 2) {
lwkopt = 1;
} else {
/* ==== Workspace query call to ZGEHRD ==== */
i__1 = jw - 1;
zgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], &
c_n1, &info);
lwk1 = (integer) work[1].r;
/* ==== Workspace query call to ZUNMHR ==== */
i__1 = jw - 1;
zunmhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1],
&v[v_offset], ldv, &work[1], &c_n1, &info);
lwk2 = (integer) work[1].r;
/* ==== Workspace query call to ZLAQR4 ==== */
zlaqr4_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sh[1],
&c__1, &jw, &v[v_offset], ldv, &work[1], &c_n1, &infqr);
lwk3 = (integer) work[1].r;
/* ==== Optimal workspace ==== */
/* Computing MAX */
i__1 = jw + max(lwk1,lwk2);
lwkopt = max(i__1,lwk3);
}
/* ==== Quick return in case of workspace query. ==== */
if (*lwork == -1) {
d__1 = (doublereal) lwkopt;
z__1.r = d__1, z__1.i = 0.;
work[1].r = z__1.r, work[1].i = z__1.i;
return 0;
}
/* ==== Nothing to do ... */
/* ... for an empty active block ... ==== */
*ns = 0;
*nd = 0;
work[1].r = 1., work[1].i = 0.;
if (*ktop > *kbot) {
return 0;
}
/* ... nor for an empty deflation window. ==== */
if (*nw < 1) {
return 0;
}
/* ==== Machine constants ==== */
safmin = dlamch_("SAFE MINIMUM");
safmax = 1. / safmin;
dlabad_(&safmin, &safmax);
ulp = dlamch_("PRECISION");
smlnum = safmin * ((doublereal) (*n) / ulp);
/* ==== Setup deflation window ==== */
/* Computing MIN */
i__1 = *nw, i__2 = *kbot - *ktop + 1;
jw = min(i__1,i__2);
kwtop = *kbot - jw + 1;
if (kwtop == *ktop) {
s.r = 0., s.i = 0.;
} else {
i__1 = kwtop + (kwtop - 1) * h_dim1;
s.r = h__[i__1].r, s.i = h__[i__1].i;
}
if (*kbot == kwtop) {
/* ==== 1-by-1 deflation window: not much to do ==== */
i__1 = kwtop;
i__2 = kwtop + kwtop * h_dim1;
sh[i__1].r = h__[i__2].r, sh[i__1].i = h__[i__2].i;
*ns = 1;
*nd = 0;
/* Computing MAX */
i__1 = kwtop + kwtop * h_dim1;
d__5 = smlnum, d__6 = ulp * ((d__1 = h__[i__1].r, abs(d__1)) + (d__2 =
d_imag(&h__[kwtop + kwtop * h_dim1]), abs(d__2)));
if ((d__3 = s.r, abs(d__3)) + (d__4 = d_imag(&s), abs(d__4)) <= max(
d__5,d__6)) {
*ns = 0;
*nd = 1;
if (kwtop > *ktop) {
i__1 = kwtop + (kwtop - 1) * h_dim1;
h__[i__1].r = 0., h__[i__1].i = 0.;
}
}
work[1].r = 1., work[1].i = 0.;
return 0;
}
/* ==== Convert to spike-triangular form. (In case of a */
/* . rare QR failure, this routine continues to do */
/* . aggressive early deflation using that part of */
/* . the deflation window that converged using INFQR */
/* . here and there to keep track.) ==== */
zlacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset],
ldt);
i__1 = jw - 1;
i__2 = *ldh + 1;
i__3 = *ldt + 1;
zcopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], &
i__3);
zlaset_("A", &jw, &jw, &c_b1, &c_b2, &v[v_offset], ldv);
nmin = ilaenv_(&c__12, "ZLAQR3", "SV", &jw, &c__1, &jw, lwork);
if (jw > nmin) {
zlaqr4_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sh[
kwtop], &c__1, &jw, &v[v_offset], ldv, &work[1], lwork, &
infqr);
} else {
zlahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sh[
kwtop], &c__1, &jw, &v[v_offset], ldv, &infqr);
}
/* ==== Deflation detection loop ==== */
*ns = jw;
ilst = infqr + 1;
i__1 = jw;
for (knt = infqr + 1; knt <= i__1; ++knt) {
/* ==== Small spike tip deflation test ==== */
i__2 = *ns + *ns * t_dim1;
foo = (d__1 = t[i__2].r, abs(d__1)) + (d__2 = d_imag(&t[*ns + *ns *
t_dim1]), abs(d__2));
if (foo == 0.) {
foo = (d__1 = s.r, abs(d__1)) + (d__2 = d_imag(&s), abs(d__2));
}
i__2 = *ns * v_dim1 + 1;
/* Computing MAX */
d__5 = smlnum, d__6 = ulp * foo;
if (((d__1 = s.r, abs(d__1)) + (d__2 = d_imag(&s), abs(d__2))) * ((
d__3 = v[i__2].r, abs(d__3)) + (d__4 = d_imag(&v[*ns * v_dim1
+ 1]), abs(d__4))) <= max(d__5,d__6)) {
/* ==== One more converged eigenvalue ==== */
--(*ns);
} else {
/* ==== One undeflatable eigenvalue. Move it up out of the */
/* . way. (ZTREXC can not fail in this case.) ==== */
ifst = *ns;
ztrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &
ilst, &info);
++ilst;
}
/* L10: */
}
/* ==== Return to Hessenberg form ==== */
if (*ns == 0) {
s.r = 0., s.i = 0.;
}
if (*ns < jw) {
/* ==== sorting the diagonal of T improves accuracy for */
/* . graded matrices. ==== */
i__1 = *ns;
for (i__ = infqr + 1; i__ <= i__1; ++i__) {
ifst = i__;
i__2 = *ns;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = j + j * t_dim1;
i__4 = ifst + ifst * t_dim1;
if ((d__1 = t[i__3].r, abs(d__1)) + (d__2 = d_imag(&t[j + j *
t_dim1]), abs(d__2)) > (d__3 = t[i__4].r, abs(d__3))
+ (d__4 = d_imag(&t[ifst + ifst * t_dim1]), abs(d__4))
) {
ifst = j;
}
/* L20: */
}
ilst = i__;
if (ifst != ilst) {
ztrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst,
&ilst, &info);
}
/* L30: */
}
}
/* ==== Restore shift/eigenvalue array from T ==== */
i__1 = jw;
for (i__ = infqr + 1; i__ <= i__1; ++i__) {
i__2 = kwtop + i__ - 1;
i__3 = i__ + i__ * t_dim1;
sh[i__2].r = t[i__3].r, sh[i__2].i = t[i__3].i;
/* L40: */
}
if (*ns < jw || s.r == 0. && s.i == 0.) {
if (*ns > 1 && (s.r != 0. || s.i != 0.)) {
/* ==== Reflect spike back into lower triangle ==== */
zcopy_(ns, &v[v_offset], ldv, &work[1], &c__1);
i__1 = *ns;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
d_cnjg(&z__1, &work[i__]);
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
/* L50: */
}
beta.r = work[1].r, beta.i = work[1].i;
zlarfg_(ns, &beta, &work[2], &c__1, &tau);
work[1].r = 1., work[1].i = 0.;
i__1 = jw - 2;
i__2 = jw - 2;
zlaset_("L", &i__1, &i__2, &c_b1, &c_b1, &t[t_dim1 + 3], ldt);
d_cnjg(&z__1, &tau);
zlarf_("L", ns, &jw, &work[1], &c__1, &z__1, &t[t_offset], ldt, &
work[jw + 1]);
zlarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, &
work[jw + 1]);
zlarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, &
work[jw + 1]);
i__1 = *lwork - jw;
zgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1]
, &i__1, &info);
}
/* ==== Copy updated reduced window into place ==== */
if (kwtop > 1) {
i__1 = kwtop + (kwtop - 1) * h_dim1;
d_cnjg(&z__2, &v[v_dim1 + 1]);
z__1.r = s.r * z__2.r - s.i * z__2.i, z__1.i = s.r * z__2.i + s.i
* z__2.r;
h__[i__1].r = z__1.r, h__[i__1].i = z__1.i;
}
zlacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1]
, ldh);
i__1 = jw - 1;
i__2 = *ldt + 1;
i__3 = *ldh + 1;
zcopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1],
&i__3);
/* ==== Accumulate orthogonal matrix in order update */
/* . H and Z, if requested. ==== */
if (*ns > 1 && (s.r != 0. || s.i != 0.)) {
i__1 = *lwork - jw;
zunmhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1],
&v[v_offset], ldv, &work[jw + 1], &i__1, &info);
}
/* ==== Update vertical slab in H ==== */
if (*wantt) {
ltop = 1;
} else {
ltop = *ktop;
}
i__1 = kwtop - 1;
i__2 = *nv;
for (krow = ltop; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow +=
i__2) {
/* Computing MIN */
i__3 = *nv, i__4 = kwtop - krow;
kln = min(i__3,i__4);
zgemm_("N", "N", &kln, &jw, &jw, &c_b2, &h__[krow + kwtop *
h_dim1], ldh, &v[v_offset], ldv, &c_b1, &wv[wv_offset],
ldwv);
zlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop *
h_dim1], ldh);
/* L60: */
}
/* ==== Update horizontal slab in H ==== */
if (*wantt) {
i__2 = *n;
i__1 = *nh;
for (kcol = *kbot + 1; i__1 < 0 ? kcol >= i__2 : kcol <= i__2;
kcol += i__1) {
/* Computing MIN */
i__3 = *nh, i__4 = *n - kcol + 1;
kln = min(i__3,i__4);
zgemm_("C", "N", &jw, &kln, &jw, &c_b2, &v[v_offset], ldv, &
h__[kwtop + kcol * h_dim1], ldh, &c_b1, &t[t_offset],
ldt);
zlacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol *
h_dim1], ldh);
/* L70: */
}
}
/* ==== Update vertical slab in Z ==== */
if (*wantz) {
i__1 = *ihiz;
i__2 = *nv;
for (krow = *iloz; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow +=
i__2) {
/* Computing MIN */
i__3 = *nv, i__4 = *ihiz - krow + 1;
kln = min(i__3,i__4);
zgemm_("N", "N", &kln, &jw, &jw, &c_b2, &z__[krow + kwtop *
z_dim1], ldz, &v[v_offset], ldv, &c_b1, &wv[wv_offset]
, ldwv);
zlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow +
kwtop * z_dim1], ldz);
/* L80: */
}
}
}
/* ==== Return the number of deflations ... ==== */
*nd = jw - *ns;
/* ==== ... and the number of shifts. (Subtracting */
/* . INFQR from the spike length takes care */
/* . of the case of a rare QR failure while */
/* . calculating eigenvalues of the deflation */
/* . window.) ==== */
*ns -= infqr;
/* ==== Return optimal workspace. ==== */
d__1 = (doublereal) lwkopt;
z__1.r = d__1, z__1.i = 0.;
work[1].r = z__1.r, work[1].i = z__1.i;
/* ==== End of ZLAQR3 ==== */
return 0;
} /* zlaqr3_ */
/* Subroutine */ int zhseqr_(char *job, char *compz, integer *n, integer *ilo,
integer *ihi, doublecomplex *h__, integer *ldh, doublecomplex *w,
doublecomplex *z__, integer *ldz, doublecomplex *work, integer *lwork,
integer *info)
{
/* System generated locals */
address a__1[2];
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3[2];
doublereal d__1, d__2, d__3;
doublecomplex z__1;
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
doublecomplex hl[2401] /* was [49][49] */;
integer kbot, nmin;
extern logical lsame_(char *, char *);
logical initz;
doublecomplex workl[49];
logical wantt, wantz;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zlaqr0_(logical *, logical *,
integer *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *), xerbla_(char *, integer *
);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int zlahqr_(logical *, logical *, integer *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *, integer *, doublecomplex *, integer *, integer *),
zlacpy_(char *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zlaset_(char *, integer *,
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
integer *);
logical lquery;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZHSEQR computes the eigenvalues of a Hessenberg matrix H */
/* and, optionally, the matrices T and Z from the Schur decomposition */
/* H = Z T Z**H, where T is an upper triangular matrix (the */
/* Schur form), and Z is the unitary matrix of Schur vectors. */
/* Optionally Z may be postmultiplied into an input unitary */
/* matrix Q so that this routine can give the Schur factorization */
/* of a matrix A which has been reduced to the Hessenberg form H */
/* by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* = 'E': compute eigenvalues only; */
/* = 'S': compute eigenvalues and the Schur form T. */
/* COMPZ (input) CHARACTER*1 */
/* = 'N': no Schur vectors are computed; */
/* = 'I': Z is initialized to the unit matrix and the matrix Z */
/* of Schur vectors of H is returned; */
/* = 'V': Z must contain an unitary matrix Q on entry, and */
/* the product Q*Z is returned. */
/* N (input) INTEGER */
/* The order of the matrix H. N .GE. 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* It is assumed that H is already upper triangular in rows */
/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */
/* set by a previous call to ZGEBAL, and then passed to ZGEHRD */
/* when the matrix output by ZGEBAL is reduced to Hessenberg */
/* form. Otherwise ILO and IHI should be set to 1 and N */
/* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. */
/* If N = 0, then ILO = 1 and IHI = 0. */
/* H (input/output) COMPLEX*16 array, dimension (LDH,N) */
/* On entry, the upper Hessenberg matrix H. */
/* On exit, if INFO = 0 and JOB = 'S', H contains the upper */
/* triangular matrix T from the Schur decomposition (the */
/* Schur form). If INFO = 0 and JOB = 'E', the contents of */
/* H are unspecified on exit. (The output value of H when */
/* INFO.GT.0 is given under the description of INFO below.) */
/* Unlike earlier versions of ZHSEQR, this subroutine may */
/* explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1 */
/* or j = IHI+1, IHI+2, ... N. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH .GE. max(1,N). */
/* W (output) COMPLEX*16 array, dimension (N) */
/* The computed eigenvalues. If JOB = 'S', the eigenvalues are */
/* stored in the same order as on the diagonal of the Schur */
/* form returned in H, with W(i) = H(i,i). */
/* Z (input/output) COMPLEX*16 array, dimension (LDZ,N) */
/* If COMPZ = 'N', Z is not referenced. */
/* If COMPZ = 'I', on entry Z need not be set and on exit, */
/* if INFO = 0, Z contains the unitary matrix Z of the Schur */
/* vectors of H. If COMPZ = 'V', on entry Z must contain an */
/* N-by-N matrix Q, which is assumed to be equal to the unit */
/* matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit, */
/* if INFO = 0, Z contains Q*Z. */
/* Normally Q is the unitary matrix generated by ZUNGHR */
/* after the call to ZGEHRD which formed the Hessenberg matrix */
/* H. (The output value of Z when INFO.GT.0 is given under */
/* the description of INFO below.) */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. if COMPZ = 'I' or */
/* COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1. */
/* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns an estimate of */
/* the optimal value for LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK .GE. max(1,N) */
/* is sufficient and delivers very good and sometimes */
/* optimal performance. However, LWORK as large as 11*N */
/* may be required for optimal performance. A workspace */
/* query is recommended to determine the optimal workspace */
/* size. */
/* If LWORK = -1, then ZHSEQR does a workspace query. */
/* In this case, ZHSEQR checks the input parameters and */
/* estimates the optimal workspace size for the given */
/* values of N, ILO and IHI. The estimate is returned */
/* in WORK(1). No error message related to LWORK is */
/* issued by XERBLA. Neither H nor Z are accessed. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* .LT. 0: if INFO = -i, the i-th argument had an illegal */
/* value */
/* .GT. 0: if INFO = i, ZHSEQR failed to compute all of */
/* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */
/* and WI contain those eigenvalues which have been */
/* successfully computed. (Failures are rare.) */
/* If INFO .GT. 0 and JOB = 'E', then on exit, the */
/* remaining unconverged eigenvalues are the eigen- */
/* values of the upper Hessenberg matrix rows and */
/* columns ILO through INFO of the final, output */
/* value of H. */
/* If INFO .GT. 0 and JOB = 'S', then on exit */
/* (*) (initial value of H)*U = U*(final value of H) */
/* where U is a unitary matrix. The final */
/* value of H is upper Hessenberg and triangular in */
/* rows and columns INFO+1 through IHI. */
/* If INFO .GT. 0 and COMPZ = 'V', then on exit */
/* (final value of Z) = (initial value of Z)*U */
/* where U is the unitary matrix in (*) (regard- */
/* less of the value of JOB.) */
/* If INFO .GT. 0 and COMPZ = 'I', then on exit */
/* (final value of Z) = U */
/* where U is the unitary matrix in (*) (regard- */
/* less of the value of JOB.) */
/* If INFO .GT. 0 and COMPZ = 'N', then Z is not */
/* accessed. */
/* ================================================================ */
/* Default values supplied by */
/* ILAENV(ISPEC,'ZHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK). */
/* It is suggested that these defaults be adjusted in order */
/* to attain best performance in each particular */
/* computational environment. */
/* ISPEC=12: The ZLAHQR vs ZLAQR0 crossover point. */
/* Default: 75. (Must be at least 11.) */
/* ISPEC=13: Recommended deflation window size. */
/* This depends on ILO, IHI and NS. NS is the */
/* number of simultaneous shifts returned */
/* by ILAENV(ISPEC=15). (See ISPEC=15 below.) */
/* The default for (IHI-ILO+1).LE.500 is NS. */
/* The default for (IHI-ILO+1).GT.500 is 3*NS/2. */
/* ISPEC=14: Nibble crossover point. (See IPARMQ for */
/* details.) Default: 14% of deflation window */
/* size. */
/* ISPEC=15: Number of simultaneous shifts in a multishift */
/* QR iteration. */
/* If IHI-ILO+1 is ... */
/* greater than ...but less ... the */
/* or equal to ... than default is */
/* 1 30 NS = 2(+) */
/* 30 60 NS = 4(+) */
/* 60 150 NS = 10(+) */
/* 150 590 NS = ** */
/* 590 3000 NS = 64 */
/* 3000 6000 NS = 128 */
/* 6000 infinity NS = 256 */
/* (+) By default some or all matrices of this order */
/* are passed to the implicit double shift routine */
/* ZLAHQR and this parameter is ignored. See */
/* ISPEC=12 above and comments in IPARMQ for */
/* details. */
/* (**) The asterisks (**) indicate an ad-hoc */
/* function of N increasing from 10 to 64. */
/* ISPEC=16: Select structured matrix multiply. */
/* If the number of simultaneous shifts (specified */
/* by ISPEC=15) is less than 14, then the default */
/* for ISPEC=16 is 0. Otherwise the default for */
/* ISPEC=16 is 2. */
/* ================================================================ */
/* Based on contributions by */
/* Karen Braman and Ralph Byers, Department of Mathematics, */
/* University of Kansas, USA */
/* ================================================================ */
/* References: */
/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
/* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */
/* Performance, SIAM Journal of Matrix Analysis, volume 23, pages */
/* 929--947, 2002. */
/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
/* Algorithm Part II: Aggressive Early Deflation, SIAM Journal */
/* of Matrix Analysis, volume 23, pages 948--973, 2002. */
/* ================================================================ */
/* .. Parameters .. */
/* ==== Matrices of order NTINY or smaller must be processed by */
/* . ZLAHQR because of insufficient subdiagonal scratch space. */
/* . (This is a hard limit.) ==== */
/* ==== NL allocates some local workspace to help small matrices */
/* . through a rare ZLAHQR failure. NL .GT. NTINY = 11 is */
/* . required and NL .LE. NMIN = ILAENV(ISPEC=12,...) is recom- */
/* . mended. (The default value of NMIN is 75.) Using NL = 49 */
/* . allows up to six simultaneous shifts and a 16-by-16 */
/* . deflation window. ==== */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* ==== Decode and check the input parameters. ==== */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
/* Function Body */
wantt = lsame_(job, "S");
initz = lsame_(compz, "I");
wantz = initz || lsame_(compz, "V");
d__1 = (doublereal) max(1,*n);
z__1.r = d__1, z__1.i = 0.;
work[1].r = z__1.r, work[1].i = z__1.i;
lquery = *lwork == -1;
*info = 0;
if (! lsame_(job, "E") && ! wantt) {
*info = -1;
} else if (! lsame_(compz, "N") && ! wantz) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ilo < 1 || *ilo > max(1,*n)) {
*info = -4;
} else if (*ihi < min(*ilo,*n) || *ihi > *n) {
*info = -5;
} else if (*ldh < max(1,*n)) {
*info = -7;
} else if (*ldz < 1 || wantz && *ldz < max(1,*n)) {
*info = -10;
} else if (*lwork < max(1,*n) && ! lquery) {
*info = -12;
}
if (*info != 0) {
/* ==== Quick return in case of invalid argument. ==== */
i__1 = -(*info);
xerbla_("ZHSEQR", &i__1);
return 0;
} else if (*n == 0) {
/* ==== Quick return in case N = 0; nothing to do. ==== */
return 0;
} else if (lquery) {
/* ==== Quick return in case of a workspace query ==== */
zlaqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &w[1], ilo,
ihi, &z__[z_offset], ldz, &work[1], lwork, info);
/* ==== Ensure reported workspace size is backward-compatible with */
/* . previous LAPACK versions. ==== */
/* Computing MAX */
d__2 = work[1].r, d__3 = (doublereal) max(1,*n);
d__1 = max(d__2,d__3);
z__1.r = d__1, z__1.i = 0.;
work[1].r = z__1.r, work[1].i = z__1.i;
return 0;
} else {
/* ==== copy eigenvalues isolated by ZGEBAL ==== */
if (*ilo > 1) {
i__1 = *ilo - 1;
i__2 = *ldh + 1;
zcopy_(&i__1, &h__[h_offset], &i__2, &w[1], &c__1);
}
if (*ihi < *n) {
i__1 = *n - *ihi;
i__2 = *ldh + 1;
zcopy_(&i__1, &h__[*ihi + 1 + (*ihi + 1) * h_dim1], &i__2, &w[*
ihi + 1], &c__1);
}
/* ==== Initialize Z, if requested ==== */
if (initz) {
zlaset_("A", n, n, &c_b1, &c_b2, &z__[z_offset], ldz);
}
/* ==== Quick return if possible ==== */
if (*ilo == *ihi) {
i__1 = *ilo;
i__2 = *ilo + *ilo * h_dim1;
w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i;
return 0;
}
/* ==== ZLAHQR/ZLAQR0 crossover point ==== */
/* 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);
nmin = ilaenv_(&c__12, "ZHSEQR", ch__1, n, ilo, ihi, lwork);
nmin = max(11,nmin);
/* ==== ZLAQR0 for big matrices; ZLAHQR for small ones ==== */
if (*n > nmin) {
zlaqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &w[1],
ilo, ihi, &z__[z_offset], ldz, &work[1], lwork, info);
} else {
/* ==== Small matrix ==== */
zlahqr_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &w[1],
ilo, ihi, &z__[z_offset], ldz, info);
if (*info > 0) {
/* ==== A rare ZLAHQR failure! ZLAQR0 sometimes succeeds */
/* . when ZLAHQR fails. ==== */
kbot = *info;
if (*n >= 49) {
/* ==== Larger matrices have enough subdiagonal scratch */
/* . space to call ZLAQR0 directly. ==== */
zlaqr0_(&wantt, &wantz, n, ilo, &kbot, &h__[h_offset],
ldh, &w[1], ilo, ihi, &z__[z_offset], ldz, &work[
1], lwork, info);
} else {
/* ==== Tiny matrices don't have enough subdiagonal */
/* . scratch space to benefit from ZLAQR0. Hence, */
/* . tiny matrices must be copied into a larger */
/* . array before calling ZLAQR0. ==== */
zlacpy_("A", n, n, &h__[h_offset], ldh, hl, &c__49);
i__1 = *n + 1 + *n * 49 - 50;
hl[i__1].r = 0., hl[i__1].i = 0.;
i__1 = 49 - *n;
zlaset_("A", &c__49, &i__1, &c_b1, &c_b1, &hl[(*n + 1) *
49 - 49], &c__49);
zlaqr0_(&wantt, &wantz, &c__49, ilo, &kbot, hl, &c__49, &
w[1], ilo, ihi, &z__[z_offset], ldz, workl, &
c__49, info);
if (wantt || *info != 0) {
zlacpy_("A", n, n, hl, &c__49, &h__[h_offset], ldh);
}
}
}
}
/* ==== Clear out the trash, if necessary. ==== */
if ((wantt || *info != 0) && *n > 2) {
i__1 = *n - 2;
i__2 = *n - 2;
zlaset_("L", &i__1, &i__2, &c_b1, &c_b1, &h__[h_dim1 + 3], ldh);
}
/* ==== Ensure reported workspace size is backward-compatible with */
/* . previous LAPACK versions. ==== */
/* Computing MAX */
d__2 = (doublereal) max(1,*n), d__3 = work[1].r;
d__1 = max(d__2,d__3);
z__1.r = d__1, z__1.i = 0.;
work[1].r = z__1.r, work[1].i = z__1.i;
}
/* ==== End of ZHSEQR ==== */
return 0;
} /* zhseqr_ */
