/* Subroutine */ int ztrevc_(char *side, char *howmny, logical *select,
integer *n, doublecomplex *t, integer *ldt, doublecomplex *vl,
integer *ldvl, doublecomplex *vr, integer *ldvr, integer *mm, integer
*m, doublecomplex *work, doublereal *rwork, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
ZTREVC computes some or all of the right and/or left eigenvectors of
a complex upper triangular matrix T.
The right eigenvector x and the left eigenvector y of T corresponding
to an eigenvalue w are defined by:
T*x = w*x, y'*T = w*y'
where y' denotes the conjugate transpose of the vector y.
If all eigenvectors are requested, the routine may either return the
matrices X and/or Y of right or left eigenvectors of T, or the
products Q*X and/or Q*Y, where Q is an input unitary
matrix. If T was obtained from the Schur factorization of an
original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of
right or left eigenvectors of A.
Arguments
=========
SIDE (input) CHARACTER*1
= 'R': compute right eigenvectors only;
= 'L': compute left eigenvectors only;
= 'B': compute both right and left eigenvectors.
HOWMNY (input) CHARACTER*1
= 'A': compute all right and/or left eigenvectors;
= 'B': compute all right and/or left eigenvectors,
and backtransform them using the input matrices
supplied in VR and/or VL;
= 'S': compute selected right and/or left eigenvectors,
specified by the logical array SELECT.
SELECT (input) LOGICAL array, dimension (N)
If HOWMNY = 'S', SELECT specifies the eigenvectors to be
computed.
If HOWMNY = 'A' or 'B', SELECT is not referenced.
To select the eigenvector corresponding to the j-th
eigenvalue, SELECT(j) must be set to .TRUE..
N (input) INTEGER
The order of the matrix T. N >= 0.
T (input/output) COMPLEX*16 array, dimension (LDT,N)
The upper triangular matrix T. T is modified, but restored
on exit.
LDT (input) INTEGER
The leading dimension of the array T. LDT >= max(1,N).
VL (input/output) COMPLEX*16 array, dimension (LDVL,MM)
On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
contain an N-by-N matrix Q (usually the unitary matrix Q of
Schur vectors returned by ZHSEQR).
On exit, if SIDE = 'L' or 'B', VL contains:
if HOWMNY = 'A', the matrix Y of left eigenvectors of T;
VL is lower triangular. The i-th column
VL(i) of VL is the eigenvector corresponding
to T(i,i).
if HOWMNY = 'B', the matrix Q*Y;
if HOWMNY = 'S', the left eigenvectors of T specified by
SELECT, 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 SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
contain an N-by-N matrix Q (usually the unitary matrix Q of
Schur vectors returned by ZHSEQR).
On exit, if SIDE = 'R' or 'B', VR contains:
if HOWMNY = 'A', the matrix X of right eigenvectors of T;
VR is upper triangular. The i-th column
VR(i) of VR is the eigenvector corresponding
to T(i,i).
if HOWMNY = 'B', the matrix Q*X;
if HOWMNY = 'S', the right eigenvectors of T specified by
SELECT, 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 actually
used to store the eigenvectors. If HOWMNY = 'A' or 'B', M
is set to N. Each selected eigenvector occupies one
column.
WORK (workspace) COMPLEX*16 array, dimension (2*N)
RWORK (workspace) DOUBLE PRECISION array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Further Details
===============
The algorithm used in this program is basically backward (forward)
substitution, with scaling to make the the code robust against
possible overflow.
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 doublecomplex c_b2 = {1.,0.};
static integer c__1 = 1;
/* System generated locals */
integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static logical allv;
static doublereal unfl, ovfl, smin;
static logical over;
static integer i__, j, k;
static doublereal scale;
extern logical lsame_(char *, char *);
static doublereal remax;
static logical leftv, bothv;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static logical somev;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
static integer ii, ki;
extern doublereal dlamch_(char *);
static integer is;
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *);
extern integer izamax_(integer *, doublecomplex *, integer *);
static logical rightv;
extern doublereal dzasum_(integer *, doublecomplex *, integer *);
static doublereal smlnum;
extern /* Subroutine */ int zlatrs_(char *, char *, char *, char *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublereal *, doublereal *, integer *);
static doublereal ulp;
#define t_subscr(a_1,a_2) (a_2)*t_dim1 + a_1
#define t_ref(a_1,a_2) t[t_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;
t_dim1 = *ldt;
t_offset = 1 + t_dim1 * 1;
t -= t_offset;
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;
/* Function Body */
bothv = lsame_(side, "B");
rightv = lsame_(side, "R") || bothv;
leftv = lsame_(side, "L") || bothv;
allv = lsame_(howmny, "A");
over = lsame_(howmny, "B");
somev = lsame_(howmny, "S");
/* Set M to the number of columns required to store the selected
eigenvectors. */
if (somev) {
*m = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (select[j]) {
++(*m);
}
/* L10: */
}
} else {
*m = *n;
}
*info = 0;
if (! rightv && ! leftv) {
*info = -1;
} else if (! allv && ! over && ! somev) {
*info = -2;
} else if (*n < 0) {
*info = -4;
} else if (*ldt < max(1,*n)) {
*info = -6;
} else if (*ldvl < 1 || leftv && *ldvl < *n) {
*info = -8;
} else if (*ldvr < 1 || rightv && *ldvr < *n) {
*info = -10;
} else if (*mm < *m) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZTREVC", &i__1);
return 0;
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
/* Set the constants to control overflow. */
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
dlabad_(&unfl, &ovfl);
ulp = dlamch_("Precision");
smlnum = unfl * (*n / ulp);
/* Store the diagonal elements of T in working array WORK. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + *n;
i__3 = t_subscr(i__, i__);
work[i__2].r = t[i__3].r, work[i__2].i = t[i__3].i;
/* L20: */
}
/* Compute 1-norm of each column of strictly upper triangular
part of T to control overflow in triangular solver. */
rwork[1] = 0.;
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
i__2 = j - 1;
rwork[j] = dzasum_(&i__2, &t_ref(1, j), &c__1);
/* L30: */
}
if (rightv) {
/* Compute right eigenvectors. */
is = *m;
for (ki = *n; ki >= 1; --ki) {
if (somev) {
if (! select[ki]) {
goto L80;
}
}
/* Computing MAX */
i__1 = t_subscr(ki, ki);
d__3 = ulp * ((d__1 = t[i__1].r, abs(d__1)) + (d__2 = d_imag(&
t_ref(ki, ki)), abs(d__2)));
smin = max(d__3,smlnum);
work[1].r = 1., work[1].i = 0.;
/* Form right-hand side. */
i__1 = ki - 1;
for (k = 1; k <= i__1; ++k) {
i__2 = k;
i__3 = t_subscr(k, ki);
z__1.r = -t[i__3].r, z__1.i = -t[i__3].i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
/* L40: */
}
/* Solve the triangular system:
(T(1:KI-1,1:KI-1) - T(KI,KI))*X = SCALE*WORK. */
i__1 = ki - 1;
for (k = 1; k <= i__1; ++k) {
i__2 = t_subscr(k, k);
i__3 = t_subscr(k, k);
i__4 = t_subscr(ki, ki);
z__1.r = t[i__3].r - t[i__4].r, z__1.i = t[i__3].i - t[i__4]
.i;
t[i__2].r = z__1.r, t[i__2].i = z__1.i;
i__2 = t_subscr(k, k);
if ((d__1 = t[i__2].r, abs(d__1)) + (d__2 = d_imag(&t_ref(k,
k)), abs(d__2)) < smin) {
i__3 = t_subscr(k, k);
t[i__3].r = smin, t[i__3].i = 0.;
}
/* L50: */
}
if (ki > 1) {
i__1 = ki - 1;
zlatrs_("Upper", "No transpose", "Non-unit", "Y", &i__1, &t[
t_offset], ldt, &work[1], &scale, &rwork[1], info);
i__1 = ki;
work[i__1].r = scale, work[i__1].i = 0.;
}
/* Copy the vector x or Q*x to VR and normalize. */
if (! over) {
zcopy_(&ki, &work[1], &c__1, &vr_ref(1, is), &c__1);
ii = izamax_(&ki, &vr_ref(1, is), &c__1);
i__1 = vr_subscr(ii, is);
remax = 1. / ((d__1 = vr[i__1].r, abs(d__1)) + (d__2 = d_imag(
&vr_ref(ii, is)), abs(d__2)));
zdscal_(&ki, &remax, &vr_ref(1, is), &c__1);
i__1 = *n;
for (k = ki + 1; k <= i__1; ++k) {
i__2 = vr_subscr(k, is);
vr[i__2].r = 0., vr[i__2].i = 0.;
/* L60: */
}
} else {
if (ki > 1) {
i__1 = ki - 1;
z__1.r = scale, z__1.i = 0.;
zgemv_("N", n, &i__1, &c_b2, &vr[vr_offset], ldvr, &work[
1], &c__1, &z__1, &vr_ref(1, ki), &c__1);
}
ii = izamax_(n, &vr_ref(1, ki), &c__1);
i__1 = vr_subscr(ii, ki);
remax = 1. / ((d__1 = vr[i__1].r, abs(d__1)) + (d__2 = d_imag(
&vr_ref(ii, ki)), abs(d__2)));
zdscal_(n, &remax, &vr_ref(1, ki), &c__1);
}
/* Set back the original diagonal elements of T. */
i__1 = ki - 1;
for (k = 1; k <= i__1; ++k) {
i__2 = t_subscr(k, k);
i__3 = k + *n;
t[i__2].r = work[i__3].r, t[i__2].i = work[i__3].i;
/* L70: */
}
--is;
L80:
;
}
}
if (leftv) {
/* Compute left eigenvectors. */
is = 1;
i__1 = *n;
for (ki = 1; ki <= i__1; ++ki) {
if (somev) {
if (! select[ki]) {
goto L130;
}
}
/* Computing MAX */
i__2 = t_subscr(ki, ki);
d__3 = ulp * ((d__1 = t[i__2].r, abs(d__1)) + (d__2 = d_imag(&
t_ref(ki, ki)), abs(d__2)));
smin = max(d__3,smlnum);
i__2 = *n;
work[i__2].r = 1., work[i__2].i = 0.;
/* Form right-hand side. */
i__2 = *n;
for (k = ki + 1; k <= i__2; ++k) {
i__3 = k;
d_cnjg(&z__2, &t_ref(ki, k));
z__1.r = -z__2.r, z__1.i = -z__2.i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L90: */
}
/* Solve the triangular system:
(T(KI+1:N,KI+1:N) - T(KI,KI))'*X = SCALE*WORK. */
i__2 = *n;
for (k = ki + 1; k <= i__2; ++k) {
i__3 = t_subscr(k, k);
i__4 = t_subscr(k, k);
i__5 = t_subscr(ki, ki);
z__1.r = t[i__4].r - t[i__5].r, z__1.i = t[i__4].i - t[i__5]
.i;
t[i__3].r = z__1.r, t[i__3].i = z__1.i;
i__3 = t_subscr(k, k);
if ((d__1 = t[i__3].r, abs(d__1)) + (d__2 = d_imag(&t_ref(k,
k)), abs(d__2)) < smin) {
i__4 = t_subscr(k, k);
t[i__4].r = smin, t[i__4].i = 0.;
}
/* L100: */
}
if (ki < *n) {
i__2 = *n - ki;
zlatrs_("Upper", "Conjugate transpose", "Non-unit", "Y", &
i__2, &t_ref(ki + 1, ki + 1), ldt, &work[ki + 1], &
scale, &rwork[1], info);
i__2 = ki;
work[i__2].r = scale, work[i__2].i = 0.;
}
/* Copy the vector x or Q*x to VL and normalize. */
if (! over) {
i__2 = *n - ki + 1;
zcopy_(&i__2, &work[ki], &c__1, &vl_ref(ki, is), &c__1);
i__2 = *n - ki + 1;
ii = izamax_(&i__2, &vl_ref(ki, is), &c__1) + ki - 1;
i__2 = vl_subscr(ii, is);
remax = 1. / ((d__1 = vl[i__2].r, abs(d__1)) + (d__2 = d_imag(
&vl_ref(ii, is)), abs(d__2)));
i__2 = *n - ki + 1;
zdscal_(&i__2, &remax, &vl_ref(ki, is), &c__1);
i__2 = ki - 1;
for (k = 1; k <= i__2; ++k) {
i__3 = vl_subscr(k, is);
vl[i__3].r = 0., vl[i__3].i = 0.;
/* L110: */
}
} else {
if (ki < *n) {
i__2 = *n - ki;
z__1.r = scale, z__1.i = 0.;
zgemv_("N", n, &i__2, &c_b2, &vl_ref(1, ki + 1), ldvl, &
work[ki + 1], &c__1, &z__1, &vl_ref(1, ki), &c__1);
}
ii = izamax_(n, &vl_ref(1, ki), &c__1);
i__2 = vl_subscr(ii, ki);
remax = 1. / ((d__1 = vl[i__2].r, abs(d__1)) + (d__2 = d_imag(
&vl_ref(ii, ki)), abs(d__2)));
zdscal_(n, &remax, &vl_ref(1, ki), &c__1);
}
/* Set back the original diagonal elements of T. */
i__2 = *n;
for (k = ki + 1; k <= i__2; ++k) {
i__3 = t_subscr(k, k);
i__4 = k + *n;
t[i__3].r = work[i__4].r, t[i__3].i = work[i__4].i;
/* L120: */
}
++is;
L130:
;
}
}
return 0;
/* End of ZTREVC */
} /* ztrevc_ */
/* Subroutine */ int cgegv_(char *jobvl, char *jobvr, integer *n, complex *a,
integer *lda, complex *b, integer *ldb, complex *alpha, complex *beta,
complex *vl, integer *ldvl, complex *vr, integer *ldvr, complex *
work, integer *lwork, real *rwork, integer *info)
{
/* -- LAPACK driver 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
=======
This routine is deprecated and has been replaced by routine CGGEV.
CGEGV computes for a pair of N-by-N complex nonsymmetric matrices A
and B, the generalized eigenvalues (alpha, beta), and optionally,
the left and/or right generalized eigenvectors (VL and VR).
A generalized eigenvalue for a pair of matrices (A,B) is, roughly
speaking, a scalar w or a ratio alpha/beta = w, such that A - w*B
is singular. It is usually represented as the pair (alpha,beta),
as there is a reasonable interpretation for beta=0, and even for
both being zero. A good beginning reference is the book, "Matrix
Computations", by G. Golub & C. van Loan (Johns Hopkins U. Press)
A right generalized eigenvector corresponding to a generalized
eigenvalue w for a pair of matrices (A,B) is a vector r such
that (A - w B) r = 0 . A left generalized eigenvector is a vector
l such that l**H * (A - w B) = 0, where l**H is the
conjugate-transpose of l.
Note: this routine performs "full balancing" on A and B -- see
"Further Details", below.
Arguments
=========
JOBVL (input) CHARACTER*1
= 'N': do not compute the left generalized eigenvectors;
= 'V': compute the left generalized eigenvectors.
JOBVR (input) CHARACTER*1
= 'N': do not compute the right generalized eigenvectors;
= 'V': compute the right generalized eigenvectors.
N (input) INTEGER
The order of the matrices A, B, VL, and VR. N >= 0.
A (input/output) COMPLEX array, dimension (LDA, N)
On entry, the first of the pair of matrices whose
generalized eigenvalues and (optionally) generalized
eigenvectors are to be computed.
On exit, the contents will have been destroyed. (For a
description of the contents of A on exit, see "Further
Details", below.)
LDA (input) INTEGER
The leading dimension of A. LDA >= max(1,N).
B (input/output) COMPLEX array, dimension (LDB, N)
On entry, the second of the pair of matrices whose
generalized eigenvalues and (optionally) generalized
eigenvectors are to be computed.
On exit, the contents will have been destroyed. (For a
description of the contents of B on exit, see "Further
Details", below.)
LDB (input) INTEGER
The leading dimension of B. LDB >= max(1,N).
ALPHA (output) COMPLEX array, dimension (N)
BETA (output) COMPLEX array, dimension (N)
On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the
generalized eigenvalues.
Note: the quotients ALPHA(j)/BETA(j) may easily over- or
underflow, and BETA(j) may even be zero. Thus, the user
should avoid naively computing the ratio alpha/beta.
However, ALPHA will be always less than and usually
comparable with norm(A) in magnitude, and BETA always less
than and usually comparable with norm(B).
VL (output) COMPLEX array, dimension (LDVL,N)
If JOBVL = 'V', the left generalized eigenvectors. (See
"Purpose", above.)
Each eigenvector will be scaled so the largest component
will have abs(real part) + abs(imag. part) = 1, *except*
that for eigenvalues with alpha=beta=0, a zero vector will
be returned as the corresponding eigenvector.
Not referenced if JOBVL = 'N'.
LDVL (input) INTEGER
The leading dimension of the matrix VL. LDVL >= 1, and
if JOBVL = 'V', LDVL >= N.
VR (output) COMPLEX array, dimension (LDVR,N)
If JOBVR = 'V', the right generalized eigenvectors. (See
"Purpose", above.)
Each eigenvector will be scaled so the largest component
will have abs(real part) + abs(imag. part) = 1, *except*
that for eigenvalues with alpha=beta=0, a zero vector will
be returned as the corresponding eigenvector.
Not referenced if JOBVR = 'N'.
LDVR (input) INTEGER
The leading dimension of the matrix VR. LDVR >= 1, and
if JOBVR = 'V', LDVR >= N.
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,2*N).
For good performance, LWORK must generally be larger.
To compute the optimal value of LWORK, call ILAENV to get
blocksizes (for CGEQRF, CUNMQR, and CUNGQR.) Then compute:
NB -- MAX of the blocksizes for CGEQRF, CUNMQR, and CUNGQR;
The optimal LWORK is MAX( 2*N, N*(NB+1) ).
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.
RWORK (workspace/output) REAL array, dimension (8*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
=1,...,N:
The QZ iteration failed. No eigenvectors have been
calculated, but ALPHA(j) and BETA(j) should be
correct for j=INFO+1,...,N.
> N: errors that usually indicate LAPACK problems:
=N+1: error return from CGGBAL
=N+2: error return from CGEQRF
=N+3: error return from CUNMQR
=N+4: error return from CUNGQR
=N+5: error return from CGGHRD
=N+6: error return from CHGEQZ (other than failed
iteration)
=N+7: error return from CTGEVC
=N+8: error return from CGGBAK (computing VL)
=N+9: error return from CGGBAK (computing VR)
=N+10: error return from CLASCL (various calls)
Further Details
===============
Balancing
---------
This driver calls CGGBAL to both permute and scale rows and columns
of A and B. The permutations PL and PR are chosen so that PL*A*PR
and PL*B*R will be upper triangular except for the diagonal blocks
A(i:j,i:j) and B(i:j,i:j), with i and j as close together as
possible. The diagonal scaling matrices DL and DR are chosen so
that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to
one (except for the elements that start out zero.)
After the eigenvalues and eigenvectors of the balanced matrices
have been computed, CGGBAK transforms the eigenvectors back to what
they would have been (in perfect arithmetic) if they had not been
balanced.
Contents of A and B on Exit
-------- -- - --- - -- ----
If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or
both), then on exit the arrays A and B will contain the complex Schur
form[*] of the "balanced" versions of A and B. If no eigenvectors
are computed, then only the diagonal blocks will be correct.
[*] In other words, upper triangular form.
=====================================================================
Decode the input arguments
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {0.f,0.f};
static complex c_b2 = {1.f,0.f};
static integer c__1 = 1;
static integer c_n1 = -1;
static real c_b29 = 1.f;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
vr_offset, i__1, i__2, i__3, i__4;
real r__1, r__2, r__3, r__4;
complex q__1, q__2;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static real absb, anrm, bnrm;
static integer itau;
static real temp;
static logical ilvl, ilvr;
static integer lopt;
static real anrm1, anrm2, bnrm1, bnrm2, absai, scale, absar, sbeta;
extern logical lsame_(char *, char *);
static integer ileft, iinfo, icols, iwork, irows, jc;
extern /* Subroutine */ int cggbak_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, complex *, integer *,
integer *), cggbal_(char *, integer *, complex *,
integer *, complex *, integer *, integer *, integer *, real *,
real *, real *, integer *);
static integer nb, in;
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *);
static integer jr;
extern /* Subroutine */ int cgghrd_(char *, char *, integer *, integer *,
integer *, complex *, integer *, complex *, integer *, complex *,
integer *, complex *, integer *, integer *);
static real salfai;
extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, complex *, integer *, integer *), cgeqrf_(integer *, integer *, complex *, integer *,
complex *, complex *, integer *, integer *);
static real salfar;
extern doublereal slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), claset_(char *,
integer *, integer *, complex *, complex *, complex *, integer *);
static real safmin;
extern /* Subroutine */ int ctgevc_(char *, char *, logical *, integer *,
complex *, integer *, complex *, integer *, complex *, integer *,
complex *, integer *, integer *, integer *, complex *, real *,
integer *);
static real safmax;
static char chtemp[1];
static logical ldumma[1];
extern /* Subroutine */ int chgeqz_(char *, char *, char *, integer *,
integer *, integer *, complex *, integer *, complex *, integer *,
complex *, complex *, complex *, integer *, complex *, integer *,
complex *, integer *, real *, integer *),
xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
static integer ijobvl, iright;
static logical ilimit;
static integer ijobvr;
extern /* Subroutine */ int cungqr_(integer *, integer *, integer *,
complex *, integer *, complex *, complex *, integer *, integer *);
static integer lwkmin, nb1, nb2, nb3;
extern /* Subroutine */ int cunmqr_(char *, char *, integer *, integer *,
integer *, complex *, integer *, complex *, complex *, integer *,
complex *, integer *, integer *);
static integer irwork, lwkopt;
static logical lquery;
static integer ihi, ilo;
static real eps;
static logical ilv;
#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 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 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)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--alpha;
--beta;
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;
/* Function Body */
if (lsame_(jobvl, "N")) {
ijobvl = 1;
ilvl = FALSE_;
} else if (lsame_(jobvl, "V")) {
ijobvl = 2;
ilvl = TRUE_;
} else {
ijobvl = -1;
ilvl = FALSE_;
}
if (lsame_(jobvr, "N")) {
ijobvr = 1;
ilvr = FALSE_;
} else if (lsame_(jobvr, "V")) {
ijobvr = 2;
ilvr = TRUE_;
} else {
ijobvr = -1;
ilvr = FALSE_;
}
ilv = ilvl || ilvr;
/* Test the input arguments
Computing MAX */
i__1 = *n << 1;
lwkmin = max(i__1,1);
lwkopt = lwkmin;
work[1].r = (real) lwkopt, work[1].i = 0.f;
lquery = *lwork == -1;
*info = 0;
if (ijobvl <= 0) {
*info = -1;
} else if (ijobvr <= 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -7;
} else if (*ldvl < 1 || ilvl && *ldvl < *n) {
*info = -11;
} else if (*ldvr < 1 || ilvr && *ldvr < *n) {
*info = -13;
} else if (*lwork < lwkmin && ! lquery) {
*info = -15;
}
if (*info == 0) {
nb1 = ilaenv_(&c__1, "CGEQRF", " ", n, n, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)1);
nb2 = ilaenv_(&c__1, "CUNMQR", " ", n, n, n, &c_n1, (ftnlen)6, (
ftnlen)1);
nb3 = ilaenv_(&c__1, "CUNGQR", " ", n, n, n, &c_n1, (ftnlen)6, (
ftnlen)1);
/* Computing MAX */
i__1 = max(nb1,nb2);
nb = max(i__1,nb3);
/* Computing MAX */
i__1 = *n << 1, i__2 = *n * (nb + 1);
lopt = max(i__1,i__2);
work[1].r = (real) lopt, work[1].i = 0.f;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGEGV ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = slamch_("E") * slamch_("B");
safmin = slamch_("S");
safmin += safmin;
safmax = 1.f / safmin;
/* Scale A */
anrm = clange_("M", n, n, &a[a_offset], lda, &rwork[1]);
anrm1 = anrm;
anrm2 = 1.f;
if (anrm < 1.f) {
if (safmax * anrm < 1.f) {
anrm1 = safmin;
anrm2 = safmax * anrm;
}
}
if (anrm > 0.f) {
clascl_("G", &c_n1, &c_n1, &anrm, &c_b29, n, n, &a[a_offset], lda, &
iinfo);
if (iinfo != 0) {
*info = *n + 10;
return 0;
}
}
/* Scale B */
bnrm = clange_("M", n, n, &b[b_offset], ldb, &rwork[1]);
bnrm1 = bnrm;
bnrm2 = 1.f;
if (bnrm < 1.f) {
if (safmax * bnrm < 1.f) {
bnrm1 = safmin;
bnrm2 = safmax * bnrm;
}
}
if (bnrm > 0.f) {
clascl_("G", &c_n1, &c_n1, &bnrm, &c_b29, n, n, &b[b_offset], ldb, &
iinfo);
if (iinfo != 0) {
*info = *n + 10;
return 0;
}
}
/* Permute the matrix to make it more nearly triangular
Also "balance" the matrix. */
ileft = 1;
iright = *n + 1;
irwork = iright + *n;
cggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &rwork[
ileft], &rwork[iright], &rwork[irwork], &iinfo);
if (iinfo != 0) {
*info = *n + 1;
goto L80;
}
/* Reduce B to triangular form, and initialize VL and/or VR */
irows = ihi + 1 - ilo;
if (ilv) {
icols = *n + 1 - ilo;
} else {
icols = irows;
}
itau = 1;
iwork = itau + irows;
i__1 = *lwork + 1 - iwork;
cgeqrf_(&irows, &icols, &b_ref(ilo, ilo), ldb, &work[itau], &work[iwork],
&i__1, &iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__3 = iwork;
i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 2;
goto L80;
}
i__1 = *lwork + 1 - iwork;
cunmqr_("L", "C", &irows, &icols, &irows, &b_ref(ilo, ilo), ldb, &work[
itau], &a_ref(ilo, ilo), lda, &work[iwork], &i__1, &iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__3 = iwork;
i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 3;
goto L80;
}
if (ilvl) {
claset_("Full", n, n, &c_b1, &c_b2, &vl[vl_offset], ldvl);
i__1 = irows - 1;
i__2 = irows - 1;
clacpy_("L", &i__1, &i__2, &b_ref(ilo + 1, ilo), ldb, &vl_ref(ilo + 1,
ilo), ldvl);
i__1 = *lwork + 1 - iwork;
cungqr_(&irows, &irows, &irows, &vl_ref(ilo, ilo), ldvl, &work[itau],
&work[iwork], &i__1, &iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__3 = iwork;
i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 4;
goto L80;
}
}
if (ilvr) {
claset_("Full", n, n, &c_b1, &c_b2, &vr[vr_offset], ldvr);
}
/* Reduce to generalized Hessenberg form */
if (ilv) {
/* Eigenvectors requested -- work on whole matrix. */
cgghrd_(jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &iinfo);
} else {
cgghrd_("N", "N", &irows, &c__1, &irows, &a_ref(ilo, ilo), lda, &
b_ref(ilo, ilo), ldb, &vl[vl_offset], ldvl, &vr[vr_offset],
ldvr, &iinfo);
}
if (iinfo != 0) {
*info = *n + 5;
goto L80;
}
/* Perform QZ algorithm */
iwork = itau;
if (ilv) {
*(unsigned char *)chtemp = 'S';
} else {
*(unsigned char *)chtemp = 'E';
}
i__1 = *lwork + 1 - iwork;
chgeqz_(chtemp, jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[
b_offset], ldb, &alpha[1], &beta[1], &vl[vl_offset], ldvl, &vr[
vr_offset], ldvr, &work[iwork], &i__1, &rwork[irwork], &iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__3 = iwork;
i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
if (iinfo > 0 && iinfo <= *n) {
*info = iinfo;
} else if (iinfo > *n && iinfo <= *n << 1) {
*info = iinfo - *n;
} else {
*info = *n + 6;
}
goto L80;
}
if (ilv) {
/* Compute Eigenvectors */
if (ilvl) {
if (ilvr) {
*(unsigned char *)chtemp = 'B';
} else {
*(unsigned char *)chtemp = 'L';
}
} else {
*(unsigned char *)chtemp = 'R';
}
ctgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], ldb,
&vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &work[
iwork], &rwork[irwork], &iinfo);
if (iinfo != 0) {
*info = *n + 7;
goto L80;
}
/* Undo balancing on VL and VR, rescale */
if (ilvl) {
cggbak_("P", "L", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n,
&vl[vl_offset], ldvl, &iinfo);
if (iinfo != 0) {
*info = *n + 8;
goto L80;
}
i__1 = *n;
for (jc = 1; jc <= i__1; ++jc) {
temp = 0.f;
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
i__3 = vl_subscr(jr, jc);
r__3 = temp, r__4 = (r__1 = vl[i__3].r, dabs(r__1)) + (
r__2 = r_imag(&vl_ref(jr, jc)), dabs(r__2));
temp = dmax(r__3,r__4);
/* L10: */
}
if (temp < safmin) {
goto L30;
}
temp = 1.f / temp;
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
i__3 = vl_subscr(jr, jc);
i__4 = vl_subscr(jr, jc);
q__1.r = temp * vl[i__4].r, q__1.i = temp * vl[i__4].i;
vl[i__3].r = q__1.r, vl[i__3].i = q__1.i;
/* L20: */
}
L30:
;
}
}
if (ilvr) {
cggbak_("P", "R", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n,
&vr[vr_offset], ldvr, &iinfo);
if (iinfo != 0) {
*info = *n + 9;
goto L80;
}
i__1 = *n;
for (jc = 1; jc <= i__1; ++jc) {
temp = 0.f;
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
i__3 = vr_subscr(jr, jc);
r__3 = temp, r__4 = (r__1 = vr[i__3].r, dabs(r__1)) + (
r__2 = r_imag(&vr_ref(jr, jc)), dabs(r__2));
temp = dmax(r__3,r__4);
/* L40: */
}
if (temp < safmin) {
goto L60;
}
temp = 1.f / temp;
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
i__3 = vr_subscr(jr, jc);
i__4 = vr_subscr(jr, jc);
q__1.r = temp * vr[i__4].r, q__1.i = temp * vr[i__4].i;
vr[i__3].r = q__1.r, vr[i__3].i = q__1.i;
/* L50: */
}
L60:
;
}
}
/* End of eigenvector calculation */
}
/* Undo scaling in alpha, beta
Note: this does not give the alpha and beta for the unscaled
problem.
Un-scaling is limited to avoid underflow in alpha and beta
if they are significant. */
i__1 = *n;
for (jc = 1; jc <= i__1; ++jc) {
i__2 = jc;
absar = (r__1 = alpha[i__2].r, dabs(r__1));
absai = (r__1 = r_imag(&alpha[jc]), dabs(r__1));
i__2 = jc;
absb = (r__1 = beta[i__2].r, dabs(r__1));
i__2 = jc;
salfar = anrm * alpha[i__2].r;
salfai = anrm * r_imag(&alpha[jc]);
i__2 = jc;
sbeta = bnrm * beta[i__2].r;
ilimit = FALSE_;
scale = 1.f;
/* Check for significant underflow in imaginary part of ALPHA
Computing MAX */
r__1 = safmin, r__2 = eps * absar, r__1 = max(r__1,r__2), r__2 = eps *
absb;
if (dabs(salfai) < safmin && absai >= dmax(r__1,r__2)) {
ilimit = TRUE_;
/* Computing MAX */
r__1 = safmin, r__2 = anrm2 * absai;
scale = safmin / anrm1 / dmax(r__1,r__2);
}
/* Check for significant underflow in real part of ALPHA
Computing MAX */
r__1 = safmin, r__2 = eps * absai, r__1 = max(r__1,r__2), r__2 = eps *
absb;
if (dabs(salfar) < safmin && absar >= dmax(r__1,r__2)) {
ilimit = TRUE_;
/* Computing MAX
Computing MAX */
r__3 = safmin, r__4 = anrm2 * absar;
r__1 = scale, r__2 = safmin / anrm1 / dmax(r__3,r__4);
scale = dmax(r__1,r__2);
}
/* Check for significant underflow in BETA
Computing MAX */
r__1 = safmin, r__2 = eps * absar, r__1 = max(r__1,r__2), r__2 = eps *
absai;
if (dabs(sbeta) < safmin && absb >= dmax(r__1,r__2)) {
ilimit = TRUE_;
/* Computing MAX
Computing MAX */
r__3 = safmin, r__4 = bnrm2 * absb;
r__1 = scale, r__2 = safmin / bnrm1 / dmax(r__3,r__4);
scale = dmax(r__1,r__2);
}
/* Check for possible overflow when limiting scaling */
if (ilimit) {
/* Computing MAX */
r__1 = dabs(salfar), r__2 = dabs(salfai), r__1 = max(r__1,r__2),
r__2 = dabs(sbeta);
temp = scale * safmin * dmax(r__1,r__2);
if (temp > 1.f) {
scale /= temp;
}
if (scale < 1.f) {
ilimit = FALSE_;
}
}
/* Recompute un-scaled ALPHA, BETA if necessary. */
if (ilimit) {
i__2 = jc;
salfar = scale * alpha[i__2].r * anrm;
salfai = scale * r_imag(&alpha[jc]) * anrm;
i__2 = jc;
q__2.r = scale * beta[i__2].r, q__2.i = scale * beta[i__2].i;
q__1.r = bnrm * q__2.r, q__1.i = bnrm * q__2.i;
sbeta = q__1.r;
}
i__2 = jc;
q__1.r = salfar, q__1.i = salfai;
alpha[i__2].r = q__1.r, alpha[i__2].i = q__1.i;
i__2 = jc;
beta[i__2].r = sbeta, beta[i__2].i = 0.f;
/* L70: */
}
L80:
work[1].r = (real) lwkopt, work[1].i = 0.f;
return 0;
/* End of CGEGV */
} /* cgegv_ */
/* 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 cggevx_(char *balanc, char *jobvl, char *jobvr, char *
sense, integer *n, complex *a, integer *lda, complex *b, integer *ldb,
complex *alpha, complex *beta, complex *vl, integer *ldvl, complex *
vr, integer *ldvr, integer *ilo, integer *ihi, real *lscale, real *
rscale, real *abnrm, real *bbnrm, real *rconde, real *rcondv, complex
*work, integer *lwork, real *rwork, integer *iwork, logical *bwork,
integer *info)
{
/* -- LAPACK driver 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
=======
CGGEVX computes for a pair of N-by-N complex nonsymmetric matrices
(A,B) the generalized eigenvalues, and optionally, the left and/or
right generalized eigenvectors.
Optionally, it also computes a balancing transformation to improve
the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for
the eigenvalues (RCONDE), and reciprocal condition numbers for the
right eigenvectors (RCONDV).
A generalized eigenvalue for a pair of matrices (A,B) is a scalar
lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
singular. It is usually represented as the pair (alpha,beta), as
there is a reasonable interpretation for beta=0, and even for both
being zero.
The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
of (A,B) satisfies
A * v(j) = lambda(j) * B * v(j) .
The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
of (A,B) satisfies
u(j)**H * A = lambda(j) * u(j)**H * B.
where u(j)**H is the conjugate-transpose of u(j).
Arguments
=========
BALANC (input) CHARACTER*1
Specifies the balance option to be performed:
= 'N': do not diagonally scale or permute;
= 'P': permute only;
= 'S': scale only;
= 'B': both permute and scale.
Computed reciprocal condition numbers will be for the
matrices after permuting and/or balancing. Permuting does
not change condition numbers (in exact arithmetic), but
balancing does.
JOBVL (input) CHARACTER*1
= 'N': do not compute the left generalized eigenvectors;
= 'V': compute the left generalized eigenvectors.
JOBVR (input) CHARACTER*1
= 'N': do not compute the right generalized eigenvectors;
= 'V': compute the right generalized eigenvectors.
SENSE (input) CHARACTER*1
Determines which reciprocal condition numbers are computed.
= 'N': none are computed;
= 'E': computed for eigenvalues only;
= 'V': computed for eigenvectors only;
= 'B': computed for eigenvalues and eigenvectors.
N (input) INTEGER
The order of the matrices A, B, VL, and VR. N >= 0.
A (input/output) COMPLEX array, dimension (LDA, N)
On entry, the matrix A in the pair (A,B).
On exit, A has been overwritten. If JOBVL='V' or JOBVR='V'
or both, then A contains the first part of the complex Schur
form of the "balanced" versions of the input A and B.
LDA (input) INTEGER
The leading dimension of A. LDA >= max(1,N).
B (input/output) COMPLEX array, dimension (LDB, N)
On entry, the matrix B in the pair (A,B).
On exit, B has been overwritten. If JOBVL='V' or JOBVR='V'
or both, then B contains the second part of the complex
Schur form of the "balanced" versions of the input A and B.
LDB (input) INTEGER
The leading dimension of B. LDB >= max(1,N).
ALPHA (output) COMPLEX array, dimension (N)
BETA (output) COMPLEX array, dimension (N)
On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the generalized
eigenvalues.
Note: the quotient ALPHA(j)/BETA(j) ) may easily over- or
underflow, and BETA(j) may even be zero. Thus, the user
should avoid naively computing the ratio ALPHA/BETA.
However, ALPHA will be always less than and usually
comparable with norm(A) in magnitude, and BETA always less
than and usually comparable with norm(B).
VL (output) COMPLEX array, dimension (LDVL,N)
If JOBVL = 'V', the left generalized eigenvectors u(j) are
stored one after another in the columns of VL, in the same
order as their eigenvalues.
Each eigenvector will be scaled so the largest component
will have abs(real part) + abs(imag. part) = 1.
Not referenced if JOBVL = 'N'.
LDVL (input) INTEGER
The leading dimension of the matrix VL. LDVL >= 1, and
if JOBVL = 'V', LDVL >= N.
VR (output) COMPLEX array, dimension (LDVR,N)
If JOBVR = 'V', the right generalized eigenvectors v(j) are
stored one after another in the columns of VR, in the same
order as their eigenvalues.
Each eigenvector will be scaled so the largest component
will have abs(real part) + abs(imag. part) = 1.
Not referenced if JOBVR = 'N'.
LDVR (input) INTEGER
The leading dimension of the matrix VR. LDVR >= 1, and
if JOBVR = 'V', LDVR >= N.
ILO,IHI (output) INTEGER
ILO and IHI are integer values such that on exit
A(i,j) = 0 and B(i,j) = 0 if i > j and
j = 1,...,ILO-1 or i = IHI+1,...,N.
If BALANC = 'N' or 'S', ILO = 1 and IHI = N.
LSCALE (output) REAL array, dimension (N)
Details of the permutations and scaling factors applied
to the left side of A and B. If PL(j) is the index of the
row interchanged with row j, and DL(j) is the scaling
factor applied to row j, then
LSCALE(j) = PL(j) for j = 1,...,ILO-1
= DL(j) for j = ILO,...,IHI
= PL(j) for j = IHI+1,...,N.
The order in which the interchanges are made is N to IHI+1,
then 1 to ILO-1.
RSCALE (output) REAL array, dimension (N)
Details of the permutations and scaling factors applied
to the right side of A and B. If PR(j) is the index of the
column interchanged with column j, and DR(j) is the scaling
factor applied to column j, then
RSCALE(j) = PR(j) for j = 1,...,ILO-1
= DR(j) for j = ILO,...,IHI
= PR(j) for j = IHI+1,...,N
The order in which the interchanges are made is N to IHI+1,
then 1 to ILO-1.
ABNRM (output) REAL
The one-norm of the balanced matrix A.
BBNRM (output) REAL
The one-norm of the balanced matrix B.
RCONDE (output) REAL array, dimension (N)
If SENSE = 'E' or 'B', the reciprocal condition numbers of
the selected eigenvalues, stored in consecutive elements of
the array.
If SENSE = 'V', RCONDE is not referenced.
RCONDV (output) REAL array, dimension (N)
If JOB = 'V' or 'B', the estimated reciprocal condition
numbers of the selected eigenvectors, stored in consecutive
elements of the array. If the eigenvalues cannot be reordered
to compute RCONDV(j), RCONDV(j) is set to 0; this can only
occur when the true value would be very small anyway.
If SENSE = 'E', RCONDV is not referenced.
Not referenced if JOB = 'E'.
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,2*N).
If SENSE = 'N' or 'E', LWORK >= 2*N.
If SENSE = 'V' or 'B', LWORK >= 2*N*N+2*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.
RWORK (workspace) REAL array, dimension (6*N)
Real workspace.
IWORK (workspace) INTEGER array, dimension (N+2)
If SENSE = 'E', IWORK is not referenced.
BWORK (workspace) LOGICAL array, dimension (N)
If SENSE = 'N', BWORK is not referenced.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
= 1,...,N:
The QZ iteration failed. No eigenvectors have been
calculated, but ALPHA(j) and BETA(j) should be correct
for j=INFO+1,...,N.
> N: =N+1: other than QZ iteration failed in CHGEQZ.
=N+2: error return from CTGEVC.
Further Details
===============
Balancing a matrix pair (A,B) includes, first, permuting rows and
columns to isolate eigenvalues, second, applying diagonal similarity
transformation to the rows and columns to make the rows and columns
as close in norm as possible. The computed reciprocal condition
numbers correspond to the balanced matrix. Permuting rows and columns
will not change the condition numbers (in exact arithmetic) but
diagonal scaling will. For further explanation of balancing, see
section 4.11.1.2 of LAPACK Users' Guide.
An approximate error bound on the chordal distance between the i-th
computed generalized eigenvalue w and the corresponding exact
eigenvalue lambda is
chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I)
An approximate error bound for the angle between the i-th computed
eigenvector VL(i) or VR(i) is given by
EPS * norm(ABNRM, BBNRM) / DIF(i).
For further explanation of the reciprocal condition numbers RCONDE
and RCONDV, see section 4.11 of LAPACK User's Guide.
=====================================================================
Decode the input arguments
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {0.f,0.f};
static complex c_b2 = {1.f,0.f};
static integer c__1 = 1;
static integer c__0 = 0;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
vr_offset, i__1, i__2, i__3, i__4;
real r__1, r__2, r__3, r__4;
complex q__1;
/* Builtin functions */
double sqrt(doublereal), r_imag(complex *);
/* Local variables */
static real anrm, bnrm;
static integer ierr, itau;
static real temp;
static logical ilvl, ilvr;
static integer iwrk, iwrk1, i__, j, m;
extern logical lsame_(char *, char *);
static integer icols, irows, jc;
extern /* Subroutine */ int cggbak_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, complex *, integer *,
integer *), cggbal_(char *, integer *, complex *,
integer *, complex *, integer *, integer *, integer *, real *,
real *, real *, integer *), slabad_(real *, real *);
static integer in;
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *);
static integer jr;
extern /* Subroutine */ int cgghrd_(char *, char *, integer *, integer *,
integer *, complex *, integer *, complex *, integer *, complex *,
integer *, complex *, integer *, integer *),
clascl_(char *, integer *, integer *, real *, real *, integer *,
integer *, complex *, integer *, integer *);
static logical ilascl, ilbscl;
extern /* Subroutine */ int cgeqrf_(integer *, integer *, complex *,
integer *, complex *, complex *, integer *, integer *), clacpy_(
char *, integer *, integer *, complex *, integer *, complex *,
integer *), claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *);
static logical ldumma[1];
static char chtemp[1];
static real bignum;
extern /* Subroutine */ int chgeqz_(char *, char *, char *, integer *,
integer *, integer *, complex *, integer *, complex *, integer *,
complex *, complex *, complex *, integer *, complex *, integer *,
complex *, integer *, real *, integer *),
ctgevc_(char *, char *, logical *, integer *, complex *, integer *
, complex *, integer *, complex *, integer *, complex *, integer *
, integer *, integer *, complex *, real *, integer *);
static integer ijobvl;
extern /* Subroutine */ int ctgsna_(char *, char *, logical *, integer *,
complex *, integer *, complex *, integer *, complex *, integer *,
complex *, integer *, real *, real *, integer *, integer *,
complex *, integer *, integer *, integer *),
slascl_(char *, integer *, integer *, real *, real *, integer *,
integer *, real *, integer *, integer *), xerbla_(char *,
integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern doublereal slamch_(char *);
static integer ijobvr;
static logical wantsb;
extern /* Subroutine */ int cungqr_(integer *, integer *, integer *,
complex *, integer *, complex *, complex *, integer *, integer *);
static real anrmto;
static logical wantse;
static real bnrmto;
extern /* Subroutine */ int cunmqr_(char *, char *, integer *, integer *,
integer *, complex *, integer *, complex *, complex *, integer *,
complex *, integer *, integer *);
static integer minwrk, maxwrk;
static logical wantsn;
static real smlnum;
static logical lquery, wantsv;
static real eps;
static logical ilv;
#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 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 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)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--alpha;
--beta;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1 * 1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1 * 1;
vr -= vr_offset;
--lscale;
--rscale;
--rconde;
--rcondv;
--work;
--rwork;
--iwork;
--bwork;
/* Function Body */
if (lsame_(jobvl, "N")) {
ijobvl = 1;
ilvl = FALSE_;
} else if (lsame_(jobvl, "V")) {
ijobvl = 2;
ilvl = TRUE_;
} else {
ijobvl = -1;
ilvl = FALSE_;
}
if (lsame_(jobvr, "N")) {
ijobvr = 1;
ilvr = FALSE_;
} else if (lsame_(jobvr, "V")) {
ijobvr = 2;
ilvr = TRUE_;
} else {
ijobvr = -1;
ilvr = FALSE_;
}
ilv = ilvl || ilvr;
wantsn = lsame_(sense, "N");
wantse = lsame_(sense, "E");
wantsv = lsame_(sense, "V");
wantsb = lsame_(sense, "B");
/* Test the input arguments */
*info = 0;
lquery = *lwork == -1;
if (! (lsame_(balanc, "N") || lsame_(balanc, "S") || lsame_(balanc, "P")
|| lsame_(balanc, "B"))) {
*info = -1;
} else if (ijobvl <= 0) {
*info = -2;
} else if (ijobvr <= 0) {
*info = -3;
} else if (! (wantsn || wantse || wantsb || wantsv)) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldvl < 1 || ilvl && *ldvl < *n) {
*info = -13;
} else if (*ldvr < 1 || ilvr && *ldvr < *n) {
*info = -15;
}
/* Compute workspace
(Note: Comments in the code beginning "Workspace:" describe the
minimal amount of workspace needed at that point in the code,
as well as the preferred amount for good performance.
NB refers to the optimal block size for the immediately
following subroutine, as returned by ILAENV. The workspace is
computed assuming ILO = 1 and IHI = N, the worst case.) */
minwrk = 1;
if (*info == 0 && (*lwork >= 1 || lquery)) {
maxwrk = *n + *n * ilaenv_(&c__1, "CGEQRF", " ", n, &c__1, n, &c__0, (
ftnlen)6, (ftnlen)1);
if (wantse) {
/* Computing MAX */
i__1 = 1, i__2 = *n << 1;
minwrk = max(i__1,i__2);
} else if (wantsv || wantsb) {
minwrk = (*n << 1) * *n + (*n << 1);
/* Computing MAX */
i__1 = maxwrk, i__2 = (*n << 1) * *n + (*n << 1);
maxwrk = max(i__1,i__2);
}
work[1].r = (real) maxwrk, work[1].i = 0.f;
}
if (*lwork < minwrk && ! lquery) {
*info = -25;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGGEVX", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = slamch_("P");
smlnum = slamch_("S");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1.f / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = clange_("M", n, n, &a[a_offset], lda, &rwork[1]);
ilascl = FALSE_;
if (anrm > 0.f && anrm < smlnum) {
anrmto = smlnum;
ilascl = TRUE_;
} else if (anrm > bignum) {
anrmto = bignum;
ilascl = TRUE_;
}
if (ilascl) {
clascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
ierr);
}
/* Scale B if max element outside range [SMLNUM,BIGNUM] */
bnrm = clange_("M", n, n, &b[b_offset], ldb, &rwork[1]);
ilbscl = FALSE_;
if (bnrm > 0.f && bnrm < smlnum) {
bnrmto = smlnum;
ilbscl = TRUE_;
} else if (bnrm > bignum) {
bnrmto = bignum;
ilbscl = TRUE_;
}
if (ilbscl) {
clascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
ierr);
}
/* Permute and/or balance the matrix pair (A,B)
(Real Workspace: need 6*N) */
cggbal_(balanc, n, &a[a_offset], lda, &b[b_offset], ldb, ilo, ihi, &
lscale[1], &rscale[1], &rwork[1], &ierr);
/* Compute ABNRM and BBNRM */
*abnrm = clange_("1", n, n, &a[a_offset], lda, &rwork[1]);
if (ilascl) {
rwork[1] = *abnrm;
slascl_("G", &c__0, &c__0, &anrmto, &anrm, &c__1, &c__1, &rwork[1], &
c__1, &ierr);
*abnrm = rwork[1];
}
*bbnrm = clange_("1", n, n, &b[b_offset], ldb, &rwork[1]);
if (ilbscl) {
rwork[1] = *bbnrm;
slascl_("G", &c__0, &c__0, &bnrmto, &bnrm, &c__1, &c__1, &rwork[1], &
c__1, &ierr);
*bbnrm = rwork[1];
}
/* Reduce B to triangular form (QR decomposition of B)
(Complex Workspace: need N, prefer N*NB ) */
irows = *ihi + 1 - *ilo;
if (ilv || ! wantsn) {
icols = *n + 1 - *ilo;
} else {
icols = irows;
}
itau = 1;
iwrk = itau + irows;
i__1 = *lwork + 1 - iwrk;
cgeqrf_(&irows, &icols, &b_ref(*ilo, *ilo), ldb, &work[itau], &work[iwrk],
&i__1, &ierr);
/* Apply the unitary transformation to A
(Complex Workspace: need N, prefer N*NB) */
i__1 = *lwork + 1 - iwrk;
cunmqr_("L", "C", &irows, &icols, &irows, &b_ref(*ilo, *ilo), ldb, &work[
itau], &a_ref(*ilo, *ilo), lda, &work[iwrk], &i__1, &ierr);
/* Initialize VL and/or VR
(Workspace: need N, prefer N*NB) */
if (ilvl) {
claset_("Full", n, n, &c_b1, &c_b2, &vl[vl_offset], ldvl);
i__1 = irows - 1;
i__2 = irows - 1;
clacpy_("L", &i__1, &i__2, &b_ref(*ilo + 1, *ilo), ldb, &vl_ref(*ilo
+ 1, *ilo), ldvl);
i__1 = *lwork + 1 - iwrk;
cungqr_(&irows, &irows, &irows, &vl_ref(*ilo, *ilo), ldvl, &work[itau]
, &work[iwrk], &i__1, &ierr);
}
if (ilvr) {
claset_("Full", n, n, &c_b1, &c_b2, &vr[vr_offset], ldvr);
}
/* Reduce to generalized Hessenberg form
(Workspace: none needed) */
if (ilv || ! wantsn) {
/* Eigenvectors requested -- work on whole matrix. */
cgghrd_(jobvl, jobvr, n, ilo, ihi, &a[a_offset], lda, &b[b_offset],
ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ierr);
} else {
cgghrd_("N", "N", &irows, &c__1, &irows, &a_ref(*ilo, *ilo), lda, &
b_ref(*ilo, *ilo), ldb, &vl[vl_offset], ldvl, &vr[vr_offset],
ldvr, &ierr);
}
/* Perform QZ algorithm (Compute eigenvalues, and optionally, the
Schur forms and Schur vectors)
(Complex Workspace: need N)
(Real Workspace: need N) */
iwrk = itau;
if (ilv || ! wantsn) {
*(unsigned char *)chtemp = 'S';
} else {
*(unsigned char *)chtemp = 'E';
}
i__1 = *lwork + 1 - iwrk;
chgeqz_(chtemp, jobvl, jobvr, n, ilo, ihi, &a[a_offset], lda, &b[b_offset]
, ldb, &alpha[1], &beta[1], &vl[vl_offset], ldvl, &vr[vr_offset],
ldvr, &work[iwrk], &i__1, &rwork[1], &ierr);
if (ierr != 0) {
if (ierr > 0 && ierr <= *n) {
*info = ierr;
} else if (ierr > *n && ierr <= *n << 1) {
*info = ierr - *n;
} else {
*info = *n + 1;
}
goto L90;
}
/* Compute Eigenvectors and estimate condition numbers if desired
CTGEVC: (Complex Workspace: need 2*N )
(Real Workspace: need 2*N )
CTGSNA: (Complex Workspace: need 2*N*N if SENSE='V' or 'B')
(Integer Workspace: need N+2 ) */
if (ilv || ! wantsn) {
if (ilv) {
if (ilvl) {
if (ilvr) {
*(unsigned char *)chtemp = 'B';
} else {
*(unsigned char *)chtemp = 'L';
}
} else {
*(unsigned char *)chtemp = 'R';
}
ctgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset],
ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &
work[iwrk], &rwork[1], &ierr);
if (ierr != 0) {
*info = *n + 2;
goto L90;
}
}
if (! wantsn) {
/* compute eigenvectors (STGEVC) and estimate condition
numbers (STGSNA). Note that the definition of the condition
number is not invariant under transformation (u,v) to
(Q*u, Z*v), where (u,v) are eigenvectors of the generalized
Schur form (S,T), Q and Z are orthogonal matrices. In order
to avoid using extra 2*N*N workspace, we have to
re-calculate eigenvectors and estimate the condition numbers
one at a time. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
bwork[j] = FALSE_;
/* L10: */
}
bwork[i__] = TRUE_;
iwrk = *n + 1;
iwrk1 = iwrk + *n;
if (wantse || wantsb) {
ctgevc_("B", "S", &bwork[1], n, &a[a_offset], lda, &b[
b_offset], ldb, &work[1], n, &work[iwrk], n, &
c__1, &m, &work[iwrk1], &rwork[1], &ierr);
if (ierr != 0) {
*info = *n + 2;
goto L90;
}
}
i__2 = *lwork - iwrk1 + 1;
ctgsna_(sense, "S", &bwork[1], n, &a[a_offset], lda, &b[
b_offset], ldb, &work[1], n, &work[iwrk], n, &rconde[
i__], &rcondv[i__], &c__1, &m, &work[iwrk1], &i__2, &
iwork[1], &ierr);
/* L20: */
}
}
}
/* Undo balancing on VL and VR and normalization
(Workspace: none needed) */
if (ilvl) {
cggbak_(balanc, "L", n, ilo, ihi, &lscale[1], &rscale[1], n, &vl[
vl_offset], ldvl, &ierr);
i__1 = *n;
for (jc = 1; jc <= i__1; ++jc) {
temp = 0.f;
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
i__3 = vl_subscr(jr, jc);
r__3 = temp, r__4 = (r__1 = vl[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&vl_ref(jr, jc)), dabs(r__2));
temp = dmax(r__3,r__4);
/* L30: */
}
if (temp < smlnum) {
goto L50;
}
temp = 1.f / temp;
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
i__3 = vl_subscr(jr, jc);
i__4 = vl_subscr(jr, jc);
q__1.r = temp * vl[i__4].r, q__1.i = temp * vl[i__4].i;
vl[i__3].r = q__1.r, vl[i__3].i = q__1.i;
/* L40: */
}
L50:
;
}
}
if (ilvr) {
cggbak_(balanc, "R", n, ilo, ihi, &lscale[1], &rscale[1], n, &vr[
vr_offset], ldvr, &ierr);
i__1 = *n;
for (jc = 1; jc <= i__1; ++jc) {
temp = 0.f;
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
i__3 = vr_subscr(jr, jc);
r__3 = temp, r__4 = (r__1 = vr[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&vr_ref(jr, jc)), dabs(r__2));
temp = dmax(r__3,r__4);
/* L60: */
}
if (temp < smlnum) {
goto L80;
}
temp = 1.f / temp;
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
i__3 = vr_subscr(jr, jc);
i__4 = vr_subscr(jr, jc);
q__1.r = temp * vr[i__4].r, q__1.i = temp * vr[i__4].i;
vr[i__3].r = q__1.r, vr[i__3].i = q__1.i;
/* L70: */
}
L80:
;
}
}
/* Undo scaling if necessary */
if (ilascl) {
clascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alpha[1], n, &
ierr);
}
if (ilbscl) {
clascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
ierr);
}
L90:
work[1].r = (real) maxwrk, work[1].i = 0.f;
return 0;
/* End of CGGEVX */
} /* cggevx_ */
/* Subroutine */ int zdrvev_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
doublecomplex *a, integer *lda, doublecomplex *h__, doublecomplex *w,
doublecomplex *w1, doublecomplex *vl, integer *ldvl, doublecomplex *
vr, integer *ldvr, doublecomplex *lre, integer *ldlre, doublereal *
result, doublecomplex *work, integer *nwork, doublereal *rwork,
integer *iwork, 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_9993[] = "(\002 ZDRVEV: \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_9999[] = "(/1x,a3,\002 -- Complex Eigenvalue-Eigenvect"
"or \002,\002Decomposition Driver\002,/\002 Matrix types (see ZDR"
"VEV for details): \002)";
static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
"rix. \002,\002 \002,\002 5=Diagonal: geom"
"etr. spaced entries.\002,/\002 2=Identity matrix. "
" \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
"/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
" 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
"l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
"ll, evenly spaced.\002)";
static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
" 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
"l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
"d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
"red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
"vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,a6,"
"/\002 12=Well-cond., random complex \002,a6,\002 \002,\002 17="
"Ill-cond., large rand. complx \002,a4,/\002 13=Ill-condi\002,"
"\002tioned, evenly spaced. \002,\002 18=Ill-cond., small ran"
"d.\002,\002 complx \002,a4)";
static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. "
" \002,\002 21=Matrix \002,\002with small random entries.\002,"
"/\002 20=Matrix with large ran\002,\002dom entries. \002,/)";
static char fmt_9995[] = "(\002 Tests performed with test threshold ="
"\002,f8.2,//\002 1 = | A VR - VR W | / ( n |A| ulp ) \002,/\002 "
"2 = | conj-trans(A) VL - VL conj-trans(W) | /\002,\002 ( n |A| u"
"lp ) \002,/\002 3 = | |VR(i)| - 1 | / ulp \002,/\002 4 = | |VL(i"
")| - 1 | / ulp \002,/\002 5 = 0 if W same no matter if VR or VL "
"computed,\002,\002 1/ulp otherwise\002,/\002 6 = 0 if VR same no"
" matter if VL computed,\002,\002 1/ulp otherwise\002,/\002 7 = "
"0 if VL same no matter if VR computed,\002,\002 1/ulp otherwis"
"e\002,/)";
static char fmt_9994[] = "(\002 N=\002,i5,\002, IWK=\002,i2,\002, seed"
"=\002,4(i4,\002,\002),\002 type \002,i2,\002, test(\002,i2,\002)="
"\002,g10.3)";
/* System generated locals */
integer a_dim1, a_offset, h_dim1, h_offset, lre_dim1, lre_offset, vl_dim1,
vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3, i__4, i__5,
i__6;
doublereal d__1, d__2, d__3, d__4, d__5;
doublecomplex z__1;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double sqrt(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
double z_abs(doublecomplex *), d_imag(doublecomplex *);
/* Local variables */
static doublereal cond;
static integer jcol;
static char path[3];
static integer nmax;
static doublereal unfl, ovfl, tnrm, vrmx, vtst;
static integer j, n;
static logical badnn;
static integer nfail, imode, iinfo;
static doublereal conds, anorm;
extern /* Subroutine */ int zget22_(char *, char *, char *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, doublereal *, doublereal *), zgeev_(char *, char *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, integer *);
static integer jsize, nerrs, itype, jtype, ntest;
static doublereal rtulp;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
static integer jj;
extern doublereal dlamch_(char *);
static integer idumma[1];
extern /* Subroutine */ int xerbla_(char *, integer *);
static integer ioldsd[4];
extern /* Subroutine */ int 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 *), zlacpy_(char *, integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *);
static integer ntestf;
extern /* Subroutine */ int 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 *), zlatms_(integer *, integer *, char *, integer *, char *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *, char *, doublecomplex *, integer *, doublecomplex *,
integer *);
static doublereal ulpinv;
static integer nnwork, mtypes, ntestt;
static doublereal rtulpi;
static doublecomplex dum[1];
static doublereal res[2];
static integer iwk;
static doublereal ulp, vmx;
/* Fortran I/O blocks */
static cilist io___31 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9994, 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 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)]
#define lre_subscr(a_1,a_2) (a_2)*lre_dim1 + a_1
#define lre_ref(a_1,a_2) lre[lre_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
September 30, 1994
Purpose
=======
ZDRVEV checks the nonsymmetric eigenvalue problem driver ZGEEV.
When ZDRVEV 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, 7
tests will be performed:
(1) | A * VR - VR * W | / ( n |A| ulp )
Here VR is the matrix of unit right eigenvectors.
W is a diagonal matrix with diagonal entries W(j).
(2) | A**H * VL - VL * W**H | / ( n |A| ulp )
Here VL is the matrix of unit left eigenvectors, A**H is the
conjugate-transpose of A, and W is as above.
(3) | |VR(i)| - 1 | / ulp and whether largest component real
VR(i) denotes the i-th column of VR.
(4) | |VL(i)| - 1 | / ulp and whether largest component real
VL(i) denotes the i-th column of VL.
(5) W(full) = W(partial)
W(full) denotes the eigenvalues computed when both VR and VL
are also computed, and W(partial) denotes the eigenvalues
computed when only W, only W and VR, or only W and VL are
computed.
(6) VR(full) = VR(partial)
VR(full) denotes the right eigenvectors computed when both VR
and VL are computed, and VR(partial) denotes the result
when only VR is computed.
(7) VL(full) = VL(partial)
VL(full) denotes the left eigenvectors computed when both VR
and VL are also computed, and VL(partial) denotes the result
when only VL is computed.
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 a constant near
the overflow threshold
(8) Same as (4), but multiplied by a constant near
the 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 a constant
near the overflow threshold
(18) Same as (16), but multiplied by a constant
near the underflow threshold
(19) Nonsymmetric matrix with random entries chosen from |z| < 1
If N is at least 4, all entries in first two rows and last
row, and first column and last two columns are zero.
(20) Same as (19), but multiplied by a constant
near the overflow threshold
(21) Same as (19), but multiplied by a constant
near the underflow threshold
Arguments
==========
NSIZES (input) INTEGER
The number of sizes of matrices to use. If it is zero,
ZDRVEV does nothing. It must be at least zero.
NN (input) 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.
NTYPES (input) INTEGER
The number of elements in DOTYPE. If it is zero, ZDRVEV
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. .
DOTYPE (input) 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.
ISEED (input/output) 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 ZDRVEV to continue the same random number
sequence.
THRESH (input) 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.
NOUNIT (input) INTEGER
The FORTRAN unit number for printing out error messages
(e.g., if a routine returns INFO not equal to 0.)
A (workspace) 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.
LDA (input) INTEGER
The leading dimension of A, and H. LDA must be at
least 1 and at least max(NN).
H (workspace) COMPLEX*16 array, dimension (LDA, max(NN))
Another copy of the test matrix A, modified by ZGEEV.
W (workspace) COMPLEX*16 array, dimension (max(NN))
The eigenvalues of A. On exit, W are the eigenvalues of
the matrix in A.
W1 (workspace) COMPLEX*16 array, dimension (max(NN))
Like W, this array contains the eigenvalues of A,
but those computed when ZGEEV only computes a partial
eigendecomposition, i.e. not the eigenvalues and left
and right eigenvectors.
VL (workspace) COMPLEX*16 array, dimension (LDVL, max(NN))
VL holds the computed left eigenvectors.
LDVL (input) INTEGER
Leading dimension of VL. Must be at least max(1,max(NN)).
VR (workspace) COMPLEX*16 array, dimension (LDVR, max(NN))
VR holds the computed right eigenvectors.
LDVR (input) INTEGER
Leading dimension of VR. Must be at least max(1,max(NN)).
LRE (workspace) COMPLEX*16 array, dimension (LDLRE, max(NN))
LRE holds the computed right or left eigenvectors.
LDLRE (input) INTEGER
Leading dimension of LRE. Must be at least max(1,max(NN)).
RESULT (output) DOUBLE PRECISION array, dimension (7)
The values computed by the seven tests described above.
The values are currently limited to 1/ulp, to avoid
overflow.
WORK (workspace) COMPLEX*16 array, dimension (NWORK)
NWORK (input) INTEGER
The number of entries in WORK. This must be at least
5*NN(j)+2*NN(j)**2 for all j.
RWORK (workspace) DOUBLE PRECISION array, dimension (2*max(NN))
IWORK (workspace) INTEGER array, dimension (max(NN))
INFO (output) 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: LDVL < 1 or LDVL < NMAX, where NMAX is max( NN(j) ).
-16: LDVR < 1 or LDVR < NMAX, where NMAX is max( NN(j) ).
-18: LDLRE < 1 or LDLRE < NMAX, where NMAX is max( NN(j) ).
-21: NWORK too small.
If ZLATMR, CLATMS, CLATME or ZGEEV returns an error code,
the absolute value of it is returned.
-----------------------------------------------------------------------
Some Local Variables and Parameters:
---- ----- --------- --- ----------
ZERO, ONE Real 0 and 1.
MAXTYP The number of types defined.
NMAX Largest value in NN.
NERRS The number of tests which have exceeded THRESH
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.
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) Selectw whether CONDS is to be 1 or
1/sqrt(ulp). (0 means irrelevant.)
=====================================================================
Parameter adjustments */
--nn;
--dotype;
--iseed;
h_dim1 = *lda;
h_offset = 1 + h_dim1 * 1;
h__ -= h_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--w;
--w1;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1 * 1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1 * 1;
vr -= vr_offset;
lre_dim1 = *ldlre;
lre_offset = 1 + lre_dim1 * 1;
lre -= lre_offset;
--result;
--work;
--rwork;
--iwork;
/* Function Body */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "EV", (ftnlen)2, (ftnlen)2);
/* Check for errors */
ntestt = 0;
ntestf = 0;
*info = 0;
/* Important constants */
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 (*nounit <= 0) {
*info = -7;
} else if (*lda < 1 || *lda < nmax) {
*info = -9;
} else if (*ldvl < 1 || *ldvl < nmax) {
*info = -14;
} else if (*ldvr < 1 || *ldvr < nmax) {
*info = -16;
} else if (*ldlre < 1 || *ldlre < nmax) {
*info = -28;
} else /* if(complicated condition) */ {
/* Computing 2nd power */
i__1 = nmax;
if (nmax * 5 + (i__1 * i__1 << 1) > *nwork) {
*info = -21;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZDRVEV", &i__1);
return 0;
}
/* Quick return if nothing to do */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
/* More Important constants */
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
dlabad_(&unfl, &ovfl);
ulp = dlamch_("Precision");
ulpinv = 1. / ulp;
rtulp = sqrt(ulp);
rtulpi = 1. / rtulp;
/* Loop over sizes, types */
nerrs = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
if (*nsizes != 1) {
mtypes = min(21,*ntypes);
} else {
mtypes = min(22,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L260;
}
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Compute "A"
Control parameters:
KMAGN KCONDS KMODE KTYPE
=1 O(1) 1 clustered 1 zero
=2 large large clustered 2 identity
=3 small exponential Jordan
=4 arithmetic diagonal, (w/ eigenvalues)
=5 random log symmetric, w/ eigenvalues
=6 random general, w/ eigenvalues
=7 random diagonal
=8 random symmetric
=9 random general
=10 random triangular */
if (mtypes > 21) {
goto L90;
}
itype = ktype[jtype - 1];
imode = kmode[jtype - 1];
/* Compute norm */
switch (kmagn[jtype - 1]) {
case 1: goto L30;
case 2: goto L40;
case 3: goto L50;
}
L30:
anorm = 1.;
goto L60;
L40:
anorm = ovfl * ulp;
goto L60;
L50:
anorm = unfl * ulpinv;
goto L60;
L60:
zlaset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
iinfo = 0;
cond = ulpinv;
/* Special Matrices -- Identity & Jordan block
Zero */
if (itype == 1) {
iinfo = 0;
} else if (itype == 2) {
/* Identity */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
i__4 = a_subscr(jcol, jcol);
z__1.r = anorm, z__1.i = 0.;
a[i__4].r = z__1.r, a[i__4].i = z__1.i;
/* L70: */
}
} else if (itype == 3) {
/* Jordan Block */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
i__4 = a_subscr(jcol, jcol);
z__1.r = anorm, z__1.i = 0.;
a[i__4].r = z__1.r, a[i__4].i = z__1.i;
if (jcol > 1) {
i__4 = a_subscr(jcol, jcol - 1);
a[i__4].r = 1., a[i__4].i = 0.;
}
/* L80: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
&anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[
n + 1], &iinfo);
} else if (itype == 5) {
/* Hermitian, eigenvalues specified */
zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
&anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
&iinfo);
} else if (itype == 6) {
/* General, eigenvalues specified */
if (kconds[jtype - 1] == 1) {
conds = 1.;
} else if (kconds[jtype - 1] == 2) {
conds = rtulpi;
} else {
conds = 0.;
}
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) + 1], &
iinfo);
} else if (itype == 7) {
/* Diagonal, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b38,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[(
n << 1) + 1], &c__1, &c_b38, "N", idumma, &c__0, &
c__0, &c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[
1], &iinfo);
} else if (itype == 8) {
/* Symmetric, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "H", &work[1], &c__6, &c_b38,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[(
n << 1) + 1], &c__1, &c_b38, "N", idumma, &n, &n, &
c_b48, &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_b38,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[(
n << 1) + 1], &c__1, &c_b38, "N", idumma, &n, &n, &
c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
if (n >= 4) {
zlaset_("Full", &c__2, &n, &c_b1, &c_b1, &a[a_offset],
lda);
i__3 = n - 3;
zlaset_("Full", &i__3, &c__1, &c_b1, &c_b1, &a_ref(3, 1),
lda);
i__3 = n - 3;
zlaset_("Full", &i__3, &c__2, &c_b1, &c_b1, &a_ref(3, n -
1), lda);
zlaset_("Full", &c__1, &n, &c_b1, &c_b1, &a_ref(n, 1),
lda);
}
} else if (itype == 10) {
/* Triangular, random eigenvalues */
zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b38,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[(
n << 1) + 1], &c__1, &c_b38, "N", idumma, &n, &c__0, &
c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else {
iinfo = 1;
}
if (iinfo != 0) {
io___31.ciunit = *nounit;
s_wsfe(&io___31);
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;
}
L90:
/* Test for minimal and generous workspace */
for (iwk = 1; iwk <= 2; ++iwk) {
if (iwk == 1) {
nnwork = n << 1;
} else {
/* Computing 2nd power */
i__3 = n;
nnwork = n * 5 + (i__3 * i__3 << 1);
}
nnwork = max(nnwork,1);
/* Initialize RESULT */
for (j = 1; j <= 7; ++j) {
result[j] = -1.;
/* L100: */
}
/* Compute eigenvalues and eigenvectors, and test them */
zlacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
zgeev_("V", "V", &n, &h__[h_offset], lda, &w[1], &vl[
vl_offset], ldvl, &vr[vr_offset], ldvr, &work[1], &
nnwork, &rwork[1], &iinfo);
if (iinfo != 0) {
result[1] = ulpinv;
io___34.ciunit = *nounit;
s_wsfe(&io___34);
do_fio(&c__1, "ZGEEV1", (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 L220;
}
/* Do Test (1) */
zget22_("N", "N", "N", &n, &a[a_offset], lda, &vr[vr_offset],
ldvr, &w[1], &work[1], &rwork[1], res);
result[1] = res[0];
/* Do Test (2) */
zget22_("C", "N", "C", &n, &a[a_offset], lda, &vl[vl_offset],
ldvl, &w[1], &work[1], &rwork[1], res);
result[2] = res[0];
/* Do Test (3) */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
tnrm = dznrm2_(&n, &vr_ref(1, j), &c__1);
/* Computing MAX
Computing MIN */
d__4 = ulpinv, d__5 = (d__1 = tnrm - 1., abs(d__1)) / ulp;
d__2 = result[3], d__3 = min(d__4,d__5);
result[3] = max(d__2,d__3);
vmx = 0.;
vrmx = 0.;
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
vtst = z_abs(&vr_ref(jj, j));
if (vtst > vmx) {
vmx = vtst;
}
i__5 = vr_subscr(jj, j);
if (d_imag(&vr_ref(jj, j)) == 0. && (d__1 = vr[i__5]
.r, abs(d__1)) > vrmx) {
i__6 = vr_subscr(jj, j);
vrmx = (d__2 = vr[i__6].r, abs(d__2));
}
/* L110: */
}
if (vrmx / vmx < 1. - ulp * 2.) {
result[3] = ulpinv;
}
/* L120: */
}
/* Do Test (4) */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
tnrm = dznrm2_(&n, &vl_ref(1, j), &c__1);
/* Computing MAX
Computing MIN */
d__4 = ulpinv, d__5 = (d__1 = tnrm - 1., abs(d__1)) / ulp;
d__2 = result[4], d__3 = min(d__4,d__5);
result[4] = max(d__2,d__3);
vmx = 0.;
vrmx = 0.;
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
vtst = z_abs(&vl_ref(jj, j));
if (vtst > vmx) {
vmx = vtst;
}
i__5 = vl_subscr(jj, j);
if (d_imag(&vl_ref(jj, j)) == 0. && (d__1 = vl[i__5]
.r, abs(d__1)) > vrmx) {
i__6 = vl_subscr(jj, j);
vrmx = (d__2 = vl[i__6].r, abs(d__2));
}
/* L130: */
}
if (vrmx / vmx < 1. - ulp * 2.) {
result[4] = ulpinv;
}
/* L140: */
}
/* Compute eigenvalues only, and test them */
zlacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
zgeev_("N", "N", &n, &h__[h_offset], lda, &w1[1], dum, &c__1,
dum, &c__1, &work[1], &nnwork, &rwork[1], &iinfo);
if (iinfo != 0) {
result[1] = ulpinv;
io___42.ciunit = *nounit;
s_wsfe(&io___42);
do_fio(&c__1, "ZGEEV2", (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 L220;
}
/* Do Test (5) */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = j;
i__5 = j;
if (w[i__4].r != w1[i__5].r || w[i__4].i != w1[i__5].i) {
result[5] = ulpinv;
}
/* L150: */
}
/* Compute eigenvalues and right eigenvectors, and test them */
zlacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
zgeev_("N", "V", &n, &h__[h_offset], lda, &w1[1], dum, &c__1,
&lre[lre_offset], ldlre, &work[1], &nnwork, &rwork[1],
&iinfo);
if (iinfo != 0) {
result[1] = ulpinv;
io___43.ciunit = *nounit;
s_wsfe(&io___43);
do_fio(&c__1, "ZGEEV3", (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 L220;
}
/* Do Test (5) again */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = j;
i__5 = j;
if (w[i__4].r != w1[i__5].r || w[i__4].i != w1[i__5].i) {
result[5] = ulpinv;
}
/* L160: */
}
/* Do Test (6) */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
i__5 = vr_subscr(j, jj);
i__6 = lre_subscr(j, jj);
if (vr[i__5].r != lre[i__6].r || vr[i__5].i != lre[
i__6].i) {
result[6] = ulpinv;
}
/* L170: */
}
/* L180: */
}
/* Compute eigenvalues and left eigenvectors, and test them */
zlacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
zgeev_("V", "N", &n, &h__[h_offset], lda, &w1[1], &lre[
lre_offset], ldlre, dum, &c__1, &work[1], &nnwork, &
rwork[1], &iinfo);
if (iinfo != 0) {
result[1] = ulpinv;
io___44.ciunit = *nounit;
s_wsfe(&io___44);
do_fio(&c__1, "ZGEEV4", (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 L220;
}
/* Do Test (5) again */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = j;
i__5 = j;
if (w[i__4].r != w1[i__5].r || w[i__4].i != w1[i__5].i) {
result[5] = ulpinv;
}
/* L190: */
}
/* Do Test (7) */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
i__5 = vl_subscr(j, jj);
i__6 = lre_subscr(j, jj);
if (vl[i__5].r != lre[i__6].r || vl[i__5].i != lre[
i__6].i) {
result[7] = ulpinv;
}
/* L200: */
}
/* L210: */
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L220:
ntest = 0;
nfail = 0;
for (j = 1; j <= 7; ++j) {
if (result[j] >= 0.) {
++ntest;
}
if (result[j] >= *thresh) {
++nfail;
}
/* L230: */
}
if (nfail > 0) {
++ntestf;
}
if (ntestf == 1) {
io___47.ciunit = *nounit;
s_wsfe(&io___47);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
io___48.ciunit = *nounit;
s_wsfe(&io___48);
e_wsfe();
io___49.ciunit = *nounit;
s_wsfe(&io___49);
e_wsfe();
io___50.ciunit = *nounit;
s_wsfe(&io___50);
e_wsfe();
io___51.ciunit = *nounit;
s_wsfe(&io___51);
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(
doublereal));
e_wsfe();
ntestf = 2;
}
for (j = 1; j <= 7; ++j) {
if (result[j] >= *thresh) {
io___52.ciunit = *nounit;
s_wsfe(&io___52);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(
doublereal));
e_wsfe();
}
/* L240: */
}
nerrs += nfail;
ntestt += ntest;
/* L250: */
}
L260:
;
}
/* L270: */
}
/* Summary */
dlasum_(path, nounit, &nerrs, &ntestt);
return 0;
/* End of ZDRVEV */
} /* zdrvev_ */
/* Subroutine */ int zget23_(logical *comp, integer *isrt, char *balanc,
integer *jtype, doublereal *thresh, integer *iseed, integer *nounit,
integer *n, doublecomplex *a, integer *lda, doublecomplex *h__,
doublecomplex *w, doublecomplex *w1, doublecomplex *vl, integer *ldvl,
doublecomplex *vr, integer *ldvr, doublecomplex *lre, integer *ldlre,
doublereal *rcondv, doublereal *rcndv1, doublereal *rcdvin,
doublereal *rconde, doublereal *rcnde1, doublereal *rcdein,
doublereal *scale, doublereal *scale1, doublereal *result,
doublecomplex *work, integer *lwork, doublereal *rwork, integer *info)
{
/* Initialized data */
static char sens[1*2] = "N" "V";
/* Format strings */
static char fmt_9998[] = "(\002 ZGET23: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, BALANC = "
"\002,a,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9999[] = "(\002 ZGET23: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, INPUT EXAMPLE NUMBER = \002,"
"i4)";
/* System generated locals */
integer a_dim1, a_offset, h_dim1, h_offset, lre_dim1, lre_offset, vl_dim1,
vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4, d__5;
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
double z_abs(doublecomplex *), d_imag(doublecomplex *);
/* Local variables */
static doublecomplex cdum[1];
static integer kmin;
static doublecomplex ctmp;
static doublereal vmax, tnrm, vrmx, vtst;
static integer i__, j;
static doublereal v;
static logical balok, nobal;
static doublereal abnrm;
extern logical lsame_(char *, char *);
static integer iinfo;
static char sense[1];
extern /* Subroutine */ int zget22_(char *, char *, char *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, doublereal *, doublereal *);
static integer isens;
static doublereal tolin, abnrm1;
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
static integer jj;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
static integer isensm;
static doublereal vricmp;
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static doublereal vrimin;
extern /* Subroutine */ int zgeevx_(char *, char *, char *, char *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *
, doublecomplex *, integer *, doublereal *, integer *);
static doublereal smlnum, ulpinv;
static integer ihi, ilo;
static doublereal eps, res[2], tol, ulp, vmx;
static integer ihi1, ilo1;
/* Fortran I/O blocks */
static cilist io___14 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___15 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___28 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___29 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___30 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___31 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___32 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
#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)]
#define lre_subscr(a_1,a_2) (a_2)*lre_dim1 + a_1
#define lre_ref(a_1,a_2) lre[lre_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
September 30, 1994
Purpose
=======
ZGET23 checks the nonsymmetric eigenvalue problem driver CGEEVX.
If COMP = .FALSE., the first 8 of the following tests will be
performed on the input matrix A, and also test 9 if LWORK is
sufficiently large.
if COMP is .TRUE. all 11 tests will be performed.
(1) | A * VR - VR * W | / ( n |A| ulp )
Here VR is the matrix of unit right eigenvectors.
W is a diagonal matrix with diagonal entries W(j).
(2) | A**H * VL - VL * W**H | / ( n |A| ulp )
Here VL is the matrix of unit left eigenvectors, A**H is the
conjugate transpose of A, and W is as above.
(3) | |VR(i)| - 1 | / ulp and largest component real
VR(i) denotes the i-th column of VR.
(4) | |VL(i)| - 1 | / ulp and largest component real
VL(i) denotes the i-th column of VL.
(5) 0 if W(full) = W(partial), 1/ulp otherwise
W(full) denotes the eigenvalues computed when VR, VL, RCONDV
and RCONDE are also computed, and W(partial) denotes the
eigenvalues computed when only some of VR, VL, RCONDV, and
RCONDE are computed.
(6) 0 if VR(full) = VR(partial), 1/ulp otherwise
VR(full) denotes the right eigenvectors computed when VL, RCONDV
and RCONDE are computed, and VR(partial) denotes the result
when only some of VL and RCONDV are computed.
(7) 0 if VL(full) = VL(partial), 1/ulp otherwise
VL(full) denotes the left eigenvectors computed when VR, RCONDV
and RCONDE are computed, and VL(partial) denotes the result
when only some of VR and RCONDV are computed.
(8) 0 if SCALE, ILO, IHI, ABNRM (full) =
SCALE, ILO, IHI, ABNRM (partial)
1/ulp otherwise
SCALE, ILO, IHI and ABNRM describe how the matrix is balanced.
(full) is when VR, VL, RCONDE and RCONDV are also computed, and
(partial) is when some are not computed.
(9) 0 if RCONDV(full) = RCONDV(partial), 1/ulp otherwise
RCONDV(full) denotes the reciprocal condition numbers of the
right eigenvectors computed when VR, VL and RCONDE are also
computed. RCONDV(partial) denotes the reciprocal condition
numbers when only some of VR, VL and RCONDE are computed.
(10) |RCONDV - RCDVIN| / cond(RCONDV)
RCONDV is the reciprocal right eigenvector condition number
computed by ZGEEVX and RCDVIN (the precomputed true value)
is supplied as input. cond(RCONDV) is the condition number of
RCONDV, and takes errors in computing RCONDV into account, so
that the resulting quantity should be O(ULP). cond(RCONDV) is
essentially given by norm(A)/RCONDE.
(11) |RCONDE - RCDEIN| / cond(RCONDE)
RCONDE is the reciprocal eigenvalue condition number
computed by ZGEEVX and RCDEIN (the precomputed true value)
is supplied as input. cond(RCONDE) is the condition number
of RCONDE, and takes errors in computing RCONDE into account,
so that the resulting quantity should be O(ULP). cond(RCONDE)
is essentially given by norm(A)/RCONDV.
Arguments
=========
COMP (input) LOGICAL
COMP describes which input tests to perform:
= .FALSE. if the computed condition numbers are not to
be tested against RCDVIN and RCDEIN
= .TRUE. if they are to be compared
ISRT (input) INTEGER
If COMP = .TRUE., ISRT indicates in how the eigenvalues
corresponding to values in RCDVIN and RCDEIN are ordered:
= 0 means the eigenvalues are sorted by
increasing real part
= 1 means the eigenvalues are sorted by
increasing imaginary part
If COMP = .FALSE., ISRT is not referenced.
BALANC (input) CHARACTER
Describes the balancing option to be tested.
= 'N' for no permuting or diagonal scaling
= 'P' for permuting but no diagonal scaling
= 'S' for no permuting but diagonal scaling
= 'B' for permuting and diagonal scaling
JTYPE (input) INTEGER
Type of input matrix. Used to label output if error occurs.
THRESH (input) 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.
ISEED (input) INTEGER array, dimension (4)
If COMP = .FALSE., the random number generator seed
used to produce matrix.
If COMP = .TRUE., ISEED(1) = the number of the example.
Used to label output if error occurs.
NOUNIT (input) INTEGER
The FORTRAN unit number for printing out error messages
(e.g., if a routine returns INFO not equal to 0.)
N (input) INTEGER
The dimension of A. N must be at least 0.
A (input/output) COMPLEX*16 array, dimension (LDA,N)
Used to hold the matrix whose eigenvalues are to be
computed.
LDA (input) INTEGER
The leading dimension of A, and H. LDA must be at
least 1 and at least N.
H (workspace) COMPLEX*16 array, dimension (LDA,N)
Another copy of the test matrix A, modified by ZGEEVX.
W (workspace) COMPLEX*16 array, dimension (N)
Contains the eigenvalues of A.
W1 (workspace) COMPLEX*16 array, dimension (N)
Like W, this array contains the eigenvalues of A,
but those computed when ZGEEVX only computes a partial
eigendecomposition, i.e. not the eigenvalues and left
and right eigenvectors.
VL (workspace) COMPLEX*16 array, dimension (LDVL,N)
VL holds the computed left eigenvectors.
LDVL (input) INTEGER
Leading dimension of VL. Must be at least max(1,N).
VR (workspace) COMPLEX*16 array, dimension (LDVR,N)
VR holds the computed right eigenvectors.
LDVR (input) INTEGER
Leading dimension of VR. Must be at least max(1,N).
LRE (workspace) COMPLEX*16 array, dimension (LDLRE,N)
LRE holds the computed right or left eigenvectors.
LDLRE (input) INTEGER
Leading dimension of LRE. Must be at least max(1,N).
RCONDV (workspace) DOUBLE PRECISION array, dimension (N)
RCONDV holds the computed reciprocal condition numbers
for eigenvectors.
RCNDV1 (workspace) DOUBLE PRECISION array, dimension (N)
RCNDV1 holds more computed reciprocal condition numbers
for eigenvectors.
RCDVIN (input) DOUBLE PRECISION array, dimension (N)
When COMP = .TRUE. RCDVIN holds the precomputed reciprocal
condition numbers for eigenvectors to be compared with
RCONDV.
RCONDE (workspace) DOUBLE PRECISION array, dimension (N)
RCONDE holds the computed reciprocal condition numbers
for eigenvalues.
RCNDE1 (workspace) DOUBLE PRECISION array, dimension (N)
RCNDE1 holds more computed reciprocal condition numbers
for eigenvalues.
RCDEIN (input) DOUBLE PRECISION array, dimension (N)
When COMP = .TRUE. RCDEIN holds the precomputed reciprocal
condition numbers for eigenvalues to be compared with
RCONDE.
SCALE (workspace) DOUBLE PRECISION array, dimension (N)
Holds information describing balancing of matrix.
SCALE1 (workspace) DOUBLE PRECISION array, dimension (N)
Holds information describing balancing of matrix.
RESULT (output) DOUBLE PRECISION array, dimension (11)
The values computed by the 11 tests described above.
The values are currently limited to 1/ulp, to avoid
overflow.
WORK (workspace) COMPLEX*16 array, dimension (LWORK)
LWORK (input) INTEGER
The number of entries in WORK. This must be at least
2*N, and 2*N+N**2 if tests 9, 10 or 11 are to be performed.
RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)
INFO (output) INTEGER
If 0, successful exit.
If <0, input parameter -INFO had an incorrect value.
If >0, ZGEEVX returned an error code, the absolute
value of which is returned.
=====================================================================
Parameter adjustments */
--iseed;
h_dim1 = *lda;
h_offset = 1 + h_dim1 * 1;
h__ -= h_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--w;
--w1;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1 * 1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1 * 1;
vr -= vr_offset;
lre_dim1 = *ldlre;
lre_offset = 1 + lre_dim1 * 1;
lre -= lre_offset;
--rcondv;
--rcndv1;
--rcdvin;
--rconde;
--rcnde1;
--rcdein;
--scale;
--scale1;
--result;
--work;
--rwork;
/* Function Body
Check for errors */
nobal = lsame_(balanc, "N");
balok = nobal || lsame_(balanc, "P") || lsame_(
balanc, "S") || lsame_(balanc, "B");
*info = 0;
if (*isrt != 0 && *isrt != 1) {
*info = -2;
} else if (! balok) {
*info = -3;
} else if (*thresh < 0.) {
*info = -5;
} else if (*nounit <= 0) {
*info = -7;
} else if (*n < 0) {
*info = -8;
} else if (*lda < 1 || *lda < *n) {
*info = -10;
} else if (*ldvl < 1 || *ldvl < *n) {
*info = -15;
} else if (*ldvr < 1 || *ldvr < *n) {
*info = -17;
} else if (*ldlre < 1 || *ldlre < *n) {
*info = -19;
} else if (*lwork < *n << 1 || *comp && *lwork < (*n << 1) + *n * *n) {
*info = -30;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGET23", &i__1);
return 0;
}
/* Quick return if nothing to do */
for (i__ = 1; i__ <= 11; ++i__) {
result[i__] = -1.;
/* L10: */
}
if (*n == 0) {
return 0;
}
/* More Important constants */
ulp = dlamch_("Precision");
smlnum = dlamch_("S");
ulpinv = 1. / ulp;
/* Compute eigenvalues and eigenvectors, and test them */
if (*lwork >= (*n << 1) + *n * *n) {
*(unsigned char *)sense = 'B';
isensm = 2;
} else {
*(unsigned char *)sense = 'E';
isensm = 1;
}
zlacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda);
zgeevx_(balanc, "V", "V", sense, n, &h__[h_offset], lda, &w[1], &vl[
vl_offset], ldvl, &vr[vr_offset], ldvr, &ilo, &ihi, &scale[1], &
abnrm, &rconde[1], &rcondv[1], &work[1], lwork, &rwork[1], &iinfo);
if (iinfo != 0) {
result[1] = ulpinv;
if (*jtype != 22) {
io___14.ciunit = *nounit;
s_wsfe(&io___14);
do_fio(&c__1, "ZGEEVX1", (ftnlen)7);
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__1, balanc, (ftnlen)1);
do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___15.ciunit = *nounit;
s_wsfe(&io___15);
do_fio(&c__1, "ZGEEVX1", (ftnlen)7);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
e_wsfe();
}
*info = abs(iinfo);
return 0;
}
/* Do Test (1) */
zget22_("N", "N", "N", n, &a[a_offset], lda, &vr[vr_offset], ldvr, &w[1],
&work[1], &rwork[1], res);
result[1] = res[0];
/* Do Test (2) */
zget22_("C", "N", "C", n, &a[a_offset], lda, &vl[vl_offset], ldvl, &w[1],
&work[1], &rwork[1], res);
result[2] = res[0];
/* Do Test (3) */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
tnrm = dznrm2_(n, &vr_ref(1, j), &c__1);
/* Computing MAX
Computing MIN */
d__4 = ulpinv, d__5 = (d__1 = tnrm - 1., abs(d__1)) / ulp;
d__2 = result[3], d__3 = min(d__4,d__5);
result[3] = max(d__2,d__3);
vmx = 0.;
vrmx = 0.;
i__2 = *n;
for (jj = 1; jj <= i__2; ++jj) {
vtst = z_abs(&vr_ref(jj, j));
if (vtst > vmx) {
vmx = vtst;
}
i__3 = vr_subscr(jj, j);
if (d_imag(&vr_ref(jj, j)) == 0. && (d__1 = vr[i__3].r, abs(d__1))
> vrmx) {
i__4 = vr_subscr(jj, j);
vrmx = (d__2 = vr[i__4].r, abs(d__2));
}
/* L20: */
}
if (vrmx / vmx < 1. - ulp * 2.) {
result[3] = ulpinv;
}
/* L30: */
}
/* Do Test (4) */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
tnrm = dznrm2_(n, &vl_ref(1, j), &c__1);
/* Computing MAX
Computing MIN */
d__4 = ulpinv, d__5 = (d__1 = tnrm - 1., abs(d__1)) / ulp;
d__2 = result[4], d__3 = min(d__4,d__5);
result[4] = max(d__2,d__3);
vmx = 0.;
vrmx = 0.;
i__2 = *n;
for (jj = 1; jj <= i__2; ++jj) {
vtst = z_abs(&vl_ref(jj, j));
if (vtst > vmx) {
vmx = vtst;
}
i__3 = vl_subscr(jj, j);
if (d_imag(&vl_ref(jj, j)) == 0. && (d__1 = vl[i__3].r, abs(d__1))
> vrmx) {
i__4 = vl_subscr(jj, j);
vrmx = (d__2 = vl[i__4].r, abs(d__2));
}
/* L40: */
}
if (vrmx / vmx < 1. - ulp * 2.) {
result[4] = ulpinv;
}
/* L50: */
}
/* Test for all options of computing condition numbers */
i__1 = isensm;
for (isens = 1; isens <= i__1; ++isens) {
*(unsigned char *)sense = *(unsigned char *)&sens[isens - 1];
/* Compute eigenvalues only, and test them */
zlacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda);
zgeevx_(balanc, "N", "N", sense, n, &h__[h_offset], lda, &w1[1], cdum,
&c__1, cdum, &c__1, &ilo1, &ihi1, &scale1[1], &abnrm1, &
rcnde1[1], &rcndv1[1], &work[1], lwork, &rwork[1], &iinfo);
if (iinfo != 0) {
result[1] = ulpinv;
if (*jtype != 22) {
io___28.ciunit = *nounit;
s_wsfe(&io___28);
do_fio(&c__1, "ZGEEVX2", (ftnlen)7);
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__1, balanc, (ftnlen)1);
do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___29.ciunit = *nounit;
s_wsfe(&io___29);
do_fio(&c__1, "ZGEEVX2", (ftnlen)7);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
e_wsfe();
}
*info = abs(iinfo);
goto L190;
}
/* Do Test (5) */
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
i__3 = j;
i__4 = j;
if (w[i__3].r != w1[i__4].r || w[i__3].i != w1[i__4].i) {
result[5] = ulpinv;
}
/* L60: */
}
/* Do Test (8) */
if (! nobal) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
if (scale[j] != scale1[j]) {
result[8] = ulpinv;
}
/* L70: */
}
if (ilo != ilo1) {
result[8] = ulpinv;
}
if (ihi != ihi1) {
result[8] = ulpinv;
}
if (abnrm != abnrm1) {
result[8] = ulpinv;
}
}
/* Do Test (9) */
if (isens == 2 && *n > 1) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
if (rcondv[j] != rcndv1[j]) {
result[9] = ulpinv;
}
/* L80: */
}
}
/* Compute eigenvalues and right eigenvectors, and test them */
zlacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda);
zgeevx_(balanc, "N", "V", sense, n, &h__[h_offset], lda, &w1[1], cdum,
&c__1, &lre[lre_offset], ldlre, &ilo1, &ihi1, &scale1[1], &
abnrm1, &rcnde1[1], &rcndv1[1], &work[1], lwork, &rwork[1], &
iinfo);
if (iinfo != 0) {
result[1] = ulpinv;
if (*jtype != 22) {
io___30.ciunit = *nounit;
s_wsfe(&io___30);
do_fio(&c__1, "ZGEEVX3", (ftnlen)7);
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__1, balanc, (ftnlen)1);
do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___31.ciunit = *nounit;
s_wsfe(&io___31);
do_fio(&c__1, "ZGEEVX3", (ftnlen)7);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
e_wsfe();
}
*info = abs(iinfo);
goto L190;
}
/* Do Test (5) again */
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
i__3 = j;
i__4 = j;
if (w[i__3].r != w1[i__4].r || w[i__3].i != w1[i__4].i) {
result[5] = ulpinv;
}
/* L90: */
}
/* Do Test (6) */
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
i__3 = *n;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = vr_subscr(j, jj);
i__5 = lre_subscr(j, jj);
if (vr[i__4].r != lre[i__5].r || vr[i__4].i != lre[i__5].i) {
result[6] = ulpinv;
}
/* L100: */
}
/* L110: */
}
/* Do Test (8) again */
if (! nobal) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
if (scale[j] != scale1[j]) {
result[8] = ulpinv;
}
/* L120: */
}
if (ilo != ilo1) {
result[8] = ulpinv;
}
if (ihi != ihi1) {
result[8] = ulpinv;
}
if (abnrm != abnrm1) {
result[8] = ulpinv;
}
}
/* Do Test (9) again */
if (isens == 2 && *n > 1) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
if (rcondv[j] != rcndv1[j]) {
result[9] = ulpinv;
}
/* L130: */
}
}
/* Compute eigenvalues and left eigenvectors, and test them */
zlacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda);
zgeevx_(balanc, "V", "N", sense, n, &h__[h_offset], lda, &w1[1], &lre[
lre_offset], ldlre, cdum, &c__1, &ilo1, &ihi1, &scale1[1], &
abnrm1, &rcnde1[1], &rcndv1[1], &work[1], lwork, &rwork[1], &
iinfo);
if (iinfo != 0) {
result[1] = ulpinv;
if (*jtype != 22) {
io___32.ciunit = *nounit;
s_wsfe(&io___32);
do_fio(&c__1, "ZGEEVX4", (ftnlen)7);
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__1, balanc, (ftnlen)1);
do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___33.ciunit = *nounit;
s_wsfe(&io___33);
do_fio(&c__1, "ZGEEVX4", (ftnlen)7);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
e_wsfe();
}
*info = abs(iinfo);
goto L190;
}
/* Do Test (5) again */
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
i__3 = j;
i__4 = j;
if (w[i__3].r != w1[i__4].r || w[i__3].i != w1[i__4].i) {
result[5] = ulpinv;
}
/* L140: */
}
/* Do Test (7) */
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
i__3 = *n;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = vl_subscr(j, jj);
i__5 = lre_subscr(j, jj);
if (vl[i__4].r != lre[i__5].r || vl[i__4].i != lre[i__5].i) {
result[7] = ulpinv;
}
/* L150: */
}
/* L160: */
}
/* Do Test (8) again */
if (! nobal) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
if (scale[j] != scale1[j]) {
result[8] = ulpinv;
}
/* L170: */
}
if (ilo != ilo1) {
result[8] = ulpinv;
}
if (ihi != ihi1) {
result[8] = ulpinv;
}
if (abnrm != abnrm1) {
result[8] = ulpinv;
}
}
/* Do Test (9) again */
if (isens == 2 && *n > 1) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
if (rcondv[j] != rcndv1[j]) {
result[9] = ulpinv;
}
/* L180: */
}
}
L190:
/* L200: */
;
}
/* If COMP, compare condition numbers to precomputed ones */
if (*comp) {
zlacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda);
zgeevx_("N", "V", "V", "B", n, &h__[h_offset], lda, &w[1], &vl[
vl_offset], ldvl, &vr[vr_offset], ldvr, &ilo, &ihi, &scale[1],
&abnrm, &rconde[1], &rcondv[1], &work[1], lwork, &rwork[1], &
iinfo);
if (iinfo != 0) {
result[1] = ulpinv;
io___34.ciunit = *nounit;
s_wsfe(&io___34);
do_fio(&c__1, "ZGEEVX5", (ftnlen)7);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L250;
}
/* Sort eigenvalues and condition numbers lexicographically
to compare with inputs */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
kmin = i__;
if (*isrt == 0) {
i__2 = i__;
vrimin = w[i__2].r;
} else {
vrimin = d_imag(&w[i__]);
}
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
if (*isrt == 0) {
i__3 = j;
vricmp = w[i__3].r;
} else {
vricmp = d_imag(&w[j]);
}
if (vricmp < vrimin) {
kmin = j;
vrimin = vricmp;
}
/* L210: */
}
i__2 = kmin;
ctmp.r = w[i__2].r, ctmp.i = w[i__2].i;
i__2 = kmin;
i__3 = i__;
w[i__2].r = w[i__3].r, w[i__2].i = w[i__3].i;
i__2 = i__;
w[i__2].r = ctmp.r, w[i__2].i = ctmp.i;
vrimin = rconde[kmin];
rconde[kmin] = rconde[i__];
rconde[i__] = vrimin;
vrimin = rcondv[kmin];
rcondv[kmin] = rcondv[i__];
rcondv[i__] = vrimin;
/* L220: */
}
/* Compare condition numbers for eigenvectors
taking their condition numbers into account */
result[10] = 0.;
eps = max(5.9605e-8,ulp);
/* Computing MAX */
d__1 = (doublereal) (*n) * eps * abnrm;
v = max(d__1,smlnum);
if (abnrm == 0.) {
v = 1.;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (v > rcondv[i__] * rconde[i__]) {
tol = rcondv[i__];
} else {
tol = v / rconde[i__];
}
if (v > rcdvin[i__] * rcdein[i__]) {
tolin = rcdvin[i__];
} else {
tolin = v / rcdein[i__];
}
/* Computing MAX */
d__1 = tol, d__2 = smlnum / eps;
tol = max(d__1,d__2);
/* Computing MAX */
d__1 = tolin, d__2 = smlnum / eps;
tolin = max(d__1,d__2);
if (eps * (rcdvin[i__] - tolin) > rcondv[i__] + tol) {
vmax = 1. / eps;
} else if (rcdvin[i__] - tolin > rcondv[i__] + tol) {
vmax = (rcdvin[i__] - tolin) / (rcondv[i__] + tol);
} else if (rcdvin[i__] + tolin < eps * (rcondv[i__] - tol)) {
vmax = 1. / eps;
} else if (rcdvin[i__] + tolin < rcondv[i__] - tol) {
vmax = (rcondv[i__] - tol) / (rcdvin[i__] + tolin);
} else {
vmax = 1.;
}
result[10] = max(result[10],vmax);
/* L230: */
}
/* Compare condition numbers for eigenvalues
taking their condition numbers into account */
result[11] = 0.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (v > rcondv[i__]) {
tol = 1.;
} else {
tol = v / rcondv[i__];
}
if (v > rcdvin[i__]) {
tolin = 1.;
} else {
tolin = v / rcdvin[i__];
}
/* Computing MAX */
d__1 = tol, d__2 = smlnum / eps;
tol = max(d__1,d__2);
/* Computing MAX */
d__1 = tolin, d__2 = smlnum / eps;
tolin = max(d__1,d__2);
if (eps * (rcdein[i__] - tolin) > rconde[i__] + tol) {
vmax = 1. / eps;
} else if (rcdein[i__] - tolin > rconde[i__] + tol) {
vmax = (rcdein[i__] - tolin) / (rconde[i__] + tol);
} else if (rcdein[i__] + tolin < eps * (rconde[i__] - tol)) {
vmax = 1. / eps;
} else if (rcdein[i__] + tolin < rconde[i__] - tol) {
vmax = (rconde[i__] - tol) / (rcdein[i__] + tolin);
} else {
vmax = 1.;
}
result[11] = max(result[11],vmax);
/* L240: */
}
L250:
;
}
return 0;
/* End of ZGET23 */
} /* zget23_ */
/* Subroutine */ int cggev_(char *jobvl, char *jobvr, integer *n, complex *a,
integer *lda, complex *b, integer *ldb, complex *alpha, complex *beta,
complex *vl, integer *ldvl, complex *vr, integer *ldvr, complex *
work, integer *lwork, real *rwork, integer *info)
{
/* -- LAPACK driver 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
=======
CGGEV computes for a pair of N-by-N complex nonsymmetric matrices
(A,B), the generalized eigenvalues, and optionally, the left and/or
right generalized eigenvectors.
A generalized eigenvalue for a pair of matrices (A,B) is a scalar
lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
singular. It is usually represented as the pair (alpha,beta), as
there is a reasonable interpretation for beta=0, and even for both
being zero.
The right generalized eigenvector v(j) corresponding to the
generalized eigenvalue lambda(j) of (A,B) satisfies
A * v(j) = lambda(j) * B * v(j).
The left generalized eigenvector u(j) corresponding to the
generalized eigenvalues lambda(j) of (A,B) satisfies
u(j)**H * A = lambda(j) * u(j)**H * B
where u(j)**H is the conjugate-transpose of u(j).
Arguments
=========
JOBVL (input) CHARACTER*1
= 'N': do not compute the left generalized eigenvectors;
= 'V': compute the left generalized eigenvectors.
JOBVR (input) CHARACTER*1
= 'N': do not compute the right generalized eigenvectors;
= 'V': compute the right generalized eigenvectors.
N (input) INTEGER
The order of the matrices A, B, VL, and VR. N >= 0.
A (input/output) COMPLEX array, dimension (LDA, N)
On entry, the matrix A in the pair (A,B).
On exit, A has been overwritten.
LDA (input) INTEGER
The leading dimension of A. LDA >= max(1,N).
B (input/output) COMPLEX array, dimension (LDB, N)
On entry, the matrix B in the pair (A,B).
On exit, B has been overwritten.
LDB (input) INTEGER
The leading dimension of B. LDB >= max(1,N).
ALPHA (output) COMPLEX array, dimension (N)
BETA (output) COMPLEX array, dimension (N)
On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the
generalized eigenvalues.
Note: the quotients ALPHA(j)/BETA(j) may easily over- or
underflow, and BETA(j) may even be zero. Thus, the user
should avoid naively computing the ratio alpha/beta.
However, ALPHA will be always less than and usually
comparable with norm(A) in magnitude, and BETA always less
than and usually comparable with norm(B).
VL (output) COMPLEX array, dimension (LDVL,N)
If JOBVL = 'V', the left generalized eigenvectors u(j) are
stored one after another in the columns of VL, in the same
order as their eigenvalues.
Each eigenvector will be scaled so the largest component
will have abs(real part) + abs(imag. part) = 1.
Not referenced if JOBVL = 'N'.
LDVL (input) INTEGER
The leading dimension of the matrix VL. LDVL >= 1, and
if JOBVL = 'V', LDVL >= N.
VR (output) COMPLEX array, dimension (LDVR,N)
If JOBVR = 'V', the right generalized eigenvectors v(j) are
stored one after another in the columns of VR, in the same
order as their eigenvalues.
Each eigenvector will be scaled so the largest component
will have abs(real part) + abs(imag. part) = 1.
Not referenced if JOBVR = 'N'.
LDVR (input) INTEGER
The leading dimension of the matrix VR. LDVR >= 1, and
if JOBVR = 'V', LDVR >= N.
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,2*N).
For good performance, LWORK must generally be larger.
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.
RWORK (workspace/output) REAL array, dimension (8*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
=1,...,N:
The QZ iteration failed. No eigenvectors have been
calculated, but ALPHA(j) and BETA(j) should be
correct for j=INFO+1,...,N.
> N: =N+1: other then QZ iteration failed in SHGEQZ,
=N+2: error return from STGEVC.
=====================================================================
Decode the input arguments
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {0.f,0.f};
static complex c_b2 = {1.f,0.f};
static integer c__1 = 1;
static integer c__0 = 0;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
vr_offset, i__1, i__2, i__3, i__4;
real r__1, r__2, r__3, r__4;
complex q__1;
/* Builtin functions */
double sqrt(doublereal), r_imag(complex *);
/* Local variables */
static real anrm, bnrm;
static integer ierr, itau;
static real temp;
static logical ilvl, ilvr;
static integer iwrk;
extern logical lsame_(char *, char *);
static integer ileft, icols, irwrk, irows, jc;
extern /* Subroutine */ int cggbak_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, complex *, integer *,
integer *), cggbal_(char *, integer *, complex *,
integer *, complex *, integer *, integer *, integer *, real *,
real *, real *, integer *), slabad_(real *, real *);
static integer in;
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *);
static integer jr;
extern /* Subroutine */ int cgghrd_(char *, char *, integer *, integer *,
integer *, complex *, integer *, complex *, integer *, complex *,
integer *, complex *, integer *, integer *),
clascl_(char *, integer *, integer *, real *, real *, integer *,
integer *, complex *, integer *, integer *);
static logical ilascl, ilbscl;
extern /* Subroutine */ int cgeqrf_(integer *, integer *, complex *,
integer *, complex *, complex *, integer *, integer *), clacpy_(
char *, integer *, integer *, complex *, integer *, complex *,
integer *), claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *), ctgevc_(char *, char
*, logical *, integer *, complex *, integer *, complex *, integer
*, complex *, integer *, complex *, integer *, integer *, integer
*, complex *, real *, integer *), xerbla_(char *,
integer *);
static logical ldumma[1];
static char chtemp[1];
static real bignum;
extern /* Subroutine */ int chgeqz_(char *, char *, char *, integer *,
integer *, integer *, complex *, integer *, complex *, integer *,
complex *, complex *, complex *, integer *, complex *, integer *,
complex *, integer *, real *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern doublereal slamch_(char *);
static integer ijobvl, iright, ijobvr;
extern /* Subroutine */ int cungqr_(integer *, integer *, integer *,
complex *, integer *, complex *, complex *, integer *, integer *);
static real anrmto;
static integer lwkmin;
static real bnrmto;
extern /* Subroutine */ int cunmqr_(char *, char *, integer *, integer *,
integer *, complex *, integer *, complex *, complex *, integer *,
complex *, integer *, integer *);
static real smlnum;
static integer lwkopt;
static logical lquery;
static integer ihi, ilo;
static real eps;
static logical ilv;
#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 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 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)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--alpha;
--beta;
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;
/* Function Body */
if (lsame_(jobvl, "N")) {
ijobvl = 1;
ilvl = FALSE_;
} else if (lsame_(jobvl, "V")) {
ijobvl = 2;
ilvl = TRUE_;
} else {
ijobvl = -1;
ilvl = FALSE_;
}
if (lsame_(jobvr, "N")) {
ijobvr = 1;
ilvr = FALSE_;
} else if (lsame_(jobvr, "V")) {
ijobvr = 2;
ilvr = TRUE_;
} else {
ijobvr = -1;
ilvr = FALSE_;
}
ilv = ilvl || ilvr;
/* Test the input arguments */
*info = 0;
lquery = *lwork == -1;
if (ijobvl <= 0) {
*info = -1;
} else if (ijobvr <= 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -7;
} else if (*ldvl < 1 || ilvl && *ldvl < *n) {
*info = -11;
} else if (*ldvr < 1 || ilvr && *ldvr < *n) {
*info = -13;
}
/* Compute workspace
(Note: Comments in the code beginning "Workspace:" describe the
minimal amount of workspace needed at that point in the code,
as well as the preferred amount for good performance.
NB refers to the optimal block size for the immediately
following subroutine, as returned by ILAENV. The workspace is
computed assuming ILO = 1 and IHI = N, the worst case.) */
lwkmin = 1;
if (*info == 0 && (*lwork >= 1 || lquery)) {
lwkopt = *n + *n * ilaenv_(&c__1, "CGEQRF", " ", n, &c__1, n, &c__0, (
ftnlen)6, (ftnlen)1);
/* Computing MAX */
i__1 = 1, i__2 = *n << 1;
lwkmin = max(i__1,i__2);
work[1].r = (real) lwkopt, work[1].i = 0.f;
}
if (*lwork < lwkmin && ! lquery) {
*info = -15;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGGEV ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
work[1].r = (real) lwkopt, work[1].i = 0.f;
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = slamch_("E") * slamch_("B");
smlnum = slamch_("S");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1.f / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = clange_("M", n, n, &a[a_offset], lda, &rwork[1]);
ilascl = FALSE_;
if (anrm > 0.f && anrm < smlnum) {
anrmto = smlnum;
ilascl = TRUE_;
} else if (anrm > bignum) {
anrmto = bignum;
ilascl = TRUE_;
}
if (ilascl) {
clascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
ierr);
}
/* Scale B if max element outside range [SMLNUM,BIGNUM] */
bnrm = clange_("M", n, n, &b[b_offset], ldb, &rwork[1]);
ilbscl = FALSE_;
if (bnrm > 0.f && bnrm < smlnum) {
bnrmto = smlnum;
ilbscl = TRUE_;
} else if (bnrm > bignum) {
bnrmto = bignum;
ilbscl = TRUE_;
}
if (ilbscl) {
clascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
ierr);
}
/* Permute the matrices A, B to isolate eigenvalues if possible
(Real Workspace: need 6*N) */
ileft = 1;
iright = *n + 1;
irwrk = iright + *n;
cggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &rwork[
ileft], &rwork[iright], &rwork[irwrk], &ierr);
/* Reduce B to triangular form (QR decomposition of B)
(Complex Workspace: need N, prefer N*NB) */
irows = ihi + 1 - ilo;
if (ilv) {
icols = *n + 1 - ilo;
} else {
icols = irows;
}
itau = 1;
iwrk = itau + irows;
i__1 = *lwork + 1 - iwrk;
cgeqrf_(&irows, &icols, &b_ref(ilo, ilo), ldb, &work[itau], &work[iwrk], &
i__1, &ierr);
/* Apply the orthogonal transformation to matrix A
(Complex Workspace: need N, prefer N*NB) */
i__1 = *lwork + 1 - iwrk;
cunmqr_("L", "C", &irows, &icols, &irows, &b_ref(ilo, ilo), ldb, &work[
itau], &a_ref(ilo, ilo), lda, &work[iwrk], &i__1, &ierr);
/* Initialize VL
(Complex Workspace: need N, prefer N*NB) */
if (ilvl) {
claset_("Full", n, n, &c_b1, &c_b2, &vl[vl_offset], ldvl);
i__1 = irows - 1;
i__2 = irows - 1;
clacpy_("L", &i__1, &i__2, &b_ref(ilo + 1, ilo), ldb, &vl_ref(ilo + 1,
ilo), ldvl);
i__1 = *lwork + 1 - iwrk;
cungqr_(&irows, &irows, &irows, &vl_ref(ilo, ilo), ldvl, &work[itau],
&work[iwrk], &i__1, &ierr);
}
/* Initialize VR */
if (ilvr) {
claset_("Full", n, n, &c_b1, &c_b2, &vr[vr_offset], ldvr);
}
/* Reduce to generalized Hessenberg form */
if (ilv) {
/* Eigenvectors requested -- work on whole matrix. */
cgghrd_(jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ierr);
} else {
cgghrd_("N", "N", &irows, &c__1, &irows, &a_ref(ilo, ilo), lda, &
b_ref(ilo, ilo), ldb, &vl[vl_offset], ldvl, &vr[vr_offset],
ldvr, &ierr);
}
/* Perform QZ algorithm (Compute eigenvalues, and optionally, the
Schur form and Schur vectors)
(Complex Workspace: need N)
(Real Workspace: need N) */
iwrk = itau;
if (ilv) {
*(unsigned char *)chtemp = 'S';
} else {
*(unsigned char *)chtemp = 'E';
}
i__1 = *lwork + 1 - iwrk;
chgeqz_(chtemp, jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[
b_offset], ldb, &alpha[1], &beta[1], &vl[vl_offset], ldvl, &vr[
vr_offset], ldvr, &work[iwrk], &i__1, &rwork[irwrk], &ierr);
if (ierr != 0) {
if (ierr > 0 && ierr <= *n) {
*info = ierr;
} else if (ierr > *n && ierr <= *n << 1) {
*info = ierr - *n;
} else {
*info = *n + 1;
}
goto L70;
}
/* Compute Eigenvectors
(Real Workspace: need 2*N)
(Complex Workspace: need 2*N) */
if (ilv) {
if (ilvl) {
if (ilvr) {
*(unsigned char *)chtemp = 'B';
} else {
*(unsigned char *)chtemp = 'L';
}
} else {
*(unsigned char *)chtemp = 'R';
}
ctgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], ldb,
&vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &work[
iwrk], &rwork[irwrk], &ierr);
if (ierr != 0) {
*info = *n + 2;
goto L70;
}
/* Undo balancing on VL and VR and normalization
(Workspace: none needed) */
if (ilvl) {
cggbak_("P", "L", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n,
&vl[vl_offset], ldvl, &ierr);
i__1 = *n;
for (jc = 1; jc <= i__1; ++jc) {
temp = 0.f;
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
i__3 = vl_subscr(jr, jc);
r__3 = temp, r__4 = (r__1 = vl[i__3].r, dabs(r__1)) + (
r__2 = r_imag(&vl_ref(jr, jc)), dabs(r__2));
temp = dmax(r__3,r__4);
/* L10: */
}
if (temp < smlnum) {
goto L30;
}
temp = 1.f / temp;
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
i__3 = vl_subscr(jr, jc);
i__4 = vl_subscr(jr, jc);
q__1.r = temp * vl[i__4].r, q__1.i = temp * vl[i__4].i;
vl[i__3].r = q__1.r, vl[i__3].i = q__1.i;
/* L20: */
}
L30:
;
}
}
if (ilvr) {
cggbak_("P", "R", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n,
&vr[vr_offset], ldvr, &ierr);
i__1 = *n;
for (jc = 1; jc <= i__1; ++jc) {
temp = 0.f;
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
i__3 = vr_subscr(jr, jc);
r__3 = temp, r__4 = (r__1 = vr[i__3].r, dabs(r__1)) + (
r__2 = r_imag(&vr_ref(jr, jc)), dabs(r__2));
temp = dmax(r__3,r__4);
/* L40: */
}
if (temp < smlnum) {
goto L60;
}
temp = 1.f / temp;
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
i__3 = vr_subscr(jr, jc);
i__4 = vr_subscr(jr, jc);
q__1.r = temp * vr[i__4].r, q__1.i = temp * vr[i__4].i;
vr[i__3].r = q__1.r, vr[i__3].i = q__1.i;
/* L50: */
}
L60:
;
}
}
}
/* Undo scaling if necessary */
if (ilascl) {
clascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alpha[1], n, &
ierr);
}
if (ilbscl) {
clascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
ierr);
}
L70:
work[1].r = (real) lwkopt, work[1].i = 0.f;
return 0;
/* End of CGGEV */
} /* cggev_ */
/* Subroutine */ int ctgevc_(char *side, char *howmny, logical *select,
integer *n, complex *a, integer *lda, complex *b, integer *ldb,
complex *vl, integer *ldvl, complex *vr, integer *ldvr, integer *mm,
integer *m, complex *work, real *rwork, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
CTGEVC computes some or all of the right and/or left generalized
eigenvectors of a pair of complex upper triangular matrices (A,B).
The right generalized eigenvector x and the left generalized
eigenvector y of (A,B) corresponding to a generalized eigenvalue
w are defined by:
(A - wB) * x = 0 and y**H * (A - wB) = 0
where y**H denotes the conjugate tranpose of y.
If an eigenvalue w is determined by zero diagonal elements of both A
and B, a unit vector is returned as the corresponding eigenvector.
If all eigenvectors are requested, the routine may either return
the matrices X and/or Y of right or left eigenvectors of (A,B), or
the products Z*X and/or Q*Y, where Z and Q are input unitary
matrices. If (A,B) was obtained from the generalized Schur
factorization of an original pair of matrices
(A0,B0) = (Q*A*Z**H,Q*B*Z**H),
then Z*X and Q*Y are the matrices of right or left eigenvectors of
A.
Arguments
=========
SIDE (input) CHARACTER*1
= 'R': compute right eigenvectors only;
= 'L': compute left eigenvectors only;
= 'B': compute both right and left eigenvectors.
HOWMNY (input) CHARACTER*1
= 'A': compute all right and/or left eigenvectors;
= 'B': compute all right and/or left eigenvectors, and
backtransform them using the input matrices supplied
in VR and/or VL;
= 'S': compute selected right and/or left eigenvectors,
specified by the logical array SELECT.
SELECT (input) LOGICAL array, dimension (N)
If HOWMNY='S', SELECT specifies the eigenvectors to be
computed.
If HOWMNY='A' or 'B', SELECT is not referenced.
To select the eigenvector corresponding to the j-th
eigenvalue, SELECT(j) must be set to .TRUE..
N (input) INTEGER
The order of the matrices A and B. N >= 0.
A (input) COMPLEX array, dimension (LDA,N)
The upper triangular matrix A.
LDA (input) INTEGER
The leading dimension of array A. LDA >= max(1,N).
B (input) COMPLEX array, dimension (LDB,N)
The upper triangular matrix B. B must have real diagonal
elements.
LDB (input) INTEGER
The leading dimension of array B. LDB >= max(1,N).
VL (input/output) COMPLEX array, dimension (LDVL,MM)
On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
contain an N-by-N matrix Q (usually the unitary matrix Q
of left Schur vectors returned by CHGEQZ).
On exit, if SIDE = 'L' or 'B', VL contains:
if HOWMNY = 'A', the matrix Y of left eigenvectors of (A,B);
if HOWMNY = 'B', the matrix Q*Y;
if HOWMNY = 'S', the left eigenvectors of (A,B) specified by
SELECT, 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 array VL.
LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
VR (input/output) COMPLEX array, dimension (LDVR,MM)
On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
contain an N-by-N matrix Q (usually the unitary matrix Z
of right Schur vectors returned by CHGEQZ).
On exit, if SIDE = 'R' or 'B', VR contains:
if HOWMNY = 'A', the matrix X of right eigenvectors of (A,B);
if HOWMNY = 'B', the matrix Z*X;
if HOWMNY = 'S', the right eigenvectors of (A,B) specified by
SELECT, 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 actually
used to store the eigenvectors. If HOWMNY = 'A' or 'B', M
is set to N. Each selected eigenvector occupies one column.
WORK (workspace) COMPLEX array, dimension (2*N)
RWORK (workspace) REAL array, dimension (2*N)
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
=====================================================================
Decode and Test the input parameters
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {0.f,0.f};
static complex c_b2 = {1.f,0.f};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
vr_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4, r__5, r__6;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
static integer ibeg, ieig, iend;
static real dmin__;
static integer isrc;
static real temp;
static complex suma, sumb;
static real xmax;
static complex d__;
static integer i__, j;
static real scale;
static logical ilall;
static integer iside;
static real sbeta;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *);
static real small;
static logical compl;
static real anorm, bnorm;
static logical compr;
static complex ca, cb;
static logical ilbbad;
static real acoefa;
static integer je;
static real bcoefa, acoeff;
static complex bcoeff;
static logical ilback;
static integer im;
extern /* Subroutine */ int slabad_(real *, real *);
static real ascale, bscale;
static integer jr;
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
extern doublereal slamch_(char *);
static complex salpha;
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static real bignum;
static logical ilcomp;
static integer ihwmny;
static real big;
static logical lsa, lsb;
static real ulp;
static complex sum;
#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 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 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;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
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;
/* Function Body */
if (lsame_(howmny, "A")) {
ihwmny = 1;
ilall = TRUE_;
ilback = FALSE_;
} else if (lsame_(howmny, "S")) {
ihwmny = 2;
ilall = FALSE_;
ilback = FALSE_;
} else if (lsame_(howmny, "B") || lsame_(howmny,
"T")) {
ihwmny = 3;
ilall = TRUE_;
ilback = TRUE_;
} else {
ihwmny = -1;
}
if (lsame_(side, "R")) {
iside = 1;
compl = FALSE_;
compr = TRUE_;
} else if (lsame_(side, "L")) {
iside = 2;
compl = TRUE_;
compr = FALSE_;
} else if (lsame_(side, "B")) {
iside = 3;
compl = TRUE_;
compr = TRUE_;
} else {
iside = -1;
}
*info = 0;
if (iside < 0) {
*info = -1;
} else if (ihwmny < 0) {
*info = -2;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldb < max(1,*n)) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTGEVC", &i__1);
return 0;
}
/* Count the number of eigenvectors */
if (! ilall) {
im = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (select[j]) {
++im;
}
/* L10: */
}
} else {
im = *n;
}
/* Check diagonal of B */
ilbbad = FALSE_;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (r_imag(&b_ref(j, j)) != 0.f) {
ilbbad = TRUE_;
}
/* L20: */
}
if (ilbbad) {
*info = -7;
} else if (compl && *ldvl < *n || *ldvl < 1) {
*info = -10;
} else if (compr && *ldvr < *n || *ldvr < 1) {
*info = -12;
} else if (*mm < im) {
*info = -13;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTGEVC", &i__1);
return 0;
}
/* Quick return if possible */
*m = im;
if (*n == 0) {
return 0;
}
/* Machine Constants */
safmin = slamch_("Safe minimum");
big = 1.f / safmin;
slabad_(&safmin, &big);
ulp = slamch_("Epsilon") * slamch_("Base");
small = safmin * *n / ulp;
big = 1.f / small;
bignum = 1.f / (safmin * *n);
/* Compute the 1-norm of each column of the strictly upper triangular
part of A and B to check for possible overflow in the triangular
solver. */
i__1 = a_subscr(1, 1);
anorm = (r__1 = a[i__1].r, dabs(r__1)) + (r__2 = r_imag(&a_ref(1, 1)),
dabs(r__2));
i__1 = b_subscr(1, 1);
bnorm = (r__1 = b[i__1].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(1, 1)),
dabs(r__2));
rwork[1] = 0.f;
rwork[*n + 1] = 0.f;
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
rwork[j] = 0.f;
rwork[*n + j] = 0.f;
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = a_subscr(i__, j);
rwork[j] += (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
a_ref(i__, j)), dabs(r__2));
i__3 = b_subscr(i__, j);
rwork[*n + j] += (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
b_ref(i__, j)), dabs(r__2));
/* L30: */
}
/* Computing MAX */
i__2 = a_subscr(j, j);
r__3 = anorm, r__4 = rwork[j] + ((r__1 = a[i__2].r, dabs(r__1)) + (
r__2 = r_imag(&a_ref(j, j)), dabs(r__2)));
anorm = dmax(r__3,r__4);
/* Computing MAX */
i__2 = b_subscr(j, j);
r__3 = bnorm, r__4 = rwork[*n + j] + ((r__1 = b[i__2].r, dabs(r__1))
+ (r__2 = r_imag(&b_ref(j, j)), dabs(r__2)));
bnorm = dmax(r__3,r__4);
/* L40: */
}
ascale = 1.f / dmax(anorm,safmin);
bscale = 1.f / dmax(bnorm,safmin);
/* Left eigenvectors */
if (compl) {
ieig = 0;
/* Main loop over eigenvalues */
i__1 = *n;
for (je = 1; je <= i__1; ++je) {
if (ilall) {
ilcomp = TRUE_;
} else {
ilcomp = select[je];
}
if (ilcomp) {
++ieig;
i__2 = a_subscr(je, je);
i__3 = b_subscr(je, je);
if ((r__2 = a[i__2].r, dabs(r__2)) + (r__3 = r_imag(&a_ref(je,
je)), dabs(r__3)) <= safmin && (r__1 = b[i__3].r,
dabs(r__1)) <= safmin) {
/* Singular matrix pencil -- return unit eigenvector */
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
i__3 = vl_subscr(jr, ieig);
vl[i__3].r = 0.f, vl[i__3].i = 0.f;
/* L50: */
}
i__2 = vl_subscr(ieig, ieig);
vl[i__2].r = 1.f, vl[i__2].i = 0.f;
goto L140;
}
/* Non-singular eigenvalue:
Compute coefficients a and b in
H
y ( a A - b B ) = 0
Computing MAX */
i__2 = a_subscr(je, je);
i__3 = b_subscr(je, je);
r__4 = ((r__2 = a[i__2].r, dabs(r__2)) + (r__3 = r_imag(&
a_ref(je, je)), dabs(r__3))) * ascale, r__5 = (r__1 =
b[i__3].r, dabs(r__1)) * bscale, r__4 = max(r__4,r__5)
;
temp = 1.f / dmax(r__4,safmin);
i__2 = a_subscr(je, je);
q__2.r = temp * a[i__2].r, q__2.i = temp * a[i__2].i;
q__1.r = ascale * q__2.r, q__1.i = ascale * q__2.i;
salpha.r = q__1.r, salpha.i = q__1.i;
i__2 = b_subscr(je, je);
sbeta = temp * b[i__2].r * bscale;
acoeff = sbeta * ascale;
q__1.r = bscale * salpha.r, q__1.i = bscale * salpha.i;
bcoeff.r = q__1.r, bcoeff.i = q__1.i;
/* Scale to avoid underflow */
lsa = dabs(sbeta) >= safmin && dabs(acoeff) < small;
lsb = (r__1 = salpha.r, dabs(r__1)) + (r__2 = r_imag(&salpha),
dabs(r__2)) >= safmin && (r__3 = bcoeff.r, dabs(r__3)
) + (r__4 = r_imag(&bcoeff), dabs(r__4)) < small;
scale = 1.f;
if (lsa) {
scale = small / dabs(sbeta) * dmin(anorm,big);
}
if (lsb) {
/* Computing MAX */
r__3 = scale, r__4 = small / ((r__1 = salpha.r, dabs(r__1)
) + (r__2 = r_imag(&salpha), dabs(r__2))) * dmin(
bnorm,big);
scale = dmax(r__3,r__4);
}
if (lsa || lsb) {
/* Computing MIN
Computing MAX */
r__5 = 1.f, r__6 = dabs(acoeff), r__5 = max(r__5,r__6),
r__6 = (r__1 = bcoeff.r, dabs(r__1)) + (r__2 =
r_imag(&bcoeff), dabs(r__2));
r__3 = scale, r__4 = 1.f / (safmin * dmax(r__5,r__6));
scale = dmin(r__3,r__4);
if (lsa) {
acoeff = ascale * (scale * sbeta);
} else {
acoeff = scale * acoeff;
}
if (lsb) {
q__2.r = scale * salpha.r, q__2.i = scale * salpha.i;
q__1.r = bscale * q__2.r, q__1.i = bscale * q__2.i;
bcoeff.r = q__1.r, bcoeff.i = q__1.i;
} else {
q__1.r = scale * bcoeff.r, q__1.i = scale * bcoeff.i;
bcoeff.r = q__1.r, bcoeff.i = q__1.i;
}
}
acoefa = dabs(acoeff);
bcoefa = (r__1 = bcoeff.r, dabs(r__1)) + (r__2 = r_imag(&
bcoeff), dabs(r__2));
xmax = 1.f;
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
i__3 = jr;
work[i__3].r = 0.f, work[i__3].i = 0.f;
/* L60: */
}
i__2 = je;
work[i__2].r = 1.f, work[i__2].i = 0.f;
/* Computing MAX */
r__1 = ulp * acoefa * anorm, r__2 = ulp * bcoefa * bnorm,
r__1 = max(r__1,r__2);
dmin__ = dmax(r__1,safmin);
/* H
Triangular solve of (a A - b B) y = 0
H
(rowwise in (a A - b B) , or columnwise in a A - b B) */
i__2 = *n;
for (j = je + 1; j <= i__2; ++j) {
/* Compute
j-1
SUM = sum conjg( a*A(k,j) - b*B(k,j) )*x(k)
k=je
(Scale if necessary) */
temp = 1.f / xmax;
if (acoefa * rwork[j] + bcoefa * rwork[*n + j] > bignum *
temp) {
i__3 = j - 1;
for (jr = je; jr <= i__3; ++jr) {
i__4 = jr;
i__5 = jr;
q__1.r = temp * work[i__5].r, q__1.i = temp *
work[i__5].i;
work[i__4].r = q__1.r, work[i__4].i = q__1.i;
/* L70: */
}
xmax = 1.f;
}
suma.r = 0.f, suma.i = 0.f;
sumb.r = 0.f, sumb.i = 0.f;
i__3 = j - 1;
for (jr = je; jr <= i__3; ++jr) {
r_cnjg(&q__3, &a_ref(jr, j));
i__4 = jr;
q__2.r = q__3.r * work[i__4].r - q__3.i * work[i__4]
.i, q__2.i = q__3.r * work[i__4].i + q__3.i *
work[i__4].r;
q__1.r = suma.r + q__2.r, q__1.i = suma.i + q__2.i;
suma.r = q__1.r, suma.i = q__1.i;
r_cnjg(&q__3, &b_ref(jr, j));
i__4 = jr;
q__2.r = q__3.r * work[i__4].r - q__3.i * work[i__4]
.i, q__2.i = q__3.r * work[i__4].i + q__3.i *
work[i__4].r;
q__1.r = sumb.r + q__2.r, q__1.i = sumb.i + q__2.i;
sumb.r = q__1.r, sumb.i = q__1.i;
/* L80: */
}
q__2.r = acoeff * suma.r, q__2.i = acoeff * suma.i;
r_cnjg(&q__4, &bcoeff);
q__3.r = q__4.r * sumb.r - q__4.i * sumb.i, q__3.i =
q__4.r * sumb.i + q__4.i * sumb.r;
q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
sum.r = q__1.r, sum.i = q__1.i;
/* Form x(j) = - SUM / conjg( a*A(j,j) - b*B(j,j) )
with scaling and perturbation of the denominator */
i__3 = a_subscr(j, j);
q__3.r = acoeff * a[i__3].r, q__3.i = acoeff * a[i__3].i;
i__4 = b_subscr(j, j);
q__4.r = bcoeff.r * b[i__4].r - bcoeff.i * b[i__4].i,
q__4.i = bcoeff.r * b[i__4].i + bcoeff.i * b[i__4]
.r;
q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i;
r_cnjg(&q__1, &q__2);
d__.r = q__1.r, d__.i = q__1.i;
if ((r__1 = d__.r, dabs(r__1)) + (r__2 = r_imag(&d__),
dabs(r__2)) <= dmin__) {
q__1.r = dmin__, q__1.i = 0.f;
d__.r = q__1.r, d__.i = q__1.i;
}
if ((r__1 = d__.r, dabs(r__1)) + (r__2 = r_imag(&d__),
dabs(r__2)) < 1.f) {
if ((r__1 = sum.r, dabs(r__1)) + (r__2 = r_imag(&sum),
dabs(r__2)) >= bignum * ((r__3 = d__.r, dabs(
r__3)) + (r__4 = r_imag(&d__), dabs(r__4)))) {
temp = 1.f / ((r__1 = sum.r, dabs(r__1)) + (r__2 =
r_imag(&sum), dabs(r__2)));
i__3 = j - 1;
for (jr = je; jr <= i__3; ++jr) {
i__4 = jr;
i__5 = jr;
q__1.r = temp * work[i__5].r, q__1.i = temp *
work[i__5].i;
work[i__4].r = q__1.r, work[i__4].i = q__1.i;
/* L90: */
}
xmax = temp * xmax;
q__1.r = temp * sum.r, q__1.i = temp * sum.i;
sum.r = q__1.r, sum.i = q__1.i;
}
}
i__3 = j;
q__2.r = -sum.r, q__2.i = -sum.i;
cladiv_(&q__1, &q__2, &d__);
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* Computing MAX */
i__3 = j;
r__3 = xmax, r__4 = (r__1 = work[i__3].r, dabs(r__1)) + (
r__2 = r_imag(&work[j]), dabs(r__2));
xmax = dmax(r__3,r__4);
/* L100: */
}
/* Back transform eigenvector if HOWMNY='B'. */
if (ilback) {
i__2 = *n + 1 - je;
cgemv_("N", n, &i__2, &c_b2, &vl_ref(1, je), ldvl, &work[
je], &c__1, &c_b1, &work[*n + 1], &c__1);
isrc = 2;
ibeg = 1;
} else {
isrc = 1;
ibeg = je;
}
/* Copy and scale eigenvector into column of VL */
xmax = 0.f;
i__2 = *n;
for (jr = ibeg; jr <= i__2; ++jr) {
/* Computing MAX */
i__3 = (isrc - 1) * *n + jr;
r__3 = xmax, r__4 = (r__1 = work[i__3].r, dabs(r__1)) + (
r__2 = r_imag(&work[(isrc - 1) * *n + jr]), dabs(
r__2));
xmax = dmax(r__3,r__4);
/* L110: */
}
if (xmax > safmin) {
temp = 1.f / xmax;
i__2 = *n;
for (jr = ibeg; jr <= i__2; ++jr) {
i__3 = vl_subscr(jr, ieig);
i__4 = (isrc - 1) * *n + jr;
q__1.r = temp * work[i__4].r, q__1.i = temp * work[
i__4].i;
vl[i__3].r = q__1.r, vl[i__3].i = q__1.i;
/* L120: */
}
} else {
ibeg = *n + 1;
}
i__2 = ibeg - 1;
for (jr = 1; jr <= i__2; ++jr) {
i__3 = vl_subscr(jr, ieig);
vl[i__3].r = 0.f, vl[i__3].i = 0.f;
/* L130: */
}
}
L140:
;
}
}
/* Right eigenvectors */
if (compr) {
ieig = im + 1;
/* Main loop over eigenvalues */
for (je = *n; je >= 1; --je) {
if (ilall) {
ilcomp = TRUE_;
} else {
ilcomp = select[je];
}
if (ilcomp) {
--ieig;
i__1 = a_subscr(je, je);
i__2 = b_subscr(je, je);
if ((r__2 = a[i__1].r, dabs(r__2)) + (r__3 = r_imag(&a_ref(je,
je)), dabs(r__3)) <= safmin && (r__1 = b[i__2].r,
dabs(r__1)) <= safmin) {
/* Singular matrix pencil -- return unit eigenvector */
i__1 = *n;
for (jr = 1; jr <= i__1; ++jr) {
i__2 = vr_subscr(jr, ieig);
vr[i__2].r = 0.f, vr[i__2].i = 0.f;
/* L150: */
}
i__1 = vr_subscr(ieig, ieig);
vr[i__1].r = 1.f, vr[i__1].i = 0.f;
goto L250;
}
/* Non-singular eigenvalue:
Compute coefficients a and b in
( a A - b B ) x = 0
Computing MAX */
i__1 = a_subscr(je, je);
i__2 = b_subscr(je, je);
r__4 = ((r__2 = a[i__1].r, dabs(r__2)) + (r__3 = r_imag(&
a_ref(je, je)), dabs(r__3))) * ascale, r__5 = (r__1 =
b[i__2].r, dabs(r__1)) * bscale, r__4 = max(r__4,r__5)
;
temp = 1.f / dmax(r__4,safmin);
i__1 = a_subscr(je, je);
q__2.r = temp * a[i__1].r, q__2.i = temp * a[i__1].i;
q__1.r = ascale * q__2.r, q__1.i = ascale * q__2.i;
salpha.r = q__1.r, salpha.i = q__1.i;
i__1 = b_subscr(je, je);
sbeta = temp * b[i__1].r * bscale;
acoeff = sbeta * ascale;
q__1.r = bscale * salpha.r, q__1.i = bscale * salpha.i;
bcoeff.r = q__1.r, bcoeff.i = q__1.i;
/* Scale to avoid underflow */
lsa = dabs(sbeta) >= safmin && dabs(acoeff) < small;
lsb = (r__1 = salpha.r, dabs(r__1)) + (r__2 = r_imag(&salpha),
dabs(r__2)) >= safmin && (r__3 = bcoeff.r, dabs(r__3)
) + (r__4 = r_imag(&bcoeff), dabs(r__4)) < small;
scale = 1.f;
if (lsa) {
scale = small / dabs(sbeta) * dmin(anorm,big);
}
if (lsb) {
/* Computing MAX */
r__3 = scale, r__4 = small / ((r__1 = salpha.r, dabs(r__1)
) + (r__2 = r_imag(&salpha), dabs(r__2))) * dmin(
bnorm,big);
scale = dmax(r__3,r__4);
}
if (lsa || lsb) {
/* Computing MIN
Computing MAX */
r__5 = 1.f, r__6 = dabs(acoeff), r__5 = max(r__5,r__6),
r__6 = (r__1 = bcoeff.r, dabs(r__1)) + (r__2 =
r_imag(&bcoeff), dabs(r__2));
r__3 = scale, r__4 = 1.f / (safmin * dmax(r__5,r__6));
scale = dmin(r__3,r__4);
if (lsa) {
acoeff = ascale * (scale * sbeta);
} else {
acoeff = scale * acoeff;
}
if (lsb) {
q__2.r = scale * salpha.r, q__2.i = scale * salpha.i;
q__1.r = bscale * q__2.r, q__1.i = bscale * q__2.i;
bcoeff.r = q__1.r, bcoeff.i = q__1.i;
} else {
q__1.r = scale * bcoeff.r, q__1.i = scale * bcoeff.i;
bcoeff.r = q__1.r, bcoeff.i = q__1.i;
}
}
acoefa = dabs(acoeff);
bcoefa = (r__1 = bcoeff.r, dabs(r__1)) + (r__2 = r_imag(&
bcoeff), dabs(r__2));
xmax = 1.f;
i__1 = *n;
for (jr = 1; jr <= i__1; ++jr) {
i__2 = jr;
work[i__2].r = 0.f, work[i__2].i = 0.f;
/* L160: */
}
i__1 = je;
work[i__1].r = 1.f, work[i__1].i = 0.f;
/* Computing MAX */
r__1 = ulp * acoefa * anorm, r__2 = ulp * bcoefa * bnorm,
r__1 = max(r__1,r__2);
dmin__ = dmax(r__1,safmin);
/* Triangular solve of (a A - b B) x = 0 (columnwise)
WORK(1:j-1) contains sums w,
WORK(j+1:JE) contains x */
i__1 = je - 1;
for (jr = 1; jr <= i__1; ++jr) {
i__2 = jr;
i__3 = a_subscr(jr, je);
q__2.r = acoeff * a[i__3].r, q__2.i = acoeff * a[i__3].i;
i__4 = b_subscr(jr, je);
q__3.r = bcoeff.r * b[i__4].r - bcoeff.i * b[i__4].i,
q__3.i = bcoeff.r * b[i__4].i + bcoeff.i * b[i__4]
.r;
q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L170: */
}
i__1 = je;
work[i__1].r = 1.f, work[i__1].i = 0.f;
for (j = je - 1; j >= 1; --j) {
/* Form x(j) := - w(j) / d
with scaling and perturbation of the denominator */
i__1 = a_subscr(j, j);
q__2.r = acoeff * a[i__1].r, q__2.i = acoeff * a[i__1].i;
i__2 = b_subscr(j, j);
q__3.r = bcoeff.r * b[i__2].r - bcoeff.i * b[i__2].i,
q__3.i = bcoeff.r * b[i__2].i + bcoeff.i * b[i__2]
.r;
q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
d__.r = q__1.r, d__.i = q__1.i;
if ((r__1 = d__.r, dabs(r__1)) + (r__2 = r_imag(&d__),
dabs(r__2)) <= dmin__) {
q__1.r = dmin__, q__1.i = 0.f;
d__.r = q__1.r, d__.i = q__1.i;
}
if ((r__1 = d__.r, dabs(r__1)) + (r__2 = r_imag(&d__),
dabs(r__2)) < 1.f) {
i__1 = j;
if ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 =
r_imag(&work[j]), dabs(r__2)) >= bignum * ((
r__3 = d__.r, dabs(r__3)) + (r__4 = r_imag(&
d__), dabs(r__4)))) {
i__1 = j;
temp = 1.f / ((r__1 = work[i__1].r, dabs(r__1)) +
(r__2 = r_imag(&work[j]), dabs(r__2)));
i__1 = je;
for (jr = 1; jr <= i__1; ++jr) {
i__2 = jr;
i__3 = jr;
q__1.r = temp * work[i__3].r, q__1.i = temp *
work[i__3].i;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L180: */
}
}
}
i__1 = j;
i__2 = j;
q__2.r = -work[i__2].r, q__2.i = -work[i__2].i;
cladiv_(&q__1, &q__2, &d__);
work[i__1].r = q__1.r, work[i__1].i = q__1.i;
if (j > 1) {
/* w = w + x(j)*(a A(*,j) - b B(*,j) ) with scaling */
i__1 = j;
if ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 =
r_imag(&work[j]), dabs(r__2)) > 1.f) {
i__1 = j;
temp = 1.f / ((r__1 = work[i__1].r, dabs(r__1)) +
(r__2 = r_imag(&work[j]), dabs(r__2)));
if (acoefa * rwork[j] + bcoefa * rwork[*n + j] >=
bignum * temp) {
i__1 = je;
for (jr = 1; jr <= i__1; ++jr) {
i__2 = jr;
i__3 = jr;
q__1.r = temp * work[i__3].r, q__1.i =
temp * work[i__3].i;
work[i__2].r = q__1.r, work[i__2].i =
q__1.i;
/* L190: */
}
}
}
i__1 = j;
q__1.r = acoeff * work[i__1].r, q__1.i = acoeff *
work[i__1].i;
ca.r = q__1.r, ca.i = q__1.i;
i__1 = j;
q__1.r = bcoeff.r * work[i__1].r - bcoeff.i * work[
i__1].i, q__1.i = bcoeff.r * work[i__1].i +
bcoeff.i * work[i__1].r;
cb.r = q__1.r, cb.i = q__1.i;
i__1 = j - 1;
for (jr = 1; jr <= i__1; ++jr) {
i__2 = jr;
i__3 = jr;
i__4 = a_subscr(jr, j);
q__3.r = ca.r * a[i__4].r - ca.i * a[i__4].i,
q__3.i = ca.r * a[i__4].i + ca.i * a[i__4]
.r;
q__2.r = work[i__3].r + q__3.r, q__2.i = work[
i__3].i + q__3.i;
i__5 = b_subscr(jr, j);
q__4.r = cb.r * b[i__5].r - cb.i * b[i__5].i,
q__4.i = cb.r * b[i__5].i + cb.i * b[i__5]
.r;
q__1.r = q__2.r - q__4.r, q__1.i = q__2.i -
q__4.i;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L200: */
}
}
/* L210: */
}
/* Back transform eigenvector if HOWMNY='B'. */
if (ilback) {
cgemv_("N", n, &je, &c_b2, &vr[vr_offset], ldvr, &work[1],
&c__1, &c_b1, &work[*n + 1], &c__1);
isrc = 2;
iend = *n;
} else {
isrc = 1;
iend = je;
}
/* Copy and scale eigenvector into column of VR */
xmax = 0.f;
i__1 = iend;
for (jr = 1; jr <= i__1; ++jr) {
/* Computing MAX */
i__2 = (isrc - 1) * *n + jr;
r__3 = xmax, r__4 = (r__1 = work[i__2].r, dabs(r__1)) + (
r__2 = r_imag(&work[(isrc - 1) * *n + jr]), dabs(
r__2));
xmax = dmax(r__3,r__4);
/* L220: */
}
if (xmax > safmin) {
temp = 1.f / xmax;
i__1 = iend;
for (jr = 1; jr <= i__1; ++jr) {
i__2 = vr_subscr(jr, ieig);
i__3 = (isrc - 1) * *n + jr;
q__1.r = temp * work[i__3].r, q__1.i = temp * work[
i__3].i;
vr[i__2].r = q__1.r, vr[i__2].i = q__1.i;
/* L230: */
}
} else {
iend = 0;
}
i__1 = *n;
for (jr = iend + 1; jr <= i__1; ++jr) {
i__2 = vr_subscr(jr, ieig);
vr[i__2].r = 0.f, vr[i__2].i = 0.f;
/* L240: */
}
}
L250:
;
}
}
return 0;
/* End of CTGEVC */
} /* ctgevc_ */
