/* Subroutine */
int zlarfgp_(integer *n, doublecomplex *alpha, doublecomplex *x, integer *incx, doublecomplex *tau)
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *), d_sign(doublereal *, doublereal *), z_abs( doublecomplex *);
/* Local variables */
integer j;
doublecomplex savealpha;
integer knt;
doublereal beta, alphi, alphr;
extern /* Subroutine */
int zscal_(integer *, doublecomplex *, doublecomplex *, integer *);
doublereal xnorm;
extern doublereal dlapy2_(doublereal *, doublereal *), dlapy3_(doublereal *, doublereal *, doublereal *), dznrm2_(integer *, doublecomplex * , integer *), dlamch_(char *);
extern /* Subroutine */
int zdscal_(integer *, doublereal *, doublecomplex *, integer *);
doublereal bignum;
extern /* Double Complex */
VOID zladiv_(doublecomplex *, doublecomplex *, doublecomplex *);
doublereal 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., tau->i = 0.;
return 0;
}
i__1 = *n - 1;
xnorm = dznrm2_(&i__1, &x[1], incx);
alphr = alpha->r;
alphi = d_imag(alpha);
if (xnorm == 0.)
{
/* H = [1-alpha/abs(alpha) 0;
0 I], sign chosen so ALPHA >= 0. */
if (alphi == 0.)
{
if (alphr >= 0.)
{
/* 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., tau->i = 0.;
}
else
{
/* However, the application routines rely on explicit */
/* zero checks when TAU.ne.ZERO, and we must clear X. */
tau->r = 2., tau->i = 0.;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.;
x[i__2].i = 0.; // , expr subst
}
z__1.r = -alpha->r;
z__1.i = -alpha->i; // , expr subst
alpha->r = z__1.r, alpha->i = z__1.i;
}
}
else
{
/* Only "reflecting" the diagonal entry to be real and non-negative. */
xnorm = dlapy2_(&alphr, &alphi);
d__1 = 1. - alphr / xnorm;
d__2 = -alphi / xnorm;
z__1.r = d__1;
z__1.i = d__2; // , expr subst
tau->r = z__1.r, tau->i = z__1.i;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.;
x[i__2].i = 0.; // , expr subst
}
alpha->r = xnorm, alpha->i = 0.;
}
}
else
{
/* general case */
d__1 = dlapy3_(&alphr, &alphi, &xnorm);
beta = d_sign(&d__1, &alphr);
smlnum = dlamch_("S") / dlamch_("E");
bignum = 1. / smlnum;
knt = 0;
if (abs(beta) < smlnum)
{
/* XNORM, BETA may be inaccurate;
scale X and recompute them */
L10:
++knt;
i__1 = *n - 1;
zdscal_(&i__1, &bignum, &x[1], incx);
beta *= bignum;
alphi *= bignum;
alphr *= bignum;
if (abs(beta) < smlnum)
{
goto L10;
}
/* New BETA is at most 1, at least SMLNUM */
i__1 = *n - 1;
xnorm = dznrm2_(&i__1, &x[1], incx);
z__1.r = alphr;
z__1.i = alphi; // , expr subst
alpha->r = z__1.r, alpha->i = z__1.i;
d__1 = dlapy3_(&alphr, &alphi, &xnorm);
beta = d_sign(&d__1, &alphr);
}
savealpha.r = alpha->r;
savealpha.i = alpha->i; // , expr subst
z__1.r = alpha->r + beta;
z__1.i = alpha->i; // , expr subst
alpha->r = z__1.r, alpha->i = z__1.i;
if (beta < 0.)
{
beta = -beta;
z__2.r = -alpha->r;
z__2.i = -alpha->i; // , expr subst
z__1.r = z__2.r / beta;
z__1.i = z__2.i / beta; // , expr subst
tau->r = z__1.r, tau->i = z__1.i;
}
else
{
alphr = alphi * (alphi / alpha->r);
alphr += xnorm * (xnorm / alpha->r);
d__1 = alphr / beta;
d__2 = -alphi / beta;
z__1.r = d__1;
z__1.i = d__2; // , expr subst
tau->r = z__1.r, tau->i = z__1.i;
d__1 = -alphr;
z__1.r = d__1;
z__1.i = alphi; // , expr subst
alpha->r = z__1.r, alpha->i = z__1.i;
}
zladiv_(&z__1, &c_b5, alpha);
alpha->r = z__1.r, alpha->i = z__1.i;
if (z_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 = d_imag(&savealpha);
if (alphi == 0.)
{
if (alphr >= 0.)
{
tau->r = 0., tau->i = 0.;
}
else
{
tau->r = 2., tau->i = 0.;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.;
x[i__2].i = 0.; // , expr subst
}
z__1.r = -savealpha.r;
z__1.i = -savealpha.i; // , expr subst
beta = z__1.r;
}
}
else
{
xnorm = dlapy2_(&alphr, &alphi);
d__1 = 1. - alphr / xnorm;
d__2 = -alphi / xnorm;
z__1.r = d__1;
z__1.i = d__2; // , expr subst
tau->r = z__1.r, tau->i = z__1.i;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.;
x[i__2].i = 0.; // , expr subst
}
beta = xnorm;
}
}
else
{
/* This is the general case. */
i__1 = *n - 1;
zscal_(&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.;
}
return 0;
/* End of ZLARFGP */
}
/* Subroutine */ int zlatrs_(char *uplo, char *trans, char *diag, char *
normin, integer *n, doublecomplex *a, integer *lda, doublecomplex *x,
doublereal *scale, doublereal *cnorm, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2, z__3, z__4;
/* Local variables */
integer i__, j;
doublereal xj, rec, tjj;
integer jinc;
doublereal xbnd;
integer imax;
doublereal tmax;
doublecomplex tjjs;
doublereal xmax, grow;
doublereal tscal;
doublecomplex uscal;
integer jlast;
doublecomplex csumj;
logical upper;
doublereal bignum;
logical notran;
integer jfirst;
doublereal smlnum;
logical nounit;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* ZLATRS 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 */
/* ZTRSV 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*16 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*16 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) DOUBLE PRECISION */
/* 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) DOUBLE PRECISION 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, ZTRSV */
/* 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] */
/* 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] */
/* 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 ZTRSV if the */
/* 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 */
/* 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 */
/* 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 ZTRSV if 1/M(n) and 1/G(n) are both greater */
/* than max(underflow, 1/overflow). */
/* ===================================================================== */
/* 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_("ZLATRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine machine dependent parameters to control overflow. */
smlnum = dlamch_("Safe minimum");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
smlnum /= dlamch_("Precision");
bignum = 1. / smlnum;
*scale = 1.;
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] = dzasum_(&i__2, &a[j * a_dim1 + 1], &c__1);
}
} else {
/* A is lower triangular. */
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j;
cnorm[j] = dzasum_(&i__2, &a[j + 1 + j * a_dim1], &c__1);
}
cnorm[*n] = 0.;
}
}
/* Scale the column norms by TSCAL if the maximum element in CNORM is */
/* greater than BIGNUM/2. */
imax = idamax_(n, &cnorm[1], &c__1);
tmax = cnorm[imax];
if (tmax <= bignum * .5) {
tscal = 1.;
} else {
tscal = .5 / (smlnum * tmax);
dscal_(n, &tscal, &cnorm[1], &c__1);
}
/* Compute a bound on the computed solution vector to see if the */
/* Level 2 BLAS routine ZTRSV can be used. */
xmax = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = j;
d__3 = xmax, d__4 = (d__1 = x[i__2].r / 2., abs(d__1)) + (d__2 =
d_imag(&x[j]) / 2., abs(d__2));
xmax = max(d__3,d__4);
}
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.) {
grow = 0.;
goto L60;
}
if (nounit) {
/* A is non-unit triangular. */
/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
grow = .5 / max(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 = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
d__2));
if (tjj >= smlnum) {
/* M(j) = G(j-1) / abs(A(j,j)) */
/* Computing MIN */
d__1 = xbnd, d__2 = min(1.,tjj) * grow;
xbnd = min(d__1,d__2);
} else {
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.;
}
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.;
}
}
grow = xbnd;
} else {
/* A is unit triangular. */
/* Computing MIN */
d__1 = 1., d__2 = .5 / max(xbnd,smlnum);
grow = min(d__1,d__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. / (cnorm[j] + 1.);
}
}
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.) {
grow = 0.;
goto L90;
}
if (nounit) {
/* A is non-unit triangular. */
/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
grow = .5 / max(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.;
/* Computing MIN */
d__1 = grow, d__2 = xbnd / xj;
grow = min(d__1,d__2);
i__3 = j + j * a_dim1;
tjjs.r = a[i__3].r, tjjs.i = a[i__3].i;
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
d__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.;
}
}
grow = min(grow,xbnd);
} else {
/* A is unit triangular. */
/* Computing MIN */
d__1 = 1., d__2 = .5 / max(xbnd,smlnum);
grow = min(d__1,d__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.;
grow /= xj;
}
}
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. */
ztrsv_(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 * .5) {
/* Scale X so that its components are less than or equal to */
/* BIGNUM in absolute value. */
*scale = bignum * .5 / xmax;
zdscal_(n, scale, &x[1], &c__1);
xmax = bignum;
} else {
xmax *= 2.;
}
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 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]),
abs(d__2));
if (nounit) {
i__3 = j + j * a_dim1;
z__1.r = tscal * a[i__3].r, z__1.i = tscal * a[i__3].i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
if (tscal == 1.) {
goto L110;
}
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
d__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale x by 1/b(j). */
rec = 1. / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
, abs(d__2));
} else if (tjj > 0.) {
/* 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.) {
/* Scale by 1/CNORM(j) to avoid overflow when */
/* multiplying x(j) times column j. */
rec /= cnorm[j];
}
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
, abs(d__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., x[i__4].i = 0.;
}
i__3 = j;
x[i__3].r = 1., x[i__3].i = 0.;
xj = 1.;
*scale = 0.;
xmax = 0.;
}
L110:
/* Scale x if necessary to avoid overflow when adding a */
/* multiple of column j of A. */
if (xj > 1.) {
rec = 1. / xj;
if (cnorm[j] > (bignum - xmax) * rec) {
/* Scale x by 1/(2*abs(x(j))). */
rec *= .5;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
} else if (xj * cnorm[j] > bignum - xmax) {
/* Scale x by 1/2. */
zdscal_(n, &c_b36, &x[1], &c__1);
*scale *= .5;
}
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;
z__2.r = -x[i__4].r, z__2.i = -x[i__4].i;
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
zaxpy_(&i__3, &z__1, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
i__3 = j - 1;
i__ = izamax_(&i__3, &x[1], &c__1);
i__3 = i__;
xmax = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
&x[i__]), abs(d__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;
z__2.r = -x[i__4].r, z__2.i = -x[i__4].i;
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
zaxpy_(&i__3, &z__1, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
i__3 = *n - j;
i__ = j + izamax_(&i__3, &x[j + 1], &c__1);
i__3 = i__;
xmax = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
&x[i__]), abs(d__2));
}
}
}
} 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 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]),
abs(d__2));
uscal.r = tscal, uscal.i = 0.;
rec = 1. / max(xmax,1.);
if (cnorm[j] > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5;
if (nounit) {
i__3 = j + j * a_dim1;
z__1.r = tscal * a[i__3].r, z__1.i = tscal * a[i__3]
.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > 1.) {
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
d__1 = 1., d__2 = rec * tjj;
rec = min(d__1,d__2);
zladiv_(&z__1, &uscal, &tjjs);
uscal.r = z__1.r, uscal.i = z__1.i;
}
if (rec < 1.) {
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0., csumj.i = 0.;
if (uscal.r == 1. && uscal.i == 0.) {
/* If the scaling needed for A in the dot product is 1, */
/* call ZDOTU to perform the dot product. */
if (upper) {
i__3 = j - 1;
zdotu_(&z__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
} else if (j < *n) {
i__3 = *n - j;
zdotu_(&z__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
csumj.r = z__1.r, csumj.i = z__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;
z__3.r = a[i__4].r * uscal.r - a[i__4].i *
uscal.i, z__3.i = a[i__4].r * uscal.i + a[
i__4].i * uscal.r;
i__5 = i__;
z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i,
z__2.i = z__3.r * x[i__5].i + z__3.i * x[
i__5].r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
}
} else if (j < *n) {
i__3 = *n;
for (i__ = j + 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * a_dim1;
z__3.r = a[i__4].r * uscal.r - a[i__4].i *
uscal.i, z__3.i = a[i__4].r * uscal.i + a[
i__4].i * uscal.r;
i__5 = i__;
z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i,
z__2.i = z__3.r * x[i__5].i + z__3.i * x[
i__5].r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
}
}
}
z__1.r = tscal, z__1.i = 0.;
if (uscal.r == z__1.r && uscal.i == z__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;
z__1.r = x[i__4].r - csumj.r, z__1.i = x[i__4].i -
csumj.i;
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
, abs(d__2));
if (nounit) {
i__3 = j + j * a_dim1;
z__1.r = tscal * a[i__3].r, z__1.i = tscal * a[i__3]
.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
if (tscal == 1.) {
goto L160;
}
}
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale X by 1/abs(x(j)). */
rec = 1. / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
} else if (tjj > 0.) {
/* 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;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__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., x[i__4].i = 0.;
}
i__3 = j;
x[i__3].r = 1., x[i__3].i = 0.;
*scale = 0.;
xmax = 0.;
}
L160:
;
} 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;
zladiv_(&z__2, &x[j], &tjjs);
z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i;
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
}
/* Computing MAX */
i__3 = j;
d__3 = xmax, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
d_imag(&x[j]), abs(d__2));
xmax = max(d__3,d__4);
}
} 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 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]),
abs(d__2));
uscal.r = tscal, uscal.i = 0.;
rec = 1. / max(xmax,1.);
if (cnorm[j] > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5;
if (nounit) {
d_cnjg(&z__2, &a[j + j * a_dim1]);
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > 1.) {
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
d__1 = 1., d__2 = rec * tjj;
rec = min(d__1,d__2);
zladiv_(&z__1, &uscal, &tjjs);
uscal.r = z__1.r, uscal.i = z__1.i;
}
if (rec < 1.) {
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0., csumj.i = 0.;
if (uscal.r == 1. && uscal.i == 0.) {
/* If the scaling needed for A in the dot product is 1, */
/* call ZDOTC to perform the dot product. */
if (upper) {
i__3 = j - 1;
zdotc_(&z__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
} else if (j < *n) {
i__3 = *n - j;
zdotc_(&z__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
csumj.r = z__1.r, csumj.i = z__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__) {
d_cnjg(&z__4, &a[i__ + j * a_dim1]);
z__3.r = z__4.r * uscal.r - z__4.i * uscal.i,
z__3.i = z__4.r * uscal.i + z__4.i *
uscal.r;
i__4 = i__;
z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i,
z__2.i = z__3.r * x[i__4].i + z__3.i * x[
i__4].r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
}
} else if (j < *n) {
i__3 = *n;
for (i__ = j + 1; i__ <= i__3; ++i__) {
d_cnjg(&z__4, &a[i__ + j * a_dim1]);
z__3.r = z__4.r * uscal.r - z__4.i * uscal.i,
z__3.i = z__4.r * uscal.i + z__4.i *
uscal.r;
i__4 = i__;
z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i,
z__2.i = z__3.r * x[i__4].i + z__3.i * x[
i__4].r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
}
}
}
z__1.r = tscal, z__1.i = 0.;
if (uscal.r == z__1.r && uscal.i == z__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;
z__1.r = x[i__4].r - csumj.r, z__1.i = x[i__4].i -
csumj.i;
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
, abs(d__2));
if (nounit) {
d_cnjg(&z__2, &a[j + j * a_dim1]);
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
if (tscal == 1.) {
goto L210;
}
}
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale X by 1/abs(x(j)). */
rec = 1. / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
} else if (tjj > 0.) {
/* 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;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__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., x[i__4].i = 0.;
}
i__3 = j;
x[i__3].r = 1., x[i__3].i = 0.;
*scale = 0.;
xmax = 0.;
}
L210:
;
} 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;
zladiv_(&z__2, &x[j], &tjjs);
z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i;
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
}
/* Computing MAX */
i__3 = j;
d__3 = xmax, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
d_imag(&x[j]), abs(d__2));
xmax = max(d__3,d__4);
}
}
*scale /= tscal;
}
/* Scale the column norms by 1/TSCAL for return. */
if (tscal != 1.) {
d__1 = 1. / tscal;
dscal_(n, &d__1, &cnorm[1], &c__1);
}
return 0;
/* End of ZLATRS */
} /* zlatrs_ */
/* Subroutine */ int zlarfg_(integer *n, doublecomplex *alpha, doublecomplex *
x, integer *incx, doublecomplex *tau)
{
/* -- 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
=======
ZLARFG 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*16
On entry, the value alpha.
On exit, it is overwritten with the value beta.
X (input/output) COMPLEX*16 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*16
The value tau.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b5 = {1.,0.};
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *), d_sign(doublereal *, doublereal *);
/* Local variables */
static doublereal beta;
static integer j;
static doublereal alphi, alphr;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
static doublereal xnorm;
extern doublereal dlapy3_(doublereal *, doublereal *, doublereal *),
dznrm2_(integer *, doublecomplex *, integer *), dlamch_(char *);
static doublereal safmin;
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *);
static doublereal rsafmn;
extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *,
doublecomplex *);
static integer knt;
--x;
/* Function Body */
if (*n <= 0) {
tau->r = 0., tau->i = 0.;
return 0;
}
i__1 = *n - 1;
xnorm = dznrm2_(&i__1, &x[1], incx);
alphr = alpha->r;
alphi = d_imag(alpha);
if (xnorm == 0. && alphi == 0.) {
/* H = I */
tau->r = 0., tau->i = 0.;
} else {
/* general case */
d__1 = dlapy3_(&alphr, &alphi, &xnorm);
beta = -d_sign(&d__1, &alphr);
safmin = dlamch_("S") / dlamch_("E");
rsafmn = 1. / safmin;
if (abs(beta) < safmin) {
/* XNORM, BETA may be inaccurate; scale X and recompute them */
knt = 0;
L10:
++knt;
i__1 = *n - 1;
zdscal_(&i__1, &rsafmn, &x[1], incx);
beta *= rsafmn;
alphi *= rsafmn;
alphr *= rsafmn;
if (abs(beta) < safmin) {
goto L10;
}
/* New BETA is at most 1, at least SAFMIN */
i__1 = *n - 1;
xnorm = dznrm2_(&i__1, &x[1], incx);
z__1.r = alphr, z__1.i = alphi;
alpha->r = z__1.r, alpha->i = z__1.i;
d__1 = dlapy3_(&alphr, &alphi, &xnorm);
beta = -d_sign(&d__1, &alphr);
d__1 = (beta - alphr) / beta;
d__2 = -alphi / beta;
z__1.r = d__1, z__1.i = d__2;
tau->r = z__1.r, tau->i = z__1.i;
z__2.r = alpha->r - beta, z__2.i = alpha->i;
zladiv_(&z__1, &c_b5, &z__2);
alpha->r = z__1.r, alpha->i = z__1.i;
i__1 = *n - 1;
zscal_(&i__1, alpha, &x[1], incx);
/* If ALPHA is subnormal, it may lose relative accuracy */
alpha->r = beta, alpha->i = 0.;
i__1 = knt;
for (j = 1; j <= i__1; ++j) {
z__1.r = safmin * alpha->r, z__1.i = safmin * alpha->i;
alpha->r = z__1.r, alpha->i = z__1.i;
/* L20: */
}
} else {
d__1 = (beta - alphr) / beta;
d__2 = -alphi / beta;
z__1.r = d__1, z__1.i = d__2;
tau->r = z__1.r, tau->i = z__1.i;
z__2.r = alpha->r - beta, z__2.i = alpha->i;
zladiv_(&z__1, &c_b5, &z__2);
alpha->r = z__1.r, alpha->i = z__1.i;
i__1 = *n - 1;
zscal_(&i__1, alpha, &x[1], incx);
alpha->r = beta, alpha->i = 0.;
}
}
return 0;
/* End of ZLARFG */
} /* zlarfg_ */
/* Subroutine */ int ztgevc_(char *side, char *howmny, logical *select,
integer *n, doublecomplex *s, integer *lds, doublecomplex *p, integer
*ldp, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *
ldvr, integer *mm, integer *m, doublecomplex *work, doublereal *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;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
doublecomplex z__1, z__2, z__3, z__4;
/* Local variables */
doublecomplex d__;
integer i__, j;
doublecomplex ca, cb;
integer je, im, jr;
doublereal big;
logical lsa, lsb;
doublereal ulp;
doublecomplex sum;
integer ibeg, ieig, iend;
doublereal dmin__;
integer isrc;
doublereal temp;
doublecomplex suma, sumb;
doublereal xmax, scale;
logical ilall;
integer iside;
doublereal sbeta;
doublereal small;
logical compl;
doublereal anorm, bnorm;
logical compr;
logical ilbbad;
doublereal acoefa, bcoefa, acoeff;
doublecomplex bcoeff;
logical ilback;
doublereal ascale, bscale;
doublecomplex salpha;
doublereal safmin;
doublereal bignum;
logical ilcomp;
integer ihwmny;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* ZTGEVC 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 ZGGHRD + ZHGEQZ. */
/* 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 */
/* Not referenced if HOWMNY = 'A' or 'B'. */
/* N (input) INTEGER */
/* The order of the matrices S and P. N >= 0. */
/* S (input) COMPLEX*16 array, dimension (LDS,N) */
/* The upper triangular matrix S from a generalized Schur */
/* factorization, as computed by ZHGEQZ. */
/* LDS (input) INTEGER */
/* The leading dimension of array S. LDS >= max(1,N). */
/* P (input) COMPLEX*16 array, dimension (LDP,N) */
/* The upper triangular matrix P from a generalized Schur */
/* factorization, as computed by ZHGEQZ. P must have real */
/* diagonal elements. */
/* LDP (input) INTEGER */
/* The leading dimension of array P. LDP >= max(1,N). */
/* VL (input/output) COMPLEX*16 array, dimension (LDVL,MM) */
/* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */
/* contain an N-by-N matrix Q (usually the unitary matrix Q */
/* of left Schur vectors returned by ZHGEQZ). */
/* 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*16 array, dimension (LDVR,MM) */
/* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */
/* contain an N-by-N matrix Q (usually the unitary matrix Z */
/* of right Schur vectors returned by ZHGEQZ). */
/* 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*16 array, dimension (2*N) */
/* RWORK (workspace) DOUBLE PRECISION 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 */
--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_("ZTGEVC", &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;
}
}
} else {
im = *n;
}
/* Check diagonal of B */
ilbbad = FALSE_;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (d_imag(&p[j + j * p_dim1]) != 0.) {
ilbbad = TRUE_;
}
}
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_("ZTGEVC", &i__1);
return 0;
}
/* Quick return if possible */
*m = im;
if (*n == 0) {
return 0;
}
/* Machine Constants */
safmin = dlamch_("Safe minimum");
big = 1. / safmin;
dlabad_(&safmin, &big);
ulp = dlamch_("Epsilon") * dlamch_("Base");
small = safmin * *n / ulp;
big = 1. / small;
bignum = 1. / (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 = (d__1 = s[i__1].r, abs(d__1)) + (d__2 = d_imag(&s[s_dim1 + 1]),
abs(d__2));
i__1 = p_dim1 + 1;
bnorm = (d__1 = p[i__1].r, abs(d__1)) + (d__2 = d_imag(&p[p_dim1 + 1]),
abs(d__2));
rwork[1] = 0.;
rwork[*n + 1] = 0.;
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
rwork[j] = 0.;
rwork[*n + j] = 0.;
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * s_dim1;
rwork[j] += (d__1 = s[i__3].r, abs(d__1)) + (d__2 = d_imag(&s[i__
+ j * s_dim1]), abs(d__2));
i__3 = i__ + j * p_dim1;
rwork[*n + j] += (d__1 = p[i__3].r, abs(d__1)) + (d__2 = d_imag(&
p[i__ + j * p_dim1]), abs(d__2));
}
/* Computing MAX */
i__2 = j + j * s_dim1;
d__3 = anorm, d__4 = rwork[j] + ((d__1 = s[i__2].r, abs(d__1)) + (
d__2 = d_imag(&s[j + j * s_dim1]), abs(d__2)));
anorm = max(d__3,d__4);
/* Computing MAX */
i__2 = j + j * p_dim1;
d__3 = bnorm, d__4 = rwork[*n + j] + ((d__1 = p[i__2].r, abs(d__1)) +
(d__2 = d_imag(&p[j + j * p_dim1]), abs(d__2)));
bnorm = max(d__3,d__4);
}
ascale = 1. / max(anorm,safmin);
bscale = 1. / 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 ((d__2 = s[i__2].r, abs(d__2)) + (d__3 = d_imag(&s[je + je
* s_dim1]), abs(d__3)) <= safmin && (d__1 = p[i__3].r,
abs(d__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., vl[i__3].i = 0.;
}
i__2 = ieig + ieig * vl_dim1;
vl[i__2].r = 1., vl[i__2].i = 0.;
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;
d__4 = ((d__2 = s[i__2].r, abs(d__2)) + (d__3 = d_imag(&s[je
+ je * s_dim1]), abs(d__3))) * ascale, d__5 = (d__1 =
p[i__3].r, abs(d__1)) * bscale, d__4 = max(d__4,d__5);
temp = 1. / max(d__4,safmin);
i__2 = je + je * s_dim1;
z__2.r = temp * s[i__2].r, z__2.i = temp * s[i__2].i;
z__1.r = ascale * z__2.r, z__1.i = ascale * z__2.i;
salpha.r = z__1.r, salpha.i = z__1.i;
i__2 = je + je * p_dim1;
sbeta = temp * p[i__2].r * bscale;
acoeff = sbeta * ascale;
z__1.r = bscale * salpha.r, z__1.i = bscale * salpha.i;
bcoeff.r = z__1.r, bcoeff.i = z__1.i;
/* Scale to avoid underflow */
lsa = abs(sbeta) >= safmin && abs(acoeff) < small;
lsb = (d__1 = salpha.r, abs(d__1)) + (d__2 = d_imag(&salpha),
abs(d__2)) >= safmin && (d__3 = bcoeff.r, abs(d__3))
+ (d__4 = d_imag(&bcoeff), abs(d__4)) < small;
scale = 1.;
if (lsa) {
scale = small / abs(sbeta) * min(anorm,big);
}
if (lsb) {
/* Computing MAX */
d__3 = scale, d__4 = small / ((d__1 = salpha.r, abs(d__1))
+ (d__2 = d_imag(&salpha), abs(d__2))) * min(
bnorm,big);
scale = max(d__3,d__4);
}
if (lsa || lsb) {
/* Computing MIN */
/* Computing MAX */
d__5 = 1., d__6 = abs(acoeff), d__5 = max(d__5,d__6),
d__6 = (d__1 = bcoeff.r, abs(d__1)) + (d__2 =
d_imag(&bcoeff), abs(d__2));
d__3 = scale, d__4 = 1. / (safmin * max(d__5,d__6));
scale = min(d__3,d__4);
if (lsa) {
acoeff = ascale * (scale * sbeta);
} else {
acoeff = scale * acoeff;
}
if (lsb) {
z__2.r = scale * salpha.r, z__2.i = scale * salpha.i;
z__1.r = bscale * z__2.r, z__1.i = bscale * z__2.i;
bcoeff.r = z__1.r, bcoeff.i = z__1.i;
} else {
z__1.r = scale * bcoeff.r, z__1.i = scale * bcoeff.i;
bcoeff.r = z__1.r, bcoeff.i = z__1.i;
}
}
acoefa = abs(acoeff);
bcoefa = (d__1 = bcoeff.r, abs(d__1)) + (d__2 = d_imag(&
bcoeff), abs(d__2));
xmax = 1.;
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
i__3 = jr;
work[i__3].r = 0., work[i__3].i = 0.;
}
i__2 = je;
work[i__2].r = 1., work[i__2].i = 0.;
/* Computing MAX */
d__1 = ulp * acoefa * anorm, d__2 = ulp * bcoefa * bnorm,
d__1 = max(d__1,d__2);
dmin__ = max(d__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. / 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;
z__1.r = temp * work[i__5].r, z__1.i = temp *
work[i__5].i;
work[i__4].r = z__1.r, work[i__4].i = z__1.i;
}
xmax = 1.;
}
suma.r = 0., suma.i = 0.;
sumb.r = 0., sumb.i = 0.;
i__3 = j - 1;
for (jr = je; jr <= i__3; ++jr) {
d_cnjg(&z__3, &s[jr + j * s_dim1]);
i__4 = jr;
z__2.r = z__3.r * work[i__4].r - z__3.i * work[i__4]
.i, z__2.i = z__3.r * work[i__4].i + z__3.i *
work[i__4].r;
z__1.r = suma.r + z__2.r, z__1.i = suma.i + z__2.i;
suma.r = z__1.r, suma.i = z__1.i;
d_cnjg(&z__3, &p[jr + j * p_dim1]);
i__4 = jr;
z__2.r = z__3.r * work[i__4].r - z__3.i * work[i__4]
.i, z__2.i = z__3.r * work[i__4].i + z__3.i *
work[i__4].r;
z__1.r = sumb.r + z__2.r, z__1.i = sumb.i + z__2.i;
sumb.r = z__1.r, sumb.i = z__1.i;
}
z__2.r = acoeff * suma.r, z__2.i = acoeff * suma.i;
d_cnjg(&z__4, &bcoeff);
z__3.r = z__4.r * sumb.r - z__4.i * sumb.i, z__3.i =
z__4.r * sumb.i + z__4.i * sumb.r;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
sum.r = z__1.r, sum.i = z__1.i;
/* 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;
z__3.r = acoeff * s[i__3].r, z__3.i = acoeff * s[i__3].i;
i__4 = j + j * p_dim1;
z__4.r = bcoeff.r * p[i__4].r - bcoeff.i * p[i__4].i,
z__4.i = bcoeff.r * p[i__4].i + bcoeff.i * p[i__4]
.r;
z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
d_cnjg(&z__1, &z__2);
d__.r = z__1.r, d__.i = z__1.i;
if ((d__1 = d__.r, abs(d__1)) + (d__2 = d_imag(&d__), abs(
d__2)) <= dmin__) {
z__1.r = dmin__, z__1.i = 0.;
d__.r = z__1.r, d__.i = z__1.i;
}
if ((d__1 = d__.r, abs(d__1)) + (d__2 = d_imag(&d__), abs(
d__2)) < 1.) {
if ((d__1 = sum.r, abs(d__1)) + (d__2 = d_imag(&sum),
abs(d__2)) >= bignum * ((d__3 = d__.r, abs(
d__3)) + (d__4 = d_imag(&d__), abs(d__4)))) {
temp = 1. / ((d__1 = sum.r, abs(d__1)) + (d__2 =
d_imag(&sum), abs(d__2)));
i__3 = j - 1;
for (jr = je; jr <= i__3; ++jr) {
i__4 = jr;
i__5 = jr;
z__1.r = temp * work[i__5].r, z__1.i = temp *
work[i__5].i;
work[i__4].r = z__1.r, work[i__4].i = z__1.i;
}
xmax = temp * xmax;
z__1.r = temp * sum.r, z__1.i = temp * sum.i;
sum.r = z__1.r, sum.i = z__1.i;
}
}
i__3 = j;
z__2.r = -sum.r, z__2.i = -sum.i;
zladiv_(&z__1, &z__2, &d__);
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* Computing MAX */
i__3 = j;
d__3 = xmax, d__4 = (d__1 = work[i__3].r, abs(d__1)) + (
d__2 = d_imag(&work[j]), abs(d__2));
xmax = max(d__3,d__4);
}
/* Back transform eigenvector if HOWMNY='B'. */
if (ilback) {
i__2 = *n + 1 - je;
zgemv_("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.;
i__2 = *n;
for (jr = ibeg; jr <= i__2; ++jr) {
/* Computing MAX */
i__3 = (isrc - 1) * *n + jr;
d__3 = xmax, d__4 = (d__1 = work[i__3].r, abs(d__1)) + (
d__2 = d_imag(&work[(isrc - 1) * *n + jr]), abs(
d__2));
xmax = max(d__3,d__4);
}
if (xmax > safmin) {
temp = 1. / xmax;
i__2 = *n;
for (jr = ibeg; jr <= i__2; ++jr) {
i__3 = jr + ieig * vl_dim1;
i__4 = (isrc - 1) * *n + jr;
z__1.r = temp * work[i__4].r, z__1.i = temp * work[
i__4].i;
vl[i__3].r = z__1.r, vl[i__3].i = z__1.i;
}
} 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., vl[i__3].i = 0.;
}
}
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 ((d__2 = s[i__1].r, abs(d__2)) + (d__3 = d_imag(&s[je + je
* s_dim1]), abs(d__3)) <= safmin && (d__1 = p[i__2].r,
abs(d__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., vr[i__2].i = 0.;
}
i__1 = ieig + ieig * vr_dim1;
vr[i__1].r = 1., vr[i__1].i = 0.;
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;
d__4 = ((d__2 = s[i__1].r, abs(d__2)) + (d__3 = d_imag(&s[je
+ je * s_dim1]), abs(d__3))) * ascale, d__5 = (d__1 =
p[i__2].r, abs(d__1)) * bscale, d__4 = max(d__4,d__5);
temp = 1. / max(d__4,safmin);
i__1 = je + je * s_dim1;
z__2.r = temp * s[i__1].r, z__2.i = temp * s[i__1].i;
z__1.r = ascale * z__2.r, z__1.i = ascale * z__2.i;
salpha.r = z__1.r, salpha.i = z__1.i;
i__1 = je + je * p_dim1;
sbeta = temp * p[i__1].r * bscale;
acoeff = sbeta * ascale;
z__1.r = bscale * salpha.r, z__1.i = bscale * salpha.i;
bcoeff.r = z__1.r, bcoeff.i = z__1.i;
/* Scale to avoid underflow */
lsa = abs(sbeta) >= safmin && abs(acoeff) < small;
lsb = (d__1 = salpha.r, abs(d__1)) + (d__2 = d_imag(&salpha),
abs(d__2)) >= safmin && (d__3 = bcoeff.r, abs(d__3))
+ (d__4 = d_imag(&bcoeff), abs(d__4)) < small;
scale = 1.;
if (lsa) {
scale = small / abs(sbeta) * min(anorm,big);
}
if (lsb) {
/* Computing MAX */
d__3 = scale, d__4 = small / ((d__1 = salpha.r, abs(d__1))
+ (d__2 = d_imag(&salpha), abs(d__2))) * min(
bnorm,big);
scale = max(d__3,d__4);
}
if (lsa || lsb) {
/* Computing MIN */
/* Computing MAX */
d__5 = 1., d__6 = abs(acoeff), d__5 = max(d__5,d__6),
d__6 = (d__1 = bcoeff.r, abs(d__1)) + (d__2 =
d_imag(&bcoeff), abs(d__2));
d__3 = scale, d__4 = 1. / (safmin * max(d__5,d__6));
scale = min(d__3,d__4);
if (lsa) {
acoeff = ascale * (scale * sbeta);
} else {
acoeff = scale * acoeff;
}
if (lsb) {
z__2.r = scale * salpha.r, z__2.i = scale * salpha.i;
z__1.r = bscale * z__2.r, z__1.i = bscale * z__2.i;
bcoeff.r = z__1.r, bcoeff.i = z__1.i;
} else {
z__1.r = scale * bcoeff.r, z__1.i = scale * bcoeff.i;
bcoeff.r = z__1.r, bcoeff.i = z__1.i;
}
}
acoefa = abs(acoeff);
bcoefa = (d__1 = bcoeff.r, abs(d__1)) + (d__2 = d_imag(&
bcoeff), abs(d__2));
xmax = 1.;
i__1 = *n;
for (jr = 1; jr <= i__1; ++jr) {
i__2 = jr;
work[i__2].r = 0., work[i__2].i = 0.;
}
i__1 = je;
work[i__1].r = 1., work[i__1].i = 0.;
/* Computing MAX */
d__1 = ulp * acoefa * anorm, d__2 = ulp * bcoefa * bnorm,
d__1 = max(d__1,d__2);
dmin__ = max(d__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;
z__2.r = acoeff * s[i__3].r, z__2.i = acoeff * s[i__3].i;
i__4 = jr + je * p_dim1;
z__3.r = bcoeff.r * p[i__4].r - bcoeff.i * p[i__4].i,
z__3.i = bcoeff.r * p[i__4].i + bcoeff.i * p[i__4]
.r;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
}
i__1 = je;
work[i__1].r = 1., work[i__1].i = 0.;
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;
z__2.r = acoeff * s[i__1].r, z__2.i = acoeff * s[i__1].i;
i__2 = j + j * p_dim1;
z__3.r = bcoeff.r * p[i__2].r - bcoeff.i * p[i__2].i,
z__3.i = bcoeff.r * p[i__2].i + bcoeff.i * p[i__2]
.r;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
d__.r = z__1.r, d__.i = z__1.i;
if ((d__1 = d__.r, abs(d__1)) + (d__2 = d_imag(&d__), abs(
d__2)) <= dmin__) {
z__1.r = dmin__, z__1.i = 0.;
d__.r = z__1.r, d__.i = z__1.i;
}
if ((d__1 = d__.r, abs(d__1)) + (d__2 = d_imag(&d__), abs(
d__2)) < 1.) {
i__1 = j;
if ((d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag(
&work[j]), abs(d__2)) >= bignum * ((d__3 =
d__.r, abs(d__3)) + (d__4 = d_imag(&d__), abs(
d__4)))) {
i__1 = j;
temp = 1. / ((d__1 = work[i__1].r, abs(d__1)) + (
d__2 = d_imag(&work[j]), abs(d__2)));
i__1 = je;
for (jr = 1; jr <= i__1; ++jr) {
i__2 = jr;
i__3 = jr;
z__1.r = temp * work[i__3].r, z__1.i = temp *
work[i__3].i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
}
}
}
i__1 = j;
i__2 = j;
z__2.r = -work[i__2].r, z__2.i = -work[i__2].i;
zladiv_(&z__1, &z__2, &d__);
work[i__1].r = z__1.r, work[i__1].i = z__1.i;
if (j > 1) {
/* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling */
i__1 = j;
if ((d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag(
&work[j]), abs(d__2)) > 1.) {
i__1 = j;
temp = 1. / ((d__1 = work[i__1].r, abs(d__1)) + (
d__2 = d_imag(&work[j]), abs(d__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;
z__1.r = temp * work[i__3].r, z__1.i =
temp * work[i__3].i;
work[i__2].r = z__1.r, work[i__2].i =
z__1.i;
}
}
}
i__1 = j;
z__1.r = acoeff * work[i__1].r, z__1.i = acoeff *
work[i__1].i;
ca.r = z__1.r, ca.i = z__1.i;
i__1 = j;
z__1.r = bcoeff.r * work[i__1].r - bcoeff.i * work[
i__1].i, z__1.i = bcoeff.r * work[i__1].i +
bcoeff.i * work[i__1].r;
cb.r = z__1.r, cb.i = z__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;
z__3.r = ca.r * s[i__4].r - ca.i * s[i__4].i,
z__3.i = ca.r * s[i__4].i + ca.i * s[i__4]
.r;
z__2.r = work[i__3].r + z__3.r, z__2.i = work[
i__3].i + z__3.i;
i__5 = jr + j * p_dim1;
z__4.r = cb.r * p[i__5].r - cb.i * p[i__5].i,
z__4.i = cb.r * p[i__5].i + cb.i * p[i__5]
.r;
z__1.r = z__2.r - z__4.r, z__1.i = z__2.i -
z__4.i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
}
}
}
/* Back transform eigenvector if HOWMNY='B'. */
if (ilback) {
zgemv_("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.;
i__1 = iend;
for (jr = 1; jr <= i__1; ++jr) {
/* Computing MAX */
i__2 = (isrc - 1) * *n + jr;
d__3 = xmax, d__4 = (d__1 = work[i__2].r, abs(d__1)) + (
d__2 = d_imag(&work[(isrc - 1) * *n + jr]), abs(
d__2));
xmax = max(d__3,d__4);
}
if (xmax > safmin) {
temp = 1. / xmax;
i__1 = iend;
for (jr = 1; jr <= i__1; ++jr) {
i__2 = jr + ieig * vr_dim1;
i__3 = (isrc - 1) * *n + jr;
z__1.r = temp * work[i__3].r, z__1.i = temp * work[
i__3].i;
vr[i__2].r = z__1.r, vr[i__2].i = z__1.i;
}
} 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., vr[i__2].i = 0.;
}
}
L250:
;
}
}
return 0;
/* End of ZTGEVC */
} /* ztgevc_ */
/* Subroutine */
int ztgevc_(char *side, char *howmny, logical *select, integer *n, doublecomplex *s, integer *lds, doublecomplex *p, integer *ldp, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer * ldvr, integer *mm, integer *m, doublecomplex *work, doublereal *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;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
doublecomplex d__;
integer i__, j;
doublecomplex ca, cb;
integer je, im, jr;
doublereal big;
logical lsa, lsb;
doublereal ulp;
doublecomplex sum;
integer ibeg, ieig, iend;
doublereal dmin__;
integer isrc;
doublereal temp;
doublecomplex suma, sumb;
doublereal xmax, scale;
logical ilall;
integer iside;
doublereal sbeta;
extern logical lsame_(char *, char *);
doublereal small;
logical compl;
doublereal anorm, bnorm;
logical compr;
extern /* Subroutine */
int zgemv_(char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
logical ilbbad;
doublereal acoefa, bcoefa, acoeff;
doublecomplex bcoeff;
logical ilback;
doublereal ascale, bscale;
extern doublereal dlamch_(char *);
doublecomplex salpha;
doublereal safmin;
extern /* Subroutine */
int xerbla_(char *, integer *);
doublereal bignum;
logical ilcomp;
extern /* Double Complex */
VOID zladiv_(doublecomplex *, doublecomplex *, doublecomplex *);
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_("ZTGEVC", &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 (d_imag(&p[j + j * p_dim1]) != 0.)
{
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_("ZTGEVC", &i__1);
return 0;
}
/* Quick return if possible */
*m = im;
if (*n == 0)
{
return 0;
}
/* Machine Constants */
safmin = dlamch_("Safe minimum");
big = 1. / safmin;
dlabad_(&safmin, &big);
ulp = dlamch_("Epsilon") * dlamch_("Base");
small = safmin * *n / ulp;
big = 1. / small;
bignum = 1. / (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 = (d__1 = s[i__1].r, abs(d__1)) + (d__2 = d_imag(&s[s_dim1 + 1]), abs(d__2));
i__1 = p_dim1 + 1;
bnorm = (d__1 = p[i__1].r, abs(d__1)) + (d__2 = d_imag(&p[p_dim1 + 1]), abs(d__2));
rwork[1] = 0.;
rwork[*n + 1] = 0.;
i__1 = *n;
for (j = 2;
j <= i__1;
++j)
{
rwork[j] = 0.;
rwork[*n + j] = 0.;
i__2 = j - 1;
for (i__ = 1;
i__ <= i__2;
++i__)
{
i__3 = i__ + j * s_dim1;
rwork[j] += (d__1 = s[i__3].r, abs(d__1)) + (d__2 = d_imag(&s[i__ + j * s_dim1]), abs(d__2));
i__3 = i__ + j * p_dim1;
rwork[*n + j] += (d__1 = p[i__3].r, abs(d__1)) + (d__2 = d_imag(& p[i__ + j * p_dim1]), abs(d__2));
/* L30: */
}
/* Computing MAX */
i__2 = j + j * s_dim1;
d__3 = anorm;
d__4 = rwork[j] + ((d__1 = s[i__2].r, abs(d__1)) + ( d__2 = d_imag(&s[j + j * s_dim1]), abs(d__2))); // , expr subst
anorm = max(d__3,d__4);
/* Computing MAX */
i__2 = j + j * p_dim1;
d__3 = bnorm;
d__4 = rwork[*n + j] + ((d__1 = p[i__2].r, abs(d__1)) + (d__2 = d_imag(&p[j + j * p_dim1]), abs(d__2))); // , expr subst
bnorm = max(d__3,d__4);
/* L40: */
}
ascale = 1. / max(anorm,safmin);
bscale = 1. / 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 ((d__2 = s[i__2].r, abs(d__2)) + (d__3 = d_imag(&s[je + je * s_dim1]), abs(d__3)) <= safmin && (d__1 = p[i__3].r, abs(d__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.;
vl[i__3].i = 0.; // , expr subst
/* L50: */
}
i__2 = ieig + ieig * vl_dim1;
vl[i__2].r = 1.;
vl[i__2].i = 0.; // , 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;
d__4 = ((d__2 = s[i__2].r, abs(d__2)) + (d__3 = d_imag(&s[je + je * s_dim1]), abs(d__3))) * ascale;
d__5 = (d__1 = p[i__3].r, abs(d__1)) * bscale;
d__4 = max(d__4,d__5); // ; expr subst
temp = 1. / max(d__4,safmin);
i__2 = je + je * s_dim1;
z__2.r = temp * s[i__2].r;
z__2.i = temp * s[i__2].i; // , expr subst
z__1.r = ascale * z__2.r;
z__1.i = ascale * z__2.i; // , expr subst
salpha.r = z__1.r;
salpha.i = z__1.i; // , expr subst
i__2 = je + je * p_dim1;
sbeta = temp * p[i__2].r * bscale;
acoeff = sbeta * ascale;
z__1.r = bscale * salpha.r;
z__1.i = bscale * salpha.i; // , expr subst
bcoeff.r = z__1.r;
bcoeff.i = z__1.i; // , expr subst
/* Scale to avoid underflow */
lsa = abs(sbeta) >= safmin && abs(acoeff) < small;
lsb = (d__1 = salpha.r, abs(d__1)) + (d__2 = d_imag(&salpha), abs(d__2)) >= safmin && (d__3 = bcoeff.r, abs(d__3)) + (d__4 = d_imag(&bcoeff), abs(d__4)) < small;
scale = 1.;
if (lsa)
{
scale = small / abs(sbeta) * min(anorm,big);
}
if (lsb)
{
/* Computing MAX */
d__3 = scale;
d__4 = small / ((d__1 = salpha.r, abs(d__1)) + (d__2 = d_imag(&salpha), abs(d__2))) * min( bnorm,big); // , expr subst
scale = max(d__3,d__4);
}
if (lsa || lsb)
{
/* Computing MIN */
/* Computing MAX */
d__5 = 1., d__6 = abs(acoeff);
d__5 = max(d__5,d__6);
d__6 = (d__1 = bcoeff.r, abs(d__1)) + (d__2 = d_imag(&bcoeff), abs(d__2)); // ; expr subst
d__3 = scale;
d__4 = 1. / (safmin * max(d__5,d__6)); // , expr subst
scale = min(d__3,d__4);
if (lsa)
{
acoeff = ascale * (scale * sbeta);
}
else
{
acoeff = scale * acoeff;
}
if (lsb)
{
z__2.r = scale * salpha.r;
z__2.i = scale * salpha.i; // , expr subst
z__1.r = bscale * z__2.r;
z__1.i = bscale * z__2.i; // , expr subst
bcoeff.r = z__1.r;
bcoeff.i = z__1.i; // , expr subst
}
else
{
z__1.r = scale * bcoeff.r;
z__1.i = scale * bcoeff.i; // , expr subst
bcoeff.r = z__1.r;
bcoeff.i = z__1.i; // , expr subst
}
}
acoefa = abs(acoeff);
bcoefa = (d__1 = bcoeff.r, abs(d__1)) + (d__2 = d_imag(& bcoeff), abs(d__2));
xmax = 1.;
i__2 = *n;
for (jr = 1;
jr <= i__2;
++jr)
{
i__3 = jr;
work[i__3].r = 0.;
work[i__3].i = 0.; // , expr subst
/* L60: */
}
i__2 = je;
work[i__2].r = 1.;
work[i__2].i = 0.; // , expr subst
/* Computing MAX */
d__1 = ulp * acoefa * anorm;
d__2 = ulp * bcoefa * bnorm;
d__1 = max(d__1,d__2); // ; expr subst
dmin__ = max(d__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. / 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;
z__1.r = temp * work[i__5].r;
z__1.i = temp * work[i__5].i; // , expr subst
work[i__4].r = z__1.r;
work[i__4].i = z__1.i; // , expr subst
/* L70: */
}
xmax = 1.;
}
suma.r = 0.;
suma.i = 0.; // , expr subst
sumb.r = 0.;
sumb.i = 0.; // , expr subst
i__3 = j - 1;
for (jr = je;
jr <= i__3;
++jr)
{
d_cnjg(&z__3, &s[jr + j * s_dim1]);
i__4 = jr;
z__2.r = z__3.r * work[i__4].r - z__3.i * work[i__4] .i;
z__2.i = z__3.r * work[i__4].i + z__3.i * work[i__4].r; // , expr subst
z__1.r = suma.r + z__2.r;
z__1.i = suma.i + z__2.i; // , expr subst
suma.r = z__1.r;
suma.i = z__1.i; // , expr subst
d_cnjg(&z__3, &p[jr + j * p_dim1]);
i__4 = jr;
z__2.r = z__3.r * work[i__4].r - z__3.i * work[i__4] .i;
z__2.i = z__3.r * work[i__4].i + z__3.i * work[i__4].r; // , expr subst
z__1.r = sumb.r + z__2.r;
z__1.i = sumb.i + z__2.i; // , expr subst
sumb.r = z__1.r;
sumb.i = z__1.i; // , expr subst
/* L80: */
}
z__2.r = acoeff * suma.r;
z__2.i = acoeff * suma.i; // , expr subst
d_cnjg(&z__4, &bcoeff);
z__3.r = z__4.r * sumb.r - z__4.i * sumb.i;
z__3.i = z__4.r * sumb.i + z__4.i * sumb.r; // , expr subst
z__1.r = z__2.r - z__3.r;
z__1.i = z__2.i - z__3.i; // , expr subst
sum.r = z__1.r;
sum.i = z__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;
z__3.r = acoeff * s[i__3].r;
z__3.i = acoeff * s[i__3].i; // , expr subst
i__4 = j + j * p_dim1;
z__4.r = bcoeff.r * p[i__4].r - bcoeff.i * p[i__4].i;
z__4.i = bcoeff.r * p[i__4].i + bcoeff.i * p[i__4] .r; // , expr subst
z__2.r = z__3.r - z__4.r;
z__2.i = z__3.i - z__4.i; // , expr subst
d_cnjg(&z__1, &z__2);
d__.r = z__1.r;
d__.i = z__1.i; // , expr subst
if ((d__1 = d__.r, abs(d__1)) + (d__2 = d_imag(&d__), abs( d__2)) <= dmin__)
{
z__1.r = dmin__;
z__1.i = 0.; // , expr subst
d__.r = z__1.r;
d__.i = z__1.i; // , expr subst
}
if ((d__1 = d__.r, abs(d__1)) + (d__2 = d_imag(&d__), abs( d__2)) < 1.)
{
if ((d__1 = sum.r, abs(d__1)) + (d__2 = d_imag(&sum), abs(d__2)) >= bignum * ((d__3 = d__.r, abs( d__3)) + (d__4 = d_imag(&d__), abs(d__4))))
{
temp = 1. / ((d__1 = sum.r, abs(d__1)) + (d__2 = d_imag(&sum), abs(d__2)));
i__3 = j - 1;
for (jr = je;
jr <= i__3;
++jr)
{
i__4 = jr;
i__5 = jr;
z__1.r = temp * work[i__5].r;
z__1.i = temp * work[i__5].i; // , expr subst
work[i__4].r = z__1.r;
work[i__4].i = z__1.i; // , expr subst
/* L90: */
}
xmax = temp * xmax;
z__1.r = temp * sum.r;
z__1.i = temp * sum.i; // , expr subst
sum.r = z__1.r;
sum.i = z__1.i; // , expr subst
}
}
i__3 = j;
z__2.r = -sum.r;
z__2.i = -sum.i; // , expr subst
zladiv_(&z__1, &z__2, &d__);
work[i__3].r = z__1.r;
work[i__3].i = z__1.i; // , expr subst
/* Computing MAX */
i__3 = j;
d__3 = xmax;
d__4 = (d__1 = work[i__3].r, abs(d__1)) + ( d__2 = d_imag(&work[j]), abs(d__2)); // , expr subst
xmax = max(d__3,d__4);
/* L100: */
}
/* Back transform eigenvector if HOWMNY='B'. */
if (ilback)
{
i__2 = *n + 1 - je;
zgemv_("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.;
i__2 = *n;
for (jr = ibeg;
jr <= i__2;
++jr)
{
/* Computing MAX */
i__3 = (isrc - 1) * *n + jr;
d__3 = xmax;
d__4 = (d__1 = work[i__3].r, abs(d__1)) + ( d__2 = d_imag(&work[(isrc - 1) * *n + jr]), abs( d__2)); // , expr subst
xmax = max(d__3,d__4);
/* L110: */
}
if (xmax > safmin)
{
temp = 1. / xmax;
i__2 = *n;
for (jr = ibeg;
jr <= i__2;
++jr)
{
i__3 = jr + ieig * vl_dim1;
i__4 = (isrc - 1) * *n + jr;
z__1.r = temp * work[i__4].r;
z__1.i = temp * work[ i__4].i; // , expr subst
vl[i__3].r = z__1.r;
vl[i__3].i = z__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.;
vl[i__3].i = 0.; // , 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 ((d__2 = s[i__1].r, abs(d__2)) + (d__3 = d_imag(&s[je + je * s_dim1]), abs(d__3)) <= safmin && (d__1 = p[i__2].r, abs(d__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.;
vr[i__2].i = 0.; // , expr subst
/* L150: */
}
i__1 = ieig + ieig * vr_dim1;
vr[i__1].r = 1.;
vr[i__1].i = 0.; // , 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;
d__4 = ((d__2 = s[i__1].r, abs(d__2)) + (d__3 = d_imag(&s[je + je * s_dim1]), abs(d__3))) * ascale;
d__5 = (d__1 = p[i__2].r, abs(d__1)) * bscale;
d__4 = max(d__4,d__5); // ; expr subst
temp = 1. / max(d__4,safmin);
i__1 = je + je * s_dim1;
z__2.r = temp * s[i__1].r;
z__2.i = temp * s[i__1].i; // , expr subst
z__1.r = ascale * z__2.r;
z__1.i = ascale * z__2.i; // , expr subst
salpha.r = z__1.r;
salpha.i = z__1.i; // , expr subst
i__1 = je + je * p_dim1;
sbeta = temp * p[i__1].r * bscale;
acoeff = sbeta * ascale;
z__1.r = bscale * salpha.r;
z__1.i = bscale * salpha.i; // , expr subst
bcoeff.r = z__1.r;
bcoeff.i = z__1.i; // , expr subst
/* Scale to avoid underflow */
lsa = abs(sbeta) >= safmin && abs(acoeff) < small;
lsb = (d__1 = salpha.r, abs(d__1)) + (d__2 = d_imag(&salpha), abs(d__2)) >= safmin && (d__3 = bcoeff.r, abs(d__3)) + (d__4 = d_imag(&bcoeff), abs(d__4)) < small;
scale = 1.;
if (lsa)
{
scale = small / abs(sbeta) * min(anorm,big);
}
if (lsb)
{
/* Computing MAX */
d__3 = scale;
d__4 = small / ((d__1 = salpha.r, abs(d__1)) + (d__2 = d_imag(&salpha), abs(d__2))) * min( bnorm,big); // , expr subst
scale = max(d__3,d__4);
}
if (lsa || lsb)
{
/* Computing MIN */
/* Computing MAX */
d__5 = 1., d__6 = abs(acoeff);
d__5 = max(d__5,d__6);
d__6 = (d__1 = bcoeff.r, abs(d__1)) + (d__2 = d_imag(&bcoeff), abs(d__2)); // ; expr subst
d__3 = scale;
d__4 = 1. / (safmin * max(d__5,d__6)); // , expr subst
scale = min(d__3,d__4);
if (lsa)
{
acoeff = ascale * (scale * sbeta);
}
else
{
acoeff = scale * acoeff;
}
if (lsb)
{
z__2.r = scale * salpha.r;
z__2.i = scale * salpha.i; // , expr subst
z__1.r = bscale * z__2.r;
z__1.i = bscale * z__2.i; // , expr subst
bcoeff.r = z__1.r;
bcoeff.i = z__1.i; // , expr subst
}
else
{
z__1.r = scale * bcoeff.r;
z__1.i = scale * bcoeff.i; // , expr subst
bcoeff.r = z__1.r;
bcoeff.i = z__1.i; // , expr subst
}
}
acoefa = abs(acoeff);
bcoefa = (d__1 = bcoeff.r, abs(d__1)) + (d__2 = d_imag(& bcoeff), abs(d__2));
xmax = 1.;
i__1 = *n;
for (jr = 1;
jr <= i__1;
++jr)
{
i__2 = jr;
work[i__2].r = 0.;
work[i__2].i = 0.; // , expr subst
/* L160: */
}
i__1 = je;
work[i__1].r = 1.;
work[i__1].i = 0.; // , expr subst
/* Computing MAX */
d__1 = ulp * acoefa * anorm;
d__2 = ulp * bcoefa * bnorm;
d__1 = max(d__1,d__2); // ; expr subst
dmin__ = max(d__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;
z__2.r = acoeff * s[i__3].r;
z__2.i = acoeff * s[i__3].i; // , expr subst
i__4 = jr + je * p_dim1;
z__3.r = bcoeff.r * p[i__4].r - bcoeff.i * p[i__4].i;
z__3.i = bcoeff.r * p[i__4].i + bcoeff.i * p[i__4] .r; // , expr subst
z__1.r = z__2.r - z__3.r;
z__1.i = z__2.i - z__3.i; // , expr subst
work[i__2].r = z__1.r;
work[i__2].i = z__1.i; // , expr subst
/* L170: */
}
i__1 = je;
work[i__1].r = 1.;
work[i__1].i = 0.; // , 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;
z__2.r = acoeff * s[i__1].r;
z__2.i = acoeff * s[i__1].i; // , expr subst
i__2 = j + j * p_dim1;
z__3.r = bcoeff.r * p[i__2].r - bcoeff.i * p[i__2].i;
z__3.i = bcoeff.r * p[i__2].i + bcoeff.i * p[i__2] .r; // , expr subst
z__1.r = z__2.r - z__3.r;
z__1.i = z__2.i - z__3.i; // , expr subst
d__.r = z__1.r;
d__.i = z__1.i; // , expr subst
if ((d__1 = d__.r, abs(d__1)) + (d__2 = d_imag(&d__), abs( d__2)) <= dmin__)
{
z__1.r = dmin__;
z__1.i = 0.; // , expr subst
d__.r = z__1.r;
d__.i = z__1.i; // , expr subst
}
if ((d__1 = d__.r, abs(d__1)) + (d__2 = d_imag(&d__), abs( d__2)) < 1.)
{
i__1 = j;
if ((d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag( &work[j]), abs(d__2)) >= bignum * ((d__3 = d__.r, abs(d__3)) + (d__4 = d_imag(&d__), abs( d__4))))
{
i__1 = j;
temp = 1. / ((d__1 = work[i__1].r, abs(d__1)) + ( d__2 = d_imag(&work[j]), abs(d__2)));
i__1 = je;
for (jr = 1;
jr <= i__1;
++jr)
{
i__2 = jr;
i__3 = jr;
z__1.r = temp * work[i__3].r;
z__1.i = temp * work[i__3].i; // , expr subst
work[i__2].r = z__1.r;
work[i__2].i = z__1.i; // , expr subst
/* L180: */
}
}
}
i__1 = j;
i__2 = j;
z__2.r = -work[i__2].r;
z__2.i = -work[i__2].i; // , expr subst
zladiv_(&z__1, &z__2, &d__);
work[i__1].r = z__1.r;
work[i__1].i = z__1.i; // , expr subst
if (j > 1)
{
/* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling */
i__1 = j;
if ((d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag( &work[j]), abs(d__2)) > 1.)
{
i__1 = j;
temp = 1. / ((d__1 = work[i__1].r, abs(d__1)) + ( d__2 = d_imag(&work[j]), abs(d__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;
z__1.r = temp * work[i__3].r;
z__1.i = temp * work[i__3].i; // , expr subst
work[i__2].r = z__1.r;
work[i__2].i = z__1.i; // , expr subst
/* L190: */
}
}
}
i__1 = j;
z__1.r = acoeff * work[i__1].r;
z__1.i = acoeff * work[i__1].i; // , expr subst
ca.r = z__1.r;
ca.i = z__1.i; // , expr subst
i__1 = j;
z__1.r = bcoeff.r * work[i__1].r - bcoeff.i * work[ i__1].i;
z__1.i = bcoeff.r * work[i__1].i + bcoeff.i * work[i__1].r; // , expr subst
cb.r = z__1.r;
cb.i = z__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;
z__3.r = ca.r * s[i__4].r - ca.i * s[i__4].i;
z__3.i = ca.r * s[i__4].i + ca.i * s[i__4] .r; // , expr subst
z__2.r = work[i__3].r + z__3.r;
z__2.i = work[ i__3].i + z__3.i; // , expr subst
i__5 = jr + j * p_dim1;
z__4.r = cb.r * p[i__5].r - cb.i * p[i__5].i;
z__4.i = cb.r * p[i__5].i + cb.i * p[i__5] .r; // , expr subst
z__1.r = z__2.r - z__4.r;
z__1.i = z__2.i - z__4.i; // , expr subst
work[i__2].r = z__1.r;
work[i__2].i = z__1.i; // , expr subst
/* L200: */
}
}
/* L210: */
}
/* Back transform eigenvector if HOWMNY='B'. */
if (ilback)
{
zgemv_("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.;
i__1 = iend;
for (jr = 1;
jr <= i__1;
++jr)
{
/* Computing MAX */
i__2 = (isrc - 1) * *n + jr;
d__3 = xmax;
d__4 = (d__1 = work[i__2].r, abs(d__1)) + ( d__2 = d_imag(&work[(isrc - 1) * *n + jr]), abs( d__2)); // , expr subst
xmax = max(d__3,d__4);
/* L220: */
}
if (xmax > safmin)
{
temp = 1. / xmax;
i__1 = iend;
for (jr = 1;
jr <= i__1;
++jr)
{
i__2 = jr + ieig * vr_dim1;
i__3 = (isrc - 1) * *n + jr;
z__1.r = temp * work[i__3].r;
z__1.i = temp * work[ i__3].i; // , expr subst
vr[i__2].r = z__1.r;
vr[i__2].i = z__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.;
vr[i__2].i = 0.; // , expr subst
/* L240: */
}
}
L250:
;
}
}
return 0;
/* End of ZTGEVC */
}
/* Subroutine */ int zlatps_(char *uplo, char *trans, char *diag, char *
normin, integer *n, doublecomplex *ap, doublecomplex *x, doublereal *
scale, doublereal *cnorm, integer *info)
{
/* -- LAPACK auxiliary routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
ZLATPS 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, where A is an upper or lower
triangular matrix stored in packed form. Here 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 ZTPSV 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.
AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
The upper or lower triangular matrix A, packed columnwise in
a linear array. The j-th column of A is stored in the array
AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
X (input/output) COMPLEX*16 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) DOUBLE PRECISION
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) DOUBLE PRECISION 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, ZTPSV
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 ZTPSV 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 ZTPSV if 1/M(n) and 1/G(n) are both greater
than max(underflow, 1/overflow).
=====================================================================
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b36 = .5;
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static integer jinc, jlen;
static doublereal xbnd;
static integer imax;
static doublereal tmax;
static doublecomplex tjjs;
static doublereal xmax, grow;
static integer i, j;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
static doublereal tscal;
static doublecomplex uscal;
static integer jlast;
static doublecomplex csumj;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static logical upper;
extern /* Double Complex */ VOID zdotu_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *), ztpsv_(
char *, char *, char *, integer *, doublecomplex *, doublecomplex
*, integer *), dlabad_(doublereal *,
doublereal *);
extern doublereal dlamch_(char *);
static integer ip;
static doublereal xj;
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *);
static doublereal bignum;
extern integer izamax_(integer *, doublecomplex *, integer *);
extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *,
doublecomplex *);
static logical notran;
static integer jfirst;
extern doublereal dzasum_(integer *, doublecomplex *, integer *);
static doublereal smlnum;
static logical nounit;
static doublereal rec, tjj;
#define CNORM(I) cnorm[(I)-1]
#define X(I) x[(I)-1]
#define AP(I) ap[(I)-1]
*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_("ZLATPS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine machine dependent parameters to control overflow. */
smlnum = dlamch_("Safe minimum");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
smlnum /= dlamch_("Precision");
bignum = 1. / smlnum;
*scale = 1.;
if (lsame_(normin, "N")) {
/* Compute the 1-norm of each column, not including the diagona
l. */
if (upper) {
/* A is upper triangular. */
ip = 1;
i__1 = *n;
for (j = 1; j <= *n; ++j) {
i__2 = j - 1;
CNORM(j) = dzasum_(&i__2, &AP(ip), &c__1);
ip += j;
/* L10: */
}
} else {
/* A is lower triangular. */
ip = 1;
i__1 = *n - 1;
for (j = 1; j <= *n-1; ++j) {
i__2 = *n - j;
CNORM(j) = dzasum_(&i__2, &AP(ip + 1), &c__1);
ip = ip + *n - j + 1;
/* L20: */
}
CNORM(*n) = 0.;
}
}
/* Scale the column norms by TSCAL if the maximum element in CNORM is
greater than BIGNUM/2. */
imax = idamax_(n, &CNORM(1), &c__1);
tmax = CNORM(imax);
if (tmax <= bignum * .5) {
tscal = 1.;
} else {
tscal = .5 / (smlnum * tmax);
dscal_(n, &tscal, &CNORM(1), &c__1);
}
/* Compute a bound on the computed solution vector to see if the
Level 2 BLAS routine ZTPSV can be used. */
xmax = 0.;
i__1 = *n;
for (j = 1; j <= *n; ++j) {
/* Computing MAX */
i__2 = j;
d__3 = xmax, d__4 = (d__1 = X(j).r / 2., abs(d__1)) + (d__2 =
d_imag(&X(j)) / 2., abs(d__2));
xmax = max(d__3,d__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.) {
grow = 0.;
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 = .5 / max(xbnd,smlnum);
xbnd = grow;
ip = jfirst * (jfirst + 1) / 2;
jlen = *n;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) {
/* Exit the loop if the growth factor is too smal
l. */
if (grow <= smlnum) {
goto L60;
}
i__3 = ip;
tjjs.r = AP(ip).r, tjjs.i = AP(ip).i;
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
d__2));
if (tjj >= smlnum) {
/* M(j) = G(j-1) / abs(A(j,j))
Computing MIN */
d__1 = xbnd, d__2 = min(1.,tjj) * grow;
xbnd = min(d__1,d__2);
} else {
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.;
}
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.;
}
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 */
d__1 = 1., d__2 = .5 / max(xbnd,smlnum);
grow = min(d__1,d__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) {
/* Exit the loop if the growth factor is too smal
l. */
if (grow <= smlnum) {
goto L60;
}
/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
grow *= 1. / (CNORM(j) + 1.);
/* 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.) {
grow = 0.;
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 = .5 / max(xbnd,smlnum);
xbnd = grow;
ip = jfirst * (jfirst + 1) / 2;
jlen = 1;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) {
/* Exit the loop if the growth factor is too smal
l. */
if (grow <= smlnum) {
goto L90;
}
/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
*/
xj = CNORM(j) + 1.;
/* Computing MIN */
d__1 = grow, d__2 = xbnd / xj;
grow = min(d__1,d__2);
i__3 = ip;
tjjs.r = AP(ip).r, tjjs.i = AP(ip).i;
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
d__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.;
}
++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 */
d__1 = 1., d__2 = .5 / max(xbnd,smlnum);
grow = min(d__1,d__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) {
/* Exit the loop if the growth factor is too smal
l. */
if (grow <= smlnum) {
goto L90;
}
/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
xj = CNORM(j) + 1.;
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. */
ztpsv_(uplo, trans, diag, n, &AP(1), &X(1), &c__1);
} else {
/* Use a Level 1 BLAS solve, scaling intermediate results. */
if (xmax > bignum * .5) {
/* Scale X so that its components are less than or equal
to
BIGNUM in absolute value. */
*scale = bignum * .5 / xmax;
zdscal_(n, scale, &X(1), &c__1);
xmax = bignum;
} else {
xmax *= 2.;
}
if (notran) {
/* Solve A * x = b */
ip = jfirst * (jfirst + 1) / 2;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) {
/* Compute x(j) = b(j) / A(j,j), scaling x if nec
essary. */
i__3 = j;
xj = (d__1 = X(j).r, abs(d__1)) + (d__2 = d_imag(&X(j)),
abs(d__2));
if (nounit) {
i__3 = ip;
z__1.r = tscal * AP(ip).r, z__1.i = tscal * AP(ip).i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
if (tscal == 1.) {
goto L110;
}
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
d__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale x by 1/b(j). */
rec = 1. / xj;
zdscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &X(j), &tjjs);
X(j).r = z__1.r, X(j).i = z__1.i;
i__3 = j;
xj = (d__1 = X(j).r, abs(d__1)) + (d__2 = d_imag(&X(j))
, abs(d__2));
} else if (tjj > 0.) {
/* 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 dividi
ng by A(j,j). */
rec = tjj * bignum / xj;
if (CNORM(j) > 1.) {
/* Scale by 1/CNORM(j) to
avoid overflow when
multiplying x(j) times
column j. */
rec /= CNORM(j);
}
zdscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &X(j), &tjjs);
X(j).r = z__1.r, X(j).i = z__1.i;
i__3 = j;
xj = (d__1 = X(j).r, abs(d__1)) + (d__2 = d_imag(&X(j))
, abs(d__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 <= *n; ++i) {
i__4 = i;
X(i).r = 0., X(i).i = 0.;
/* L100: */
}
i__3 = j;
X(j).r = 1., X(j).i = 0.;
xj = 1.;
*scale = 0.;
xmax = 0.;
}
L110:
/* Scale x if necessary to avoid overflow when ad
ding a
multiple of column j of A. */
if (xj > 1.) {
rec = 1. / xj;
if (CNORM(j) > (bignum - xmax) * rec) {
/* Scale x by 1/(2*abs(x(j))). */
rec *= .5;
zdscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
}
} else if (xj * CNORM(j) > bignum - xmax) {
/* Scale x by 1/2. */
zdscal_(n, &c_b36, &X(1), &c__1);
*scale *= .5;
}
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;
z__2.r = -X(j).r, z__2.i = -X(j).i;
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
zaxpy_(&i__3, &z__1, &AP(ip - j + 1), &c__1, &X(1), &
c__1);
i__3 = j - 1;
i = izamax_(&i__3, &X(1), &c__1);
i__3 = i;
xmax = (d__1 = X(i).r, abs(d__1)) + (d__2 = d_imag(
&X(i)), abs(d__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;
z__2.r = -X(j).r, z__2.i = -X(j).i;
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
zaxpy_(&i__3, &z__1, &AP(ip + 1), &c__1, &X(j + 1), &
c__1);
i__3 = *n - j;
i = j + izamax_(&i__3, &X(j + 1), &c__1);
i__3 = i;
xmax = (d__1 = X(i).r, abs(d__1)) + (d__2 = d_imag(
&X(i)), abs(d__2));
}
ip = ip + *n - j + 1;
}
/* L120: */
}
} 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; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) {
/* Compute x(j) = b(j) - sum A(k,j)*x(k).
k<>j */
i__3 = j;
xj = (d__1 = X(j).r, abs(d__1)) + (d__2 = d_imag(&X(j)),
abs(d__2));
uscal.r = tscal, uscal.i = 0.;
rec = 1. / max(xmax,1.);
if (CNORM(j) > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2
*XMAX). */
rec *= .5;
if (nounit) {
i__3 = ip;
z__1.r = tscal * AP(ip).r, z__1.i = tscal * AP(ip)
.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > 1.) {
/* Divide by A(j,j) when scaling
x if A(j,j) > 1.
Computing MIN */
d__1 = 1., d__2 = rec * tjj;
rec = min(d__1,d__2);
zladiv_(&z__1, &uscal, &tjjs);
uscal.r = z__1.r, uscal.i = z__1.i;
}
if (rec < 1.) {
zdscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0., csumj.i = 0.;
if (uscal.r == 1. && uscal.i == 0.) {
/* If the scaling needed for A in the dot
product is 1,
call ZDOTU to perform the dot product.
*/
if (upper) {
i__3 = j - 1;
zdotu_(&z__1, &i__3, &AP(ip - j + 1), &c__1, &X(1), &
c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
} else if (j < *n) {
i__3 = *n - j;
zdotu_(&z__1, &i__3, &AP(ip + 1), &c__1, &X(j + 1), &
c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
}
} else {
/* Otherwise, use in-line code for the dot
product. */
if (upper) {
i__3 = j - 1;
for (i = 1; i <= j-1; ++i) {
i__4 = ip - j + i;
z__3.r = AP(ip-j+i).r * uscal.r - AP(ip-j+i).i *
uscal.i, z__3.i = AP(ip-j+i).r * uscal.i +
AP(ip-j+i).i * uscal.r;
i__5 = i;
z__2.r = z__3.r * X(i).r - z__3.i * X(i).i,
z__2.i = z__3.r * X(i).i + z__3.i * X(
i).r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
/* L130: */
}
} else if (j < *n) {
i__3 = *n - j;
for (i = 1; i <= *n-j; ++i) {
i__4 = ip + i;
z__3.r = AP(ip+i).r * uscal.r - AP(ip+i).i *
uscal.i, z__3.i = AP(ip+i).r * uscal.i +
AP(ip+i).i * uscal.r;
i__5 = j + i;
z__2.r = z__3.r * X(j+i).r - z__3.i * X(j+i).i,
z__2.i = z__3.r * X(j+i).i + z__3.i * X(
j+i).r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
/* L140: */
}
}
}
z__1.r = tscal, z__1.i = 0.;
if (uscal.r == z__1.r && uscal.i == z__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;
z__1.r = X(j).r - csumj.r, z__1.i = X(j).i -
csumj.i;
X(j).r = z__1.r, X(j).i = z__1.i;
i__3 = j;
xj = (d__1 = X(j).r, abs(d__1)) + (d__2 = d_imag(&X(j))
, abs(d__2));
if (nounit) {
/* Compute x(j) = x(j) / A(j,j), sc
aling if necessary. */
i__3 = ip;
z__1.r = tscal * AP(ip).r, z__1.i = tscal * AP(ip)
.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
if (tscal == 1.) {
goto L160;
}
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale X by 1/ab
s(x(j)). */
rec = 1. / xj;
zdscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &X(j), &tjjs);
X(j).r = z__1.r, X(j).i = z__1.i;
} else if (tjj > 0.) {
/* 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;
zdscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &X(j), &tjjs);
X(j).r = z__1.r, X(j).i = z__1.i;
} else {
/* A(j,j) = 0: Set x(1:n) = 0,
x(j) = 1, and
scale = 0 and compute a solut
ion to A**T *x = 0. */
i__3 = *n;
for (i = 1; i <= *n; ++i) {
i__4 = i;
X(i).r = 0., X(i).i = 0.;
/* L150: */
}
i__3 = j;
X(j).r = 1., X(j).i = 0.;
*scale = 0.;
xmax = 0.;
}
L160:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - CSUMJ i
f the dot
product has already been divided by 1/A
(j,j). */
i__3 = j;
zladiv_(&z__2, &X(j), &tjjs);
z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i;
X(j).r = z__1.r, X(j).i = z__1.i;
}
/* Computing MAX */
i__3 = j;
d__3 = xmax, d__4 = (d__1 = X(j).r, abs(d__1)) + (d__2 =
d_imag(&X(j)), abs(d__2));
xmax = max(d__3,d__4);
++jlen;
ip += jinc * jlen;
/* L170: */
}
} else {
/* Solve A**H * x = b */
ip = jfirst * (jfirst + 1) / 2;
jlen = 1;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; jinc < 0 ? j >= jlast : j <= jlast; j += jinc) {
/* Compute x(j) = b(j) - sum A(k,j)*x(k).
k<>j */
i__3 = j;
xj = (d__1 = X(j).r, abs(d__1)) + (d__2 = d_imag(&X(j)),
abs(d__2));
uscal.r = tscal, uscal.i = 0.;
rec = 1. / max(xmax,1.);
if (CNORM(j) > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2
*XMAX). */
rec *= .5;
if (nounit) {
d_cnjg(&z__2, &AP(ip));
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > 1.) {
/* Divide by A(j,j) when scaling
x if A(j,j) > 1.
Computing MIN */
d__1 = 1., d__2 = rec * tjj;
rec = min(d__1,d__2);
zladiv_(&z__1, &uscal, &tjjs);
uscal.r = z__1.r, uscal.i = z__1.i;
}
if (rec < 1.) {
zdscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0., csumj.i = 0.;
if (uscal.r == 1. && uscal.i == 0.) {
/* If the scaling needed for A in the dot
product is 1,
call ZDOTC to perform the dot product.
*/
if (upper) {
i__3 = j - 1;
zdotc_(&z__1, &i__3, &AP(ip - j + 1), &c__1, &X(1), &
c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
} else if (j < *n) {
i__3 = *n - j;
zdotc_(&z__1, &i__3, &AP(ip + 1), &c__1, &X(j + 1), &
c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
}
} else {
/* Otherwise, use in-line code for the dot
product. */
if (upper) {
i__3 = j - 1;
for (i = 1; i <= j-1; ++i) {
d_cnjg(&z__4, &AP(ip - j + i));
z__3.r = z__4.r * uscal.r - z__4.i * uscal.i,
z__3.i = z__4.r * uscal.i + z__4.i *
uscal.r;
i__4 = i;
z__2.r = z__3.r * X(i).r - z__3.i * X(i).i,
z__2.i = z__3.r * X(i).i + z__3.i * X(
i).r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
/* L180: */
}
} else if (j < *n) {
i__3 = *n - j;
for (i = 1; i <= *n-j; ++i) {
d_cnjg(&z__4, &AP(ip + i));
z__3.r = z__4.r * uscal.r - z__4.i * uscal.i,
z__3.i = z__4.r * uscal.i + z__4.i *
uscal.r;
i__4 = j + i;
z__2.r = z__3.r * X(j+i).r - z__3.i * X(j+i).i,
z__2.i = z__3.r * X(j+i).i + z__3.i * X(
j+i).r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
/* L190: */
}
}
}
z__1.r = tscal, z__1.i = 0.;
if (uscal.r == z__1.r && uscal.i == z__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;
z__1.r = X(j).r - csumj.r, z__1.i = X(j).i -
csumj.i;
X(j).r = z__1.r, X(j).i = z__1.i;
i__3 = j;
xj = (d__1 = X(j).r, abs(d__1)) + (d__2 = d_imag(&X(j))
, abs(d__2));
if (nounit) {
/* Compute x(j) = x(j) / A(j,j), sc
aling if necessary. */
d_cnjg(&z__2, &AP(ip));
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
if (tscal == 1.) {
goto L210;
}
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale X by 1/ab
s(x(j)). */
rec = 1. / xj;
zdscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &X(j), &tjjs);
X(j).r = z__1.r, X(j).i = z__1.i;
} else if (tjj > 0.) {
/* 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;
zdscal_(n, &rec, &X(1), &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &X(j), &tjjs);
X(j).r = z__1.r, X(j).i = z__1.i;
} else {
/* A(j,j) = 0: Set x(1:n) = 0,
x(j) = 1, and
scale = 0 and compute a solut
ion to A**H *x = 0. */
i__3 = *n;
for (i = 1; i <= *n; ++i) {
i__4 = i;
X(i).r = 0., X(i).i = 0.;
/* L200: */
}
i__3 = j;
X(j).r = 1., X(j).i = 0.;
*scale = 0.;
xmax = 0.;
}
L210:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - CSUMJ i
f the dot
product has already been divided by 1/A
(j,j). */
i__3 = j;
zladiv_(&z__2, &X(j), &tjjs);
z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i;
X(j).r = z__1.r, X(j).i = z__1.i;
}
/* Computing MAX */
i__3 = j;
d__3 = xmax, d__4 = (d__1 = X(j).r, abs(d__1)) + (d__2 =
d_imag(&X(j)), abs(d__2));
xmax = max(d__3,d__4);
++jlen;
ip += jinc * jlen;
/* L220: */
}
}
*scale /= tscal;
}
/* Scale the column norms by 1/TSCAL for return. */
if (tscal != 1.) {
d__1 = 1. / tscal;
dscal_(n, &d__1, &CNORM(1), &c__1);
}
return 0;
/* End of ZLATPS */
} /* zlatps_ */
/* Subroutine */
int zlatps_(char *uplo, char *trans, char *diag, char * normin, integer *n, doublecomplex *ap, doublecomplex *x, doublereal * scale, doublereal *cnorm, integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j, ip;
doublereal xj, rec, tjj;
integer jinc, jlen;
doublereal xbnd;
integer imax;
doublereal tmax;
doublecomplex tjjs;
doublereal xmax, grow;
extern /* Subroutine */
int dscal_(integer *, doublereal *, doublereal *, integer *);
extern logical lsame_(char *, char *);
doublereal tscal;
doublecomplex uscal;
integer jlast;
doublecomplex csumj;
extern /* Double Complex */
VOID zdotc_f2c_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *);
logical upper;
extern /* Double Complex */
VOID zdotu_f2c_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *);
extern /* Subroutine */
int zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), ztpsv_( char *, char *, char *, integer *, doublecomplex *, doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */
int xerbla_(char *, integer *), zdscal_( integer *, doublereal *, doublecomplex *, integer *);
doublereal bignum;
extern integer izamax_(integer *, doublecomplex *, integer *);
extern /* Double Complex */
VOID zladiv_(doublecomplex *, doublecomplex *, doublecomplex *);
logical notran;
integer jfirst;
extern doublereal dzasum_(integer *, doublecomplex *, integer *);
doublereal 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_("ZLATPS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
return 0;
}
/* Determine machine dependent parameters to control overflow. */
smlnum = dlamch_("Safe minimum");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
smlnum /= dlamch_("Precision");
bignum = 1. / smlnum;
*scale = 1.;
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] = dzasum_(&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] = dzasum_(&i__2, &ap[ip + 1], &c__1);
ip = ip + *n - j + 1;
/* L20: */
}
cnorm[*n] = 0.;
}
}
/* Scale the column norms by TSCAL if the maximum element in CNORM is */
/* greater than BIGNUM/2. */
imax = idamax_(n, &cnorm[1], &c__1);
tmax = cnorm[imax];
if (tmax <= bignum * .5)
{
tscal = 1.;
}
else
{
tscal = .5 / (smlnum * tmax);
dscal_(n, &tscal, &cnorm[1], &c__1);
}
/* Compute a bound on the computed solution vector to see if the */
/* Level 2 BLAS routine ZTPSV can be used. */
xmax = 0.;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MAX */
i__2 = j;
d__3 = xmax;
d__4 = (d__1 = x[i__2].r / 2., abs(d__1)) + (d__2 = d_imag(&x[j]) / 2., abs(d__2)); // , expr subst
xmax = max(d__3,d__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.)
{
grow = 0.;
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 = .5 / 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 = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs( d__2));
if (tjj >= smlnum)
{
/* M(j) = G(j-1) / abs(A(j,j)) */
/* Computing MIN */
d__1 = xbnd;
d__2 = min(1.,tjj) * grow; // , expr subst
xbnd = min(d__1,d__2);
}
else
{
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.;
}
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.;
}
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 */
d__1 = 1.;
d__2 = .5 / max(xbnd,smlnum); // , expr subst
grow = min(d__1,d__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. / (cnorm[j] + 1.);
/* 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.)
{
grow = 0.;
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 = .5 / 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.;
/* Computing MIN */
d__1 = grow;
d__2 = xbnd / xj; // , expr subst
grow = min(d__1,d__2);
i__3 = ip;
tjjs.r = ap[i__3].r;
tjjs.i = ap[i__3].i; // , expr subst
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs( d__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.;
}
++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 */
d__1 = 1.;
d__2 = .5 / max(xbnd,smlnum); // , expr subst
grow = min(d__1,d__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.;
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. */
ztpsv_(uplo, trans, diag, n, &ap[1], &x[1], &c__1);
}
else
{
/* Use a Level 1 BLAS solve, scaling intermediate results. */
if (xmax > bignum * .5)
{
/* Scale X so that its components are less than or equal to */
/* BIGNUM in absolute value. */
*scale = bignum * .5 / xmax;
zdscal_(n, scale, &x[1], &c__1);
xmax = bignum;
}
else
{
xmax *= 2.;
}
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 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]), abs(d__2));
if (nounit)
{
i__3 = ip;
z__1.r = tscal * ap[i__3].r;
z__1.i = tscal * ap[i__3].i; // , expr subst
tjjs.r = z__1.r;
tjjs.i = z__1.i; // , expr subst
}
else
{
tjjs.r = tscal;
tjjs.i = 0.; // , expr subst
if (tscal == 1.)
{
goto L110;
}
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs( d__2));
if (tjj > smlnum)
{
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.)
{
if (xj > tjj * bignum)
{
/* Scale x by 1/b(j). */
rec = 1. / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r;
x[i__3].i = z__1.i; // , expr subst
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]) , abs(d__2));
}
else if (tjj > 0.)
{
/* 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.)
{
/* Scale by 1/CNORM(j) to avoid overflow when */
/* multiplying x(j) times column j. */
rec /= cnorm[j];
}
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r;
x[i__3].i = z__1.i; // , expr subst
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]) , abs(d__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.;
x[i__4].i = 0.; // , expr subst
/* L100: */
}
i__3 = j;
x[i__3].r = 1.;
x[i__3].i = 0.; // , expr subst
xj = 1.;
*scale = 0.;
xmax = 0.;
}
L110: /* Scale x if necessary to avoid overflow when adding a */
/* multiple of column j of A. */
if (xj > 1.)
{
rec = 1. / xj;
if (cnorm[j] > (bignum - xmax) * rec)
{
/* Scale x by 1/(2*abs(x(j))). */
rec *= .5;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
}
else if (xj * cnorm[j] > bignum - xmax)
{
/* Scale x by 1/2. */
zdscal_(n, &c_b36, &x[1], &c__1);
*scale *= .5;
}
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;
z__2.r = -x[i__4].r;
z__2.i = -x[i__4].i; // , expr subst
z__1.r = tscal * z__2.r;
z__1.i = tscal * z__2.i; // , expr subst
zaxpy_(&i__3, &z__1, &ap[ip - j + 1], &c__1, &x[1], & c__1);
i__3 = j - 1;
i__ = izamax_(&i__3, &x[1], &c__1);
i__3 = i__;
xmax = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag( &x[i__]), abs(d__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;
z__2.r = -x[i__4].r;
z__2.i = -x[i__4].i; // , expr subst
z__1.r = tscal * z__2.r;
z__1.i = tscal * z__2.i; // , expr subst
zaxpy_(&i__3, &z__1, &ap[ip + 1], &c__1, &x[j + 1], & c__1);
i__3 = *n - j;
i__ = j + izamax_(&i__3, &x[j + 1], &c__1);
i__3 = i__;
xmax = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag( &x[i__]), abs(d__2));
}
ip = ip + *n - j + 1;
}
/* L120: */
}
}
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 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]), abs(d__2));
uscal.r = tscal;
uscal.i = 0.; // , expr subst
rec = 1. / max(xmax,1.);
if (cnorm[j] > (bignum - xj) * rec)
{
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5;
if (nounit)
{
i__3 = ip;
z__1.r = tscal * ap[i__3].r;
z__1.i = tscal * ap[i__3] .i; // , expr subst
tjjs.r = z__1.r;
tjjs.i = z__1.i; // , expr subst
}
else
{
tjjs.r = tscal;
tjjs.i = 0.; // , expr subst
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(d__2));
if (tjj > 1.)
{
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
d__1 = 1.;
d__2 = rec * tjj; // , expr subst
rec = min(d__1,d__2);
zladiv_(&z__1, &uscal, &tjjs);
uscal.r = z__1.r;
uscal.i = z__1.i; // , expr subst
}
if (rec < 1.)
{
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0.;
csumj.i = 0.; // , expr subst
if (uscal.r == 1. && uscal.i == 0.)
{
/* If the scaling needed for A in the dot product is 1, */
/* call ZDOTU to perform the dot product. */
if (upper)
{
i__3 = j - 1;
zdotu_f2c_(&z__1, &i__3, &ap[ip - j + 1], &c__1, &x[1], & c__1);
csumj.r = z__1.r;
csumj.i = z__1.i; // , expr subst
}
else if (j < *n)
{
i__3 = *n - j;
zdotu_f2c_(&z__1, &i__3, &ap[ip + 1], &c__1, &x[j + 1], & c__1);
csumj.r = z__1.r;
csumj.i = z__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__;
z__3.r = ap[i__4].r * uscal.r - ap[i__4].i * uscal.i;
z__3.i = ap[i__4].r * uscal.i + ap[i__4].i * uscal.r; // , expr subst
i__5 = i__;
z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i;
z__2.i = z__3.r * x[i__5].i + z__3.i * x[ i__5].r; // , expr subst
z__1.r = csumj.r + z__2.r;
z__1.i = csumj.i + z__2.i; // , expr subst
csumj.r = z__1.r;
csumj.i = z__1.i; // , expr subst
/* L130: */
}
}
else if (j < *n)
{
i__3 = *n - j;
for (i__ = 1;
i__ <= i__3;
++i__)
{
i__4 = ip + i__;
z__3.r = ap[i__4].r * uscal.r - ap[i__4].i * uscal.i;
z__3.i = ap[i__4].r * uscal.i + ap[i__4].i * uscal.r; // , expr subst
i__5 = j + i__;
z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i;
z__2.i = z__3.r * x[i__5].i + z__3.i * x[ i__5].r; // , expr subst
z__1.r = csumj.r + z__2.r;
z__1.i = csumj.i + z__2.i; // , expr subst
csumj.r = z__1.r;
csumj.i = z__1.i; // , expr subst
/* L140: */
}
}
}
z__1.r = tscal;
z__1.i = 0.; // , expr subst
if (uscal.r == z__1.r && uscal.i == z__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;
z__1.r = x[i__4].r - csumj.r;
z__1.i = x[i__4].i - csumj.i; // , expr subst
x[i__3].r = z__1.r;
x[i__3].i = z__1.i; // , expr subst
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]) , abs(d__2));
if (nounit)
{
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
i__3 = ip;
z__1.r = tscal * ap[i__3].r;
z__1.i = tscal * ap[i__3] .i; // , expr subst
tjjs.r = z__1.r;
tjjs.i = z__1.i; // , expr subst
}
else
{
tjjs.r = tscal;
tjjs.i = 0.; // , expr subst
if (tscal == 1.)
{
goto L160;
}
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(d__2));
if (tjj > smlnum)
{
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.)
{
if (xj > tjj * bignum)
{
/* Scale X by 1/abs(x(j)). */
rec = 1. / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r;
x[i__3].i = z__1.i; // , expr subst
}
else if (tjj > 0.)
{
/* 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;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r;
x[i__3].i = z__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.;
x[i__4].i = 0.; // , expr subst
/* L150: */
}
i__3 = j;
x[i__3].r = 1.;
x[i__3].i = 0.; // , expr subst
*scale = 0.;
xmax = 0.;
}
L160:
;
}
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;
zladiv_(&z__2, &x[j], &tjjs);
z__1.r = z__2.r - csumj.r;
z__1.i = z__2.i - csumj.i; // , expr subst
x[i__3].r = z__1.r;
x[i__3].i = z__1.i; // , expr subst
}
/* Computing MAX */
i__3 = j;
d__3 = xmax;
d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]), abs(d__2)); // , expr subst
xmax = max(d__3,d__4);
++jlen;
ip += jinc * jlen;
/* L170: */
}
}
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 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]), abs(d__2));
uscal.r = tscal;
uscal.i = 0.; // , expr subst
rec = 1. / max(xmax,1.);
if (cnorm[j] > (bignum - xj) * rec)
{
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5;
if (nounit)
{
d_cnjg(&z__2, &ap[ip]);
z__1.r = tscal * z__2.r;
z__1.i = tscal * z__2.i; // , expr subst
tjjs.r = z__1.r;
tjjs.i = z__1.i; // , expr subst
}
else
{
tjjs.r = tscal;
tjjs.i = 0.; // , expr subst
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(d__2));
if (tjj > 1.)
{
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
d__1 = 1.;
d__2 = rec * tjj; // , expr subst
rec = min(d__1,d__2);
zladiv_(&z__1, &uscal, &tjjs);
uscal.r = z__1.r;
uscal.i = z__1.i; // , expr subst
}
if (rec < 1.)
{
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0.;
csumj.i = 0.; // , expr subst
if (uscal.r == 1. && uscal.i == 0.)
{
/* If the scaling needed for A in the dot product is 1, */
/* call ZDOTC to perform the dot product. */
if (upper)
{
i__3 = j - 1;
zdotc_f2c_(&z__1, &i__3, &ap[ip - j + 1], &c__1, &x[1], & c__1);
csumj.r = z__1.r;
csumj.i = z__1.i; // , expr subst
}
else if (j < *n)
{
i__3 = *n - j;
zdotc_f2c_(&z__1, &i__3, &ap[ip + 1], &c__1, &x[j + 1], & c__1);
csumj.r = z__1.r;
csumj.i = z__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__)
{
d_cnjg(&z__4, &ap[ip - j + i__]);
z__3.r = z__4.r * uscal.r - z__4.i * uscal.i;
z__3.i = z__4.r * uscal.i + z__4.i * uscal.r; // , expr subst
i__4 = i__;
z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i;
z__2.i = z__3.r * x[i__4].i + z__3.i * x[ i__4].r; // , expr subst
z__1.r = csumj.r + z__2.r;
z__1.i = csumj.i + z__2.i; // , expr subst
csumj.r = z__1.r;
csumj.i = z__1.i; // , expr subst
/* L180: */
}
}
else if (j < *n)
{
i__3 = *n - j;
for (i__ = 1;
i__ <= i__3;
++i__)
{
d_cnjg(&z__4, &ap[ip + i__]);
z__3.r = z__4.r * uscal.r - z__4.i * uscal.i;
z__3.i = z__4.r * uscal.i + z__4.i * uscal.r; // , expr subst
i__4 = j + i__;
z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i;
z__2.i = z__3.r * x[i__4].i + z__3.i * x[ i__4].r; // , expr subst
z__1.r = csumj.r + z__2.r;
z__1.i = csumj.i + z__2.i; // , expr subst
csumj.r = z__1.r;
csumj.i = z__1.i; // , expr subst
/* L190: */
}
}
}
z__1.r = tscal;
z__1.i = 0.; // , expr subst
if (uscal.r == z__1.r && uscal.i == z__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;
z__1.r = x[i__4].r - csumj.r;
z__1.i = x[i__4].i - csumj.i; // , expr subst
x[i__3].r = z__1.r;
x[i__3].i = z__1.i; // , expr subst
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]) , abs(d__2));
if (nounit)
{
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
d_cnjg(&z__2, &ap[ip]);
z__1.r = tscal * z__2.r;
z__1.i = tscal * z__2.i; // , expr subst
tjjs.r = z__1.r;
tjjs.i = z__1.i; // , expr subst
}
else
{
tjjs.r = tscal;
tjjs.i = 0.; // , expr subst
if (tscal == 1.)
{
goto L210;
}
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(d__2));
if (tjj > smlnum)
{
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.)
{
if (xj > tjj * bignum)
{
/* Scale X by 1/abs(x(j)). */
rec = 1. / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r;
x[i__3].i = z__1.i; // , expr subst
}
else if (tjj > 0.)
{
/* 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;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r;
x[i__3].i = z__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.;
x[i__4].i = 0.; // , expr subst
/* L200: */
}
i__3 = j;
x[i__3].r = 1.;
x[i__3].i = 0.; // , expr subst
*scale = 0.;
xmax = 0.;
}
L210:
;
}
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;
zladiv_(&z__2, &x[j], &tjjs);
z__1.r = z__2.r - csumj.r;
z__1.i = z__2.i - csumj.i; // , expr subst
x[i__3].r = z__1.r;
x[i__3].i = z__1.i; // , expr subst
}
/* Computing MAX */
i__3 = j;
d__3 = xmax;
d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]), abs(d__2)); // , expr subst
xmax = max(d__3,d__4);
++jlen;
ip += jinc * jlen;
/* L220: */
}
}
*scale /= tscal;
}
/* Scale the column norms by 1/TSCAL for return. */
if (tscal != 1.)
{
d__1 = 1. / tscal;
dscal_(n, &d__1, &cnorm[1], &c__1);
}
return 0;
/* End of ZLATPS */
}
/* Subroutine */ int zlarfp_(integer *n, doublecomplex *alpha, doublecomplex *
x, integer *incx, doublecomplex *tau)
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2;
doublecomplex z__1, z__2;
/* Builtin functions */
double d_imag(doublecomplex *), d_sign(doublereal *, doublereal *);
/* Local variables */
integer j, knt;
doublereal beta, alphi, alphr;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
doublereal xnorm;
extern doublereal dlapy2_(doublereal *, doublereal *), dlapy3_(doublereal
*, doublereal *, doublereal *), dznrm2_(integer *, doublecomplex *
, integer *), dlamch_(char *);
doublereal safmin;
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *);
doublereal rsafmn;
extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *,
doublecomplex *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLARFP 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*16 */
/* On entry, the value alpha. */
/* On exit, it is overwritten with the value beta. */
/* X (input/output) COMPLEX*16 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*16 */
/* 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., tau->i = 0.;
return 0;
}
i__1 = *n - 1;
xnorm = dznrm2_(&i__1, &x[1], incx);
alphr = alpha->r;
alphi = d_imag(alpha);
if (xnorm == 0. && alphi == 0.) {
/* H = [1-alpha/abs(alpha) 0; 0 I], sign chosen so ALPHA >= 0. */
if (alphi == 0.) {
if (alphr >= 0.) {
/* 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., tau->i = 0.;
} else {
/* However, the application routines rely on explicit */
/* zero checks when TAU.ne.ZERO, and we must clear X. */
tau->r = 2., tau->i = 0.;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0., x[i__2].i = 0.;
}
z__1.r = -alpha->r, z__1.i = -alpha->i;
alpha->r = z__1.r, alpha->i = z__1.i;
}
} else {
/* Only "reflecting" the diagonal entry to be real and non-negative. */
xnorm = dlapy2_(&alphr, &alphi);
d__1 = 1. - alphr / xnorm;
d__2 = -alphi / xnorm;
z__1.r = d__1, z__1.i = d__2;
tau->r = z__1.r, tau->i = z__1.i;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0., x[i__2].i = 0.;
}
alpha->r = xnorm, alpha->i = 0.;
}
} else {
/* general case */
d__1 = dlapy3_(&alphr, &alphi, &xnorm);
beta = d_sign(&d__1, &alphr);
safmin = dlamch_("S") / dlamch_("E");
rsafmn = 1. / safmin;
knt = 0;
if (abs(beta) < safmin) {
/* XNORM, BETA may be inaccurate; scale X and recompute them */
L10:
++knt;
i__1 = *n - 1;
zdscal_(&i__1, &rsafmn, &x[1], incx);
beta *= rsafmn;
alphi *= rsafmn;
alphr *= rsafmn;
if (abs(beta) < safmin) {
goto L10;
}
/* New BETA is at most 1, at least SAFMIN */
i__1 = *n - 1;
xnorm = dznrm2_(&i__1, &x[1], incx);
z__1.r = alphr, z__1.i = alphi;
alpha->r = z__1.r, alpha->i = z__1.i;
d__1 = dlapy3_(&alphr, &alphi, &xnorm);
beta = d_sign(&d__1, &alphr);
}
z__1.r = alpha->r + beta, z__1.i = alpha->i;
alpha->r = z__1.r, alpha->i = z__1.i;
if (beta < 0.) {
beta = -beta;
z__2.r = -alpha->r, z__2.i = -alpha->i;
z__1.r = z__2.r / beta, z__1.i = z__2.i / beta;
tau->r = z__1.r, tau->i = z__1.i;
} else {
alphr = alphi * (alphi / alpha->r);
alphr += xnorm * (xnorm / alpha->r);
d__1 = alphr / beta;
d__2 = -alphi / beta;
z__1.r = d__1, z__1.i = d__2;
tau->r = z__1.r, tau->i = z__1.i;
d__1 = -alphr;
z__1.r = d__1, z__1.i = alphi;
alpha->r = z__1.r, alpha->i = z__1.i;
}
zladiv_(&z__1, &c_b5, alpha);
alpha->r = z__1.r, alpha->i = z__1.i;
i__1 = *n - 1;
zscal_(&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.;
}
return 0;
/* End of ZLARFP */
} /* zlarfp_ */
int zlaein_(int *rightv, int *noinit, int *n,
doublecomplex *h__, int *ldh, doublecomplex *w, doublecomplex *v,
doublecomplex *b, int *ldb, double *rwork, double *eps3,
double *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;
double d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2;
/* Builtin functions */
double sqrt(double), d_imag(doublecomplex *);
/* Local variables */
int i__, j;
doublecomplex x, ei, ej;
int its, ierr;
doublecomplex temp;
double scale;
char trans[1];
double rtemp, rootn, vnorm;
extern double dznrm2_(int *, doublecomplex *, int *);
extern int zdscal_(int *, double *,
doublecomplex *, int *);
extern int izamax_(int *, doublecomplex *, int *);
extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *,
doublecomplex *);
char normin[1];
extern double dzasum_(int *, doublecomplex *, int *);
double nrmsml;
extern int zlatrs_(char *, char *, char *, char *,
int *, doublecomplex *, int *, doublecomplex *,
double *, double *, int *);
double growto;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLAEIN 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*16 array, dimension (LDH,N) */
/* The upper Hessenberg matrix H. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH >= MAX(1,N). */
/* W (input) COMPLEX*16 */
/* The eigenvalue of H whose corresponding right or left */
/* eigenvector is to be computed. */
/* V (input/output) COMPLEX*16 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*16 array, dimension (LDB,N) */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= MAX(1,N). */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* EPS3 (input) DOUBLE PRECISION */
/* A small machine-dependent value which is used to perturb */
/* close eigenvalues, and to replace zero pivots. */
/* SMLNUM (input) DOUBLE PRECISION */
/* 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((double) (*n));
growto = .1 / rootn;
/* Computing MAX */
d__1 = 1., d__2 = *eps3 * rootn;
nrmsml = MAX(d__1,d__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;
z__1.r = h__[i__3].r - w->r, z__1.i = h__[i__3].i - w->i;
b[i__2].r = z__1.r, b[i__2].i = z__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.;
/* L30: */
}
} else {
/* Scale supplied initial vector. */
vnorm = dznrm2_(n, &v[1], &c__1);
d__1 = *eps3 * rootn / MAX(vnorm,nrmsml);
zdscal_(n, &d__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 ((d__1 = b[i__2].r, ABS(d__1)) + (d__2 = d_imag(&b[i__ + i__ *
b_dim1]), ABS(d__2)) < (d__3 = ei.r, ABS(d__3)) + (d__4 =
d_imag(&ei), ABS(d__4))) {
/* Interchange rows and eliminate. */
zladiv_(&z__1, &b[i__ + i__ * b_dim1], &ei);
x.r = z__1.r, x.i = z__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;
z__2.r = x.r * temp.r - x.i * temp.i, z__2.i = x.r *
temp.i + x.i * temp.r;
z__1.r = b[i__4].r - z__2.r, z__1.i = b[i__4].i - z__2.i;
b[i__3].r = z__1.r, b[i__3].i = z__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. && b[i__2].i == 0.) {
i__3 = i__ + i__ * b_dim1;
b[i__3].r = *eps3, b[i__3].i = 0.;
}
zladiv_(&z__1, &ei, &b[i__ + i__ * b_dim1]);
x.r = z__1.r, x.i = z__1.i;
if (x.r != 0. || x.i != 0.) {
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;
z__2.r = x.r * b[i__5].r - x.i * b[i__5].i, z__2.i =
x.r * b[i__5].i + x.i * b[i__5].r;
z__1.r = b[i__4].r - z__2.r, z__1.i = b[i__4].i -
z__2.i;
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
/* L50: */
}
}
}
/* L60: */
}
i__1 = *n + *n * b_dim1;
if (b[i__1].r == 0. && b[i__1].i == 0.) {
i__2 = *n + *n * b_dim1;
b[i__2].r = *eps3, b[i__2].i = 0.;
}
*(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 ((d__1 = b[i__1].r, ABS(d__1)) + (d__2 = d_imag(&b[j + j *
b_dim1]), ABS(d__2)) < (d__3 = ej.r, ABS(d__3)) + (d__4 =
d_imag(&ej), ABS(d__4))) {
/* Interchange columns and eliminate. */
zladiv_(&z__1, &b[j + j * b_dim1], &ej);
x.r = z__1.r, x.i = z__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;
z__2.r = x.r * temp.r - x.i * temp.i, z__2.i = x.r *
temp.i + x.i * temp.r;
z__1.r = b[i__3].r - z__2.r, z__1.i = b[i__3].i - z__2.i;
b[i__2].r = z__1.r, b[i__2].i = z__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. && b[i__1].i == 0.) {
i__2 = j + j * b_dim1;
b[i__2].r = *eps3, b[i__2].i = 0.;
}
zladiv_(&z__1, &ej, &b[j + j * b_dim1]);
x.r = z__1.r, x.i = z__1.i;
if (x.r != 0. || x.i != 0.) {
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;
z__2.r = x.r * b[i__4].r - x.i * b[i__4].i, z__2.i =
x.r * b[i__4].i + x.i * b[i__4].r;
z__1.r = b[i__3].r - z__2.r, z__1.i = b[i__3].i -
z__2.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
/* L80: */
}
}
}
/* L90: */
}
i__1 = b_dim1 + 1;
if (b[i__1].r == 0. && b[i__1].i == 0.) {
i__2 = b_dim1 + 1;
b[i__2].r = *eps3, b[i__2].i = 0.;
}
*(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. */
zlatrs_("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 = dzasum_(n, &v[1], &c__1);
if (vnorm >= growto * scale) {
goto L120;
}
/* Choose new orthogonal starting vector and try again. */
rtemp = *eps3 / (rootn + 1.);
v[1].r = *eps3, v[1].i = 0.;
i__2 = *n;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = i__;
v[i__3].r = rtemp, v[i__3].i = 0.;
/* L100: */
}
i__2 = *n - its + 1;
i__3 = *n - its + 1;
d__1 = *eps3 * rootn;
z__1.r = v[i__3].r - d__1, z__1.i = v[i__3].i;
v[i__2].r = z__1.r, v[i__2].i = z__1.i;
/* L110: */
}
/* Failure to find eigenvector in N iterations. */
*info = 1;
L120:
/* Normalize eigenvector. */
i__ = izamax_(n, &v[1], &c__1);
i__1 = i__;
d__3 = 1. / ((d__1 = v[i__1].r, ABS(d__1)) + (d__2 = d_imag(&v[i__]), ABS(
d__2)));
zdscal_(n, &d__3, &v[1], &c__1);
return 0;
/* End of ZLAEIN */
} /* zlaein_ */
/* Subroutine */ int zlahqr_(logical *wantt, logical *wantz, integer *n,
integer *ilo, integer *ihi, doublecomplex *h__, integer *ldh,
doublecomplex *w, integer *iloz, integer *ihiz, doublecomplex *z__,
integer *ldz, integer *info)
{
/* System generated locals */
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double d_imag(doublecomplex *);
void z_sqrt(doublecomplex *, doublecomplex *), d_cnjg(doublecomplex *,
doublecomplex *);
double z_abs(doublecomplex *);
/* Local variables */
static doublecomplex temp;
static doublereal opst;
static integer i__, j, k, l, m;
static doublereal s;
static doublecomplex t, u, v[2], x, y;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
static doublereal rtemp;
static integer i1, i2;
static doublereal rwork[1];
static doublecomplex t1;
static doublereal t2;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
static doublecomplex v2;
static doublereal h10;
static doublecomplex h11;
static doublereal h21;
static doublecomplex h22;
static integer nh;
extern doublereal dlamch_(char *);
static integer nz;
extern /* Subroutine */ int zlarfg_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *);
extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *,
doublecomplex *);
extern doublereal zlanhs_(char *, integer *, doublecomplex *, integer *,
doublereal *);
static doublereal smlnum;
static doublecomplex h11s;
static integer itn, its;
static doublereal ulp;
static doublecomplex sum;
static doublereal tst1;
#define h___subscr(a_1,a_2) (a_2)*h_dim1 + a_1
#define h___ref(a_1,a_2) h__[h___subscr(a_1,a_2)]
#define z___subscr(a_1,a_2) (a_2)*z_dim1 + a_1
#define z___ref(a_1,a_2) z__[z___subscr(a_1,a_2)]
/* -- LAPACK auxiliary routine (instrumented to count operations) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Common block to return operation count.
Purpose
=======
ZLAHQR is an auxiliary routine called by ZHSEQR to update the
eigenvalues and Schur decomposition already computed by ZHSEQR, by
dealing with the Hessenberg submatrix in rows and columns ILO to IHI.
Arguments
=========
WANTT (input) LOGICAL
= .TRUE. : the full Schur form T is required;
= .FALSE.: only eigenvalues are required.
WANTZ (input) LOGICAL
= .TRUE. : the matrix of Schur vectors Z is required;
= .FALSE.: Schur vectors are not required.
N (input) INTEGER
The order of the matrix H. N >= 0.
ILO (input) INTEGER
IHI (input) INTEGER
It is assumed that H is already upper triangular in rows and
columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1).
ZLAHQR works primarily with the Hessenberg submatrix in rows
and columns ILO to IHI, but applies transformations to all of
H if WANTT is .TRUE..
1 <= ILO <= max(1,IHI); IHI <= N.
H (input/output) COMPLEX*16 array, dimension (LDH,N)
On entry, the upper Hessenberg matrix H.
On exit, if WANTT is .TRUE., H is upper triangular in rows
and columns ILO:IHI, with any 2-by-2 diagonal blocks in
standard form. If WANTT is .FALSE., the contents of H are
unspecified on exit.
LDH (input) INTEGER
The leading dimension of the array H. LDH >= max(1,N).
W (output) COMPLEX*16 array, dimension (N)
The computed eigenvalues ILO to IHI are stored in the
corresponding elements of W. If WANTT is .TRUE., the
eigenvalues are stored in the same order as on the diagonal
of the Schur form returned in H, with W(i) = H(i,i).
ILOZ (input) INTEGER
IHIZ (input) INTEGER
Specify the rows of Z to which transformations must be
applied if WANTZ is .TRUE..
1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
Z (input/output) COMPLEX*16 array, dimension (LDZ,N)
If WANTZ is .TRUE., on entry Z must contain the current
matrix Z of transformations accumulated by ZHSEQR, and on
exit Z has been updated; transformations are applied only to
the submatrix Z(ILOZ:IHIZ,ILO:IHI).
If WANTZ is .FALSE., Z is not referenced.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
> 0: if INFO = i, ZLAHQR failed to compute all the
eigenvalues ILO to IHI in a total of 30*(IHI-ILO+1)
iterations; elements i+1:ihi of W contain those
eigenvalues which have been successfully computed.
=====================================================================
Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1 * 1;
h__ -= h_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
/* Function Body */
*info = 0;
/* **
Initialize */
opst = 0.;
/* **
Quick return if possible */
if (*n == 0) {
return 0;
}
if (*ilo == *ihi) {
i__1 = *ilo;
i__2 = h___subscr(*ilo, *ilo);
w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i;
return 0;
}
nh = *ihi - *ilo + 1;
nz = *ihiz - *iloz + 1;
/* Set machine-dependent constants for the stopping criterion.
If norm(H) <= sqrt(OVFL), overflow should not occur. */
ulp = dlamch_("Precision");
smlnum = dlamch_("Safe minimum") / ulp;
/* I1 and I2 are the indices of the first row and last column of H
to which transformations must be applied. If eigenvalues only are
being computed, I1 and I2 are set inside the main loop. */
if (*wantt) {
i1 = 1;
i2 = *n;
}
/* ITN is the total number of QR iterations allowed. */
itn = nh * 30;
/* The main loop begins here. I is the loop index and decreases from
IHI to ILO in steps of 1. Each iteration of the loop works
with the active submatrix in rows and columns L to I.
Eigenvalues I+1 to IHI have already converged. Either L = ILO, or
H(L,L-1) is negligible so that the matrix splits. */
i__ = *ihi;
L10:
if (i__ < *ilo) {
goto L130;
}
/* Perform QR iterations on rows and columns ILO to I until a
submatrix of order 1 splits off at the bottom because a
subdiagonal element has become negligible. */
l = *ilo;
i__1 = itn;
for (its = 0; its <= i__1; ++its) {
/* Look for a single small subdiagonal element. */
i__2 = l + 1;
for (k = i__; k >= i__2; --k) {
i__3 = h___subscr(k - 1, k - 1);
i__4 = h___subscr(k, k);
tst1 = (d__1 = h__[i__3].r, abs(d__1)) + (d__2 = d_imag(&h___ref(
k - 1, k - 1)), abs(d__2)) + ((d__3 = h__[i__4].r, abs(
d__3)) + (d__4 = d_imag(&h___ref(k, k)), abs(d__4)));
if (tst1 == 0.) {
i__3 = i__ - l + 1;
tst1 = zlanhs_("1", &i__3, &h___ref(l, l), ldh, rwork);
/* **
Increment op count */
latime_1.ops += (i__ - l + 1) * 5 * (i__ - l) / 2;
/* ** */
}
i__3 = h___subscr(k, k - 1);
/* Computing MAX */
d__2 = ulp * tst1;
if ((d__1 = h__[i__3].r, abs(d__1)) <= max(d__2,smlnum)) {
goto L30;
}
/* L20: */
}
L30:
l = k;
/* **
Increment op count */
opst += (i__ - l + 1) * 5;
/* ** */
if (l > *ilo) {
/* H(L,L-1) is negligible */
i__2 = h___subscr(l, l - 1);
h__[i__2].r = 0., h__[i__2].i = 0.;
}
/* Exit from loop if a submatrix of order 1 has split off. */
if (l >= i__) {
goto L120;
}
/* Now the active submatrix is in rows and columns L to I. If
eigenvalues only are being computed, only the active submatrix
need be transformed. */
if (! (*wantt)) {
i1 = l;
i2 = i__;
}
if (its == 10 || its == 20) {
/* Exceptional shift. */
i__2 = h___subscr(i__, i__ - 1);
s = (d__1 = h__[i__2].r, abs(d__1)) * .75;
i__2 = h___subscr(i__, i__);
z__1.r = s + h__[i__2].r, z__1.i = h__[i__2].i;
t.r = z__1.r, t.i = z__1.i;
/* **
Increment op count */
opst += 1;
/* ** */
} else {
/* Wilkinson's shift. */
i__2 = h___subscr(i__, i__);
t.r = h__[i__2].r, t.i = h__[i__2].i;
i__2 = h___subscr(i__ - 1, i__);
i__3 = h___subscr(i__, i__ - 1);
d__1 = h__[i__3].r;
z__1.r = d__1 * h__[i__2].r, z__1.i = d__1 * h__[i__2].i;
u.r = z__1.r, u.i = z__1.i;
/* **
Increment op count */
opst += 2;
/* ** */
if (u.r != 0. || u.i != 0.) {
i__2 = h___subscr(i__ - 1, i__ - 1);
z__2.r = h__[i__2].r - t.r, z__2.i = h__[i__2].i - t.i;
z__1.r = z__2.r * .5, z__1.i = z__2.i * .5;
x.r = z__1.r, x.i = z__1.i;
z__3.r = x.r * x.r - x.i * x.i, z__3.i = x.r * x.i + x.i *
x.r;
z__2.r = z__3.r + u.r, z__2.i = z__3.i + u.i;
z_sqrt(&z__1, &z__2);
y.r = z__1.r, y.i = z__1.i;
if (x.r * y.r + d_imag(&x) * d_imag(&y) < 0.) {
z__1.r = -y.r, z__1.i = -y.i;
y.r = z__1.r, y.i = z__1.i;
}
z__3.r = x.r + y.r, z__3.i = x.i + y.i;
zladiv_(&z__2, &u, &z__3);
z__1.r = t.r - z__2.r, z__1.i = t.i - z__2.i;
t.r = z__1.r, t.i = z__1.i;
/* **
Increment op count */
opst += 20;
/* ** */
}
}
/* Look for two consecutive small subdiagonal elements. */
i__2 = l + 1;
for (m = i__ - 1; m >= i__2; --m) {
/* Determine the effect of starting the single-shift QR
iteration at row M, and see if this would make H(M,M-1)
negligible. */
i__3 = h___subscr(m, m);
h11.r = h__[i__3].r, h11.i = h__[i__3].i;
i__3 = h___subscr(m + 1, m + 1);
h22.r = h__[i__3].r, h22.i = h__[i__3].i;
z__1.r = h11.r - t.r, z__1.i = h11.i - t.i;
h11s.r = z__1.r, h11s.i = z__1.i;
i__3 = h___subscr(m + 1, m);
h21 = h__[i__3].r;
s = (d__1 = h11s.r, abs(d__1)) + (d__2 = d_imag(&h11s), abs(d__2))
+ abs(h21);
z__1.r = h11s.r / s, z__1.i = h11s.i / s;
h11s.r = z__1.r, h11s.i = z__1.i;
h21 /= s;
v[0].r = h11s.r, v[0].i = h11s.i;
v[1].r = h21, v[1].i = 0.;
i__3 = h___subscr(m, m - 1);
h10 = h__[i__3].r;
tst1 = ((d__1 = h11s.r, abs(d__1)) + (d__2 = d_imag(&h11s), abs(
d__2))) * ((d__3 = h11.r, abs(d__3)) + (d__4 = d_imag(&
h11), abs(d__4)) + ((d__5 = h22.r, abs(d__5)) + (d__6 =
d_imag(&h22), abs(d__6))));
if ((d__1 = h10 * h21, abs(d__1)) <= ulp * tst1) {
goto L50;
}
/* L40: */
}
i__2 = h___subscr(l, l);
h11.r = h__[i__2].r, h11.i = h__[i__2].i;
i__2 = h___subscr(l + 1, l + 1);
h22.r = h__[i__2].r, h22.i = h__[i__2].i;
z__1.r = h11.r - t.r, z__1.i = h11.i - t.i;
h11s.r = z__1.r, h11s.i = z__1.i;
i__2 = h___subscr(l + 1, l);
h21 = h__[i__2].r;
s = (d__1 = h11s.r, abs(d__1)) + (d__2 = d_imag(&h11s), abs(d__2)) +
abs(h21);
z__1.r = h11s.r / s, z__1.i = h11s.i / s;
h11s.r = z__1.r, h11s.i = z__1.i;
h21 /= s;
v[0].r = h11s.r, v[0].i = h11s.i;
v[1].r = h21, v[1].i = 0.;
L50:
/* **
Increment op count */
opst += (i__ - m) * 14;
/* **
Single-shift QR step */
i__2 = i__ - 1;
for (k = m; k <= i__2; ++k) {
/* The first iteration of this loop determines a reflection G
from the vector V and applies it from left and right to H,
thus creating a nonzero bulge below the subdiagonal.
Each subsequent iteration determines a reflection G to
restore the Hessenberg form in the (K-1)th column, and thus
chases the bulge one step toward the bottom of the active
submatrix.
V(2) is always real before the call to ZLARFG, and hence
after the call T2 ( = T1*V(2) ) is also real. */
if (k > m) {
zcopy_(&c__2, &h___ref(k, k - 1), &c__1, v, &c__1);
}
zlarfg_(&c__2, v, &v[1], &c__1, &t1);
/* **
Increment op count */
opst += 38;
/* ** */
if (k > m) {
i__3 = h___subscr(k, k - 1);
h__[i__3].r = v[0].r, h__[i__3].i = v[0].i;
i__3 = h___subscr(k + 1, k - 1);
h__[i__3].r = 0., h__[i__3].i = 0.;
}
v2.r = v[1].r, v2.i = v[1].i;
z__1.r = t1.r * v2.r - t1.i * v2.i, z__1.i = t1.r * v2.i + t1.i *
v2.r;
t2 = z__1.r;
/* Apply G from the left to transform the rows of the matrix
in columns K to I2. */
i__3 = i2;
for (j = k; j <= i__3; ++j) {
d_cnjg(&z__3, &t1);
i__4 = h___subscr(k, j);
z__2.r = z__3.r * h__[i__4].r - z__3.i * h__[i__4].i, z__2.i =
z__3.r * h__[i__4].i + z__3.i * h__[i__4].r;
i__5 = h___subscr(k + 1, j);
z__4.r = t2 * h__[i__5].r, z__4.i = t2 * h__[i__5].i;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
sum.r = z__1.r, sum.i = z__1.i;
i__4 = h___subscr(k, j);
i__5 = h___subscr(k, j);
z__1.r = h__[i__5].r - sum.r, z__1.i = h__[i__5].i - sum.i;
h__[i__4].r = z__1.r, h__[i__4].i = z__1.i;
i__4 = h___subscr(k + 1, j);
i__5 = h___subscr(k + 1, j);
z__2.r = sum.r * v2.r - sum.i * v2.i, z__2.i = sum.r * v2.i +
sum.i * v2.r;
z__1.r = h__[i__5].r - z__2.r, z__1.i = h__[i__5].i - z__2.i;
h__[i__4].r = z__1.r, h__[i__4].i = z__1.i;
/* L60: */
}
/* Apply G from the right to transform the columns of the
matrix in rows I1 to min(K+2,I).
Computing MIN */
i__4 = k + 2;
i__3 = min(i__4,i__);
for (j = i1; j <= i__3; ++j) {
i__4 = h___subscr(j, k);
z__2.r = t1.r * h__[i__4].r - t1.i * h__[i__4].i, z__2.i =
t1.r * h__[i__4].i + t1.i * h__[i__4].r;
i__5 = h___subscr(j, k + 1);
z__3.r = t2 * h__[i__5].r, z__3.i = t2 * h__[i__5].i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
sum.r = z__1.r, sum.i = z__1.i;
i__4 = h___subscr(j, k);
i__5 = h___subscr(j, k);
z__1.r = h__[i__5].r - sum.r, z__1.i = h__[i__5].i - sum.i;
h__[i__4].r = z__1.r, h__[i__4].i = z__1.i;
i__4 = h___subscr(j, k + 1);
i__5 = h___subscr(j, k + 1);
d_cnjg(&z__3, &v2);
z__2.r = sum.r * z__3.r - sum.i * z__3.i, z__2.i = sum.r *
z__3.i + sum.i * z__3.r;
z__1.r = h__[i__5].r - z__2.r, z__1.i = h__[i__5].i - z__2.i;
h__[i__4].r = z__1.r, h__[i__4].i = z__1.i;
/* L70: */
}
/* **
Increment op count
Computing MIN */
i__3 = 2, i__4 = i__ - k;
latime_1.ops += (i2 - i1 + 2 + min(i__3,i__4)) * 20;
/* ** */
if (*wantz) {
/* Accumulate transformations in the matrix Z */
i__3 = *ihiz;
for (j = *iloz; j <= i__3; ++j) {
i__4 = z___subscr(j, k);
z__2.r = t1.r * z__[i__4].r - t1.i * z__[i__4].i, z__2.i =
t1.r * z__[i__4].i + t1.i * z__[i__4].r;
i__5 = z___subscr(j, k + 1);
z__3.r = t2 * z__[i__5].r, z__3.i = t2 * z__[i__5].i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
sum.r = z__1.r, sum.i = z__1.i;
i__4 = z___subscr(j, k);
i__5 = z___subscr(j, k);
z__1.r = z__[i__5].r - sum.r, z__1.i = z__[i__5].i -
sum.i;
z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
i__4 = z___subscr(j, k + 1);
i__5 = z___subscr(j, k + 1);
d_cnjg(&z__3, &v2);
z__2.r = sum.r * z__3.r - sum.i * z__3.i, z__2.i = sum.r *
z__3.i + sum.i * z__3.r;
z__1.r = z__[i__5].r - z__2.r, z__1.i = z__[i__5].i -
z__2.i;
z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
/* L80: */
}
/* **
Increment op count */
latime_1.ops += nz * 20;
/* ** */
}
if (k == m && m > l) {
/* If the QR step was started at row M > L because two
consecutive small subdiagonals were found, then extra
scaling must be performed to ensure that H(M,M-1) remains
real. */
z__1.r = 1. - t1.r, z__1.i = 0. - t1.i;
temp.r = z__1.r, temp.i = z__1.i;
d__1 = z_abs(&temp);
z__1.r = temp.r / d__1, z__1.i = temp.i / d__1;
temp.r = z__1.r, temp.i = z__1.i;
i__3 = h___subscr(m + 1, m);
i__4 = h___subscr(m + 1, m);
d_cnjg(&z__2, &temp);
z__1.r = h__[i__4].r * z__2.r - h__[i__4].i * z__2.i, z__1.i =
h__[i__4].r * z__2.i + h__[i__4].i * z__2.r;
h__[i__3].r = z__1.r, h__[i__3].i = z__1.i;
if (m + 2 <= i__) {
i__3 = h___subscr(m + 2, m + 1);
i__4 = h___subscr(m + 2, m + 1);
z__1.r = h__[i__4].r * temp.r - h__[i__4].i * temp.i,
z__1.i = h__[i__4].r * temp.i + h__[i__4].i *
temp.r;
h__[i__3].r = z__1.r, h__[i__3].i = z__1.i;
}
i__3 = i__;
for (j = m; j <= i__3; ++j) {
if (j != m + 1) {
if (i2 > j) {
i__4 = i2 - j;
zscal_(&i__4, &temp, &h___ref(j, j + 1), ldh);
}
i__4 = j - i1;
d_cnjg(&z__1, &temp);
zscal_(&i__4, &z__1, &h___ref(i1, j), &c__1);
/* **
Increment op count */
opst += (i2 - i1 + 3) * 6;
/* ** */
if (*wantz) {
d_cnjg(&z__1, &temp);
zscal_(&nz, &z__1, &z___ref(*iloz, j), &c__1);
/* **
Increment op count */
opst += nz * 6;
/* ** */
}
}
/* L90: */
}
}
/* L100: */
}
/* Ensure that H(I,I-1) is real. */
i__2 = h___subscr(i__, i__ - 1);
temp.r = h__[i__2].r, temp.i = h__[i__2].i;
if (d_imag(&temp) != 0.) {
rtemp = z_abs(&temp);
i__2 = h___subscr(i__, i__ - 1);
h__[i__2].r = rtemp, h__[i__2].i = 0.;
z__1.r = temp.r / rtemp, z__1.i = temp.i / rtemp;
temp.r = z__1.r, temp.i = z__1.i;
if (i2 > i__) {
i__2 = i2 - i__;
d_cnjg(&z__1, &temp);
zscal_(&i__2, &z__1, &h___ref(i__, i__ + 1), ldh);
}
i__2 = i__ - i1;
zscal_(&i__2, &temp, &h___ref(i1, i__), &c__1);
/* **
Increment op count */
opst += (i2 - i1 + 1) * 6;
/* ** */
if (*wantz) {
zscal_(&nz, &temp, &z___ref(*iloz, i__), &c__1);
/* **
Increment op count */
opst += nz * 6;
/* ** */
}
}
/* L110: */
}
/* Failure to converge in remaining number of iterations */
*info = i__;
return 0;
L120:
/* H(I,I-1) is negligible: one eigenvalue has converged. */
i__1 = i__;
i__2 = h___subscr(i__, i__);
w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i;
/* Decrement number of remaining iterations, and return to start of
the main loop with new value of I. */
itn -= its;
i__ = l - 1;
goto L10;
L130:
/* **
Compute final op count */
latime_1.ops += opst;
/* ** */
return 0;
/* End of ZLAHQR */
} /* zlahqr_ */
/* Subroutine */ int ztgevc_(char *side, char *howmny, logical *select,
integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer
*ldb, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *
ldvr, integer *mm, integer *m, doublecomplex *work, doublereal *rwork,
integer *info, ftnlen side_len, ftnlen howmny_len)
{
/* 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;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static doublecomplex d__;
static integer i__, j;
static doublecomplex ca, cb;
static integer je, im, jr;
static doublereal big;
static logical lsa, lsb;
static doublereal ulp;
static doublecomplex sum;
static integer ibeg, ieig, iend;
static doublereal dmin__;
static integer isrc;
static doublereal temp;
static doublecomplex suma, sumb;
static doublereal xmax, scale;
static logical ilall;
static integer iside;
static doublereal sbeta;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static doublereal small;
static logical compl;
static doublereal anorm, bnorm;
static logical compr;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, ftnlen),
dlabad_(doublereal *, doublereal *);
static logical ilbbad;
static doublereal acoefa, bcoefa, acoeff;
static doublecomplex bcoeff;
static logical ilback;
static doublereal ascale, bscale;
extern doublereal dlamch_(char *, ftnlen);
static doublecomplex salpha;
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
static doublereal bignum;
static logical ilcomp;
extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *,
doublecomplex *);
static integer ihwmny;
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZTGEVC 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*16 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*16 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*16 array, dimension (LDVL,MM) */
/* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */
/* contain an N-by-N matrix Q (usually the unitary matrix Q */
/* of left Schur vectors returned by ZHGEQZ). */
/* 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*16 array, dimension (LDVR,MM) */
/* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */
/* contain an N-by-N matrix Q (usually the unitary matrix Z */
/* of right Schur vectors returned by ZHGEQZ). */
/* 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*16 array, dimension (2*N) */
/* RWORK (workspace) DOUBLE PRECISION 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;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_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", (ftnlen)1, (ftnlen)1)) {
ihwmny = 1;
ilall = TRUE_;
ilback = FALSE_;
} else if (lsame_(howmny, "S", (ftnlen)1, (ftnlen)1)) {
ihwmny = 2;
ilall = FALSE_;
ilback = FALSE_;
} else if (lsame_(howmny, "B", (ftnlen)1, (ftnlen)1) || lsame_(howmny,
"T", (ftnlen)1, (ftnlen)1)) {
ihwmny = 3;
ilall = TRUE_;
ilback = TRUE_;
} else {
ihwmny = -1;
}
if (lsame_(side, "R", (ftnlen)1, (ftnlen)1)) {
iside = 1;
compl = FALSE_;
compr = TRUE_;
} else if (lsame_(side, "L", (ftnlen)1, (ftnlen)1)) {
iside = 2;
compl = TRUE_;
compr = FALSE_;
} else if (lsame_(side, "B", (ftnlen)1, (ftnlen)1)) {
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_("ZTGEVC", &i__1, (ftnlen)6);
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 (d_imag(&b[j + j * b_dim1]) != 0.) {
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_("ZTGEVC", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
*m = im;
if (*n == 0) {
return 0;
}
/* Machine Constants */
safmin = dlamch_("Safe minimum", (ftnlen)12);
big = 1. / safmin;
dlabad_(&safmin, &big);
ulp = dlamch_("Epsilon", (ftnlen)7) * dlamch_("Base", (ftnlen)4);
small = safmin * *n / ulp;
big = 1. / small;
bignum = 1. / (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_dim1 + 1;
anorm = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[a_dim1 + 1]),
abs(d__2));
i__1 = b_dim1 + 1;
bnorm = (d__1 = b[i__1].r, abs(d__1)) + (d__2 = d_imag(&b[b_dim1 + 1]),
abs(d__2));
rwork[1] = 0.;
rwork[*n + 1] = 0.;
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
rwork[j] = 0.;
rwork[*n + j] = 0.;
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
rwork[j] += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__
+ j * a_dim1]), abs(d__2));
i__3 = i__ + j * b_dim1;
rwork[*n + j] += (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&
b[i__ + j * b_dim1]), abs(d__2));
/* L30: */
}
/* Computing MAX */
i__2 = j + j * a_dim1;
d__3 = anorm, d__4 = rwork[j] + ((d__1 = a[i__2].r, abs(d__1)) + (
d__2 = d_imag(&a[j + j * a_dim1]), abs(d__2)));
anorm = max(d__3,d__4);
/* Computing MAX */
i__2 = j + j * b_dim1;
d__3 = bnorm, d__4 = rwork[*n + j] + ((d__1 = b[i__2].r, abs(d__1)) +
(d__2 = d_imag(&b[j + j * b_dim1]), abs(d__2)));
bnorm = max(d__3,d__4);
/* L40: */
}
ascale = 1. / max(anorm,safmin);
bscale = 1. / 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 * a_dim1;
i__3 = je + je * b_dim1;
if ((d__2 = a[i__2].r, abs(d__2)) + (d__3 = d_imag(&a[je + je
* a_dim1]), abs(d__3)) <= safmin && (d__1 = b[i__3].r,
abs(d__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., vl[i__3].i = 0.;
/* L50: */
}
i__2 = ieig + ieig * vl_dim1;
vl[i__2].r = 1., vl[i__2].i = 0.;
goto L140;
}
/* Non-singular eigenvalue: */
/* Compute coefficients a and b in */
/* H */
/* y ( a A - b B ) = 0 */
/* Computing MAX */
i__2 = je + je * a_dim1;
i__3 = je + je * b_dim1;
d__4 = ((d__2 = a[i__2].r, abs(d__2)) + (d__3 = d_imag(&a[je
+ je * a_dim1]), abs(d__3))) * ascale, d__5 = (d__1 =
b[i__3].r, abs(d__1)) * bscale, d__4 = max(d__4,d__5);
temp = 1. / max(d__4,safmin);
i__2 = je + je * a_dim1;
z__2.r = temp * a[i__2].r, z__2.i = temp * a[i__2].i;
z__1.r = ascale * z__2.r, z__1.i = ascale * z__2.i;
salpha.r = z__1.r, salpha.i = z__1.i;
i__2 = je + je * b_dim1;
sbeta = temp * b[i__2].r * bscale;
acoeff = sbeta * ascale;
z__1.r = bscale * salpha.r, z__1.i = bscale * salpha.i;
bcoeff.r = z__1.r, bcoeff.i = z__1.i;
/* Scale to avoid underflow */
lsa = abs(sbeta) >= safmin && abs(acoeff) < small;
lsb = (d__1 = salpha.r, abs(d__1)) + (d__2 = d_imag(&salpha),
abs(d__2)) >= safmin && (d__3 = bcoeff.r, abs(d__3))
+ (d__4 = d_imag(&bcoeff), abs(d__4)) < small;
scale = 1.;
if (lsa) {
scale = small / abs(sbeta) * min(anorm,big);
}
if (lsb) {
/* Computing MAX */
d__3 = scale, d__4 = small / ((d__1 = salpha.r, abs(d__1))
+ (d__2 = d_imag(&salpha), abs(d__2))) * min(
bnorm,big);
scale = max(d__3,d__4);
}
if (lsa || lsb) {
/* Computing MIN */
/* Computing MAX */
d__5 = 1., d__6 = abs(acoeff), d__5 = max(d__5,d__6),
d__6 = (d__1 = bcoeff.r, abs(d__1)) + (d__2 =
d_imag(&bcoeff), abs(d__2));
d__3 = scale, d__4 = 1. / (safmin * max(d__5,d__6));
scale = min(d__3,d__4);
if (lsa) {
acoeff = ascale * (scale * sbeta);
} else {
acoeff = scale * acoeff;
}
if (lsb) {
z__2.r = scale * salpha.r, z__2.i = scale * salpha.i;
z__1.r = bscale * z__2.r, z__1.i = bscale * z__2.i;
bcoeff.r = z__1.r, bcoeff.i = z__1.i;
} else {
z__1.r = scale * bcoeff.r, z__1.i = scale * bcoeff.i;
bcoeff.r = z__1.r, bcoeff.i = z__1.i;
}
}
acoefa = abs(acoeff);
bcoefa = (d__1 = bcoeff.r, abs(d__1)) + (d__2 = d_imag(&
bcoeff), abs(d__2));
xmax = 1.;
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
i__3 = jr;
work[i__3].r = 0., work[i__3].i = 0.;
/* L60: */
}
i__2 = je;
work[i__2].r = 1., work[i__2].i = 0.;
/* Computing MAX */
d__1 = ulp * acoefa * anorm, d__2 = ulp * bcoefa * bnorm,
d__1 = max(d__1,d__2);
dmin__ = max(d__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. / 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;
z__1.r = temp * work[i__5].r, z__1.i = temp *
work[i__5].i;
work[i__4].r = z__1.r, work[i__4].i = z__1.i;
/* L70: */
}
xmax = 1.;
}
suma.r = 0., suma.i = 0.;
sumb.r = 0., sumb.i = 0.;
i__3 = j - 1;
for (jr = je; jr <= i__3; ++jr) {
d_cnjg(&z__3, &a[jr + j * a_dim1]);
i__4 = jr;
z__2.r = z__3.r * work[i__4].r - z__3.i * work[i__4]
.i, z__2.i = z__3.r * work[i__4].i + z__3.i *
work[i__4].r;
z__1.r = suma.r + z__2.r, z__1.i = suma.i + z__2.i;
suma.r = z__1.r, suma.i = z__1.i;
d_cnjg(&z__3, &b[jr + j * b_dim1]);
i__4 = jr;
z__2.r = z__3.r * work[i__4].r - z__3.i * work[i__4]
.i, z__2.i = z__3.r * work[i__4].i + z__3.i *
work[i__4].r;
z__1.r = sumb.r + z__2.r, z__1.i = sumb.i + z__2.i;
sumb.r = z__1.r, sumb.i = z__1.i;
/* L80: */
}
z__2.r = acoeff * suma.r, z__2.i = acoeff * suma.i;
d_cnjg(&z__4, &bcoeff);
z__3.r = z__4.r * sumb.r - z__4.i * sumb.i, z__3.i =
z__4.r * sumb.i + z__4.i * sumb.r;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
sum.r = z__1.r, sum.i = z__1.i;
/* Form x(j) = - SUM / conjg( a*A(j,j) - b*B(j,j) ) */
/* with scaling and perturbation of the denominator */
i__3 = j + j * a_dim1;
z__3.r = acoeff * a[i__3].r, z__3.i = acoeff * a[i__3].i;
i__4 = j + j * b_dim1;
z__4.r = bcoeff.r * b[i__4].r - bcoeff.i * b[i__4].i,
z__4.i = bcoeff.r * b[i__4].i + bcoeff.i * b[i__4]
.r;
z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
d_cnjg(&z__1, &z__2);
d__.r = z__1.r, d__.i = z__1.i;
if ((d__1 = d__.r, abs(d__1)) + (d__2 = d_imag(&d__), abs(
d__2)) <= dmin__) {
z__1.r = dmin__, z__1.i = 0.;
d__.r = z__1.r, d__.i = z__1.i;
}
if ((d__1 = d__.r, abs(d__1)) + (d__2 = d_imag(&d__), abs(
d__2)) < 1.) {
if ((d__1 = sum.r, abs(d__1)) + (d__2 = d_imag(&sum),
abs(d__2)) >= bignum * ((d__3 = d__.r, abs(
d__3)) + (d__4 = d_imag(&d__), abs(d__4)))) {
temp = 1. / ((d__1 = sum.r, abs(d__1)) + (d__2 =
d_imag(&sum), abs(d__2)));
i__3 = j - 1;
for (jr = je; jr <= i__3; ++jr) {
i__4 = jr;
i__5 = jr;
z__1.r = temp * work[i__5].r, z__1.i = temp *
work[i__5].i;
work[i__4].r = z__1.r, work[i__4].i = z__1.i;
/* L90: */
}
xmax = temp * xmax;
z__1.r = temp * sum.r, z__1.i = temp * sum.i;
sum.r = z__1.r, sum.i = z__1.i;
}
}
i__3 = j;
z__2.r = -sum.r, z__2.i = -sum.i;
zladiv_(&z__1, &z__2, &d__);
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* Computing MAX */
i__3 = j;
d__3 = xmax, d__4 = (d__1 = work[i__3].r, abs(d__1)) + (
d__2 = d_imag(&work[j]), abs(d__2));
xmax = max(d__3,d__4);
/* L100: */
}
/* Back transform eigenvector if HOWMNY='B'. */
if (ilback) {
i__2 = *n + 1 - je;
zgemv_("N", n, &i__2, &c_b2, &vl[je * vl_dim1 + 1], ldvl,
&work[je], &c__1, &c_b1, &work[*n + 1], &c__1, (
ftnlen)1);
isrc = 2;
ibeg = 1;
} else {
isrc = 1;
ibeg = je;
}
/* Copy and scale eigenvector into column of VL */
xmax = 0.;
i__2 = *n;
for (jr = ibeg; jr <= i__2; ++jr) {
/* Computing MAX */
i__3 = (isrc - 1) * *n + jr;
d__3 = xmax, d__4 = (d__1 = work[i__3].r, abs(d__1)) + (
d__2 = d_imag(&work[(isrc - 1) * *n + jr]), abs(
d__2));
xmax = max(d__3,d__4);
/* L110: */
}
if (xmax > safmin) {
temp = 1. / xmax;
i__2 = *n;
for (jr = ibeg; jr <= i__2; ++jr) {
i__3 = jr + ieig * vl_dim1;
i__4 = (isrc - 1) * *n + jr;
z__1.r = temp * work[i__4].r, z__1.i = temp * work[
i__4].i;
vl[i__3].r = z__1.r, vl[i__3].i = z__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., vl[i__3].i = 0.;
/* 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 * a_dim1;
i__2 = je + je * b_dim1;
if ((d__2 = a[i__1].r, abs(d__2)) + (d__3 = d_imag(&a[je + je
* a_dim1]), abs(d__3)) <= safmin && (d__1 = b[i__2].r,
abs(d__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., vr[i__2].i = 0.;
/* L150: */
}
i__1 = ieig + ieig * vr_dim1;
vr[i__1].r = 1., vr[i__1].i = 0.;
goto L250;
}
/* Non-singular eigenvalue: */
/* Compute coefficients a and b in */
/* ( a A - b B ) x = 0 */
/* Computing MAX */
i__1 = je + je * a_dim1;
i__2 = je + je * b_dim1;
d__4 = ((d__2 = a[i__1].r, abs(d__2)) + (d__3 = d_imag(&a[je
+ je * a_dim1]), abs(d__3))) * ascale, d__5 = (d__1 =
b[i__2].r, abs(d__1)) * bscale, d__4 = max(d__4,d__5);
temp = 1. / max(d__4,safmin);
i__1 = je + je * a_dim1;
z__2.r = temp * a[i__1].r, z__2.i = temp * a[i__1].i;
z__1.r = ascale * z__2.r, z__1.i = ascale * z__2.i;
salpha.r = z__1.r, salpha.i = z__1.i;
i__1 = je + je * b_dim1;
sbeta = temp * b[i__1].r * bscale;
acoeff = sbeta * ascale;
z__1.r = bscale * salpha.r, z__1.i = bscale * salpha.i;
bcoeff.r = z__1.r, bcoeff.i = z__1.i;
/* Scale to avoid underflow */
lsa = abs(sbeta) >= safmin && abs(acoeff) < small;
lsb = (d__1 = salpha.r, abs(d__1)) + (d__2 = d_imag(&salpha),
abs(d__2)) >= safmin && (d__3 = bcoeff.r, abs(d__3))
+ (d__4 = d_imag(&bcoeff), abs(d__4)) < small;
scale = 1.;
if (lsa) {
scale = small / abs(sbeta) * min(anorm,big);
}
if (lsb) {
/* Computing MAX */
d__3 = scale, d__4 = small / ((d__1 = salpha.r, abs(d__1))
+ (d__2 = d_imag(&salpha), abs(d__2))) * min(
bnorm,big);
scale = max(d__3,d__4);
}
if (lsa || lsb) {
/* Computing MIN */
/* Computing MAX */
d__5 = 1., d__6 = abs(acoeff), d__5 = max(d__5,d__6),
d__6 = (d__1 = bcoeff.r, abs(d__1)) + (d__2 =
d_imag(&bcoeff), abs(d__2));
d__3 = scale, d__4 = 1. / (safmin * max(d__5,d__6));
scale = min(d__3,d__4);
if (lsa) {
acoeff = ascale * (scale * sbeta);
} else {
acoeff = scale * acoeff;
}
if (lsb) {
z__2.r = scale * salpha.r, z__2.i = scale * salpha.i;
z__1.r = bscale * z__2.r, z__1.i = bscale * z__2.i;
bcoeff.r = z__1.r, bcoeff.i = z__1.i;
} else {
z__1.r = scale * bcoeff.r, z__1.i = scale * bcoeff.i;
bcoeff.r = z__1.r, bcoeff.i = z__1.i;
}
}
acoefa = abs(acoeff);
bcoefa = (d__1 = bcoeff.r, abs(d__1)) + (d__2 = d_imag(&
bcoeff), abs(d__2));
xmax = 1.;
i__1 = *n;
for (jr = 1; jr <= i__1; ++jr) {
i__2 = jr;
work[i__2].r = 0., work[i__2].i = 0.;
/* L160: */
}
i__1 = je;
work[i__1].r = 1., work[i__1].i = 0.;
/* Computing MAX */
d__1 = ulp * acoefa * anorm, d__2 = ulp * bcoefa * bnorm,
d__1 = max(d__1,d__2);
dmin__ = max(d__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 * a_dim1;
z__2.r = acoeff * a[i__3].r, z__2.i = acoeff * a[i__3].i;
i__4 = jr + je * b_dim1;
z__3.r = bcoeff.r * b[i__4].r - bcoeff.i * b[i__4].i,
z__3.i = bcoeff.r * b[i__4].i + bcoeff.i * b[i__4]
.r;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
/* L170: */
}
i__1 = je;
work[i__1].r = 1., work[i__1].i = 0.;
for (j = je - 1; j >= 1; --j) {
/* Form x(j) := - w(j) / d */
/* with scaling and perturbation of the denominator */
i__1 = j + j * a_dim1;
z__2.r = acoeff * a[i__1].r, z__2.i = acoeff * a[i__1].i;
i__2 = j + j * b_dim1;
z__3.r = bcoeff.r * b[i__2].r - bcoeff.i * b[i__2].i,
z__3.i = bcoeff.r * b[i__2].i + bcoeff.i * b[i__2]
.r;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
d__.r = z__1.r, d__.i = z__1.i;
if ((d__1 = d__.r, abs(d__1)) + (d__2 = d_imag(&d__), abs(
d__2)) <= dmin__) {
z__1.r = dmin__, z__1.i = 0.;
d__.r = z__1.r, d__.i = z__1.i;
}
if ((d__1 = d__.r, abs(d__1)) + (d__2 = d_imag(&d__), abs(
d__2)) < 1.) {
i__1 = j;
if ((d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag(
&work[j]), abs(d__2)) >= bignum * ((d__3 =
d__.r, abs(d__3)) + (d__4 = d_imag(&d__), abs(
d__4)))) {
i__1 = j;
temp = 1. / ((d__1 = work[i__1].r, abs(d__1)) + (
d__2 = d_imag(&work[j]), abs(d__2)));
i__1 = je;
for (jr = 1; jr <= i__1; ++jr) {
i__2 = jr;
i__3 = jr;
z__1.r = temp * work[i__3].r, z__1.i = temp *
work[i__3].i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
/* L180: */
}
}
}
i__1 = j;
i__2 = j;
z__2.r = -work[i__2].r, z__2.i = -work[i__2].i;
zladiv_(&z__1, &z__2, &d__);
work[i__1].r = z__1.r, work[i__1].i = z__1.i;
if (j > 1) {
/* w = w + x(j)*(a A(*,j) - b B(*,j) ) with scaling */
i__1 = j;
if ((d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag(
&work[j]), abs(d__2)) > 1.) {
i__1 = j;
temp = 1. / ((d__1 = work[i__1].r, abs(d__1)) + (
d__2 = d_imag(&work[j]), abs(d__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;
z__1.r = temp * work[i__3].r, z__1.i =
temp * work[i__3].i;
work[i__2].r = z__1.r, work[i__2].i =
z__1.i;
/* L190: */
}
}
}
i__1 = j;
z__1.r = acoeff * work[i__1].r, z__1.i = acoeff *
work[i__1].i;
ca.r = z__1.r, ca.i = z__1.i;
i__1 = j;
z__1.r = bcoeff.r * work[i__1].r - bcoeff.i * work[
i__1].i, z__1.i = bcoeff.r * work[i__1].i +
bcoeff.i * work[i__1].r;
cb.r = z__1.r, cb.i = z__1.i;
i__1 = j - 1;
for (jr = 1; jr <= i__1; ++jr) {
i__2 = jr;
i__3 = jr;
i__4 = jr + j * a_dim1;
z__3.r = ca.r * a[i__4].r - ca.i * a[i__4].i,
z__3.i = ca.r * a[i__4].i + ca.i * a[i__4]
.r;
z__2.r = work[i__3].r + z__3.r, z__2.i = work[
i__3].i + z__3.i;
i__5 = jr + j * b_dim1;
z__4.r = cb.r * b[i__5].r - cb.i * b[i__5].i,
z__4.i = cb.r * b[i__5].i + cb.i * b[i__5]
.r;
z__1.r = z__2.r - z__4.r, z__1.i = z__2.i -
z__4.i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
/* L200: */
}
}
/* L210: */
}
/* Back transform eigenvector if HOWMNY='B'. */
if (ilback) {
zgemv_("N", n, &je, &c_b2, &vr[vr_offset], ldvr, &work[1],
&c__1, &c_b1, &work[*n + 1], &c__1, (ftnlen)1);
isrc = 2;
iend = *n;
} else {
isrc = 1;
iend = je;
}
/* Copy and scale eigenvector into column of VR */
xmax = 0.;
i__1 = iend;
for (jr = 1; jr <= i__1; ++jr) {
/* Computing MAX */
i__2 = (isrc - 1) * *n + jr;
d__3 = xmax, d__4 = (d__1 = work[i__2].r, abs(d__1)) + (
d__2 = d_imag(&work[(isrc - 1) * *n + jr]), abs(
d__2));
xmax = max(d__3,d__4);
/* L220: */
}
if (xmax > safmin) {
temp = 1. / xmax;
i__1 = iend;
for (jr = 1; jr <= i__1; ++jr) {
i__2 = jr + ieig * vr_dim1;
i__3 = (isrc - 1) * *n + jr;
z__1.r = temp * work[i__3].r, z__1.i = temp * work[
i__3].i;
vr[i__2].r = z__1.r, vr[i__2].i = z__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., vr[i__2].i = 0.;
/* L240: */
}
}
L250:
;
}
}
return 0;
/* End of ZTGEVC */
} /* ztgevc_ */
/* Subroutine */ int ztrsyl_(char *trana, char *tranb, integer *isgn, integer
*m, integer *n, doublecomplex *a, integer *lda, doublecomplex *b,
integer *ldb, doublecomplex *c__, integer *ldc, doublereal *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;
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer j, k, l;
doublecomplex a11;
doublereal db;
doublecomplex x11;
doublereal da11;
doublecomplex vec;
doublereal dum[1], eps, sgn, smin;
doublecomplex suml, sumr;
extern logical lsame_(char *, char *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *), zdotu_(
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *);
doublereal scaloc;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *);
doublereal bignum;
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *);
extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *,
doublecomplex *);
logical notrna, notrnb;
doublereal 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 */
/* ======= */
/* ZTRSYL 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*16 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*16 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*16 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) DOUBLE PRECISION */
/* 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_("ZTRSYL", &i__1);
return 0;
}
/* Quick return if possible */
*scale = 1.;
if (*m == 0 || *n == 0) {
return 0;
}
/* Set constants to control overflow */
eps = dlamch_("P");
smlnum = dlamch_("S");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
smlnum = smlnum * (doublereal) (*m * *n) / eps;
bignum = 1. / smlnum;
/* Computing MAX */
d__1 = smlnum, d__2 = eps * zlange_("M", m, m, &a[a_offset], lda, dum), d__1 = max(d__1,d__2), d__2 = eps * zlange_("M", n, n,
&b[b_offset], ldb, dum);
smin = max(d__1,d__2);
sgn = (doublereal) (*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;
zdotu_(&z__1, &i__2, &a[k + min(i__3, *m)* a_dim1], lda, &c__[
min(i__4, *m)+ l * c_dim1], &c__1);
suml.r = z__1.r, suml.i = z__1.i;
i__2 = l - 1;
zdotu_(&z__1, &i__2, &c__[k + c_dim1], ldc, &b[l * b_dim1 + 1]
, &c__1);
sumr.r = z__1.r, sumr.i = z__1.i;
i__2 = k + l * c_dim1;
z__3.r = sgn * sumr.r, z__3.i = sgn * sumr.i;
z__2.r = suml.r + z__3.r, z__2.i = suml.i + z__3.i;
z__1.r = c__[i__2].r - z__2.r, z__1.i = c__[i__2].i - z__2.i;
vec.r = z__1.r, vec.i = z__1.i;
scaloc = 1.;
i__2 = k + k * a_dim1;
i__3 = l + l * b_dim1;
z__2.r = sgn * b[i__3].r, z__2.i = sgn * b[i__3].i;
z__1.r = a[i__2].r + z__2.r, z__1.i = a[i__2].i + z__2.i;
a11.r = z__1.r, a11.i = z__1.i;
da11 = (d__1 = a11.r, abs(d__1)) + (d__2 = d_imag(&a11), abs(
d__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.;
da11 = smin;
*info = 1;
}
db = (d__1 = vec.r, abs(d__1)) + (d__2 = d_imag(&vec), abs(
d__2));
if (da11 < 1. && db > 1.) {
if (db > bignum * da11) {
scaloc = 1. / db;
}
}
z__3.r = scaloc, z__3.i = 0.;
z__2.r = vec.r * z__3.r - vec.i * z__3.i, z__2.i = vec.r *
z__3.i + vec.i * z__3.r;
zladiv_(&z__1, &z__2, &a11);
x11.r = z__1.r, x11.i = z__1.i;
if (scaloc != 1.) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
zdscal_(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;
zdotc_(&z__1, &i__3, &a[k * a_dim1 + 1], &c__1, &c__[l *
c_dim1 + 1], &c__1);
suml.r = z__1.r, suml.i = z__1.i;
i__3 = l - 1;
zdotu_(&z__1, &i__3, &c__[k + c_dim1], ldc, &b[l * b_dim1 + 1]
, &c__1);
sumr.r = z__1.r, sumr.i = z__1.i;
i__3 = k + l * c_dim1;
z__3.r = sgn * sumr.r, z__3.i = sgn * sumr.i;
z__2.r = suml.r + z__3.r, z__2.i = suml.i + z__3.i;
z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
vec.r = z__1.r, vec.i = z__1.i;
scaloc = 1.;
d_cnjg(&z__2, &a[k + k * a_dim1]);
i__3 = l + l * b_dim1;
z__3.r = sgn * b[i__3].r, z__3.i = sgn * b[i__3].i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
a11.r = z__1.r, a11.i = z__1.i;
da11 = (d__1 = a11.r, abs(d__1)) + (d__2 = d_imag(&a11), abs(
d__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.;
da11 = smin;
*info = 1;
}
db = (d__1 = vec.r, abs(d__1)) + (d__2 = d_imag(&vec), abs(
d__2));
if (da11 < 1. && db > 1.) {
if (db > bignum * da11) {
scaloc = 1. / db;
}
}
z__3.r = scaloc, z__3.i = 0.;
z__2.r = vec.r * z__3.r - vec.i * z__3.i, z__2.i = vec.r *
z__3.i + vec.i * z__3.r;
zladiv_(&z__1, &z__2, &a11);
x11.r = z__1.r, x11.i = z__1.i;
if (scaloc != 1.) {
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
zdscal_(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;
zdotc_(&z__1, &i__2, &a[k * a_dim1 + 1], &c__1, &c__[l *
c_dim1 + 1], &c__1);
suml.r = z__1.r, suml.i = z__1.i;
i__2 = *n - l;
/* Computing MIN */
i__3 = l + 1;
/* Computing MIN */
i__4 = l + 1;
zdotc_(&z__1, &i__2, &c__[k + min(i__3, *n)* c_dim1], ldc, &b[
l + min(i__4, *n)* b_dim1], ldb);
sumr.r = z__1.r, sumr.i = z__1.i;
i__2 = k + l * c_dim1;
d_cnjg(&z__4, &sumr);
z__3.r = sgn * z__4.r, z__3.i = sgn * z__4.i;
z__2.r = suml.r + z__3.r, z__2.i = suml.i + z__3.i;
z__1.r = c__[i__2].r - z__2.r, z__1.i = c__[i__2].i - z__2.i;
vec.r = z__1.r, vec.i = z__1.i;
scaloc = 1.;
i__2 = k + k * a_dim1;
i__3 = l + l * b_dim1;
z__3.r = sgn * b[i__3].r, z__3.i = sgn * b[i__3].i;
z__2.r = a[i__2].r + z__3.r, z__2.i = a[i__2].i + z__3.i;
d_cnjg(&z__1, &z__2);
a11.r = z__1.r, a11.i = z__1.i;
da11 = (d__1 = a11.r, abs(d__1)) + (d__2 = d_imag(&a11), abs(
d__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.;
da11 = smin;
*info = 1;
}
db = (d__1 = vec.r, abs(d__1)) + (d__2 = d_imag(&vec), abs(
d__2));
if (da11 < 1. && db > 1.) {
if (db > bignum * da11) {
scaloc = 1. / db;
}
}
z__3.r = scaloc, z__3.i = 0.;
z__2.r = vec.r * z__3.r - vec.i * z__3.i, z__2.i = vec.r *
z__3.i + vec.i * z__3.r;
zladiv_(&z__1, &z__2, &a11);
x11.r = z__1.r, x11.i = z__1.i;
if (scaloc != 1.) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
zdscal_(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;
zdotu_(&z__1, &i__1, &a[k + min(i__2, *m)* a_dim1], lda, &c__[
min(i__3, *m)+ l * c_dim1], &c__1);
suml.r = z__1.r, suml.i = z__1.i;
i__1 = *n - l;
/* Computing MIN */
i__2 = l + 1;
/* Computing MIN */
i__3 = l + 1;
zdotc_(&z__1, &i__1, &c__[k + min(i__2, *n)* c_dim1], ldc, &b[
l + min(i__3, *n)* b_dim1], ldb);
sumr.r = z__1.r, sumr.i = z__1.i;
i__1 = k + l * c_dim1;
d_cnjg(&z__4, &sumr);
z__3.r = sgn * z__4.r, z__3.i = sgn * z__4.i;
z__2.r = suml.r + z__3.r, z__2.i = suml.i + z__3.i;
z__1.r = c__[i__1].r - z__2.r, z__1.i = c__[i__1].i - z__2.i;
vec.r = z__1.r, vec.i = z__1.i;
scaloc = 1.;
i__1 = k + k * a_dim1;
d_cnjg(&z__3, &b[l + l * b_dim1]);
z__2.r = sgn * z__3.r, z__2.i = sgn * z__3.i;
z__1.r = a[i__1].r + z__2.r, z__1.i = a[i__1].i + z__2.i;
a11.r = z__1.r, a11.i = z__1.i;
da11 = (d__1 = a11.r, abs(d__1)) + (d__2 = d_imag(&a11), abs(
d__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.;
da11 = smin;
*info = 1;
}
db = (d__1 = vec.r, abs(d__1)) + (d__2 = d_imag(&vec), abs(
d__2));
if (da11 < 1. && db > 1.) {
if (db > bignum * da11) {
scaloc = 1. / db;
}
}
z__3.r = scaloc, z__3.i = 0.;
z__2.r = vec.r * z__3.r - vec.i * z__3.i, z__2.i = vec.r *
z__3.i + vec.i * z__3.r;
zladiv_(&z__1, &z__2, &a11);
x11.r = z__1.r, x11.i = z__1.i;
if (scaloc != 1.) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
zdscal_(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 ZTRSYL */
} /* ztrsyl_ */
