/* Subroutine */ int chseqr_(char *job, char *compz, integer *n, integer *ilo,
integer *ihi, complex *h__, integer *ldh, complex *w, complex *z__,
integer *ldz, complex *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, i__4[2],
i__5, i__6;
real r__1, r__2, r__3, r__4;
complex q__1;
char ch__1[2];
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static integer maxb, ierr;
static real unfl;
static complex temp;
static real ovfl, opst;
static integer i__, j, k, l;
static complex s[225] /* was [15][15] */;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
static complex v[16];
extern logical lsame_(char *, char *);
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *), ccopy_(integer *, complex *, integer *,
complex *, integer *);
static integer itemp;
static real rtemp;
static integer i1, i2;
static logical initz, wantt, wantz;
static real rwork[1];
extern doublereal slapy2_(real *, real *);
static integer ii, nh;
extern /* Subroutine */ int slabad_(real *, real *), clarfg_(integer *,
complex *, complex *, integer *, complex *);
static integer nr, ns;
extern integer icamax_(integer *, complex *, integer *);
static integer nv;
extern doublereal slamch_(char *), clanhs_(char *, integer *,
complex *, integer *, real *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), clahqr_(logical *, logical *, integer *, integer *, integer *,
complex *, integer *, complex *, integer *, integer *, complex *,
integer *, integer *), clacpy_(char *, integer *, integer *,
complex *, integer *, complex *, integer *);
static complex vv[16];
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int clarfx_(char *, integer *, integer *, complex
*, complex *, complex *, integer *, complex *), xerbla_(
char *, integer *);
static real smlnum;
static logical lquery;
static integer itn;
static complex tau;
static integer its;
static real 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)]
/* -- LAPACK routine (instrumented to count operations, version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Common block to return operation count.
Purpose
=======
CHSEQR 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 CGEBAL, and then passed to CGEHRD
when the matrix output by CGEBAL 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 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 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 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 CUNGHR after
the call to CGEHRD 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 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, CHSEQR 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 */
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 = (real) i__1, work[1].i = 0.f;
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_("CHSEQR", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* **
Initialize */
opst = 0.f;
/* **
Initialize Z, if necessary */
if (initz) {
claset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz);
}
/* Store the eigenvalues isolated by CGEBAL. */
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.f, h__[i__3].i = 0.f;
/* 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 (r_imag(&temp) != 0.f) {
r__1 = temp.r;
r__2 = r_imag(&temp);
rtemp = slapy2_(&r__1, &r__2);
i__2 = h___subscr(i__, i__ - 1);
h__[i__2].r = rtemp, h__[i__2].i = 0.f;
q__1.r = temp.r / rtemp, q__1.i = temp.i / rtemp;
temp.r = q__1.r, temp.i = q__1.i;
if (i2 > i__) {
i__2 = i2 - i__;
r_cnjg(&q__1, &temp);
cscal_(&i__2, &q__1, &h___ref(i__, i__ + 1), ldh);
}
i__2 = i__ - i1;
cscal_(&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__);
q__1.r = temp.r * h__[i__3].r - temp.i * h__[i__3].i, q__1.i =
temp.r * h__[i__3].i + temp.i * h__[i__3].r;
h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
}
/* **
Increment op count */
opst += (i2 - i1 + 2) * 6;
/* ** */
if (wantz) {
cscal_(&nh, &temp, &z___ref(*ilo, i__), &c__1);
/* **
Increment op count */
opst += nh * 6;
/* ** */
}
}
/* 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, "CHSEQR", 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, "CHSEQR", ch__1, n, ilo, ihi, &c_n1, (ftnlen)6, (
ftnlen)2);
if (ns <= 1 || ns > nh || maxb >= nh) {
/* Use the standard double-shift algorithm */
clahqr_(&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 = slamch_("Safe minimum");
ovfl = 1.f / unfl;
slabad_(&unfl, &ovfl);
ulp = slamch_("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 = (r__1 = h__[i__3].r, dabs(r__1)) + (r__2 = r_imag(&h___ref(
k - 1, k - 1)), dabs(r__2)) + ((r__3 = h__[i__5].r, dabs(
r__3)) + (r__4 = r_imag(&h___ref(k, k)), dabs(r__4)));
if (tst1 == 0.f) {
i__3 = i__ - l + 1;
tst1 = clanhs_("1", &i__3, &h___ref(l, l), ldh, rwork);
/* **
Increment op count */
latime_1.ops += (i__ - l + 1) * 5 * (i__ - l) / 2;
/* ** */
}
i__3 = h___subscr(k, k - 1);
/* Computing MAX */
r__2 = ulp * tst1;
if ((r__1 = h__[i__3].r, dabs(r__1)) <= dmax(r__2,smlnum)) {
goto L80;
}
/* L70: */
}
L80:
l = k;
/* **
Increment op count */
opst += (i__ - l + 1) * 5;
/* ** */
if (l > *ilo) {
/* H(L,L-1) is negligible. */
i__2 = h___subscr(l, l - 1);
h__[i__2].r = 0.f, h__[i__2].i = 0.f;
}
/* 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);
r__3 = ((r__1 = h__[i__5].r, dabs(r__1)) + (r__2 = h__[i__6]
.r, dabs(r__2))) * 1.5f;
w[i__3].r = r__3, w[i__3].i = 0.f;
/* L90: */
}
/* **
Increment op count */
opst += ns << 1;
/* ** */
} else {
/* Use eigenvalues of trailing submatrix of order NS as shifts. */
clacpy_("Full", &ns, &ns, &h___ref(i__ - ns + 1, i__ - ns + 1),
ldh, s, &c__15);
clahqr_(&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 CLAHQR 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.f, v[0].i = 0.f;
i__2 = ns + 1;
for (ii = 2; ii <= i__2; ++ii) {
i__3 = ii - 1;
v[i__3].r = 0.f, v[i__3].i = 0.f;
/* L110: */
}
nv = 1;
i__2 = i__;
for (j = i__ - ns + 1; j <= i__2; ++j) {
i__3 = nv + 1;
ccopy_(&i__3, v, &c__1, vv, &c__1);
i__3 = nv + 1;
i__5 = j;
q__1.r = -w[i__5].r, q__1.i = -w[i__5].i;
cgemv_("No transpose", &i__3, &nv, &c_b2, &h___ref(l, l), ldh, vv,
&c__1, &q__1, v, &c__1);
++nv;
/* **
Increment op count */
opst = opst + (nv << 3) * (*n + 1) + (nv + 1) * 6;
/* **
Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero,
reset it to the unit vector. */
itemp = icamax_(&nv, v, &c__1);
/* **
Increment op count */
opst += nv << 1;
/* ** */
i__3 = itemp - 1;
rtemp = (r__1 = v[i__3].r, dabs(r__1)) + (r__2 = r_imag(&v[itemp
- 1]), dabs(r__2));
if (rtemp == 0.f) {
v[0].r = 1.f, v[0].i = 0.f;
i__3 = nv;
for (ii = 2; ii <= i__3; ++ii) {
i__5 = ii - 1;
v[i__5].r = 0.f, v[i__5].i = 0.f;
/* L120: */
}
} else {
rtemp = dmax(rtemp,smlnum);
r__1 = 1.f / rtemp;
csscal_(&nv, &r__1, v, &c__1);
/* **
Increment op count */
opst += nv << 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) {
ccopy_(&nr, &h___ref(k, k - 1), &c__1, v, &c__1);
}
clarfg_(&nr, v, &v[1], &c__1, &tau);
/* **
Increment op count */
opst = opst + nr * 10 + 12;
/* ** */
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.f, h__[i__5].i = 0.f;
/* L140: */
}
}
v[0].r = 1.f, v[0].i = 0.f;
/* Apply G' from the left to transform the rows of the matrix
in columns K to I2. */
i__3 = i2 - k + 1;
r_cnjg(&q__1, &tau);
clarfx_("Left", &nr, &i__3, v, &q__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;
clarfx_("Right", &i__3, &nr, v, &tau, &h___ref(i1, k), ldh, &work[
1]);
/* **
Increment op count
Computing MIN */
i__3 = nr, i__5 = i__ - k;
latime_1.ops += ((nr << 2) - 2 << 2) * (i2 - i1 + 2 + min(i__3,
i__5));
/* ** */
if (wantz) {
/* Accumulate transformations in the matrix Z */
clarfx_("Right", &nh, &nr, v, &tau, &z___ref(*ilo, k), ldz, &
work[1]);
/* **
Increment op count */
latime_1.ops += ((nr << 2) - 2 << 2) * nh;
/* ** */
}
/* 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 (r_imag(&temp) != 0.f) {
r__1 = temp.r;
r__2 = r_imag(&temp);
rtemp = slapy2_(&r__1, &r__2);
i__2 = h___subscr(i__, i__ - 1);
h__[i__2].r = rtemp, h__[i__2].i = 0.f;
q__1.r = temp.r / rtemp, q__1.i = temp.i / rtemp;
temp.r = q__1.r, temp.i = q__1.i;
if (i2 > i__) {
i__2 = i2 - i__;
r_cnjg(&q__1, &temp);
cscal_(&i__2, &q__1, &h___ref(i__, i__ + 1), ldh);
}
i__2 = i__ - i1;
cscal_(&i__2, &temp, &h___ref(i1, i__), &c__1);
/* **
Increment op count */
opst += (i2 - i1 + 1) * 6;
/* ** */
if (wantz) {
cscal_(&nh, &temp, &z___ref(*ilo, i__), &c__1);
/* **
Increment op count */
opst += nh * 6;
/* ** */
}
}
/* 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. */
clahqr_(&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:
/* **
Compute final op count */
latime_1.ops += opst;
/* ** */
i__1 = max(1,*n);
work[1].r = (real) i__1, work[1].i = 0.f;
return 0;
/* End of CHSEQR */
} /* chseqr_ */
/* Subroutine */ int dchkhs_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
doublereal *a, integer *lda, doublereal *h__, doublereal *t1,
doublereal *t2, doublereal *u, integer *ldu, doublereal *z__,
doublereal *uz, doublereal *wr1, doublereal *wi1, doublereal *wr3,
doublereal *wi3, doublereal *evectl, doublereal *evectr, doublereal *
evecty, doublereal *evectx, doublereal *uu, doublereal *tau,
doublereal *work, integer *nwork, integer *iwork, logical *select,
doublereal *result, integer *info)
{
/* Initialized data */
static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
/* Format strings */
static char fmt_9999[] = "(\002 DCHKHS: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(\002 DCHKHS: \002,a,\002 Eigenvectors from"
" \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
"error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
"i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9997[] = "(\002 DCHKHS: Selected \002,a,\002 Eigenvector"
"s from \002,a,\002 do not match other eigenvectors \002,9x,\002N="
"\002,i6,\002, JTYPE=\002,i6,\002, ISEED=(\002,3(i5,\002,\002),i5,"
"\002)\002)";
/* System generated locals */
integer a_dim1, a_offset, evectl_dim1, evectl_offset, evectr_dim1,
evectr_offset, evectx_dim1, evectx_offset, evecty_dim1,
evecty_offset, h_dim1, h_offset, t1_dim1, t1_offset, t2_dim1,
t2_offset, u_dim1, u_offset, uu_dim1, uu_offset, uz_dim1,
uz_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;
/* Builtin functions */
double sqrt(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static doublereal cond;
static integer jcol, nmax;
static doublereal unfl, ovfl, temp1, temp2;
static integer i__, j, k, n;
static logical badnn;
extern /* Subroutine */ int dget10_(integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *),
dget22_(char *, char *, char *, integer *, doublereal *, integer *
, doublereal *, integer *, doublereal *, doublereal *, doublereal
*, doublereal *), dgemm_(char *, char *,
integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *);
static logical match;
static integer imode;
static doublereal dumma[6];
static integer iinfo, nselc;
static doublereal conds;
extern /* Subroutine */ int dhst01_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *);
static doublereal aninv, anorm;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
static integer nmats, nselr, jsize, nerrs, itype, jtype, ntest, n1;
static doublereal rtulp;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
static integer jj, in;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dgehrd_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *);
static char adumma[1*1];
extern /* Subroutine */ int dlatme_(integer *, char *, integer *,
doublereal *, integer *, doublereal *, doublereal *, char *, char
*, char *, char *, doublereal *, integer *, doublereal *, integer
*, integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *), dhsein_(char
*, char *, char *, logical *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *,
integer *, integer *, integer *, doublereal *, integer *,
integer *, integer *);
static integer idumma[1];
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *);
static integer ioldsd[4];
extern /* Subroutine */ int dlafts_(char *, integer *, integer *, integer
*, integer *, doublereal *, integer *, doublereal *, integer *,
integer *), dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
dlasum_(char *, integer *, integer *, integer *), dhseqr_(
char *, char *, integer *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *, integer *), dlatmr_(
integer *, integer *, char *, integer *, char *, doublereal *,
integer *, doublereal *, doublereal *, char *, char *, doublereal
*, integer *, doublereal *, doublereal *, integer *, doublereal *,
char *, integer *, integer *, integer *, doublereal *,
doublereal *, char *, doublereal *, integer *, integer *, integer
*), dlatms_(
integer *, integer *, char *, integer *, char *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *, char
*, doublereal *, integer *, doublereal *, integer *), dorghr_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *), dormhr_(char *, char *, integer *, integer *, integer
*, integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *),
dtrevc_(char *, char *, logical *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
integer *, integer *, doublereal *, integer *),
xerbla_(char *, integer *);
static doublereal rtunfl, rtovfl, rtulpi, ulpinv;
static integer mtypes, ntestt, ihi, ilo;
static doublereal ulp;
/* Fortran I/O blocks */
static cilist io___36 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___58 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___59 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___60 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___61 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___62 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___63 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___64 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___65 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___66 = { 0, 0, 0, fmt_9999, 0 };
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define h___ref(a_1,a_2) h__[(a_2)*h_dim1 + a_1]
#define u_ref(a_1,a_2) u[(a_2)*u_dim1 + a_1]
#define uu_ref(a_1,a_2) uu[(a_2)*uu_dim1 + a_1]
#define evectl_ref(a_1,a_2) evectl[(a_2)*evectl_dim1 + a_1]
#define evectr_ref(a_1,a_2) evectr[(a_2)*evectr_dim1 + a_1]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1999
Purpose
=======
DCHKHS checks the nonsymmetric eigenvalue problem routines.
DGEHRD factors A as U H U' , where ' means transpose,
H is hessenberg, and U is an orthogonal matrix.
DORGHR generates the orthogonal matrix U.
DORMHR multiplies a matrix by the orthogonal matrix U.
DHSEQR factors H as Z T Z' , where Z is orthogonal and
T is "quasi-triangular", and the eigenvalue vector W.
DTREVC computes the left and right eigenvector matrices
L and R for T.
DHSEIN computes the left and right eigenvector matrices
Y and X for H, using inverse iteration.
When DCHKHS is called, a number of matrix "sizes" ("n's") and a
number of matrix "types" are specified. For each size ("n")
and each type of matrix, one matrix will be generated and used
to test the nonsymmetric eigenroutines. For each matrix, 14
tests will be performed:
(1) | A - U H U**T | / ( |A| n ulp )
(2) | I - UU**T | / ( n ulp )
(3) | H - Z T Z**T | / ( |H| n ulp )
(4) | I - ZZ**T | / ( n ulp )
(5) | A - UZ H (UZ)**T | / ( |A| n ulp )
(6) | I - UZ (UZ)**T | / ( n ulp )
(7) | T(Z computed) - T(Z not computed) | / ( |T| ulp )
(8) | W(Z computed) - W(Z not computed) | / ( |W| ulp )
(9) | TR - RW | / ( |T| |R| ulp )
(10) | L**H T - W**H L | / ( |T| |L| ulp )
(11) | HX - XW | / ( |H| |X| ulp )
(12) | Y**H H - W**H Y | / ( |H| |Y| ulp )
(13) | AX - XW | / ( |A| |X| ulp )
(14) | Y**H A - W**H Y | / ( |A| |Y| ulp )
The "sizes" are specified by an array NN(1:NSIZES); the value of
each element NN(j) specifies one size.
The "types" are specified by a logical array DOTYPE( 1:NTYPES );
if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
Currently, the list of possible types is:
(1) The zero matrix.
(2) The identity matrix.
(3) A (transposed) Jordan block, with 1's on the diagonal.
(4) A diagonal matrix with evenly spaced entries
1, ..., ULP and random signs.
(ULP = (first number larger than 1) - 1 )
(5) A diagonal matrix with geometrically spaced entries
1, ..., ULP and random signs.
(6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
and random signs.
(7) Same as (4), but multiplied by SQRT( overflow threshold )
(8) Same as (4), but multiplied by SQRT( underflow threshold )
(9) A matrix of the form U' T U, where U is orthogonal and
T has evenly spaced entries 1, ..., ULP with random signs
on the diagonal and random O(1) entries in the upper
triangle.
(10) A matrix of the form U' T U, where U is orthogonal and
T has geometrically spaced entries 1, ..., ULP with random
signs on the diagonal and random O(1) entries in the upper
triangle.
(11) A matrix of the form U' T U, where U is orthogonal and
T has "clustered" entries 1, ULP,..., ULP with random
signs on the diagonal and random O(1) entries in the upper
triangle.
(12) A matrix of the form U' T U, where U is orthogonal and
T has real or complex conjugate paired eigenvalues randomly
chosen from ( ULP, 1 ) and random O(1) entries in the upper
triangle.
(13) A matrix of the form X' T X, where X has condition
SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP
with random signs on the diagonal and random O(1) entries
in the upper triangle.
(14) A matrix of the form X' T X, where X has condition
SQRT( ULP ) and T has geometrically spaced entries
1, ..., ULP with random signs on the diagonal and random
O(1) entries in the upper triangle.
(15) A matrix of the form X' T X, where X has condition
SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP
with random signs on the diagonal and random O(1) entries
in the upper triangle.
(16) A matrix of the form X' T X, where X has condition
SQRT( ULP ) and T has real or complex conjugate paired
eigenvalues randomly chosen from ( ULP, 1 ) and random
O(1) entries in the upper triangle.
(17) Same as (16), but multiplied by SQRT( overflow threshold )
(18) Same as (16), but multiplied by SQRT( underflow threshold )
(19) Nonsymmetric matrix with random entries chosen from (-1,1).
(20) Same as (19), but multiplied by SQRT( overflow threshold )
(21) Same as (19), but multiplied by SQRT( underflow threshold )
Arguments
==========
NSIZES - INTEGER
The number of sizes of matrices to use. If it is zero,
DCHKHS does nothing. It must be at least zero.
Not modified.
NN - INTEGER array, dimension (NSIZES)
An array containing the sizes to be used for the matrices.
Zero values will be skipped. The values must be at least
zero.
Not modified.
NTYPES - INTEGER
The number of elements in DOTYPE. If it is zero, DCHKHS
does nothing. It must be at least zero. If it is MAXTYP+1
and NSIZES is 1, then an additional type, MAXTYP+1 is
defined, which is to use whatever matrix is in A. This
is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
DOTYPE(MAXTYP+1) is .TRUE. .
Not modified.
DOTYPE - LOGICAL array, dimension (NTYPES)
If DOTYPE(j) is .TRUE., then for each size in NN a
matrix of that size and of type j will be generated.
If NTYPES is smaller than the maximum number of types
defined (PARAMETER MAXTYP), then types NTYPES+1 through
MAXTYP will not be generated. If NTYPES is larger
than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
will be ignored.
Not modified.
ISEED - INTEGER array, dimension (4)
On entry ISEED specifies the seed of the random number
generator. The array elements should be between 0 and 4095;
if not they will be reduced mod 4096. Also, ISEED(4) must
be odd. The random number generator uses a linear
congruential sequence limited to small integers, and so
should produce machine independent random numbers. The
values of ISEED are changed on exit, and can be used in the
next call to DCHKHS to continue the same random number
sequence.
Modified.
THRESH - DOUBLE PRECISION
A test will count as "failed" if the "error", computed as
described above, exceeds THRESH. Note that the error
is scaled to be O(1), so THRESH should be a reasonably
small multiple of 1, e.g., 10 or 100. In particular,
it should not depend on the precision (single vs. double)
or the size of the matrix. It must be at least zero.
Not modified.
NOUNIT - INTEGER
The FORTRAN unit number for printing out error messages
(e.g., if a routine returns IINFO not equal to 0.)
Not modified.
A - DOUBLE PRECISION array, dimension (LDA,max(NN))
Used to hold the matrix whose eigenvalues are to be
computed. On exit, A contains the last matrix actually
used.
Modified.
LDA - INTEGER
The leading dimension of A, H, T1 and T2. It must be at
least 1 and at least max( NN ).
Not modified.
H - DOUBLE PRECISION array, dimension (LDA,max(NN))
The upper hessenberg matrix computed by DGEHRD. On exit,
H contains the Hessenberg form of the matrix in A.
Modified.
T1 - DOUBLE PRECISION array, dimension (LDA,max(NN))
The Schur (="quasi-triangular") matrix computed by DHSEQR
if Z is computed. On exit, T1 contains the Schur form of
the matrix in A.
Modified.
T2 - DOUBLE PRECISION array, dimension (LDA,max(NN))
The Schur matrix computed by DHSEQR when Z is not computed.
This should be identical to T1.
Modified.
LDU - INTEGER
The leading dimension of U, Z, UZ and UU. It must be at
least 1 and at least max( NN ).
Not modified.
U - DOUBLE PRECISION array, dimension (LDU,max(NN))
The orthogonal matrix computed by DGEHRD.
Modified.
Z - DOUBLE PRECISION array, dimension (LDU,max(NN))
The orthogonal matrix computed by DHSEQR.
Modified.
UZ - DOUBLE PRECISION array, dimension (LDU,max(NN))
The product of U times Z.
Modified.
WR1 - DOUBLE PRECISION array, dimension (max(NN))
WI1 - DOUBLE PRECISION array, dimension (max(NN))
The real and imaginary parts of the eigenvalues of A,
as computed when Z is computed.
On exit, WR1 + WI1*i are the eigenvalues of the matrix in A.
Modified.
WR3 - DOUBLE PRECISION array, dimension (max(NN))
WI3 - DOUBLE PRECISION array, dimension (max(NN))
Like WR1, WI1, these arrays contain the eigenvalues of A,
but those computed when DHSEQR only computes the
eigenvalues, i.e., not the Schur vectors and no more of the
Schur form than is necessary for computing the
eigenvalues.
Modified.
EVECTL - DOUBLE PRECISION array, dimension (LDU,max(NN))
The (upper triangular) left eigenvector matrix for the
matrix in T1. For complex conjugate pairs, the real part
is stored in one row and the imaginary part in the next.
Modified.
EVEZTR - DOUBLE PRECISION array, dimension (LDU,max(NN))
The (upper triangular) right eigenvector matrix for the
matrix in T1. For complex conjugate pairs, the real part
is stored in one column and the imaginary part in the next.
Modified.
EVECTY - DOUBLE PRECISION array, dimension (LDU,max(NN))
The left eigenvector matrix for the
matrix in H. For complex conjugate pairs, the real part
is stored in one row and the imaginary part in the next.
Modified.
EVECTX - DOUBLE PRECISION array, dimension (LDU,max(NN))
The right eigenvector matrix for the
matrix in H. For complex conjugate pairs, the real part
is stored in one column and the imaginary part in the next.
Modified.
UU - DOUBLE PRECISION array, dimension (LDU,max(NN))
Details of the orthogonal matrix computed by DGEHRD.
Modified.
TAU - DOUBLE PRECISION array, dimension(max(NN))
Further details of the orthogonal matrix computed by DGEHRD.
Modified.
WORK - DOUBLE PRECISION array, dimension (NWORK)
Workspace.
Modified.
NWORK - INTEGER
The number of entries in WORK. NWORK >= 4*NN(j)*NN(j) + 2.
IWORK - INTEGER array, dimension (max(NN))
Workspace.
Modified.
SELECT - LOGICAL array, dimension (max(NN))
Workspace.
Modified.
RESULT - DOUBLE PRECISION array, dimension (14)
The values computed by the fourteen tests described above.
The values are currently limited to 1/ulp, to avoid
overflow.
Modified.
INFO - INTEGER
If 0, then everything ran OK.
-1: NSIZES < 0
-2: Some NN(j) < 0
-3: NTYPES < 0
-6: THRESH < 0
-9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
-14: LDU < 1 or LDU < NMAX.
-28: NWORK too small.
If DLATMR, SLATMS, or SLATME returns an error code, the
absolute value of it is returned.
If 1, then DHSEQR could not find all the shifts.
If 2, then the EISPACK code (for small blocks) failed.
If >2, then 30*N iterations were not enough to find an
eigenvalue or to decompose the problem.
Modified.
-----------------------------------------------------------------------
Some Local Variables and Parameters:
---- ----- --------- --- ----------
ZERO, ONE Real 0 and 1.
MAXTYP The number of types defined.
MTEST The number of tests defined: care must be taken
that (1) the size of RESULT, (2) the number of
tests actually performed, and (3) MTEST agree.
NTEST The number of tests performed on this matrix
so far. This should be less than MTEST, and
equal to it by the last test. It will be less
if any of the routines being tested indicates
that it could not compute the matrices that
would be tested.
NMAX Largest value in NN.
NMATS The number of matrices generated so far.
NERRS The number of tests which have exceeded THRESH
so far (computed by DLAFTS).
COND, CONDS,
IMODE Values to be passed to the matrix generators.
ANORM Norm of A; passed to matrix generators.
OVFL, UNFL Overflow and underflow thresholds.
ULP, ULPINV Finest relative precision and its inverse.
RTOVFL, RTUNFL,
RTULP, RTULPI Square roots of the previous 4 values.
The following four arrays decode JTYPE:
KTYPE(j) The general type (1-10) for type "j".
KMODE(j) The MODE value to be passed to the matrix
generator for type "j".
KMAGN(j) The order of magnitude ( O(1),
O(overflow^(1/2) ), O(underflow^(1/2) )
KCONDS(j) Selects whether CONDS is to be 1 or
1/sqrt(ulp). (0 means irrelevant.)
=====================================================================
Parameter adjustments */
--nn;
--dotype;
--iseed;
t2_dim1 = *lda;
t2_offset = 1 + t2_dim1 * 1;
t2 -= t2_offset;
t1_dim1 = *lda;
t1_offset = 1 + t1_dim1 * 1;
t1 -= t1_offset;
h_dim1 = *lda;
h_offset = 1 + h_dim1 * 1;
h__ -= h_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
uu_dim1 = *ldu;
uu_offset = 1 + uu_dim1 * 1;
uu -= uu_offset;
evectx_dim1 = *ldu;
evectx_offset = 1 + evectx_dim1 * 1;
evectx -= evectx_offset;
evecty_dim1 = *ldu;
evecty_offset = 1 + evecty_dim1 * 1;
evecty -= evecty_offset;
evectr_dim1 = *ldu;
evectr_offset = 1 + evectr_dim1 * 1;
evectr -= evectr_offset;
evectl_dim1 = *ldu;
evectl_offset = 1 + evectl_dim1 * 1;
evectl -= evectl_offset;
uz_dim1 = *ldu;
uz_offset = 1 + uz_dim1 * 1;
uz -= uz_offset;
z_dim1 = *ldu;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
--wr1;
--wi1;
--wr3;
--wi3;
--tau;
--work;
--iwork;
--select;
--result;
/* Function Body
Check for errors */
ntestt = 0;
*info = 0;
badnn = FALSE_;
nmax = 0;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.) {
*info = -6;
} else if (*lda <= 1 || *lda < nmax) {
*info = -9;
} else if (*ldu <= 1 || *ldu < nmax) {
*info = -14;
} else if ((nmax << 2) * nmax + 2 > *nwork) {
*info = -28;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DCHKHS", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
/* More important constants */
unfl = dlamch_("Safe minimum");
ovfl = dlamch_("Overflow");
dlabad_(&unfl, &ovfl);
ulp = dlamch_("Epsilon") * dlamch_("Base");
ulpinv = 1. / ulp;
rtunfl = sqrt(unfl);
rtovfl = sqrt(ovfl);
rtulp = sqrt(ulp);
rtulpi = 1. / rtulp;
/* Loop over sizes, types */
nerrs = 0;
nmats = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
if (n == 0) {
goto L270;
}
n1 = max(1,n);
aninv = 1. / (doublereal) n1;
if (*nsizes != 1) {
mtypes = min(21,*ntypes);
} else {
mtypes = min(22,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L260;
}
++nmats;
ntest = 0;
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Initialize RESULT */
for (j = 1; j <= 14; ++j) {
result[j] = 0.;
/* L30: */
}
/* Compute "A"
Control parameters:
KMAGN KCONDS KMODE KTYPE
=1 O(1) 1 clustered 1 zero
=2 large large clustered 2 identity
=3 small exponential Jordan
=4 arithmetic diagonal, (w/ eigenvalues)
=5 random log symmetric, w/ eigenvalues
=6 random general, w/ eigenvalues
=7 random diagonal
=8 random symmetric
=9 random general
=10 random triangular */
if (mtypes > 21) {
goto L100;
}
itype = ktype[jtype - 1];
imode = kmode[jtype - 1];
/* Compute norm */
switch (kmagn[jtype - 1]) {
case 1: goto L40;
case 2: goto L50;
case 3: goto L60;
}
L40:
anorm = 1.;
goto L70;
L50:
anorm = rtovfl * ulp * aninv;
goto L70;
L60:
anorm = rtunfl * n * ulpinv;
goto L70;
L70:
dlaset_("Full", lda, &n, &c_b18, &c_b18, &a[a_offset], lda);
iinfo = 0;
cond = ulpinv;
/* Special Matrices */
if (itype == 1) {
/* Zero */
iinfo = 0;
} else if (itype == 2) {
/* Identity */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
a_ref(jcol, jcol) = anorm;
/* L80: */
}
} else if (itype == 3) {
/* Jordan Block */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
a_ref(jcol, jcol) = anorm;
if (jcol > 1) {
a_ref(jcol, jcol - 1) = 1.;
}
/* L90: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
&anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[n
+ 1], &iinfo);
} else if (itype == 5) {
/* Symmetric, eigenvalues specified */
dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
&anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
&iinfo);
} else if (itype == 6) {
/* General, eigenvalues specified */
if (kconds[jtype - 1] == 1) {
conds = 1.;
} else if (kconds[jtype - 1] == 2) {
conds = rtulpi;
} else {
conds = 0.;
}
*(unsigned char *)&adumma[0] = ' ';
dlatme_(&n, "S", &iseed[1], &work[1], &imode, &cond, &c_b32,
adumma, "T", "T", "T", &work[n + 1], &c__4, &conds, &
n, &n, &anorm, &a[a_offset], lda, &work[(n << 1) + 1],
&iinfo);
} else if (itype == 7) {
/* Diagonal, random eigenvalues */
dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &c__0, &
c__0, &c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[
1], &iinfo);
} else if (itype == 8) {
/* Symmetric, random eigenvalues */
dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else if (itype == 9) {
/* General, random eigenvalues */
dlatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else if (itype == 10) {
/* Triangular, random eigenvalues */
dlatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &c__0, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else {
iinfo = 1;
}
if (iinfo != 0) {
io___36.ciunit = *nounit;
s_wsfe(&io___36);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L100:
/* Call DGEHRD to compute H and U, do tests. */
dlacpy_(" ", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
ntest = 1;
ilo = 1;
ihi = n;
i__3 = *nwork - n;
dgehrd_(&n, &ilo, &ihi, &h__[h_offset], lda, &work[1], &work[n +
1], &i__3, &iinfo);
if (iinfo != 0) {
result[1] = ulpinv;
io___39.ciunit = *nounit;
s_wsfe(&io___39);
do_fio(&c__1, "DGEHRD", (ftnlen)6);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L250;
}
i__3 = n - 1;
for (j = 1; j <= i__3; ++j) {
uu_ref(j + 1, j) = 0.;
i__4 = n;
for (i__ = j + 2; i__ <= i__4; ++i__) {
u_ref(i__, j) = h___ref(i__, j);
uu_ref(i__, j) = h___ref(i__, j);
h___ref(i__, j) = 0.;
/* L110: */
}
/* L120: */
}
dcopy_(&n, &work[1], &c__1, &tau[1], &c__1);
i__3 = *nwork - n;
dorghr_(&n, &ilo, &ihi, &u[u_offset], ldu, &work[1], &work[n + 1],
&i__3, &iinfo);
ntest = 2;
dhst01_(&n, &ilo, &ihi, &a[a_offset], lda, &h__[h_offset], lda, &
u[u_offset], ldu, &work[1], nwork, &result[1]);
/* Call DHSEQR to compute T1, T2 and Z, do tests.
Eigenvalues only (WR3,WI3) */
dlacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda);
ntest = 3;
result[3] = ulpinv;
dhseqr_("E", "N", &n, &ilo, &ihi, &t2[t2_offset], lda, &wr3[1], &
wi3[1], &uz[uz_offset], ldu, &work[1], nwork, &iinfo);
if (iinfo != 0) {
io___41.ciunit = *nounit;
s_wsfe(&io___41);
do_fio(&c__1, "DHSEQR(E)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
if (iinfo <= n + 2) {
*info = abs(iinfo);
goto L250;
}
}
/* Eigenvalues (WR1,WI1) and Full Schur Form (T2) */
dlacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda);
dhseqr_("S", "N", &n, &ilo, &ihi, &t2[t2_offset], lda, &wr1[1], &
wi1[1], &uz[uz_offset], ldu, &work[1], nwork, &iinfo);
if (iinfo != 0 && iinfo <= n + 2) {
io___42.ciunit = *nounit;
s_wsfe(&io___42);
do_fio(&c__1, "DHSEQR(S)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L250;
}
/* Eigenvalues (WR1,WI1), Schur Form (T1), and Schur vectors
(UZ) */
dlacpy_(" ", &n, &n, &h__[h_offset], lda, &t1[t1_offset], lda);
dlacpy_(" ", &n, &n, &u[u_offset], ldu, &uz[uz_offset], lda);
dhseqr_("S", "V", &n, &ilo, &ihi, &t1[t1_offset], lda, &wr1[1], &
wi1[1], &uz[uz_offset], ldu, &work[1], nwork, &iinfo);
if (iinfo != 0 && iinfo <= n + 2) {
io___43.ciunit = *nounit;
s_wsfe(&io___43);
do_fio(&c__1, "DHSEQR(V)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L250;
}
/* Compute Z = U' UZ */
dgemm_("T", "N", &n, &n, &n, &c_b32, &u[u_offset], ldu, &uz[
uz_offset], ldu, &c_b18, &z__[z_offset], ldu);
ntest = 8;
/* Do Tests 3: | H - Z T Z' | / ( |H| n ulp )
and 4: | I - Z Z' | / ( n ulp ) */
dhst01_(&n, &ilo, &ihi, &h__[h_offset], lda, &t1[t1_offset], lda,
&z__[z_offset], ldu, &work[1], nwork, &result[3]);
/* Do Tests 5: | A - UZ T (UZ)' | / ( |A| n ulp )
and 6: | I - UZ (UZ)' | / ( n ulp ) */
dhst01_(&n, &ilo, &ihi, &a[a_offset], lda, &t1[t1_offset], lda, &
uz[uz_offset], ldu, &work[1], nwork, &result[5]);
/* Do Test 7: | T2 - T1 | / ( |T| n ulp ) */
dget10_(&n, &n, &t2[t2_offset], lda, &t1[t1_offset], lda, &work[1]
, &result[7]);
/* Do Test 8: | W3 - W1 | / ( max(|W1|,|W3|) ulp ) */
temp1 = 0.;
temp2 = 0.;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
/* Computing MAX */
d__5 = temp1, d__6 = (d__1 = wr1[j], abs(d__1)) + (d__2 = wi1[
j], abs(d__2)), d__5 = max(d__5,d__6), d__6 = (d__3 =
wr3[j], abs(d__3)) + (d__4 = wi3[j], abs(d__4));
temp1 = max(d__5,d__6);
/* Computing MAX */
d__3 = temp2, d__4 = (d__1 = wr1[j] - wr3[j], abs(d__1)) + (
d__2 = wr1[j] - wr3[j], abs(d__2));
temp2 = max(d__3,d__4);
/* L130: */
}
/* Computing MAX */
d__1 = unfl, d__2 = ulp * max(temp1,temp2);
result[8] = temp2 / max(d__1,d__2);
/* Compute the Left and Right Eigenvectors of T
Compute the Right eigenvector Matrix: */
ntest = 9;
result[9] = ulpinv;
/* Select last max(N/4,1) real, max(N/4,1) complex eigenvectors */
nselc = 0;
nselr = 0;
j = n;
L140:
if (wi1[j] == 0.) {
/* Computing MAX */
i__3 = n / 4;
if (nselr < max(i__3,1)) {
++nselr;
select[j] = TRUE_;
} else {
select[j] = FALSE_;
}
--j;
} else {
/* Computing MAX */
i__3 = n / 4;
if (nselc < max(i__3,1)) {
++nselc;
select[j] = TRUE_;
select[j - 1] = FALSE_;
} else {
select[j] = FALSE_;
select[j - 1] = FALSE_;
}
j += -2;
}
if (j > 0) {
goto L140;
}
dtrevc_("Right", "All", &select[1], &n, &t1[t1_offset], lda,
dumma, ldu, &evectr[evectr_offset], ldu, &n, &in, &work[1]
, &iinfo);
if (iinfo != 0) {
io___50.ciunit = *nounit;
s_wsfe(&io___50);
do_fio(&c__1, "DTREVC(R,A)", (ftnlen)11);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L250;
}
/* Test 9: | TR - RW | / ( |T| |R| ulp ) */
dget22_("N", "N", "N", &n, &t1[t1_offset], lda, &evectr[
evectr_offset], ldu, &wr1[1], &wi1[1], &work[1], dumma);
result[9] = dumma[0];
if (dumma[1] > *thresh) {
io___51.ciunit = *nounit;
s_wsfe(&io___51);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "DTREVC", (ftnlen)6);
do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Compute selected right eigenvectors and confirm that
they agree with previous right eigenvectors */
dtrevc_("Right", "Some", &select[1], &n, &t1[t1_offset], lda,
dumma, ldu, &evectl[evectl_offset], ldu, &n, &in, &work[1]
, &iinfo);
if (iinfo != 0) {
io___52.ciunit = *nounit;
s_wsfe(&io___52);
do_fio(&c__1, "DTREVC(R,S)", (ftnlen)11);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L250;
}
k = 1;
match = TRUE_;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
if (select[j] && wi1[j] == 0.) {
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
if (evectr_ref(jj, j) != evectl_ref(jj, k)) {
match = FALSE_;
goto L180;
}
/* L150: */
}
++k;
} else if (select[j] && wi1[j] != 0.) {
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
if (evectr_ref(jj, j) != evectl_ref(jj, k) ||
evectr_ref(jj, j + 1) != evectl_ref(jj, k + 1)
) {
match = FALSE_;
goto L180;
}
/* L160: */
}
k += 2;
}
/* L170: */
}
L180:
if (! match) {
io___56.ciunit = *nounit;
s_wsfe(&io___56);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "DTREVC", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Compute the Left eigenvector Matrix: */
ntest = 10;
result[10] = ulpinv;
dtrevc_("Left", "All", &select[1], &n, &t1[t1_offset], lda, &
evectl[evectl_offset], ldu, dumma, ldu, &n, &in, &work[1],
&iinfo);
if (iinfo != 0) {
io___57.ciunit = *nounit;
s_wsfe(&io___57);
do_fio(&c__1, "DTREVC(L,A)", (ftnlen)11);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L250;
}
/* Test 10: | LT - WL | / ( |T| |L| ulp ) */
dget22_("Trans", "N", "Conj", &n, &t1[t1_offset], lda, &evectl[
evectl_offset], ldu, &wr1[1], &wi1[1], &work[1], &dumma[2]
);
result[10] = dumma[2];
if (dumma[3] > *thresh) {
io___58.ciunit = *nounit;
s_wsfe(&io___58);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "DTREVC", (ftnlen)6);
do_fio(&c__1, (char *)&dumma[3], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Compute selected left eigenvectors and confirm that
they agree with previous left eigenvectors */
dtrevc_("Left", "Some", &select[1], &n, &t1[t1_offset], lda, &
evectr[evectr_offset], ldu, dumma, ldu, &n, &in, &work[1],
&iinfo);
if (iinfo != 0) {
io___59.ciunit = *nounit;
s_wsfe(&io___59);
do_fio(&c__1, "DTREVC(L,S)", (ftnlen)11);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L250;
}
k = 1;
match = TRUE_;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
if (select[j] && wi1[j] == 0.) {
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
if (evectl_ref(jj, j) != evectr_ref(jj, k)) {
match = FALSE_;
goto L220;
}
/* L190: */
}
++k;
} else if (select[j] && wi1[j] != 0.) {
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
if (evectl_ref(jj, j) != evectr_ref(jj, k) ||
evectl_ref(jj, j + 1) != evectr_ref(jj, k + 1)
) {
match = FALSE_;
goto L220;
}
/* L200: */
}
k += 2;
}
/* L210: */
}
L220:
if (! match) {
io___60.ciunit = *nounit;
s_wsfe(&io___60);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "DTREVC", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Call DHSEIN for Right eigenvectors of H, do test 11 */
ntest = 11;
result[11] = ulpinv;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
select[j] = TRUE_;
/* L230: */
}
dhsein_("Right", "Qr", "Ninitv", &select[1], &n, &h__[h_offset],
lda, &wr3[1], &wi3[1], dumma, ldu, &evectx[evectx_offset],
ldu, &n1, &in, &work[1], &iwork[1], &iwork[1], &iinfo);
if (iinfo != 0) {
io___61.ciunit = *nounit;
s_wsfe(&io___61);
do_fio(&c__1, "DHSEIN(R)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
goto L250;
}
} else {
/* Test 11: | HX - XW | / ( |H| |X| ulp )
(from inverse iteration) */
dget22_("N", "N", "N", &n, &h__[h_offset], lda, &evectx[
evectx_offset], ldu, &wr3[1], &wi3[1], &work[1],
dumma);
if (dumma[0] < ulpinv) {
result[11] = dumma[0] * aninv;
}
if (dumma[1] > *thresh) {
io___62.ciunit = *nounit;
s_wsfe(&io___62);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "DHSEIN", (ftnlen)6);
do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(
doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
}
}
/* Call DHSEIN for Left eigenvectors of H, do test 12 */
ntest = 12;
result[12] = ulpinv;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
select[j] = TRUE_;
/* L240: */
}
dhsein_("Left", "Qr", "Ninitv", &select[1], &n, &h__[h_offset],
lda, &wr3[1], &wi3[1], &evecty[evecty_offset], ldu, dumma,
ldu, &n1, &in, &work[1], &iwork[1], &iwork[1], &iinfo);
if (iinfo != 0) {
io___63.ciunit = *nounit;
s_wsfe(&io___63);
do_fio(&c__1, "DHSEIN(L)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
goto L250;
}
} else {
/* Test 12: | YH - WY | / ( |H| |Y| ulp )
(from inverse iteration) */
dget22_("C", "N", "C", &n, &h__[h_offset], lda, &evecty[
evecty_offset], ldu, &wr3[1], &wi3[1], &work[1], &
dumma[2]);
if (dumma[2] < ulpinv) {
result[12] = dumma[2] * aninv;
}
if (dumma[3] > *thresh) {
io___64.ciunit = *nounit;
s_wsfe(&io___64);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "DHSEIN", (ftnlen)6);
do_fio(&c__1, (char *)&dumma[3], (ftnlen)sizeof(
doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
}
}
/* Call DORMHR for Right eigenvectors of A, do test 13 */
ntest = 13;
result[13] = ulpinv;
dormhr_("Left", "No transpose", &n, &n, &ilo, &ihi, &uu[uu_offset]
, ldu, &tau[1], &evectx[evectx_offset], ldu, &work[1],
nwork, &iinfo);
if (iinfo != 0) {
io___65.ciunit = *nounit;
s_wsfe(&io___65);
do_fio(&c__1, "DORMHR(R)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
goto L250;
}
} else {
/* Test 13: | AX - XW | / ( |A| |X| ulp )
(from inverse iteration) */
dget22_("N", "N", "N", &n, &a[a_offset], lda, &evectx[
evectx_offset], ldu, &wr3[1], &wi3[1], &work[1],
dumma);
if (dumma[0] < ulpinv) {
result[13] = dumma[0] * aninv;
}
}
/* Call DORMHR for Left eigenvectors of A, do test 14 */
ntest = 14;
result[14] = ulpinv;
dormhr_("Left", "No transpose", &n, &n, &ilo, &ihi, &uu[uu_offset]
, ldu, &tau[1], &evecty[evecty_offset], ldu, &work[1],
nwork, &iinfo);
if (iinfo != 0) {
io___66.ciunit = *nounit;
s_wsfe(&io___66);
do_fio(&c__1, "DORMHR(L)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
goto L250;
}
} else {
/* Test 14: | YA - WY | / ( |A| |Y| ulp )
(from inverse iteration) */
dget22_("C", "N", "C", &n, &a[a_offset], lda, &evecty[
evecty_offset], ldu, &wr3[1], &wi3[1], &work[1], &
dumma[2]);
if (dumma[2] < ulpinv) {
result[14] = dumma[2] * aninv;
}
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L250:
ntestt += ntest;
dlafts_("DHS", &n, &n, &jtype, &ntest, &result[1], ioldsd, thresh,
nounit, &nerrs);
L260:
;
}
L270:
;
}
/* Summary */
dlasum_("DHS", nounit, &nerrs, &ntestt);
return 0;
/* End of DCHKHS */
} /* dchkhs_ */
/* Subroutine */ int zhsein_(char *side, char *eigsrc, char *initv, logical *
select, integer *n, doublecomplex *h__, integer *ldh, doublecomplex *
w, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr,
integer *mm, integer *m, doublecomplex *work, doublereal *rwork,
integer *ifaill, integer *ifailr, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZHSEIN uses inverse iteration to find specified right and/or left
eigenvectors of a complex upper Hessenberg matrix H.
The right eigenvector x and the left eigenvector y of the matrix H
corresponding to an eigenvalue w are defined by:
H * x = w * x, y**h * H = w * y**h
where y**h denotes the conjugate transpose of the vector y.
Arguments
=========
SIDE (input) CHARACTER*1
= 'R': compute right eigenvectors only;
= 'L': compute left eigenvectors only;
= 'B': compute both right and left eigenvectors.
EIGSRC (input) CHARACTER*1
Specifies the source of eigenvalues supplied in W:
= 'Q': the eigenvalues were found using ZHSEQR; thus, if
H has zero subdiagonal elements, and so is
block-triangular, then the j-th eigenvalue can be
assumed to be an eigenvalue of the block containing
the j-th row/column. This property allows ZHSEIN to
perform inverse iteration on just one diagonal block.
= 'N': no assumptions are made on the correspondence
between eigenvalues and diagonal blocks. In this
case, ZHSEIN must always perform inverse iteration
using the whole matrix H.
INITV (input) CHARACTER*1
= 'N': no initial vectors are supplied;
= 'U': user-supplied initial vectors are stored in the arrays
VL and/or VR.
SELECT (input) LOGICAL array, dimension (N)
Specifies the eigenvectors to be computed. To select the
eigenvector corresponding to the eigenvalue W(j),
SELECT(j) must be set to .TRUE..
N (input) INTEGER
The order of the matrix H. N >= 0.
H (input) COMPLEX*16 array, dimension (LDH,N)
The upper Hessenberg matrix H.
LDH (input) INTEGER
The leading dimension of the array H. LDH >= max(1,N).
W (input/output) COMPLEX*16 array, dimension (N)
On entry, the eigenvalues of H.
On exit, the real parts of W may have been altered since
close eigenvalues are perturbed slightly in searching for
independent eigenvectors.
VL (input/output) COMPLEX*16 array, dimension (LDVL,MM)
On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must
contain starting vectors for the inverse iteration for the
left eigenvectors; the starting vector for each eigenvector
must be in the same column in which the eigenvector will be
stored.
On exit, if SIDE = 'L' or 'B', the left eigenvectors
specified by SELECT will be stored consecutively in the
columns of VL, in the same order as their eigenvalues.
If SIDE = 'R', VL is not referenced.
LDVL (input) INTEGER
The leading dimension of the array VL.
LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
VR (input/output) COMPLEX*16 array, dimension (LDVR,MM)
On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must
contain starting vectors for the inverse iteration for the
right eigenvectors; the starting vector for each eigenvector
must be in the same column in which the eigenvector will be
stored.
On exit, if SIDE = 'R' or 'B', the right eigenvectors
specified by SELECT will be stored consecutively in the
columns of VR, in the same order as their eigenvalues.
If SIDE = 'L', VR is not referenced.
LDVR (input) INTEGER
The leading dimension of the array VR.
LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.
MM (input) INTEGER
The number of columns in the arrays VL and/or VR. MM >= M.
M (output) INTEGER
The number of columns in the arrays VL and/or VR required to
store the eigenvectors (= the number of .TRUE. elements in
SELECT).
WORK (workspace) COMPLEX*16 array, dimension (N*N)
RWORK (workspace) DOUBLE PRECISION array, dimension (N)
IFAILL (output) INTEGER array, dimension (MM)
If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left
eigenvector in the i-th column of VL (corresponding to the
eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the
eigenvector converged satisfactorily.
If SIDE = 'R', IFAILL is not referenced.
IFAILR (output) INTEGER array, dimension (MM)
If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right
eigenvector in the i-th column of VR (corresponding to the
eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the
eigenvector converged satisfactorily.
If SIDE = 'L', IFAILR is not referenced.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, i is the number of eigenvectors which
failed to converge; see IFAILL and IFAILR for further
details.
Further Details
===============
Each eigenvector is normalized so that the element of largest
magnitude has magnitude 1; here the magnitude of a complex number
(x,y) is taken to be |x|+|y|.
=====================================================================
Decode and test the input parameters.
Parameter adjustments */
/* Table of constant values */
static logical c_false = FALSE_;
static logical c_true = TRUE_;
/* System generated locals */
integer h_dim1, h_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3;
doublereal d__1, d__2;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static doublereal unfl;
static integer i__, k;
extern logical lsame_(char *, char *);
static integer iinfo;
static logical leftv, bothv;
static doublereal hnorm;
static integer kl;
extern doublereal dlamch_(char *);
static integer kr, ks;
static doublecomplex wk;
extern /* Subroutine */ int xerbla_(char *, integer *), zlaein_(
logical *, logical *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublereal *, doublereal *, doublereal *, integer *);
extern doublereal zlanhs_(char *, integer *, doublecomplex *, integer *,
doublereal *);
static logical noinit;
static integer ldwork;
static logical rightv, fromqr;
static doublereal smlnum;
static integer kln;
static doublereal ulp, eps3;
#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 vl_subscr(a_1,a_2) (a_2)*vl_dim1 + a_1
#define vl_ref(a_1,a_2) vl[vl_subscr(a_1,a_2)]
#define vr_subscr(a_1,a_2) (a_2)*vr_dim1 + a_1
#define vr_ref(a_1,a_2) vr[vr_subscr(a_1,a_2)]
--select;
h_dim1 = *ldh;
h_offset = 1 + h_dim1 * 1;
h__ -= h_offset;
--w;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1 * 1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1 * 1;
vr -= vr_offset;
--work;
--rwork;
--ifaill;
--ifailr;
/* Function Body */
bothv = lsame_(side, "B");
rightv = lsame_(side, "R") || bothv;
leftv = lsame_(side, "L") || bothv;
fromqr = lsame_(eigsrc, "Q");
noinit = lsame_(initv, "N");
/* Set M to the number of columns required to store the selected
eigenvectors. */
*m = 0;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (select[k]) {
++(*m);
}
/* L10: */
}
*info = 0;
if (! rightv && ! leftv) {
*info = -1;
} else if (! fromqr && ! lsame_(eigsrc, "N")) {
*info = -2;
} else if (! noinit && ! lsame_(initv, "U")) {
*info = -3;
} else if (*n < 0) {
*info = -5;
} else if (*ldh < max(1,*n)) {
*info = -7;
} else if (*ldvl < 1 || leftv && *ldvl < *n) {
*info = -10;
} else if (*ldvr < 1 || rightv && *ldvr < *n) {
*info = -12;
} else if (*mm < *m) {
*info = -13;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHSEIN", &i__1);
return 0;
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
/* Set machine-dependent constants. */
unfl = dlamch_("Safe minimum");
ulp = dlamch_("Precision");
smlnum = unfl * (*n / ulp);
ldwork = *n;
kl = 1;
kln = 0;
if (fromqr) {
kr = 0;
} else {
kr = *n;
}
ks = 1;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (select[k]) {
/* Compute eigenvector(s) corresponding to W(K). */
if (fromqr) {
/* If affiliation of eigenvalues is known, check whether
the matrix splits.
Determine KL and KR such that 1 <= KL <= K <= KR <= N
and H(KL,KL-1) and H(KR+1,KR) are zero (or KL = 1 or
KR = N).
Then inverse iteration can be performed with the
submatrix H(KL:N,KL:N) for a left eigenvector, and with
the submatrix H(1:KR,1:KR) for a right eigenvector. */
i__2 = kl + 1;
for (i__ = k; i__ >= i__2; --i__) {
i__3 = h___subscr(i__, i__ - 1);
if (h__[i__3].r == 0. && h__[i__3].i == 0.) {
goto L30;
}
/* L20: */
}
L30:
kl = i__;
if (k > kr) {
i__2 = *n - 1;
for (i__ = k; i__ <= i__2; ++i__) {
i__3 = h___subscr(i__ + 1, i__);
if (h__[i__3].r == 0. && h__[i__3].i == 0.) {
goto L50;
}
/* L40: */
}
L50:
kr = i__;
}
}
if (kl != kln) {
kln = kl;
/* Compute infinity-norm of submatrix H(KL:KR,KL:KR) if it
has not ben computed before. */
i__2 = kr - kl + 1;
hnorm = zlanhs_("I", &i__2, &h___ref(kl, kl), ldh, &rwork[1]);
if (hnorm > 0.) {
eps3 = hnorm * ulp;
} else {
eps3 = smlnum;
}
}
/* Perturb eigenvalue if it is close to any previous
selected eigenvalues affiliated to the submatrix
H(KL:KR,KL:KR). Close roots are modified by EPS3. */
i__2 = k;
wk.r = w[i__2].r, wk.i = w[i__2].i;
L60:
i__2 = kl;
for (i__ = k - 1; i__ >= i__2; --i__) {
i__3 = i__;
z__2.r = w[i__3].r - wk.r, z__2.i = w[i__3].i - wk.i;
z__1.r = z__2.r, z__1.i = z__2.i;
if (select[i__] && (d__1 = z__1.r, abs(d__1)) + (d__2 =
d_imag(&z__1), abs(d__2)) < eps3) {
z__1.r = wk.r + eps3, z__1.i = wk.i;
wk.r = z__1.r, wk.i = z__1.i;
goto L60;
}
/* L70: */
}
i__2 = k;
w[i__2].r = wk.r, w[i__2].i = wk.i;
if (leftv) {
/* Compute left eigenvector. */
i__2 = *n - kl + 1;
zlaein_(&c_false, &noinit, &i__2, &h___ref(kl, kl), ldh, &wk,
&vl_ref(kl, ks), &work[1], &ldwork, &rwork[1], &eps3,
&smlnum, &iinfo);
if (iinfo > 0) {
++(*info);
ifaill[ks] = k;
} else {
ifaill[ks] = 0;
}
i__2 = kl - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = vl_subscr(i__, ks);
vl[i__3].r = 0., vl[i__3].i = 0.;
/* L80: */
}
}
if (rightv) {
/* Compute right eigenvector. */
zlaein_(&c_true, &noinit, &kr, &h__[h_offset], ldh, &wk, &
vr_ref(1, ks), &work[1], &ldwork, &rwork[1], &eps3, &
smlnum, &iinfo);
if (iinfo > 0) {
++(*info);
ifailr[ks] = k;
} else {
ifailr[ks] = 0;
}
i__2 = *n;
for (i__ = kr + 1; i__ <= i__2; ++i__) {
i__3 = vr_subscr(i__, ks);
vr[i__3].r = 0., vr[i__3].i = 0.;
/* L90: */
}
}
++ks;
}
/* L100: */
}
return 0;
/* End of ZHSEIN */
} /* zhsein_ */
/* Subroutine */ int shsein_(char *side, char *eigsrc, char *initv, logical *
select, integer *n, real *h__, integer *ldh, real *wr, real *wi, real
*vl, integer *ldvl, real *vr, integer *ldvr, integer *mm, integer *m,
real *work, integer *ifaill, integer *ifailr, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
SHSEIN uses inverse iteration to find specified right and/or left
eigenvectors of a real upper Hessenberg matrix H.
The right eigenvector x and the left eigenvector y of the matrix H
corresponding to an eigenvalue w are defined by:
H * x = w * x, y**h * H = w * y**h
where y**h denotes the conjugate transpose of the vector y.
Arguments
=========
SIDE (input) CHARACTER*1
= 'R': compute right eigenvectors only;
= 'L': compute left eigenvectors only;
= 'B': compute both right and left eigenvectors.
EIGSRC (input) CHARACTER*1
Specifies the source of eigenvalues supplied in (WR,WI):
= 'Q': the eigenvalues were found using SHSEQR; thus, if
H has zero subdiagonal elements, and so is
block-triangular, then the j-th eigenvalue can be
assumed to be an eigenvalue of the block containing
the j-th row/column. This property allows SHSEIN to
perform inverse iteration on just one diagonal block.
= 'N': no assumptions are made on the correspondence
between eigenvalues and diagonal blocks. In this
case, SHSEIN must always perform inverse iteration
using the whole matrix H.
INITV (input) CHARACTER*1
= 'N': no initial vectors are supplied;
= 'U': user-supplied initial vectors are stored in the arrays
VL and/or VR.
SELECT (input/output) LOGICAL array, dimension (N)
Specifies the eigenvectors to be computed. To select the
real eigenvector corresponding to a real eigenvalue WR(j),
SELECT(j) must be set to .TRUE.. To select the complex
eigenvector corresponding to a complex eigenvalue
(WR(j),WI(j)), with complex conjugate (WR(j+1),WI(j+1)),
either SELECT(j) or SELECT(j+1) or both must be set to
.TRUE.; then on exit SELECT(j) is .TRUE. and SELECT(j+1) is
.FALSE..
N (input) INTEGER
The order of the matrix H. N >= 0.
H (input) REAL array, dimension (LDH,N)
The upper Hessenberg matrix H.
LDH (input) INTEGER
The leading dimension of the array H. LDH >= max(1,N).
WR (input/output) REAL array, dimension (N)
WI (input) REAL array, dimension (N)
On entry, the real and imaginary parts of the eigenvalues of
H; a complex conjugate pair of eigenvalues must be stored in
consecutive elements of WR and WI.
On exit, WR may have been altered since close eigenvalues
are perturbed slightly in searching for independent
eigenvectors.
VL (input/output) REAL array, dimension (LDVL,MM)
On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must
contain starting vectors for the inverse iteration for the
left eigenvectors; the starting vector for each eigenvector
must be in the same column(s) in which the eigenvector will
be stored.
On exit, if SIDE = 'L' or 'B', the left eigenvectors
specified by SELECT will be stored consecutively in the
columns of VL, in the same order as their eigenvalues. A
complex eigenvector corresponding to a complex eigenvalue is
stored in two consecutive columns, the first holding the real
part and the second the imaginary part.
If SIDE = 'R', VL is not referenced.
LDVL (input) INTEGER
The leading dimension of the array VL.
LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
VR (input/output) REAL array, dimension (LDVR,MM)
On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must
contain starting vectors for the inverse iteration for the
right eigenvectors; the starting vector for each eigenvector
must be in the same column(s) in which the eigenvector will
be stored.
On exit, if SIDE = 'R' or 'B', the right eigenvectors
specified by SELECT will be stored consecutively in the
columns of VR, in the same order as their eigenvalues. A
complex eigenvector corresponding to a complex eigenvalue is
stored in two consecutive columns, the first holding the real
part and the second the imaginary part.
If SIDE = 'L', VR is not referenced.
LDVR (input) INTEGER
The leading dimension of the array VR.
LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.
MM (input) INTEGER
The number of columns in the arrays VL and/or VR. MM >= M.
M (output) INTEGER
The number of columns in the arrays VL and/or VR required to
store the eigenvectors; each selected real eigenvector
occupies one column and each selected complex eigenvector
occupies two columns.
WORK (workspace) REAL array, dimension ((N+2)*N)
IFAILL (output) INTEGER array, dimension (MM)
If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left
eigenvector in the i-th column of VL (corresponding to the
eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the
eigenvector converged satisfactorily. If the i-th and (i+1)th
columns of VL hold a complex eigenvector, then IFAILL(i) and
IFAILL(i+1) are set to the same value.
If SIDE = 'R', IFAILL is not referenced.
IFAILR (output) INTEGER array, dimension (MM)
If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right
eigenvector in the i-th column of VR (corresponding to the
eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the
eigenvector converged satisfactorily. If the i-th and (i+1)th
columns of VR hold a complex eigenvector, then IFAILR(i) and
IFAILR(i+1) are set to the same value.
If SIDE = 'L', IFAILR is not referenced.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, i is the number of eigenvectors which
failed to converge; see IFAILL and IFAILR for further
details.
Further Details
===============
Each eigenvector is normalized so that the element of largest
magnitude has magnitude 1; here the magnitude of a complex number
(x,y) is taken to be |x|+|y|.
=====================================================================
Decode and test the input parameters.
Parameter adjustments */
/* Table of constant values */
static logical c_false = FALSE_;
static logical c_true = TRUE_;
/* System generated locals */
integer h_dim1, h_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2;
real r__1, r__2;
/* Local variables */
static logical pair;
static real unfl;
static integer i__, k;
extern logical lsame_(char *, char *);
static integer iinfo;
static logical leftv, bothv;
static real hnorm;
static integer kl, kr;
extern doublereal slamch_(char *);
extern /* Subroutine */ int slaein_(logical *, logical *, integer *, real
*, integer *, real *, real *, real *, real *, real *, integer *,
real *, real *, real *, real *, integer *), xerbla_(char *,
integer *);
static real bignum;
extern doublereal slanhs_(char *, integer *, real *, integer *, real *);
static logical noinit;
static integer ldwork;
static logical rightv, fromqr;
static real smlnum;
static integer kln, ksi;
static real wki;
static integer ksr;
static real ulp, wkr, eps3;
#define h___ref(a_1,a_2) h__[(a_2)*h_dim1 + a_1]
#define vl_ref(a_1,a_2) vl[(a_2)*vl_dim1 + a_1]
#define vr_ref(a_1,a_2) vr[(a_2)*vr_dim1 + a_1]
--select;
h_dim1 = *ldh;
h_offset = 1 + h_dim1 * 1;
h__ -= h_offset;
--wr;
--wi;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1 * 1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1 * 1;
vr -= vr_offset;
--work;
--ifaill;
--ifailr;
/* Function Body */
bothv = lsame_(side, "B");
rightv = lsame_(side, "R") || bothv;
leftv = lsame_(side, "L") || bothv;
fromqr = lsame_(eigsrc, "Q");
noinit = lsame_(initv, "N");
/* Set M to the number of columns required to store the selected
eigenvectors, and standardize the array SELECT. */
*m = 0;
pair = FALSE_;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (pair) {
pair = FALSE_;
select[k] = FALSE_;
} else {
if (wi[k] == 0.f) {
if (select[k]) {
++(*m);
}
} else {
pair = TRUE_;
if (select[k] || select[k + 1]) {
select[k] = TRUE_;
*m += 2;
}
}
}
/* L10: */
}
*info = 0;
if (! rightv && ! leftv) {
*info = -1;
} else if (! fromqr && ! lsame_(eigsrc, "N")) {
*info = -2;
} else if (! noinit && ! lsame_(initv, "U")) {
*info = -3;
} else if (*n < 0) {
*info = -5;
} else if (*ldh < max(1,*n)) {
*info = -7;
} else if (*ldvl < 1 || leftv && *ldvl < *n) {
*info = -11;
} else if (*ldvr < 1 || rightv && *ldvr < *n) {
*info = -13;
} else if (*mm < *m) {
*info = -14;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SHSEIN", &i__1);
return 0;
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
/* Set machine-dependent constants. */
unfl = slamch_("Safe minimum");
ulp = slamch_("Precision");
smlnum = unfl * (*n / ulp);
bignum = (1.f - ulp) / smlnum;
ldwork = *n + 1;
kl = 1;
kln = 0;
if (fromqr) {
kr = 0;
} else {
kr = *n;
}
ksr = 1;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (select[k]) {
/* Compute eigenvector(s) corresponding to W(K). */
if (fromqr) {
/* If affiliation of eigenvalues is known, check whether
the matrix splits.
Determine KL and KR such that 1 <= KL <= K <= KR <= N
and H(KL,KL-1) and H(KR+1,KR) are zero (or KL = 1 or
KR = N).
Then inverse iteration can be performed with the
submatrix H(KL:N,KL:N) for a left eigenvector, and with
the submatrix H(1:KR,1:KR) for a right eigenvector. */
i__2 = kl + 1;
for (i__ = k; i__ >= i__2; --i__) {
if (h___ref(i__, i__ - 1) == 0.f) {
goto L30;
}
/* L20: */
}
L30:
kl = i__;
if (k > kr) {
i__2 = *n - 1;
for (i__ = k; i__ <= i__2; ++i__) {
if (h___ref(i__ + 1, i__) == 0.f) {
goto L50;
}
/* L40: */
}
L50:
kr = i__;
}
}
if (kl != kln) {
kln = kl;
/* Compute infinity-norm of submatrix H(KL:KR,KL:KR) if it
has not ben computed before. */
i__2 = kr - kl + 1;
hnorm = slanhs_("I", &i__2, &h___ref(kl, kl), ldh, &work[1]);
if (hnorm > 0.f) {
eps3 = hnorm * ulp;
} else {
eps3 = smlnum;
}
}
/* Perturb eigenvalue if it is close to any previous
selected eigenvalues affiliated to the submatrix
H(KL:KR,KL:KR). Close roots are modified by EPS3. */
wkr = wr[k];
wki = wi[k];
L60:
i__2 = kl;
for (i__ = k - 1; i__ >= i__2; --i__) {
if (select[i__] && (r__1 = wr[i__] - wkr, dabs(r__1)) + (r__2
= wi[i__] - wki, dabs(r__2)) < eps3) {
wkr += eps3;
goto L60;
}
/* L70: */
}
wr[k] = wkr;
pair = wki != 0.f;
if (pair) {
ksi = ksr + 1;
} else {
ksi = ksr;
}
if (leftv) {
/* Compute left eigenvector. */
i__2 = *n - kl + 1;
slaein_(&c_false, &noinit, &i__2, &h___ref(kl, kl), ldh, &wkr,
&wki, &vl_ref(kl, ksr), &vl_ref(kl, ksi), &work[1], &
ldwork, &work[*n * *n + *n + 1], &eps3, &smlnum, &
bignum, &iinfo);
if (iinfo > 0) {
if (pair) {
*info += 2;
} else {
++(*info);
}
ifaill[ksr] = k;
ifaill[ksi] = k;
} else {
ifaill[ksr] = 0;
ifaill[ksi] = 0;
}
i__2 = kl - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
vl_ref(i__, ksr) = 0.f;
/* L80: */
}
if (pair) {
i__2 = kl - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
vl_ref(i__, ksi) = 0.f;
/* L90: */
}
}
}
if (rightv) {
/* Compute right eigenvector. */
slaein_(&c_true, &noinit, &kr, &h__[h_offset], ldh, &wkr, &
wki, &vr_ref(1, ksr), &vr_ref(1, ksi), &work[1], &
ldwork, &work[*n * *n + *n + 1], &eps3, &smlnum, &
bignum, &iinfo);
if (iinfo > 0) {
if (pair) {
*info += 2;
} else {
++(*info);
}
ifailr[ksr] = k;
ifailr[ksi] = k;
} else {
ifailr[ksr] = 0;
ifailr[ksi] = 0;
}
i__2 = *n;
for (i__ = kr + 1; i__ <= i__2; ++i__) {
vr_ref(i__, ksr) = 0.f;
/* L100: */
}
if (pair) {
i__2 = *n;
for (i__ = kr + 1; i__ <= i__2; ++i__) {
vr_ref(i__, ksi) = 0.f;
/* L110: */
}
}
}
if (pair) {
ksr += 2;
} else {
++ksr;
}
}
/* L120: */
}
return 0;
/* End of SHSEIN */
} /* shsein_ */
/* Subroutine */ int dlahqr_(logical *wantt, logical *wantz, integer *n,
integer *ilo, integer *ihi, doublereal *h__, integer *ldh, doublereal
*wr, doublereal *wi, integer *iloz, integer *ihiz, doublereal *z__,
integer *ldz, integer *info)
{
/* System generated locals */
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
static doublereal h43h34, disc, unfl, ovfl;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
static doublereal work[1], opst;
static integer i__, j, k, l, m;
static doublereal s, v[3];
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
static integer i1, i2;
static doublereal t1, t2, t3, v1, v2, v3;
extern /* Subroutine */ int dlanv2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *), dlabad_(
doublereal *, doublereal *);
static doublereal h00, h10, h11, h12, h21, h22, h33, h44;
static integer nh;
static doublereal cs;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
integer *, doublereal *);
static integer nr;
static doublereal sn;
static integer nz;
extern doublereal dlanhs_(char *, integer *, doublereal *, integer *,
doublereal *);
static doublereal smlnum, ave, h33s, h44s;
static integer itn, its;
static doublereal ulp, sum, tst1;
#define h___ref(a_1,a_2) h__[(a_2)*h_dim1 + a_1]
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
/* -- LAPACK auxiliary routine (instrum. to count ops. version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Common block to return operation count.
Purpose
=======
DLAHQR is an auxiliary routine called by DHSEQR to update the
eigenvalues and Schur decomposition already computed by DHSEQR, by
dealing with the Hessenberg submatrix in rows and columns ILO to IHI.
Arguments
=========
WANTT (input) LOGICAL
= .TRUE. : the full Schur form T is required;
= .FALSE.: only eigenvalues are required.
WANTZ (input) LOGICAL
= .TRUE. : the matrix of Schur vectors Z is required;
= .FALSE.: Schur vectors are not required.
N (input) INTEGER
The order of the matrix H. N >= 0.
ILO (input) INTEGER
IHI (input) INTEGER
It is assumed that H is already upper quasi-triangular in
rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless
ILO = 1). DLAHQR works primarily with the Hessenberg
submatrix in rows and columns ILO to IHI, but applies
transformations to all of H if WANTT is .TRUE..
1 <= ILO <= max(1,IHI); IHI <= N.
H (input/output) DOUBLE PRECISION array, dimension (LDH,N)
On entry, the upper Hessenberg matrix H.
On exit, if WANTT is .TRUE., H is upper quasi-triangular in
rows and columns ILO:IHI, with any 2-by-2 diagonal blocks in
standard form. If WANTT is .FALSE., the contents of H are
unspecified on exit.
LDH (input) INTEGER
The leading dimension of the array H. LDH >= max(1,N).
WR (output) DOUBLE PRECISION array, dimension (N)
WI (output) DOUBLE PRECISION array, dimension (N)
The real and imaginary parts, respectively, of the computed
eigenvalues ILO to IHI are stored in the corresponding
elements of WR and WI. If two eigenvalues are computed as a
complex conjugate pair, they are stored in consecutive
elements of WR and WI, say the i-th and (i+1)th, with
WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the
eigenvalues are stored in the same order as on the diagonal
of the Schur form returned in H, with WR(i) = H(i,i), and, if
H(i:i+1,i:i+1) is a 2-by-2 diagonal block,
WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i).
ILOZ (input) INTEGER
IHIZ (input) INTEGER
Specify the rows of Z to which transformations must be
applied if WANTZ is .TRUE..
1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
If WANTZ is .TRUE., on entry Z must contain the current
matrix Z of transformations accumulated by DHSEQR, and on
exit Z has been updated; transformations are applied only to
the submatrix Z(ILOZ:IHIZ,ILO:IHI).
If WANTZ is .FALSE., Z is not referenced.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
> 0: DLAHQR failed to compute all the eigenvalues ILO to IHI
in a total of 30*(IHI-ILO+1) iterations; if INFO = i,
elements i+1:ihi of WR and WI contain those eigenvalues
which have been successfully computed.
Further Details
===============
2-96 Based on modifications by
David Day, Sandia National Laboratory, USA
=====================================================================
Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1 * 1;
h__ -= h_offset;
--wr;
--wi;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
/* Function Body */
*info = 0;
/* **
Initialize */
opst = 0.;
/* **
Quick return if possible */
if (*n == 0) {
return 0;
}
if (*ilo == *ihi) {
wr[*ilo] = h___ref(*ilo, *ilo);
wi[*ilo] = 0.;
return 0;
}
nh = *ihi - *ilo + 1;
nz = *ihiz - *iloz + 1;
/* Set machine-dependent constants for the stopping criterion.
If norm(H) <= sqrt(OVFL), overflow should not occur. */
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
dlabad_(&unfl, &ovfl);
ulp = dlamch_("Precision");
smlnum = unfl * (nh / ulp);
/* I1 and I2 are the indices of the first row and last column of H
to which transformations must be applied. If eigenvalues only are
being computed, I1 and I2 are set inside the main loop. */
if (*wantt) {
i1 = 1;
i2 = *n;
}
/* ITN is the total number of QR iterations allowed. */
itn = nh * 30;
/* The main loop begins here. I is the loop index and decreases from
IHI to ILO in steps of 1 or 2. Each iteration of the loop works
with the active submatrix in rows and columns L to I.
Eigenvalues I+1 to IHI have already converged. Either L = ILO or
H(L,L-1) is negligible so that the matrix splits. */
i__ = *ihi;
L10:
l = *ilo;
if (i__ < *ilo) {
goto L150;
}
/* Perform QR iterations on rows and columns ILO to I until a
submatrix of order 1 or 2 splits off at the bottom because a
subdiagonal element has become negligible. */
i__1 = itn;
for (its = 0; its <= i__1; ++its) {
/* Look for a single small subdiagonal element. */
i__2 = l + 1;
for (k = i__; k >= i__2; --k) {
tst1 = (d__1 = h___ref(k - 1, k - 1), abs(d__1)) + (d__2 =
h___ref(k, k), abs(d__2));
if (tst1 == 0.) {
i__3 = i__ - l + 1;
tst1 = dlanhs_("1", &i__3, &h___ref(l, l), ldh, work);
/* **
Increment op count */
latime_1.ops += (i__ - l + 1) * (i__ - l + 2) / 2;
/* ** */
}
/* Computing MAX */
d__2 = ulp * tst1;
if ((d__1 = h___ref(k, k - 1), abs(d__1)) <= max(d__2,smlnum)) {
goto L30;
}
/* L20: */
}
L30:
l = k;
/* **
Increment op count */
opst += (i__ - l + 1) * 3;
/* ** */
if (l > *ilo) {
/* H(L,L-1) is negligible */
h___ref(l, l - 1) = 0.;
}
/* Exit from loop if a submatrix of order 1 or 2 has split off. */
if (l >= i__ - 1) {
goto L140;
}
/* Now the active submatrix is in rows and columns L to I. If
eigenvalues only are being computed, only the active submatrix
need be transformed. */
if (! (*wantt)) {
i1 = l;
i2 = i__;
}
if (its == 10 || its == 20) {
/* Exceptional shift. */
s = (d__1 = h___ref(i__, i__ - 1), abs(d__1)) + (d__2 = h___ref(
i__ - 1, i__ - 2), abs(d__2));
h44 = s * .75 + h___ref(i__, i__);
h33 = h44;
h43h34 = s * -.4375 * s;
/* **
Increment op count */
opst += 5;
/* ** */
} else {
/* Prepare to use Francis' double shift
(i.e. 2nd degree generalized Rayleigh quotient) */
h44 = h___ref(i__, i__);
h33 = h___ref(i__ - 1, i__ - 1);
h43h34 = h___ref(i__, i__ - 1) * h___ref(i__ - 1, i__);
s = h___ref(i__ - 1, i__ - 2) * h___ref(i__ - 1, i__ - 2);
disc = (h33 - h44) * .5;
disc = disc * disc + h43h34;
/* **
Increment op count */
opst += 6;
/* ** */
if (disc > 0.) {
/* Real roots: use Wilkinson's shift twice */
disc = sqrt(disc);
ave = (h33 + h44) * .5;
/* **
Increment op count */
opst += 2;
/* ** */
if (abs(h33) - abs(h44) > 0.) {
h33 = h33 * h44 - h43h34;
h44 = h33 / (d_sign(&disc, &ave) + ave);
/* **
Increment op count */
opst += 4;
/* ** */
} else {
h44 = d_sign(&disc, &ave) + ave;
/* **
Increment op count */
opst += 1;
/* ** */
}
h33 = h44;
h43h34 = 0.;
}
}
/* Look for two consecutive small subdiagonal elements. */
i__2 = l;
for (m = i__ - 2; m >= i__2; --m) {
/* Determine the effect of starting the double-shift QR
iteration at row M, and see if this would make H(M,M-1)
negligible. */
h11 = h___ref(m, m);
h22 = h___ref(m + 1, m + 1);
h21 = h___ref(m + 1, m);
h12 = h___ref(m, m + 1);
h44s = h44 - h11;
h33s = h33 - h11;
v1 = (h33s * h44s - h43h34) / h21 + h12;
v2 = h22 - h11 - h33s - h44s;
v3 = h___ref(m + 2, m + 1);
s = abs(v1) + abs(v2) + abs(v3);
v1 /= s;
v2 /= s;
v3 /= s;
v[0] = v1;
v[1] = v2;
v[2] = v3;
if (m == l) {
goto L50;
}
h00 = h___ref(m - 1, m - 1);
h10 = h___ref(m, m - 1);
tst1 = abs(v1) * (abs(h00) + abs(h11) + abs(h22));
if (abs(h10) * (abs(v2) + abs(v3)) <= ulp * tst1) {
goto L50;
}
/* L40: */
}
L50:
/* **
Increment op count */
opst += (i__ - m - 1) * 20;
/* **
Double-shift QR step */
i__2 = i__ - 1;
for (k = m; k <= i__2; ++k) {
/* The first iteration of this loop determines a reflection G
from the vector V and applies it from left and right to H,
thus creating a nonzero bulge below the subdiagonal.
Each subsequent iteration determines a reflection G to
restore the Hessenberg form in the (K-1)th column, and thus
chases the bulge one step toward the bottom of the active
submatrix. NR is the order of G.
Computing MIN */
i__3 = 3, i__4 = i__ - k + 1;
nr = min(i__3,i__4);
if (k > m) {
dcopy_(&nr, &h___ref(k, k - 1), &c__1, v, &c__1);
}
dlarfg_(&nr, v, &v[1], &c__1, &t1);
/* **
Increment op count */
opst = opst + nr * 3 + 9;
/* ** */
if (k > m) {
h___ref(k, k - 1) = v[0];
h___ref(k + 1, k - 1) = 0.;
if (k < i__ - 1) {
h___ref(k + 2, k - 1) = 0.;
}
} else if (m > l) {
h___ref(k, k - 1) = -h___ref(k, k - 1);
}
v2 = v[1];
t2 = t1 * v2;
if (nr == 3) {
v3 = v[2];
t3 = t1 * v3;
/* Apply G from the left to transform the rows of the matrix
in columns K to I2. */
i__3 = i2;
for (j = k; j <= i__3; ++j) {
sum = h___ref(k, j) + v2 * h___ref(k + 1, j) + v3 *
h___ref(k + 2, j);
h___ref(k, j) = h___ref(k, j) - sum * t1;
h___ref(k + 1, j) = h___ref(k + 1, j) - sum * t2;
h___ref(k + 2, j) = h___ref(k + 2, j) - sum * t3;
/* L60: */
}
/* Apply G from the right to transform the columns of the
matrix in rows I1 to min(K+3,I).
Computing MIN */
i__4 = k + 3;
i__3 = min(i__4,i__);
for (j = i1; j <= i__3; ++j) {
sum = h___ref(j, k) + v2 * h___ref(j, k + 1) + v3 *
h___ref(j, k + 2);
h___ref(j, k) = h___ref(j, k) - sum * t1;
h___ref(j, k + 1) = h___ref(j, k + 1) - sum * t2;
h___ref(j, k + 2) = h___ref(j, k + 2) - sum * t3;
/* L70: */
}
/* **
Increment op count
Computing MIN */
i__3 = 3, i__4 = i__ - k;
latime_1.ops += (i2 - i1 + 2 + min(i__3,i__4)) * 10;
/* ** */
if (*wantz) {
/* Accumulate transformations in the matrix Z */
i__3 = *ihiz;
for (j = *iloz; j <= i__3; ++j) {
sum = z___ref(j, k) + v2 * z___ref(j, k + 1) + v3 *
z___ref(j, k + 2);
z___ref(j, k) = z___ref(j, k) - sum * t1;
z___ref(j, k + 1) = z___ref(j, k + 1) - sum * t2;
z___ref(j, k + 2) = z___ref(j, k + 2) - sum * t3;
/* L80: */
}
/* **
Increment op count */
latime_1.ops += nz * 10;
/* ** */
}
} else if (nr == 2) {
/* Apply G from the left to transform the rows of the matrix
in columns K to I2. */
i__3 = i2;
for (j = k; j <= i__3; ++j) {
sum = h___ref(k, j) + v2 * h___ref(k + 1, j);
h___ref(k, j) = h___ref(k, j) - sum * t1;
h___ref(k + 1, j) = h___ref(k + 1, j) - sum * t2;
/* L90: */
}
/* Apply G from the right to transform the columns of the
matrix in rows I1 to min(K+3,I). */
i__3 = i__;
for (j = i1; j <= i__3; ++j) {
sum = h___ref(j, k) + v2 * h___ref(j, k + 1);
h___ref(j, k) = h___ref(j, k) - sum * t1;
h___ref(j, k + 1) = h___ref(j, k + 1) - sum * t2;
/* L100: */
}
/* **
Increment op count */
latime_1.ops += (i2 - i1 + 3) * 6;
/* ** */
if (*wantz) {
/* Accumulate transformations in the matrix Z */
i__3 = *ihiz;
for (j = *iloz; j <= i__3; ++j) {
sum = z___ref(j, k) + v2 * z___ref(j, k + 1);
z___ref(j, k) = z___ref(j, k) - sum * t1;
z___ref(j, k + 1) = z___ref(j, k + 1) - sum * t2;
/* L110: */
}
/* **
Increment op count */
latime_1.ops += nz * 6;
/* ** */
}
}
/* L120: */
}
/* L130: */
}
/* Failure to converge in remaining number of iterations */
*info = i__;
return 0;
L140:
if (l == i__) {
/* H(I,I-1) is negligible: one eigenvalue has converged. */
wr[i__] = h___ref(i__, i__);
wi[i__] = 0.;
} else if (l == i__ - 1) {
/* H(I-1,I-2) is negligible: a pair of eigenvalues have converged.
Transform the 2-by-2 submatrix to standard Schur form,
and compute and store the eigenvalues. */
dlanv2_(&h___ref(i__ - 1, i__ - 1), &h___ref(i__ - 1, i__), &h___ref(
i__, i__ - 1), &h___ref(i__, i__), &wr[i__ - 1], &wi[i__ - 1],
&wr[i__], &wi[i__], &cs, &sn);
if (*wantt) {
/* Apply the transformation to the rest of H. */
if (i2 > i__) {
i__1 = i2 - i__;
drot_(&i__1, &h___ref(i__ - 1, i__ + 1), ldh, &h___ref(i__,
i__ + 1), ldh, &cs, &sn);
}
i__1 = i__ - i1 - 1;
drot_(&i__1, &h___ref(i1, i__ - 1), &c__1, &h___ref(i1, i__), &
c__1, &cs, &sn);
/* **
Increment op count */
latime_1.ops += (i2 - i1 - 1) * 6;
/* ** */
}
if (*wantz) {
/* Apply the transformation to Z. */
drot_(&nz, &z___ref(*iloz, i__ - 1), &c__1, &z___ref(*iloz, i__),
&c__1, &cs, &sn);
/* **
Increment op count */
latime_1.ops += nz * 6;
/* ** */
}
}
/* Decrement number of remaining iterations, and return to start of
the main loop with new value of I. */
itn -= its;
i__ = l - 1;
goto L10;
L150:
/* **
Compute final op count */
latime_1.ops += opst;
/* ** */
return 0;
/* End of DLAHQR */
} /* dlahqr_ */
/* Subroutine */ int dhseqr_(char *job, char *compz, integer *n, integer *ilo,
integer *ihi, doublereal *h__, integer *ldh, doublereal *wr,
doublereal *wi, doublereal *z__, integer *ldz, doublereal *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
=======
DHSEQR computes the eigenvalues of a real upper Hessenberg matrix H
and, optionally, the matrices T and Z from the Schur decomposition
H = Z T Z**T, where T is an upper quasi-triangular matrix (the Schur
form), and Z is the orthogonal matrix of Schur vectors.
Optionally Z may be postmultiplied into an input orthogonal matrix Q,
so that this routine can give the Schur factorization of a matrix A
which has been reduced to the Hessenberg form H by the orthogonal
matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.
Arguments
=========
JOB (input) CHARACTER*1
= 'E': compute eigenvalues only;
= 'S': compute eigenvalues and the Schur form T.
COMPZ (input) CHARACTER*1
= 'N': no Schur vectors are computed;
= 'I': Z is initialized to the unit matrix and the matrix Z
of Schur vectors of H is returned;
= 'V': Z must contain an orthogonal matrix Q on entry, and
the product Q*Z is returned.
N (input) INTEGER
The order of the matrix H. N >= 0.
ILO (input) INTEGER
IHI (input) INTEGER
It is assumed that H is already upper triangular in rows
and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
set by a previous call to DGEBAL, and then passed to SGEHRD
when the matrix output by DGEBAL 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) DOUBLE PRECISION array, dimension (LDH,N)
On entry, the upper Hessenberg matrix H.
On exit, if JOB = 'S', H contains the upper quasi-triangular
matrix T from the Schur decomposition (the Schur form);
2-by-2 diagonal blocks (corresponding to complex conjugate
pairs of eigenvalues) are returned in standard form, with
H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0. If JOB = 'E',
the contents of H are unspecified on exit.
LDH (input) INTEGER
The leading dimension of the array H. LDH >= max(1,N).
WR (output) DOUBLE PRECISION array, dimension (N)
WI (output) DOUBLE PRECISION array, dimension (N)
The real and imaginary parts, respectively, of the computed
eigenvalues. If two eigenvalues are computed as a complex
conjugate pair, they are stored in consecutive elements of
WR and WI, say the i-th and (i+1)th, with WI(i) > 0 and
WI(i+1) < 0. If JOB = 'S', the eigenvalues are stored in the
same order as on the diagonal of the Schur form returned in
H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2
diagonal block, WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and
WI(i+1) = -WI(i).
Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
If COMPZ = 'N': Z is not referenced.
If COMPZ = 'I': on entry, Z need not be set, and on exit, Z
contains the orthogonal matrix Z of the Schur vectors of H.
If COMPZ = 'V': on entry Z must contain an N-by-N matrix Q,
which is assumed to be equal to the unit matrix except for
the submatrix Z(ILO:IHI,ILO:IHI); on exit Z contains Q*Z.
Normally Q is the orthogonal matrix generated by DORGHR after
the call to DGEHRD 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) DOUBLE PRECISION 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, DHSEQR failed to compute all of the
eigenvalues in a total of 30*(IHI-ILO+1) iterations;
elements 1:ilo-1 and i+1:n of WR and WI contain those
eigenvalues which have been successfully computed.
=====================================================================
Decode and test the input parameters
Parameter adjustments */
/* Table of constant values */
static doublereal c_b9 = 0.;
static doublereal c_b10 = 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_;
static integer c__1 = 1;
/* System generated locals */
address a__1[2];
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3[2], i__4,
i__5;
doublereal d__1, d__2;
char ch__1[2];
/* Builtin functions
Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static integer maxb;
static doublereal absw;
static integer ierr;
static doublereal unfl, temp, ovfl;
static integer i__, j, k, l;
static doublereal s[225] /* was [15][15] */, v[16];
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
static integer itemp;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
static integer i1, i2;
static logical initz, wantt, wantz;
extern doublereal dlapy2_(doublereal *, doublereal *);
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
static integer ii, nh;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
integer *, doublereal *);
static integer nr, ns;
extern integer idamax_(integer *, doublereal *, integer *);
static integer nv;
extern doublereal dlanhs_(char *, integer *, doublereal *, integer *,
doublereal *);
extern /* Subroutine */ int dlahqr_(logical *, logical *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *);
static doublereal vv[16];
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
dlarfx_(char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *), xerbla_(char *,
integer *);
static doublereal smlnum;
static logical lquery;
static integer itn;
static doublereal tau;
static integer its;
static doublereal ulp, tst1;
#define h___ref(a_1,a_2) h__[(a_2)*h_dim1 + a_1]
#define s_ref(a_1,a_2) s[(a_2)*15 + a_1 - 16]
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
h_dim1 = *ldh;
h_offset = 1 + h_dim1 * 1;
h__ -= h_offset;
--wr;
--wi;
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;
work[1] = (doublereal) max(1,*n);
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 = -11;
} else if (*lwork < max(1,*n) && ! lquery) {
*info = -13;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DHSEQR", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Initialize Z, if necessary */
if (initz) {
dlaset_("Full", n, n, &c_b9, &c_b10, &z__[z_offset], ldz);
}
/* Store the eigenvalues isolated by DGEBAL. */
i__1 = *ilo - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
wr[i__] = h___ref(i__, i__);
wi[i__] = 0.;
/* L10: */
}
i__1 = *n;
for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
wr[i__] = h___ref(i__, i__);
wi[i__] = 0.;
/* L20: */
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
if (*ilo == *ihi) {
wr[*ilo] = h___ref(*ilo, *ilo);
wi[*ilo] = 0.;
return 0;
}
/* Set rows and columns ILO to IHI to zero below the first
subdiagonal. */
i__1 = *ihi - 2;
for (j = *ilo; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 2; i__ <= i__2; ++i__) {
h___ref(i__, j) = 0.;
/* L30: */
}
/* L40: */
}
nh = *ihi - *ilo + 1;
/* Determine the order of the multi-shift QR algorithm to be used.
Writing concatenation */
i__3[0] = 1, a__1[0] = job;
i__3[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
ns = ilaenv_(&c__4, "DHSEQR", ch__1, n, ilo, ihi, &c_n1, (ftnlen)6, (
ftnlen)2);
/* Writing concatenation */
i__3[0] = 1, a__1[0] = job;
i__3[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
maxb = ilaenv_(&c__8, "DHSEQR", ch__1, n, ilo, ihi, &c_n1, (ftnlen)6, (
ftnlen)2);
if (ns <= 2 || ns > nh || maxb >= nh) {
/* Use the standard double-shift algorithm */
dlahqr_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &wi[
1], ilo, ihi, &z__[z_offset], ldz, info);
return 0;
}
maxb = max(3,maxb);
/* Computing MIN */
i__1 = min(ns,maxb);
ns = min(i__1,15);
/* Now 2 < NS <= MAXB < NH.
Set machine-dependent constants for the stopping criterion.
If norm(H) <= sqrt(OVFL), overflow should not occur. */
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
dlabad_(&unfl, &ovfl);
ulp = dlamch_("Precision");
smlnum = unfl * (nh / ulp);
/* I1 and I2 are the indices of the first row and last column of H
to which transformations must be applied. If eigenvalues only are
being computed, I1 and I2 are set inside the main loop. */
if (wantt) {
i1 = 1;
i2 = *n;
}
/* ITN is the total number of multiple-shift QR iterations allowed. */
itn = nh * 30;
/* The main loop begins here. I is the loop index and decreases from
IHI to ILO in steps of at most MAXB. Each iteration of the loop
works with the active submatrix in rows and columns L to I.
Eigenvalues I+1 to IHI have already converged. Either L = ILO or
H(L,L-1) is negligible so that the matrix splits. */
i__ = *ihi;
L50:
l = *ilo;
if (i__ < *ilo) {
goto L170;
}
/* Perform multiple-shift QR iterations on rows and columns ILO to I
until a submatrix of order at most MAXB splits off at the bottom
because a subdiagonal element has become negligible. */
i__1 = itn;
for (its = 0; its <= i__1; ++its) {
/* Look for a single small subdiagonal element. */
i__2 = l + 1;
for (k = i__; k >= i__2; --k) {
tst1 = (d__1 = h___ref(k - 1, k - 1), abs(d__1)) + (d__2 =
h___ref(k, k), abs(d__2));
if (tst1 == 0.) {
i__4 = i__ - l + 1;
tst1 = dlanhs_("1", &i__4, &h___ref(l, l), ldh, &work[1]);
}
/* Computing MAX */
d__2 = ulp * tst1;
if ((d__1 = h___ref(k, k - 1), abs(d__1)) <= max(d__2,smlnum)) {
goto L70;
}
/* L60: */
}
L70:
l = k;
if (l > *ilo) {
/* H(L,L-1) is negligible. */
h___ref(l, l - 1) = 0.;
}
/* Exit from loop if a submatrix of order <= MAXB has split off. */
if (l >= i__ - maxb + 1) {
goto L160;
}
/* Now the active submatrix is in rows and columns L to I. If
eigenvalues only are being computed, only the active submatrix
need be transformed. */
if (! wantt) {
i1 = l;
i2 = i__;
}
if (its == 20 || its == 30) {
/* Exceptional shifts. */
i__2 = i__;
for (ii = i__ - ns + 1; ii <= i__2; ++ii) {
wr[ii] = ((d__1 = h___ref(ii, ii - 1), abs(d__1)) + (d__2 =
h___ref(ii, ii), abs(d__2))) * 1.5;
wi[ii] = 0.;
/* L80: */
}
} else {
/* Use eigenvalues of trailing submatrix of order NS as shifts. */
dlacpy_("Full", &ns, &ns, &h___ref(i__ - ns + 1, i__ - ns + 1),
ldh, s, &c__15);
dlahqr_(&c_false, &c_false, &ns, &c__1, &ns, s, &c__15, &wr[i__ -
ns + 1], &wi[i__ - ns + 1], &c__1, &ns, &z__[z_offset],
ldz, &ierr);
if (ierr > 0) {
/* If DLAHQR failed to compute all NS eigenvalues, use the
unconverged diagonal elements as the remaining shifts. */
i__2 = ierr;
for (ii = 1; ii <= i__2; ++ii) {
wr[i__ - ns + ii] = s_ref(ii, ii);
wi[i__ - ns + ii] = 0.;
/* L90: */
}
}
}
/* Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns))
where G is the Hessenberg submatrix H(L:I,L:I) and w is
the vector of shifts (stored in WR and WI). The result is
stored in the local array V. */
v[0] = 1.;
i__2 = ns + 1;
for (ii = 2; ii <= i__2; ++ii) {
v[ii - 1] = 0.;
/* L100: */
}
nv = 1;
i__2 = i__;
for (j = i__ - ns + 1; j <= i__2; ++j) {
if (wi[j] >= 0.) {
if (wi[j] == 0.) {
/* real shift */
i__4 = nv + 1;
dcopy_(&i__4, v, &c__1, vv, &c__1);
i__4 = nv + 1;
d__1 = -wr[j];
dgemv_("No transpose", &i__4, &nv, &c_b10, &h___ref(l, l),
ldh, vv, &c__1, &d__1, v, &c__1);
++nv;
} else if (wi[j] > 0.) {
/* complex conjugate pair of shifts */
i__4 = nv + 1;
dcopy_(&i__4, v, &c__1, vv, &c__1);
i__4 = nv + 1;
d__1 = wr[j] * -2.;
dgemv_("No transpose", &i__4, &nv, &c_b10, &h___ref(l, l),
ldh, v, &c__1, &d__1, vv, &c__1);
i__4 = nv + 1;
itemp = idamax_(&i__4, vv, &c__1);
/* Computing MAX */
d__2 = (d__1 = vv[itemp - 1], abs(d__1));
temp = 1. / max(d__2,smlnum);
i__4 = nv + 1;
dscal_(&i__4, &temp, vv, &c__1);
absw = dlapy2_(&wr[j], &wi[j]);
temp = temp * absw * absw;
i__4 = nv + 2;
i__5 = nv + 1;
dgemv_("No transpose", &i__4, &i__5, &c_b10, &h___ref(l,
l), ldh, vv, &c__1, &temp, v, &c__1);
nv += 2;
}
/* Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero,
reset it to the unit vector. */
itemp = idamax_(&nv, v, &c__1);
temp = (d__1 = v[itemp - 1], abs(d__1));
if (temp == 0.) {
v[0] = 1.;
i__4 = nv;
for (ii = 2; ii <= i__4; ++ii) {
v[ii - 1] = 0.;
/* L110: */
}
} else {
temp = max(temp,smlnum);
d__1 = 1. / temp;
dscal_(&nv, &d__1, v, &c__1);
}
}
/* L120: */
}
/* Multiple-shift QR step */
i__2 = i__ - 1;
for (k = l; k <= i__2; ++k) {
/* The first iteration of this loop determines a reflection G
from the vector V and applies it from left and right to H,
thus creating a nonzero bulge below the subdiagonal.
Each subsequent iteration determines a reflection G to
restore the Hessenberg form in the (K-1)th column, and thus
chases the bulge one step toward the bottom of the active
submatrix. NR is the order of G.
Computing MIN */
i__4 = ns + 1, i__5 = i__ - k + 1;
nr = min(i__4,i__5);
if (k > l) {
dcopy_(&nr, &h___ref(k, k - 1), &c__1, v, &c__1);
}
dlarfg_(&nr, v, &v[1], &c__1, &tau);
if (k > l) {
h___ref(k, k - 1) = v[0];
i__4 = i__;
for (ii = k + 1; ii <= i__4; ++ii) {
h___ref(ii, k - 1) = 0.;
/* L130: */
}
}
v[0] = 1.;
/* Apply G from the left to transform the rows of the matrix in
columns K to I2. */
i__4 = i2 - k + 1;
dlarfx_("Left", &nr, &i__4, v, &tau, &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__4 = min(i__5,i__) - i1 + 1;
dlarfx_("Right", &i__4, &nr, v, &tau, &h___ref(i1, k), ldh, &work[
1]);
if (wantz) {
/* Accumulate transformations in the matrix Z */
dlarfx_("Right", &nh, &nr, v, &tau, &z___ref(*ilo, k), ldz, &
work[1]);
}
/* L140: */
}
/* L150: */
}
/* Failure to converge in remaining number of iterations */
*info = i__;
return 0;
L160:
/* A submatrix of order <= MAXB in rows and columns L to I has split
off. Use the double-shift QR algorithm to handle it. */
dlahqr_(&wantt, &wantz, n, &l, &i__, &h__[h_offset], ldh, &wr[1], &wi[1],
ilo, ihi, &z__[z_offset], ldz, info);
if (*info > 0) {
return 0;
}
/* Decrement number of remaining iterations, and return to start of
the main loop with a new value of I. */
itn -= its;
i__ = l - 1;
goto L50;
L170:
work[1] = (doublereal) max(1,*n);
return 0;
/* End of DHSEQR */
} /* dhseqr_ */
/* Subroutine */ int zlahqr_(logical *wantt, logical *wantz, integer *n,
integer *ilo, integer *ihi, doublecomplex *h__, integer *ldh,
doublecomplex *w, integer *iloz, integer *ihiz, doublecomplex *z__,
integer *ldz, integer *info)
{
/* System generated locals */
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double d_imag(doublecomplex *);
void z_sqrt(doublecomplex *, doublecomplex *), d_cnjg(doublecomplex *,
doublecomplex *);
double z_abs(doublecomplex *);
/* Local variables */
static doublecomplex temp;
static doublereal opst;
static integer i__, j, k, l, m;
static doublereal s;
static doublecomplex t, u, v[2], x, y;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
static doublereal rtemp;
static integer i1, i2;
static doublereal rwork[1];
static doublecomplex t1;
static doublereal t2;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
static doublecomplex v2;
static doublereal h10;
static doublecomplex h11;
static doublereal h21;
static doublecomplex h22;
static integer nh;
extern doublereal dlamch_(char *);
static integer nz;
extern /* Subroutine */ int zlarfg_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *);
extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *,
doublecomplex *);
extern doublereal zlanhs_(char *, integer *, doublecomplex *, integer *,
doublereal *);
static doublereal smlnum;
static doublecomplex h11s;
static integer itn, its;
static doublereal ulp;
static doublecomplex sum;
static doublereal 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 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)]
/* -- LAPACK auxiliary routine (instrumented to count operations) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Common block to return operation count.
Purpose
=======
ZLAHQR is an auxiliary routine called by ZHSEQR to update the
eigenvalues and Schur decomposition already computed by ZHSEQR, by
dealing with the Hessenberg submatrix in rows and columns ILO to IHI.
Arguments
=========
WANTT (input) LOGICAL
= .TRUE. : the full Schur form T is required;
= .FALSE.: only eigenvalues are required.
WANTZ (input) LOGICAL
= .TRUE. : the matrix of Schur vectors Z is required;
= .FALSE.: Schur vectors are not required.
N (input) INTEGER
The order of the matrix H. N >= 0.
ILO (input) INTEGER
IHI (input) INTEGER
It is assumed that H is already upper triangular in rows and
columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1).
ZLAHQR works primarily with the Hessenberg submatrix in rows
and columns ILO to IHI, but applies transformations to all of
H if WANTT is .TRUE..
1 <= ILO <= max(1,IHI); IHI <= N.
H (input/output) COMPLEX*16 array, dimension (LDH,N)
On entry, the upper Hessenberg matrix H.
On exit, if WANTT is .TRUE., H is upper triangular in rows
and columns ILO:IHI, with any 2-by-2 diagonal blocks in
standard form. If WANTT is .FALSE., the contents of H are
unspecified on exit.
LDH (input) INTEGER
The leading dimension of the array H. LDH >= max(1,N).
W (output) COMPLEX*16 array, dimension (N)
The computed eigenvalues ILO to IHI are stored in the
corresponding elements of W. If WANTT is .TRUE., 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).
ILOZ (input) INTEGER
IHIZ (input) INTEGER
Specify the rows of Z to which transformations must be
applied if WANTZ is .TRUE..
1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
Z (input/output) COMPLEX*16 array, dimension (LDZ,N)
If WANTZ is .TRUE., on entry Z must contain the current
matrix Z of transformations accumulated by ZHSEQR, and on
exit Z has been updated; transformations are applied only to
the submatrix Z(ILOZ:IHIZ,ILO:IHI).
If WANTZ is .FALSE., Z is not referenced.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
> 0: if INFO = i, ZLAHQR failed to compute all the
eigenvalues ILO to IHI in a total of 30*(IHI-ILO+1)
iterations; elements i+1:ihi of W contain those
eigenvalues which have been successfully computed.
=====================================================================
Parameter adjustments */
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;
/* Function Body */
*info = 0;
/* **
Initialize */
opst = 0.;
/* **
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;
}
nh = *ihi - *ilo + 1;
nz = *ihiz - *iloz + 1;
/* Set machine-dependent constants for the stopping criterion.
If norm(H) <= sqrt(OVFL), overflow should not occur. */
ulp = dlamch_("Precision");
smlnum = dlamch_("Safe minimum") / ulp;
/* I1 and I2 are the indices of the first row and last column of H
to which transformations must be applied. If eigenvalues only are
being computed, I1 and I2 are set inside the main loop. */
if (*wantt) {
i1 = 1;
i2 = *n;
}
/* ITN is the total number of QR iterations allowed. */
itn = nh * 30;
/* The main loop begins here. I is the loop index and decreases from
IHI to ILO in steps of 1. Each iteration of the loop works
with the active submatrix in rows and columns L to I.
Eigenvalues I+1 to IHI have already converged. Either L = ILO, or
H(L,L-1) is negligible so that the matrix splits. */
i__ = *ihi;
L10:
if (i__ < *ilo) {
goto L130;
}
/* Perform QR iterations on rows and columns ILO to I until a
submatrix of order 1 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__4 = 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__4].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);
/* **
Increment op count */
latime_1.ops += (i__ - l + 1) * 5 * (i__ - l) / 2;
/* ** */
}
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 L30;
}
/* L20: */
}
L30:
l = k;
/* **
Increment op count */
opst += (i__ - l + 1) * 5;
/* ** */
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 1 has split off. */
if (l >= i__) {
goto L120;
}
/* Now the active submatrix is in rows and columns L to I. If
eigenvalues only are being computed, only the active submatrix
need be transformed. */
if (! (*wantt)) {
i1 = l;
i2 = i__;
}
if (its == 10 || its == 20) {
/* Exceptional shift. */
i__2 = h___subscr(i__, i__ - 1);
s = (d__1 = h__[i__2].r, abs(d__1)) * .75;
i__2 = h___subscr(i__, i__);
z__1.r = s + h__[i__2].r, z__1.i = h__[i__2].i;
t.r = z__1.r, t.i = z__1.i;
/* **
Increment op count */
opst += 1;
/* ** */
} else {
/* Wilkinson's shift. */
i__2 = h___subscr(i__, i__);
t.r = h__[i__2].r, t.i = h__[i__2].i;
i__2 = h___subscr(i__ - 1, i__);
i__3 = h___subscr(i__, i__ - 1);
d__1 = h__[i__3].r;
z__1.r = d__1 * h__[i__2].r, z__1.i = d__1 * h__[i__2].i;
u.r = z__1.r, u.i = z__1.i;
/* **
Increment op count */
opst += 2;
/* ** */
if (u.r != 0. || u.i != 0.) {
i__2 = h___subscr(i__ - 1, i__ - 1);
z__2.r = h__[i__2].r - t.r, z__2.i = h__[i__2].i - t.i;
z__1.r = z__2.r * .5, z__1.i = z__2.i * .5;
x.r = z__1.r, x.i = z__1.i;
z__3.r = x.r * x.r - x.i * x.i, z__3.i = x.r * x.i + x.i *
x.r;
z__2.r = z__3.r + u.r, z__2.i = z__3.i + u.i;
z_sqrt(&z__1, &z__2);
y.r = z__1.r, y.i = z__1.i;
if (x.r * y.r + d_imag(&x) * d_imag(&y) < 0.) {
z__1.r = -y.r, z__1.i = -y.i;
y.r = z__1.r, y.i = z__1.i;
}
z__3.r = x.r + y.r, z__3.i = x.i + y.i;
zladiv_(&z__2, &u, &z__3);
z__1.r = t.r - z__2.r, z__1.i = t.i - z__2.i;
t.r = z__1.r, t.i = z__1.i;
/* **
Increment op count */
opst += 20;
/* ** */
}
}
/* Look for two consecutive small subdiagonal elements. */
i__2 = l + 1;
for (m = i__ - 1; m >= i__2; --m) {
/* Determine the effect of starting the single-shift QR
iteration at row M, and see if this would make H(M,M-1)
negligible. */
i__3 = h___subscr(m, m);
h11.r = h__[i__3].r, h11.i = h__[i__3].i;
i__3 = h___subscr(m + 1, m + 1);
h22.r = h__[i__3].r, h22.i = h__[i__3].i;
z__1.r = h11.r - t.r, z__1.i = h11.i - t.i;
h11s.r = z__1.r, h11s.i = z__1.i;
i__3 = h___subscr(m + 1, m);
h21 = h__[i__3].r;
s = (d__1 = h11s.r, abs(d__1)) + (d__2 = d_imag(&h11s), abs(d__2))
+ abs(h21);
z__1.r = h11s.r / s, z__1.i = h11s.i / s;
h11s.r = z__1.r, h11s.i = z__1.i;
h21 /= s;
v[0].r = h11s.r, v[0].i = h11s.i;
v[1].r = h21, v[1].i = 0.;
i__3 = h___subscr(m, m - 1);
h10 = h__[i__3].r;
tst1 = ((d__1 = h11s.r, abs(d__1)) + (d__2 = d_imag(&h11s), abs(
d__2))) * ((d__3 = h11.r, abs(d__3)) + (d__4 = d_imag(&
h11), abs(d__4)) + ((d__5 = h22.r, abs(d__5)) + (d__6 =
d_imag(&h22), abs(d__6))));
if ((d__1 = h10 * h21, abs(d__1)) <= ulp * tst1) {
goto L50;
}
/* L40: */
}
i__2 = h___subscr(l, l);
h11.r = h__[i__2].r, h11.i = h__[i__2].i;
i__2 = h___subscr(l + 1, l + 1);
h22.r = h__[i__2].r, h22.i = h__[i__2].i;
z__1.r = h11.r - t.r, z__1.i = h11.i - t.i;
h11s.r = z__1.r, h11s.i = z__1.i;
i__2 = h___subscr(l + 1, l);
h21 = h__[i__2].r;
s = (d__1 = h11s.r, abs(d__1)) + (d__2 = d_imag(&h11s), abs(d__2)) +
abs(h21);
z__1.r = h11s.r / s, z__1.i = h11s.i / s;
h11s.r = z__1.r, h11s.i = z__1.i;
h21 /= s;
v[0].r = h11s.r, v[0].i = h11s.i;
v[1].r = h21, v[1].i = 0.;
L50:
/* **
Increment op count */
opst += (i__ - m) * 14;
/* **
Single-shift QR step */
i__2 = i__ - 1;
for (k = m; k <= i__2; ++k) {
/* The first iteration of this loop determines a reflection G
from the vector V and applies it from left and right to H,
thus creating a nonzero bulge below the subdiagonal.
Each subsequent iteration determines a reflection G to
restore the Hessenberg form in the (K-1)th column, and thus
chases the bulge one step toward the bottom of the active
submatrix.
V(2) is always real before the call to ZLARFG, and hence
after the call T2 ( = T1*V(2) ) is also real. */
if (k > m) {
zcopy_(&c__2, &h___ref(k, k - 1), &c__1, v, &c__1);
}
zlarfg_(&c__2, v, &v[1], &c__1, &t1);
/* **
Increment op count */
opst += 38;
/* ** */
if (k > m) {
i__3 = h___subscr(k, k - 1);
h__[i__3].r = v[0].r, h__[i__3].i = v[0].i;
i__3 = h___subscr(k + 1, k - 1);
h__[i__3].r = 0., h__[i__3].i = 0.;
}
v2.r = v[1].r, v2.i = v[1].i;
z__1.r = t1.r * v2.r - t1.i * v2.i, z__1.i = t1.r * v2.i + t1.i *
v2.r;
t2 = z__1.r;
/* Apply G from the left to transform the rows of the matrix
in columns K to I2. */
i__3 = i2;
for (j = k; j <= i__3; ++j) {
d_cnjg(&z__3, &t1);
i__4 = h___subscr(k, j);
z__2.r = z__3.r * h__[i__4].r - z__3.i * h__[i__4].i, z__2.i =
z__3.r * h__[i__4].i + z__3.i * h__[i__4].r;
i__5 = h___subscr(k + 1, j);
z__4.r = t2 * h__[i__5].r, z__4.i = t2 * h__[i__5].i;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
sum.r = z__1.r, sum.i = z__1.i;
i__4 = h___subscr(k, j);
i__5 = h___subscr(k, j);
z__1.r = h__[i__5].r - sum.r, z__1.i = h__[i__5].i - sum.i;
h__[i__4].r = z__1.r, h__[i__4].i = z__1.i;
i__4 = h___subscr(k + 1, j);
i__5 = h___subscr(k + 1, j);
z__2.r = sum.r * v2.r - sum.i * v2.i, z__2.i = sum.r * v2.i +
sum.i * v2.r;
z__1.r = h__[i__5].r - z__2.r, z__1.i = h__[i__5].i - z__2.i;
h__[i__4].r = z__1.r, h__[i__4].i = z__1.i;
/* L60: */
}
/* Apply G from the right to transform the columns of the
matrix in rows I1 to min(K+2,I).
Computing MIN */
i__4 = k + 2;
i__3 = min(i__4,i__);
for (j = i1; j <= i__3; ++j) {
i__4 = h___subscr(j, k);
z__2.r = t1.r * h__[i__4].r - t1.i * h__[i__4].i, z__2.i =
t1.r * h__[i__4].i + t1.i * h__[i__4].r;
i__5 = h___subscr(j, k + 1);
z__3.r = t2 * h__[i__5].r, z__3.i = t2 * h__[i__5].i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
sum.r = z__1.r, sum.i = z__1.i;
i__4 = h___subscr(j, k);
i__5 = h___subscr(j, k);
z__1.r = h__[i__5].r - sum.r, z__1.i = h__[i__5].i - sum.i;
h__[i__4].r = z__1.r, h__[i__4].i = z__1.i;
i__4 = h___subscr(j, k + 1);
i__5 = h___subscr(j, k + 1);
d_cnjg(&z__3, &v2);
z__2.r = sum.r * z__3.r - sum.i * z__3.i, z__2.i = sum.r *
z__3.i + sum.i * z__3.r;
z__1.r = h__[i__5].r - z__2.r, z__1.i = h__[i__5].i - z__2.i;
h__[i__4].r = z__1.r, h__[i__4].i = z__1.i;
/* L70: */
}
/* **
Increment op count
Computing MIN */
i__3 = 2, i__4 = i__ - k;
latime_1.ops += (i2 - i1 + 2 + min(i__3,i__4)) * 20;
/* ** */
if (*wantz) {
/* Accumulate transformations in the matrix Z */
i__3 = *ihiz;
for (j = *iloz; j <= i__3; ++j) {
i__4 = z___subscr(j, k);
z__2.r = t1.r * z__[i__4].r - t1.i * z__[i__4].i, z__2.i =
t1.r * z__[i__4].i + t1.i * z__[i__4].r;
i__5 = z___subscr(j, k + 1);
z__3.r = t2 * z__[i__5].r, z__3.i = t2 * z__[i__5].i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
sum.r = z__1.r, sum.i = z__1.i;
i__4 = z___subscr(j, k);
i__5 = z___subscr(j, k);
z__1.r = z__[i__5].r - sum.r, z__1.i = z__[i__5].i -
sum.i;
z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
i__4 = z___subscr(j, k + 1);
i__5 = z___subscr(j, k + 1);
d_cnjg(&z__3, &v2);
z__2.r = sum.r * z__3.r - sum.i * z__3.i, z__2.i = sum.r *
z__3.i + sum.i * z__3.r;
z__1.r = z__[i__5].r - z__2.r, z__1.i = z__[i__5].i -
z__2.i;
z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
/* L80: */
}
/* **
Increment op count */
latime_1.ops += nz * 20;
/* ** */
}
if (k == m && m > l) {
/* If the QR step was started at row M > L because two
consecutive small subdiagonals were found, then extra
scaling must be performed to ensure that H(M,M-1) remains
real. */
z__1.r = 1. - t1.r, z__1.i = 0. - t1.i;
temp.r = z__1.r, temp.i = z__1.i;
d__1 = z_abs(&temp);
z__1.r = temp.r / d__1, z__1.i = temp.i / d__1;
temp.r = z__1.r, temp.i = z__1.i;
i__3 = h___subscr(m + 1, m);
i__4 = h___subscr(m + 1, m);
d_cnjg(&z__2, &temp);
z__1.r = h__[i__4].r * z__2.r - h__[i__4].i * z__2.i, z__1.i =
h__[i__4].r * z__2.i + h__[i__4].i * z__2.r;
h__[i__3].r = z__1.r, h__[i__3].i = z__1.i;
if (m + 2 <= i__) {
i__3 = h___subscr(m + 2, m + 1);
i__4 = h___subscr(m + 2, m + 1);
z__1.r = h__[i__4].r * temp.r - h__[i__4].i * temp.i,
z__1.i = h__[i__4].r * temp.i + h__[i__4].i *
temp.r;
h__[i__3].r = z__1.r, h__[i__3].i = z__1.i;
}
i__3 = i__;
for (j = m; j <= i__3; ++j) {
if (j != m + 1) {
if (i2 > j) {
i__4 = i2 - j;
zscal_(&i__4, &temp, &h___ref(j, j + 1), ldh);
}
i__4 = j - i1;
d_cnjg(&z__1, &temp);
zscal_(&i__4, &z__1, &h___ref(i1, j), &c__1);
/* **
Increment op count */
opst += (i2 - i1 + 3) * 6;
/* ** */
if (*wantz) {
d_cnjg(&z__1, &temp);
zscal_(&nz, &z__1, &z___ref(*iloz, j), &c__1);
/* **
Increment op count */
opst += nz * 6;
/* ** */
}
}
/* L90: */
}
}
/* L100: */
}
/* 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.) {
rtemp = z_abs(&temp);
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);
/* **
Increment op count */
opst += (i2 - i1 + 1) * 6;
/* ** */
if (*wantz) {
zscal_(&nz, &temp, &z___ref(*iloz, i__), &c__1);
/* **
Increment op count */
opst += nz * 6;
/* ** */
}
}
/* L110: */
}
/* Failure to converge in remaining number of iterations */
*info = i__;
return 0;
L120:
/* H(I,I-1) is negligible: one eigenvalue has converged. */
i__1 = i__;
i__2 = h___subscr(i__, i__);
w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i;
/* Decrement number of remaining iterations, and return to start of
the main loop with new value of I. */
itn -= its;
i__ = l - 1;
goto L10;
L130:
/* **
Compute final op count */
latime_1.ops += opst;
/* ** */
return 0;
/* End of ZLAHQR */
} /* zlahqr_ */
