/* 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 claein_(logical *rightv, logical *noinit, integer *n,
complex *h__, integer *ldh, complex *w, complex *v, complex *b,
integer *ldb, real *rwork, real *eps3, real *smlnum, integer *info)
{
/* -- LAPACK auxiliary 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
=======
CLAEIN uses inverse iteration to find a right or left eigenvector
corresponding to the eigenvalue W of a complex upper Hessenberg
matrix H.
Arguments
=========
RIGHTV (input) LOGICAL
= .TRUE. : compute right eigenvector;
= .FALSE.: compute left eigenvector.
NOINIT (input) LOGICAL
= .TRUE. : no initial vector supplied in V
= .FALSE.: initial vector supplied in V.
N (input) INTEGER
The order of the matrix H. N >= 0.
H (input) COMPLEX 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) COMPLEX
The eigenvalue of H whose corresponding right or left
eigenvector is to be computed.
V (input/output) COMPLEX array, dimension (N)
On entry, if NOINIT = .FALSE., V must contain a starting
vector for inverse iteration; otherwise V need not be set.
On exit, V contains the computed eigenvector, normalized so
that the component of largest magnitude has magnitude 1; here
the magnitude of a complex number (x,y) is taken to be
|x| + |y|.
B (workspace) COMPLEX array, dimension (LDB,N)
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
RWORK (workspace) REAL array, dimension (N)
EPS3 (input) REAL
A small machine-dependent value which is used to perturb
close eigenvalues, and to replace zero pivots.
SMLNUM (input) REAL
A machine-dependent value close to the underflow threshold.
INFO (output) INTEGER
= 0: successful exit
= 1: inverse iteration did not converge; V is set to the
last iterate.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer b_dim1, b_offset, h_dim1, h_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
complex q__1, q__2;
/* Builtin functions */
double sqrt(doublereal), r_imag(complex *);
/* Local variables */
static integer ierr;
static complex temp;
static integer i__, j;
static real scale;
static complex x;
static char trans[1];
static real rtemp, rootn, vnorm;
extern doublereal scnrm2_(integer *, complex *, integer *);
static complex ei, ej;
extern integer icamax_(integer *, complex *, integer *);
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), clatrs_(char *, char *, char *, char *, integer *, complex *,
integer *, complex *, real *, real *, integer *);
extern doublereal scasum_(integer *, complex *, integer *);
static char normin[1];
static real nrmsml, growto;
static integer its;
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#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)]
h_dim1 = *ldh;
h_offset = 1 + h_dim1 * 1;
h__ -= h_offset;
--v;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--rwork;
/* Function Body */
*info = 0;
/* GROWTO is the threshold used in the acceptance test for an
eigenvector. */
rootn = sqrt((real) (*n));
growto = .1f / rootn;
/* Computing MAX */
r__1 = 1.f, r__2 = *eps3 * rootn;
nrmsml = dmax(r__1,r__2) * *smlnum;
/* Form B = H - W*I (except that the subdiagonal elements are not
stored). */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = h___subscr(i__, j);
b[i__3].r = h__[i__4].r, b[i__3].i = h__[i__4].i;
/* L10: */
}
i__2 = b_subscr(j, j);
i__3 = h___subscr(j, j);
q__1.r = h__[i__3].r - w->r, q__1.i = h__[i__3].i - w->i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L20: */
}
if (*noinit) {
/* Initialize V. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
v[i__2].r = *eps3, v[i__2].i = 0.f;
/* L30: */
}
} else {
/* Scale supplied initial vector. */
vnorm = scnrm2_(n, &v[1], &c__1);
r__1 = *eps3 * rootn / dmax(vnorm,nrmsml);
csscal_(n, &r__1, &v[1], &c__1);
}
if (*rightv) {
/* LU decomposition with partial pivoting of B, replacing zero
pivots by EPS3. */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = h___subscr(i__ + 1, i__);
ei.r = h__[i__2].r, ei.i = h__[i__2].i;
i__2 = b_subscr(i__, i__);
if ((r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(i__,
i__)), dabs(r__2)) < (r__3 = ei.r, dabs(r__3)) + (r__4 =
r_imag(&ei), dabs(r__4))) {
/* Interchange rows and eliminate. */
cladiv_(&q__1, &b_ref(i__, i__), &ei);
x.r = q__1.r, x.i = q__1.i;
i__2 = b_subscr(i__, i__);
b[i__2].r = ei.r, b[i__2].i = ei.i;
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = b_subscr(i__ + 1, j);
temp.r = b[i__3].r, temp.i = b[i__3].i;
i__3 = b_subscr(i__ + 1, j);
i__4 = b_subscr(i__, j);
q__2.r = x.r * temp.r - x.i * temp.i, q__2.i = x.r *
temp.i + x.i * temp.r;
q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i - q__2.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
i__3 = b_subscr(i__, j);
b[i__3].r = temp.r, b[i__3].i = temp.i;
/* L40: */
}
} else {
/* Eliminate without interchange. */
i__2 = b_subscr(i__, i__);
if (b[i__2].r == 0.f && b[i__2].i == 0.f) {
i__3 = b_subscr(i__, i__);
b[i__3].r = *eps3, b[i__3].i = 0.f;
}
cladiv_(&q__1, &ei, &b_ref(i__, i__));
x.r = q__1.r, x.i = q__1.i;
if (x.r != 0.f || x.i != 0.f) {
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = b_subscr(i__ + 1, j);
i__4 = b_subscr(i__ + 1, j);
i__5 = b_subscr(i__, j);
q__2.r = x.r * b[i__5].r - x.i * b[i__5].i, q__2.i =
x.r * b[i__5].i + x.i * b[i__5].r;
q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i -
q__2.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L50: */
}
}
}
/* L60: */
}
i__1 = b_subscr(*n, *n);
if (b[i__1].r == 0.f && b[i__1].i == 0.f) {
i__2 = b_subscr(*n, *n);
b[i__2].r = *eps3, b[i__2].i = 0.f;
}
*(unsigned char *)trans = 'N';
} else {
/* UL decomposition with partial pivoting of B, replacing zero
pivots by EPS3. */
for (j = *n; j >= 2; --j) {
i__1 = h___subscr(j, j - 1);
ej.r = h__[i__1].r, ej.i = h__[i__1].i;
i__1 = b_subscr(j, j);
if ((r__1 = b[i__1].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(j, j)),
dabs(r__2)) < (r__3 = ej.r, dabs(r__3)) + (r__4 = r_imag(
&ej), dabs(r__4))) {
/* Interchange columns and eliminate. */
cladiv_(&q__1, &b_ref(j, j), &ej);
x.r = q__1.r, x.i = q__1.i;
i__1 = b_subscr(j, j);
b[i__1].r = ej.r, b[i__1].i = ej.i;
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = b_subscr(i__, j - 1);
temp.r = b[i__2].r, temp.i = b[i__2].i;
i__2 = b_subscr(i__, j - 1);
i__3 = b_subscr(i__, j);
q__2.r = x.r * temp.r - x.i * temp.i, q__2.i = x.r *
temp.i + x.i * temp.r;
q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = b_subscr(i__, j);
b[i__2].r = temp.r, b[i__2].i = temp.i;
/* L70: */
}
} else {
/* Eliminate without interchange. */
i__1 = b_subscr(j, j);
if (b[i__1].r == 0.f && b[i__1].i == 0.f) {
i__2 = b_subscr(j, j);
b[i__2].r = *eps3, b[i__2].i = 0.f;
}
cladiv_(&q__1, &ej, &b_ref(j, j));
x.r = q__1.r, x.i = q__1.i;
if (x.r != 0.f || x.i != 0.f) {
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = b_subscr(i__, j - 1);
i__3 = b_subscr(i__, j - 1);
i__4 = b_subscr(i__, j);
q__2.r = x.r * b[i__4].r - x.i * b[i__4].i, q__2.i =
x.r * b[i__4].i + x.i * b[i__4].r;
q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i -
q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L80: */
}
}
}
/* L90: */
}
i__1 = b_subscr(1, 1);
if (b[i__1].r == 0.f && b[i__1].i == 0.f) {
i__2 = b_subscr(1, 1);
b[i__2].r = *eps3, b[i__2].i = 0.f;
}
*(unsigned char *)trans = 'C';
}
*(unsigned char *)normin = 'N';
i__1 = *n;
for (its = 1; its <= i__1; ++its) {
/* Solve U*x = scale*v for a right eigenvector
or U'*x = scale*v for a left eigenvector,
overwriting x on v. */
clatrs_("Upper", trans, "Nonunit", normin, n, &b[b_offset], ldb, &v[1]
, &scale, &rwork[1], &ierr);
*(unsigned char *)normin = 'Y';
/* Test for sufficient growth in the norm of v. */
vnorm = scasum_(n, &v[1], &c__1);
if (vnorm >= growto * scale) {
goto L120;
}
/* Choose new orthogonal starting vector and try again. */
rtemp = *eps3 / (rootn + 1.f);
v[1].r = *eps3, v[1].i = 0.f;
i__2 = *n;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = i__;
v[i__3].r = rtemp, v[i__3].i = 0.f;
/* L100: */
}
i__2 = *n - its + 1;
i__3 = *n - its + 1;
r__1 = *eps3 * rootn;
q__1.r = v[i__3].r - r__1, q__1.i = v[i__3].i;
v[i__2].r = q__1.r, v[i__2].i = q__1.i;
/* L110: */
}
/* Failure to find eigenvector in N iterations. */
*info = 1;
L120:
/* Normalize eigenvector. */
i__ = icamax_(n, &v[1], &c__1);
i__1 = i__;
r__3 = 1.f / ((r__1 = v[i__1].r, dabs(r__1)) + (r__2 = r_imag(&v[i__]),
dabs(r__2)));
csscal_(n, &r__3, &v[1], &c__1);
return 0;
/* End of CLAEIN */
} /* claein_ */
/* Subroutine */ int zchkhs_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
doublecomplex *a, integer *lda, doublecomplex *h__, doublecomplex *t1,
doublecomplex *t2, doublecomplex *u, integer *ldu, doublecomplex *
z__, doublecomplex *uz, doublecomplex *w1, doublecomplex *w3,
doublecomplex *evectl, doublecomplex *evectr, doublecomplex *evecty,
doublecomplex *evectx, doublecomplex *uu, doublecomplex *tau,
doublecomplex *work, integer *nwork, doublereal *rwork, 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 ZCHKHS: \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 ZCHKHS: \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 ZCHKHS: 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, i__5, i__6;
doublereal d__1, d__2;
doublecomplex z__1;
/* Builtin functions */
double sqrt(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
double z_abs(doublecomplex *);
/* Local variables */
static doublereal cond;
static integer jcol, nmax;
static doublereal unfl, ovfl, temp1, temp2;
static integer i__, j, k, n;
static logical badnn, match;
static integer imode;
static doublereal dumma[4];
static integer iinfo;
static doublereal conds;
extern /* Subroutine */ int zget10_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublereal *, doublereal *);
static doublereal aninv, anorm;
extern /* Subroutine */ int zget22_(char *, char *, char *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, doublereal *, doublereal *), zgemm_(char *, char *, integer *,
integer *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
static integer nmats, jsize, nerrs, itype, jtype, ntest, n1;
extern /* Subroutine */ int zhst01_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *);
static doublereal rtulp;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
static integer jj, in;
extern doublereal dlamch_(char *);
static doublecomplex cdumma[4];
static integer idumma[1];
extern /* Subroutine */ int dlafts_(char *, integer *, integer *, integer
*, integer *, doublereal *, integer *, doublereal *, integer *,
integer *);
static integer ioldsd[4];
extern /* Subroutine */ int xerbla_(char *, integer *), zgehrd_(
integer *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *, integer *), dlasum_(
char *, integer *, integer *, integer *), zlatme_(integer
*, char *, integer *, doublecomplex *, integer *, doublereal *,
doublecomplex *, char *, char *, char *, char *, doublereal *,
integer *, doublereal *, integer *, integer *, doublereal *,
doublecomplex *, integer *, doublecomplex *, integer *), zhsein_(char *, char *, char *,
logical *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *
, integer *, doublecomplex *, doublereal *, integer *, integer *,
integer *), zlacpy_(char *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *), zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *), zlatmr_(
integer *, integer *, char *, integer *, char *, doublecomplex *,
integer *, doublereal *, doublecomplex *, char *, char *,
doublecomplex *, integer *, doublereal *, doublecomplex *,
integer *, doublereal *, char *, integer *, integer *, integer *,
doublereal *, doublereal *, char *, doublecomplex *, integer *,
integer *, integer *);
static doublereal rtunfl, rtovfl, rtulpi, ulpinv;
static integer mtypes, ntestt;
extern /* Subroutine */ int zhseqr_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *), zlatms_(integer *, integer *, char *, integer *,
char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublecomplex *, integer *,
doublecomplex *, integer *), ztrevc_(char
*, char *, logical *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *,
integer *, doublecomplex *, doublereal *, integer *), zunghr_(integer *, integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, integer *
), zunmhr_(char *, char *, integer *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *);
static integer ihi, ilo;
static doublereal ulp;
/* Fortran I/O blocks */
static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___40 = { 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___47 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___58 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___59 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___60 = { 0, 0, 0, fmt_9998, 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_9999, 0 };
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#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 u_subscr(a_1,a_2) (a_2)*u_dim1 + a_1
#define u_ref(a_1,a_2) u[u_subscr(a_1,a_2)]
#define uu_subscr(a_1,a_2) (a_2)*uu_dim1 + a_1
#define uu_ref(a_1,a_2) uu[uu_subscr(a_1,a_2)]
#define evectl_subscr(a_1,a_2) (a_2)*evectl_dim1 + a_1
#define evectl_ref(a_1,a_2) evectl[evectl_subscr(a_1,a_2)]
#define evectr_subscr(a_1,a_2) (a_2)*evectr_dim1 + a_1
#define evectr_ref(a_1,a_2) evectr[evectr_subscr(a_1,a_2)]
/* -- LAPACK test 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
=======
ZCHKHS checks the nonsymmetric eigenvalue problem routines.
ZGEHRD factors A as U H U' , where ' means conjugate
transpose, H is hessenberg, and U is unitary.
ZUNGHR generates the unitary matrix U.
ZUNMHR multiplies a matrix by the unitary matrix U.
ZHSEQR factors H as Z T Z' , where Z is unitary and T
is upper triangular. It also computes the eigenvalues,
w(1), ..., w(n); we define a diagonal matrix W whose
(diagonal) entries are the eigenvalues.
ZTREVC computes the left eigenvector matrix L and the
right eigenvector matrix R for the matrix T. The
columns of L are the complex conjugates of the left
eigenvectors of T. The columns of R are the right
eigenvectors of T. L is lower triangular, and R is
upper triangular.
ZHSEIN computes the left eigenvector matrix Y and the
right eigenvector matrix X for the matrix H. The
columns of Y are the complex conjugates of the left
eigenvectors of H. The columns of X are the right
eigenvectors of H. Y is lower triangular, and X is
upper triangular.
When ZCHKHS 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**H | / ( |A| n ulp )
(2) | I - UU**H | / ( n ulp )
(3) | H - Z T Z**H | / ( |H| n ulp )
(4) | I - ZZ**H | / ( n ulp )
(5) | A - UZ H (UZ)**H | / ( |A| n ulp )
(6) | I - UZ (UZ)**H | / ( 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 complex angles.
(ULP = (first number larger than 1) - 1 )
(5) A diagonal matrix with geometrically spaced entries
1, ..., ULP and random complex angles.
(6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
and random complex angles.
(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 unitary and
T has evenly spaced entries 1, ..., ULP with random complex
angles on the diagonal and random O(1) entries in the upper
triangle.
(10) A matrix of the form U' T U, where U is unitary and
T has geometrically spaced entries 1, ..., ULP with random
complex angles on the diagonal and random O(1) entries in
the upper triangle.
(11) A matrix of the form U' T U, where U is unitary and
T has "clustered" entries 1, ULP,..., ULP with random
complex angles on the diagonal and random O(1) entries in
the upper triangle.
(12) A matrix of the form U' T U, where U is unitary and
T has complex eigenvalues randomly chosen from
ULP < |z| < 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 complex angles 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 complex angles 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 complex angles 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 complex eigenvalues randomly chosen
from ULP < |z| < 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 |z| < 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,
ZCHKHS 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, ZCHKHS
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 ZCHKHS 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 - COMPLEX*16 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 - COMPLEX*16 array, dimension (LDA,max(NN))
The upper hessenberg matrix computed by ZGEHRD. On exit,
H contains the Hessenberg form of the matrix in A.
Modified.
T1 - COMPLEX*16 array, dimension (LDA,max(NN))
The Schur (="quasi-triangular") matrix computed by ZHSEQR
if Z is computed. On exit, T1 contains the Schur form of
the matrix in A.
Modified.
T2 - COMPLEX*16 array, dimension (LDA,max(NN))
The Schur matrix computed by ZHSEQR 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 - COMPLEX*16 array, dimension (LDU,max(NN))
The unitary matrix computed by ZGEHRD.
Modified.
Z - COMPLEX*16 array, dimension (LDU,max(NN))
The unitary matrix computed by ZHSEQR.
Modified.
UZ - COMPLEX*16 array, dimension (LDU,max(NN))
The product of U times Z.
Modified.
W1 - COMPLEX*16 array, dimension (max(NN))
The eigenvalues of A, as computed by a full Schur
decomposition H = Z T Z'. On exit, W1 contains the
eigenvalues of the matrix in A.
Modified.
W3 - COMPLEX*16 array, dimension (max(NN))
The eigenvalues of A, as computed by a partial Schur
decomposition (Z not computed, T only computed as much
as is necessary for determining eigenvalues). On exit,
W3 contains the eigenvalues of the matrix in A, possibly
perturbed by ZHSEIN.
Modified.
EVECTL - COMPLEX*16 array, dimension (LDU,max(NN))
The conjugate transpose of the (upper triangular) left
eigenvector matrix for the matrix in T1.
Modified.
EVEZTR - COMPLEX*16 array, dimension (LDU,max(NN))
The (upper triangular) right eigenvector matrix for the
matrix in T1.
Modified.
EVECTY - COMPLEX*16 array, dimension (LDU,max(NN))
The conjugate transpose of the left eigenvector matrix
for the matrix in H.
Modified.
EVECTX - COMPLEX*16 array, dimension (LDU,max(NN))
The right eigenvector matrix for the matrix in H.
Modified.
UU - COMPLEX*16 array, dimension (LDU,max(NN))
Details of the unitary matrix computed by ZGEHRD.
Modified.
TAU - COMPLEX*16 array, dimension (max(NN))
Further details of the unitary matrix computed by ZGEHRD.
Modified.
WORK - COMPLEX*16 array, dimension (NWORK)
Workspace.
Modified.
NWORK - INTEGER
The number of entries in WORK. NWORK >= 4*NN(j)*NN(j) + 2.
RWORK - DOUBLE PRECISION array, dimension (max(NN))
Workspace. Could be equivalenced to IWORK, but not SELECT.
Modified.
IWORK - INTEGER array, dimension (max(NN))
Workspace.
Modified.
SELECT - LOGICAL array, dimension (max(NN))
Workspace. Could be equivalenced to IWORK, but not RWORK.
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.
-26: NWORK too small.
If ZLATMR, CLATMS, or CLATME returns an error code, the
absolute value of it is returned.
If 1, then ZHSEQR 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;
--w1;
--w3;
--tau;
--work;
--rwork;
--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 = -26;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZCHKHS", &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];
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 L250;
}
++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 hermitian, w/ eigenvalues
=6 random general, w/ eigenvalues
=7 random diagonal
=8 random hermitian
=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:
zlaset_("Full", lda, &n, &c_b1, &c_b1, &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) {
i__4 = a_subscr(jcol, jcol);
a[i__4].r = anorm, a[i__4].i = 0.;
/* L80: */
}
} else if (itype == 3) {
/* Jordan Block */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
i__4 = a_subscr(jcol, jcol);
a[i__4].r = anorm, a[i__4].i = 0.;
if (jcol > 1) {
i__4 = a_subscr(jcol, jcol - 1);
a[i__4].r = 1., a[i__4].i = 0.;
}
/* L90: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &imode, &cond,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
n << 1) + 1], &c__1, &c_b27, "N", idumma, &c__0, &
c__0, &c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[
1], &iinfo);
} else if (itype == 5) {
/* Hermitian, eigenvalues specified */
zlatms_(&n, &n, "D", &iseed[1], "H", &rwork[1], &imode, &cond,
&anorm, &n, &n, "N", &a[a_offset], lda, &work[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.;
}
zlatme_(&n, "D", &iseed[1], &work[1], &imode, &cond, &c_b2,
" ", "T", "T", "T", &rwork[1], &c__4, &conds, &n, &n,
&anorm, &a[a_offset], lda, &work[n + 1], &iinfo);
} else if (itype == 7) {
/* Diagonal, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b27,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
n << 1) + 1], &c__1, &c_b27, "N", idumma, &c__0, &
c__0, &c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[
1], &iinfo);
} else if (itype == 8) {
/* Hermitian, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "H", &work[1], &c__6, &c_b27,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
n << 1) + 1], &c__1, &c_b27, "N", idumma, &n, &n, &
c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else if (itype == 9) {
/* General, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b27,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
n << 1) + 1], &c__1, &c_b27, "N", idumma, &n, &n, &
c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else if (itype == 10) {
/* Triangular, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b27,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
n << 1) + 1], &c__1, &c_b27, "N", idumma, &n, &c__0, &
c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else {
iinfo = 1;
}
if (iinfo != 0) {
io___35.ciunit = *nounit;
s_wsfe(&io___35);
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 ZGEHRD to compute H and U, do tests. */
zlacpy_(" ", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
ntest = 1;
ilo = 1;
ihi = n;
i__3 = *nwork - n;
zgehrd_(&n, &ilo, &ihi, &h__[h_offset], lda, &work[1], &work[n +
1], &i__3, &iinfo);
if (iinfo != 0) {
result[1] = ulpinv;
io___38.ciunit = *nounit;
s_wsfe(&io___38);
do_fio(&c__1, "ZGEHRD", (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 L240;
}
i__3 = n - 1;
for (j = 1; j <= i__3; ++j) {
i__4 = uu_subscr(j + 1, j);
uu[i__4].r = 0., uu[i__4].i = 0.;
i__4 = n;
for (i__ = j + 2; i__ <= i__4; ++i__) {
i__5 = u_subscr(i__, j);
i__6 = h___subscr(i__, j);
u[i__5].r = h__[i__6].r, u[i__5].i = h__[i__6].i;
i__5 = uu_subscr(i__, j);
i__6 = h___subscr(i__, j);
uu[i__5].r = h__[i__6].r, uu[i__5].i = h__[i__6].i;
i__5 = h___subscr(i__, j);
h__[i__5].r = 0., h__[i__5].i = 0.;
/* L110: */
}
/* L120: */
}
zcopy_(&n, &work[1], &c__1, &tau[1], &c__1);
i__3 = *nwork - n;
zunghr_(&n, &ilo, &ihi, &u[u_offset], ldu, &work[1], &work[n + 1],
&i__3, &iinfo);
ntest = 2;
zhst01_(&n, &ilo, &ihi, &a[a_offset], lda, &h__[h_offset], lda, &
u[u_offset], ldu, &work[1], nwork, &rwork[1], &result[1]);
/* Call ZHSEQR to compute T1, T2 and Z, do tests.
Eigenvalues only (W3) */
zlacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda);
ntest = 3;
result[3] = ulpinv;
zhseqr_("E", "N", &n, &ilo, &ihi, &t2[t2_offset], lda, &w3[1], &
uz[uz_offset], ldu, &work[1], nwork, &iinfo);
if (iinfo != 0) {
io___40.ciunit = *nounit;
s_wsfe(&io___40);
do_fio(&c__1, "ZHSEQR(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 L240;
}
}
/* Eigenvalues (W1) and Full Schur Form (T2) */
zlacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda);
zhseqr_("S", "N", &n, &ilo, &ihi, &t2[t2_offset], lda, &w1[1], &
uz[uz_offset], ldu, &work[1], nwork, &iinfo);
if (iinfo != 0 && iinfo <= n + 2) {
io___41.ciunit = *nounit;
s_wsfe(&io___41);
do_fio(&c__1, "ZHSEQR(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 L240;
}
/* Eigenvalues (W1), Schur Form (T1), and Schur Vectors (UZ) */
zlacpy_(" ", &n, &n, &h__[h_offset], lda, &t1[t1_offset], lda);
zlacpy_(" ", &n, &n, &u[u_offset], ldu, &uz[uz_offset], ldu);
zhseqr_("S", "V", &n, &ilo, &ihi, &t1[t1_offset], lda, &w1[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, "ZHSEQR(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 L240;
}
/* Compute Z = U' UZ */
zgemm_("C", "N", &n, &n, &n, &c_b2, &u[u_offset], ldu, &uz[
uz_offset], ldu, &c_b1, &z__[z_offset], ldu);
ntest = 8;
/* Do Tests 3: | H - Z T Z' | / ( |H| n ulp )
and 4: | I - Z Z' | / ( n ulp ) */
zhst01_(&n, &ilo, &ihi, &h__[h_offset], lda, &t1[t1_offset], lda,
&z__[z_offset], ldu, &work[1], nwork, &rwork[1], &result[
3]);
/* Do Tests 5: | A - UZ T (UZ)' | / ( |A| n ulp )
and 6: | I - UZ (UZ)' | / ( n ulp ) */
zhst01_(&n, &ilo, &ihi, &a[a_offset], lda, &t1[t1_offset], lda, &
uz[uz_offset], ldu, &work[1], nwork, &rwork[1], &result[5]
);
/* Do Test 7: | T2 - T1 | / ( |T| n ulp ) */
zget10_(&n, &n, &t2[t2_offset], lda, &t1[t1_offset], lda, &work[1]
, &rwork[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__1 = temp1, d__2 = z_abs(&w1[j]), d__1 = max(d__1,d__2),
d__2 = z_abs(&w3[j]);
temp1 = max(d__1,d__2);
/* Computing MAX */
i__4 = j;
i__5 = j;
z__1.r = w1[i__4].r - w3[i__5].r, z__1.i = w1[i__4].i - w3[
i__5].i;
d__1 = temp2, d__2 = z_abs(&z__1);
temp2 = max(d__1,d__2);
/* 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 every other eigenvector */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
select[j] = FALSE_;
/* L140: */
}
i__3 = n;
for (j = 1; j <= i__3; j += 2) {
select[j] = TRUE_;
/* L150: */
}
ztrevc_("Right", "All", &select[1], &n, &t1[t1_offset], lda,
cdumma, ldu, &evectr[evectr_offset], ldu, &n, &in, &work[
1], &rwork[1], &iinfo);
if (iinfo != 0) {
io___47.ciunit = *nounit;
s_wsfe(&io___47);
do_fio(&c__1, "ZTREVC(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 L240;
}
/* Test 9: | TR - RW | / ( |T| |R| ulp ) */
zget22_("N", "N", "N", &n, &t1[t1_offset], lda, &evectr[
evectr_offset], ldu, &w1[1], &work[1], &rwork[1], dumma);
result[9] = dumma[0];
if (dumma[1] > *thresh) {
io___49.ciunit = *nounit;
s_wsfe(&io___49);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "ZTREVC", (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 */
ztrevc_("Right", "Some", &select[1], &n, &t1[t1_offset], lda,
cdumma, ldu, &evectl[evectl_offset], ldu, &n, &in, &work[
1], &rwork[1], &iinfo);
if (iinfo != 0) {
io___50.ciunit = *nounit;
s_wsfe(&io___50);
do_fio(&c__1, "ZTREVC(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 L240;
}
k = 1;
match = TRUE_;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
if (select[j]) {
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
i__5 = evectr_subscr(jj, j);
i__6 = evectl_subscr(jj, k);
if (evectr[i__5].r != evectl[i__6].r || evectr[i__5]
.i != evectl[i__6].i) {
match = FALSE_;
goto L180;
}
/* L160: */
}
++k;
}
/* L170: */
}
L180:
if (! match) {
io___54.ciunit = *nounit;
s_wsfe(&io___54);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "ZTREVC", (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;
ztrevc_("Left", "All", &select[1], &n, &t1[t1_offset], lda, &
evectl[evectl_offset], ldu, cdumma, ldu, &n, &in, &work[1]
, &rwork[1], &iinfo);
if (iinfo != 0) {
io___55.ciunit = *nounit;
s_wsfe(&io___55);
do_fio(&c__1, "ZTREVC(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 L240;
}
/* Test 10: | LT - WL | / ( |T| |L| ulp ) */
zget22_("C", "N", "C", &n, &t1[t1_offset], lda, &evectl[
evectl_offset], ldu, &w1[1], &work[1], &rwork[1], &dumma[
2]);
result[10] = dumma[2];
if (dumma[3] > *thresh) {
io___56.ciunit = *nounit;
s_wsfe(&io___56);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "ZTREVC", (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 */
ztrevc_("Left", "Some", &select[1], &n, &t1[t1_offset], lda, &
evectr[evectr_offset], ldu, cdumma, ldu, &n, &in, &work[1]
, &rwork[1], &iinfo);
if (iinfo != 0) {
io___57.ciunit = *nounit;
s_wsfe(&io___57);
do_fio(&c__1, "ZTREVC(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 L240;
}
k = 1;
match = TRUE_;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
if (select[j]) {
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
i__5 = evectl_subscr(jj, j);
i__6 = evectr_subscr(jj, k);
if (evectl[i__5].r != evectr[i__6].r || evectl[i__5]
.i != evectr[i__6].i) {
match = FALSE_;
goto L210;
}
/* L190: */
}
++k;
}
/* L200: */
}
L210:
if (! match) {
io___58.ciunit = *nounit;
s_wsfe(&io___58);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "ZTREVC", (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 ZHSEIN 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_;
/* L220: */
}
zhsein_("Right", "Qr", "Ninitv", &select[1], &n, &h__[h_offset],
lda, &w3[1], cdumma, ldu, &evectx[evectx_offset], ldu, &
n1, &in, &work[1], &rwork[1], &iwork[1], &iwork[1], &
iinfo);
if (iinfo != 0) {
io___59.ciunit = *nounit;
s_wsfe(&io___59);
do_fio(&c__1, "ZHSEIN(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 L240;
}
} else {
/* Test 11: | HX - XW | / ( |H| |X| ulp )
(from inverse iteration) */
zget22_("N", "N", "N", &n, &h__[h_offset], lda, &evectx[
evectx_offset], ldu, &w3[1], &work[1], &rwork[1],
dumma);
if (dumma[0] < ulpinv) {
result[11] = dumma[0] * aninv;
}
if (dumma[1] > *thresh) {
io___60.ciunit = *nounit;
s_wsfe(&io___60);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "ZHSEIN", (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 ZHSEIN 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_;
/* L230: */
}
zhsein_("Left", "Qr", "Ninitv", &select[1], &n, &h__[h_offset],
lda, &w3[1], &evecty[evecty_offset], ldu, cdumma, ldu, &
n1, &in, &work[1], &rwork[1], &iwork[1], &iwork[1], &
iinfo);
if (iinfo != 0) {
io___61.ciunit = *nounit;
s_wsfe(&io___61);
do_fio(&c__1, "ZHSEIN(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 L240;
}
} else {
/* Test 12: | YH - WY | / ( |H| |Y| ulp )
(from inverse iteration) */
zget22_("C", "N", "C", &n, &h__[h_offset], lda, &evecty[
evecty_offset], ldu, &w3[1], &work[1], &rwork[1], &
dumma[2]);
if (dumma[2] < ulpinv) {
result[12] = dumma[2] * aninv;
}
if (dumma[3] > *thresh) {
io___62.ciunit = *nounit;
s_wsfe(&io___62);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "ZHSEIN", (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 ZUNMHR for Right eigenvectors of A, do test 13 */
ntest = 13;
result[13] = ulpinv;
zunmhr_("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___63.ciunit = *nounit;
s_wsfe(&io___63);
do_fio(&c__1, "ZUNMHR(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 L240;
}
} else {
/* Test 13: | AX - XW | / ( |A| |X| ulp )
(from inverse iteration) */
zget22_("N", "N", "N", &n, &a[a_offset], lda, &evectx[
evectx_offset], ldu, &w3[1], &work[1], &rwork[1],
dumma);
if (dumma[0] < ulpinv) {
result[13] = dumma[0] * aninv;
}
}
/* Call ZUNMHR for Left eigenvectors of A, do test 14 */
ntest = 14;
result[14] = ulpinv;
zunmhr_("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___64.ciunit = *nounit;
s_wsfe(&io___64);
do_fio(&c__1, "ZUNMHR(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 L240;
}
} else {
/* Test 14: | YA - WY | / ( |A| |Y| ulp )
(from inverse iteration) */
zget22_("C", "N", "C", &n, &a[a_offset], lda, &evecty[
evecty_offset], ldu, &w3[1], &work[1], &rwork[1], &
dumma[2]);
if (dumma[2] < ulpinv) {
result[14] = dumma[2] * aninv;
}
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L240:
ntestt += ntest;
dlafts_("ZHS", &n, &n, &jtype, &ntest, &result[1], ioldsd, thresh,
nounit, &nerrs);
L250:
;
}
/* L260: */
}
/* Summary */
dlasum_("ZHS", nounit, &nerrs, &ntestt);
return 0;
/* End of ZCHKHS */
} /* zchkhs_ */
/* 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 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_ */
