int chgeqz_(char *job, char *compq, char *compz, int *n,
int *ilo, int *ihi, complex *h__, int *ldh, complex *t,
int *ldt, complex *alpha, complex *beta, complex *q, int *ldq,
complex *z__, int *ldz, complex *work, int *lwork, float *
rwork, int *info)
{
/* System generated locals */
int h_dim1, h_offset, q_dim1, q_offset, t_dim1, t_offset, z_dim1,
z_offset, i__1, i__2, i__3, i__4, i__5, i__6;
float r__1, r__2, r__3, r__4, r__5, r__6;
complex q__1, q__2, q__3, q__4, q__5, q__6;
/* Builtin functions */
double c_abs(complex *);
void r_cnjg(complex *, complex *);
double r_imag(complex *);
void c_div(complex *, complex *, complex *), pow_ci(complex *, complex *,
int *), c_sqrt(complex *, complex *);
/* Local variables */
float c__;
int j;
complex s, t1;
int jc, in;
complex u12;
int jr;
complex ad11, ad12, ad21, ad22;
int jch;
int ilq, ilz;
float ulp;
complex abi22;
float absb, atol, btol, temp;
extern int crot_(int *, complex *, int *,
complex *, int *, float *, complex *);
float temp2;
extern int cscal_(int *, complex *, complex *,
int *);
extern int lsame_(char *, char *);
complex ctemp;
int iiter, ilast, jiter;
float anorm, bnorm;
int maxit;
complex shift;
float tempr;
complex ctemp2, ctemp3;
int ilazr2;
float ascale, bscale;
complex signbc;
extern double slamch_(char *), clanhs_(char *, int *,
complex *, int *, float *);
extern int claset_(char *, int *, int *, complex
*, complex *, complex *, int *), clartg_(complex *,
complex *, float *, complex *, complex *);
float safmin;
extern int xerbla_(char *, int *);
complex eshift;
int ilschr;
int icompq, ilastm;
complex rtdisc;
int ischur;
int ilazro;
int icompz, ifirst, ifrstm, istart;
int lquery;
/* -- 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 */
/* ======= */
/* CHGEQZ computes the eigenvalues of a complex matrix pair (H,T), */
/* where H is an upper Hessenberg matrix and T is upper triangular, */
/* using the single-shift QZ method. */
/* Matrix pairs of this type are produced by the reduction to */
/* generalized upper Hessenberg form of a complex matrix pair (A,B): */
/* A = Q1*H*Z1**H, B = Q1*T*Z1**H, */
/* as computed by CGGHRD. */
/* If JOB='S', then the Hessenberg-triangular pair (H,T) is */
/* also reduced to generalized Schur form, */
/* H = Q*S*Z**H, T = Q*P*Z**H, */
/* where Q and Z are unitary matrices and S and P are upper triangular. */
/* Optionally, the unitary matrix Q from the generalized Schur */
/* factorization may be postmultiplied into an input matrix Q1, and the */
/* unitary matrix Z may be postmultiplied into an input matrix Z1. */
/* If Q1 and Z1 are the unitary matrices from CGGHRD that reduced */
/* the matrix pair (A,B) to generalized Hessenberg form, then the output */
/* matrices Q1*Q and Z1*Z are the unitary factors from the generalized */
/* Schur factorization of (A,B): */
/* A = (Q1*Q)*S*(Z1*Z)**H, B = (Q1*Q)*P*(Z1*Z)**H. */
/* To avoid overflow, eigenvalues of the matrix pair (H,T) */
/* (equivalently, of (A,B)) are computed as a pair of complex values */
/* (alpha,beta). If beta is nonzero, lambda = alpha / beta is an */
/* eigenvalue of the generalized nonsymmetric eigenvalue problem (GNEP) */
/* A*x = lambda*B*x */
/* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the */
/* alternate form of the GNEP */
/* mu*A*y = B*y. */
/* The values of alpha and beta for the i-th eigenvalue can be read */
/* directly from the generalized Schur form: alpha = S(i,i), */
/* beta = P(i,i). */
/* Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix */
/* Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), */
/* pp. 241--256. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* = 'E': Compute eigenvalues only; */
/* = 'S': Computer eigenvalues and the Schur form. */
/* COMPQ (input) CHARACTER*1 */
/* = 'N': Left Schur vectors (Q) are not computed; */
/* = 'I': Q is initialized to the unit matrix and the matrix Q */
/* of left Schur vectors of (H,T) is returned; */
/* = 'V': Q must contain a unitary matrix Q1 on entry and */
/* the product Q1*Q is returned. */
/* COMPZ (input) CHARACTER*1 */
/* = 'N': Right Schur vectors (Z) are not computed; */
/* = 'I': Q is initialized to the unit matrix and the matrix Z */
/* of right Schur vectors of (H,T) is returned; */
/* = 'V': Z must contain a unitary matrix Z1 on entry and */
/* the product Z1*Z is returned. */
/* N (input) INTEGER */
/* The order of the matrices H, T, Q, and Z. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* ILO and IHI mark the rows and columns of H which are in */
/* Hessenberg form. It is assumed that A is already upper */
/* triangular in rows and columns 1:ILO-1 and IHI+1:N. */
/* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. */
/* H (input/output) COMPLEX array, dimension (LDH, N) */
/* On entry, the N-by-N upper Hessenberg matrix H. */
/* On exit, if JOB = 'S', H contains the upper triangular */
/* matrix S from the generalized Schur factorization. */
/* If JOB = 'E', the diagonal of H matches that of S, but */
/* the rest of H is unspecified. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH >= MAX( 1, N ). */
/* T (input/output) COMPLEX array, dimension (LDT, N) */
/* On entry, the N-by-N upper triangular matrix T. */
/* On exit, if JOB = 'S', T contains the upper triangular */
/* matrix P from the generalized Schur factorization. */
/* If JOB = 'E', the diagonal of T matches that of P, but */
/* the rest of T is unspecified. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= MAX( 1, N ). */
/* ALPHA (output) COMPLEX array, dimension (N) */
/* The complex scalars alpha that define the eigenvalues of */
/* GNEP. ALPHA(i) = S(i,i) in the generalized Schur */
/* factorization. */
/* BETA (output) COMPLEX array, dimension (N) */
/* The float non-negative scalars beta that define the */
/* eigenvalues of GNEP. BETA(i) = P(i,i) in the generalized */
/* Schur factorization. */
/* Together, the quantities alpha = ALPHA(j) and beta = BETA(j) */
/* represent the j-th eigenvalue of the matrix pair (A,B), in */
/* one of the forms lambda = alpha/beta or mu = beta/alpha. */
/* Since either lambda or mu may overflow, they should not, */
/* in general, be computed. */
/* Q (input/output) COMPLEX array, dimension (LDQ, N) */
/* On entry, if COMPZ = 'V', the unitary matrix Q1 used in the */
/* reduction of (A,B) to generalized Hessenberg form. */
/* On exit, if COMPZ = 'I', the unitary matrix of left Schur */
/* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of */
/* left Schur vectors of (A,B). */
/* Not referenced if COMPZ = 'N'. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= 1. */
/* If COMPQ='V' or 'I', then LDQ >= N. */
/* Z (input/output) COMPLEX array, dimension (LDZ, N) */
/* On entry, if COMPZ = 'V', the unitary matrix Z1 used in the */
/* reduction of (A,B) to generalized Hessenberg form. */
/* On exit, if COMPZ = 'I', the unitary matrix of right Schur */
/* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of */
/* right Schur vectors of (A,B). */
/* Not referenced if COMPZ = 'N'. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1. */
/* If COMPZ='V' or 'I', then LDZ >= N. */
/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO >= 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= MAX(1,N). */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* RWORK (workspace) REAL array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* = 1,...,N: the QZ iteration did not converge. (H,T) is not */
/* in Schur form, but ALPHA(i) and BETA(i), */
/* i=INFO+1,...,N should be correct. */
/* = N+1,...,2*N: the shift calculation failed. (H,T) is not */
/* in Schur form, but ALPHA(i) and BETA(i), */
/* i=INFO-N+1,...,N should be correct. */
/* Further Details */
/* =============== */
/* We assume that complex ABS works as long as its value is less than */
/* overflow. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode JOB, COMPQ, COMPZ */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
--alpha;
--beta;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--rwork;
/* Function Body */
if (lsame_(job, "E")) {
ilschr = FALSE;
ischur = 1;
} else if (lsame_(job, "S")) {
ilschr = TRUE;
ischur = 2;
} else {
ischur = 0;
}
if (lsame_(compq, "N")) {
ilq = FALSE;
icompq = 1;
} else if (lsame_(compq, "V")) {
ilq = TRUE;
icompq = 2;
} else if (lsame_(compq, "I")) {
ilq = TRUE;
icompq = 3;
} else {
icompq = 0;
}
if (lsame_(compz, "N")) {
ilz = FALSE;
icompz = 1;
} else if (lsame_(compz, "V")) {
ilz = TRUE;
icompz = 2;
} else if (lsame_(compz, "I")) {
ilz = TRUE;
icompz = 3;
} else {
icompz = 0;
}
/* Check Argument Values */
*info = 0;
i__1 = MAX(1,*n);
work[1].r = (float) i__1, work[1].i = 0.f;
lquery = *lwork == -1;
if (ischur == 0) {
*info = -1;
} else if (icompq == 0) {
*info = -2;
} else if (icompz == 0) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*ilo < 1) {
*info = -5;
} else if (*ihi > *n || *ihi < *ilo - 1) {
*info = -6;
} else if (*ldh < *n) {
*info = -8;
} else if (*ldt < *n) {
*info = -10;
} else if (*ldq < 1 || ilq && *ldq < *n) {
*info = -14;
} else if (*ldz < 1 || ilz && *ldz < *n) {
*info = -16;
} else if (*lwork < MAX(1,*n) && ! lquery) {
*info = -18;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHGEQZ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
/* WORK( 1 ) = CMPLX( 1 ) */
if (*n <= 0) {
work[1].r = 1.f, work[1].i = 0.f;
return 0;
}
/* Initialize Q and Z */
if (icompq == 3) {
claset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq);
}
if (icompz == 3) {
claset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz);
}
/* Machine Constants */
in = *ihi + 1 - *ilo;
safmin = slamch_("S");
ulp = slamch_("E") * slamch_("B");
anorm = clanhs_("F", &in, &h__[*ilo + *ilo * h_dim1], ldh, &rwork[1]);
bnorm = clanhs_("F", &in, &t[*ilo + *ilo * t_dim1], ldt, &rwork[1]);
/* Computing MAX */
r__1 = safmin, r__2 = ulp * anorm;
atol = MAX(r__1,r__2);
/* Computing MAX */
r__1 = safmin, r__2 = ulp * bnorm;
btol = MAX(r__1,r__2);
ascale = 1.f / MAX(safmin,anorm);
bscale = 1.f / MAX(safmin,bnorm);
/* Set Eigenvalues IHI+1:N */
i__1 = *n;
for (j = *ihi + 1; j <= i__1; ++j) {
absb = c_abs(&t[j + j * t_dim1]);
if (absb > safmin) {
i__2 = j + j * t_dim1;
q__2.r = t[i__2].r / absb, q__2.i = t[i__2].i / absb;
r_cnjg(&q__1, &q__2);
signbc.r = q__1.r, signbc.i = q__1.i;
i__2 = j + j * t_dim1;
t[i__2].r = absb, t[i__2].i = 0.f;
if (ilschr) {
i__2 = j - 1;
cscal_(&i__2, &signbc, &t[j * t_dim1 + 1], &c__1);
cscal_(&j, &signbc, &h__[j * h_dim1 + 1], &c__1);
} else {
i__2 = j + j * h_dim1;
i__3 = j + j * h_dim1;
q__1.r = h__[i__3].r * signbc.r - h__[i__3].i * signbc.i,
q__1.i = h__[i__3].r * signbc.i + h__[i__3].i *
signbc.r;
h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
}
if (ilz) {
cscal_(n, &signbc, &z__[j * z_dim1 + 1], &c__1);
}
} else {
i__2 = j + j * t_dim1;
t[i__2].r = 0.f, t[i__2].i = 0.f;
}
i__2 = j;
i__3 = j + j * h_dim1;
alpha[i__2].r = h__[i__3].r, alpha[i__2].i = h__[i__3].i;
i__2 = j;
i__3 = j + j * t_dim1;
beta[i__2].r = t[i__3].r, beta[i__2].i = t[i__3].i;
/* L10: */
}
/* If IHI < ILO, skip QZ steps */
if (*ihi < *ilo) {
goto L190;
}
/* MAIN QZ ITERATION LOOP */
/* Initialize dynamic indices */
/* Eigenvalues ILAST+1:N have been found. */
/* Column operations modify rows IFRSTM:whatever */
/* Row operations modify columns whatever:ILASTM */
/* If only eigenvalues are being computed, then */
/* IFRSTM is the row of the last splitting row above row ILAST; */
/* this is always at least ILO. */
/* IITER counts iterations since the last eigenvalue was found, */
/* to tell when to use an extraordinary shift. */
/* MAXIT is the maximum number of QZ sweeps allowed. */
ilast = *ihi;
if (ilschr) {
ifrstm = 1;
ilastm = *n;
} else {
ifrstm = *ilo;
ilastm = *ihi;
}
iiter = 0;
eshift.r = 0.f, eshift.i = 0.f;
maxit = (*ihi - *ilo + 1) * 30;
i__1 = maxit;
for (jiter = 1; jiter <= i__1; ++jiter) {
/* Check for too many iterations. */
if (jiter > maxit) {
goto L180;
}
/* Split the matrix if possible. */
/* Two tests: */
/* 1: H(j,j-1)=0 or j=ILO */
/* 2: T(j,j)=0 */
/* Special case: j=ILAST */
if (ilast == *ilo) {
goto L60;
} else {
i__2 = ilast + (ilast - 1) * h_dim1;
if ((r__1 = h__[i__2].r, ABS(r__1)) + (r__2 = r_imag(&h__[ilast
+ (ilast - 1) * h_dim1]), ABS(r__2)) <= atol) {
i__2 = ilast + (ilast - 1) * h_dim1;
h__[i__2].r = 0.f, h__[i__2].i = 0.f;
goto L60;
}
}
if (c_abs(&t[ilast + ilast * t_dim1]) <= btol) {
i__2 = ilast + ilast * t_dim1;
t[i__2].r = 0.f, t[i__2].i = 0.f;
goto L50;
}
/* General case: j<ILAST */
i__2 = *ilo;
for (j = ilast - 1; j >= i__2; --j) {
/* Test 1: for H(j,j-1)=0 or j=ILO */
if (j == *ilo) {
ilazro = TRUE;
} else {
i__3 = j + (j - 1) * h_dim1;
if ((r__1 = h__[i__3].r, ABS(r__1)) + (r__2 = r_imag(&h__[j
+ (j - 1) * h_dim1]), ABS(r__2)) <= atol) {
i__3 = j + (j - 1) * h_dim1;
h__[i__3].r = 0.f, h__[i__3].i = 0.f;
ilazro = TRUE;
} else {
ilazro = FALSE;
}
}
/* Test 2: for T(j,j)=0 */
if (c_abs(&t[j + j * t_dim1]) < btol) {
i__3 = j + j * t_dim1;
t[i__3].r = 0.f, t[i__3].i = 0.f;
/* Test 1a: Check for 2 consecutive small subdiagonals in A */
ilazr2 = FALSE;
if (! ilazro) {
i__3 = j + (j - 1) * h_dim1;
i__4 = j + 1 + j * h_dim1;
i__5 = j + j * h_dim1;
if (((r__1 = h__[i__3].r, ABS(r__1)) + (r__2 = r_imag(&
h__[j + (j - 1) * h_dim1]), ABS(r__2))) * (
ascale * ((r__3 = h__[i__4].r, ABS(r__3)) + (
r__4 = r_imag(&h__[j + 1 + j * h_dim1]), ABS(
r__4)))) <= ((r__5 = h__[i__5].r, ABS(r__5)) + (
r__6 = r_imag(&h__[j + j * h_dim1]), ABS(r__6)))
* (ascale * atol)) {
ilazr2 = TRUE;
}
}
/* If both tests pass (1 & 2), i.e., the leading diagonal */
/* element of B in the block is zero, split a 1x1 block off */
/* at the top. (I.e., at the J-th row/column) The leading */
/* diagonal element of the remainder can also be zero, so */
/* this may have to be done repeatedly. */
if (ilazro || ilazr2) {
i__3 = ilast - 1;
for (jch = j; jch <= i__3; ++jch) {
i__4 = jch + jch * h_dim1;
ctemp.r = h__[i__4].r, ctemp.i = h__[i__4].i;
clartg_(&ctemp, &h__[jch + 1 + jch * h_dim1], &c__, &
s, &h__[jch + jch * h_dim1]);
i__4 = jch + 1 + jch * h_dim1;
h__[i__4].r = 0.f, h__[i__4].i = 0.f;
i__4 = ilastm - jch;
crot_(&i__4, &h__[jch + (jch + 1) * h_dim1], ldh, &
h__[jch + 1 + (jch + 1) * h_dim1], ldh, &c__,
&s);
i__4 = ilastm - jch;
crot_(&i__4, &t[jch + (jch + 1) * t_dim1], ldt, &t[
jch + 1 + (jch + 1) * t_dim1], ldt, &c__, &s);
if (ilq) {
r_cnjg(&q__1, &s);
crot_(n, &q[jch * q_dim1 + 1], &c__1, &q[(jch + 1)
* q_dim1 + 1], &c__1, &c__, &q__1);
}
if (ilazr2) {
i__4 = jch + (jch - 1) * h_dim1;
i__5 = jch + (jch - 1) * h_dim1;
q__1.r = c__ * h__[i__5].r, q__1.i = c__ * h__[
i__5].i;
h__[i__4].r = q__1.r, h__[i__4].i = q__1.i;
}
ilazr2 = FALSE;
i__4 = jch + 1 + (jch + 1) * t_dim1;
if ((r__1 = t[i__4].r, ABS(r__1)) + (r__2 = r_imag(&
t[jch + 1 + (jch + 1) * t_dim1]), ABS(r__2))
>= btol) {
if (jch + 1 >= ilast) {
goto L60;
} else {
ifirst = jch + 1;
goto L70;
}
}
i__4 = jch + 1 + (jch + 1) * t_dim1;
t[i__4].r = 0.f, t[i__4].i = 0.f;
/* L20: */
}
goto L50;
} else {
/* Only test 2 passed -- chase the zero to T(ILAST,ILAST) */
/* Then process as in the case T(ILAST,ILAST)=0 */
i__3 = ilast - 1;
for (jch = j; jch <= i__3; ++jch) {
i__4 = jch + (jch + 1) * t_dim1;
ctemp.r = t[i__4].r, ctemp.i = t[i__4].i;
clartg_(&ctemp, &t[jch + 1 + (jch + 1) * t_dim1], &
c__, &s, &t[jch + (jch + 1) * t_dim1]);
i__4 = jch + 1 + (jch + 1) * t_dim1;
t[i__4].r = 0.f, t[i__4].i = 0.f;
if (jch < ilastm - 1) {
i__4 = ilastm - jch - 1;
crot_(&i__4, &t[jch + (jch + 2) * t_dim1], ldt, &
t[jch + 1 + (jch + 2) * t_dim1], ldt, &
c__, &s);
}
i__4 = ilastm - jch + 2;
crot_(&i__4, &h__[jch + (jch - 1) * h_dim1], ldh, &
h__[jch + 1 + (jch - 1) * h_dim1], ldh, &c__,
&s);
if (ilq) {
r_cnjg(&q__1, &s);
crot_(n, &q[jch * q_dim1 + 1], &c__1, &q[(jch + 1)
* q_dim1 + 1], &c__1, &c__, &q__1);
}
i__4 = jch + 1 + jch * h_dim1;
ctemp.r = h__[i__4].r, ctemp.i = h__[i__4].i;
clartg_(&ctemp, &h__[jch + 1 + (jch - 1) * h_dim1], &
c__, &s, &h__[jch + 1 + jch * h_dim1]);
i__4 = jch + 1 + (jch - 1) * h_dim1;
h__[i__4].r = 0.f, h__[i__4].i = 0.f;
i__4 = jch + 1 - ifrstm;
crot_(&i__4, &h__[ifrstm + jch * h_dim1], &c__1, &h__[
ifrstm + (jch - 1) * h_dim1], &c__1, &c__, &s)
;
i__4 = jch - ifrstm;
crot_(&i__4, &t[ifrstm + jch * t_dim1], &c__1, &t[
ifrstm + (jch - 1) * t_dim1], &c__1, &c__, &s)
;
if (ilz) {
crot_(n, &z__[jch * z_dim1 + 1], &c__1, &z__[(jch
- 1) * z_dim1 + 1], &c__1, &c__, &s);
}
/* L30: */
}
goto L50;
}
} else if (ilazro) {
/* Only test 1 passed -- work on J:ILAST */
ifirst = j;
goto L70;
}
/* Neither test passed -- try next J */
/* L40: */
}
/* (Drop-through is "impossible") */
*info = (*n << 1) + 1;
goto L210;
/* T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a */
/* 1x1 block. */
L50:
i__2 = ilast + ilast * h_dim1;
ctemp.r = h__[i__2].r, ctemp.i = h__[i__2].i;
clartg_(&ctemp, &h__[ilast + (ilast - 1) * h_dim1], &c__, &s, &h__[
ilast + ilast * h_dim1]);
i__2 = ilast + (ilast - 1) * h_dim1;
h__[i__2].r = 0.f, h__[i__2].i = 0.f;
i__2 = ilast - ifrstm;
crot_(&i__2, &h__[ifrstm + ilast * h_dim1], &c__1, &h__[ifrstm + (
ilast - 1) * h_dim1], &c__1, &c__, &s);
i__2 = ilast - ifrstm;
crot_(&i__2, &t[ifrstm + ilast * t_dim1], &c__1, &t[ifrstm + (ilast -
1) * t_dim1], &c__1, &c__, &s);
if (ilz) {
crot_(n, &z__[ilast * z_dim1 + 1], &c__1, &z__[(ilast - 1) *
z_dim1 + 1], &c__1, &c__, &s);
}
/* H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHA and BETA */
L60:
absb = c_abs(&t[ilast + ilast * t_dim1]);
if (absb > safmin) {
i__2 = ilast + ilast * t_dim1;
q__2.r = t[i__2].r / absb, q__2.i = t[i__2].i / absb;
r_cnjg(&q__1, &q__2);
signbc.r = q__1.r, signbc.i = q__1.i;
i__2 = ilast + ilast * t_dim1;
t[i__2].r = absb, t[i__2].i = 0.f;
if (ilschr) {
i__2 = ilast - ifrstm;
cscal_(&i__2, &signbc, &t[ifrstm + ilast * t_dim1], &c__1);
i__2 = ilast + 1 - ifrstm;
cscal_(&i__2, &signbc, &h__[ifrstm + ilast * h_dim1], &c__1);
} else {
i__2 = ilast + ilast * h_dim1;
i__3 = ilast + ilast * h_dim1;
q__1.r = h__[i__3].r * signbc.r - h__[i__3].i * signbc.i,
q__1.i = h__[i__3].r * signbc.i + h__[i__3].i *
signbc.r;
h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
}
if (ilz) {
cscal_(n, &signbc, &z__[ilast * z_dim1 + 1], &c__1);
}
} else {
i__2 = ilast + ilast * t_dim1;
t[i__2].r = 0.f, t[i__2].i = 0.f;
}
i__2 = ilast;
i__3 = ilast + ilast * h_dim1;
alpha[i__2].r = h__[i__3].r, alpha[i__2].i = h__[i__3].i;
i__2 = ilast;
i__3 = ilast + ilast * t_dim1;
beta[i__2].r = t[i__3].r, beta[i__2].i = t[i__3].i;
/* Go to next block -- exit if finished. */
--ilast;
if (ilast < *ilo) {
goto L190;
}
/* Reset counters */
iiter = 0;
eshift.r = 0.f, eshift.i = 0.f;
if (! ilschr) {
ilastm = ilast;
if (ifrstm > ilast) {
ifrstm = *ilo;
}
}
goto L160;
/* QZ step */
/* This iteration only involves rows/columns IFIRST:ILAST. We */
/* assume IFIRST < ILAST, and that the diagonal of B is non-zero. */
L70:
++iiter;
if (! ilschr) {
ifrstm = ifirst;
}
/* Compute the Shift. */
/* At this point, IFIRST < ILAST, and the diagonal elements of */
/* T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in */
/* magnitude) */
if (iiter / 10 * 10 != iiter) {
/* The Wilkinson shift (AEP p.512), i.e., the eigenvalue of */
/* the bottom-right 2x2 block of A inv(B) which is nearest to */
/* the bottom-right element. */
/* We factor B as U*D, where U has unit diagonals, and */
/* compute (A*inv(D))*inv(U). */
i__2 = ilast - 1 + ilast * t_dim1;
q__2.r = bscale * t[i__2].r, q__2.i = bscale * t[i__2].i;
i__3 = ilast + ilast * t_dim1;
q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
c_div(&q__1, &q__2, &q__3);
u12.r = q__1.r, u12.i = q__1.i;
i__2 = ilast - 1 + (ilast - 1) * h_dim1;
q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
i__3 = ilast - 1 + (ilast - 1) * t_dim1;
q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
c_div(&q__1, &q__2, &q__3);
ad11.r = q__1.r, ad11.i = q__1.i;
i__2 = ilast + (ilast - 1) * h_dim1;
q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
i__3 = ilast - 1 + (ilast - 1) * t_dim1;
q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
c_div(&q__1, &q__2, &q__3);
ad21.r = q__1.r, ad21.i = q__1.i;
i__2 = ilast - 1 + ilast * h_dim1;
q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
i__3 = ilast + ilast * t_dim1;
q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
c_div(&q__1, &q__2, &q__3);
ad12.r = q__1.r, ad12.i = q__1.i;
i__2 = ilast + ilast * h_dim1;
q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
i__3 = ilast + ilast * t_dim1;
q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
c_div(&q__1, &q__2, &q__3);
ad22.r = q__1.r, ad22.i = q__1.i;
q__2.r = u12.r * ad21.r - u12.i * ad21.i, q__2.i = u12.r * ad21.i
+ u12.i * ad21.r;
q__1.r = ad22.r - q__2.r, q__1.i = ad22.i - q__2.i;
abi22.r = q__1.r, abi22.i = q__1.i;
q__2.r = ad11.r + abi22.r, q__2.i = ad11.i + abi22.i;
q__1.r = q__2.r * .5f, q__1.i = q__2.i * .5f;
t1.r = q__1.r, t1.i = q__1.i;
pow_ci(&q__4, &t1, &c__2);
q__5.r = ad12.r * ad21.r - ad12.i * ad21.i, q__5.i = ad12.r *
ad21.i + ad12.i * ad21.r;
q__3.r = q__4.r + q__5.r, q__3.i = q__4.i + q__5.i;
q__6.r = ad11.r * ad22.r - ad11.i * ad22.i, q__6.i = ad11.r *
ad22.i + ad11.i * ad22.r;
q__2.r = q__3.r - q__6.r, q__2.i = q__3.i - q__6.i;
c_sqrt(&q__1, &q__2);
rtdisc.r = q__1.r, rtdisc.i = q__1.i;
q__1.r = t1.r - abi22.r, q__1.i = t1.i - abi22.i;
q__2.r = t1.r - abi22.r, q__2.i = t1.i - abi22.i;
temp = q__1.r * rtdisc.r + r_imag(&q__2) * r_imag(&rtdisc);
if (temp <= 0.f) {
q__1.r = t1.r + rtdisc.r, q__1.i = t1.i + rtdisc.i;
shift.r = q__1.r, shift.i = q__1.i;
} else {
q__1.r = t1.r - rtdisc.r, q__1.i = t1.i - rtdisc.i;
shift.r = q__1.r, shift.i = q__1.i;
}
} else {
/* Exceptional shift. Chosen for no particularly good reason. */
i__2 = ilast - 1 + ilast * h_dim1;
q__4.r = ascale * h__[i__2].r, q__4.i = ascale * h__[i__2].i;
i__3 = ilast - 1 + (ilast - 1) * t_dim1;
q__5.r = bscale * t[i__3].r, q__5.i = bscale * t[i__3].i;
c_div(&q__3, &q__4, &q__5);
r_cnjg(&q__2, &q__3);
q__1.r = eshift.r + q__2.r, q__1.i = eshift.i + q__2.i;
eshift.r = q__1.r, eshift.i = q__1.i;
shift.r = eshift.r, shift.i = eshift.i;
}
/* Now check for two consecutive small subdiagonals. */
i__2 = ifirst + 1;
for (j = ilast - 1; j >= i__2; --j) {
istart = j;
i__3 = j + j * h_dim1;
q__2.r = ascale * h__[i__3].r, q__2.i = ascale * h__[i__3].i;
i__4 = j + j * t_dim1;
q__4.r = bscale * t[i__4].r, q__4.i = bscale * t[i__4].i;
q__3.r = shift.r * q__4.r - shift.i * q__4.i, q__3.i = shift.r *
q__4.i + shift.i * q__4.r;
q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
temp = (r__1 = ctemp.r, ABS(r__1)) + (r__2 = r_imag(&ctemp),
ABS(r__2));
i__3 = j + 1 + j * h_dim1;
temp2 = ascale * ((r__1 = h__[i__3].r, ABS(r__1)) + (r__2 =
r_imag(&h__[j + 1 + j * h_dim1]), ABS(r__2)));
tempr = MAX(temp,temp2);
if (tempr < 1.f && tempr != 0.f) {
temp /= tempr;
temp2 /= tempr;
}
i__3 = j + (j - 1) * h_dim1;
if (((r__1 = h__[i__3].r, ABS(r__1)) + (r__2 = r_imag(&h__[j + (
j - 1) * h_dim1]), ABS(r__2))) * temp2 <= temp * atol) {
goto L90;
}
/* L80: */
}
istart = ifirst;
i__2 = ifirst + ifirst * h_dim1;
q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
i__3 = ifirst + ifirst * t_dim1;
q__4.r = bscale * t[i__3].r, q__4.i = bscale * t[i__3].i;
q__3.r = shift.r * q__4.r - shift.i * q__4.i, q__3.i = shift.r *
q__4.i + shift.i * q__4.r;
q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
L90:
/* Do an implicit-shift QZ sweep. */
/* Initial Q */
i__2 = istart + 1 + istart * h_dim1;
q__1.r = ascale * h__[i__2].r, q__1.i = ascale * h__[i__2].i;
ctemp2.r = q__1.r, ctemp2.i = q__1.i;
clartg_(&ctemp, &ctemp2, &c__, &s, &ctemp3);
/* Sweep */
i__2 = ilast - 1;
for (j = istart; j <= i__2; ++j) {
if (j > istart) {
i__3 = j + (j - 1) * h_dim1;
ctemp.r = h__[i__3].r, ctemp.i = h__[i__3].i;
clartg_(&ctemp, &h__[j + 1 + (j - 1) * h_dim1], &c__, &s, &
h__[j + (j - 1) * h_dim1]);
i__3 = j + 1 + (j - 1) * h_dim1;
h__[i__3].r = 0.f, h__[i__3].i = 0.f;
}
i__3 = ilastm;
for (jc = j; jc <= i__3; ++jc) {
i__4 = j + jc * h_dim1;
q__2.r = c__ * h__[i__4].r, q__2.i = c__ * h__[i__4].i;
i__5 = j + 1 + jc * h_dim1;
q__3.r = s.r * h__[i__5].r - s.i * h__[i__5].i, q__3.i = s.r *
h__[i__5].i + s.i * h__[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__4 = j + 1 + jc * h_dim1;
r_cnjg(&q__4, &s);
q__3.r = -q__4.r, q__3.i = -q__4.i;
i__5 = j + jc * h_dim1;
q__2.r = q__3.r * h__[i__5].r - q__3.i * h__[i__5].i, q__2.i =
q__3.r * h__[i__5].i + q__3.i * h__[i__5].r;
i__6 = j + 1 + jc * h_dim1;
q__5.r = c__ * h__[i__6].r, q__5.i = c__ * h__[i__6].i;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
h__[i__4].r = q__1.r, h__[i__4].i = q__1.i;
i__4 = j + jc * h_dim1;
h__[i__4].r = ctemp.r, h__[i__4].i = ctemp.i;
i__4 = j + jc * t_dim1;
q__2.r = c__ * t[i__4].r, q__2.i = c__ * t[i__4].i;
i__5 = j + 1 + jc * t_dim1;
q__3.r = s.r * t[i__5].r - s.i * t[i__5].i, q__3.i = s.r * t[
i__5].i + s.i * t[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
ctemp2.r = q__1.r, ctemp2.i = q__1.i;
i__4 = j + 1 + jc * t_dim1;
r_cnjg(&q__4, &s);
q__3.r = -q__4.r, q__3.i = -q__4.i;
i__5 = j + jc * t_dim1;
q__2.r = q__3.r * t[i__5].r - q__3.i * t[i__5].i, q__2.i =
q__3.r * t[i__5].i + q__3.i * t[i__5].r;
i__6 = j + 1 + jc * t_dim1;
q__5.r = c__ * t[i__6].r, q__5.i = c__ * t[i__6].i;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
t[i__4].r = q__1.r, t[i__4].i = q__1.i;
i__4 = j + jc * t_dim1;
t[i__4].r = ctemp2.r, t[i__4].i = ctemp2.i;
/* L100: */
}
if (ilq) {
i__3 = *n;
for (jr = 1; jr <= i__3; ++jr) {
i__4 = jr + j * q_dim1;
q__2.r = c__ * q[i__4].r, q__2.i = c__ * q[i__4].i;
r_cnjg(&q__4, &s);
i__5 = jr + (j + 1) * q_dim1;
q__3.r = q__4.r * q[i__5].r - q__4.i * q[i__5].i, q__3.i =
q__4.r * q[i__5].i + q__4.i * q[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__4 = jr + (j + 1) * q_dim1;
q__3.r = -s.r, q__3.i = -s.i;
i__5 = jr + j * q_dim1;
q__2.r = q__3.r * q[i__5].r - q__3.i * q[i__5].i, q__2.i =
q__3.r * q[i__5].i + q__3.i * q[i__5].r;
i__6 = jr + (j + 1) * q_dim1;
q__4.r = c__ * q[i__6].r, q__4.i = c__ * q[i__6].i;
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
q[i__4].r = q__1.r, q[i__4].i = q__1.i;
i__4 = jr + j * q_dim1;
q[i__4].r = ctemp.r, q[i__4].i = ctemp.i;
/* L110: */
}
}
i__3 = j + 1 + (j + 1) * t_dim1;
ctemp.r = t[i__3].r, ctemp.i = t[i__3].i;
clartg_(&ctemp, &t[j + 1 + j * t_dim1], &c__, &s, &t[j + 1 + (j +
1) * t_dim1]);
i__3 = j + 1 + j * t_dim1;
t[i__3].r = 0.f, t[i__3].i = 0.f;
/* Computing MIN */
i__4 = j + 2;
i__3 = MIN(i__4,ilast);
for (jr = ifrstm; jr <= i__3; ++jr) {
i__4 = jr + (j + 1) * h_dim1;
q__2.r = c__ * h__[i__4].r, q__2.i = c__ * h__[i__4].i;
i__5 = jr + j * h_dim1;
q__3.r = s.r * h__[i__5].r - s.i * h__[i__5].i, q__3.i = s.r *
h__[i__5].i + s.i * h__[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__4 = jr + j * h_dim1;
r_cnjg(&q__4, &s);
q__3.r = -q__4.r, q__3.i = -q__4.i;
i__5 = jr + (j + 1) * h_dim1;
q__2.r = q__3.r * h__[i__5].r - q__3.i * h__[i__5].i, q__2.i =
q__3.r * h__[i__5].i + q__3.i * h__[i__5].r;
i__6 = jr + j * h_dim1;
q__5.r = c__ * h__[i__6].r, q__5.i = c__ * h__[i__6].i;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
h__[i__4].r = q__1.r, h__[i__4].i = q__1.i;
i__4 = jr + (j + 1) * h_dim1;
h__[i__4].r = ctemp.r, h__[i__4].i = ctemp.i;
/* L120: */
}
i__3 = j;
for (jr = ifrstm; jr <= i__3; ++jr) {
i__4 = jr + (j + 1) * t_dim1;
q__2.r = c__ * t[i__4].r, q__2.i = c__ * t[i__4].i;
i__5 = jr + j * t_dim1;
q__3.r = s.r * t[i__5].r - s.i * t[i__5].i, q__3.i = s.r * t[
i__5].i + s.i * t[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__4 = jr + j * t_dim1;
r_cnjg(&q__4, &s);
q__3.r = -q__4.r, q__3.i = -q__4.i;
i__5 = jr + (j + 1) * t_dim1;
q__2.r = q__3.r * t[i__5].r - q__3.i * t[i__5].i, q__2.i =
q__3.r * t[i__5].i + q__3.i * t[i__5].r;
i__6 = jr + j * t_dim1;
q__5.r = c__ * t[i__6].r, q__5.i = c__ * t[i__6].i;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
t[i__4].r = q__1.r, t[i__4].i = q__1.i;
i__4 = jr + (j + 1) * t_dim1;
t[i__4].r = ctemp.r, t[i__4].i = ctemp.i;
/* L130: */
}
if (ilz) {
i__3 = *n;
for (jr = 1; jr <= i__3; ++jr) {
i__4 = jr + (j + 1) * z_dim1;
q__2.r = c__ * z__[i__4].r, q__2.i = c__ * z__[i__4].i;
i__5 = jr + j * z_dim1;
q__3.r = s.r * z__[i__5].r - s.i * z__[i__5].i, q__3.i =
s.r * z__[i__5].i + s.i * z__[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__4 = jr + j * z_dim1;
r_cnjg(&q__4, &s);
q__3.r = -q__4.r, q__3.i = -q__4.i;
i__5 = jr + (j + 1) * z_dim1;
q__2.r = q__3.r * z__[i__5].r - q__3.i * z__[i__5].i,
q__2.i = q__3.r * z__[i__5].i + q__3.i * z__[i__5]
.r;
i__6 = jr + j * z_dim1;
q__5.r = c__ * z__[i__6].r, q__5.i = c__ * z__[i__6].i;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
z__[i__4].r = q__1.r, z__[i__4].i = q__1.i;
i__4 = jr + (j + 1) * z_dim1;
z__[i__4].r = ctemp.r, z__[i__4].i = ctemp.i;
/* L140: */
}
}
/* L150: */
}
L160:
/* L170: */
;
}
/* Drop-through = non-convergence */
L180:
*info = ilast;
goto L210;
/* Successful completion of all QZ steps */
L190:
/* Set Eigenvalues 1:ILO-1 */
i__1 = *ilo - 1;
for (j = 1; j <= i__1; ++j) {
absb = c_abs(&t[j + j * t_dim1]);
if (absb > safmin) {
i__2 = j + j * t_dim1;
q__2.r = t[i__2].r / absb, q__2.i = t[i__2].i / absb;
r_cnjg(&q__1, &q__2);
signbc.r = q__1.r, signbc.i = q__1.i;
i__2 = j + j * t_dim1;
t[i__2].r = absb, t[i__2].i = 0.f;
if (ilschr) {
i__2 = j - 1;
cscal_(&i__2, &signbc, &t[j * t_dim1 + 1], &c__1);
cscal_(&j, &signbc, &h__[j * h_dim1 + 1], &c__1);
} else {
i__2 = j + j * h_dim1;
i__3 = j + j * h_dim1;
q__1.r = h__[i__3].r * signbc.r - h__[i__3].i * signbc.i,
q__1.i = h__[i__3].r * signbc.i + h__[i__3].i *
signbc.r;
h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
}
if (ilz) {
cscal_(n, &signbc, &z__[j * z_dim1 + 1], &c__1);
}
} else {
i__2 = j + j * t_dim1;
t[i__2].r = 0.f, t[i__2].i = 0.f;
}
i__2 = j;
i__3 = j + j * h_dim1;
alpha[i__2].r = h__[i__3].r, alpha[i__2].i = h__[i__3].i;
i__2 = j;
i__3 = j + j * t_dim1;
beta[i__2].r = t[i__3].r, beta[i__2].i = t[i__3].i;
/* L200: */
}
/* Normal Termination */
*info = 0;
/* Exit (other than argument error) -- return optimal workspace size */
L210:
q__1.r = (float) (*n), q__1.i = 0.f;
work[1].r = q__1.r, work[1].i = q__1.i;
return 0;
/* End of CHGEQZ */
} /* chgeqz_ */
/* Subroutine */ int claesy_(complex *a, complex *b, complex *c, complex *rt1,
complex *rt2, complex *evscal, complex *cs1, complex *sn1)
{
/* -- LAPACK auxiliary routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CLAESY computes the eigendecomposition of a 2-by-2 symmetric matrix
( ( A, B );( B, C ) )
provided the norm of the matrix of eigenvectors is larger than
some threshold value.
RT1 is the eigenvalue of larger absolute value, and RT2 of
smaller absolute value. If the eigenvectors are computed, then
on return ( CS1, SN1 ) is the unit eigenvector for RT1, hence
[ CS1 SN1 ] . [ A B ] . [ CS1 -SN1 ] = [ RT1 0 ]
[ -SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]
Arguments
=========
A (input) COMPLEX
The ( 1, 1 ) element of input matrix.
B (input) COMPLEX
The ( 1, 2 ) element of input matrix. The ( 2, 1 ) element
is also given by B, since the 2-by-2 matrix is symmetric.
C (input) COMPLEX
The ( 2, 2 ) element of input matrix.
RT1 (output) COMPLEX
The eigenvalue of larger modulus.
RT2 (output) COMPLEX
The eigenvalue of smaller modulus.
EVSCAL (output) COMPLEX
The complex value by which the eigenvector matrix was scaled
to make it orthonormal. If EVSCAL is zero, the eigenvectors
were not computed. This means one of two things: the 2-by-2
matrix could not be diagonalized, or the norm of the matrix
of eigenvectors before scaling was larger than the threshold
value THRESH (set below).
CS1 (output) COMPLEX
SN1 (output) COMPLEX
If EVSCAL .NE. 0, ( CS1, SN1 ) is the unit right eigenvector
for RT1.
=====================================================================
Special case: The matrix is actually diagonal.
To avoid divide by zero later, we treat this case separately. */
/* Table of constant values */
static complex c_b1 = {1.f,0.f};
static integer c__2 = 2;
/* System generated locals */
real r__1;
doublereal d__1;
complex q__1, q__2, q__3, q__4, q__5, q__6, q__7;
/* Builtin functions */
double c_abs(complex *);
void pow_ci(complex *, complex *, integer *), c_sqrt(complex *, complex *)
, c_div(complex *, complex *, complex *);
/* Local variables */
static real babs, tabs;
static complex s, t;
static real z, evnorm;
static complex tmp;
if (c_abs(b) == 0.f) {
rt1->r = a->r, rt1->i = a->i;
rt2->r = c->r, rt2->i = c->i;
if (c_abs(rt1) < c_abs(rt2)) {
tmp.r = rt1->r, tmp.i = rt1->i;
rt1->r = rt2->r, rt1->i = rt2->i;
rt2->r = tmp.r, rt2->i = tmp.i;
cs1->r = 0.f, cs1->i = 0.f;
sn1->r = 1.f, sn1->i = 0.f;
} else {
cs1->r = 1.f, cs1->i = 0.f;
sn1->r = 0.f, sn1->i = 0.f;
}
} else {
/* Compute the eigenvalues and eigenvectors.
The characteristic equation is
lambda **2 - (A+C) lambda + (A*C - B*B)
and we solve it using the quadratic formula. */
q__2.r = a->r + c->r, q__2.i = a->i + c->i;
q__1.r = q__2.r * .5f, q__1.i = q__2.i * .5f;
s.r = q__1.r, s.i = q__1.i;
q__2.r = a->r - c->r, q__2.i = a->i - c->i;
q__1.r = q__2.r * .5f, q__1.i = q__2.i * .5f;
t.r = q__1.r, t.i = q__1.i;
/* Take the square root carefully to avoid over/under flow. */
babs = c_abs(b);
tabs = c_abs(&t);
z = dmax(babs,tabs);
if (z > 0.f) {
q__5.r = t.r / z, q__5.i = t.i / z;
pow_ci(&q__4, &q__5, &c__2);
q__7.r = b->r / z, q__7.i = b->i / z;
pow_ci(&q__6, &q__7, &c__2);
q__3.r = q__4.r + q__6.r, q__3.i = q__4.i + q__6.i;
c_sqrt(&q__2, &q__3);
q__1.r = z * q__2.r, q__1.i = z * q__2.i;
t.r = q__1.r, t.i = q__1.i;
}
/* Compute the two eigenvalues. RT1 and RT2 are exchanged
if necessary so that RT1 will have the greater magnitude. */
q__1.r = s.r + t.r, q__1.i = s.i + t.i;
rt1->r = q__1.r, rt1->i = q__1.i;
q__1.r = s.r - t.r, q__1.i = s.i - t.i;
rt2->r = q__1.r, rt2->i = q__1.i;
if (c_abs(rt1) < c_abs(rt2)) {
tmp.r = rt1->r, tmp.i = rt1->i;
rt1->r = rt2->r, rt1->i = rt2->i;
rt2->r = tmp.r, rt2->i = tmp.i;
}
/* Choose CS1 = 1 and SN1 to satisfy the first equation, then
scale the components of this eigenvector so that the matrix
of eigenvectors X satisfies X * X' = I . (No scaling is
done if the norm of the eigenvalue matrix is less than THRES
H.) */
q__2.r = rt1->r - a->r, q__2.i = rt1->i - a->i;
c_div(&q__1, &q__2, b);
sn1->r = q__1.r, sn1->i = q__1.i;
tabs = c_abs(sn1);
if (tabs > 1.f) {
/* Computing 2nd power */
r__1 = 1.f / tabs;
d__1 = r__1 * r__1;
q__5.r = sn1->r / tabs, q__5.i = sn1->i / tabs;
pow_ci(&q__4, &q__5, &c__2);
q__3.r = d__1 + q__4.r, q__3.i = q__4.i;
c_sqrt(&q__2, &q__3);
q__1.r = tabs * q__2.r, q__1.i = tabs * q__2.i;
t.r = q__1.r, t.i = q__1.i;
} else {
q__3.r = sn1->r * sn1->r - sn1->i * sn1->i, q__3.i = sn1->r *
sn1->i + sn1->i * sn1->r;
q__2.r = q__3.r + 1.f, q__2.i = q__3.i + 0.f;
c_sqrt(&q__1, &q__2);
t.r = q__1.r, t.i = q__1.i;
}
evnorm = c_abs(&t);
if (evnorm >= .1f) {
c_div(&q__1, &c_b1, &t);
evscal->r = q__1.r, evscal->i = q__1.i;
cs1->r = evscal->r, cs1->i = evscal->i;
q__1.r = sn1->r * evscal->r - sn1->i * evscal->i, q__1.i = sn1->r
* evscal->i + sn1->i * evscal->r;
sn1->r = q__1.r, sn1->i = q__1.i;
} else {
evscal->r = 0.f, evscal->i = 0.f;
}
}
return 0;
/* End of CLAESY */
} /* claesy_ */
/* DECK CPSI */
/* Complex */ void cpsi_(complex * ret_val, complex *zin)
{
/* Initialized data */
static real bern[13] = { .083333333333333333f,-.0083333333333333333f,
.0039682539682539683f,-.0041666666666666667f,
.0075757575757575758f,-.021092796092796093f,.083333333333333333f,
-.44325980392156863f,3.0539543302701197f,-26.456212121212121f,
281.46014492753623f,-3454.8853937728938f,54827.583333333333f };
static real pi = 3.141592653589793f;
static logical first = TRUE_;
/* System generated locals */
integer i__1, i__2;
real r__1, r__2;
doublereal d__1, d__2;
complex q__1, q__2, q__3, q__4, q__5, q__6;
/* Local variables */
static integer i__, n;
static real x, y;
static complex z__;
static integer ndx;
static real rbig;
extern /* Complex */ void ccot_(complex *, complex *);
static complex corr;
static real rmin;
static complex z2inv;
static real cabsz, bound, dxrel;
static integer nterm;
extern doublereal r1mach_(integer *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE CPSI */
/* ***PURPOSE Compute the Psi (or Digamma) function. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C7C */
/* ***TYPE COMPLEX (PSI-S, DPSI-D, CPSI-C) */
/* ***KEYWORDS DIGAMMA FUNCTION, FNLIB, PSI FUNCTION, SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* PSI(X) calculates the psi (or digamma) function of X. PSI(X) */
/* is the logarithmic derivative of the gamma function of X. */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED CCOT, R1MACH, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 780501 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890531 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* 900727 Added EXTERNAL statement. (WRB) */
/* ***END PROLOGUE CPSI */
/* ***FIRST EXECUTABLE STATEMENT CPSI */
if (first) {
nterm = log(r1mach_(&c__3)) * -.3f;
/* MAYBE BOUND = N*(0.1*EPS)**(-1/(2*N-1)) / (PI*EXP(1)) */
d__1 = (doublereal) (r1mach_(&c__3) * .1f);
d__2 = (doublereal) (-1.f / ((nterm << 1) - 1));
bound = nterm * .1171f * pow_dd(&d__1, &d__2);
dxrel = sqrt(r1mach_(&c__4));
/* Computing MAX */
r__1 = log(r1mach_(&c__1)), r__2 = -log(r1mach_(&c__2));
rmin = exp(dmax(r__1,r__2) + .011f);
rbig = 1.f / r1mach_(&c__3);
}
first = FALSE_;
z__.r = zin->r, z__.i = zin->i;
x = z__.r;
y = r_imag(&z__);
if (y < 0.f) {
r_cnjg(&q__1, &z__);
z__.r = q__1.r, z__.i = q__1.i;
}
corr.r = 0.f, corr.i = 0.f;
cabsz = c_abs(&z__);
if (x >= 0.f && cabsz > bound) {
goto L50;
}
if (x < 0.f && dabs(y) > bound) {
goto L50;
}
if (cabsz < bound) {
goto L20;
}
/* USE THE REFLECTION FORMULA FOR REAL(Z) NEGATIVE, ABS(Z) LARGE, AND */
/* ABS(AIMAG(Y)) SMALL. */
r__1 = -pi;
q__3.r = pi * z__.r, q__3.i = pi * z__.i;
ccot_(&q__2, &q__3);
q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
corr.r = q__1.r, corr.i = q__1.i;
q__1.r = 1.f - z__.r, q__1.i = -z__.i;
z__.r = q__1.r, z__.i = q__1.i;
goto L50;
/* USE THE RECURSION RELATION FOR ABS(Z) SMALL. */
L20:
if (cabsz < rmin) {
xermsg_("SLATEC", "CPSI", "CPSI CALLED WITH Z SO NEAR 0 THAT CPSI OV"
"ERFLOWS", &c__2, &c__2, (ftnlen)6, (ftnlen)4, (ftnlen)48);
}
if (x >= -.5f || dabs(y) > dxrel) {
goto L30;
}
r__2 = x - .5f;
r__1 = r_int(&r__2);
q__2.r = z__.r - r__1, q__2.i = z__.i;
q__1.r = q__2.r / x, q__1.i = q__2.i / x;
if (c_abs(&q__1) < dxrel) {
xermsg_("SLATEC", "CPSI", "ANSWER LT HALF PRECISION BECAUSE Z TOO NE"
"AR NEGATIVE INTEGER", &c__1, &c__1, (ftnlen)6, (ftnlen)4, (
ftnlen)60);
}
if (y == 0.f && x == r_int(&x)) {
xermsg_("SLATEC", "CPSI", "Z IS A NEGATIVE INTEGER", &c__3, &c__2, (
ftnlen)6, (ftnlen)4, (ftnlen)23);
}
L30:
/* Computing 2nd power */
r__1 = bound;
/* Computing 2nd power */
r__2 = y;
n = sqrt(r__1 * r__1 - r__2 * r__2) - x + 1.f;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
c_div(&q__2, &c_b28, &z__);
q__1.r = corr.r - q__2.r, q__1.i = corr.i - q__2.i;
corr.r = q__1.r, corr.i = q__1.i;
q__1.r = z__.r + 1.f, q__1.i = z__.i;
z__.r = q__1.r, z__.i = q__1.i;
/* L40: */
}
/* NOW EVALUATE THE ASYMPTOTIC SERIES FOR SUITABLY LARGE Z. */
L50:
if (cabsz > rbig) {
c_log(&q__2, &z__);
q__1.r = q__2.r + corr.r, q__1.i = q__2.i + corr.i;
ret_val->r = q__1.r, ret_val->i = q__1.i;
}
if (cabsz > rbig) {
goto L70;
}
ret_val->r = 0.f, ret_val->i = 0.f;
pow_ci(&q__2, &z__, &c__2);
c_div(&q__1, &c_b28, &q__2);
z2inv.r = q__1.r, z2inv.i = q__1.i;
i__1 = nterm;
for (i__ = 1; i__ <= i__1; ++i__) {
ndx = nterm + 1 - i__;
i__2 = ndx - 1;
q__2.r = z2inv.r * ret_val->r - z2inv.i * ret_val->i, q__2.i =
z2inv.r * ret_val->i + z2inv.i * ret_val->r;
q__1.r = bern[i__2] + q__2.r, q__1.i = q__2.i;
ret_val->r = q__1.r, ret_val->i = q__1.i;
/* L60: */
}
c_log(&q__4, &z__);
c_div(&q__5, &c_b34, &z__);
q__3.r = q__4.r - q__5.r, q__3.i = q__4.i - q__5.i;
q__6.r = ret_val->r * z2inv.r - ret_val->i * z2inv.i, q__6.i =
ret_val->r * z2inv.i + ret_val->i * z2inv.r;
q__2.r = q__3.r - q__6.r, q__2.i = q__3.i - q__6.i;
q__1.r = q__2.r + corr.r, q__1.i = q__2.i + corr.i;
ret_val->r = q__1.r, ret_val->i = q__1.i;
L70:
if (y < 0.f) {
r_cnjg(&q__1, ret_val);
ret_val->r = q__1.r, ret_val->i = q__1.i;
}
return ;
} /* cpsi_ */
/* Subroutine */ int clahqr_(logical *wantt, logical *wantz, integer *n,
integer *ilo, integer *ihi, complex *h__, integer *ldh, complex *w,
integer *iloz, integer *ihiz, complex *z__, integer *ldz, integer *
info)
{
/* System generated locals */
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
real r__1, r__2, r__3, r__4, r__5, r__6;
complex q__1, q__2, q__3, q__4, q__5, q__6, q__7;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
double c_abs(complex *);
void c_sqrt(complex *, complex *), pow_ci(complex *, complex *, integer *)
;
/* Local variables */
integer i__, j, k, l, m;
real s;
complex t, u, v[2], x, y;
integer i1, i2;
complex t1;
real t2;
complex v2;
real aa, ab, ba, bb, h10;
complex h11;
real h21;
complex h22, sc;
integer nh, nz;
real sx;
integer jhi;
complex h11s;
integer jlo, its;
real ulp;
complex sum;
real tst;
complex temp;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *), ccopy_(integer *, complex *, integer *, complex *,
integer *);
real rtemp;
extern /* Subroutine */ int slabad_(real *, real *), clarfg_(integer *,
complex *, complex *, integer *, complex *);
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
extern doublereal slamch_(char *);
real safmin, safmax, smlnum;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLAHQR is an auxiliary routine called by CHSEQR to update the */
/* eigenvalues and Schur decomposition already computed by CHSEQR, by */
/* dealing with the Hessenberg submatrix in rows and columns ILO to */
/* IHI. */
/* Arguments */
/* ========= */
/* WANTT (input) LOGICAL */
/* = .TRUE. : the full Schur form T is required; */
/* = .FALSE.: only eigenvalues are required. */
/* WANTZ (input) LOGICAL */
/* = .TRUE. : the matrix of Schur vectors Z is required; */
/* = .FALSE.: Schur vectors are not required. */
/* N (input) INTEGER */
/* The order of the matrix H. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* It is assumed that H is already upper triangular in rows and */
/* columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1). */
/* CLAHQR works primarily with the Hessenberg submatrix in rows */
/* and columns ILO to IHI, but applies transformations to all of */
/* H if WANTT is .TRUE.. */
/* 1 <= ILO <= max(1,IHI); IHI <= N. */
/* H (input/output) COMPLEX array, dimension (LDH,N) */
/* On entry, the upper Hessenberg matrix H. */
/* On exit, if INFO is zero and if WANTT is .TRUE., then H */
/* is upper triangular in rows and columns ILO:IHI. If INFO */
/* is zero and if WANTT is .FALSE., then the contents of H */
/* are unspecified on exit. The output state of H in case */
/* INF is positive is below under the description of INFO. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH >= max(1,N). */
/* W (output) COMPLEX array, dimension (N) */
/* The computed eigenvalues ILO to IHI are stored in the */
/* corresponding elements of W. If WANTT is .TRUE., the */
/* eigenvalues are stored in the same order as on the diagonal */
/* of the Schur form returned in H, with W(i) = H(i,i). */
/* ILOZ (input) INTEGER */
/* IHIZ (input) INTEGER */
/* Specify the rows of Z to which transformations must be */
/* applied if WANTZ is .TRUE.. */
/* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. */
/* Z (input/output) COMPLEX array, dimension (LDZ,N) */
/* If WANTZ is .TRUE., on entry Z must contain the current */
/* matrix Z of transformations accumulated by CHSEQR, and on */
/* exit Z has been updated; transformations are applied only to */
/* the submatrix Z(ILOZ:IHIZ,ILO:IHI). */
/* If WANTZ is .FALSE., Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* .GT. 0: if INFO = i, CLAHQR failed to compute all the */
/* eigenvalues ILO to IHI in a total of 30 iterations */
/* per eigenvalue; elements i+1:ihi of W contain */
/* those eigenvalues which have been successfully */
/* computed. */
/* If INFO .GT. 0 and WANTT is .FALSE., then on exit, */
/* the remaining unconverged eigenvalues are the */
/* eigenvalues of the upper Hessenberg matrix */
/* rows and columns ILO thorugh INFO of the final, */
/* output value of H. */
/* If INFO .GT. 0 and WANTT is .TRUE., then on exit */
/* (*) (initial value of H)*U = U*(final value of H) */
/* where U is an orthognal matrix. The final */
/* value of H is upper Hessenberg and triangular in */
/* rows and columns INFO+1 through IHI. */
/* If INFO .GT. 0 and WANTZ is .TRUE., then on exit */
/* (final value of Z) = (initial value of Z)*U */
/* where U is the orthogonal matrix in (*) */
/* (regardless of the value of WANTT.) */
/* Further Details */
/* =============== */
/* 02-96 Based on modifications by */
/* David Day, Sandia National Laboratory, USA */
/* 12-04 Further modifications by */
/* Ralph Byers, University of Kansas, USA */
/* This is a modified version of CLAHQR from LAPACK version 3.0. */
/* It is (1) more robust against overflow and underflow and */
/* (2) adopts the more conservative Ahues & Tisseur stopping */
/* criterion (LAWN 122, 1997). */
/* ========================================================= */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*ilo == *ihi) {
i__1 = *ilo;
i__2 = *ilo + *ilo * h_dim1;
w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i;
return 0;
}
/* ==== clear out the trash ==== */
i__1 = *ihi - 3;
for (j = *ilo; j <= i__1; ++j) {
i__2 = j + 2 + j * h_dim1;
h__[i__2].r = 0.f, h__[i__2].i = 0.f;
i__2 = j + 3 + j * h_dim1;
h__[i__2].r = 0.f, h__[i__2].i = 0.f;
/* L10: */
}
if (*ilo <= *ihi - 2) {
i__1 = *ihi + (*ihi - 2) * h_dim1;
h__[i__1].r = 0.f, h__[i__1].i = 0.f;
}
/* ==== ensure that subdiagonal entries are real ==== */
if (*wantt) {
jlo = 1;
jhi = *n;
} else {
jlo = *ilo;
jhi = *ihi;
}
i__1 = *ihi;
for (i__ = *ilo + 1; i__ <= i__1; ++i__) {
if (r_imag(&h__[i__ + (i__ - 1) * h_dim1]) != 0.f) {
/* ==== The following redundant normalization */
/* . avoids problems with both gradual and */
/* . sudden underflow in ABS(H(I,I-1)) ==== */
i__2 = i__ + (i__ - 1) * h_dim1;
i__3 = i__ + (i__ - 1) * h_dim1;
r__3 = (r__1 = h__[i__3].r, dabs(r__1)) + (r__2 = r_imag(&h__[i__
+ (i__ - 1) * h_dim1]), dabs(r__2));
q__1.r = h__[i__2].r / r__3, q__1.i = h__[i__2].i / r__3;
sc.r = q__1.r, sc.i = q__1.i;
r_cnjg(&q__2, &sc);
r__1 = c_abs(&sc);
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
sc.r = q__1.r, sc.i = q__1.i;
i__2 = i__ + (i__ - 1) * h_dim1;
r__1 = c_abs(&h__[i__ + (i__ - 1) * h_dim1]);
h__[i__2].r = r__1, h__[i__2].i = 0.f;
i__2 = jhi - i__ + 1;
cscal_(&i__2, &sc, &h__[i__ + i__ * h_dim1], ldh);
/* Computing MIN */
i__3 = jhi, i__4 = i__ + 1;
i__2 = min(i__3,i__4) - jlo + 1;
r_cnjg(&q__1, &sc);
cscal_(&i__2, &q__1, &h__[jlo + i__ * h_dim1], &c__1);
if (*wantz) {
i__2 = *ihiz - *iloz + 1;
r_cnjg(&q__1, &sc);
cscal_(&i__2, &q__1, &z__[*iloz + i__ * z_dim1], &c__1);
}
}
/* L20: */
}
nh = *ihi - *ilo + 1;
nz = *ihiz - *iloz + 1;
/* Set machine-dependent constants for the stopping criterion. */
safmin = slamch_("SAFE MINIMUM");
safmax = 1.f / safmin;
slabad_(&safmin, &safmax);
ulp = slamch_("PRECISION");
smlnum = safmin * ((real) nh / ulp);
/* I1 and I2 are the indices of the first row and last column of H */
/* to which transformations must be applied. If eigenvalues only are */
/* being computed, I1 and I2 are set inside the main loop. */
if (*wantt) {
i1 = 1;
i2 = *n;
}
/* The main loop begins here. I is the loop index and decreases from */
/* IHI to ILO in steps of 1. Each iteration of the loop works */
/* with the active submatrix in rows and columns L to I. */
/* Eigenvalues I+1 to IHI have already converged. Either L = ILO, or */
/* H(L,L-1) is negligible so that the matrix splits. */
i__ = *ihi;
L30:
if (i__ < *ilo) {
goto L150;
}
/* Perform QR iterations on rows and columns ILO to I until a */
/* submatrix of order 1 splits off at the bottom because a */
/* subdiagonal element has become negligible. */
l = *ilo;
for (its = 0; its <= 30; ++its) {
/* Look for a single small subdiagonal element. */
i__1 = l + 1;
for (k = i__; k >= i__1; --k) {
i__2 = k + (k - 1) * h_dim1;
if ((r__1 = h__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&h__[k + (k
- 1) * h_dim1]), dabs(r__2)) <= smlnum) {
goto L50;
}
i__2 = k - 1 + (k - 1) * h_dim1;
i__3 = k + k * h_dim1;
tst = (r__1 = h__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&h__[k -
1 + (k - 1) * h_dim1]), dabs(r__2)) + ((r__3 = h__[i__3]
.r, dabs(r__3)) + (r__4 = r_imag(&h__[k + k * h_dim1]),
dabs(r__4)));
if (tst == 0.f) {
if (k - 2 >= *ilo) {
i__2 = k - 1 + (k - 2) * h_dim1;
tst += (r__1 = h__[i__2].r, dabs(r__1));
}
if (k + 1 <= *ihi) {
i__2 = k + 1 + k * h_dim1;
tst += (r__1 = h__[i__2].r, dabs(r__1));
}
}
/* ==== The following is a conservative small subdiagonal */
/* . deflation criterion due to Ahues & Tisseur (LAWN 122, */
/* . 1997). It has better mathematical foundation and */
/* . improves accuracy in some examples. ==== */
i__2 = k + (k - 1) * h_dim1;
if ((r__1 = h__[i__2].r, dabs(r__1)) <= ulp * tst) {
/* Computing MAX */
i__2 = k + (k - 1) * h_dim1;
i__3 = k - 1 + k * h_dim1;
r__5 = (r__1 = h__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&h__[
k + (k - 1) * h_dim1]), dabs(r__2)), r__6 = (r__3 =
h__[i__3].r, dabs(r__3)) + (r__4 = r_imag(&h__[k - 1
+ k * h_dim1]), dabs(r__4));
ab = dmax(r__5,r__6);
/* Computing MIN */
i__2 = k + (k - 1) * h_dim1;
i__3 = k - 1 + k * h_dim1;
r__5 = (r__1 = h__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&h__[
k + (k - 1) * h_dim1]), dabs(r__2)), r__6 = (r__3 =
h__[i__3].r, dabs(r__3)) + (r__4 = r_imag(&h__[k - 1
+ k * h_dim1]), dabs(r__4));
ba = dmin(r__5,r__6);
i__2 = k - 1 + (k - 1) * h_dim1;
i__3 = k + k * h_dim1;
q__2.r = h__[i__2].r - h__[i__3].r, q__2.i = h__[i__2].i -
h__[i__3].i;
q__1.r = q__2.r, q__1.i = q__2.i;
/* Computing MAX */
i__4 = k + k * h_dim1;
r__5 = (r__1 = h__[i__4].r, dabs(r__1)) + (r__2 = r_imag(&h__[
k + k * h_dim1]), dabs(r__2)), r__6 = (r__3 = q__1.r,
dabs(r__3)) + (r__4 = r_imag(&q__1), dabs(r__4));
aa = dmax(r__5,r__6);
i__2 = k - 1 + (k - 1) * h_dim1;
i__3 = k + k * h_dim1;
q__2.r = h__[i__2].r - h__[i__3].r, q__2.i = h__[i__2].i -
h__[i__3].i;
q__1.r = q__2.r, q__1.i = q__2.i;
/* Computing MIN */
i__4 = k + k * h_dim1;
r__5 = (r__1 = h__[i__4].r, dabs(r__1)) + (r__2 = r_imag(&h__[
k + k * h_dim1]), dabs(r__2)), r__6 = (r__3 = q__1.r,
dabs(r__3)) + (r__4 = r_imag(&q__1), dabs(r__4));
bb = dmin(r__5,r__6);
s = aa + ab;
/* Computing MAX */
r__1 = smlnum, r__2 = ulp * (bb * (aa / s));
if (ba * (ab / s) <= dmax(r__1,r__2)) {
goto L50;
}
}
/* L40: */
}
L50:
l = k;
if (l > *ilo) {
/* H(L,L-1) is negligible */
i__1 = l + (l - 1) * h_dim1;
h__[i__1].r = 0.f, h__[i__1].i = 0.f;
}
/* Exit from loop if a submatrix of order 1 has split off. */
if (l >= i__) {
goto L140;
}
/* Now the active submatrix is in rows and columns L to I. If */
/* eigenvalues only are being computed, only the active submatrix */
/* need be transformed. */
if (! (*wantt)) {
i1 = l;
i2 = i__;
}
if (its == 10) {
/* Exceptional shift. */
i__1 = l + 1 + l * h_dim1;
s = (r__1 = h__[i__1].r, dabs(r__1)) * .75f;
i__1 = l + l * h_dim1;
q__1.r = s + h__[i__1].r, q__1.i = h__[i__1].i;
t.r = q__1.r, t.i = q__1.i;
} else if (its == 20) {
/* Exceptional shift. */
i__1 = i__ + (i__ - 1) * h_dim1;
s = (r__1 = h__[i__1].r, dabs(r__1)) * .75f;
i__1 = i__ + i__ * h_dim1;
q__1.r = s + h__[i__1].r, q__1.i = h__[i__1].i;
t.r = q__1.r, t.i = q__1.i;
} else {
/* Wilkinson's shift. */
i__1 = i__ + i__ * h_dim1;
t.r = h__[i__1].r, t.i = h__[i__1].i;
c_sqrt(&q__2, &h__[i__ - 1 + i__ * h_dim1]);
c_sqrt(&q__3, &h__[i__ + (i__ - 1) * h_dim1]);
q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = q__2.r *
q__3.i + q__2.i * q__3.r;
u.r = q__1.r, u.i = q__1.i;
s = (r__1 = u.r, dabs(r__1)) + (r__2 = r_imag(&u), dabs(r__2));
if (s != 0.f) {
i__1 = i__ - 1 + (i__ - 1) * h_dim1;
q__2.r = h__[i__1].r - t.r, q__2.i = h__[i__1].i - t.i;
q__1.r = q__2.r * .5f, q__1.i = q__2.i * .5f;
x.r = q__1.r, x.i = q__1.i;
sx = (r__1 = x.r, dabs(r__1)) + (r__2 = r_imag(&x), dabs(r__2)
);
/* Computing MAX */
r__3 = s, r__4 = (r__1 = x.r, dabs(r__1)) + (r__2 = r_imag(&x)
, dabs(r__2));
s = dmax(r__3,r__4);
q__5.r = x.r / s, q__5.i = x.i / s;
pow_ci(&q__4, &q__5, &c__2);
q__7.r = u.r / s, q__7.i = u.i / s;
pow_ci(&q__6, &q__7, &c__2);
q__3.r = q__4.r + q__6.r, q__3.i = q__4.i + q__6.i;
c_sqrt(&q__2, &q__3);
q__1.r = s * q__2.r, q__1.i = s * q__2.i;
y.r = q__1.r, y.i = q__1.i;
if (sx > 0.f) {
q__1.r = x.r / sx, q__1.i = x.i / sx;
q__2.r = x.r / sx, q__2.i = x.i / sx;
if (q__1.r * y.r + r_imag(&q__2) * r_imag(&y) < 0.f) {
q__3.r = -y.r, q__3.i = -y.i;
y.r = q__3.r, y.i = q__3.i;
}
}
q__4.r = x.r + y.r, q__4.i = x.i + y.i;
cladiv_(&q__3, &u, &q__4);
q__2.r = u.r * q__3.r - u.i * q__3.i, q__2.i = u.r * q__3.i +
u.i * q__3.r;
q__1.r = t.r - q__2.r, q__1.i = t.i - q__2.i;
t.r = q__1.r, t.i = q__1.i;
}
}
/* Look for two consecutive small subdiagonal elements. */
i__1 = l + 1;
for (m = i__ - 1; m >= i__1; --m) {
/* Determine the effect of starting the single-shift QR */
/* iteration at row M, and see if this would make H(M,M-1) */
/* negligible. */
i__2 = m + m * h_dim1;
h11.r = h__[i__2].r, h11.i = h__[i__2].i;
i__2 = m + 1 + (m + 1) * h_dim1;
h22.r = h__[i__2].r, h22.i = h__[i__2].i;
q__1.r = h11.r - t.r, q__1.i = h11.i - t.i;
h11s.r = q__1.r, h11s.i = q__1.i;
i__2 = m + 1 + m * h_dim1;
h21 = h__[i__2].r;
s = (r__1 = h11s.r, dabs(r__1)) + (r__2 = r_imag(&h11s), dabs(
r__2)) + dabs(h21);
q__1.r = h11s.r / s, q__1.i = h11s.i / s;
h11s.r = q__1.r, h11s.i = q__1.i;
h21 /= s;
v[0].r = h11s.r, v[0].i = h11s.i;
v[1].r = h21, v[1].i = 0.f;
i__2 = m + (m - 1) * h_dim1;
h10 = h__[i__2].r;
if (dabs(h10) * dabs(h21) <= ulp * (((r__1 = h11s.r, dabs(r__1))
+ (r__2 = r_imag(&h11s), dabs(r__2))) * ((r__3 = h11.r,
dabs(r__3)) + (r__4 = r_imag(&h11), dabs(r__4)) + ((r__5 =
h22.r, dabs(r__5)) + (r__6 = r_imag(&h22), dabs(r__6)))))
) {
goto L70;
}
/* L60: */
}
i__1 = l + l * h_dim1;
h11.r = h__[i__1].r, h11.i = h__[i__1].i;
i__1 = l + 1 + (l + 1) * h_dim1;
h22.r = h__[i__1].r, h22.i = h__[i__1].i;
q__1.r = h11.r - t.r, q__1.i = h11.i - t.i;
h11s.r = q__1.r, h11s.i = q__1.i;
i__1 = l + 1 + l * h_dim1;
h21 = h__[i__1].r;
s = (r__1 = h11s.r, dabs(r__1)) + (r__2 = r_imag(&h11s), dabs(r__2))
+ dabs(h21);
q__1.r = h11s.r / s, q__1.i = h11s.i / s;
h11s.r = q__1.r, h11s.i = q__1.i;
h21 /= s;
v[0].r = h11s.r, v[0].i = h11s.i;
v[1].r = h21, v[1].i = 0.f;
L70:
/* Single-shift QR step */
i__1 = i__ - 1;
for (k = m; k <= i__1; ++k) {
/* The first iteration of this loop determines a reflection G */
/* from the vector V and applies it from left and right to H, */
/* thus creating a nonzero bulge below the subdiagonal. */
/* Each subsequent iteration determines a reflection G to */
/* restore the Hessenberg form in the (K-1)th column, and thus */
/* chases the bulge one step toward the bottom of the active */
/* submatrix. */
/* V(2) is always real before the call to CLARFG, and hence */
/* after the call T2 ( = T1*V(2) ) is also real. */
if (k > m) {
ccopy_(&c__2, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1);
}
clarfg_(&c__2, v, &v[1], &c__1, &t1);
if (k > m) {
i__2 = k + (k - 1) * h_dim1;
h__[i__2].r = v[0].r, h__[i__2].i = v[0].i;
i__2 = k + 1 + (k - 1) * h_dim1;
h__[i__2].r = 0.f, h__[i__2].i = 0.f;
}
v2.r = v[1].r, v2.i = v[1].i;
q__1.r = t1.r * v2.r - t1.i * v2.i, q__1.i = t1.r * v2.i + t1.i *
v2.r;
t2 = q__1.r;
/* Apply G from the left to transform the rows of the matrix */
/* in columns K to I2. */
i__2 = i2;
for (j = k; j <= i__2; ++j) {
r_cnjg(&q__3, &t1);
i__3 = k + j * h_dim1;
q__2.r = q__3.r * h__[i__3].r - q__3.i * h__[i__3].i, q__2.i =
q__3.r * h__[i__3].i + q__3.i * h__[i__3].r;
i__4 = k + 1 + j * h_dim1;
q__4.r = t2 * h__[i__4].r, q__4.i = t2 * h__[i__4].i;
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
sum.r = q__1.r, sum.i = q__1.i;
i__3 = k + j * h_dim1;
i__4 = k + j * h_dim1;
q__1.r = h__[i__4].r - sum.r, q__1.i = h__[i__4].i - sum.i;
h__[i__3].r = q__1.r, h__[i__3].i = q__1.i;
i__3 = k + 1 + j * h_dim1;
i__4 = k + 1 + j * h_dim1;
q__2.r = sum.r * v2.r - sum.i * v2.i, q__2.i = sum.r * v2.i +
sum.i * v2.r;
q__1.r = h__[i__4].r - q__2.r, q__1.i = h__[i__4].i - q__2.i;
h__[i__3].r = q__1.r, h__[i__3].i = q__1.i;
/* L80: */
}
/* Apply G from the right to transform the columns of the */
/* matrix in rows I1 to min(K+2,I). */
/* Computing MIN */
i__3 = k + 2;
i__2 = min(i__3,i__);
for (j = i1; j <= i__2; ++j) {
i__3 = j + k * h_dim1;
q__2.r = t1.r * h__[i__3].r - t1.i * h__[i__3].i, q__2.i =
t1.r * h__[i__3].i + t1.i * h__[i__3].r;
i__4 = j + (k + 1) * h_dim1;
q__3.r = t2 * h__[i__4].r, q__3.i = t2 * h__[i__4].i;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
sum.r = q__1.r, sum.i = q__1.i;
i__3 = j + k * h_dim1;
i__4 = j + k * h_dim1;
q__1.r = h__[i__4].r - sum.r, q__1.i = h__[i__4].i - sum.i;
h__[i__3].r = q__1.r, h__[i__3].i = q__1.i;
i__3 = j + (k + 1) * h_dim1;
i__4 = j + (k + 1) * h_dim1;
r_cnjg(&q__3, &v2);
q__2.r = sum.r * q__3.r - sum.i * q__3.i, q__2.i = sum.r *
q__3.i + sum.i * q__3.r;
q__1.r = h__[i__4].r - q__2.r, q__1.i = h__[i__4].i - q__2.i;
h__[i__3].r = q__1.r, h__[i__3].i = q__1.i;
/* L90: */
}
if (*wantz) {
/* Accumulate transformations in the matrix Z */
i__2 = *ihiz;
for (j = *iloz; j <= i__2; ++j) {
i__3 = j + k * z_dim1;
q__2.r = t1.r * z__[i__3].r - t1.i * z__[i__3].i, q__2.i =
t1.r * z__[i__3].i + t1.i * z__[i__3].r;
i__4 = j + (k + 1) * z_dim1;
q__3.r = t2 * z__[i__4].r, q__3.i = t2 * z__[i__4].i;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
sum.r = q__1.r, sum.i = q__1.i;
i__3 = j + k * z_dim1;
i__4 = j + k * z_dim1;
q__1.r = z__[i__4].r - sum.r, q__1.i = z__[i__4].i -
sum.i;
z__[i__3].r = q__1.r, z__[i__3].i = q__1.i;
i__3 = j + (k + 1) * z_dim1;
i__4 = j + (k + 1) * z_dim1;
r_cnjg(&q__3, &v2);
q__2.r = sum.r * q__3.r - sum.i * q__3.i, q__2.i = sum.r *
q__3.i + sum.i * q__3.r;
q__1.r = z__[i__4].r - q__2.r, q__1.i = z__[i__4].i -
q__2.i;
z__[i__3].r = q__1.r, z__[i__3].i = q__1.i;
/* L100: */
}
}
if (k == m && m > l) {
/* If the QR step was started at row M > L because two */
/* consecutive small subdiagonals were found, then extra */
/* scaling must be performed to ensure that H(M,M-1) remains */
/* real. */
q__1.r = 1.f - t1.r, q__1.i = 0.f - t1.i;
temp.r = q__1.r, temp.i = q__1.i;
r__1 = c_abs(&temp);
q__1.r = temp.r / r__1, q__1.i = temp.i / r__1;
temp.r = q__1.r, temp.i = q__1.i;
i__2 = m + 1 + m * h_dim1;
i__3 = m + 1 + m * h_dim1;
r_cnjg(&q__2, &temp);
q__1.r = h__[i__3].r * q__2.r - h__[i__3].i * q__2.i, q__1.i =
h__[i__3].r * q__2.i + h__[i__3].i * q__2.r;
h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
if (m + 2 <= i__) {
i__2 = m + 2 + (m + 1) * h_dim1;
i__3 = m + 2 + (m + 1) * h_dim1;
q__1.r = h__[i__3].r * temp.r - h__[i__3].i * temp.i,
q__1.i = h__[i__3].r * temp.i + h__[i__3].i *
temp.r;
h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
}
i__2 = i__;
for (j = m; j <= i__2; ++j) {
if (j != m + 1) {
if (i2 > j) {
i__3 = i2 - j;
cscal_(&i__3, &temp, &h__[j + (j + 1) * h_dim1],
ldh);
}
i__3 = j - i1;
r_cnjg(&q__1, &temp);
cscal_(&i__3, &q__1, &h__[i1 + j * h_dim1], &c__1);
if (*wantz) {
r_cnjg(&q__1, &temp);
cscal_(&nz, &q__1, &z__[*iloz + j * z_dim1], &
c__1);
}
}
/* L110: */
}
}
/* L120: */
}
/* Ensure that H(I,I-1) is real. */
i__1 = i__ + (i__ - 1) * h_dim1;
temp.r = h__[i__1].r, temp.i = h__[i__1].i;
if (r_imag(&temp) != 0.f) {
rtemp = c_abs(&temp);
i__1 = i__ + (i__ - 1) * h_dim1;
h__[i__1].r = rtemp, h__[i__1].i = 0.f;
q__1.r = temp.r / rtemp, q__1.i = temp.i / rtemp;
temp.r = q__1.r, temp.i = q__1.i;
if (i2 > i__) {
i__1 = i2 - i__;
r_cnjg(&q__1, &temp);
cscal_(&i__1, &q__1, &h__[i__ + (i__ + 1) * h_dim1], ldh);
}
i__1 = i__ - i1;
cscal_(&i__1, &temp, &h__[i1 + i__ * h_dim1], &c__1);
if (*wantz) {
cscal_(&nz, &temp, &z__[*iloz + i__ * z_dim1], &c__1);
}
}
/* L130: */
}
/* Failure to converge in remaining number of iterations */
*info = i__;
return 0;
L140:
/* H(I,I-1) is negligible: one eigenvalue has converged. */
i__1 = i__;
i__2 = i__ + i__ * h_dim1;
w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i;
/* return to start of the main loop with new value of I. */
i__ = l - 1;
goto L30;
L150:
return 0;
/* End of CLAHQR */
} /* clahqr_ */
/* DECK PPADD */
/* Subroutine */ int ppadd_(integer *n, integer *ierror, real *a, real *c__,
complex *cbp, real *bp, real *bh)
{
/* System generated locals */
integer i__1, i__2, i__3;
real r__1;
complex q__1, q__2, q__3, q__4, q__5;
/* Local variables */
static complex f;
static integer j, i3;
static complex r1, r2, r3;
static real db;
static complex dd;
static integer if__, ig;
static complex fp, cx;
static integer is, it, nt, iz;
static real xl, xm, xr;
static complex fsg, hsg;
static integer icv;
static complex fpp;
static real sgn, psg;
static complex cdis;
extern doublereal bsrh_(real *, real *, integer *, real *, real *, real *,
E_fp, real *), psgf_(real *, integer *, real *, real *, real *);
static real scnv;
static integer nhalf;
extern doublereal ppsgf_(real *, integer *, real *, real *, real *);
static integer modiz;
extern /* Subroutine */ int ppspf_();
/* ***BEGIN PROLOGUE PPADD */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to BLKTRI */
/* ***LIBRARY SLATEC */
/* ***TYPE SINGLE PRECISION (PPADD-S) */
/* ***AUTHOR (UNKNOWN) */
/* ***DESCRIPTION */
/* PPADD computes the eigenvalues of the periodic tridiagonal matrix */
/* with coefficients AN,BN,CN. */
/* N is the order of the BH and BP polynomials. */
/* BP contains the eigenvalues on output. */
/* CBP is the same as BP except type complex. */
/* BH is used to temporarily store the roots of the B HAT polynomial */
/* which enters through BP. */
/* ***SEE ALSO BLKTRI */
/* ***ROUTINES CALLED BSRH, PPSGF, PPSPF, PSGF */
/* ***COMMON BLOCKS CBLKT */
/* ***REVISION HISTORY (YYMMDD) */
/* 801001 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900402 Added TYPE section. (WRB) */
/* ***END PROLOGUE PPADD */
/* ***FIRST EXECUTABLE STATEMENT PPADD */
/* Parameter adjustments */
--bh;
--bp;
--cbp;
--c__;
--a;
/* Function Body */
scnv = sqrt(cblkt_1.cnv);
iz = *n;
if ((r__1 = bp[*n] - bp[1]) < 0.f) {
goto L101;
} else if (r__1 == 0) {
goto L142;
} else {
goto L103;
}
L101:
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
nt = *n - j;
bh[j] = bp[nt + 1];
/* L102: */
}
goto L105;
L103:
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
bh[j] = bp[j];
/* L104: */
}
L105:
cblkt_1.ncmplx = 0;
modiz = iz % 2;
is = 1;
if (modiz != 0) {
goto L106;
} else {
goto L107;
}
L106:
if (a[1] < 0.f) {
goto L110;
} else if (a[1] == 0) {
goto L142;
} else {
goto L107;
}
L107:
xl = bh[1];
db = bh[3] - bh[1];
L108:
xl -= db;
if (psgf_(&xl, &iz, &c__[1], &a[1], &bh[1]) <= 0.f) {
goto L108;
} else {
goto L109;
}
L109:
sgn = -1.f;
r__1 = bsrh_(&xl, &bh[1], &iz, &c__[1], &a[1], &bh[1], (E_fp)psgf_, &sgn);
q__1.r = r__1, q__1.i = 0.f;
cbp[1].r = q__1.r, cbp[1].i = q__1.i;
is = 2;
L110:
if__ = iz - 1;
if (modiz != 0) {
goto L111;
} else {
goto L112;
}
L111:
if (a[1] < 0.f) {
goto L112;
} else if (a[1] == 0) {
goto L142;
} else {
goto L115;
}
L112:
xr = bh[iz];
db = bh[iz] - bh[iz - 2];
L113:
xr += db;
if (psgf_(&xr, &iz, &c__[1], &a[1], &bh[1]) >= 0.f) {
goto L114;
} else {
goto L113;
}
L114:
sgn = 1.f;
i__1 = iz;
r__1 = bsrh_(&bh[iz], &xr, &iz, &c__[1], &a[1], &bh[1], (E_fp)psgf_, &sgn)
;
q__1.r = r__1, q__1.i = 0.f;
cbp[i__1].r = q__1.r, cbp[i__1].i = q__1.i;
if__ = iz - 2;
L115:
i__1 = if__;
for (ig = is; ig <= i__1; ig += 2) {
xl = bh[ig];
xr = bh[ig + 1];
sgn = -1.f;
xm = bsrh_(&xl, &xr, &iz, &c__[1], &a[1], &bh[1], (E_fp)ppspf_, &sgn);
psg = psgf_(&xm, &iz, &c__[1], &a[1], &bh[1]);
if (dabs(psg) - cblkt_1.eps <= 0.f) {
goto L118;
} else {
goto L116;
}
L116:
if ((r__1 = psg * ppsgf_(&xm, &iz, &c__[1], &a[1], &bh[1])) < 0.f) {
goto L117;
} else if (r__1 == 0) {
goto L118;
} else {
goto L119;
}
/* CASE OF A REAL ZERO */
L117:
sgn = 1.f;
i__2 = ig;
r__1 = bsrh_(&bh[ig], &xm, &iz, &c__[1], &a[1], &bh[1], (E_fp)psgf_, &
sgn);
q__1.r = r__1, q__1.i = 0.f;
cbp[i__2].r = q__1.r, cbp[i__2].i = q__1.i;
sgn = -1.f;
i__2 = ig + 1;
r__1 = bsrh_(&xm, &bh[ig + 1], &iz, &c__[1], &a[1], &bh[1], (E_fp)
psgf_, &sgn);
q__1.r = r__1, q__1.i = 0.f;
cbp[i__2].r = q__1.r, cbp[i__2].i = q__1.i;
goto L136;
/* CASE OF A MULTIPLE ZERO */
L118:
i__2 = ig;
q__1.r = xm, q__1.i = 0.f;
cbp[i__2].r = q__1.r, cbp[i__2].i = q__1.i;
i__2 = ig + 1;
q__1.r = xm, q__1.i = 0.f;
cbp[i__2].r = q__1.r, cbp[i__2].i = q__1.i;
goto L136;
/* CASE OF A COMPLEX ZERO */
L119:
it = 0;
icv = 0;
q__1.r = xm, q__1.i = 0.f;
cx.r = q__1.r, cx.i = q__1.i;
L120:
fsg.r = 1.f, fsg.i = 0.f;
hsg.r = 1.f, hsg.i = 0.f;
fp.r = 0.f, fp.i = 0.f;
fpp.r = 0.f, fpp.i = 0.f;
i__2 = iz;
for (j = 1; j <= i__2; ++j) {
i__3 = j;
q__2.r = cx.r - bh[i__3], q__2.i = cx.i;
c_div(&q__1, &c_b24, &q__2);
dd.r = q__1.r, dd.i = q__1.i;
i__3 = j;
q__2.r = a[i__3] * fsg.r, q__2.i = a[i__3] * fsg.i;
q__1.r = q__2.r * dd.r - q__2.i * dd.i, q__1.i = q__2.r * dd.i +
q__2.i * dd.r;
fsg.r = q__1.r, fsg.i = q__1.i;
i__3 = j;
q__2.r = c__[i__3] * hsg.r, q__2.i = c__[i__3] * hsg.i;
q__1.r = q__2.r * dd.r - q__2.i * dd.i, q__1.i = q__2.r * dd.i +
q__2.i * dd.r;
hsg.r = q__1.r, hsg.i = q__1.i;
q__1.r = fp.r + dd.r, q__1.i = fp.i + dd.i;
fp.r = q__1.r, fp.i = q__1.i;
q__2.r = dd.r * dd.r - dd.i * dd.i, q__2.i = dd.r * dd.i + dd.i *
dd.r;
q__1.r = fpp.r - q__2.r, q__1.i = fpp.i - q__2.i;
fpp.r = q__1.r, fpp.i = q__1.i;
/* L121: */
}
if (modiz != 0) {
goto L123;
} else {
goto L122;
}
L122:
q__2.r = 1.f - fsg.r, q__2.i = 0.f - fsg.i;
q__1.r = q__2.r - hsg.r, q__1.i = q__2.i - hsg.i;
f.r = q__1.r, f.i = q__1.i;
goto L124;
L123:
q__2.r = fsg.r + 1.f, q__2.i = fsg.i + 0.f;
q__1.r = q__2.r + hsg.r, q__1.i = q__2.i + hsg.i;
f.r = q__1.r, f.i = q__1.i;
L124:
i3 = 0;
if (c_abs(&fp) <= 0.f) {
goto L126;
} else {
goto L125;
}
L125:
i3 = 1;
q__2.r = -f.r, q__2.i = -f.i;
c_div(&q__1, &q__2, &fp);
r3.r = q__1.r, r3.i = q__1.i;
L126:
if (c_abs(&fpp) <= 0.f) {
goto L132;
} else {
goto L127;
}
L127:
pow_ci(&q__3, &fp, &c__2);
q__5.r = f.r * 2.f, q__5.i = f.i * 2.f;
q__4.r = q__5.r * fpp.r - q__5.i * fpp.i, q__4.i = q__5.r * fpp.i +
q__5.i * fpp.r;
q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i;
c_sqrt(&q__1, &q__2);
cdis.r = q__1.r, cdis.i = q__1.i;
q__1.r = cdis.r - fp.r, q__1.i = cdis.i - fp.i;
r1.r = q__1.r, r1.i = q__1.i;
q__2.r = -fp.r, q__2.i = -fp.i;
q__1.r = q__2.r - cdis.r, q__1.i = q__2.i - cdis.i;
r2.r = q__1.r, r2.i = q__1.i;
if (c_abs(&r1) - c_abs(&r2) <= 0.f) {
goto L129;
} else {
goto L128;
}
L128:
c_div(&q__1, &r1, &fpp);
r1.r = q__1.r, r1.i = q__1.i;
goto L130;
L129:
c_div(&q__1, &r2, &fpp);
r1.r = q__1.r, r1.i = q__1.i;
L130:
q__3.r = f.r * 2.f, q__3.i = f.i * 2.f;
c_div(&q__2, &q__3, &fpp);
c_div(&q__1, &q__2, &r1);
r2.r = q__1.r, r2.i = q__1.i;
if (c_abs(&r2) < c_abs(&r1)) {
r1.r = r2.r, r1.i = r2.i;
}
if (i3 <= 0) {
goto L133;
} else {
goto L131;
}
L131:
if (c_abs(&r3) < c_abs(&r1)) {
r1.r = r3.r, r1.i = r3.i;
}
goto L133;
L132:
r1.r = r3.r, r1.i = r3.i;
L133:
q__1.r = cx.r + r1.r, q__1.i = cx.i + r1.i;
cx.r = q__1.r, cx.i = q__1.i;
++it;
if (it > 50) {
goto L142;
}
if (c_abs(&r1) > scnv) {
goto L120;
}
if (icv <= 0) {
goto L134;
} else {
goto L135;
}
L134:
icv = 1;
goto L120;
L135:
i__2 = ig;
cbp[i__2].r = cx.r, cbp[i__2].i = cx.i;
i__2 = ig + 1;
r_cnjg(&q__1, &cx);
cbp[i__2].r = q__1.r, cbp[i__2].i = q__1.i;
L136:
;
}
if ((r__1 = c_abs(&cbp[*n]) - c_abs(&cbp[1])) < 0.f) {
goto L137;
} else if (r__1 == 0) {
goto L142;
} else {
goto L139;
}
L137:
nhalf = *n / 2;
i__1 = nhalf;
for (j = 1; j <= i__1; ++j) {
nt = *n - j;
i__2 = j;
cx.r = cbp[i__2].r, cx.i = cbp[i__2].i;
i__2 = j;
i__3 = nt + 1;
cbp[i__2].r = cbp[i__3].r, cbp[i__2].i = cbp[i__3].i;
i__2 = nt + 1;
cbp[i__2].r = cx.r, cbp[i__2].i = cx.i;
/* L138: */
}
L139:
cblkt_1.ncmplx = 1;
i__1 = iz;
for (j = 2; j <= i__1; ++j) {
if (r_imag(&cbp[j]) != 0.f) {
goto L143;
} else {
goto L140;
}
L140:
;
}
cblkt_1.ncmplx = 0;
i__1 = iz;
for (j = 2; j <= i__1; ++j) {
i__2 = j;
bp[j] = cbp[i__2].r;
/* L141: */
}
goto L143;
L142:
*ierror = 4;
L143:
return 0;
} /* ppadd_ */