/* Subroutine */
int ctgevc_(char *side, char *howmny, logical *select, integer *n, complex *s, integer *lds, complex *p, integer *ldp, complex *vl, integer *ldvl, complex *vr, integer *ldvr, integer *mm, integer *m, complex *work, real *rwork, integer *info)
{
/* System generated locals */
integer p_dim1, p_offset, s_dim1, s_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 */
complex d__;
integer i__, j;
complex ca, cb;
integer je, im, jr;
real big;
logical lsa, lsb;
real ulp;
complex sum;
integer ibeg, ieig, iend;
real dmin__;
integer isrc;
real temp;
complex suma, sumb;
real xmax, scale;
logical ilall;
integer iside;
real sbeta;
extern logical lsame_(char *, char *);
extern /* Subroutine */
int cgemv_(char *, integer *, integer *, complex * , complex *, integer *, complex *, integer *, complex *, complex * , integer *);
real small;
logical compl;
real anorm, bnorm;
logical compr, ilbbad;
real acoefa, bcoefa, acoeff;
complex bcoeff;
logical ilback;
extern /* Subroutine */
int slabad_(real *, real *);
real ascale, bscale;
extern /* Complex */
VOID cladiv_(complex *, complex *, complex *);
extern real slamch_(char *);
complex salpha;
real safmin;
extern /* Subroutine */
int xerbla_(char *, integer *);
real bignum;
logical ilcomp;
integer ihwmny;
/* -- LAPACK computational routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and Test the input parameters */
/* Parameter adjustments */
--select;
s_dim1 = *lds;
s_offset = 1 + s_dim1;
s -= s_offset;
p_dim1 = *ldp;
p_offset = 1 + p_dim1;
p -= p_offset;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
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"))
{
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 (*lds < max(1,*n))
{
*info = -6;
}
else if (*ldp < 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(&p[j + j * p_dim1]) != 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 = s_dim1 + 1;
anorm = (r__1 = s[i__1].r, abs(r__1)) + (r__2 = r_imag(&s[s_dim1 + 1]), abs(r__2));
i__1 = p_dim1 + 1;
bnorm = (r__1 = p[i__1].r, abs(r__1)) + (r__2 = r_imag(&p[p_dim1 + 1]), abs(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 = i__ + j * s_dim1;
rwork[j] += (r__1 = s[i__3].r, abs(r__1)) + (r__2 = r_imag(&s[i__ + j * s_dim1]), abs(r__2));
i__3 = i__ + j * p_dim1;
rwork[*n + j] += (r__1 = p[i__3].r, abs(r__1)) + (r__2 = r_imag(& p[i__ + j * p_dim1]), abs(r__2));
/* L30: */
}
/* Computing MAX */
i__2 = j + j * s_dim1;
r__3 = anorm;
r__4 = rwork[j] + ((r__1 = s[i__2].r, abs(r__1)) + ( r__2 = r_imag(&s[j + j * s_dim1]), abs(r__2))); // , expr subst
anorm = max(r__3,r__4);
/* Computing MAX */
i__2 = j + j * p_dim1;
r__3 = bnorm;
r__4 = rwork[*n + j] + ((r__1 = p[i__2].r, abs(r__1)) + (r__2 = r_imag(&p[j + j * p_dim1]), abs(r__2))); // , expr subst
bnorm = max(r__3,r__4);
/* L40: */
}
ascale = 1.f / max(anorm,safmin);
bscale = 1.f / max(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 = je + je * s_dim1;
i__3 = je + je * p_dim1;
if ((r__2 = s[i__2].r, abs(r__2)) + (r__3 = r_imag(&s[je + je * s_dim1]), abs(r__3)) <= safmin && (r__1 = p[i__3].r, abs(r__1)) <= safmin)
{
/* Singular matrix pencil -- return unit eigenvector */
i__2 = *n;
for (jr = 1;
jr <= i__2;
++jr)
{
i__3 = jr + ieig * vl_dim1;
vl[i__3].r = 0.f;
vl[i__3].i = 0.f; // , expr subst
/* L50: */
}
i__2 = ieig + ieig * vl_dim1;
vl[i__2].r = 1.f;
vl[i__2].i = 0.f; // , expr subst
goto L140;
}
/* Non-singular eigenvalue: */
/* Compute coefficients a and b in */
/* H */
/* y ( a A - b B ) = 0 */
/* Computing MAX */
i__2 = je + je * s_dim1;
i__3 = je + je * p_dim1;
r__4 = ((r__2 = s[i__2].r, abs(r__2)) + (r__3 = r_imag(&s[je + je * s_dim1]), abs(r__3))) * ascale;
r__5 = (r__1 = p[i__3].r, abs(r__1)) * bscale;
r__4 = max(r__4,r__5); // ; expr subst
temp = 1.f / max(r__4,safmin);
i__2 = je + je * s_dim1;
q__2.r = temp * s[i__2].r;
q__2.i = temp * s[i__2].i; // , expr subst
q__1.r = ascale * q__2.r;
q__1.i = ascale * q__2.i; // , expr subst
salpha.r = q__1.r;
salpha.i = q__1.i; // , expr subst
i__2 = je + je * p_dim1;
sbeta = temp * p[i__2].r * bscale;
acoeff = sbeta * ascale;
q__1.r = bscale * salpha.r;
q__1.i = bscale * salpha.i; // , expr subst
bcoeff.r = q__1.r;
bcoeff.i = q__1.i; // , expr subst
/* Scale to avoid underflow */
lsa = abs(sbeta) >= safmin && abs(acoeff) < small;
lsb = (r__1 = salpha.r, abs(r__1)) + (r__2 = r_imag(&salpha), abs(r__2)) >= safmin && (r__3 = bcoeff.r, abs(r__3)) + (r__4 = r_imag(&bcoeff), abs(r__4)) < small;
scale = 1.f;
if (lsa)
{
scale = small / abs(sbeta) * min(anorm,big);
}
if (lsb)
{
/* Computing MAX */
r__3 = scale;
r__4 = small / ((r__1 = salpha.r, abs(r__1)) + (r__2 = r_imag(&salpha), abs(r__2))) * min( bnorm,big); // , expr subst
scale = max(r__3,r__4);
}
if (lsa || lsb)
{
/* Computing MIN */
/* Computing MAX */
r__5 = 1.f, r__6 = abs(acoeff);
r__5 = max(r__5,r__6);
r__6 = (r__1 = bcoeff.r, abs(r__1)) + (r__2 = r_imag(&bcoeff), abs(r__2)); // ; expr subst
r__3 = scale;
r__4 = 1.f / (safmin * max(r__5,r__6)); // , expr subst
scale = min(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; // , expr subst
q__1.r = bscale * q__2.r;
q__1.i = bscale * q__2.i; // , expr subst
bcoeff.r = q__1.r;
bcoeff.i = q__1.i; // , expr subst
}
else
{
q__1.r = scale * bcoeff.r;
q__1.i = scale * bcoeff.i; // , expr subst
bcoeff.r = q__1.r;
bcoeff.i = q__1.i; // , expr subst
}
}
acoefa = abs(acoeff);
bcoefa = (r__1 = bcoeff.r, abs(r__1)) + (r__2 = r_imag(& bcoeff), abs(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; // , expr subst
/* L60: */
}
i__2 = je;
work[i__2].r = 1.f;
work[i__2].i = 0.f; // , expr subst
/* Computing MAX */
r__1 = ulp * acoefa * anorm;
r__2 = ulp * bcoefa * bnorm;
r__1 = max(r__1,r__2); // ; expr subst
dmin__ = max(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*S(k,j) - b*P(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; // , expr subst
work[i__4].r = q__1.r;
work[i__4].i = q__1.i; // , expr subst
/* L70: */
}
xmax = 1.f;
}
suma.r = 0.f;
suma.i = 0.f; // , expr subst
sumb.r = 0.f;
sumb.i = 0.f; // , expr subst
i__3 = j - 1;
for (jr = je;
jr <= i__3;
++jr)
{
r_cnjg(&q__3, &s[jr + j * s_dim1]);
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; // , expr subst
q__1.r = suma.r + q__2.r;
q__1.i = suma.i + q__2.i; // , expr subst
suma.r = q__1.r;
suma.i = q__1.i; // , expr subst
r_cnjg(&q__3, &p[jr + j * p_dim1]);
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; // , expr subst
q__1.r = sumb.r + q__2.r;
q__1.i = sumb.i + q__2.i; // , expr subst
sumb.r = q__1.r;
sumb.i = q__1.i; // , expr subst
/* L80: */
}
q__2.r = acoeff * suma.r;
q__2.i = acoeff * suma.i; // , expr subst
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; // , expr subst
q__1.r = q__2.r - q__3.r;
q__1.i = q__2.i - q__3.i; // , expr subst
sum.r = q__1.r;
sum.i = q__1.i; // , expr subst
/* Form x(j) = - SUM / conjg( a*S(j,j) - b*P(j,j) ) */
/* with scaling and perturbation of the denominator */
i__3 = j + j * s_dim1;
q__3.r = acoeff * s[i__3].r;
q__3.i = acoeff * s[i__3].i; // , expr subst
i__4 = j + j * p_dim1;
q__4.r = bcoeff.r * p[i__4].r - bcoeff.i * p[i__4].i;
q__4.i = bcoeff.r * p[i__4].i + bcoeff.i * p[i__4] .r; // , expr subst
q__2.r = q__3.r - q__4.r;
q__2.i = q__3.i - q__4.i; // , expr subst
r_cnjg(&q__1, &q__2);
d__.r = q__1.r;
d__.i = q__1.i; // , expr subst
if ((r__1 = d__.r, abs(r__1)) + (r__2 = r_imag(&d__), abs( r__2)) <= dmin__)
{
q__1.r = dmin__;
q__1.i = 0.f; // , expr subst
d__.r = q__1.r;
d__.i = q__1.i; // , expr subst
}
if ((r__1 = d__.r, abs(r__1)) + (r__2 = r_imag(&d__), abs( r__2)) < 1.f)
{
if ((r__1 = sum.r, abs(r__1)) + (r__2 = r_imag(&sum), abs(r__2)) >= bignum * ((r__3 = d__.r, abs( r__3)) + (r__4 = r_imag(&d__), abs(r__4))))
{
temp = 1.f / ((r__1 = sum.r, abs(r__1)) + (r__2 = r_imag(&sum), abs(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; // , expr subst
work[i__4].r = q__1.r;
work[i__4].i = q__1.i; // , expr subst
/* L90: */
}
xmax = temp * xmax;
q__1.r = temp * sum.r;
q__1.i = temp * sum.i; // , expr subst
sum.r = q__1.r;
sum.i = q__1.i; // , expr subst
}
}
i__3 = j;
q__2.r = -sum.r;
q__2.i = -sum.i; // , expr subst
cladiv_(&q__1, &q__2, &d__);
work[i__3].r = q__1.r;
work[i__3].i = q__1.i; // , expr subst
/* Computing MAX */
i__3 = j;
r__3 = xmax;
r__4 = (r__1 = work[i__3].r, abs(r__1)) + ( r__2 = r_imag(&work[j]), abs(r__2)); // , expr subst
xmax = max(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[je * vl_dim1 + 1], 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, abs(r__1)) + ( r__2 = r_imag(&work[(isrc - 1) * *n + jr]), abs( r__2)); // , expr subst
xmax = max(r__3,r__4);
/* L110: */
}
if (xmax > safmin)
{
temp = 1.f / xmax;
i__2 = *n;
for (jr = ibeg;
jr <= i__2;
++jr)
{
i__3 = jr + ieig * vl_dim1;
i__4 = (isrc - 1) * *n + jr;
q__1.r = temp * work[i__4].r;
q__1.i = temp * work[ i__4].i; // , expr subst
vl[i__3].r = q__1.r;
vl[i__3].i = q__1.i; // , expr subst
/* L120: */
}
}
else
{
ibeg = *n + 1;
}
i__2 = ibeg - 1;
for (jr = 1;
jr <= i__2;
++jr)
{
i__3 = jr + ieig * vl_dim1;
vl[i__3].r = 0.f;
vl[i__3].i = 0.f; // , expr subst
/* 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 = je + je * s_dim1;
i__2 = je + je * p_dim1;
if ((r__2 = s[i__1].r, abs(r__2)) + (r__3 = r_imag(&s[je + je * s_dim1]), abs(r__3)) <= safmin && (r__1 = p[i__2].r, abs(r__1)) <= safmin)
{
/* Singular matrix pencil -- return unit eigenvector */
i__1 = *n;
for (jr = 1;
jr <= i__1;
++jr)
{
i__2 = jr + ieig * vr_dim1;
vr[i__2].r = 0.f;
vr[i__2].i = 0.f; // , expr subst
/* L150: */
}
i__1 = ieig + ieig * vr_dim1;
vr[i__1].r = 1.f;
vr[i__1].i = 0.f; // , expr subst
goto L250;
}
/* Non-singular eigenvalue: */
/* Compute coefficients a and b in */
/* ( a A - b B ) x = 0 */
/* Computing MAX */
i__1 = je + je * s_dim1;
i__2 = je + je * p_dim1;
r__4 = ((r__2 = s[i__1].r, abs(r__2)) + (r__3 = r_imag(&s[je + je * s_dim1]), abs(r__3))) * ascale;
r__5 = (r__1 = p[i__2].r, abs(r__1)) * bscale;
r__4 = max(r__4,r__5); // ; expr subst
temp = 1.f / max(r__4,safmin);
i__1 = je + je * s_dim1;
q__2.r = temp * s[i__1].r;
q__2.i = temp * s[i__1].i; // , expr subst
q__1.r = ascale * q__2.r;
q__1.i = ascale * q__2.i; // , expr subst
salpha.r = q__1.r;
salpha.i = q__1.i; // , expr subst
i__1 = je + je * p_dim1;
sbeta = temp * p[i__1].r * bscale;
acoeff = sbeta * ascale;
q__1.r = bscale * salpha.r;
q__1.i = bscale * salpha.i; // , expr subst
bcoeff.r = q__1.r;
bcoeff.i = q__1.i; // , expr subst
/* Scale to avoid underflow */
lsa = abs(sbeta) >= safmin && abs(acoeff) < small;
lsb = (r__1 = salpha.r, abs(r__1)) + (r__2 = r_imag(&salpha), abs(r__2)) >= safmin && (r__3 = bcoeff.r, abs(r__3)) + (r__4 = r_imag(&bcoeff), abs(r__4)) < small;
scale = 1.f;
if (lsa)
{
scale = small / abs(sbeta) * min(anorm,big);
}
if (lsb)
{
/* Computing MAX */
r__3 = scale;
r__4 = small / ((r__1 = salpha.r, abs(r__1)) + (r__2 = r_imag(&salpha), abs(r__2))) * min( bnorm,big); // , expr subst
scale = max(r__3,r__4);
}
if (lsa || lsb)
{
/* Computing MIN */
/* Computing MAX */
r__5 = 1.f, r__6 = abs(acoeff);
r__5 = max(r__5,r__6);
r__6 = (r__1 = bcoeff.r, abs(r__1)) + (r__2 = r_imag(&bcoeff), abs(r__2)); // ; expr subst
r__3 = scale;
r__4 = 1.f / (safmin * max(r__5,r__6)); // , expr subst
scale = min(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; // , expr subst
q__1.r = bscale * q__2.r;
q__1.i = bscale * q__2.i; // , expr subst
bcoeff.r = q__1.r;
bcoeff.i = q__1.i; // , expr subst
}
else
{
q__1.r = scale * bcoeff.r;
q__1.i = scale * bcoeff.i; // , expr subst
bcoeff.r = q__1.r;
bcoeff.i = q__1.i; // , expr subst
}
}
acoefa = abs(acoeff);
bcoefa = (r__1 = bcoeff.r, abs(r__1)) + (r__2 = r_imag(& bcoeff), abs(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; // , expr subst
/* L160: */
}
i__1 = je;
work[i__1].r = 1.f;
work[i__1].i = 0.f; // , expr subst
/* Computing MAX */
r__1 = ulp * acoefa * anorm;
r__2 = ulp * bcoefa * bnorm;
r__1 = max(r__1,r__2); // ; expr subst
dmin__ = max(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 = jr + je * s_dim1;
q__2.r = acoeff * s[i__3].r;
q__2.i = acoeff * s[i__3].i; // , expr subst
i__4 = jr + je * p_dim1;
q__3.r = bcoeff.r * p[i__4].r - bcoeff.i * p[i__4].i;
q__3.i = bcoeff.r * p[i__4].i + bcoeff.i * p[i__4] .r; // , expr subst
q__1.r = q__2.r - q__3.r;
q__1.i = q__2.i - q__3.i; // , expr subst
work[i__2].r = q__1.r;
work[i__2].i = q__1.i; // , expr subst
/* L170: */
}
i__1 = je;
work[i__1].r = 1.f;
work[i__1].i = 0.f; // , expr subst
for (j = je - 1;
j >= 1;
--j)
{
/* Form x(j) := - w(j) / d */
/* with scaling and perturbation of the denominator */
i__1 = j + j * s_dim1;
q__2.r = acoeff * s[i__1].r;
q__2.i = acoeff * s[i__1].i; // , expr subst
i__2 = j + j * p_dim1;
q__3.r = bcoeff.r * p[i__2].r - bcoeff.i * p[i__2].i;
q__3.i = bcoeff.r * p[i__2].i + bcoeff.i * p[i__2] .r; // , expr subst
q__1.r = q__2.r - q__3.r;
q__1.i = q__2.i - q__3.i; // , expr subst
d__.r = q__1.r;
d__.i = q__1.i; // , expr subst
if ((r__1 = d__.r, abs(r__1)) + (r__2 = r_imag(&d__), abs( r__2)) <= dmin__)
{
q__1.r = dmin__;
q__1.i = 0.f; // , expr subst
d__.r = q__1.r;
d__.i = q__1.i; // , expr subst
}
if ((r__1 = d__.r, abs(r__1)) + (r__2 = r_imag(&d__), abs( r__2)) < 1.f)
{
i__1 = j;
if ((r__1 = work[i__1].r, abs(r__1)) + (r__2 = r_imag( &work[j]), abs(r__2)) >= bignum * ((r__3 = d__.r, abs(r__3)) + (r__4 = r_imag(&d__), abs( r__4))))
{
i__1 = j;
temp = 1.f / ((r__1 = work[i__1].r, abs(r__1)) + ( r__2 = r_imag(&work[j]), abs(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; // , expr subst
work[i__2].r = q__1.r;
work[i__2].i = q__1.i; // , expr subst
/* L180: */
}
}
}
i__1 = j;
i__2 = j;
q__2.r = -work[i__2].r;
q__2.i = -work[i__2].i; // , expr subst
cladiv_(&q__1, &q__2, &d__);
work[i__1].r = q__1.r;
work[i__1].i = q__1.i; // , expr subst
if (j > 1)
{
/* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling */
i__1 = j;
if ((r__1 = work[i__1].r, abs(r__1)) + (r__2 = r_imag( &work[j]), abs(r__2)) > 1.f)
{
i__1 = j;
temp = 1.f / ((r__1 = work[i__1].r, abs(r__1)) + ( r__2 = r_imag(&work[j]), abs(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; // , expr subst
work[i__2].r = q__1.r;
work[i__2].i = q__1.i; // , expr subst
/* L190: */
}
}
}
i__1 = j;
q__1.r = acoeff * work[i__1].r;
q__1.i = acoeff * work[i__1].i; // , expr subst
ca.r = q__1.r;
ca.i = q__1.i; // , expr subst
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; // , expr subst
cb.r = q__1.r;
cb.i = q__1.i; // , expr subst
i__1 = j - 1;
for (jr = 1;
jr <= i__1;
++jr)
{
i__2 = jr;
i__3 = jr;
i__4 = jr + j * s_dim1;
q__3.r = ca.r * s[i__4].r - ca.i * s[i__4].i;
q__3.i = ca.r * s[i__4].i + ca.i * s[i__4] .r; // , expr subst
q__2.r = work[i__3].r + q__3.r;
q__2.i = work[ i__3].i + q__3.i; // , expr subst
i__5 = jr + j * p_dim1;
q__4.r = cb.r * p[i__5].r - cb.i * p[i__5].i;
q__4.i = cb.r * p[i__5].i + cb.i * p[i__5] .r; // , expr subst
q__1.r = q__2.r - q__4.r;
q__1.i = q__2.i - q__4.i; // , expr subst
work[i__2].r = q__1.r;
work[i__2].i = q__1.i; // , expr subst
/* 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, abs(r__1)) + ( r__2 = r_imag(&work[(isrc - 1) * *n + jr]), abs( r__2)); // , expr subst
xmax = max(r__3,r__4);
/* L220: */
}
if (xmax > safmin)
{
temp = 1.f / xmax;
i__1 = iend;
for (jr = 1;
jr <= i__1;
++jr)
{
i__2 = jr + ieig * vr_dim1;
i__3 = (isrc - 1) * *n + jr;
q__1.r = temp * work[i__3].r;
q__1.i = temp * work[ i__3].i; // , expr subst
vr[i__2].r = q__1.r;
vr[i__2].i = q__1.i; // , expr subst
/* L230: */
}
}
else
{
iend = 0;
}
i__1 = *n;
for (jr = iend + 1;
jr <= i__1;
++jr)
{
i__2 = jr + ieig * vr_dim1;
vr[i__2].r = 0.f;
vr[i__2].i = 0.f; // , expr subst
/* L240: */
}
}
L250:
;
}
}
return 0;
/* End of CTGEVC */
}
/* Subroutine */ int clatrs_(char *uplo, char *trans, char *diag, char *
normin, integer *n, complex *a, integer *lda, complex *x, real *scale,
real *cnorm, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
integer i__, j;
real xj, rec, tjj;
integer jinc;
real xbnd;
integer imax;
real tmax;
complex tjjs;
real xmax, grow;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
real tscal;
complex uscal;
integer jlast;
extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer
*, complex *, integer *);
complex csumj;
extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
logical upper;
extern /* Subroutine */ int ctrsv_(char *, char *, char *, integer *,
complex *, integer *, complex *, integer *), slabad_(real *, real *);
extern integer icamax_(integer *, complex *, integer *);
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), xerbla_(char *, integer *);
real bignum;
extern integer isamax_(integer *, real *, integer *);
extern doublereal scasum_(integer *, complex *, integer *);
logical notran;
integer jfirst;
real smlnum;
logical nounit;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLATRS solves one of the triangular systems */
/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b, */
/* with scaling to prevent overflow. Here A is an upper or lower */
/* triangular matrix, A**T denotes the transpose of A, A**H denotes the */
/* conjugate transpose of A, x and b are n-element vectors, and s is a */
/* scaling factor, usually less than or equal to 1, chosen so that the */
/* components of x will be less than the overflow threshold. If the */
/* unscaled problem will not cause overflow, the Level 2 BLAS routine */
/* CTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j), */
/* then s is set to 0 and a non-trivial solution to A*x = 0 is returned. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A is upper or lower triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* TRANS (input) CHARACTER*1 */
/* Specifies the operation applied to A. */
/* = 'N': Solve A * x = s*b (No transpose) */
/* = 'T': Solve A**T * x = s*b (Transpose) */
/* = 'C': Solve A**H * x = s*b (Conjugate transpose) */
/* DIAG (input) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* NORMIN (input) CHARACTER*1 */
/* Specifies whether CNORM has been set or not. */
/* = 'Y': CNORM contains the column norms on entry */
/* = 'N': CNORM is not set on entry. On exit, the norms will */
/* be computed and stored in CNORM. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The triangular matrix A. If UPLO = 'U', the leading n by n */
/* upper triangular part of the array A contains the upper */
/* triangular matrix, and the strictly lower triangular part of */
/* A is not referenced. If UPLO = 'L', the leading n by n lower */
/* triangular part of the array A contains the lower triangular */
/* matrix, and the strictly upper triangular part of A is not */
/* referenced. If DIAG = 'U', the diagonal elements of A are */
/* also not referenced and are assumed to be 1. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max (1,N). */
/* X (input/output) COMPLEX array, dimension (N) */
/* On entry, the right hand side b of the triangular system. */
/* On exit, X is overwritten by the solution vector x. */
/* SCALE (output) REAL */
/* The scaling factor s for the triangular system */
/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b. */
/* If SCALE = 0, the matrix A is singular or badly scaled, and */
/* the vector x is an exact or approximate solution to A*x = 0. */
/* CNORM (input or output) REAL array, dimension (N) */
/* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */
/* contains the norm of the off-diagonal part of the j-th column */
/* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */
/* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */
/* must be greater than or equal to the 1-norm. */
/* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */
/* returns the 1-norm of the offdiagonal part of the j-th column */
/* of A. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* Further Details */
/* ======= ======= */
/* A rough bound on x is computed; if that is less than overflow, CTRSV */
/* is called, otherwise, specific code is used which checks for possible */
/* overflow or divide-by-zero at every operation. */
/* A columnwise scheme is used for solving A*x = b. The basic algorithm */
/* if A is lower triangular is */
/* x[1:n] := b[1:n] */
/* for j = 1, ..., n */
/* x(j) := x(j) / A(j,j) */
/* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */
/* end */
/* Define bounds on the components of x after j iterations of the loop: */
/* M(j) = bound on x[1:j] */
/* G(j) = bound on x[j+1:n] */
/* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. */
/* Then for iteration j+1 we have */
/* M(j+1) <= G(j) / | A(j+1,j+1) | */
/* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */
/* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */
/* where CNORM(j+1) is greater than or equal to the infinity-norm of */
/* column j+1 of A, not counting the diagonal. Hence */
/* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */
/* 1<=i<=j */
/* and */
/* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */
/* 1<=i< j */
/* Since |x(j)| <= M(j), we use the Level 2 BLAS routine CTRSV if the */
/* reciprocal of the largest M(j), j=1,..,n, is larger than */
/* max(underflow, 1/overflow). */
/* The bound on x(j) is also used to determine when a step in the */
/* columnwise method can be performed without fear of overflow. If */
/* the computed bound is greater than a large constant, x is scaled to */
/* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */
/* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */
/* Similarly, a row-wise scheme is used to solve A**T *x = b or */
/* A**H *x = b. The basic algorithm for A upper triangular is */
/* for j = 1, ..., n */
/* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */
/* end */
/* We simultaneously compute two bounds */
/* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */
/* M(j) = bound on x(i), 1<=i<=j */
/* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we */
/* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */
/* Then the bound on x(j) is */
/* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */
/* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */
/* 1<=i<=j */
/* and we can safely call CTRSV if 1/M(n) and 1/G(n) are both greater */
/* than max(underflow, 1/overflow). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--x;
--cnorm;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
/* Test the input parameters. */
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && !
lsame_(trans, "C")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (! lsame_(normin, "Y") && ! lsame_(normin,
"N")) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CLATRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine machine dependent parameters to control overflow. */
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum /= slamch_("Precision");
bignum = 1.f / smlnum;
*scale = 1.f;
if (lsame_(normin, "N")) {
/* Compute the 1-norm of each column, not including the diagonal. */
if (upper) {
/* A is upper triangular. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
cnorm[j] = scasum_(&i__2, &a[j * a_dim1 + 1], &c__1);
/* L10: */
}
} else {
/* A is lower triangular. */
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j;
cnorm[j] = scasum_(&i__2, &a[j + 1 + j * a_dim1], &c__1);
/* L20: */
}
cnorm[*n] = 0.f;
}
}
/* Scale the column norms by TSCAL if the maximum element in CNORM is */
/* greater than BIGNUM/2. */
imax = isamax_(n, &cnorm[1], &c__1);
tmax = cnorm[imax];
if (tmax <= bignum * .5f) {
tscal = 1.f;
} else {
tscal = .5f / (smlnum * tmax);
sscal_(n, &tscal, &cnorm[1], &c__1);
}
/* Compute a bound on the computed solution vector to see if the */
/* Level 2 BLAS routine CTRSV can be used. */
xmax = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = j;
r__3 = xmax, r__4 = (r__1 = x[i__2].r / 2.f, dabs(r__1)) + (r__2 =
r_imag(&x[j]) / 2.f, dabs(r__2));
xmax = dmax(r__3,r__4);
/* L30: */
}
xbnd = xmax;
if (notran) {
/* Compute the growth in A * x = b. */
if (upper) {
jfirst = *n;
jlast = 1;
jinc = -1;
} else {
jfirst = 1;
jlast = *n;
jinc = 1;
}
if (tscal != 1.f) {
grow = 0.f;
goto L60;
}
if (nounit) {
/* A is non-unit triangular. */
/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
/* Initially, G(0) = max{x(i), i=1,...,n}. */
grow = .5f / dmax(xbnd,smlnum);
xbnd = grow;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L60;
}
i__3 = j + j * a_dim1;
tjjs.r = a[i__3].r, tjjs.i = a[i__3].i;
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj >= smlnum) {
/* M(j) = G(j-1) / abs(A(j,j)) */
/* Computing MIN */
r__1 = xbnd, r__2 = dmin(1.f,tjj) * grow;
xbnd = dmin(r__1,r__2);
} else {
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.f;
}
if (tjj + cnorm[j] >= smlnum) {
/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */
grow *= tjj / (tjj + cnorm[j]);
} else {
/* G(j) could overflow, set GROW to 0. */
grow = 0.f;
}
/* L40: */
}
grow = xbnd;
} else {
/* A is unit triangular. */
/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
/* Computing MIN */
r__1 = 1.f, r__2 = .5f / dmax(xbnd,smlnum);
grow = dmin(r__1,r__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L60;
}
/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
grow *= 1.f / (cnorm[j] + 1.f);
/* L50: */
}
}
L60:
;
} else {
/* Compute the growth in A**T * x = b or A**H * x = b. */
if (upper) {
jfirst = 1;
jlast = *n;
jinc = 1;
} else {
jfirst = *n;
jlast = 1;
jinc = -1;
}
if (tscal != 1.f) {
grow = 0.f;
goto L90;
}
if (nounit) {
/* A is non-unit triangular. */
/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
/* Initially, M(0) = max{x(i), i=1,...,n}. */
grow = .5f / dmax(xbnd,smlnum);
xbnd = grow;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L90;
}
/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */
xj = cnorm[j] + 1.f;
/* Computing MIN */
r__1 = grow, r__2 = xbnd / xj;
grow = dmin(r__1,r__2);
i__3 = j + j * a_dim1;
tjjs.r = a[i__3].r, tjjs.i = a[i__3].i;
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj >= smlnum) {
/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */
if (xj > tjj) {
xbnd *= tjj / xj;
}
} else {
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.f;
}
/* L70: */
}
grow = dmin(grow,xbnd);
} else {
/* A is unit triangular. */
/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
/* Computing MIN */
r__1 = 1.f, r__2 = .5f / dmax(xbnd,smlnum);
grow = dmin(r__1,r__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L90;
}
/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
xj = cnorm[j] + 1.f;
grow /= xj;
/* L80: */
}
}
L90:
;
}
if (grow * tscal > smlnum) {
/* Use the Level 2 BLAS solve if the reciprocal of the bound on */
/* elements of X is not too small. */
ctrsv_(uplo, trans, diag, n, &a[a_offset], lda, &x[1], &c__1);
} else {
/* Use a Level 1 BLAS solve, scaling intermediate results. */
if (xmax > bignum * .5f) {
/* Scale X so that its components are less than or equal to */
/* BIGNUM in absolute value. */
*scale = bignum * .5f / xmax;
csscal_(n, scale, &x[1], &c__1);
xmax = bignum;
} else {
xmax *= 2.f;
}
if (notran) {
/* Solve A * x = b */
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
dabs(r__2));
if (nounit) {
i__3 = j + j * a_dim1;
q__1.r = tscal * a[i__3].r, q__1.i = tscal * a[i__3].i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
if (tscal == 1.f) {
goto L105;
}
}
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f) {
if (xj > tjj * bignum) {
/* Scale x by 1/b(j). */
rec = 1.f / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
), dabs(r__2));
} else if (tjj > 0.f) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */
/* to avoid overflow when dividing by A(j,j). */
rec = tjj * bignum / xj;
if (cnorm[j] > 1.f) {
/* Scale by 1/CNORM(j) to avoid overflow when */
/* multiplying x(j) times column j. */
rec /= cnorm[j];
}
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
), dabs(r__2));
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0, and compute a solution to A*x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0.f, x[i__4].i = 0.f;
/* L100: */
}
i__3 = j;
x[i__3].r = 1.f, x[i__3].i = 0.f;
xj = 1.f;
*scale = 0.f;
xmax = 0.f;
}
L105:
/* Scale x if necessary to avoid overflow when adding a */
/* multiple of column j of A. */
if (xj > 1.f) {
rec = 1.f / xj;
if (cnorm[j] > (bignum - xmax) * rec) {
/* Scale x by 1/(2*abs(x(j))). */
rec *= .5f;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
} else if (xj * cnorm[j] > bignum - xmax) {
/* Scale x by 1/2. */
csscal_(n, &c_b36, &x[1], &c__1);
*scale *= .5f;
}
if (upper) {
if (j > 1) {
/* Compute the update */
/* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */
i__3 = j - 1;
i__4 = j;
q__2.r = -x[i__4].r, q__2.i = -x[i__4].i;
q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
caxpy_(&i__3, &q__1, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
i__3 = j - 1;
i__ = icamax_(&i__3, &x[1], &c__1);
i__3 = i__;
xmax = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[i__]), dabs(r__2));
}
} else {
if (j < *n) {
/* Compute the update */
/* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */
i__3 = *n - j;
i__4 = j;
q__2.r = -x[i__4].r, q__2.i = -x[i__4].i;
q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
caxpy_(&i__3, &q__1, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
i__3 = *n - j;
i__ = j + icamax_(&i__3, &x[j + 1], &c__1);
i__3 = i__;
xmax = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[i__]), dabs(r__2));
}
}
/* L110: */
}
} else if (lsame_(trans, "T")) {
/* Solve A**T * x = b */
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
/* k<>j */
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
dabs(r__2));
uscal.r = tscal, uscal.i = 0.f;
rec = 1.f / dmax(xmax,1.f);
if (cnorm[j] > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5f;
if (nounit) {
i__3 = j + j * a_dim1;
q__1.r = tscal * a[i__3].r, q__1.i = tscal * a[i__3]
.i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
}
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > 1.f) {
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
r__1 = 1.f, r__2 = rec * tjj;
rec = dmin(r__1,r__2);
cladiv_(&q__1, &uscal, &tjjs);
uscal.r = q__1.r, uscal.i = q__1.i;
}
if (rec < 1.f) {
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0.f, csumj.i = 0.f;
if (uscal.r == 1.f && uscal.i == 0.f) {
/* If the scaling needed for A in the dot product is 1, */
/* call CDOTU to perform the dot product. */
if (upper) {
i__3 = j - 1;
cdotu_(&q__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
csumj.r = q__1.r, csumj.i = q__1.i;
} else if (j < *n) {
i__3 = *n - j;
cdotu_(&q__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
csumj.r = q__1.r, csumj.i = q__1.i;
}
} else {
/* Otherwise, use in-line code for the dot product. */
if (upper) {
i__3 = j - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * a_dim1;
q__3.r = a[i__4].r * uscal.r - a[i__4].i *
uscal.i, q__3.i = a[i__4].r * uscal.i + a[
i__4].i * uscal.r;
i__5 = i__;
q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i,
q__2.i = q__3.r * x[i__5].i + q__3.i * x[
i__5].r;
q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
q__2.i;
csumj.r = q__1.r, csumj.i = q__1.i;
/* L120: */
}
} else if (j < *n) {
i__3 = *n;
for (i__ = j + 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * a_dim1;
q__3.r = a[i__4].r * uscal.r - a[i__4].i *
uscal.i, q__3.i = a[i__4].r * uscal.i + a[
i__4].i * uscal.r;
i__5 = i__;
q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i,
q__2.i = q__3.r * x[i__5].i + q__3.i * x[
i__5].r;
q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
q__2.i;
csumj.r = q__1.r, csumj.i = q__1.i;
/* L130: */
}
}
}
q__1.r = tscal, q__1.i = 0.f;
if (uscal.r == q__1.r && uscal.i == q__1.i) {
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
/* was not used to scale the dotproduct. */
i__3 = j;
i__4 = j;
q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i -
csumj.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
), dabs(r__2));
if (nounit) {
i__3 = j + j * a_dim1;
q__1.r = tscal * a[i__3].r, q__1.i = tscal * a[i__3]
.i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
if (tscal == 1.f) {
goto L145;
}
}
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f) {
if (xj > tjj * bignum) {
/* Scale X by 1/abs(x(j)). */
rec = 1.f / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
} else if (tjj > 0.f) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0 and compute a solution to A**T *x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0.f, x[i__4].i = 0.f;
/* L140: */
}
i__3 = j;
x[i__3].r = 1.f, x[i__3].i = 0.f;
*scale = 0.f;
xmax = 0.f;
}
L145:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
/* product has already been divided by 1/A(j,j). */
i__3 = j;
cladiv_(&q__2, &x[j], &tjjs);
q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
}
/* Computing MAX */
i__3 = j;
r__3 = xmax, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[j]), dabs(r__2));
xmax = dmax(r__3,r__4);
/* L150: */
}
} else {
/* Solve A**H * x = b */
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
/* k<>j */
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
dabs(r__2));
uscal.r = tscal, uscal.i = 0.f;
rec = 1.f / dmax(xmax,1.f);
if (cnorm[j] > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5f;
if (nounit) {
r_cnjg(&q__2, &a[j + j * a_dim1]);
q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
}
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > 1.f) {
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
r__1 = 1.f, r__2 = rec * tjj;
rec = dmin(r__1,r__2);
cladiv_(&q__1, &uscal, &tjjs);
uscal.r = q__1.r, uscal.i = q__1.i;
}
if (rec < 1.f) {
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0.f, csumj.i = 0.f;
if (uscal.r == 1.f && uscal.i == 0.f) {
/* If the scaling needed for A in the dot product is 1, */
/* call CDOTC to perform the dot product. */
if (upper) {
i__3 = j - 1;
cdotc_(&q__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
csumj.r = q__1.r, csumj.i = q__1.i;
} else if (j < *n) {
i__3 = *n - j;
cdotc_(&q__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
csumj.r = q__1.r, csumj.i = q__1.i;
}
} else {
/* Otherwise, use in-line code for the dot product. */
if (upper) {
i__3 = j - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
r_cnjg(&q__4, &a[i__ + j * a_dim1]);
q__3.r = q__4.r * uscal.r - q__4.i * uscal.i,
q__3.i = q__4.r * uscal.i + q__4.i *
uscal.r;
i__4 = i__;
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i,
q__2.i = q__3.r * x[i__4].i + q__3.i * x[
i__4].r;
q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
q__2.i;
csumj.r = q__1.r, csumj.i = q__1.i;
/* L160: */
}
} else if (j < *n) {
i__3 = *n;
for (i__ = j + 1; i__ <= i__3; ++i__) {
r_cnjg(&q__4, &a[i__ + j * a_dim1]);
q__3.r = q__4.r * uscal.r - q__4.i * uscal.i,
q__3.i = q__4.r * uscal.i + q__4.i *
uscal.r;
i__4 = i__;
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i,
q__2.i = q__3.r * x[i__4].i + q__3.i * x[
i__4].r;
q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
q__2.i;
csumj.r = q__1.r, csumj.i = q__1.i;
/* L170: */
}
}
}
q__1.r = tscal, q__1.i = 0.f;
if (uscal.r == q__1.r && uscal.i == q__1.i) {
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
/* was not used to scale the dotproduct. */
i__3 = j;
i__4 = j;
q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i -
csumj.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
), dabs(r__2));
if (nounit) {
r_cnjg(&q__2, &a[j + j * a_dim1]);
q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
if (tscal == 1.f) {
goto L185;
}
}
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f) {
if (xj > tjj * bignum) {
/* Scale X by 1/abs(x(j)). */
rec = 1.f / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
} else if (tjj > 0.f) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0 and compute a solution to A**H *x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0.f, x[i__4].i = 0.f;
/* L180: */
}
i__3 = j;
x[i__3].r = 1.f, x[i__3].i = 0.f;
*scale = 0.f;
xmax = 0.f;
}
L185:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
/* product has already been divided by 1/A(j,j). */
i__3 = j;
cladiv_(&q__2, &x[j], &tjjs);
q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
}
/* Computing MAX */
i__3 = j;
r__3 = xmax, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[j]), dabs(r__2));
xmax = dmax(r__3,r__4);
/* L190: */
}
}
*scale /= tscal;
}
/* Scale the column norms by 1/TSCAL for return. */
if (tscal != 1.f) {
r__1 = 1.f / tscal;
sscal_(n, &r__1, &cnorm[1], &c__1);
}
return 0;
/* End of CLATRS */
} /* clatrs_ */
/* Subroutine */ int clahqr_(logical *wantt, logical *wantz, integer *n,
integer *ilo, integer *ihi, complex *h__, integer *ldh, complex *w,
integer *iloz, integer *ihiz, complex *z__, integer *ldz, integer *
info)
{
/* System generated locals */
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
real r__1, r__2, r__3, r__4, r__5, r__6;
complex q__1, q__2, q__3, q__4, q__5, q__6, q__7;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
double c_abs(complex *);
void c_sqrt(complex *, complex *), pow_ci(complex *, complex *, integer *)
;
/* Local variables */
integer i__, j, k, l, m;
real s;
complex t, u, v[2], x, y;
integer i1, i2;
complex t1;
real t2;
complex v2;
real aa, ab, ba, bb, h10;
complex h11;
real h21;
complex h22, sc;
integer nh, nz;
real sx;
integer jhi;
complex h11s;
integer jlo, its;
real ulp;
complex sum;
real tst;
complex temp;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *), ccopy_(integer *, complex *, integer *, complex *,
integer *);
real rtemp;
extern /* Subroutine */ int slabad_(real *, real *), clarfg_(integer *,
complex *, complex *, integer *, complex *);
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
extern doublereal slamch_(char *);
real safmin, safmax, smlnum;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLAHQR is an auxiliary routine called by CHSEQR to update the */
/* eigenvalues and Schur decomposition already computed by CHSEQR, by */
/* dealing with the Hessenberg submatrix in rows and columns ILO to */
/* IHI. */
/* Arguments */
/* ========= */
/* WANTT (input) LOGICAL */
/* = .TRUE. : the full Schur form T is required; */
/* = .FALSE.: only eigenvalues are required. */
/* WANTZ (input) LOGICAL */
/* = .TRUE. : the matrix of Schur vectors Z is required; */
/* = .FALSE.: Schur vectors are not required. */
/* N (input) INTEGER */
/* The order of the matrix H. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* It is assumed that H is already upper triangular in rows and */
/* columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1). */
/* CLAHQR works primarily with the Hessenberg submatrix in rows */
/* and columns ILO to IHI, but applies transformations to all of */
/* H if WANTT is .TRUE.. */
/* 1 <= ILO <= max(1,IHI); IHI <= N. */
/* H (input/output) COMPLEX array, dimension (LDH,N) */
/* On entry, the upper Hessenberg matrix H. */
/* On exit, if INFO is zero and if WANTT is .TRUE., then H */
/* is upper triangular in rows and columns ILO:IHI. If INFO */
/* is zero and if WANTT is .FALSE., then the contents of H */
/* are unspecified on exit. The output state of H in case */
/* INF is positive is below under the description of INFO. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH >= max(1,N). */
/* W (output) COMPLEX array, dimension (N) */
/* The computed eigenvalues ILO to IHI are stored in the */
/* corresponding elements of W. If WANTT is .TRUE., the */
/* eigenvalues are stored in the same order as on the diagonal */
/* of the Schur form returned in H, with W(i) = H(i,i). */
/* ILOZ (input) INTEGER */
/* IHIZ (input) INTEGER */
/* Specify the rows of Z to which transformations must be */
/* applied if WANTZ is .TRUE.. */
/* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. */
/* Z (input/output) COMPLEX array, dimension (LDZ,N) */
/* If WANTZ is .TRUE., on entry Z must contain the current */
/* matrix Z of transformations accumulated by CHSEQR, and on */
/* exit Z has been updated; transformations are applied only to */
/* the submatrix Z(ILOZ:IHIZ,ILO:IHI). */
/* If WANTZ is .FALSE., Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* .GT. 0: if INFO = i, CLAHQR failed to compute all the */
/* eigenvalues ILO to IHI in a total of 30 iterations */
/* per eigenvalue; elements i+1:ihi of W contain */
/* those eigenvalues which have been successfully */
/* computed. */
/* If INFO .GT. 0 and WANTT is .FALSE., then on exit, */
/* the remaining unconverged eigenvalues are the */
/* eigenvalues of the upper Hessenberg matrix */
/* rows and columns ILO thorugh INFO of the final, */
/* output value of H. */
/* If INFO .GT. 0 and WANTT is .TRUE., then on exit */
/* (*) (initial value of H)*U = U*(final value of H) */
/* where U is an orthognal matrix. The final */
/* value of H is upper Hessenberg and triangular in */
/* rows and columns INFO+1 through IHI. */
/* If INFO .GT. 0 and WANTZ is .TRUE., then on exit */
/* (final value of Z) = (initial value of Z)*U */
/* where U is the orthogonal matrix in (*) */
/* (regardless of the value of WANTT.) */
/* Further Details */
/* =============== */
/* 02-96 Based on modifications by */
/* David Day, Sandia National Laboratory, USA */
/* 12-04 Further modifications by */
/* Ralph Byers, University of Kansas, USA */
/* This is a modified version of CLAHQR from LAPACK version 3.0. */
/* It is (1) more robust against overflow and underflow and */
/* (2) adopts the more conservative Ahues & Tisseur stopping */
/* criterion (LAWN 122, 1997). */
/* ========================================================= */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*ilo == *ihi) {
i__1 = *ilo;
i__2 = *ilo + *ilo * h_dim1;
w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i;
return 0;
}
/* ==== clear out the trash ==== */
i__1 = *ihi - 3;
for (j = *ilo; j <= i__1; ++j) {
i__2 = j + 2 + j * h_dim1;
h__[i__2].r = 0.f, h__[i__2].i = 0.f;
i__2 = j + 3 + j * h_dim1;
h__[i__2].r = 0.f, h__[i__2].i = 0.f;
/* L10: */
}
if (*ilo <= *ihi - 2) {
i__1 = *ihi + (*ihi - 2) * h_dim1;
h__[i__1].r = 0.f, h__[i__1].i = 0.f;
}
/* ==== ensure that subdiagonal entries are real ==== */
if (*wantt) {
jlo = 1;
jhi = *n;
} else {
jlo = *ilo;
jhi = *ihi;
}
i__1 = *ihi;
for (i__ = *ilo + 1; i__ <= i__1; ++i__) {
if (r_imag(&h__[i__ + (i__ - 1) * h_dim1]) != 0.f) {
/* ==== The following redundant normalization */
/* . avoids problems with both gradual and */
/* . sudden underflow in ABS(H(I,I-1)) ==== */
i__2 = i__ + (i__ - 1) * h_dim1;
i__3 = i__ + (i__ - 1) * h_dim1;
r__3 = (r__1 = h__[i__3].r, dabs(r__1)) + (r__2 = r_imag(&h__[i__
+ (i__ - 1) * h_dim1]), dabs(r__2));
q__1.r = h__[i__2].r / r__3, q__1.i = h__[i__2].i / r__3;
sc.r = q__1.r, sc.i = q__1.i;
r_cnjg(&q__2, &sc);
r__1 = c_abs(&sc);
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
sc.r = q__1.r, sc.i = q__1.i;
i__2 = i__ + (i__ - 1) * h_dim1;
r__1 = c_abs(&h__[i__ + (i__ - 1) * h_dim1]);
h__[i__2].r = r__1, h__[i__2].i = 0.f;
i__2 = jhi - i__ + 1;
cscal_(&i__2, &sc, &h__[i__ + i__ * h_dim1], ldh);
/* Computing MIN */
i__3 = jhi, i__4 = i__ + 1;
i__2 = min(i__3,i__4) - jlo + 1;
r_cnjg(&q__1, &sc);
cscal_(&i__2, &q__1, &h__[jlo + i__ * h_dim1], &c__1);
if (*wantz) {
i__2 = *ihiz - *iloz + 1;
r_cnjg(&q__1, &sc);
cscal_(&i__2, &q__1, &z__[*iloz + i__ * z_dim1], &c__1);
}
}
/* L20: */
}
nh = *ihi - *ilo + 1;
nz = *ihiz - *iloz + 1;
/* Set machine-dependent constants for the stopping criterion. */
safmin = slamch_("SAFE MINIMUM");
safmax = 1.f / safmin;
slabad_(&safmin, &safmax);
ulp = slamch_("PRECISION");
smlnum = safmin * ((real) nh / ulp);
/* I1 and I2 are the indices of the first row and last column of H */
/* to which transformations must be applied. If eigenvalues only are */
/* being computed, I1 and I2 are set inside the main loop. */
if (*wantt) {
i1 = 1;
i2 = *n;
}
/* The main loop begins here. I is the loop index and decreases from */
/* IHI to ILO in steps of 1. Each iteration of the loop works */
/* with the active submatrix in rows and columns L to I. */
/* Eigenvalues I+1 to IHI have already converged. Either L = ILO, or */
/* H(L,L-1) is negligible so that the matrix splits. */
i__ = *ihi;
L30:
if (i__ < *ilo) {
goto L150;
}
/* Perform QR iterations on rows and columns ILO to I until a */
/* submatrix of order 1 splits off at the bottom because a */
/* subdiagonal element has become negligible. */
l = *ilo;
for (its = 0; its <= 30; ++its) {
/* Look for a single small subdiagonal element. */
i__1 = l + 1;
for (k = i__; k >= i__1; --k) {
i__2 = k + (k - 1) * h_dim1;
if ((r__1 = h__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&h__[k + (k
- 1) * h_dim1]), dabs(r__2)) <= smlnum) {
goto L50;
}
i__2 = k - 1 + (k - 1) * h_dim1;
i__3 = k + k * h_dim1;
tst = (r__1 = h__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&h__[k -
1 + (k - 1) * h_dim1]), dabs(r__2)) + ((r__3 = h__[i__3]
.r, dabs(r__3)) + (r__4 = r_imag(&h__[k + k * h_dim1]),
dabs(r__4)));
if (tst == 0.f) {
if (k - 2 >= *ilo) {
i__2 = k - 1 + (k - 2) * h_dim1;
tst += (r__1 = h__[i__2].r, dabs(r__1));
}
if (k + 1 <= *ihi) {
i__2 = k + 1 + k * h_dim1;
tst += (r__1 = h__[i__2].r, dabs(r__1));
}
}
/* ==== The following is a conservative small subdiagonal */
/* . deflation criterion due to Ahues & Tisseur (LAWN 122, */
/* . 1997). It has better mathematical foundation and */
/* . improves accuracy in some examples. ==== */
i__2 = k + (k - 1) * h_dim1;
if ((r__1 = h__[i__2].r, dabs(r__1)) <= ulp * tst) {
/* Computing MAX */
i__2 = k + (k - 1) * h_dim1;
i__3 = k - 1 + k * h_dim1;
r__5 = (r__1 = h__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&h__[
k + (k - 1) * h_dim1]), dabs(r__2)), r__6 = (r__3 =
h__[i__3].r, dabs(r__3)) + (r__4 = r_imag(&h__[k - 1
+ k * h_dim1]), dabs(r__4));
ab = dmax(r__5,r__6);
/* Computing MIN */
i__2 = k + (k - 1) * h_dim1;
i__3 = k - 1 + k * h_dim1;
r__5 = (r__1 = h__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&h__[
k + (k - 1) * h_dim1]), dabs(r__2)), r__6 = (r__3 =
h__[i__3].r, dabs(r__3)) + (r__4 = r_imag(&h__[k - 1
+ k * h_dim1]), dabs(r__4));
ba = dmin(r__5,r__6);
i__2 = k - 1 + (k - 1) * h_dim1;
i__3 = k + k * h_dim1;
q__2.r = h__[i__2].r - h__[i__3].r, q__2.i = h__[i__2].i -
h__[i__3].i;
q__1.r = q__2.r, q__1.i = q__2.i;
/* Computing MAX */
i__4 = k + k * h_dim1;
r__5 = (r__1 = h__[i__4].r, dabs(r__1)) + (r__2 = r_imag(&h__[
k + k * h_dim1]), dabs(r__2)), r__6 = (r__3 = q__1.r,
dabs(r__3)) + (r__4 = r_imag(&q__1), dabs(r__4));
aa = dmax(r__5,r__6);
i__2 = k - 1 + (k - 1) * h_dim1;
i__3 = k + k * h_dim1;
q__2.r = h__[i__2].r - h__[i__3].r, q__2.i = h__[i__2].i -
h__[i__3].i;
q__1.r = q__2.r, q__1.i = q__2.i;
/* Computing MIN */
i__4 = k + k * h_dim1;
r__5 = (r__1 = h__[i__4].r, dabs(r__1)) + (r__2 = r_imag(&h__[
k + k * h_dim1]), dabs(r__2)), r__6 = (r__3 = q__1.r,
dabs(r__3)) + (r__4 = r_imag(&q__1), dabs(r__4));
bb = dmin(r__5,r__6);
s = aa + ab;
/* Computing MAX */
r__1 = smlnum, r__2 = ulp * (bb * (aa / s));
if (ba * (ab / s) <= dmax(r__1,r__2)) {
goto L50;
}
}
/* L40: */
}
L50:
l = k;
if (l > *ilo) {
/* H(L,L-1) is negligible */
i__1 = l + (l - 1) * h_dim1;
h__[i__1].r = 0.f, h__[i__1].i = 0.f;
}
/* Exit from loop if a submatrix of order 1 has split off. */
if (l >= i__) {
goto L140;
}
/* Now the active submatrix is in rows and columns L to I. If */
/* eigenvalues only are being computed, only the active submatrix */
/* need be transformed. */
if (! (*wantt)) {
i1 = l;
i2 = i__;
}
if (its == 10) {
/* Exceptional shift. */
i__1 = l + 1 + l * h_dim1;
s = (r__1 = h__[i__1].r, dabs(r__1)) * .75f;
i__1 = l + l * h_dim1;
q__1.r = s + h__[i__1].r, q__1.i = h__[i__1].i;
t.r = q__1.r, t.i = q__1.i;
} else if (its == 20) {
/* Exceptional shift. */
i__1 = i__ + (i__ - 1) * h_dim1;
s = (r__1 = h__[i__1].r, dabs(r__1)) * .75f;
i__1 = i__ + i__ * h_dim1;
q__1.r = s + h__[i__1].r, q__1.i = h__[i__1].i;
t.r = q__1.r, t.i = q__1.i;
} else {
/* Wilkinson's shift. */
i__1 = i__ + i__ * h_dim1;
t.r = h__[i__1].r, t.i = h__[i__1].i;
c_sqrt(&q__2, &h__[i__ - 1 + i__ * h_dim1]);
c_sqrt(&q__3, &h__[i__ + (i__ - 1) * h_dim1]);
q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = q__2.r *
q__3.i + q__2.i * q__3.r;
u.r = q__1.r, u.i = q__1.i;
s = (r__1 = u.r, dabs(r__1)) + (r__2 = r_imag(&u), dabs(r__2));
if (s != 0.f) {
i__1 = i__ - 1 + (i__ - 1) * h_dim1;
q__2.r = h__[i__1].r - t.r, q__2.i = h__[i__1].i - t.i;
q__1.r = q__2.r * .5f, q__1.i = q__2.i * .5f;
x.r = q__1.r, x.i = q__1.i;
sx = (r__1 = x.r, dabs(r__1)) + (r__2 = r_imag(&x), dabs(r__2)
);
/* Computing MAX */
r__3 = s, r__4 = (r__1 = x.r, dabs(r__1)) + (r__2 = r_imag(&x)
, dabs(r__2));
s = dmax(r__3,r__4);
q__5.r = x.r / s, q__5.i = x.i / s;
pow_ci(&q__4, &q__5, &c__2);
q__7.r = u.r / s, q__7.i = u.i / s;
pow_ci(&q__6, &q__7, &c__2);
q__3.r = q__4.r + q__6.r, q__3.i = q__4.i + q__6.i;
c_sqrt(&q__2, &q__3);
q__1.r = s * q__2.r, q__1.i = s * q__2.i;
y.r = q__1.r, y.i = q__1.i;
if (sx > 0.f) {
q__1.r = x.r / sx, q__1.i = x.i / sx;
q__2.r = x.r / sx, q__2.i = x.i / sx;
if (q__1.r * y.r + r_imag(&q__2) * r_imag(&y) < 0.f) {
q__3.r = -y.r, q__3.i = -y.i;
y.r = q__3.r, y.i = q__3.i;
}
}
q__4.r = x.r + y.r, q__4.i = x.i + y.i;
cladiv_(&q__3, &u, &q__4);
q__2.r = u.r * q__3.r - u.i * q__3.i, q__2.i = u.r * q__3.i +
u.i * q__3.r;
q__1.r = t.r - q__2.r, q__1.i = t.i - q__2.i;
t.r = q__1.r, t.i = q__1.i;
}
}
/* Look for two consecutive small subdiagonal elements. */
i__1 = l + 1;
for (m = i__ - 1; m >= i__1; --m) {
/* Determine the effect of starting the single-shift QR */
/* iteration at row M, and see if this would make H(M,M-1) */
/* negligible. */
i__2 = m + m * h_dim1;
h11.r = h__[i__2].r, h11.i = h__[i__2].i;
i__2 = m + 1 + (m + 1) * h_dim1;
h22.r = h__[i__2].r, h22.i = h__[i__2].i;
q__1.r = h11.r - t.r, q__1.i = h11.i - t.i;
h11s.r = q__1.r, h11s.i = q__1.i;
i__2 = m + 1 + m * h_dim1;
h21 = h__[i__2].r;
s = (r__1 = h11s.r, dabs(r__1)) + (r__2 = r_imag(&h11s), dabs(
r__2)) + dabs(h21);
q__1.r = h11s.r / s, q__1.i = h11s.i / s;
h11s.r = q__1.r, h11s.i = q__1.i;
h21 /= s;
v[0].r = h11s.r, v[0].i = h11s.i;
v[1].r = h21, v[1].i = 0.f;
i__2 = m + (m - 1) * h_dim1;
h10 = h__[i__2].r;
if (dabs(h10) * dabs(h21) <= ulp * (((r__1 = h11s.r, dabs(r__1))
+ (r__2 = r_imag(&h11s), dabs(r__2))) * ((r__3 = h11.r,
dabs(r__3)) + (r__4 = r_imag(&h11), dabs(r__4)) + ((r__5 =
h22.r, dabs(r__5)) + (r__6 = r_imag(&h22), dabs(r__6)))))
) {
goto L70;
}
/* L60: */
}
i__1 = l + l * h_dim1;
h11.r = h__[i__1].r, h11.i = h__[i__1].i;
i__1 = l + 1 + (l + 1) * h_dim1;
h22.r = h__[i__1].r, h22.i = h__[i__1].i;
q__1.r = h11.r - t.r, q__1.i = h11.i - t.i;
h11s.r = q__1.r, h11s.i = q__1.i;
i__1 = l + 1 + l * h_dim1;
h21 = h__[i__1].r;
s = (r__1 = h11s.r, dabs(r__1)) + (r__2 = r_imag(&h11s), dabs(r__2))
+ dabs(h21);
q__1.r = h11s.r / s, q__1.i = h11s.i / s;
h11s.r = q__1.r, h11s.i = q__1.i;
h21 /= s;
v[0].r = h11s.r, v[0].i = h11s.i;
v[1].r = h21, v[1].i = 0.f;
L70:
/* Single-shift QR step */
i__1 = i__ - 1;
for (k = m; k <= i__1; ++k) {
/* The first iteration of this loop determines a reflection G */
/* from the vector V and applies it from left and right to H, */
/* thus creating a nonzero bulge below the subdiagonal. */
/* Each subsequent iteration determines a reflection G to */
/* restore the Hessenberg form in the (K-1)th column, and thus */
/* chases the bulge one step toward the bottom of the active */
/* submatrix. */
/* V(2) is always real before the call to CLARFG, and hence */
/* after the call T2 ( = T1*V(2) ) is also real. */
if (k > m) {
ccopy_(&c__2, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1);
}
clarfg_(&c__2, v, &v[1], &c__1, &t1);
if (k > m) {
i__2 = k + (k - 1) * h_dim1;
h__[i__2].r = v[0].r, h__[i__2].i = v[0].i;
i__2 = k + 1 + (k - 1) * h_dim1;
h__[i__2].r = 0.f, h__[i__2].i = 0.f;
}
v2.r = v[1].r, v2.i = v[1].i;
q__1.r = t1.r * v2.r - t1.i * v2.i, q__1.i = t1.r * v2.i + t1.i *
v2.r;
t2 = q__1.r;
/* Apply G from the left to transform the rows of the matrix */
/* in columns K to I2. */
i__2 = i2;
for (j = k; j <= i__2; ++j) {
r_cnjg(&q__3, &t1);
i__3 = k + j * h_dim1;
q__2.r = q__3.r * h__[i__3].r - q__3.i * h__[i__3].i, q__2.i =
q__3.r * h__[i__3].i + q__3.i * h__[i__3].r;
i__4 = k + 1 + j * h_dim1;
q__4.r = t2 * h__[i__4].r, q__4.i = t2 * h__[i__4].i;
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
sum.r = q__1.r, sum.i = q__1.i;
i__3 = k + j * h_dim1;
i__4 = k + j * h_dim1;
q__1.r = h__[i__4].r - sum.r, q__1.i = h__[i__4].i - sum.i;
h__[i__3].r = q__1.r, h__[i__3].i = q__1.i;
i__3 = k + 1 + j * h_dim1;
i__4 = k + 1 + j * h_dim1;
q__2.r = sum.r * v2.r - sum.i * v2.i, q__2.i = sum.r * v2.i +
sum.i * v2.r;
q__1.r = h__[i__4].r - q__2.r, q__1.i = h__[i__4].i - q__2.i;
h__[i__3].r = q__1.r, h__[i__3].i = q__1.i;
/* L80: */
}
/* Apply G from the right to transform the columns of the */
/* matrix in rows I1 to min(K+2,I). */
/* Computing MIN */
i__3 = k + 2;
i__2 = min(i__3,i__);
for (j = i1; j <= i__2; ++j) {
i__3 = j + k * h_dim1;
q__2.r = t1.r * h__[i__3].r - t1.i * h__[i__3].i, q__2.i =
t1.r * h__[i__3].i + t1.i * h__[i__3].r;
i__4 = j + (k + 1) * h_dim1;
q__3.r = t2 * h__[i__4].r, q__3.i = t2 * h__[i__4].i;
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;
i__3 = j + k * h_dim1;
i__4 = j + k * h_dim1;
q__1.r = h__[i__4].r - sum.r, q__1.i = h__[i__4].i - sum.i;
h__[i__3].r = q__1.r, h__[i__3].i = q__1.i;
i__3 = j + (k + 1) * h_dim1;
i__4 = j + (k + 1) * h_dim1;
r_cnjg(&q__3, &v2);
q__2.r = sum.r * q__3.r - sum.i * q__3.i, q__2.i = sum.r *
q__3.i + sum.i * q__3.r;
q__1.r = h__[i__4].r - q__2.r, q__1.i = h__[i__4].i - q__2.i;
h__[i__3].r = q__1.r, h__[i__3].i = q__1.i;
/* L90: */
}
if (*wantz) {
/* Accumulate transformations in the matrix Z */
i__2 = *ihiz;
for (j = *iloz; j <= i__2; ++j) {
i__3 = j + k * z_dim1;
q__2.r = t1.r * z__[i__3].r - t1.i * z__[i__3].i, q__2.i =
t1.r * z__[i__3].i + t1.i * z__[i__3].r;
i__4 = j + (k + 1) * z_dim1;
q__3.r = t2 * z__[i__4].r, q__3.i = t2 * z__[i__4].i;
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;
i__3 = j + k * z_dim1;
i__4 = j + k * z_dim1;
q__1.r = z__[i__4].r - sum.r, q__1.i = z__[i__4].i -
sum.i;
z__[i__3].r = q__1.r, z__[i__3].i = q__1.i;
i__3 = j + (k + 1) * z_dim1;
i__4 = j + (k + 1) * z_dim1;
r_cnjg(&q__3, &v2);
q__2.r = sum.r * q__3.r - sum.i * q__3.i, q__2.i = sum.r *
q__3.i + sum.i * q__3.r;
q__1.r = z__[i__4].r - q__2.r, q__1.i = z__[i__4].i -
q__2.i;
z__[i__3].r = q__1.r, z__[i__3].i = q__1.i;
/* L100: */
}
}
if (k == m && m > l) {
/* If the QR step was started at row M > L because two */
/* consecutive small subdiagonals were found, then extra */
/* scaling must be performed to ensure that H(M,M-1) remains */
/* real. */
q__1.r = 1.f - t1.r, q__1.i = 0.f - t1.i;
temp.r = q__1.r, temp.i = q__1.i;
r__1 = c_abs(&temp);
q__1.r = temp.r / r__1, q__1.i = temp.i / r__1;
temp.r = q__1.r, temp.i = q__1.i;
i__2 = m + 1 + m * h_dim1;
i__3 = m + 1 + m * h_dim1;
r_cnjg(&q__2, &temp);
q__1.r = h__[i__3].r * q__2.r - h__[i__3].i * q__2.i, q__1.i =
h__[i__3].r * q__2.i + h__[i__3].i * q__2.r;
h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
if (m + 2 <= i__) {
i__2 = m + 2 + (m + 1) * h_dim1;
i__3 = m + 2 + (m + 1) * h_dim1;
q__1.r = h__[i__3].r * temp.r - h__[i__3].i * temp.i,
q__1.i = h__[i__3].r * temp.i + h__[i__3].i *
temp.r;
h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
}
i__2 = i__;
for (j = m; j <= i__2; ++j) {
if (j != m + 1) {
if (i2 > j) {
i__3 = i2 - j;
cscal_(&i__3, &temp, &h__[j + (j + 1) * h_dim1],
ldh);
}
i__3 = j - i1;
r_cnjg(&q__1, &temp);
cscal_(&i__3, &q__1, &h__[i1 + j * h_dim1], &c__1);
if (*wantz) {
r_cnjg(&q__1, &temp);
cscal_(&nz, &q__1, &z__[*iloz + j * z_dim1], &
c__1);
}
}
/* L110: */
}
}
/* L120: */
}
/* Ensure that H(I,I-1) is real. */
i__1 = i__ + (i__ - 1) * h_dim1;
temp.r = h__[i__1].r, temp.i = h__[i__1].i;
if (r_imag(&temp) != 0.f) {
rtemp = c_abs(&temp);
i__1 = i__ + (i__ - 1) * h_dim1;
h__[i__1].r = rtemp, h__[i__1].i = 0.f;
q__1.r = temp.r / rtemp, q__1.i = temp.i / rtemp;
temp.r = q__1.r, temp.i = q__1.i;
if (i2 > i__) {
i__1 = i2 - i__;
r_cnjg(&q__1, &temp);
cscal_(&i__1, &q__1, &h__[i__ + (i__ + 1) * h_dim1], ldh);
}
i__1 = i__ - i1;
cscal_(&i__1, &temp, &h__[i1 + i__ * h_dim1], &c__1);
if (*wantz) {
cscal_(&nz, &temp, &z__[*iloz + i__ * z_dim1], &c__1);
}
}
/* L130: */
}
/* Failure to converge in remaining number of iterations */
*info = i__;
return 0;
L140:
/* H(I,I-1) is negligible: one eigenvalue has converged. */
i__1 = i__;
i__2 = i__ + i__ * h_dim1;
w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i;
/* return to start of the main loop with new value of I. */
i__ = l - 1;
goto L30;
L150:
return 0;
/* End of CLAHQR */
} /* clahqr_ */
/* Subroutine */ int claein_(logical *rightv, logical *noinit, integer *n,
complex *h__, integer *ldh, complex *w, complex *v, complex *b,
integer *ldb, real *rwork, real *eps3, real *smlnum, integer *info)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CLAEIN uses inverse iteration to find a right or left eigenvector
corresponding to the eigenvalue W of a complex upper Hessenberg
matrix H.
Arguments
=========
RIGHTV (input) LOGICAL
= .TRUE. : compute right eigenvector;
= .FALSE.: compute left eigenvector.
NOINIT (input) LOGICAL
= .TRUE. : no initial vector supplied in V
= .FALSE.: initial vector supplied in V.
N (input) INTEGER
The order of the matrix H. N >= 0.
H (input) COMPLEX array, dimension (LDH,N)
The upper Hessenberg matrix H.
LDH (input) INTEGER
The leading dimension of the array H. LDH >= max(1,N).
W (input) COMPLEX
The eigenvalue of H whose corresponding right or left
eigenvector is to be computed.
V (input/output) COMPLEX array, dimension (N)
On entry, if NOINIT = .FALSE., V must contain a starting
vector for inverse iteration; otherwise V need not be set.
On exit, V contains the computed eigenvector, normalized so
that the component of largest magnitude has magnitude 1; here
the magnitude of a complex number (x,y) is taken to be
|x| + |y|.
B (workspace) COMPLEX array, dimension (LDB,N)
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
RWORK (workspace) REAL array, dimension (N)
EPS3 (input) REAL
A small machine-dependent value which is used to perturb
close eigenvalues, and to replace zero pivots.
SMLNUM (input) REAL
A machine-dependent value close to the underflow threshold.
INFO (output) INTEGER
= 0: successful exit
= 1: inverse iteration did not converge; V is set to the
last iterate.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer b_dim1, b_offset, h_dim1, h_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
complex q__1, q__2;
/* Builtin functions */
double sqrt(doublereal), r_imag(complex *);
/* Local variables */
static integer ierr;
static complex temp;
static integer i__, j;
static real scale;
static complex x;
static char trans[1];
static real rtemp, rootn, vnorm;
extern doublereal scnrm2_(integer *, complex *, integer *);
static complex ei, ej;
extern integer icamax_(integer *, complex *, integer *);
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), clatrs_(char *, char *, char *, char *, integer *, complex *,
integer *, complex *, real *, real *, integer *);
extern doublereal scasum_(integer *, complex *, integer *);
static char normin[1];
static real nrmsml, growto;
static integer its;
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define h___subscr(a_1,a_2) (a_2)*h_dim1 + a_1
#define h___ref(a_1,a_2) h__[h___subscr(a_1,a_2)]
h_dim1 = *ldh;
h_offset = 1 + h_dim1 * 1;
h__ -= h_offset;
--v;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--rwork;
/* Function Body */
*info = 0;
/* GROWTO is the threshold used in the acceptance test for an
eigenvector. */
rootn = sqrt((real) (*n));
growto = .1f / rootn;
/* Computing MAX */
r__1 = 1.f, r__2 = *eps3 * rootn;
nrmsml = dmax(r__1,r__2) * *smlnum;
/* Form B = H - W*I (except that the subdiagonal elements are not
stored). */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
i__4 = h___subscr(i__, j);
b[i__3].r = h__[i__4].r, b[i__3].i = h__[i__4].i;
/* L10: */
}
i__2 = b_subscr(j, j);
i__3 = h___subscr(j, j);
q__1.r = h__[i__3].r - w->r, q__1.i = h__[i__3].i - w->i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L20: */
}
if (*noinit) {
/* Initialize V. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
v[i__2].r = *eps3, v[i__2].i = 0.f;
/* L30: */
}
} else {
/* Scale supplied initial vector. */
vnorm = scnrm2_(n, &v[1], &c__1);
r__1 = *eps3 * rootn / dmax(vnorm,nrmsml);
csscal_(n, &r__1, &v[1], &c__1);
}
if (*rightv) {
/* LU decomposition with partial pivoting of B, replacing zero
pivots by EPS3. */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = h___subscr(i__ + 1, i__);
ei.r = h__[i__2].r, ei.i = h__[i__2].i;
i__2 = b_subscr(i__, i__);
if ((r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(i__,
i__)), dabs(r__2)) < (r__3 = ei.r, dabs(r__3)) + (r__4 =
r_imag(&ei), dabs(r__4))) {
/* Interchange rows and eliminate. */
cladiv_(&q__1, &b_ref(i__, i__), &ei);
x.r = q__1.r, x.i = q__1.i;
i__2 = b_subscr(i__, i__);
b[i__2].r = ei.r, b[i__2].i = ei.i;
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = b_subscr(i__ + 1, j);
temp.r = b[i__3].r, temp.i = b[i__3].i;
i__3 = b_subscr(i__ + 1, j);
i__4 = b_subscr(i__, j);
q__2.r = x.r * temp.r - x.i * temp.i, q__2.i = x.r *
temp.i + x.i * temp.r;
q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i - q__2.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
i__3 = b_subscr(i__, j);
b[i__3].r = temp.r, b[i__3].i = temp.i;
/* L40: */
}
} else {
/* Eliminate without interchange. */
i__2 = b_subscr(i__, i__);
if (b[i__2].r == 0.f && b[i__2].i == 0.f) {
i__3 = b_subscr(i__, i__);
b[i__3].r = *eps3, b[i__3].i = 0.f;
}
cladiv_(&q__1, &ei, &b_ref(i__, i__));
x.r = q__1.r, x.i = q__1.i;
if (x.r != 0.f || x.i != 0.f) {
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = b_subscr(i__ + 1, j);
i__4 = b_subscr(i__ + 1, j);
i__5 = b_subscr(i__, j);
q__2.r = x.r * b[i__5].r - x.i * b[i__5].i, q__2.i =
x.r * b[i__5].i + x.i * b[i__5].r;
q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i -
q__2.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L50: */
}
}
}
/* L60: */
}
i__1 = b_subscr(*n, *n);
if (b[i__1].r == 0.f && b[i__1].i == 0.f) {
i__2 = b_subscr(*n, *n);
b[i__2].r = *eps3, b[i__2].i = 0.f;
}
*(unsigned char *)trans = 'N';
} else {
/* UL decomposition with partial pivoting of B, replacing zero
pivots by EPS3. */
for (j = *n; j >= 2; --j) {
i__1 = h___subscr(j, j - 1);
ej.r = h__[i__1].r, ej.i = h__[i__1].i;
i__1 = b_subscr(j, j);
if ((r__1 = b[i__1].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(j, j)),
dabs(r__2)) < (r__3 = ej.r, dabs(r__3)) + (r__4 = r_imag(
&ej), dabs(r__4))) {
/* Interchange columns and eliminate. */
cladiv_(&q__1, &b_ref(j, j), &ej);
x.r = q__1.r, x.i = q__1.i;
i__1 = b_subscr(j, j);
b[i__1].r = ej.r, b[i__1].i = ej.i;
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = b_subscr(i__, j - 1);
temp.r = b[i__2].r, temp.i = b[i__2].i;
i__2 = b_subscr(i__, j - 1);
i__3 = b_subscr(i__, j);
q__2.r = x.r * temp.r - x.i * temp.i, q__2.i = x.r *
temp.i + x.i * temp.r;
q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = b_subscr(i__, j);
b[i__2].r = temp.r, b[i__2].i = temp.i;
/* L70: */
}
} else {
/* Eliminate without interchange. */
i__1 = b_subscr(j, j);
if (b[i__1].r == 0.f && b[i__1].i == 0.f) {
i__2 = b_subscr(j, j);
b[i__2].r = *eps3, b[i__2].i = 0.f;
}
cladiv_(&q__1, &ej, &b_ref(j, j));
x.r = q__1.r, x.i = q__1.i;
if (x.r != 0.f || x.i != 0.f) {
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = b_subscr(i__, j - 1);
i__3 = b_subscr(i__, j - 1);
i__4 = b_subscr(i__, j);
q__2.r = x.r * b[i__4].r - x.i * b[i__4].i, q__2.i =
x.r * b[i__4].i + x.i * b[i__4].r;
q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i -
q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L80: */
}
}
}
/* L90: */
}
i__1 = b_subscr(1, 1);
if (b[i__1].r == 0.f && b[i__1].i == 0.f) {
i__2 = b_subscr(1, 1);
b[i__2].r = *eps3, b[i__2].i = 0.f;
}
*(unsigned char *)trans = 'C';
}
*(unsigned char *)normin = 'N';
i__1 = *n;
for (its = 1; its <= i__1; ++its) {
/* Solve U*x = scale*v for a right eigenvector
or U'*x = scale*v for a left eigenvector,
overwriting x on v. */
clatrs_("Upper", trans, "Nonunit", normin, n, &b[b_offset], ldb, &v[1]
, &scale, &rwork[1], &ierr);
*(unsigned char *)normin = 'Y';
/* Test for sufficient growth in the norm of v. */
vnorm = scasum_(n, &v[1], &c__1);
if (vnorm >= growto * scale) {
goto L120;
}
/* Choose new orthogonal starting vector and try again. */
rtemp = *eps3 / (rootn + 1.f);
v[1].r = *eps3, v[1].i = 0.f;
i__2 = *n;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = i__;
v[i__3].r = rtemp, v[i__3].i = 0.f;
/* L100: */
}
i__2 = *n - its + 1;
i__3 = *n - its + 1;
r__1 = *eps3 * rootn;
q__1.r = v[i__3].r - r__1, q__1.i = v[i__3].i;
v[i__2].r = q__1.r, v[i__2].i = q__1.i;
/* L110: */
}
/* Failure to find eigenvector in N iterations. */
*info = 1;
L120:
/* Normalize eigenvector. */
i__ = icamax_(n, &v[1], &c__1);
i__1 = i__;
r__3 = 1.f / ((r__1 = v[i__1].r, dabs(r__1)) + (r__2 = r_imag(&v[i__]),
dabs(r__2)));
csscal_(n, &r__3, &v[1], &c__1);
return 0;
/* End of CLAEIN */
} /* claein_ */
/* Subroutine */ int ctrsyl_(char *trana, char *tranb, integer *isgn, integer
*m, integer *n, complex *a, integer *lda, complex *b, integer *ldb,
complex *c__, integer *ldc, real *scale, 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
=======
CTRSYL solves the complex Sylvester matrix equation:
op(A)*X + X*op(B) = scale*C or
op(A)*X - X*op(B) = scale*C,
where op(A) = A or A**H, and A and B are both upper triangular. A is
M-by-M and B is N-by-N; the right hand side C and the solution X are
M-by-N; and scale is an output scale factor, set <= 1 to avoid
overflow in X.
Arguments
=========
TRANA (input) CHARACTER*1
Specifies the option op(A):
= 'N': op(A) = A (No transpose)
= 'C': op(A) = A**H (Conjugate transpose)
TRANB (input) CHARACTER*1
Specifies the option op(B):
= 'N': op(B) = B (No transpose)
= 'C': op(B) = B**H (Conjugate transpose)
ISGN (input) INTEGER
Specifies the sign in the equation:
= +1: solve op(A)*X + X*op(B) = scale*C
= -1: solve op(A)*X - X*op(B) = scale*C
M (input) INTEGER
The order of the matrix A, and the number of rows in the
matrices X and C. M >= 0.
N (input) INTEGER
The order of the matrix B, and the number of columns in the
matrices X and C. N >= 0.
A (input) COMPLEX array, dimension (LDA,M)
The upper triangular matrix A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
B (input) COMPLEX array, dimension (LDB,N)
The upper triangular matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
C (input/output) COMPLEX array, dimension (LDC,N)
On entry, the M-by-N right hand side matrix C.
On exit, C is overwritten by the solution matrix X.
LDC (input) INTEGER
The leading dimension of the array C. LDC >= max(1,M)
SCALE (output) REAL
The scale factor, scale, set <= 1 to avoid overflow in X.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
= 1: A and B have common or very close eigenvalues; perturbed
values were used to solve the equation (but the matrices
A and B are unchanged).
=====================================================================
Decode and Test input parameters
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
i__3, i__4;
real r__1, r__2;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
static real smin;
static complex suml, sumr;
static integer j, k, l;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer
*, complex *, integer *);
static complex a11;
static real db;
extern /* Subroutine */ int slabad_(real *, real *);
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *);
static complex x11;
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
static real scaloc;
extern doublereal slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), xerbla_(char *, integer *);
static real bignum;
static logical notrna, notrnb;
static real smlnum, da11;
static complex vec;
static real dum[1], eps, sgn;
#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 c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1
#define c___ref(a_1,a_2) c__[c___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;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
/* Function Body */
notrna = lsame_(trana, "N");
notrnb = lsame_(tranb, "N");
*info = 0;
if (! notrna && ! lsame_(trana, "T") && ! lsame_(
trana, "C")) {
*info = -1;
} else if (! notrnb && ! lsame_(tranb, "T") && !
lsame_(tranb, "C")) {
*info = -2;
} else if (*isgn != 1 && *isgn != -1) {
*info = -3;
} else if (*m < 0) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*m)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldc < max(1,*m)) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTRSYL", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
/* Set constants to control overflow */
eps = slamch_("P");
smlnum = slamch_("S");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum = smlnum * (real) (*m * *n) / eps;
bignum = 1.f / smlnum;
/* Computing MAX */
r__1 = smlnum, r__2 = eps * clange_("M", m, m, &a[a_offset], lda, dum), r__1 = max(r__1,r__2), r__2 = eps * clange_("M", n, n,
&b[b_offset], ldb, dum);
smin = dmax(r__1,r__2);
*scale = 1.f;
sgn = (real) (*isgn);
if (notrna && notrnb) {
/* Solve A*X + ISGN*X*B = scale*C.
The (K,L)th block of X is determined starting from
bottom-left corner column by column by
A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
Where
M L-1
R(K,L) = SUM [A(K,I)*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)].
I=K+1 J=1 */
i__1 = *n;
for (l = 1; l <= i__1; ++l) {
for (k = *m; k >= 1; --k) {
/* Computing MIN */
i__2 = k + 1;
/* Computing MIN */
i__3 = k + 1;
i__4 = *m - k;
cdotu_(&q__1, &i__4, &a_ref(k, min(i__2,*m)), lda, &c___ref(
min(i__3,*m), l), &c__1);
suml.r = q__1.r, suml.i = q__1.i;
i__2 = l - 1;
cdotu_(&q__1, &i__2, &c___ref(k, 1), ldc, &b_ref(1, l), &c__1)
;
sumr.r = q__1.r, sumr.i = q__1.i;
i__2 = c___subscr(k, l);
q__3.r = sgn * sumr.r, q__3.i = sgn * sumr.i;
q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
q__1.r = c__[i__2].r - q__2.r, q__1.i = c__[i__2].i - q__2.i;
vec.r = q__1.r, vec.i = q__1.i;
scaloc = 1.f;
i__2 = a_subscr(k, k);
i__3 = b_subscr(l, l);
q__2.r = sgn * b[i__3].r, q__2.i = sgn * b[i__3].i;
q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i;
a11.r = q__1.r, a11.i = q__1.i;
da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
dabs(r__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.f;
da11 = smin;
*info = 1;
}
db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
r__2));
if (da11 < 1.f && db > 1.f) {
if (db > bignum * da11) {
scaloc = 1.f / db;
}
}
q__3.r = scaloc, q__3.i = 0.f;
q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
q__3.i + vec.i * q__3.r;
cladiv_(&q__1, &q__2, &a11);
x11.r = q__1.r, x11.i = q__1.i;
if (scaloc != 1.f) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
csscal_(m, &scaloc, &c___ref(1, j), &c__1);
/* L10: */
}
*scale *= scaloc;
}
i__2 = c___subscr(k, l);
c__[i__2].r = x11.r, c__[i__2].i = x11.i;
/* L20: */
}
/* L30: */
}
} else if (! notrna && notrnb) {
/* Solve A' *X + ISGN*X*B = scale*C.
The (K,L)th block of X is determined starting from
upper-left corner column by column by
A'(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
Where
K-1 L-1
R(K,L) = SUM [A'(I,K)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)]
I=1 J=1 */
i__1 = *n;
for (l = 1; l <= i__1; ++l) {
i__2 = *m;
for (k = 1; k <= i__2; ++k) {
i__3 = k - 1;
cdotc_(&q__1, &i__3, &a_ref(1, k), &c__1, &c___ref(1, l), &
c__1);
suml.r = q__1.r, suml.i = q__1.i;
i__3 = l - 1;
cdotu_(&q__1, &i__3, &c___ref(k, 1), ldc, &b_ref(1, l), &c__1)
;
sumr.r = q__1.r, sumr.i = q__1.i;
i__3 = c___subscr(k, l);
q__3.r = sgn * sumr.r, q__3.i = sgn * sumr.i;
q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
vec.r = q__1.r, vec.i = q__1.i;
scaloc = 1.f;
r_cnjg(&q__2, &a_ref(k, k));
i__3 = b_subscr(l, l);
q__3.r = sgn * b[i__3].r, q__3.i = sgn * b[i__3].i;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
a11.r = q__1.r, a11.i = q__1.i;
da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
dabs(r__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.f;
da11 = smin;
*info = 1;
}
db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
r__2));
if (da11 < 1.f && db > 1.f) {
if (db > bignum * da11) {
scaloc = 1.f / db;
}
}
q__3.r = scaloc, q__3.i = 0.f;
q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
q__3.i + vec.i * q__3.r;
cladiv_(&q__1, &q__2, &a11);
x11.r = q__1.r, x11.i = q__1.i;
if (scaloc != 1.f) {
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
csscal_(m, &scaloc, &c___ref(1, j), &c__1);
/* L40: */
}
*scale *= scaloc;
}
i__3 = c___subscr(k, l);
c__[i__3].r = x11.r, c__[i__3].i = x11.i;
/* L50: */
}
/* L60: */
}
} else if (! notrna && ! notrnb) {
/* Solve A'*X + ISGN*X*B' = C.
The (K,L)th block of X is determined starting from
upper-right corner column by column by
A'(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L)
Where
K-1
R(K,L) = SUM [A'(I,K)*X(I,L)] +
I=1
N
ISGN*SUM [X(K,J)*B'(L,J)].
J=L+1 */
for (l = *n; l >= 1; --l) {
i__1 = *m;
for (k = 1; k <= i__1; ++k) {
i__2 = k - 1;
cdotc_(&q__1, &i__2, &a_ref(1, k), &c__1, &c___ref(1, l), &
c__1);
suml.r = q__1.r, suml.i = q__1.i;
/* Computing MIN */
i__2 = l + 1;
/* Computing MIN */
i__3 = l + 1;
i__4 = *n - l;
cdotc_(&q__1, &i__4, &c___ref(k, min(i__2,*n)), ldc, &b_ref(l,
min(i__3,*n)), ldb);
sumr.r = q__1.r, sumr.i = q__1.i;
i__2 = c___subscr(k, l);
r_cnjg(&q__4, &sumr);
q__3.r = sgn * q__4.r, q__3.i = sgn * q__4.i;
q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
q__1.r = c__[i__2].r - q__2.r, q__1.i = c__[i__2].i - q__2.i;
vec.r = q__1.r, vec.i = q__1.i;
scaloc = 1.f;
i__2 = a_subscr(k, k);
i__3 = b_subscr(l, l);
q__3.r = sgn * b[i__3].r, q__3.i = sgn * b[i__3].i;
q__2.r = a[i__2].r + q__3.r, q__2.i = a[i__2].i + q__3.i;
r_cnjg(&q__1, &q__2);
a11.r = q__1.r, a11.i = q__1.i;
da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
dabs(r__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.f;
da11 = smin;
*info = 1;
}
db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
r__2));
if (da11 < 1.f && db > 1.f) {
if (db > bignum * da11) {
scaloc = 1.f / db;
}
}
q__3.r = scaloc, q__3.i = 0.f;
q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
q__3.i + vec.i * q__3.r;
cladiv_(&q__1, &q__2, &a11);
x11.r = q__1.r, x11.i = q__1.i;
if (scaloc != 1.f) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
csscal_(m, &scaloc, &c___ref(1, j), &c__1);
/* L70: */
}
*scale *= scaloc;
}
i__2 = c___subscr(k, l);
c__[i__2].r = x11.r, c__[i__2].i = x11.i;
/* L80: */
}
/* L90: */
}
} else if (notrna && ! notrnb) {
/* Solve A*X + ISGN*X*B' = C.
The (K,L)th block of X is determined starting from
bottom-left corner column by column by
A(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L)
Where
M N
R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B'(L,J)]
I=K+1 J=L+1 */
for (l = *n; l >= 1; --l) {
for (k = *m; k >= 1; --k) {
/* Computing MIN */
i__1 = k + 1;
/* Computing MIN */
i__2 = k + 1;
i__3 = *m - k;
cdotu_(&q__1, &i__3, &a_ref(k, min(i__1,*m)), lda, &c___ref(
min(i__2,*m), l), &c__1);
suml.r = q__1.r, suml.i = q__1.i;
/* Computing MIN */
i__1 = l + 1;
/* Computing MIN */
i__2 = l + 1;
i__3 = *n - l;
cdotc_(&q__1, &i__3, &c___ref(k, min(i__1,*n)), ldc, &b_ref(l,
min(i__2,*n)), ldb);
sumr.r = q__1.r, sumr.i = q__1.i;
i__1 = c___subscr(k, l);
r_cnjg(&q__4, &sumr);
q__3.r = sgn * q__4.r, q__3.i = sgn * q__4.i;
q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
q__1.r = c__[i__1].r - q__2.r, q__1.i = c__[i__1].i - q__2.i;
vec.r = q__1.r, vec.i = q__1.i;
scaloc = 1.f;
i__1 = a_subscr(k, k);
r_cnjg(&q__3, &b_ref(l, l));
q__2.r = sgn * q__3.r, q__2.i = sgn * q__3.i;
q__1.r = a[i__1].r + q__2.r, q__1.i = a[i__1].i + q__2.i;
a11.r = q__1.r, a11.i = q__1.i;
da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
dabs(r__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.f;
da11 = smin;
*info = 1;
}
db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
r__2));
if (da11 < 1.f && db > 1.f) {
if (db > bignum * da11) {
scaloc = 1.f / db;
}
}
q__3.r = scaloc, q__3.i = 0.f;
q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
q__3.i + vec.i * q__3.r;
cladiv_(&q__1, &q__2, &a11);
x11.r = q__1.r, x11.i = q__1.i;
if (scaloc != 1.f) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
csscal_(m, &scaloc, &c___ref(1, j), &c__1);
/* L100: */
}
*scale *= scaloc;
}
i__1 = c___subscr(k, l);
c__[i__1].r = x11.r, c__[i__1].i = x11.i;
/* L110: */
}
/* L120: */
}
}
return 0;
/* End of CTRSYL */
} /* ctrsyl_ */
/* Subroutine */
int clarfgp_(integer *n, complex *alpha, complex *x, integer *incx, complex *tau)
{
/* System generated locals */
integer i__1, i__2;
real r__1, r__2;
complex q__1, q__2;
/* Builtin functions */
double r_imag(complex *), r_sign(real *, real *), c_abs(complex *);
/* Local variables */
integer j;
complex savealpha;
integer knt;
real beta;
extern /* Subroutine */
int cscal_(integer *, complex *, complex *, integer *);
real alphi, alphr, xnorm;
extern real scnrm2_(integer *, complex *, integer *), slapy2_(real *, real *), slapy3_(real *, real *, real *);
extern /* Complex */
VOID cladiv_(complex *, complex *, complex *);
extern real slamch_(char *);
extern /* Subroutine */
int csscal_(integer *, real *, complex *, integer *);
real bignum, smlnum;
/* -- LAPACK auxiliary routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--x;
/* Function Body */
if (*n <= 0)
{
tau->r = 0.f, tau->i = 0.f;
return 0;
}
i__1 = *n - 1;
xnorm = scnrm2_(&i__1, &x[1], incx);
alphr = alpha->r;
alphi = r_imag(alpha);
if (xnorm == 0.f)
{
/* H = [1-alpha/f2c_abs(alpha) 0;
0 I], sign chosen so ALPHA >= 0. */
if (alphi == 0.f)
{
if (alphr >= 0.f)
{
/* When TAU.eq.ZERO, the vector is special-cased to be */
/* all zeros in the application routines. We do not need */
/* to clear it. */
tau->r = 0.f, tau->i = 0.f;
}
else
{
/* However, the application routines rely on explicit */
/* zero checks when TAU.ne.ZERO, and we must clear X. */
tau->r = 2.f, tau->i = 0.f;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.f;
x[i__2].i = 0.f; // , expr subst
}
q__1.r = -alpha->r;
q__1.i = -alpha->i; // , expr subst
alpha->r = q__1.r, alpha->i = q__1.i;
}
}
else
{
/* Only "reflecting" the diagonal entry to be real and non-negative. */
xnorm = slapy2_(&alphr, &alphi);
r__1 = 1.f - alphr / xnorm;
r__2 = -alphi / xnorm;
q__1.r = r__1;
q__1.i = r__2; // , expr subst
tau->r = q__1.r, tau->i = q__1.i;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.f;
x[i__2].i = 0.f; // , expr subst
}
alpha->r = xnorm, alpha->i = 0.f;
}
}
else
{
/* general case */
r__1 = slapy3_(&alphr, &alphi, &xnorm);
beta = r_sign(&r__1, &alphr);
smlnum = slamch_("S") / slamch_("E");
bignum = 1.f / smlnum;
knt = 0;
if (f2c_abs(beta) < smlnum)
{
/* XNORM, BETA may be inaccurate;
scale X and recompute them */
L10:
++knt;
i__1 = *n - 1;
csscal_(&i__1, &bignum, &x[1], incx);
beta *= bignum;
alphi *= bignum;
alphr *= bignum;
if (f2c_abs(beta) < smlnum)
{
goto L10;
}
/* New BETA is at most 1, at least SMLNUM */
i__1 = *n - 1;
xnorm = scnrm2_(&i__1, &x[1], incx);
q__1.r = alphr;
q__1.i = alphi; // , expr subst
alpha->r = q__1.r, alpha->i = q__1.i;
r__1 = slapy3_(&alphr, &alphi, &xnorm);
beta = r_sign(&r__1, &alphr);
}
savealpha.r = alpha->r;
savealpha.i = alpha->i; // , expr subst
q__1.r = alpha->r + beta;
q__1.i = alpha->i; // , expr subst
alpha->r = q__1.r, alpha->i = q__1.i;
if (beta < 0.f)
{
beta = -beta;
q__2.r = -alpha->r;
q__2.i = -alpha->i; // , expr subst
q__1.r = q__2.r / beta;
q__1.i = q__2.i / beta; // , expr subst
tau->r = q__1.r, tau->i = q__1.i;
}
else
{
alphr = alphi * (alphi / alpha->r);
alphr += xnorm * (xnorm / alpha->r);
r__1 = alphr / beta;
r__2 = -alphi / beta;
q__1.r = r__1;
q__1.i = r__2; // , expr subst
tau->r = q__1.r, tau->i = q__1.i;
r__1 = -alphr;
q__1.r = r__1;
q__1.i = alphi; // , expr subst
alpha->r = q__1.r, alpha->i = q__1.i;
}
cladiv_(&q__1, &c_b5, alpha);
alpha->r = q__1.r, alpha->i = q__1.i;
if (c_abs(tau) <= smlnum)
{
/* In the case where the computed TAU ends up being a denormalized number, */
/* it loses relative accuracy. This is a BIG problem. Solution: flush TAU */
/* to ZERO (or TWO or whatever makes a nonnegative real number for BETA). */
/* (Bug report provided by Pat Quillen from MathWorks on Jul 29, 2009.) */
/* (Thanks Pat. Thanks MathWorks.) */
alphr = savealpha.r;
alphi = r_imag(&savealpha);
if (alphi == 0.f)
{
if (alphr >= 0.f)
{
tau->r = 0.f, tau->i = 0.f;
}
else
{
tau->r = 2.f, tau->i = 0.f;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.f;
x[i__2].i = 0.f; // , expr subst
}
q__1.r = -savealpha.r;
q__1.i = -savealpha.i; // , expr subst
beta = q__1.r;
}
}
else
{
xnorm = slapy2_(&alphr, &alphi);
r__1 = 1.f - alphr / xnorm;
r__2 = -alphi / xnorm;
q__1.r = r__1;
q__1.i = r__2; // , expr subst
tau->r = q__1.r, tau->i = q__1.i;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.f;
x[i__2].i = 0.f; // , expr subst
}
beta = xnorm;
}
}
else
{
/* This is the general case. */
i__1 = *n - 1;
cscal_(&i__1, alpha, &x[1], incx);
}
/* If BETA is subnormal, it may lose relative accuracy */
i__1 = knt;
for (j = 1;
j <= i__1;
++j)
{
beta *= smlnum;
/* L20: */
}
alpha->r = beta, alpha->i = 0.f;
}
return 0;
/* End of CLARFGP */
}
/* Subroutine */ int clarfp_(integer *n, complex *alpha, complex *x, integer *
incx, complex *tau)
{
/* System generated locals */
integer i__1, i__2;
real r__1, r__2;
complex q__1, q__2;
/* Builtin functions */
double r_imag(complex *), r_sign(real *, real *);
/* Local variables */
integer j, knt;
real beta;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
real alphi, alphr, xnorm;
extern doublereal scnrm2_(integer *, complex *, integer *), slapy2_(real *
, real *), slapy3_(real *, real *, real *);
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*);
real safmin, rsafmn;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLARFP generates a complex elementary reflector H of order n, such */
/* that */
/* H' * ( alpha ) = ( beta ), H' * H = I. */
/* ( x ) ( 0 ) */
/* where alpha and beta are scalars, beta is real and non-negative, and */
/* x is an (n-1)-element complex vector. H is represented in the form */
/* H = I - tau * ( 1 ) * ( 1 v' ) , */
/* ( v ) */
/* where tau is a complex scalar and v is a complex (n-1)-element */
/* vector. Note that H is not hermitian. */
/* If the elements of x are all zero and alpha is real, then tau = 0 */
/* and H is taken to be the unit matrix. */
/* Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 . */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the elementary reflector. */
/* ALPHA (input/output) COMPLEX */
/* On entry, the value alpha. */
/* On exit, it is overwritten with the value beta. */
/* X (input/output) COMPLEX array, dimension */
/* (1+(N-2)*abs(INCX)) */
/* On entry, the vector x. */
/* On exit, it is overwritten with the vector v. */
/* INCX (input) INTEGER */
/* The increment between elements of X. INCX > 0. */
/* TAU (output) COMPLEX */
/* The value tau. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--x;
/* Function Body */
if (*n <= 0) {
tau->r = 0.f, tau->i = 0.f;
return 0;
}
i__1 = *n - 1;
xnorm = scnrm2_(&i__1, &x[1], incx);
alphr = alpha->r;
alphi = r_imag(alpha);
if (xnorm == 0.f && alphi == 0.f) {
/* H = [1-alpha/abs(alpha) 0; 0 I], sign chosen so ALPHA >= 0. */
if (alphi == 0.f) {
if (alphr >= 0.f) {
/* When TAU.eq.ZERO, the vector is special-cased to be */
/* all zeros in the application routines. We do not need */
/* to clear it. */
tau->r = 0.f, tau->i = 0.f;
} else {
/* However, the application routines rely on explicit */
/* zero checks when TAU.ne.ZERO, and we must clear X. */
tau->r = 2.f, tau->i = 0.f;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.f, x[i__2].i = 0.f;
}
q__1.r = -alpha->r, q__1.i = -alpha->i;
alpha->r = q__1.r, alpha->i = q__1.i;
}
} else {
/* Only "reflecting" the diagonal entry to be real and non-negative. */
xnorm = slapy2_(&alphr, &alphi);
r__1 = 1.f - alphr / xnorm;
r__2 = -alphi / xnorm;
q__1.r = r__1, q__1.i = r__2;
tau->r = q__1.r, tau->i = q__1.i;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.f, x[i__2].i = 0.f;
}
alpha->r = xnorm, alpha->i = 0.f;
}
} else {
/* general case */
r__1 = slapy3_(&alphr, &alphi, &xnorm);
beta = r_sign(&r__1, &alphr);
safmin = slamch_("S") / slamch_("E");
rsafmn = 1.f / safmin;
knt = 0;
if (dabs(beta) < safmin) {
/* XNORM, BETA may be inaccurate; scale X and recompute them */
L10:
++knt;
i__1 = *n - 1;
csscal_(&i__1, &rsafmn, &x[1], incx);
beta *= rsafmn;
alphi *= rsafmn;
alphr *= rsafmn;
if (dabs(beta) < safmin) {
goto L10;
}
/* New BETA is at most 1, at least SAFMIN */
i__1 = *n - 1;
xnorm = scnrm2_(&i__1, &x[1], incx);
q__1.r = alphr, q__1.i = alphi;
alpha->r = q__1.r, alpha->i = q__1.i;
r__1 = slapy3_(&alphr, &alphi, &xnorm);
beta = r_sign(&r__1, &alphr);
}
q__1.r = alpha->r + beta, q__1.i = alpha->i;
alpha->r = q__1.r, alpha->i = q__1.i;
if (beta < 0.f) {
beta = -beta;
q__2.r = -alpha->r, q__2.i = -alpha->i;
q__1.r = q__2.r / beta, q__1.i = q__2.i / beta;
tau->r = q__1.r, tau->i = q__1.i;
} else {
alphr = alphi * (alphi / alpha->r);
alphr += xnorm * (xnorm / alpha->r);
r__1 = alphr / beta;
r__2 = -alphi / beta;
q__1.r = r__1, q__1.i = r__2;
tau->r = q__1.r, tau->i = q__1.i;
r__1 = -alphr;
q__1.r = r__1, q__1.i = alphi;
alpha->r = q__1.r, alpha->i = q__1.i;
}
cladiv_(&q__1, &c_b5, alpha);
alpha->r = q__1.r, alpha->i = q__1.i;
i__1 = *n - 1;
cscal_(&i__1, alpha, &x[1], incx);
/* If BETA is subnormal, it may lose relative accuracy */
i__1 = knt;
for (j = 1; j <= i__1; ++j) {
beta *= safmin;
/* L20: */
}
alpha->r = beta, alpha->i = 0.f;
}
return 0;
/* End of CLARFP */
} /* clarfp_ */
int claein_(int *rightv, int *noinit, int *n,
complex *h__, int *ldh, complex *w, complex *v, complex *b,
int *ldb, float *rwork, float *eps3, float *smlnum, int *info)
{
/* System generated locals */
int b_dim1, b_offset, h_dim1, h_offset, i__1, i__2, i__3, i__4, i__5;
float r__1, r__2, r__3, r__4;
complex q__1, q__2;
/* Builtin functions */
double sqrt(double), r_imag(complex *);
/* Local variables */
int i__, j;
complex x, ei, ej;
int its, ierr;
complex temp;
float scale;
char trans[1];
float rtemp, rootn, vnorm;
extern double scnrm2_(int *, complex *, int *);
extern int icamax_(int *, complex *, int *);
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
extern int csscal_(int *, float *, complex *, int
*), clatrs_(char *, char *, char *, char *, int *, complex *,
int *, complex *, float *, float *, int *);
extern double scasum_(int *, complex *, int *);
char normin[1];
float nrmsml, growto;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLAEIN uses inverse iteration to find a right or left eigenvector */
/* corresponding to the eigenvalue W of a complex upper Hessenberg */
/* matrix H. */
/* Arguments */
/* ========= */
/* RIGHTV (input) LOGICAL */
/* = .TRUE. : compute right eigenvector; */
/* = .FALSE.: compute left eigenvector. */
/* NOINIT (input) LOGICAL */
/* = .TRUE. : no initial vector supplied in V */
/* = .FALSE.: initial vector supplied in V. */
/* N (input) INTEGER */
/* The order of the matrix H. N >= 0. */
/* H (input) COMPLEX array, dimension (LDH,N) */
/* The upper Hessenberg matrix H. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH >= MAX(1,N). */
/* W (input) COMPLEX */
/* The eigenvalue of H whose corresponding right or left */
/* eigenvector is to be computed. */
/* V (input/output) COMPLEX array, dimension (N) */
/* On entry, if NOINIT = .FALSE., V must contain a starting */
/* vector for inverse iteration; otherwise V need not be set. */
/* On exit, V contains the computed eigenvector, normalized so */
/* that the component of largest magnitude has magnitude 1; here */
/* the magnitude of a complex number (x,y) is taken to be */
/* |x| + |y|. */
/* B (workspace) COMPLEX array, dimension (LDB,N) */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= MAX(1,N). */
/* RWORK (workspace) REAL array, dimension (N) */
/* EPS3 (input) REAL */
/* A small machine-dependent value which is used to perturb */
/* close eigenvalues, and to replace zero pivots. */
/* SMLNUM (input) REAL */
/* A machine-dependent value close to the underflow threshold. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* = 1: inverse iteration did not converge; V is set to the */
/* last iterate. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--v;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--rwork;
/* Function Body */
*info = 0;
/* GROWTO is the threshold used in the acceptance test for an */
/* eigenvector. */
rootn = sqrt((float) (*n));
growto = .1f / rootn;
/* Computing MAX */
r__1 = 1.f, r__2 = *eps3 * rootn;
nrmsml = MAX(r__1,r__2) * *smlnum;
/* Form B = H - W*I (except that the subdiagonal elements are not */
/* stored). */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * b_dim1;
i__4 = i__ + j * h_dim1;
b[i__3].r = h__[i__4].r, b[i__3].i = h__[i__4].i;
/* L10: */
}
i__2 = j + j * b_dim1;
i__3 = j + j * h_dim1;
q__1.r = h__[i__3].r - w->r, q__1.i = h__[i__3].i - w->i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L20: */
}
if (*noinit) {
/* Initialize V. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
v[i__2].r = *eps3, v[i__2].i = 0.f;
/* L30: */
}
} else {
/* Scale supplied initial vector. */
vnorm = scnrm2_(n, &v[1], &c__1);
r__1 = *eps3 * rootn / MAX(vnorm,nrmsml);
csscal_(n, &r__1, &v[1], &c__1);
}
if (*rightv) {
/* LU decomposition with partial pivoting of B, replacing zero */
/* pivots by EPS3. */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + 1 + i__ * h_dim1;
ei.r = h__[i__2].r, ei.i = h__[i__2].i;
i__2 = i__ + i__ * b_dim1;
if ((r__1 = b[i__2].r, ABS(r__1)) + (r__2 = r_imag(&b[i__ + i__ *
b_dim1]), ABS(r__2)) < (r__3 = ei.r, ABS(r__3)) + (
r__4 = r_imag(&ei), ABS(r__4))) {
/* Interchange rows and eliminate. */
cladiv_(&q__1, &b[i__ + i__ * b_dim1], &ei);
x.r = q__1.r, x.i = q__1.i;
i__2 = i__ + i__ * b_dim1;
b[i__2].r = ei.r, b[i__2].i = ei.i;
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = i__ + 1 + j * b_dim1;
temp.r = b[i__3].r, temp.i = b[i__3].i;
i__3 = i__ + 1 + j * b_dim1;
i__4 = i__ + j * b_dim1;
q__2.r = x.r * temp.r - x.i * temp.i, q__2.i = x.r *
temp.i + x.i * temp.r;
q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i - q__2.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
i__3 = i__ + j * b_dim1;
b[i__3].r = temp.r, b[i__3].i = temp.i;
/* L40: */
}
} else {
/* Eliminate without interchange. */
i__2 = i__ + i__ * b_dim1;
if (b[i__2].r == 0.f && b[i__2].i == 0.f) {
i__3 = i__ + i__ * b_dim1;
b[i__3].r = *eps3, b[i__3].i = 0.f;
}
cladiv_(&q__1, &ei, &b[i__ + i__ * b_dim1]);
x.r = q__1.r, x.i = q__1.i;
if (x.r != 0.f || x.i != 0.f) {
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = i__ + 1 + j * b_dim1;
i__4 = i__ + 1 + j * b_dim1;
i__5 = i__ + j * b_dim1;
q__2.r = x.r * b[i__5].r - x.i * b[i__5].i, q__2.i =
x.r * b[i__5].i + x.i * b[i__5].r;
q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i -
q__2.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L50: */
}
}
}
/* L60: */
}
i__1 = *n + *n * b_dim1;
if (b[i__1].r == 0.f && b[i__1].i == 0.f) {
i__2 = *n + *n * b_dim1;
b[i__2].r = *eps3, b[i__2].i = 0.f;
}
*(unsigned char *)trans = 'N';
} else {
/* UL decomposition with partial pivoting of B, replacing zero */
/* pivots by EPS3. */
for (j = *n; j >= 2; --j) {
i__1 = j + (j - 1) * h_dim1;
ej.r = h__[i__1].r, ej.i = h__[i__1].i;
i__1 = j + j * b_dim1;
if ((r__1 = b[i__1].r, ABS(r__1)) + (r__2 = r_imag(&b[j + j *
b_dim1]), ABS(r__2)) < (r__3 = ej.r, ABS(r__3)) + (r__4
= r_imag(&ej), ABS(r__4))) {
/* Interchange columns and eliminate. */
cladiv_(&q__1, &b[j + j * b_dim1], &ej);
x.r = q__1.r, x.i = q__1.i;
i__1 = j + j * b_dim1;
b[i__1].r = ej.r, b[i__1].i = ej.i;
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + (j - 1) * b_dim1;
temp.r = b[i__2].r, temp.i = b[i__2].i;
i__2 = i__ + (j - 1) * b_dim1;
i__3 = i__ + j * b_dim1;
q__2.r = x.r * temp.r - x.i * temp.i, q__2.i = x.r *
temp.i + x.i * temp.r;
q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = i__ + j * b_dim1;
b[i__2].r = temp.r, b[i__2].i = temp.i;
/* L70: */
}
} else {
/* Eliminate without interchange. */
i__1 = j + j * b_dim1;
if (b[i__1].r == 0.f && b[i__1].i == 0.f) {
i__2 = j + j * b_dim1;
b[i__2].r = *eps3, b[i__2].i = 0.f;
}
cladiv_(&q__1, &ej, &b[j + j * b_dim1]);
x.r = q__1.r, x.i = q__1.i;
if (x.r != 0.f || x.i != 0.f) {
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + (j - 1) * b_dim1;
i__3 = i__ + (j - 1) * b_dim1;
i__4 = i__ + j * b_dim1;
q__2.r = x.r * b[i__4].r - x.i * b[i__4].i, q__2.i =
x.r * b[i__4].i + x.i * b[i__4].r;
q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i -
q__2.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L80: */
}
}
}
/* L90: */
}
i__1 = b_dim1 + 1;
if (b[i__1].r == 0.f && b[i__1].i == 0.f) {
i__2 = b_dim1 + 1;
b[i__2].r = *eps3, b[i__2].i = 0.f;
}
*(unsigned char *)trans = 'C';
}
*(unsigned char *)normin = 'N';
i__1 = *n;
for (its = 1; its <= i__1; ++its) {
/* Solve U*x = scale*v for a right eigenvector */
/* or U'*x = scale*v for a left eigenvector, */
/* overwriting x on v. */
clatrs_("Upper", trans, "Nonunit", normin, n, &b[b_offset], ldb, &v[1]
, &scale, &rwork[1], &ierr);
*(unsigned char *)normin = 'Y';
/* Test for sufficient growth in the norm of v. */
vnorm = scasum_(n, &v[1], &c__1);
if (vnorm >= growto * scale) {
goto L120;
}
/* Choose new orthogonal starting vector and try again. */
rtemp = *eps3 / (rootn + 1.f);
v[1].r = *eps3, v[1].i = 0.f;
i__2 = *n;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = i__;
v[i__3].r = rtemp, v[i__3].i = 0.f;
/* L100: */
}
i__2 = *n - its + 1;
i__3 = *n - its + 1;
r__1 = *eps3 * rootn;
q__1.r = v[i__3].r - r__1, q__1.i = v[i__3].i;
v[i__2].r = q__1.r, v[i__2].i = q__1.i;
/* L110: */
}
/* Failure to find eigenvector in N iterations. */
*info = 1;
L120:
/* Normalize eigenvector. */
i__ = icamax_(n, &v[1], &c__1);
i__1 = i__;
r__3 = 1.f / ((r__1 = v[i__1].r, ABS(r__1)) + (r__2 = r_imag(&v[i__]),
ABS(r__2)));
csscal_(n, &r__3, &v[1], &c__1);
return 0;
/* End of CLAEIN */
} /* claein_ */
/* Subroutine */
int clatps_(char *uplo, char *trans, char *diag, char * normin, integer *n, complex *ap, complex *x, real *scale, real *cnorm, integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
integer i__, j, ip;
real xj, rec, tjj;
integer jinc, jlen;
real xbnd;
integer imax;
real tmax;
complex tjjs;
real xmax, grow;
extern /* Complex */
VOID cdotc_f2c_(complex *, integer *, complex *, integer *, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */
int sscal_(integer *, real *, real *, integer *);
real tscal;
complex uscal;
integer jlast;
extern /* Complex */
VOID cdotu_f2c_(complex *, integer *, complex *, integer *, complex *, integer *);
complex csumj;
extern /* Subroutine */
int caxpy_(integer *, complex *, complex *, integer *, complex *, integer *);
logical upper;
extern /* Subroutine */
int ctpsv_(char *, char *, char *, integer *, complex *, complex *, integer *), slabad_( real *, real *);
extern integer icamax_(integer *, complex *, integer *);
extern /* Complex */
VOID cladiv_(complex *, complex *, complex *);
extern real slamch_(char *);
extern /* Subroutine */
int csscal_(integer *, real *, complex *, integer *), xerbla_(char *, integer *);
real bignum;
extern integer isamax_(integer *, real *, integer *);
extern real scasum_(integer *, complex *, integer *);
logical notran;
integer jfirst;
real smlnum;
logical nounit;
/* -- LAPACK auxiliary routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--cnorm;
--x;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
/* Test the input parameters. */
if (! upper && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (! notran && ! lsame_(trans, "T") && ! lsame_(trans, "C"))
{
*info = -2;
}
else if (! nounit && ! lsame_(diag, "U"))
{
*info = -3;
}
else if (! lsame_(normin, "Y") && ! lsame_(normin, "N"))
{
*info = -4;
}
else if (*n < 0)
{
*info = -5;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CLATPS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
return 0;
}
/* Determine machine dependent parameters to control overflow. */
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum /= slamch_("Precision");
bignum = 1.f / smlnum;
*scale = 1.f;
if (lsame_(normin, "N"))
{
/* Compute the 1-norm of each column, not including the diagonal. */
if (upper)
{
/* A is upper triangular. */
ip = 1;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = j - 1;
cnorm[j] = scasum_(&i__2, &ap[ip], &c__1);
ip += j;
/* L10: */
}
}
else
{
/* A is lower triangular. */
ip = 1;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n - j;
cnorm[j] = scasum_(&i__2, &ap[ip + 1], &c__1);
ip = ip + *n - j + 1;
/* L20: */
}
cnorm[*n] = 0.f;
}
}
/* Scale the column norms by TSCAL if the maximum element in CNORM is */
/* greater than BIGNUM/2. */
imax = isamax_(n, &cnorm[1], &c__1);
tmax = cnorm[imax];
if (tmax <= bignum * .5f)
{
tscal = 1.f;
}
else
{
tscal = .5f / (smlnum * tmax);
sscal_(n, &tscal, &cnorm[1], &c__1);
}
/* Compute a bound on the computed solution vector to see if the */
/* Level 2 BLAS routine CTPSV can be used. */
xmax = 0.f;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MAX */
i__2 = j;
r__3 = xmax;
r__4 = (r__1 = x[i__2].r / 2.f, abs(r__1)) + (r__2 = r_imag(&x[j]) / 2.f, abs(r__2)); // , expr subst
xmax = max(r__3,r__4);
/* L30: */
}
xbnd = xmax;
if (notran)
{
/* Compute the growth in A * x = b. */
if (upper)
{
jfirst = *n;
jlast = 1;
jinc = -1;
}
else
{
jfirst = 1;
jlast = *n;
jinc = 1;
}
if (tscal != 1.f)
{
grow = 0.f;
goto L60;
}
if (nounit)
{
/* A is non-unit triangular. */
/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
/* Initially, G(0) = max{
x(i), i=1,...,n}
. */
grow = .5f / max(xbnd,smlnum);
xbnd = grow;
ip = jfirst * (jfirst + 1) / 2;
jlen = *n;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst;
i__2 < 0 ? j >= i__1 : j <= i__1;
j += i__2)
{
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum)
{
goto L60;
}
i__3 = ip;
tjjs.r = ap[i__3].r;
tjjs.i = ap[i__3].i; // , expr subst
tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs( r__2));
if (tjj >= smlnum)
{
/* M(j) = G(j-1) / abs(A(j,j)) */
/* Computing MIN */
r__1 = xbnd;
r__2 = min(1.f,tjj) * grow; // , expr subst
xbnd = min(r__1,r__2);
}
else
{
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.f;
}
if (tjj + cnorm[j] >= smlnum)
{
/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */
grow *= tjj / (tjj + cnorm[j]);
}
else
{
/* G(j) could overflow, set GROW to 0. */
grow = 0.f;
}
ip += jinc * jlen;
--jlen;
/* L40: */
}
grow = xbnd;
}
else
{
/* A is unit triangular. */
/* Compute GROW = 1/G(j), where G(0) = max{
x(i), i=1,...,n}
. */
/* Computing MIN */
r__1 = 1.f;
r__2 = .5f / max(xbnd,smlnum); // , expr subst
grow = min(r__1,r__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst;
i__1 < 0 ? j >= i__2 : j <= i__2;
j += i__1)
{
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum)
{
goto L60;
}
/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
grow *= 1.f / (cnorm[j] + 1.f);
/* L50: */
}
}
L60:
;
}
else
{
/* Compute the growth in A**T * x = b or A**H * x = b. */
if (upper)
{
jfirst = 1;
jlast = *n;
jinc = 1;
}
else
{
jfirst = *n;
jlast = 1;
jinc = -1;
}
if (tscal != 1.f)
{
grow = 0.f;
goto L90;
}
if (nounit)
{
/* A is non-unit triangular. */
/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
/* Initially, M(0) = max{
x(i), i=1,...,n}
. */
grow = .5f / max(xbnd,smlnum);
xbnd = grow;
ip = jfirst * (jfirst + 1) / 2;
jlen = 1;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst;
i__2 < 0 ? j >= i__1 : j <= i__1;
j += i__2)
{
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum)
{
goto L90;
}
/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */
xj = cnorm[j] + 1.f;
/* Computing MIN */
r__1 = grow;
r__2 = xbnd / xj; // , expr subst
grow = min(r__1,r__2);
i__3 = ip;
tjjs.r = ap[i__3].r;
tjjs.i = ap[i__3].i; // , expr subst
tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs( r__2));
if (tjj >= smlnum)
{
/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */
if (xj > tjj)
{
xbnd *= tjj / xj;
}
}
else
{
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.f;
}
++jlen;
ip += jinc * jlen;
/* L70: */
}
grow = min(grow,xbnd);
}
else
{
/* A is unit triangular. */
/* Compute GROW = 1/G(j), where G(0) = max{
x(i), i=1,...,n}
. */
/* Computing MIN */
r__1 = 1.f;
r__2 = .5f / max(xbnd,smlnum); // , expr subst
grow = min(r__1,r__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst;
i__1 < 0 ? j >= i__2 : j <= i__2;
j += i__1)
{
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum)
{
goto L90;
}
/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
xj = cnorm[j] + 1.f;
grow /= xj;
/* L80: */
}
}
L90:
;
}
if (grow * tscal > smlnum)
{
/* Use the Level 2 BLAS solve if the reciprocal of the bound on */
/* elements of X is not too small. */
ctpsv_(uplo, trans, diag, n, &ap[1], &x[1], &c__1);
}
else
{
/* Use a Level 1 BLAS solve, scaling intermediate results. */
if (xmax > bignum * .5f)
{
/* Scale X so that its components are less than or equal to */
/* BIGNUM in absolute value. */
*scale = bignum * .5f / xmax;
csscal_(n, scale, &x[1], &c__1);
xmax = bignum;
}
else
{
xmax *= 2.f;
}
if (notran)
{
/* Solve A * x = b */
ip = jfirst * (jfirst + 1) / 2;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst;
i__2 < 0 ? j >= i__1 : j <= i__1;
j += i__2)
{
/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */
i__3 = j;
xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]), abs(r__2));
if (nounit)
{
i__3 = ip;
q__1.r = tscal * ap[i__3].r;
q__1.i = tscal * ap[i__3].i; // , expr subst
tjjs.r = q__1.r;
tjjs.i = q__1.i; // , expr subst
}
else
{
tjjs.r = tscal;
tjjs.i = 0.f; // , expr subst
if (tscal == 1.f)
{
goto L105;
}
}
tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs( r__2));
if (tjj > smlnum)
{
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f)
{
if (xj > tjj * bignum)
{
/* Scale x by 1/b(j). */
rec = 1.f / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r;
x[i__3].i = q__1.i; // , expr subst
i__3 = j;
xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]) , abs(r__2));
}
else if (tjj > 0.f)
{
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum)
{
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */
/* to avoid overflow when dividing by A(j,j). */
rec = tjj * bignum / xj;
if (cnorm[j] > 1.f)
{
/* Scale by 1/CNORM(j) to avoid overflow when */
/* multiplying x(j) times column j. */
rec /= cnorm[j];
}
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r;
x[i__3].i = q__1.i; // , expr subst
i__3 = j;
xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]) , abs(r__2));
}
else
{
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0, and compute a solution to A*x = 0. */
i__3 = *n;
for (i__ = 1;
i__ <= i__3;
++i__)
{
i__4 = i__;
x[i__4].r = 0.f;
x[i__4].i = 0.f; // , expr subst
/* L100: */
}
i__3 = j;
x[i__3].r = 1.f;
x[i__3].i = 0.f; // , expr subst
xj = 1.f;
*scale = 0.f;
xmax = 0.f;
}
L105: /* Scale x if necessary to avoid overflow when adding a */
/* multiple of column j of A. */
if (xj > 1.f)
{
rec = 1.f / xj;
if (cnorm[j] > (bignum - xmax) * rec)
{
/* Scale x by 1/(2*abs(x(j))). */
rec *= .5f;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
}
else if (xj * cnorm[j] > bignum - xmax)
{
/* Scale x by 1/2. */
csscal_(n, &c_b36, &x[1], &c__1);
*scale *= .5f;
}
if (upper)
{
if (j > 1)
{
/* Compute the update */
/* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */
i__3 = j - 1;
i__4 = j;
q__2.r = -x[i__4].r;
q__2.i = -x[i__4].i; // , expr subst
q__1.r = tscal * q__2.r;
q__1.i = tscal * q__2.i; // , expr subst
caxpy_(&i__3, &q__1, &ap[ip - j + 1], &c__1, &x[1], & c__1);
i__3 = j - 1;
i__ = icamax_(&i__3, &x[1], &c__1);
i__3 = i__;
xmax = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag( &x[i__]), abs(r__2));
}
ip -= j;
}
else
{
if (j < *n)
{
/* Compute the update */
/* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */
i__3 = *n - j;
i__4 = j;
q__2.r = -x[i__4].r;
q__2.i = -x[i__4].i; // , expr subst
q__1.r = tscal * q__2.r;
q__1.i = tscal * q__2.i; // , expr subst
caxpy_(&i__3, &q__1, &ap[ip + 1], &c__1, &x[j + 1], & c__1);
i__3 = *n - j;
i__ = j + icamax_(&i__3, &x[j + 1], &c__1);
i__3 = i__;
xmax = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag( &x[i__]), abs(r__2));
}
ip = ip + *n - j + 1;
}
/* L110: */
}
}
else if (lsame_(trans, "T"))
{
/* Solve A**T * x = b */
ip = jfirst * (jfirst + 1) / 2;
jlen = 1;
i__2 = jlast;
i__1 = jinc;
for (j = jfirst;
i__1 < 0 ? j >= i__2 : j <= i__2;
j += i__1)
{
/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
/* k<>j */
i__3 = j;
xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]), abs(r__2));
uscal.r = tscal;
uscal.i = 0.f; // , expr subst
rec = 1.f / max(xmax,1.f);
if (cnorm[j] > (bignum - xj) * rec)
{
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5f;
if (nounit)
{
i__3 = ip;
q__1.r = tscal * ap[i__3].r;
q__1.i = tscal * ap[i__3] .i; // , expr subst
tjjs.r = q__1.r;
tjjs.i = q__1.i; // , expr subst
}
else
{
tjjs.r = tscal;
tjjs.i = 0.f; // , expr subst
}
tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs(r__2));
if (tjj > 1.f)
{
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
r__1 = 1.f;
r__2 = rec * tjj; // , expr subst
rec = min(r__1,r__2);
cladiv_(&q__1, &uscal, &tjjs);
uscal.r = q__1.r;
uscal.i = q__1.i; // , expr subst
}
if (rec < 1.f)
{
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0.f;
csumj.i = 0.f; // , expr subst
if (uscal.r == 1.f && uscal.i == 0.f)
{
/* If the scaling needed for A in the dot product is 1, */
/* call CDOTU to perform the dot product. */
if (upper)
{
i__3 = j - 1;
cdotu_f2c_(&q__1, &i__3, &ap[ip - j + 1], &c__1, &x[1], & c__1);
csumj.r = q__1.r;
csumj.i = q__1.i; // , expr subst
}
else if (j < *n)
{
i__3 = *n - j;
cdotu_f2c_(&q__1, &i__3, &ap[ip + 1], &c__1, &x[j + 1], & c__1);
csumj.r = q__1.r;
csumj.i = q__1.i; // , expr subst
}
}
else
{
/* Otherwise, use in-line code for the dot product. */
if (upper)
{
i__3 = j - 1;
for (i__ = 1;
i__ <= i__3;
++i__)
{
i__4 = ip - j + i__;
q__3.r = ap[i__4].r * uscal.r - ap[i__4].i * uscal.i;
q__3.i = ap[i__4].r * uscal.i + ap[i__4].i * uscal.r; // , expr subst
i__5 = i__;
q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i;
q__2.i = q__3.r * x[i__5].i + q__3.i * x[ i__5].r; // , expr subst
q__1.r = csumj.r + q__2.r;
q__1.i = csumj.i + q__2.i; // , expr subst
csumj.r = q__1.r;
csumj.i = q__1.i; // , expr subst
/* L120: */
}
}
else if (j < *n)
{
i__3 = *n - j;
for (i__ = 1;
i__ <= i__3;
++i__)
{
i__4 = ip + i__;
q__3.r = ap[i__4].r * uscal.r - ap[i__4].i * uscal.i;
q__3.i = ap[i__4].r * uscal.i + ap[i__4].i * uscal.r; // , expr subst
i__5 = j + i__;
q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i;
q__2.i = q__3.r * x[i__5].i + q__3.i * x[ i__5].r; // , expr subst
q__1.r = csumj.r + q__2.r;
q__1.i = csumj.i + q__2.i; // , expr subst
csumj.r = q__1.r;
csumj.i = q__1.i; // , expr subst
/* L130: */
}
}
}
q__1.r = tscal;
q__1.i = 0.f; // , expr subst
if (uscal.r == q__1.r && uscal.i == q__1.i)
{
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
/* was not used to scale the dotproduct. */
i__3 = j;
i__4 = j;
q__1.r = x[i__4].r - csumj.r;
q__1.i = x[i__4].i - csumj.i; // , expr subst
x[i__3].r = q__1.r;
x[i__3].i = q__1.i; // , expr subst
i__3 = j;
xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]) , abs(r__2));
if (nounit)
{
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
i__3 = ip;
q__1.r = tscal * ap[i__3].r;
q__1.i = tscal * ap[i__3] .i; // , expr subst
tjjs.r = q__1.r;
tjjs.i = q__1.i; // , expr subst
}
else
{
tjjs.r = tscal;
tjjs.i = 0.f; // , expr subst
if (tscal == 1.f)
{
goto L145;
}
}
tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs(r__2));
if (tjj > smlnum)
{
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f)
{
if (xj > tjj * bignum)
{
/* Scale X by 1/abs(x(j)). */
rec = 1.f / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r;
x[i__3].i = q__1.i; // , expr subst
}
else if (tjj > 0.f)
{
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum)
{
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r;
x[i__3].i = q__1.i; // , expr subst
}
else
{
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0 and compute a solution to A**T *x = 0. */
i__3 = *n;
for (i__ = 1;
i__ <= i__3;
++i__)
{
i__4 = i__;
x[i__4].r = 0.f;
x[i__4].i = 0.f; // , expr subst
/* L140: */
}
i__3 = j;
x[i__3].r = 1.f;
x[i__3].i = 0.f; // , expr subst
*scale = 0.f;
xmax = 0.f;
}
L145:
;
}
else
{
/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
/* product has already been divided by 1/A(j,j). */
i__3 = j;
cladiv_(&q__2, &x[j], &tjjs);
q__1.r = q__2.r - csumj.r;
q__1.i = q__2.i - csumj.i; // , expr subst
x[i__3].r = q__1.r;
x[i__3].i = q__1.i; // , expr subst
}
/* Computing MAX */
i__3 = j;
r__3 = xmax;
r__4 = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]), abs(r__2)); // , expr subst
xmax = max(r__3,r__4);
++jlen;
ip += jinc * jlen;
/* L150: */
}
}
else
{
/* Solve A**H * x = b */
ip = jfirst * (jfirst + 1) / 2;
jlen = 1;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst;
i__2 < 0 ? j >= i__1 : j <= i__1;
j += i__2)
{
/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
/* k<>j */
i__3 = j;
xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]), abs(r__2));
uscal.r = tscal;
uscal.i = 0.f; // , expr subst
rec = 1.f / max(xmax,1.f);
if (cnorm[j] > (bignum - xj) * rec)
{
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5f;
if (nounit)
{
r_cnjg(&q__2, &ap[ip]);
q__1.r = tscal * q__2.r;
q__1.i = tscal * q__2.i; // , expr subst
tjjs.r = q__1.r;
tjjs.i = q__1.i; // , expr subst
}
else
{
tjjs.r = tscal;
tjjs.i = 0.f; // , expr subst
}
tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs(r__2));
if (tjj > 1.f)
{
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
r__1 = 1.f;
r__2 = rec * tjj; // , expr subst
rec = min(r__1,r__2);
cladiv_(&q__1, &uscal, &tjjs);
uscal.r = q__1.r;
uscal.i = q__1.i; // , expr subst
}
if (rec < 1.f)
{
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0.f;
csumj.i = 0.f; // , expr subst
if (uscal.r == 1.f && uscal.i == 0.f)
{
/* If the scaling needed for A in the dot product is 1, */
/* call CDOTC to perform the dot product. */
if (upper)
{
i__3 = j - 1;
cdotc_f2c_(&q__1, &i__3, &ap[ip - j + 1], &c__1, &x[1], & c__1);
csumj.r = q__1.r;
csumj.i = q__1.i; // , expr subst
}
else if (j < *n)
{
i__3 = *n - j;
cdotc_f2c_(&q__1, &i__3, &ap[ip + 1], &c__1, &x[j + 1], & c__1);
csumj.r = q__1.r;
csumj.i = q__1.i; // , expr subst
}
}
else
{
/* Otherwise, use in-line code for the dot product. */
if (upper)
{
i__3 = j - 1;
for (i__ = 1;
i__ <= i__3;
++i__)
{
r_cnjg(&q__4, &ap[ip - j + i__]);
q__3.r = q__4.r * uscal.r - q__4.i * uscal.i;
q__3.i = q__4.r * uscal.i + q__4.i * uscal.r; // , expr subst
i__4 = i__;
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i;
q__2.i = q__3.r * x[i__4].i + q__3.i * x[ i__4].r; // , expr subst
q__1.r = csumj.r + q__2.r;
q__1.i = csumj.i + q__2.i; // , expr subst
csumj.r = q__1.r;
csumj.i = q__1.i; // , expr subst
/* L160: */
}
}
else if (j < *n)
{
i__3 = *n - j;
for (i__ = 1;
i__ <= i__3;
++i__)
{
r_cnjg(&q__4, &ap[ip + i__]);
q__3.r = q__4.r * uscal.r - q__4.i * uscal.i;
q__3.i = q__4.r * uscal.i + q__4.i * uscal.r; // , expr subst
i__4 = j + i__;
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i;
q__2.i = q__3.r * x[i__4].i + q__3.i * x[ i__4].r; // , expr subst
q__1.r = csumj.r + q__2.r;
q__1.i = csumj.i + q__2.i; // , expr subst
csumj.r = q__1.r;
csumj.i = q__1.i; // , expr subst
/* L170: */
}
}
}
q__1.r = tscal;
q__1.i = 0.f; // , expr subst
if (uscal.r == q__1.r && uscal.i == q__1.i)
{
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
/* was not used to scale the dotproduct. */
i__3 = j;
i__4 = j;
q__1.r = x[i__4].r - csumj.r;
q__1.i = x[i__4].i - csumj.i; // , expr subst
x[i__3].r = q__1.r;
x[i__3].i = q__1.i; // , expr subst
i__3 = j;
xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]) , abs(r__2));
if (nounit)
{
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
r_cnjg(&q__2, &ap[ip]);
q__1.r = tscal * q__2.r;
q__1.i = tscal * q__2.i; // , expr subst
tjjs.r = q__1.r;
tjjs.i = q__1.i; // , expr subst
}
else
{
tjjs.r = tscal;
tjjs.i = 0.f; // , expr subst
if (tscal == 1.f)
{
goto L185;
}
}
tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs(r__2));
if (tjj > smlnum)
{
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f)
{
if (xj > tjj * bignum)
{
/* Scale X by 1/abs(x(j)). */
rec = 1.f / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r;
x[i__3].i = q__1.i; // , expr subst
}
else if (tjj > 0.f)
{
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum)
{
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r;
x[i__3].i = q__1.i; // , expr subst
}
else
{
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0 and compute a solution to A**H *x = 0. */
i__3 = *n;
for (i__ = 1;
i__ <= i__3;
++i__)
{
i__4 = i__;
x[i__4].r = 0.f;
x[i__4].i = 0.f; // , expr subst
/* L180: */
}
i__3 = j;
x[i__3].r = 1.f;
x[i__3].i = 0.f; // , expr subst
*scale = 0.f;
xmax = 0.f;
}
L185:
;
}
else
{
/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
/* product has already been divided by 1/A(j,j). */
i__3 = j;
cladiv_(&q__2, &x[j], &tjjs);
q__1.r = q__2.r - csumj.r;
q__1.i = q__2.i - csumj.i; // , expr subst
x[i__3].r = q__1.r;
x[i__3].i = q__1.i; // , expr subst
}
/* Computing MAX */
i__3 = j;
r__3 = xmax;
r__4 = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]), abs(r__2)); // , expr subst
xmax = max(r__3,r__4);
++jlen;
ip += jinc * jlen;
/* L190: */
}
}
*scale /= tscal;
}
/* Scale the column norms by 1/TSCAL for return. */
if (tscal != 1.f)
{
r__1 = 1.f / tscal;
sscal_(n, &r__1, &cnorm[1], &c__1);
}
return 0;
/* End of CLATPS */
}
/* 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_ */
/* Subroutine */ int clarfg_(integer *n, complex *alpha, complex *x, integer *
incx, complex *tau)
{
/* -- LAPACK auxiliary routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CLARFG generates a complex elementary reflector H of order n, such
that
H' * ( alpha ) = ( beta ), H' * H = I.
( x ) ( 0 )
where alpha and beta are scalars, with beta real, and x is an
(n-1)-element complex vector. H is represented in the form
H = I - tau * ( 1 ) * ( 1 v' ) ,
( v )
where tau is a complex scalar and v is a complex (n-1)-element
vector. Note that H is not hermitian.
If the elements of x are all zero and alpha is real, then tau = 0
and H is taken to be the unit matrix.
Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 .
Arguments
=========
N (input) INTEGER
The order of the elementary reflector.
ALPHA (input/output) COMPLEX
On entry, the value alpha.
On exit, it is overwritten with the value beta.
X (input/output) COMPLEX array, dimension
(1+(N-2)*abs(INCX))
On entry, the vector x.
On exit, it is overwritten with the vector v.
INCX (input) INTEGER
The increment between elements of X. INCX > 0.
TAU (output) COMPLEX
The value tau.
=====================================================================
Parameter adjustments
Function Body */
/* Table of constant values */
static complex c_b5 = {1.f,0.f};
/* System generated locals */
integer i__1;
real r__1;
doublereal d__1, d__2;
complex q__1, q__2;
/* Builtin functions */
double r_imag(complex *), r_sign(real *, real *);
/* Local variables */
static real beta;
static integer j;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
static real alphi, alphr, xnorm;
extern doublereal scnrm2_(integer *, complex *, integer *), slapy3_(real *
, real *, real *);
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*);
static real safmin, rsafmn;
static integer knt;
#define X(I) x[(I)-1]
if (*n <= 0) {
tau->r = 0.f, tau->i = 0.f;
return 0;
}
i__1 = *n - 1;
xnorm = scnrm2_(&i__1, &X(1), incx);
alphr = alpha->r;
alphi = r_imag(alpha);
if (xnorm == 0.f && alphi == 0.f) {
/* H = I */
tau->r = 0.f, tau->i = 0.f;
} else {
/* general case */
r__1 = slapy3_(&alphr, &alphi, &xnorm);
beta = -(doublereal)r_sign(&r__1, &alphr);
safmin = slamch_("S") / slamch_("E");
rsafmn = 1.f / safmin;
if (dabs(beta) < safmin) {
/* XNORM, BETA may be inaccurate; scale X and recompute
them */
knt = 0;
L10:
++knt;
i__1 = *n - 1;
csscal_(&i__1, &rsafmn, &X(1), incx);
beta *= rsafmn;
alphi *= rsafmn;
alphr *= rsafmn;
if (dabs(beta) < safmin) {
goto L10;
}
/* New BETA is at most 1, at least SAFMIN */
i__1 = *n - 1;
xnorm = scnrm2_(&i__1, &X(1), incx);
q__1.r = alphr, q__1.i = alphi;
alpha->r = q__1.r, alpha->i = q__1.i;
r__1 = slapy3_(&alphr, &alphi, &xnorm);
beta = -(doublereal)r_sign(&r__1, &alphr);
d__1 = (beta - alphr) / beta;
d__2 = -(doublereal)alphi / beta;
q__1.r = d__1, q__1.i = d__2;
tau->r = q__1.r, tau->i = q__1.i;
q__2.r = alpha->r - beta, q__2.i = alpha->i;
cladiv_(&q__1, &c_b5, &q__2);
alpha->r = q__1.r, alpha->i = q__1.i;
i__1 = *n - 1;
cscal_(&i__1, alpha, &X(1), incx);
/* If ALPHA is subnormal, it may lose relative accuracy
*/
alpha->r = beta, alpha->i = 0.f;
i__1 = knt;
for (j = 1; j <= knt; ++j) {
q__1.r = safmin * alpha->r, q__1.i = safmin * alpha->i;
alpha->r = q__1.r, alpha->i = q__1.i;
/* L20: */
}
} else {
d__1 = (beta - alphr) / beta;
d__2 = -(doublereal)alphi / beta;
q__1.r = d__1, q__1.i = d__2;
tau->r = q__1.r, tau->i = q__1.i;
q__2.r = alpha->r - beta, q__2.i = alpha->i;
cladiv_(&q__1, &c_b5, &q__2);
alpha->r = q__1.r, alpha->i = q__1.i;
i__1 = *n - 1;
cscal_(&i__1, alpha, &X(1), incx);
alpha->r = beta, alpha->i = 0.f;
}
}
return 0;
/* End of CLARFG */
} /* clarfg_ */
/* Subroutine */ int ctrsyl_(char *trana, char *tranb, integer *isgn, integer
*m, integer *n, complex *a, integer *lda, complex *b, integer *ldb,
complex *c__, integer *ldc, real *scale, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
i__3, i__4;
real r__1, r__2;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
integer j, k, l;
complex a11;
real db;
complex x11;
real da11;
complex vec;
real dum[1], eps, sgn, smin;
complex suml, sumr;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern /* Subroutine */ int slabad_(real *, real *);
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *);
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
real scaloc;
extern doublereal slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), xerbla_(char *, integer *);
real bignum;
logical notrna, notrnb;
real smlnum;
/* -- LAPACK routine (version 3.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CTRSYL solves the complex Sylvester matrix equation: */
/* op(A)*X + X*op(B) = scale*C or */
/* op(A)*X - X*op(B) = scale*C, */
/* where op(A) = A or A**H, and A and B are both upper triangular. A is */
/* M-by-M and B is N-by-N; the right hand side C and the solution X are */
/* M-by-N; and scale is an output scale factor, set <= 1 to avoid */
/* overflow in X. */
/* Arguments */
/* ========= */
/* TRANA (input) CHARACTER*1 */
/* Specifies the option op(A): */
/* = 'N': op(A) = A (No transpose) */
/* = 'C': op(A) = A**H (Conjugate transpose) */
/* TRANB (input) CHARACTER*1 */
/* Specifies the option op(B): */
/* = 'N': op(B) = B (No transpose) */
/* = 'C': op(B) = B**H (Conjugate transpose) */
/* ISGN (input) INTEGER */
/* Specifies the sign in the equation: */
/* = +1: solve op(A)*X + X*op(B) = scale*C */
/* = -1: solve op(A)*X - X*op(B) = scale*C */
/* M (input) INTEGER */
/* The order of the matrix A, and the number of rows in the */
/* matrices X and C. M >= 0. */
/* N (input) INTEGER */
/* The order of the matrix B, and the number of columns in the */
/* matrices X and C. N >= 0. */
/* A (input) COMPLEX array, dimension (LDA,M) */
/* The upper triangular matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* B (input) COMPLEX array, dimension (LDB,N) */
/* The upper triangular matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* C (input/output) COMPLEX array, dimension (LDC,N) */
/* On entry, the M-by-N right hand side matrix C. */
/* On exit, C is overwritten by the solution matrix X. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,M) */
/* SCALE (output) REAL */
/* The scale factor, scale, set <= 1 to avoid overflow in X. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* = 1: A and B have common or very close eigenvalues; perturbed */
/* values were used to solve the equation (but the matrices */
/* A and B are unchanged). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and Test input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
/* Function Body */
notrna = lsame_(trana, "N");
notrnb = lsame_(tranb, "N");
*info = 0;
if (! notrna && ! lsame_(trana, "C")) {
*info = -1;
} else if (! notrnb && ! lsame_(tranb, "C")) {
*info = -2;
} else if (*isgn != 1 && *isgn != -1) {
*info = -3;
} else if (*m < 0) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*m)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldc < max(1,*m)) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTRSYL", &i__1);
return 0;
}
/* Quick return if possible */
*scale = 1.f;
if (*m == 0 || *n == 0) {
return 0;
}
/* Set constants to control overflow */
eps = slamch_("P");
smlnum = slamch_("S");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum = smlnum * (real) (*m * *n) / eps;
bignum = 1.f / smlnum;
/* Computing MAX */
r__1 = smlnum, r__2 = eps * clange_("M", m, m, &a[a_offset], lda, dum), r__1 = max(r__1,r__2), r__2 = eps * clange_("M", n, n,
&b[b_offset], ldb, dum);
smin = dmax(r__1,r__2);
sgn = (real) (*isgn);
if (notrna && notrnb) {
/* Solve A*X + ISGN*X*B = scale*C. */
/* The (K,L)th block of X is determined starting from */
/* bottom-left corner column by column by */
/* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) */
/* Where */
/* M L-1 */
/* R(K,L) = SUM [A(K,I)*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)]. */
/* I=K+1 J=1 */
i__1 = *n;
for (l = 1; l <= i__1; ++l) {
for (k = *m; k >= 1; --k) {
i__2 = *m - k;
/* Computing MIN */
i__3 = k + 1;
/* Computing MIN */
i__4 = k + 1;
cdotu_(&q__1, &i__2, &a[k + min(i__3, *m)* a_dim1], lda, &c__[
min(i__4, *m)+ l * c_dim1], &c__1);
suml.r = q__1.r, suml.i = q__1.i;
i__2 = l - 1;
cdotu_(&q__1, &i__2, &c__[k + c_dim1], ldc, &b[l * b_dim1 + 1]
, &c__1);
sumr.r = q__1.r, sumr.i = q__1.i;
i__2 = k + l * c_dim1;
q__3.r = sgn * sumr.r, q__3.i = sgn * sumr.i;
q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
q__1.r = c__[i__2].r - q__2.r, q__1.i = c__[i__2].i - q__2.i;
vec.r = q__1.r, vec.i = q__1.i;
scaloc = 1.f;
i__2 = k + k * a_dim1;
i__3 = l + l * b_dim1;
q__2.r = sgn * b[i__3].r, q__2.i = sgn * b[i__3].i;
q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i;
a11.r = q__1.r, a11.i = q__1.i;
da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
dabs(r__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.f;
da11 = smin;
*info = 1;
}
db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
r__2));
if (da11 < 1.f && db > 1.f) {
if (db > bignum * da11) {
scaloc = 1.f / db;
}
}
q__3.r = scaloc, q__3.i = 0.f;
q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
q__3.i + vec.i * q__3.r;
cladiv_(&q__1, &q__2, &a11);
x11.r = q__1.r, x11.i = q__1.i;
if (scaloc != 1.f) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
csscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
/* L10: */
}
*scale *= scaloc;
}
i__2 = k + l * c_dim1;
c__[i__2].r = x11.r, c__[i__2].i = x11.i;
/* L20: */
}
/* L30: */
}
} else if (! notrna && notrnb) {
/* Solve A' *X + ISGN*X*B = scale*C. */
/* The (K,L)th block of X is determined starting from */
/* upper-left corner column by column by */
/* A'(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) */
/* Where */
/* K-1 L-1 */
/* R(K,L) = SUM [A'(I,K)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)] */
/* I=1 J=1 */
i__1 = *n;
for (l = 1; l <= i__1; ++l) {
i__2 = *m;
for (k = 1; k <= i__2; ++k) {
i__3 = k - 1;
cdotc_(&q__1, &i__3, &a[k * a_dim1 + 1], &c__1, &c__[l *
c_dim1 + 1], &c__1);
suml.r = q__1.r, suml.i = q__1.i;
i__3 = l - 1;
cdotu_(&q__1, &i__3, &c__[k + c_dim1], ldc, &b[l * b_dim1 + 1]
, &c__1);
sumr.r = q__1.r, sumr.i = q__1.i;
i__3 = k + l * c_dim1;
q__3.r = sgn * sumr.r, q__3.i = sgn * sumr.i;
q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
vec.r = q__1.r, vec.i = q__1.i;
scaloc = 1.f;
r_cnjg(&q__2, &a[k + k * a_dim1]);
i__3 = l + l * b_dim1;
q__3.r = sgn * b[i__3].r, q__3.i = sgn * b[i__3].i;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
a11.r = q__1.r, a11.i = q__1.i;
da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
dabs(r__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.f;
da11 = smin;
*info = 1;
}
db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
r__2));
if (da11 < 1.f && db > 1.f) {
if (db > bignum * da11) {
scaloc = 1.f / db;
}
}
q__3.r = scaloc, q__3.i = 0.f;
q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
q__3.i + vec.i * q__3.r;
cladiv_(&q__1, &q__2, &a11);
x11.r = q__1.r, x11.i = q__1.i;
if (scaloc != 1.f) {
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
csscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
/* L40: */
}
*scale *= scaloc;
}
i__3 = k + l * c_dim1;
c__[i__3].r = x11.r, c__[i__3].i = x11.i;
/* L50: */
}
/* L60: */
}
} else if (! notrna && ! notrnb) {
/* Solve A'*X + ISGN*X*B' = C. */
/* The (K,L)th block of X is determined starting from */
/* upper-right corner column by column by */
/* A'(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L) */
/* Where */
/* K-1 */
/* R(K,L) = SUM [A'(I,K)*X(I,L)] + */
/* I=1 */
/* N */
/* ISGN*SUM [X(K,J)*B'(L,J)]. */
/* J=L+1 */
for (l = *n; l >= 1; --l) {
i__1 = *m;
for (k = 1; k <= i__1; ++k) {
i__2 = k - 1;
cdotc_(&q__1, &i__2, &a[k * a_dim1 + 1], &c__1, &c__[l *
c_dim1 + 1], &c__1);
suml.r = q__1.r, suml.i = q__1.i;
i__2 = *n - l;
/* Computing MIN */
i__3 = l + 1;
/* Computing MIN */
i__4 = l + 1;
cdotc_(&q__1, &i__2, &c__[k + min(i__3, *n)* c_dim1], ldc, &b[
l + min(i__4, *n)* b_dim1], ldb);
sumr.r = q__1.r, sumr.i = q__1.i;
i__2 = k + l * c_dim1;
r_cnjg(&q__4, &sumr);
q__3.r = sgn * q__4.r, q__3.i = sgn * q__4.i;
q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
q__1.r = c__[i__2].r - q__2.r, q__1.i = c__[i__2].i - q__2.i;
vec.r = q__1.r, vec.i = q__1.i;
scaloc = 1.f;
i__2 = k + k * a_dim1;
i__3 = l + l * b_dim1;
q__3.r = sgn * b[i__3].r, q__3.i = sgn * b[i__3].i;
q__2.r = a[i__2].r + q__3.r, q__2.i = a[i__2].i + q__3.i;
r_cnjg(&q__1, &q__2);
a11.r = q__1.r, a11.i = q__1.i;
da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
dabs(r__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.f;
da11 = smin;
*info = 1;
}
db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
r__2));
if (da11 < 1.f && db > 1.f) {
if (db > bignum * da11) {
scaloc = 1.f / db;
}
}
q__3.r = scaloc, q__3.i = 0.f;
q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
q__3.i + vec.i * q__3.r;
cladiv_(&q__1, &q__2, &a11);
x11.r = q__1.r, x11.i = q__1.i;
if (scaloc != 1.f) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
csscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
/* L70: */
}
*scale *= scaloc;
}
i__2 = k + l * c_dim1;
c__[i__2].r = x11.r, c__[i__2].i = x11.i;
/* L80: */
}
/* L90: */
}
} else if (notrna && ! notrnb) {
/* Solve A*X + ISGN*X*B' = C. */
/* The (K,L)th block of X is determined starting from */
/* bottom-left corner column by column by */
/* A(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L) */
/* Where */
/* M N */
/* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B'(L,J)] */
/* I=K+1 J=L+1 */
for (l = *n; l >= 1; --l) {
for (k = *m; k >= 1; --k) {
i__1 = *m - k;
/* Computing MIN */
i__2 = k + 1;
/* Computing MIN */
i__3 = k + 1;
cdotu_(&q__1, &i__1, &a[k + min(i__2, *m)* a_dim1], lda, &c__[
min(i__3, *m)+ l * c_dim1], &c__1);
suml.r = q__1.r, suml.i = q__1.i;
i__1 = *n - l;
/* Computing MIN */
i__2 = l + 1;
/* Computing MIN */
i__3 = l + 1;
cdotc_(&q__1, &i__1, &c__[k + min(i__2, *n)* c_dim1], ldc, &b[
l + min(i__3, *n)* b_dim1], ldb);
sumr.r = q__1.r, sumr.i = q__1.i;
i__1 = k + l * c_dim1;
r_cnjg(&q__4, &sumr);
q__3.r = sgn * q__4.r, q__3.i = sgn * q__4.i;
q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
q__1.r = c__[i__1].r - q__2.r, q__1.i = c__[i__1].i - q__2.i;
vec.r = q__1.r, vec.i = q__1.i;
scaloc = 1.f;
i__1 = k + k * a_dim1;
r_cnjg(&q__3, &b[l + l * b_dim1]);
q__2.r = sgn * q__3.r, q__2.i = sgn * q__3.i;
q__1.r = a[i__1].r + q__2.r, q__1.i = a[i__1].i + q__2.i;
a11.r = q__1.r, a11.i = q__1.i;
da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
dabs(r__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.f;
da11 = smin;
*info = 1;
}
db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
r__2));
if (da11 < 1.f && db > 1.f) {
if (db > bignum * da11) {
scaloc = 1.f / db;
}
}
q__3.r = scaloc, q__3.i = 0.f;
q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
q__3.i + vec.i * q__3.r;
cladiv_(&q__1, &q__2, &a11);
x11.r = q__1.r, x11.i = q__1.i;
if (scaloc != 1.f) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
csscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
/* L100: */
}
*scale *= scaloc;
}
i__1 = k + l * c_dim1;
c__[i__1].r = x11.r, c__[i__1].i = x11.i;
/* L110: */
}
/* L120: */
}
}
return 0;
/* End of CTRSYL */
} /* ctrsyl_ */
/* Subroutine */ int ctgevc_(char *side, char *howmny, logical *select,
integer *n, complex *s, integer *lds, complex *p, integer *ldp,
complex *vl, integer *ldvl, complex *vr, integer *ldvr, integer *mm,
integer *m, complex *work, real *rwork, integer *info)
{
/* System generated locals */
integer p_dim1, p_offset, s_dim1, s_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 */
complex d__;
integer i__, j;
complex ca, cb;
integer je, im, jr;
real big;
logical lsa, lsb;
real ulp;
complex sum;
integer ibeg, ieig, iend;
real dmin__;
integer isrc;
real temp;
complex suma, sumb;
real xmax, scale;
logical ilall;
integer iside;
real sbeta;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *);
real small;
logical compl;
real anorm, bnorm;
logical compr, ilbbad;
real acoefa, bcoefa, acoeff;
complex bcoeff;
logical ilback;
extern /* Subroutine */ int slabad_(real *, real *);
real ascale, bscale;
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
extern doublereal slamch_(char *);
complex salpha;
real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
real bignum;
logical ilcomp;
integer ihwmny;
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CTGEVC computes some or all of the right and/or left eigenvectors of */
/* a pair of complex matrices (S,P), where S and P are upper triangular. */
/* Matrix pairs of this type are produced by the generalized Schur */
/* factorization of a complex matrix pair (A,B): */
/* A = Q*S*Z**H, B = Q*P*Z**H */
/* as computed by CGGHRD + CHGEQZ. */
/* The right eigenvector x and the left eigenvector y of (S,P) */
/* corresponding to an eigenvalue w are defined by: */
/* S*x = w*P*x, (y**H)*S = w*(y**H)*P, */
/* where y**H denotes the conjugate tranpose of y. */
/* The eigenvalues are not input to this routine, but are computed */
/* directly from the diagonal elements of S and P. */
/* This routine returns the matrices X and/or Y of right and left */
/* eigenvectors of (S,P), or the products Z*X and/or Q*Y, */
/* where Z and Q are input matrices. */
/* If Q and Z are the unitary factors from the generalized Schur */
/* factorization of a matrix pair (A,B), then Z*X and Q*Y */
/* are the matrices of right and left eigenvectors of (A,B). */
/* 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, */
/* backtransformed by the matrices 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. The eigenvector corresponding to the j-th */
/* eigenvalue is computed if SELECT(j) = .TRUE.. */
/* Not referenced if HOWMNY = 'A' or 'B'. */
/* N (input) INTEGER */
/* The order of the matrices S and P. N >= 0. */
/* S (input) COMPLEX array, dimension (LDS,N) */
/* The upper triangular matrix S from a generalized Schur */
/* factorization, as computed by CHGEQZ. */
/* LDS (input) INTEGER */
/* The leading dimension of array S. LDS >= max(1,N). */
/* P (input) COMPLEX array, dimension (LDP,N) */
/* The upper triangular matrix P from a generalized Schur */
/* factorization, as computed by CHGEQZ. P must have real */
/* diagonal elements. */
/* LDP (input) INTEGER */
/* The leading dimension of array P. LDP >= 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 (S,P); */
/* if HOWMNY = 'B', the matrix Q*Y; */
/* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by */
/* SELECT, stored consecutively in the columns of */
/* VL, in the same order as their eigenvalues. */
/* Not referenced if SIDE = 'R'. */
/* LDVL (input) INTEGER */
/* The leading dimension of array VL. LDVL >= 1, and if */
/* SIDE = 'L' or 'l' or 'B' or 'b', LDVL >= N. */
/* 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 (S,P); */
/* if HOWMNY = 'B', the matrix Z*X; */
/* if HOWMNY = 'S', the right eigenvectors of (S,P) specified by */
/* SELECT, stored consecutively in the columns of */
/* VR, in the same order as their eigenvalues. */
/* Not referenced if SIDE = 'L'. */
/* LDVR (input) INTEGER */
/* The leading dimension of the array VR. LDVR >= 1, and if */
/* SIDE = 'R' or 'B', LDVR >= N. */
/* 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. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and Test the input parameters */
/* Parameter adjustments */
--select;
s_dim1 = *lds;
s_offset = 1 + s_dim1;
s -= s_offset;
p_dim1 = *ldp;
p_offset = 1 + p_dim1;
p -= p_offset;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
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")) {
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 (*lds < max(1,*n)) {
*info = -6;
} else if (*ldp < 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(&p[j + j * p_dim1]) != 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 = s_dim1 + 1;
anorm = (r__1 = s[i__1].r, dabs(r__1)) + (r__2 = r_imag(&s[s_dim1 + 1]),
dabs(r__2));
i__1 = p_dim1 + 1;
bnorm = (r__1 = p[i__1].r, dabs(r__1)) + (r__2 = r_imag(&p[p_dim1 + 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 = i__ + j * s_dim1;
rwork[j] += (r__1 = s[i__3].r, dabs(r__1)) + (r__2 = r_imag(&s[
i__ + j * s_dim1]), dabs(r__2));
i__3 = i__ + j * p_dim1;
rwork[*n + j] += (r__1 = p[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
p[i__ + j * p_dim1]), dabs(r__2));
/* L30: */
}
/* Computing MAX */
i__2 = j + j * s_dim1;
r__3 = anorm, r__4 = rwork[j] + ((r__1 = s[i__2].r, dabs(r__1)) + (
r__2 = r_imag(&s[j + j * s_dim1]), dabs(r__2)));
anorm = dmax(r__3,r__4);
/* Computing MAX */
i__2 = j + j * p_dim1;
r__3 = bnorm, r__4 = rwork[*n + j] + ((r__1 = p[i__2].r, dabs(r__1))
+ (r__2 = r_imag(&p[j + j * p_dim1]), 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 = je + je * s_dim1;
i__3 = je + je * p_dim1;
if ((r__2 = s[i__2].r, dabs(r__2)) + (r__3 = r_imag(&s[je +
je * s_dim1]), dabs(r__3)) <= safmin && (r__1 = p[
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 = jr + ieig * vl_dim1;
vl[i__3].r = 0.f, vl[i__3].i = 0.f;
/* L50: */
}
i__2 = ieig + ieig * vl_dim1;
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 = je + je * s_dim1;
i__3 = je + je * p_dim1;
r__4 = ((r__2 = s[i__2].r, dabs(r__2)) + (r__3 = r_imag(&s[je
+ je * s_dim1]), dabs(r__3))) * ascale, r__5 = (r__1 =
p[i__3].r, dabs(r__1)) * bscale, r__4 = max(r__4,
r__5);
temp = 1.f / dmax(r__4,safmin);
i__2 = je + je * s_dim1;
q__2.r = temp * s[i__2].r, q__2.i = temp * s[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 = je + je * p_dim1;
sbeta = temp * p[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*S(k,j) - b*P(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, &s[jr + j * s_dim1]);
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, &p[jr + j * p_dim1]);
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*S(j,j) - b*P(j,j) ) */
/* with scaling and perturbation of the denominator */
i__3 = j + j * s_dim1;
q__3.r = acoeff * s[i__3].r, q__3.i = acoeff * s[i__3].i;
i__4 = j + j * p_dim1;
q__4.r = bcoeff.r * p[i__4].r - bcoeff.i * p[i__4].i,
q__4.i = bcoeff.r * p[i__4].i + bcoeff.i * p[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[je * vl_dim1 + 1], 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 = jr + ieig * vl_dim1;
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 = jr + ieig * vl_dim1;
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 = je + je * s_dim1;
i__2 = je + je * p_dim1;
if ((r__2 = s[i__1].r, dabs(r__2)) + (r__3 = r_imag(&s[je +
je * s_dim1]), dabs(r__3)) <= safmin && (r__1 = p[
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 = jr + ieig * vr_dim1;
vr[i__2].r = 0.f, vr[i__2].i = 0.f;
/* L150: */
}
i__1 = ieig + ieig * vr_dim1;
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 = je + je * s_dim1;
i__2 = je + je * p_dim1;
r__4 = ((r__2 = s[i__1].r, dabs(r__2)) + (r__3 = r_imag(&s[je
+ je * s_dim1]), dabs(r__3))) * ascale, r__5 = (r__1 =
p[i__2].r, dabs(r__1)) * bscale, r__4 = max(r__4,
r__5);
temp = 1.f / dmax(r__4,safmin);
i__1 = je + je * s_dim1;
q__2.r = temp * s[i__1].r, q__2.i = temp * s[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 = je + je * p_dim1;
sbeta = temp * p[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 = jr + je * s_dim1;
q__2.r = acoeff * s[i__3].r, q__2.i = acoeff * s[i__3].i;
i__4 = jr + je * p_dim1;
q__3.r = bcoeff.r * p[i__4].r - bcoeff.i * p[i__4].i,
q__3.i = bcoeff.r * p[i__4].i + bcoeff.i * p[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 = j + j * s_dim1;
q__2.r = acoeff * s[i__1].r, q__2.i = acoeff * s[i__1].i;
i__2 = j + j * p_dim1;
q__3.r = bcoeff.r * p[i__2].r - bcoeff.i * p[i__2].i,
q__3.i = bcoeff.r * p[i__2].i + bcoeff.i * p[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 S(*,j) - b P(*,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 = jr + j * s_dim1;
q__3.r = ca.r * s[i__4].r - ca.i * s[i__4].i,
q__3.i = ca.r * s[i__4].i + ca.i * s[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 = jr + j * p_dim1;
q__4.r = cb.r * p[i__5].r - cb.i * p[i__5].i,
q__4.i = cb.r * p[i__5].i + cb.i * p[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 = jr + ieig * vr_dim1;
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 = jr + ieig * vr_dim1;
vr[i__2].r = 0.f, vr[i__2].i = 0.f;
/* L240: */
}
}
L250:
;
}
}
return 0;
/* End of CTGEVC */
} /* ctgevc_ */
