static Py_complex
c_asinh(Py_complex x)
{
Py_complex z;
z = c_sqrt(c_half);
z = c_log(c_prod(z, c_sum(c_sqrt(c_sum(x, c_i)),
c_sqrt(c_diff(x, c_i)))));
return c_sum(z, z);
}
inline
complex< T > cx_sqrt(const complex< T >& c)
{
if (c.im == 0)
{
return c_sqrt(c.re);
}
complex< T > com;
short sgn = (c.im < 0 ? -1 : (c.im > 0 ? 1 : 0));
if ( same_type< T, double >::value )
{
com.re = sqrt(( c.re + sqrt(c.re * c.re + c.im * c.im)) / 2.) ;
com.im = sgn * sqrt((-c.re + sqrt(c.re * c.re + c.im * c.im)) / 2.) ;
}
else if ( same_type< T, float >::value )
{
com.re = sqrtf(( c.re + sqrtf(c.re * c.re + c.im * c.im)) / 2.);
com.im = sgn * sqrtf((-c.re + sqrtf(c.re * c.re + c.im * c.im)) / 2.);
}
else if ( same_type< T, long double >::value )
{
com.re = sqrtl(( c.re + sqrtl(c.re * c.re + c.im * c.im)) / 2.);
com.im = sgn * sqrtl((-c.re + sqrtl(c.re * c.re + c.im * c.im)) / 2.);
}
else
{
com.re = static_cast< T >(sqrt(static_cast< double >(c.re + sqrt(static_cast< double >(c.re * c.re + c.im * c.im))) / 2));
com.im = static_cast< T >(sgn * sqrt(static_cast< double >(-c.re + sqrt(c.re * c.re + c.im * c.im)) / 2));
}
return com;
}
void paint_julia_prev(infoptr pic, point mouse_pos)
{
struct picture_info prev_pic;
dpoint p, tmp;
int n = 0;
prev_pic.area = get_prev_rect(pic);
init_coords(&prev_pic); /* Asetetaan sopiva skaalaus */
/* Julia-vakio hiiren koordinaateista */
prev_pic.julia_c = to_dpoint(mouse_pos, pic);
SRGP_setClipRectangle(prev_pic.area);
SRGP_setColor(SRGP_BLACK); /* Peitetään vanha kuva */
SRGP_fillRectangleCoord(prev_pic.area.bottom_left.x + 1,
prev_pic.area.bottom_left.y + 1,
prev_pic.area.top_right.x - 1,
prev_pic.area.top_right.y - 1);
SRGP_setColor(SRGP_WHITE); /* Valkea reunus */
SRGP_rectangle(prev_pic.area);
p.x = 0; /* Inverse functionin */
p.y = 0; /* alkupiste */
while(n < JULIA_LIMIT)
{ /* z[n+1] = sqrt(z[n] - c) */
tmp.x = p.x - prev_pic.julia_c.x;
tmp.y = p.y - prev_pic.julia_c.y;
p = c_sqrt(tmp);
SRGP_point(to_point(p, &prev_pic));
n++;
}
SRGP_setClipRectangle(pic->area);
}
/* Function Definitions */
real_T b_sqrt(const emlrtStack *sp, real_T x)
{
real_T b_x;
b_x = x;
c_sqrt(sp, &b_x);
return b_x;
}
static Py_complex
c_asin(Py_complex x)
{
/* -i * log[(sqrt(1-x**2) + i*x] */
const Py_complex squared = c_prod(x, x);
const Py_complex sqrt_1_minus_x_sq = c_sqrt(c_diff(c_one, squared));
return c_neg(c_prodi(c_log(
c_sum(sqrt_1_minus_x_sq, c_prodi(x))
) ) );
}
/* 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_ */
static Py_complex
c_acos(Py_complex x)
{
return c_neg(c_prodi(c_log(c_sum(x,c_prod(c_i,
c_sqrt(c_diff(c_one,c_prod(x,x))))))));
}
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 claic1_(integer *job, integer *j, complex *x, real *sest,
complex *w, complex *gamma, real *sestpr, complex *s, complex *c__)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
CLAIC1 applies one step of incremental condition estimation in
its simplest version:
Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j
lower triangular matrix L, such that
twonorm(L*x) = sest
Then CLAIC1 computes sestpr, s, c such that
the vector
[ s*x ]
xhat = [ c ]
is an approximate singular vector of
[ L 0 ]
Lhat = [ w' gamma ]
in the sense that
twonorm(Lhat*xhat) = sestpr.
Depending on JOB, an estimate for the largest or smallest singular
value is computed.
Note that [s c]' and sestpr**2 is an eigenpair of the system
diag(sest*sest, 0) + [alpha gamma] * [ conjg(alpha) ]
[ conjg(gamma) ]
where alpha = conjg(x)'*w.
Arguments
=========
JOB (input) INTEGER
= 1: an estimate for the largest singular value is computed.
= 2: an estimate for the smallest singular value is computed.
J (input) INTEGER
Length of X and W
X (input) COMPLEX array, dimension (J)
The j-vector x.
SEST (input) REAL
Estimated singular value of j by j matrix L
W (input) COMPLEX array, dimension (J)
The j-vector w.
GAMMA (input) COMPLEX
The diagonal element gamma.
SESTPR (output) REAL
Estimated singular value of (j+1) by (j+1) matrix Lhat.
S (output) COMPLEX
Sine needed in forming xhat.
C (output) COMPLEX
Cosine needed in forming xhat.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
real r__1, r__2;
complex q__1, q__2, q__3, q__4, q__5, q__6;
/* Builtin functions */
double c_abs(complex *);
void r_cnjg(complex *, complex *), c_sqrt(complex *, complex *);
double sqrt(doublereal);
void c_div(complex *, complex *, complex *);
/* Local variables */
static complex sine;
static real test, zeta1, zeta2, b, t;
static complex alpha;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
static real norma, s1, s2, absgam, absalp;
extern doublereal slamch_(char *);
static complex cosine;
static real absest, scl, eps, tmp;
--w;
--x;
/* Function Body */
eps = slamch_("Epsilon");
cdotc_(&q__1, j, &x[1], &c__1, &w[1], &c__1);
alpha.r = q__1.r, alpha.i = q__1.i;
absalp = c_abs(&alpha);
absgam = c_abs(gamma);
absest = dabs(*sest);
if (*job == 1) {
/* Estimating largest singular value
special cases */
if (*sest == 0.f) {
s1 = dmax(absgam,absalp);
if (s1 == 0.f) {
s->r = 0.f, s->i = 0.f;
c__->r = 1.f, c__->i = 0.f;
*sestpr = 0.f;
} else {
q__1.r = alpha.r / s1, q__1.i = alpha.i / s1;
s->r = q__1.r, s->i = q__1.i;
q__1.r = gamma->r / s1, q__1.i = gamma->i / s1;
c__->r = q__1.r, c__->i = q__1.i;
r_cnjg(&q__4, s);
q__3.r = s->r * q__4.r - s->i * q__4.i, q__3.i = s->r *
q__4.i + s->i * q__4.r;
r_cnjg(&q__6, c__);
q__5.r = c__->r * q__6.r - c__->i * q__6.i, q__5.i = c__->r *
q__6.i + c__->i * q__6.r;
q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
c_sqrt(&q__1, &q__2);
tmp = q__1.r;
q__1.r = s->r / tmp, q__1.i = s->i / tmp;
s->r = q__1.r, s->i = q__1.i;
q__1.r = c__->r / tmp, q__1.i = c__->i / tmp;
c__->r = q__1.r, c__->i = q__1.i;
*sestpr = s1 * tmp;
}
return 0;
} else if (absgam <= eps * absest) {
s->r = 1.f, s->i = 0.f;
c__->r = 0.f, c__->i = 0.f;
tmp = dmax(absest,absalp);
s1 = absest / tmp;
s2 = absalp / tmp;
*sestpr = tmp * sqrt(s1 * s1 + s2 * s2);
return 0;
} else if (absalp <= eps * absest) {
s1 = absgam;
s2 = absest;
if (s1 <= s2) {
s->r = 1.f, s->i = 0.f;
c__->r = 0.f, c__->i = 0.f;
*sestpr = s2;
} else {
s->r = 0.f, s->i = 0.f;
c__->r = 1.f, c__->i = 0.f;
*sestpr = s1;
}
return 0;
} else if (absest <= eps * absalp || absest <= eps * absgam) {
s1 = absgam;
s2 = absalp;
if (s1 <= s2) {
tmp = s1 / s2;
scl = sqrt(tmp * tmp + 1.f);
*sestpr = s2 * scl;
q__2.r = alpha.r / s2, q__2.i = alpha.i / s2;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
s->r = q__1.r, s->i = q__1.i;
q__2.r = gamma->r / s2, q__2.i = gamma->i / s2;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
c__->r = q__1.r, c__->i = q__1.i;
} else {
tmp = s2 / s1;
scl = sqrt(tmp * tmp + 1.f);
*sestpr = s1 * scl;
q__2.r = alpha.r / s1, q__2.i = alpha.i / s1;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
s->r = q__1.r, s->i = q__1.i;
q__2.r = gamma->r / s1, q__2.i = gamma->i / s1;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
c__->r = q__1.r, c__->i = q__1.i;
}
return 0;
} else {
/* normal case */
zeta1 = absalp / absest;
zeta2 = absgam / absest;
b = (1.f - zeta1 * zeta1 - zeta2 * zeta2) * .5f;
r__1 = zeta1 * zeta1;
c__->r = r__1, c__->i = 0.f;
if (b > 0.f) {
r__1 = b * b;
q__4.r = r__1 + c__->r, q__4.i = c__->i;
c_sqrt(&q__3, &q__4);
q__2.r = b + q__3.r, q__2.i = q__3.i;
c_div(&q__1, c__, &q__2);
t = q__1.r;
} else {
r__1 = b * b;
q__3.r = r__1 + c__->r, q__3.i = c__->i;
c_sqrt(&q__2, &q__3);
q__1.r = q__2.r - b, q__1.i = q__2.i;
t = q__1.r;
}
q__3.r = alpha.r / absest, q__3.i = alpha.i / absest;
q__2.r = -q__3.r, q__2.i = -q__3.i;
q__1.r = q__2.r / t, q__1.i = q__2.i / t;
sine.r = q__1.r, sine.i = q__1.i;
q__3.r = gamma->r / absest, q__3.i = gamma->i / absest;
q__2.r = -q__3.r, q__2.i = -q__3.i;
r__1 = t + 1.f;
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
cosine.r = q__1.r, cosine.i = q__1.i;
r_cnjg(&q__4, &sine);
q__3.r = sine.r * q__4.r - sine.i * q__4.i, q__3.i = sine.r *
q__4.i + sine.i * q__4.r;
r_cnjg(&q__6, &cosine);
q__5.r = cosine.r * q__6.r - cosine.i * q__6.i, q__5.i = cosine.r
* q__6.i + cosine.i * q__6.r;
q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
c_sqrt(&q__1, &q__2);
tmp = q__1.r;
q__1.r = sine.r / tmp, q__1.i = sine.i / tmp;
s->r = q__1.r, s->i = q__1.i;
q__1.r = cosine.r / tmp, q__1.i = cosine.i / tmp;
c__->r = q__1.r, c__->i = q__1.i;
*sestpr = sqrt(t + 1.f) * absest;
return 0;
}
} else if (*job == 2) {
/* Estimating smallest singular value
special cases */
if (*sest == 0.f) {
*sestpr = 0.f;
if (dmax(absgam,absalp) == 0.f) {
sine.r = 1.f, sine.i = 0.f;
cosine.r = 0.f, cosine.i = 0.f;
} else {
r_cnjg(&q__2, gamma);
q__1.r = -q__2.r, q__1.i = -q__2.i;
sine.r = q__1.r, sine.i = q__1.i;
r_cnjg(&q__1, &alpha);
cosine.r = q__1.r, cosine.i = q__1.i;
}
/* Computing MAX */
r__1 = c_abs(&sine), r__2 = c_abs(&cosine);
s1 = dmax(r__1,r__2);
q__1.r = sine.r / s1, q__1.i = sine.i / s1;
s->r = q__1.r, s->i = q__1.i;
q__1.r = cosine.r / s1, q__1.i = cosine.i / s1;
c__->r = q__1.r, c__->i = q__1.i;
r_cnjg(&q__4, s);
q__3.r = s->r * q__4.r - s->i * q__4.i, q__3.i = s->r * q__4.i +
s->i * q__4.r;
r_cnjg(&q__6, c__);
q__5.r = c__->r * q__6.r - c__->i * q__6.i, q__5.i = c__->r *
q__6.i + c__->i * q__6.r;
q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
c_sqrt(&q__1, &q__2);
tmp = q__1.r;
q__1.r = s->r / tmp, q__1.i = s->i / tmp;
s->r = q__1.r, s->i = q__1.i;
q__1.r = c__->r / tmp, q__1.i = c__->i / tmp;
c__->r = q__1.r, c__->i = q__1.i;
return 0;
} else if (absgam <= eps * absest) {
s->r = 0.f, s->i = 0.f;
c__->r = 1.f, c__->i = 0.f;
*sestpr = absgam;
return 0;
} else if (absalp <= eps * absest) {
s1 = absgam;
s2 = absest;
if (s1 <= s2) {
s->r = 0.f, s->i = 0.f;
c__->r = 1.f, c__->i = 0.f;
*sestpr = s1;
} else {
s->r = 1.f, s->i = 0.f;
c__->r = 0.f, c__->i = 0.f;
*sestpr = s2;
}
return 0;
} else if (absest <= eps * absalp || absest <= eps * absgam) {
s1 = absgam;
s2 = absalp;
if (s1 <= s2) {
tmp = s1 / s2;
scl = sqrt(tmp * tmp + 1.f);
*sestpr = absest * (tmp / scl);
r_cnjg(&q__4, gamma);
q__3.r = q__4.r / s2, q__3.i = q__4.i / s2;
q__2.r = -q__3.r, q__2.i = -q__3.i;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
s->r = q__1.r, s->i = q__1.i;
r_cnjg(&q__3, &alpha);
q__2.r = q__3.r / s2, q__2.i = q__3.i / s2;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
c__->r = q__1.r, c__->i = q__1.i;
} else {
tmp = s2 / s1;
scl = sqrt(tmp * tmp + 1.f);
*sestpr = absest / scl;
r_cnjg(&q__4, gamma);
q__3.r = q__4.r / s1, q__3.i = q__4.i / s1;
q__2.r = -q__3.r, q__2.i = -q__3.i;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
s->r = q__1.r, s->i = q__1.i;
r_cnjg(&q__3, &alpha);
q__2.r = q__3.r / s1, q__2.i = q__3.i / s1;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
c__->r = q__1.r, c__->i = q__1.i;
}
return 0;
} else {
/* normal case */
zeta1 = absalp / absest;
zeta2 = absgam / absest;
/* Computing MAX */
r__1 = zeta1 * zeta1 + 1.f + zeta1 * zeta2, r__2 = zeta1 * zeta2
+ zeta2 * zeta2;
norma = dmax(r__1,r__2);
/* See if root is closer to zero or to ONE */
test = (zeta1 - zeta2) * 2.f * (zeta1 + zeta2) + 1.f;
if (test >= 0.f) {
/* root is close to zero, compute directly */
b = (zeta1 * zeta1 + zeta2 * zeta2 + 1.f) * .5f;
r__1 = zeta2 * zeta2;
c__->r = r__1, c__->i = 0.f;
r__2 = b * b;
q__2.r = r__2 - c__->r, q__2.i = -c__->i;
r__1 = b + sqrt(c_abs(&q__2));
q__1.r = c__->r / r__1, q__1.i = c__->i / r__1;
t = q__1.r;
q__2.r = alpha.r / absest, q__2.i = alpha.i / absest;
r__1 = 1.f - t;
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
sine.r = q__1.r, sine.i = q__1.i;
q__3.r = gamma->r / absest, q__3.i = gamma->i / absest;
q__2.r = -q__3.r, q__2.i = -q__3.i;
q__1.r = q__2.r / t, q__1.i = q__2.i / t;
cosine.r = q__1.r, cosine.i = q__1.i;
*sestpr = sqrt(t + eps * 4.f * eps * norma) * absest;
} else {
/* root is closer to ONE, shift by that amount */
b = (zeta2 * zeta2 + zeta1 * zeta1 - 1.f) * .5f;
r__1 = zeta1 * zeta1;
c__->r = r__1, c__->i = 0.f;
if (b >= 0.f) {
q__2.r = -c__->r, q__2.i = -c__->i;
r__1 = b * b;
q__5.r = r__1 + c__->r, q__5.i = c__->i;
c_sqrt(&q__4, &q__5);
q__3.r = b + q__4.r, q__3.i = q__4.i;
c_div(&q__1, &q__2, &q__3);
t = q__1.r;
} else {
r__1 = b * b;
q__3.r = r__1 + c__->r, q__3.i = c__->i;
c_sqrt(&q__2, &q__3);
q__1.r = b - q__2.r, q__1.i = -q__2.i;
t = q__1.r;
}
q__3.r = alpha.r / absest, q__3.i = alpha.i / absest;
q__2.r = -q__3.r, q__2.i = -q__3.i;
q__1.r = q__2.r / t, q__1.i = q__2.i / t;
sine.r = q__1.r, sine.i = q__1.i;
q__3.r = gamma->r / absest, q__3.i = gamma->i / absest;
q__2.r = -q__3.r, q__2.i = -q__3.i;
r__1 = t + 1.f;
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
cosine.r = q__1.r, cosine.i = q__1.i;
*sestpr = sqrt(t + 1.f + eps * 4.f * eps * norma) * absest;
}
r_cnjg(&q__4, &sine);
q__3.r = sine.r * q__4.r - sine.i * q__4.i, q__3.i = sine.r *
q__4.i + sine.i * q__4.r;
r_cnjg(&q__6, &cosine);
q__5.r = cosine.r * q__6.r - cosine.i * q__6.i, q__5.i = cosine.r
* q__6.i + cosine.i * q__6.r;
q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
c_sqrt(&q__1, &q__2);
tmp = q__1.r;
q__1.r = sine.r / tmp, q__1.i = sine.i / tmp;
s->r = q__1.r, s->i = q__1.i;
q__1.r = cosine.r / tmp, q__1.i = cosine.i / tmp;
c__->r = q__1.r, c__->i = q__1.i;
return 0;
}
}
return 0;
/* End of CLAIC1 */
} /* claic1_ */
/* DECK CAIRY */
/* Subroutine */ int cairy_(complex *z__, integer *id, integer *kode, complex
*ai, integer *nz, integer *ierr)
{
/* Initialized data */
static real tth = .666666666666666667f;
static real c1 = .35502805388781724f;
static real c2 = .258819403792806799f;
static real coef = .183776298473930683f;
static complex cone = {1.f,0.f};
/* 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 k;
static real d1, d2;
static integer k1, k2;
static complex s1, s2, z3;
static real aa, bb, ad, ak, bk, ck, dk, az;
static complex cy[1];
static integer nn;
static real rl;
static integer mr;
static real zi, zr, az3, z3i, z3r, fid, dig, r1m5;
static complex csq;
static real fnu;
static complex zta;
static real tol;
static complex trm1, trm2;
static real sfac, alim, elim, alaz, atrm;
extern /* Subroutine */ int cacai_(complex *, real *, integer *, integer *
, integer *, complex *, integer *, real *, real *, real *, real *)
;
static integer iflag;
extern /* Subroutine */ int cbknu_(complex *, real *, integer *, integer *
, complex *, integer *, real *, real *, real *);
extern integer i1mach_(integer *);
extern doublereal r1mach_(integer *);
/* ***BEGIN PROLOGUE CAIRY */
/* ***PURPOSE Compute the Airy function Ai(z) or its derivative dAi/dz */
/* for complex argument z. A scaling option is available */
/* to help avoid underflow and overflow. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY C10D */
/* ***TYPE COMPLEX (CAIRY-C, ZAIRY-C) */
/* ***KEYWORDS AIRY FUNCTION, BESSEL FUNCTION OF ORDER ONE THIRD, */
/* BESSEL FUNCTION OF ORDER TWO THIRDS */
/* ***AUTHOR Amos, D. E., (SNL) */
/* ***DESCRIPTION */
/* On KODE=1, CAIRY computes the complex Airy function Ai(z) */
/* or its derivative dAi/dz on ID=0 or ID=1 respectively. On */
/* KODE=2, a scaling option exp(zeta)*Ai(z) or exp(zeta)*dAi/dz */
/* is provided to remove the exponential decay in -pi/3<arg(z) */
/* <pi/3 and the exponential growth in pi/3<abs(arg(z))<pi where */
/* zeta=(2/3)*z**(3/2). */
/* While the Airy functions Ai(z) and dAi/dz are analytic in */
/* the whole z-plane, the corresponding scaled functions defined */
/* for KODE=2 have a cut along the negative real axis. */
/* Input */
/* Z - Argument of type COMPLEX */
/* ID - Order of derivative, ID=0 or ID=1 */
/* KODE - A parameter to indicate the scaling option */
/* KODE=1 returns */
/* AI=Ai(z) on ID=0 */
/* AI=dAi/dz on ID=1 */
/* at z=Z */
/* =2 returns */
/* AI=exp(zeta)*Ai(z) on ID=0 */
/* AI=exp(zeta)*dAi/dz on ID=1 */
/* at z=Z where zeta=(2/3)*z**(3/2) */
/* Output */
/* AI - Result of type COMPLEX */
/* NZ - Underflow indicator */
/* NZ=0 Normal return */
/* NZ=1 AI=0 due to underflow in */
/* -pi/3<arg(Z)<pi/3 on KODE=1 */
/* IERR - Error flag */
/* IERR=0 Normal return - COMPUTATION COMPLETED */
/* IERR=1 Input error - NO COMPUTATION */
/* IERR=2 Overflow - NO COMPUTATION */
/* (Re(Z) too large with KODE=1) */
/* IERR=3 Precision warning - COMPUTATION COMPLETED */
/* (Result has less than half precision) */
/* IERR=4 Precision error - NO COMPUTATION */
/* (Result has no precision) */
/* IERR=5 Algorithmic error - NO COMPUTATION */
/* (Termination condition not met) */
/* *Long Description: */
/* Ai(z) and dAi/dz are computed from K Bessel functions by */
/* Ai(z) = c*sqrt(z)*K(1/3,zeta) */
/* dAi/dz = -c* z *K(2/3,zeta) */
/* c = 1/(pi*sqrt(3)) */
/* zeta = (2/3)*z**(3/2) */
/* when abs(z)>1 and from power series when abs(z)<=1. */
/* In most complex variable computation, one must evaluate ele- */
/* mentary functions. When the magnitude of Z is large, losses */
/* of significance by argument reduction occur. Consequently, if */
/* the magnitude of ZETA=(2/3)*Z**(3/2) exceeds U1=SQRT(0.5/UR), */
/* then losses exceeding half precision are likely and an error */
/* flag IERR=3 is triggered where UR=R1MACH(4)=UNIT ROUNDOFF. */
/* Also, if the magnitude of ZETA is larger than U2=0.5/UR, then */
/* all significance is lost and IERR=4. In order to use the INT */
/* function, ZETA must be further restricted not to exceed */
/* U3=I1MACH(9)=LARGEST INTEGER. Thus, the magnitude of ZETA */
/* must be restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, */
/* and U3 are approximately 2.0E+3, 4.2E+6, 2.1E+9 in single */
/* precision and 4.7E+7, 2.3E+15, 2.1E+9 in double precision. */
/* This makes U2 limiting is single precision and U3 limiting */
/* in double precision. This means that the magnitude of Z */
/* cannot exceed approximately 3.4E+4 in single precision and */
/* 2.1E+6 in double precision. This also means that one can */
/* expect to retain, in the worst cases on 32-bit machines, */
/* no digits in single precision and only 6 digits in double */
/* precision. */
/* The approximate relative error in the magnitude of a complex */
/* Bessel function can be expressed as P*10**S where P=MAX(UNIT */
/* ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- */
/* sents the increase in error due to argument reduction in the */
/* elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), */
/* ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF */
/* ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may */
/* have only absolute accuracy. This is most likely to occur */
/* when one component (in magnitude) is larger than the other by */
/* several orders of magnitude. If one component is 10**K larger */
/* than the other, then one can expect only MAX(ABS(LOG10(P))-K, */
/* 0) significant digits; or, stated another way, when K exceeds */
/* the exponent of P, no significant digits remain in the smaller */
/* component. However, the phase angle retains absolute accuracy */
/* because, in complex arithmetic with precision P, the smaller */
/* component will not (as a rule) decrease below P times the */
/* magnitude of the larger component. In these extreme cases, */
/* the principal phase angle is on the order of +P, -P, PI/2-P, */
/* or -PI/2+P. */
/* ***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- */
/* matical Functions, National Bureau of Standards */
/* Applied Mathematics Series 55, U. S. Department */
/* of Commerce, Tenth Printing (1972) or later. */
/* 2. D. E. Amos, Computation of Bessel Functions of */
/* Complex Argument and Large Order, Report SAND83-0643, */
/* Sandia National Laboratories, Albuquerque, NM, May */
/* 1983. */
/* 3. D. E. Amos, A Subroutine Package for Bessel Functions */
/* of a Complex Argument and Nonnegative Order, Report */
/* SAND85-1018, Sandia National Laboratory, Albuquerque, */
/* NM, May 1985. */
/* 4. D. E. Amos, A portable package for Bessel functions */
/* of a complex argument and nonnegative order, ACM */
/* Transactions on Mathematical Software, 12 (September */
/* 1986), pp. 265-273. */
/* ***ROUTINES CALLED CACAI, CBKNU, I1MACH, R1MACH */
/* ***REVISION HISTORY (YYMMDD) */
/* 830501 DATE WRITTEN */
/* 890801 REVISION DATE from Version 3.2 */
/* 910415 Prologue converted to Version 4.0 format. (BAB) */
/* 920128 Category corrected. (WRB) */
/* 920811 Prologue revised. (DWL) */
/* ***END PROLOGUE CAIRY */
/* ***FIRST EXECUTABLE STATEMENT CAIRY */
*ierr = 0;
*nz = 0;
if (*id < 0 || *id > 1) {
*ierr = 1;
}
if (*kode < 1 || *kode > 2) {
*ierr = 1;
}
if (*ierr != 0) {
return 0;
}
az = c_abs(z__);
/* Computing MAX */
r__1 = r1mach_(&c__4);
tol = dmax(r__1,1e-18f);
fid = (real) (*id);
if (az > 1.f) {
goto L60;
}
/* ----------------------------------------------------------------------- */
/* POWER SERIES FOR ABS(Z).LE.1. */
/* ----------------------------------------------------------------------- */
s1.r = cone.r, s1.i = cone.i;
s2.r = cone.r, s2.i = cone.i;
if (az < tol) {
goto L160;
}
aa = az * az;
if (aa < tol / az) {
goto L40;
}
trm1.r = cone.r, trm1.i = cone.i;
trm2.r = cone.r, trm2.i = cone.i;
atrm = 1.f;
q__2.r = z__->r * z__->r - z__->i * z__->i, q__2.i = z__->r * z__->i +
z__->i * z__->r;
q__1.r = q__2.r * z__->r - q__2.i * z__->i, q__1.i = q__2.r * z__->i +
q__2.i * z__->r;
z3.r = q__1.r, z3.i = q__1.i;
az3 = az * aa;
ak = fid + 2.f;
bk = 3.f - fid - fid;
ck = 4.f - fid;
dk = fid + 3.f + fid;
d1 = ak * dk;
d2 = bk * ck;
ad = dmin(d1,d2);
ak = fid * 9.f + 24.f;
bk = 30.f - fid * 9.f;
z3r = z3.r;
z3i = r_imag(&z3);
for (k = 1; k <= 25; ++k) {
r__1 = z3r / d1;
r__2 = z3i / d1;
q__2.r = r__1, q__2.i = r__2;
q__1.r = trm1.r * q__2.r - trm1.i * q__2.i, q__1.i = trm1.r * q__2.i
+ trm1.i * q__2.r;
trm1.r = q__1.r, trm1.i = q__1.i;
q__1.r = s1.r + trm1.r, q__1.i = s1.i + trm1.i;
s1.r = q__1.r, s1.i = q__1.i;
r__1 = z3r / d2;
r__2 = z3i / d2;
q__2.r = r__1, q__2.i = r__2;
q__1.r = trm2.r * q__2.r - trm2.i * q__2.i, q__1.i = trm2.r * q__2.i
+ trm2.i * q__2.r;
trm2.r = q__1.r, trm2.i = q__1.i;
q__1.r = s2.r + trm2.r, q__1.i = s2.i + trm2.i;
s2.r = q__1.r, s2.i = q__1.i;
atrm = atrm * az3 / ad;
d1 += ak;
d2 += bk;
ad = dmin(d1,d2);
if (atrm < tol * ad) {
goto L40;
}
ak += 18.f;
bk += 18.f;
/* L30: */
}
L40:
if (*id == 1) {
goto L50;
}
q__3.r = c1, q__3.i = 0.f;
q__2.r = s1.r * q__3.r - s1.i * q__3.i, q__2.i = s1.r * q__3.i + s1.i *
q__3.r;
q__5.r = z__->r * s2.r - z__->i * s2.i, q__5.i = z__->r * s2.i + z__->i *
s2.r;
q__6.r = c2, q__6.i = 0.f;
q__4.r = q__5.r * q__6.r - q__5.i * q__6.i, q__4.i = q__5.r * q__6.i +
q__5.i * q__6.r;
q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
ai->r = q__1.r, ai->i = q__1.i;
if (*kode == 1) {
return 0;
}
c_sqrt(&q__3, z__);
q__2.r = z__->r * q__3.r - z__->i * q__3.i, q__2.i = z__->r * q__3.i +
z__->i * q__3.r;
q__4.r = tth, q__4.i = 0.f;
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i +
q__2.i * q__4.r;
zta.r = q__1.r, zta.i = q__1.i;
c_exp(&q__2, &zta);
q__1.r = ai->r * q__2.r - ai->i * q__2.i, q__1.i = ai->r * q__2.i + ai->i
* q__2.r;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L50:
q__2.r = -s2.r, q__2.i = -s2.i;
q__3.r = c2, q__3.i = 0.f;
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;
ai->r = q__1.r, ai->i = q__1.i;
if (az > tol) {
q__4.r = z__->r * z__->r - z__->i * z__->i, q__4.i = z__->r * z__->i
+ z__->i * z__->r;
q__3.r = q__4.r * s1.r - q__4.i * s1.i, q__3.i = q__4.r * s1.i +
q__4.i * s1.r;
r__1 = c1 / (fid + 1.f);
q__5.r = r__1, q__5.i = 0.f;
q__2.r = q__3.r * q__5.r - q__3.i * q__5.i, q__2.i = q__3.r * q__5.i
+ q__3.i * q__5.r;
q__1.r = ai->r + q__2.r, q__1.i = ai->i + q__2.i;
ai->r = q__1.r, ai->i = q__1.i;
}
if (*kode == 1) {
return 0;
}
c_sqrt(&q__3, z__);
q__2.r = z__->r * q__3.r - z__->i * q__3.i, q__2.i = z__->r * q__3.i +
z__->i * q__3.r;
q__4.r = tth, q__4.i = 0.f;
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i +
q__2.i * q__4.r;
zta.r = q__1.r, zta.i = q__1.i;
c_exp(&q__2, &zta);
q__1.r = ai->r * q__2.r - ai->i * q__2.i, q__1.i = ai->r * q__2.i + ai->i
* q__2.r;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
/* ----------------------------------------------------------------------- */
/* CASE FOR ABS(Z).GT.1.0 */
/* ----------------------------------------------------------------------- */
L60:
fnu = (fid + 1.f) / 3.f;
/* ----------------------------------------------------------------------- */
/* SET PARAMETERS RELATED TO MACHINE CONSTANTS. */
/* TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. */
/* ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. */
/* EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND */
/* EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR */
/* UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. */
/* RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. */
/* DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). */
/* ----------------------------------------------------------------------- */
k1 = i1mach_(&c__12);
k2 = i1mach_(&c__13);
r1m5 = r1mach_(&c__5);
/* Computing MIN */
i__1 = abs(k1), i__2 = abs(k2);
k = min(i__1,i__2);
elim = (k * r1m5 - 3.f) * 2.303f;
k1 = i1mach_(&c__11) - 1;
aa = r1m5 * k1;
dig = dmin(aa,18.f);
aa *= 2.303f;
/* Computing MAX */
r__1 = -aa;
alim = elim + dmax(r__1,-41.45f);
rl = dig * 1.2f + 3.f;
alaz = log(az);
/* ----------------------------------------------------------------------- */
/* TEST FOR RANGE */
/* ----------------------------------------------------------------------- */
aa = .5f / tol;
bb = i1mach_(&c__9) * .5f;
aa = dmin(aa,bb);
d__1 = (doublereal) aa;
d__2 = (doublereal) tth;
aa = pow_dd(&d__1, &d__2);
if (az > aa) {
goto L260;
}
aa = sqrt(aa);
if (az > aa) {
*ierr = 3;
}
c_sqrt(&q__1, z__);
csq.r = q__1.r, csq.i = q__1.i;
q__2.r = z__->r * csq.r - z__->i * csq.i, q__2.i = z__->r * csq.i +
z__->i * csq.r;
q__3.r = tth, q__3.i = 0.f;
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;
zta.r = q__1.r, zta.i = q__1.i;
/* ----------------------------------------------------------------------- */
/* RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL */
/* ----------------------------------------------------------------------- */
iflag = 0;
sfac = 1.f;
zi = r_imag(z__);
zr = z__->r;
ak = r_imag(&zta);
if (zr >= 0.f) {
goto L70;
}
bk = zta.r;
ck = -dabs(bk);
q__1.r = ck, q__1.i = ak;
zta.r = q__1.r, zta.i = q__1.i;
L70:
if (zi != 0.f) {
goto L80;
}
if (zr > 0.f) {
goto L80;
}
q__1.r = 0.f, q__1.i = ak;
zta.r = q__1.r, zta.i = q__1.i;
L80:
aa = zta.r;
if (aa >= 0.f && zr > 0.f) {
goto L100;
}
if (*kode == 2) {
goto L90;
}
/* ----------------------------------------------------------------------- */
/* OVERFLOW TEST */
/* ----------------------------------------------------------------------- */
if (aa > -alim) {
goto L90;
}
aa = -aa + alaz * .25f;
iflag = 1;
sfac = tol;
if (aa > elim) {
goto L240;
}
L90:
/* ----------------------------------------------------------------------- */
/* CBKNU AND CACAI RETURN EXP(ZTA)*K(FNU,ZTA) ON KODE=2 */
/* ----------------------------------------------------------------------- */
mr = 1;
if (zi < 0.f) {
mr = -1;
}
cacai_(&zta, &fnu, kode, &mr, &c__1, cy, &nn, &rl, &tol, &elim, &alim);
if (nn < 0) {
goto L250;
}
*nz += nn;
goto L120;
L100:
if (*kode == 2) {
goto L110;
}
/* ----------------------------------------------------------------------- */
/* UNDERFLOW TEST */
/* ----------------------------------------------------------------------- */
if (aa < alim) {
goto L110;
}
aa = -aa - alaz * .25f;
iflag = 2;
sfac = 1.f / tol;
if (aa < -elim) {
goto L180;
}
L110:
cbknu_(&zta, &fnu, kode, &c__1, cy, nz, &tol, &elim, &alim);
L120:
q__2.r = coef, q__2.i = 0.f;
q__1.r = cy[0].r * q__2.r - cy[0].i * q__2.i, q__1.i = cy[0].r * q__2.i +
cy[0].i * q__2.r;
s1.r = q__1.r, s1.i = q__1.i;
if (iflag != 0) {
goto L140;
}
if (*id == 1) {
goto L130;
}
q__1.r = csq.r * s1.r - csq.i * s1.i, q__1.i = csq.r * s1.i + csq.i *
s1.r;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L130:
q__2.r = -z__->r, q__2.i = -z__->i;
q__1.r = q__2.r * s1.r - q__2.i * s1.i, q__1.i = q__2.r * s1.i + q__2.i *
s1.r;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L140:
q__2.r = sfac, q__2.i = 0.f;
q__1.r = s1.r * q__2.r - s1.i * q__2.i, q__1.i = s1.r * q__2.i + s1.i *
q__2.r;
s1.r = q__1.r, s1.i = q__1.i;
if (*id == 1) {
goto L150;
}
q__1.r = s1.r * csq.r - s1.i * csq.i, q__1.i = s1.r * csq.i + s1.i *
csq.r;
s1.r = q__1.r, s1.i = q__1.i;
r__1 = 1.f / sfac;
q__2.r = r__1, q__2.i = 0.f;
q__1.r = s1.r * q__2.r - s1.i * q__2.i, q__1.i = s1.r * q__2.i + s1.i *
q__2.r;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L150:
q__2.r = -s1.r, q__2.i = -s1.i;
q__1.r = q__2.r * z__->r - q__2.i * z__->i, q__1.i = q__2.r * z__->i +
q__2.i * z__->r;
s1.r = q__1.r, s1.i = q__1.i;
r__1 = 1.f / sfac;
q__2.r = r__1, q__2.i = 0.f;
q__1.r = s1.r * q__2.r - s1.i * q__2.i, q__1.i = s1.r * q__2.i + s1.i *
q__2.r;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L160:
aa = r1mach_(&c__1) * 1e3f;
s1.r = 0.f, s1.i = 0.f;
if (*id == 1) {
goto L170;
}
if (az > aa) {
q__2.r = c2, q__2.i = 0.f;
q__1.r = q__2.r * z__->r - q__2.i * z__->i, q__1.i = q__2.r * z__->i
+ q__2.i * z__->r;
s1.r = q__1.r, s1.i = q__1.i;
}
q__2.r = c1, q__2.i = 0.f;
q__1.r = q__2.r - s1.r, q__1.i = q__2.i - s1.i;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L170:
q__2.r = c2, q__2.i = 0.f;
q__1.r = -q__2.r, q__1.i = -q__2.i;
ai->r = q__1.r, ai->i = q__1.i;
aa = sqrt(aa);
if (az > aa) {
q__2.r = z__->r * z__->r - z__->i * z__->i, q__2.i = z__->r * z__->i
+ z__->i * z__->r;
q__1.r = q__2.r * .5f - q__2.i * 0.f, q__1.i = q__2.r * 0.f + q__2.i *
.5f;
s1.r = q__1.r, s1.i = q__1.i;
}
q__3.r = c1, q__3.i = 0.f;
q__2.r = s1.r * q__3.r - s1.i * q__3.i, q__2.i = s1.r * q__3.i + s1.i *
q__3.r;
q__1.r = ai->r + q__2.r, q__1.i = ai->i + q__2.i;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L180:
*nz = 1;
ai->r = 0.f, ai->i = 0.f;
return 0;
L240:
*nz = 0;
*ierr = 2;
return 0;
L250:
if (nn == -1) {
goto L240;
}
*nz = 0;
*ierr = 5;
return 0;
L260:
*ierr = 4;
*nz = 0;
return 0;
} /* cairy_ */
void schurFactorization(long n, complex **A, complex **T, complex **U)
{
/* Schur factorization: A = U*T*U', T = upper triangular, U = unitary */
long i,j,iter,maxIter;
double tol, diff1,diff2;
complex T11, T12, T21, T22;
complex sigma1, sigma2, sigma;
complex z, z1, z2;
complex **P, **Q, **R;
/* Allocate auxiliary matrices */
P = (complex **)Mem(MEM_ALLOC,n, sizeof(complex *));
Q = (complex **)Mem(MEM_ALLOC,n, sizeof(complex *));
R = (complex **)Mem(MEM_ALLOC,n, sizeof(complex *));
for (i=0; i<n; i++){
P[i] = (complex *)Mem(MEM_ALLOC,n, sizeof(complex));
Q[i] = (complex *)Mem(MEM_ALLOC,n, sizeof(complex));
R[i] = (complex *)Mem(MEM_ALLOC,n, sizeof(complex));
}
/* ------------------------------------------------------------*/
/* Parameters for iteration */
maxIter = 500;
tol = 1E-30;
/* ------------------------------------------------------------*/
/* Init U = eye(n) (identity matrix) */
for (i=0; i<n; i++){
U[i][i].re = 1.0;
U[i][i].im = 0.0;
}
/* ------------------------------------------------------------*/
/* Reduce A to Hessenberg form */
hessFactorization(n,A,P,T);
/* ------------------------------------------------------------*/
/* Compute Schur factorization of Hessenberg matrix T */
for (j=n-1; j>0; j--){ /* Main loop */
for (iter=0; iter<maxIter; iter++){ /* Iteration loop */
sigma.re = T[j][j].re;
sigma.im = T[j][j].im;
/* -- Use Wilkinson shift -- */
/* submatrix considered in the shift */
T11 = T[j-1][j-1];
T12 = T[j-1][j];
T21 = T[j][j-1];
T22 = T[j][j];
/* Compute eigenvalues of submatrix */
z.re = 0.0;
z.im = 0.0;
z2.re = 0.0;
z2.im = 0.0;
/* z = T11*T11 + T22*T22 - 2*T11*T22 + 4*T12*T21 */
z1 = c_mul(T11,T11);
z = c_add(z ,z1);
z2 = c_add(z2,z1);
z1 = c_mul(T22,T22);
z = c_add(z ,z1);
z2 = c_add(z2,z1);
z1 = c_mul(T11,T22);
z1.re = -2.0 * z1.re;
z1.im = -2.0 * z1.im;
z = c_add(z,z1);
z1 = c_mul(T12,T21);
z1.re = 4.0 * z1.re;
z1.im = 4.0 * z1.im;
z = c_add(z,z1);
/* Square root*/
z = c_sqrt(z);
/* Eigenvalues */
sigma1 = c_add(z2,z);
sigma2 = c_sub(z2,z);
/* printf("sigma1 = %e %e\n", sigma1.re, sigma1.im); */
/* printf("sigma2 = %e %e\n", sigma2.re, sigma2.im); */
/* Select eigenvalue for shift*/
diff1 = c_norm( c_sub(T[j][j], sigma1) );
diff2 = c_norm( c_sub(T[j][j], sigma2) );
if (diff1 < diff2){
sigma.re = sigma1.re;
sigma.im = sigma1.im;
}else{
sigma.re = sigma2.re;
sigma.im = sigma2.im;
}
/* --- QR step with Wilkinson shift --- */
/* Shift: T(1:j,1:j) = T(1:j,1:j) - sigma * eye(j) */
for (i=0; i<j+1; i++){
CheckValue(FUNCTION_NAME, "T[i][i].re","", T[i][i].re, -INFTY, INFTY);
CheckValue(FUNCTION_NAME, "T[i][i].im","", T[i][i].im, -INFTY, INFTY);
T[i][i].re = T[i][i].re - sigma.re;
T[i][i].im = T[i][i].im - sigma.im;
}
/* Compute QR factorization of shifted Hessenberg matrix */
for (i=0; i<n; i++){
memset(Q[i], 0, n*sizeof(complex));
memset(R[i], 0, n*sizeof(complex));
}
QRfactorization(n,T,Q,R);
/* T = T_new = R * Q */
for (i=0; i<n; i++){
memset(T[i], 0, n*sizeof(complex));
}
matProduct(n, n, n, R, Q, T);
/* T(1:j,1:j) = T(1:j,1:j) + sigma * eye(j) */
for (i=0; i<j+1; i++){
T[i][i].re = T[i][i].re + sigma.re;
T[i][i].im = T[i][i].im + sigma.im;
}
/* R = U_new = U * Q */
for (i=0; i<n; i++){
memset(R[i], 0, n*sizeof(complex));
}
matProduct(n,n,n,U,Q,R);
/* U = R */
for (i=0; i<n; i++){
memcpy(U[i],R[i], n*sizeof(complex));
}
/* Check convergence */
if (c_norm( T[j][j-1] ) <= tol * (c_norm(T[j-1][j-1]) + c_norm(T[j][j]))){
T[j][j-1].re = 0.0;
T[j][j-1].im = 0.0;
break;
}
} /* end of iter loop */
} /* end of main loop */
/* -------------------------------------------------------------*/
/* U = P*U */
for (i=0; i<n; i++){
memset(U[i], 0, n*sizeof(complex));
}
matProduct(n,n,n,P,R,U);
/* -------------------------------------------------------------*/
/* Free auxiliary variables */
for (i=0; i<n; i++){
Mem(MEM_FREE,P[i]);
Mem(MEM_FREE,Q[i]);
Mem(MEM_FREE,R[i]);
}
Mem(MEM_FREE,P);
Mem(MEM_FREE,Q);
Mem(MEM_FREE,R);
/* Return */
return;
}
/* 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 CQRDC */
/* Subroutine */ int cqrdc_(complex *x, integer *ldx, integer *n, integer *p,
complex *qraux, integer *jpvt, complex *work, integer *job)
{
/* System generated locals */
integer x_dim1, x_offset, i__1, i__2, i__3, i__4;
real r__1, r__2, r__3, r__4;
complex q__1, q__2, q__3;
/* Local variables */
static integer j, l;
static complex t;
static integer jj, jp, pl, pu;
static real tt;
static integer lp1, lup;
static logical negj;
static integer maxj;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
extern /* Complex */ void cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
complex *, integer *);
static logical swapj;
extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
static complex nrmxl;
extern doublereal scnrm2_(integer *, complex *, integer *);
static real maxnrm;
/* ***BEGIN PROLOGUE CQRDC */
/* ***PURPOSE Use Householder transformations to compute the QR */
/* factorization of an N by P matrix. Column pivoting is a */
/* users option. */
/* ***LIBRARY SLATEC (LINPACK) */
/* ***CATEGORY D5 */
/* ***TYPE COMPLEX (SQRDC-S, DQRDC-D, CQRDC-C) */
/* ***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, ORTHOGONAL TRIANGULAR, */
/* QR DECOMPOSITION */
/* ***AUTHOR Stewart, G. W., (U. of Maryland) */
/* ***DESCRIPTION */
/* CQRDC uses Householder transformations to compute the QR */
/* factorization of an N by P matrix X. Column pivoting */
/* based on the 2-norms of the reduced columns may be */
/* performed at the users option. */
/* On Entry */
/* X COMPLEX(LDX,P), where LDX .GE. N. */
/* X contains the matrix whose decomposition is to be */
/* computed. */
/* LDX INTEGER. */
/* LDX is the leading dimension of the array X. */
/* N INTEGER. */
/* N is the number of rows of the matrix X. */
/* P INTEGER. */
/* P is the number of columns of the matrix X. */
/* JVPT INTEGER(P). */
/* JVPT contains integers that control the selection */
/* of the pivot columns. The K-th column X(K) of X */
/* is placed in one of three classes according to the */
/* value of JVPT(K). */
/* If JVPT(K) .GT. 0, then X(K) is an initial */
/* column. */
/* If JVPT(K) .EQ. 0, then X(K) is a free column. */
/* If JVPT(K) .LT. 0, then X(K) is a final column. */
/* Before the decomposition is computed, initial columns */
/* are moved to the beginning of the array X and final */
/* columns to the end. Both initial and final columns */
/* are frozen in place during the computation and only */
/* free columns are moved. At the K-th stage of the */
/* reduction, if X(K) is occupied by a free column */
/* it is interchanged with the free column of largest */
/* reduced norm. JVPT is not referenced if */
/* JOB .EQ. 0. */
/* WORK COMPLEX(P). */
/* WORK is a work array. WORK is not referenced if */
/* JOB .EQ. 0. */
/* JOB INTEGER. */
/* JOB is an integer that initiates column pivoting. */
/* If JOB .EQ. 0, no pivoting is done. */
/* If JOB .NE. 0, pivoting is done. */
/* On Return */
/* X X contains in its upper triangle the upper */
/* triangular matrix R of the QR factorization. */
/* Below its diagonal X contains information from */
/* which the unitary part of the decomposition */
/* can be recovered. Note that if pivoting has */
/* been requested, the decomposition is not that */
/* of the original matrix X but that of X */
/* with its columns permuted as described by JVPT. */
/* QRAUX COMPLEX(P). */
/* QRAUX contains further information required to recover */
/* the unitary part of the decomposition. */
/* JVPT JVPT(K) contains the index of the column of the */
/* original matrix that has been interchanged into */
/* the K-th column, if pivoting was requested. */
/* ***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. */
/* Stewart, LINPACK Users' Guide, SIAM, 1979. */
/* ***ROUTINES CALLED CAXPY, CDOTC, CSCAL, CSWAP, SCNRM2 */
/* ***REVISION HISTORY (YYMMDD) */
/* 780814 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890831 Modified array declarations. (WRB) */
/* 890831 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900326 Removed duplicate information from DESCRIPTION section. */
/* (WRB) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE CQRDC */
/* ***FIRST EXECUTABLE STATEMENT CQRDC */
/* Parameter adjustments */
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--qraux;
--jpvt;
--work;
/* Function Body */
pl = 1;
pu = 0;
if (*job == 0) {
goto L60;
}
/* PIVOTING HAS BEEN REQUESTED. REARRANGE THE COLUMNS */
/* ACCORDING TO JPVT. */
i__1 = *p;
for (j = 1; j <= i__1; ++j) {
swapj = jpvt[j] > 0;
negj = jpvt[j] < 0;
jpvt[j] = j;
if (negj) {
jpvt[j] = -j;
}
if (! swapj) {
goto L10;
}
if (j != pl) {
cswap_(n, &x[pl * x_dim1 + 1], &c__1, &x[j * x_dim1 + 1], &c__1);
}
jpvt[j] = jpvt[pl];
jpvt[pl] = j;
++pl;
L10:
/* L20: */
;
}
pu = *p;
i__1 = *p;
for (jj = 1; jj <= i__1; ++jj) {
j = *p - jj + 1;
if (jpvt[j] >= 0) {
goto L40;
}
jpvt[j] = -jpvt[j];
if (j == pu) {
goto L30;
}
cswap_(n, &x[pu * x_dim1 + 1], &c__1, &x[j * x_dim1 + 1], &c__1);
jp = jpvt[pu];
jpvt[pu] = jpvt[j];
jpvt[j] = jp;
L30:
--pu;
L40:
/* L50: */
;
}
L60:
/* COMPUTE THE NORMS OF THE FREE COLUMNS. */
if (pu < pl) {
goto L80;
}
i__1 = pu;
for (j = pl; j <= i__1; ++j) {
i__2 = j;
r__1 = scnrm2_(n, &x[j * x_dim1 + 1], &c__1);
q__1.r = r__1, q__1.i = 0.f;
qraux[i__2].r = q__1.r, qraux[i__2].i = q__1.i;
i__2 = j;
i__3 = j;
work[i__2].r = qraux[i__3].r, work[i__2].i = qraux[i__3].i;
/* L70: */
}
L80:
/* PERFORM THE HOUSEHOLDER REDUCTION OF X. */
lup = min(*n,*p);
i__1 = lup;
for (l = 1; l <= i__1; ++l) {
if (l < pl || l >= pu) {
goto L120;
}
/* LOCATE THE COLUMN OF LARGEST NORM AND BRING IT */
/* INTO THE PIVOT POSITION. */
maxnrm = 0.f;
maxj = l;
i__2 = pu;
for (j = l; j <= i__2; ++j) {
i__3 = j;
if (qraux[i__3].r <= maxnrm) {
goto L90;
}
i__3 = j;
maxnrm = qraux[i__3].r;
maxj = j;
L90:
/* L100: */
;
}
if (maxj == l) {
goto L110;
}
cswap_(n, &x[l * x_dim1 + 1], &c__1, &x[maxj * x_dim1 + 1], &c__1);
i__2 = maxj;
i__3 = l;
qraux[i__2].r = qraux[i__3].r, qraux[i__2].i = qraux[i__3].i;
i__2 = maxj;
i__3 = l;
work[i__2].r = work[i__3].r, work[i__2].i = work[i__3].i;
jp = jpvt[maxj];
jpvt[maxj] = jpvt[l];
jpvt[l] = jp;
L110:
L120:
i__2 = l;
qraux[i__2].r = 0.f, qraux[i__2].i = 0.f;
if (l == *n) {
goto L190;
}
/* COMPUTE THE HOUSEHOLDER TRANSFORMATION FOR COLUMN L. */
i__2 = *n - l + 1;
r__1 = scnrm2_(&i__2, &x[l + l * x_dim1], &c__1);
q__1.r = r__1, q__1.i = 0.f;
nrmxl.r = q__1.r, nrmxl.i = q__1.i;
if ((r__1 = nrmxl.r, dabs(r__1)) + (r__2 = r_imag(&nrmxl), dabs(r__2))
== 0.f) {
goto L180;
}
i__2 = l + l * x_dim1;
if ((r__1 = x[i__2].r, dabs(r__1)) + (r__2 = r_imag(&x[l + l * x_dim1]
), dabs(r__2)) != 0.f) {
r__3 = c_abs(&nrmxl);
i__3 = l + l * x_dim1;
r__4 = c_abs(&x[l + l * x_dim1]);
q__2.r = x[i__3].r / r__4, q__2.i = x[i__3].i / r__4;
q__1.r = r__3 * q__2.r, q__1.i = r__3 * q__2.i;
nrmxl.r = q__1.r, nrmxl.i = q__1.i;
}
i__2 = *n - l + 1;
c_div(&q__1, &c_b26, &nrmxl);
cscal_(&i__2, &q__1, &x[l + l * x_dim1], &c__1);
i__2 = l + l * x_dim1;
i__3 = l + l * x_dim1;
q__1.r = x[i__3].r + 1.f, q__1.i = x[i__3].i + 0.f;
x[i__2].r = q__1.r, x[i__2].i = q__1.i;
/* APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS, */
/* UPDATING THE NORMS. */
lp1 = l + 1;
if (*p < lp1) {
goto L170;
}
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
i__3 = *n - l + 1;
cdotc_(&q__3, &i__3, &x[l + l * x_dim1], &c__1, &x[l + j * x_dim1]
, &c__1);
q__2.r = -q__3.r, q__2.i = -q__3.i;
c_div(&q__1, &q__2, &x[l + l * x_dim1]);
t.r = q__1.r, t.i = q__1.i;
i__3 = *n - l + 1;
caxpy_(&i__3, &t, &x[l + l * x_dim1], &c__1, &x[l + j * x_dim1], &
c__1);
if (j < pl || j > pu) {
goto L150;
}
i__3 = j;
if ((r__1 = qraux[i__3].r, dabs(r__1)) + (r__2 = r_imag(&qraux[j])
, dabs(r__2)) == 0.f) {
goto L150;
}
i__3 = j;
/* Computing 2nd power */
r__1 = c_abs(&x[l + j * x_dim1]) / qraux[i__3].r;
tt = 1.f - r__1 * r__1;
tt = dmax(tt,0.f);
q__1.r = tt, q__1.i = 0.f;
t.r = q__1.r, t.i = q__1.i;
i__3 = j;
i__4 = j;
/* Computing 2nd power */
r__1 = qraux[i__3].r / work[i__4].r;
tt = tt * .05f * (r__1 * r__1) + 1.f;
if (tt == 1.f) {
goto L130;
}
i__3 = j;
i__4 = j;
c_sqrt(&q__2, &t);
q__1.r = qraux[i__4].r * q__2.r - qraux[i__4].i * q__2.i, q__1.i =
qraux[i__4].r * q__2.i + qraux[i__4].i * q__2.r;
qraux[i__3].r = q__1.r, qraux[i__3].i = q__1.i;
goto L140;
L130:
i__3 = j;
i__4 = *n - l;
r__1 = scnrm2_(&i__4, &x[l + 1 + j * x_dim1], &c__1);
q__1.r = r__1, q__1.i = 0.f;
qraux[i__3].r = q__1.r, qraux[i__3].i = q__1.i;
i__3 = j;
i__4 = j;
work[i__3].r = qraux[i__4].r, work[i__3].i = qraux[i__4].i;
L140:
L150:
/* L160: */
;
}
L170:
/* SAVE THE TRANSFORMATION. */
i__2 = l;
i__3 = l + l * x_dim1;
qraux[i__2].r = x[i__3].r, qraux[i__2].i = x[i__3].i;
i__2 = l + l * x_dim1;
q__1.r = -nrmxl.r, q__1.i = -nrmxl.i;
x[i__2].r = q__1.r, x[i__2].i = q__1.i;
L180:
L190:
/* L200: */
;
}
return 0;
} /* cqrdc_ */
/* DECK CUNHJ */
/* Subroutine */ int cunhj_(complex *z__, real *fnu, integer *ipmtr, real *
tol, complex *phi, complex *arg, complex *zeta1, complex *zeta2,
complex *asum, complex *bsum)
{
/* Initialized data */
static real ar[14] = { 1.f,.104166666666666667f,.0835503472222222222f,
.12822657455632716f,.291849026464140464f,.881627267443757652f,
3.32140828186276754f,14.9957629868625547f,78.9230130115865181f,
474.451538868264323f,3207.49009089066193f,24086.5496408740049f,
198923.119169509794f,1791902.00777534383f };
static real pi = 3.14159265358979324f;
static real thpi = 4.71238898038468986f;
static complex czero = {0.f,0.f};
static complex cone = {1.f,0.f};
static real br[14] = { 1.f,-.145833333333333333f,-.0987413194444444444f,
-.143312053915895062f,-.317227202678413548f,-.942429147957120249f,
-3.51120304082635426f,-15.7272636203680451f,-82.2814390971859444f,
-492.355370523670524f,-3316.21856854797251f,-24827.6742452085896f,
-204526.587315129788f,-1838444.9170682099f };
static real c__[105] = { 1.f,-.208333333333333333f,.125f,
.334201388888888889f,-.401041666666666667f,.0703125f,
-1.02581259645061728f,1.84646267361111111f,-.8912109375f,
.0732421875f,4.66958442342624743f,-11.2070026162229938f,
8.78912353515625f,-2.3640869140625f,.112152099609375f,
-28.2120725582002449f,84.6362176746007346f,-91.8182415432400174f,
42.5349987453884549f,-7.3687943594796317f,.227108001708984375f,
212.570130039217123f,-765.252468141181642f,1059.99045252799988f,
-699.579627376132541f,218.19051174421159f,-26.4914304869515555f,
.572501420974731445f,-1919.457662318407f,8061.72218173730938f,
-13586.5500064341374f,11655.3933368645332f,-5305.64697861340311f,
1200.90291321635246f,-108.090919788394656f,1.7277275025844574f,
20204.2913309661486f,-96980.5983886375135f,192547.001232531532f,
-203400.177280415534f,122200.46498301746f,-41192.6549688975513f,
7109.51430248936372f,-493.915304773088012f,6.07404200127348304f,
-242919.187900551333f,1311763.6146629772f,-2998015.91853810675f,
3763271.297656404f,-2813563.22658653411f,1268365.27332162478f,
-331645.172484563578f,45218.7689813627263f,-2499.83048181120962f,
24.3805296995560639f,3284469.85307203782f,-19706819.1184322269f,
50952602.4926646422f,-74105148.2115326577f,66344512.2747290267f,
-37567176.6607633513f,13288767.1664218183f,-2785618.12808645469f,
308186.404612662398f,-13886.0897537170405f,110.017140269246738f,
-49329253.664509962f,325573074.185765749f,-939462359.681578403f,
1553596899.57058006f,-1621080552.10833708f,1106842816.82301447f,
-495889784.275030309f,142062907.797533095f,-24474062.7257387285f,
2243768.17792244943f,-84005.4336030240853f,551.335896122020586f,
814789096.118312115f,-5866481492.05184723f,18688207509.2958249f,
-34632043388.1587779f,41280185579.753974f,-33026599749.8007231f,
17954213731.1556001f,-6563293792.61928433f,1559279864.87925751f,
-225105661.889415278f,17395107.5539781645f,-549842.327572288687f,
3038.09051092238427f,-14679261247.6956167f,114498237732.02581f,
-399096175224.466498f,819218669548.577329f,-1098375156081.22331f,
1008158106865.38209f,-645364869245.376503f,287900649906.150589f,
-87867072178.0232657f,17634730606.8349694f,-2167164983.22379509f,
143157876.718888981f,-3871833.44257261262f,18257.7554742931747f };
static real alfa[180] = { -.00444444444444444444f,
-9.22077922077922078e-4f,-8.84892884892884893e-5f,
1.65927687832449737e-4f,2.4669137274179291e-4f,
2.6599558934625478e-4f,2.61824297061500945e-4f,
2.48730437344655609e-4f,2.32721040083232098e-4f,
2.16362485712365082e-4f,2.00738858762752355e-4f,
1.86267636637545172e-4f,1.73060775917876493e-4f,
1.61091705929015752e-4f,1.50274774160908134e-4f,
1.40503497391269794e-4f,1.31668816545922806e-4f,
1.23667445598253261e-4f,1.16405271474737902e-4f,
1.09798298372713369e-4f,1.03772410422992823e-4f,
9.82626078369363448e-5f,9.32120517249503256e-5f,
8.85710852478711718e-5f,8.42963105715700223e-5f,
8.03497548407791151e-5f,7.66981345359207388e-5f,
7.33122157481777809e-5f,7.01662625163141333e-5f,
6.72375633790160292e-5f,6.93735541354588974e-4f,
2.32241745182921654e-4f,-1.41986273556691197e-5f,
-1.1644493167204864e-4f,-1.50803558053048762e-4f,
-1.55121924918096223e-4f,-1.46809756646465549e-4f,
-1.33815503867491367e-4f,-1.19744975684254051e-4f,
-1.0618431920797402e-4f,-9.37699549891194492e-5f,
-8.26923045588193274e-5f,-7.29374348155221211e-5f,
-6.44042357721016283e-5f,-5.69611566009369048e-5f,
-5.04731044303561628e-5f,-4.48134868008882786e-5f,
-3.98688727717598864e-5f,-3.55400532972042498e-5f,
-3.1741425660902248e-5f,-2.83996793904174811e-5f,
-2.54522720634870566e-5f,-2.28459297164724555e-5f,
-2.05352753106480604e-5f,-1.84816217627666085e-5f,
-1.66519330021393806e-5f,-1.50179412980119482e-5f,
-1.35554031379040526e-5f,-1.22434746473858131e-5f,
-1.10641884811308169e-5f,-3.54211971457743841e-4f,
-1.56161263945159416e-4f,3.0446550359493641e-5f,
1.30198655773242693e-4f,1.67471106699712269e-4f,
1.70222587683592569e-4f,1.56501427608594704e-4f,
1.3633917097744512e-4f,1.14886692029825128e-4f,
9.45869093034688111e-5f,7.64498419250898258e-5f,
6.07570334965197354e-5f,4.74394299290508799e-5f,
3.62757512005344297e-5f,2.69939714979224901e-5f,
1.93210938247939253e-5f,1.30056674793963203e-5f,
7.82620866744496661e-6f,3.59257485819351583e-6f,
1.44040049814251817e-7f,-2.65396769697939116e-6f,
-4.9134686709848591e-6f,-6.72739296091248287e-6f,
-8.17269379678657923e-6f,-9.31304715093561232e-6f,
-1.02011418798016441e-5f,-1.0880596251059288e-5f,
-1.13875481509603555e-5f,-1.17519675674556414e-5f,
-1.19987364870944141e-5f,3.78194199201772914e-4f,
2.02471952761816167e-4f,-6.37938506318862408e-5f,
-2.38598230603005903e-4f,-3.10916256027361568e-4f,
-3.13680115247576316e-4f,-2.78950273791323387e-4f,
-2.28564082619141374e-4f,-1.75245280340846749e-4f,
-1.25544063060690348e-4f,-8.22982872820208365e-5f,
-4.62860730588116458e-5f,-1.72334302366962267e-5f,
5.60690482304602267e-6f,2.313954431482868e-5f,
3.62642745856793957e-5f,4.58006124490188752e-5f,
5.2459529495911405e-5f,5.68396208545815266e-5f,
5.94349820393104052e-5f,6.06478527578421742e-5f,
6.08023907788436497e-5f,6.01577894539460388e-5f,
5.891996573446985e-5f,5.72515823777593053e-5f,
5.52804375585852577e-5f,5.3106377380288017e-5f,
5.08069302012325706e-5f,4.84418647620094842e-5f,
4.6056858160747537e-5f,-6.91141397288294174e-4f,
-4.29976633058871912e-4f,1.83067735980039018e-4f,
6.60088147542014144e-4f,8.75964969951185931e-4f,
8.77335235958235514e-4f,7.49369585378990637e-4f,
5.63832329756980918e-4f,3.68059319971443156e-4f,
1.88464535514455599e-4f,3.70663057664904149e-5f,
-8.28520220232137023e-5f,-1.72751952869172998e-4f,
-2.36314873605872983e-4f,-2.77966150694906658e-4f,
-3.02079514155456919e-4f,-3.12594712643820127e-4f,
-3.12872558758067163e-4f,-3.05678038466324377e-4f,
-2.93226470614557331e-4f,-2.77255655582934777e-4f,
-2.59103928467031709e-4f,-2.39784014396480342e-4f,
-2.20048260045422848e-4f,-2.00443911094971498e-4f,
-1.81358692210970687e-4f,-1.63057674478657464e-4f,
-1.45712672175205844e-4f,-1.29425421983924587e-4f,
-1.14245691942445952e-4f,.00192821964248775885f,
.00135592576302022234f,-7.17858090421302995e-4f,
-.00258084802575270346f,-.00349271130826168475f,
-.00346986299340960628f,-.00282285233351310182f,
-.00188103076404891354f,-8.895317183839476e-4f,
3.87912102631035228e-6f,7.28688540119691412e-4f,
.00126566373053457758f,.00162518158372674427f,
.00183203153216373172f,.00191588388990527909f,
.00190588846755546138f,.00182798982421825727f,
.0017038950642112153f,.00155097127171097686f,
.00138261421852276159f,.00120881424230064774f,
.00103676532638344962f,8.71437918068619115e-4f,
7.16080155297701002e-4f,5.72637002558129372e-4f,
4.42089819465802277e-4f,3.24724948503090564e-4f,
2.20342042730246599e-4f,1.28412898401353882e-4f,
4.82005924552095464e-5f };
static real beta[210] = { .0179988721413553309f,.00559964911064388073f,
.00288501402231132779f,.00180096606761053941f,
.00124753110589199202f,9.22878876572938311e-4f,
7.14430421727287357e-4f,5.71787281789704872e-4f,
4.69431007606481533e-4f,3.93232835462916638e-4f,
3.34818889318297664e-4f,2.88952148495751517e-4f,
2.52211615549573284e-4f,2.22280580798883327e-4f,
1.97541838033062524e-4f,1.76836855019718004e-4f,
1.59316899661821081e-4f,1.44347930197333986e-4f,
1.31448068119965379e-4f,1.20245444949302884e-4f,
1.10449144504599392e-4f,1.01828770740567258e-4f,
9.41998224204237509e-5f,8.74130545753834437e-5f,
8.13466262162801467e-5f,7.59002269646219339e-5f,
7.09906300634153481e-5f,6.65482874842468183e-5f,
6.25146958969275078e-5f,5.88403394426251749e-5f,
-.00149282953213429172f,-8.78204709546389328e-4f,
-5.02916549572034614e-4f,-2.94822138512746025e-4f,
-1.75463996970782828e-4f,-1.04008550460816434e-4f,
-5.96141953046457895e-5f,-3.1203892907609834e-5f,
-1.26089735980230047e-5f,-2.42892608575730389e-7f,
8.05996165414273571e-6f,1.36507009262147391e-5f,
1.73964125472926261e-5f,1.9867297884213378e-5f,
2.14463263790822639e-5f,2.23954659232456514e-5f,
2.28967783814712629e-5f,2.30785389811177817e-5f,
2.30321976080909144e-5f,2.28236073720348722e-5f,
2.25005881105292418e-5f,2.20981015361991429e-5f,
2.16418427448103905e-5f,2.11507649256220843e-5f,
2.06388749782170737e-5f,2.01165241997081666e-5f,
1.95913450141179244e-5f,1.9068936791043674e-5f,
1.85533719641636667e-5f,1.80475722259674218e-5f,
5.5221307672129279e-4f,4.47932581552384646e-4f,
2.79520653992020589e-4f,1.52468156198446602e-4f,
6.93271105657043598e-5f,1.76258683069991397e-5f,
-1.35744996343269136e-5f,-3.17972413350427135e-5f,
-4.18861861696693365e-5f,-4.69004889379141029e-5f,
-4.87665447413787352e-5f,-4.87010031186735069e-5f,
-4.74755620890086638e-5f,-4.55813058138628452e-5f,
-4.33309644511266036e-5f,-4.09230193157750364e-5f,
-3.84822638603221274e-5f,-3.60857167535410501e-5f,
-3.37793306123367417e-5f,-3.15888560772109621e-5f,
-2.95269561750807315e-5f,-2.75978914828335759e-5f,
-2.58006174666883713e-5f,-2.413083567612802e-5f,
-2.25823509518346033e-5f,-2.11479656768912971e-5f,
-1.98200638885294927e-5f,-1.85909870801065077e-5f,
-1.74532699844210224e-5f,-1.63997823854497997e-5f,
-4.74617796559959808e-4f,-4.77864567147321487e-4f,
-3.20390228067037603e-4f,-1.61105016119962282e-4f,
-4.25778101285435204e-5f,3.44571294294967503e-5f,
7.97092684075674924e-5f,1.031382367082722e-4f,
1.12466775262204158e-4f,1.13103642108481389e-4f,
1.08651634848774268e-4f,1.01437951597661973e-4f,
9.29298396593363896e-5f,8.40293133016089978e-5f,
7.52727991349134062e-5f,6.69632521975730872e-5f,
5.92564547323194704e-5f,5.22169308826975567e-5f,
4.58539485165360646e-5f,4.01445513891486808e-5f,
3.50481730031328081e-5f,3.05157995034346659e-5f,
2.64956119950516039e-5f,2.29363633690998152e-5f,
1.97893056664021636e-5f,1.70091984636412623e-5f,
1.45547428261524004e-5f,1.23886640995878413e-5f,
1.04775876076583236e-5f,8.79179954978479373e-6f,
7.36465810572578444e-4f,8.72790805146193976e-4f,
6.22614862573135066e-4f,2.85998154194304147e-4f,
3.84737672879366102e-6f,-1.87906003636971558e-4f,
-2.97603646594554535e-4f,-3.45998126832656348e-4f,
-3.53382470916037712e-4f,-3.35715635775048757e-4f,
-3.04321124789039809e-4f,-2.66722723047612821e-4f,
-2.27654214122819527e-4f,-1.89922611854562356e-4f,
-1.5505891859909387e-4f,-1.2377824076187363e-4f,
-9.62926147717644187e-5f,-7.25178327714425337e-5f,
-5.22070028895633801e-5f,-3.50347750511900522e-5f,
-2.06489761035551757e-5f,-8.70106096849767054e-6f,
1.1369868667510029e-6f,9.16426474122778849e-6f,
1.5647778542887262e-5f,2.08223629482466847e-5f,
2.48923381004595156e-5f,2.80340509574146325e-5f,
3.03987774629861915e-5f,3.21156731406700616e-5f,
-.00180182191963885708f,-.00243402962938042533f,
-.00183422663549856802f,-7.62204596354009765e-4f,
2.39079475256927218e-4f,9.49266117176881141e-4f,
.00134467449701540359f,.00148457495259449178f,
.00144732339830617591f,.00130268261285657186f,
.00110351597375642682f,8.86047440419791759e-4f,
6.73073208165665473e-4f,4.77603872856582378e-4f,
3.05991926358789362e-4f,1.6031569459472163e-4f,
4.00749555270613286e-5f,-5.66607461635251611e-5f,
-1.32506186772982638e-4f,-1.90296187989614057e-4f,
-2.32811450376937408e-4f,-2.62628811464668841e-4f,
-2.82050469867598672e-4f,-2.93081563192861167e-4f,
-2.97435962176316616e-4f,-2.96557334239348078e-4f,
-2.91647363312090861e-4f,-2.83696203837734166e-4f,
-2.73512317095673346e-4f,-2.6175015580676858e-4f,
.00638585891212050914f,.00962374215806377941f,
.00761878061207001043f,.00283219055545628054f,
-.0020984135201272009f,-.00573826764216626498f,
-.0077080424449541462f,-.00821011692264844401f,
-.00765824520346905413f,-.00647209729391045177f,
-.00499132412004966473f,-.0034561228971313328f,
-.00201785580014170775f,-7.59430686781961401e-4f,
2.84173631523859138e-4f,.00110891667586337403f,
.00172901493872728771f,.00216812590802684701f,
.00245357710494539735f,.00261281821058334862f,
.00267141039656276912f,.0026520307339598043f,
.00257411652877287315f,.00245389126236094427f,
.00230460058071795494f,.00213684837686712662f,
.00195896528478870911f,.00177737008679454412f,
.00159690280765839059f,.00142111975664438546f };
static real gama[30] = { .629960524947436582f,.251984209978974633f,
.154790300415655846f,.110713062416159013f,.0857309395527394825f,
.0697161316958684292f,.0586085671893713576f,.0504698873536310685f,
.0442600580689154809f,.0393720661543509966f,.0354283195924455368f,
.0321818857502098231f,.0294646240791157679f,.0271581677112934479f,
.0251768272973861779f,.0234570755306078891f,.0219508390134907203f,
.020621082823564624f,.0194388240897880846f,.0183810633800683158f,
.0174293213231963172f,.0165685837786612353f,.0157865285987918445f,
.0150729501494095594f,.0144193250839954639f,.0138184805735341786f,
.0132643378994276568f,.0127517121970498651f,.0122761545318762767f,
.0118338262398482403f };
static real ex1 = .333333333333333333f;
static real ex2 = .666666666666666667f;
static real hpi = 1.57079632679489662f;
/* System generated locals */
integer i__1, i__2, i__3;
real r__1;
doublereal d__1, d__2;
complex q__1, q__2, q__3, q__4, q__5;
/* Local variables */
static integer j, k, l, m;
static complex p[30], w;
static integer l1, l2;
static complex t2, w2;
static real ac, ap[30];
static complex cr[14], dr[14], za, zb, zc;
static integer is, jr;
static real pp, wi;
static integer ju, ks, lr;
static complex up[14];
static real wr, aw2;
static integer kp1;
static real ang, fn13, fn23;
static integer ias, ibs;
static real zci;
static complex tfn;
static real zcr;
static complex zth;
static integer lrp1;
static complex rfn13, cfnu;
static real atol, btol;
static integer kmax;
static complex zeta, ptfn, suma, sumb;
static real azth, rfnu, zthi, test, tsti;
static complex rzth;
static real zthr, tstr, rfnu2, zetai, asumi, bsumi, zetar, asumr, bsumr;
static complex rtzta, przth;
extern doublereal r1mach_(integer *);
/* ***BEGIN PROLOGUE CUNHJ */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to CBESI and CBESK */
/* ***LIBRARY SLATEC */
/* ***TYPE ALL (CUNHJ-A, ZUNHJ-A) */
/* ***AUTHOR Amos, D. E., (SNL) */
/* ***DESCRIPTION */
/* REFERENCES */
/* HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ AND I.A. */
/* STEGUN, AMS55, NATIONAL BUREAU OF STANDARDS, 1965, CHAPTER 9. */
/* ASYMPTOTICS AND SPECIAL FUNCTIONS BY F.W.J. OLVER, ACADEMIC */
/* PRESS, N.Y., 1974, PAGE 420 */
/* ABSTRACT */
/* CUNHJ COMPUTES PARAMETERS FOR BESSEL FUNCTIONS C(FNU,Z) = */
/* J(FNU,Z), Y(FNU,Z) OR H(I,FNU,Z) I=1,2 FOR LARGE ORDERS FNU */
/* BY MEANS OF THE UNIFORM ASYMPTOTIC EXPANSION */
/* C(FNU,Z)=C1*PHI*( ASUM*AIRY(ARG) + C2*BSUM*DAIRY(ARG) ) */
/* FOR PROPER CHOICES OF C1, C2, AIRY AND DAIRY WHERE AIRY IS */
/* AN AIRY FUNCTION AND DAIRY IS ITS DERIVATIVE. */
/* (2/3)*FNU*ZETA**1.5 = ZETA1-ZETA2, */
/* ZETA1=0.5*FNU*CLOG((1+W)/(1-W)), ZETA2=FNU*W FOR SCALING */
/* PURPOSES IN AIRY FUNCTIONS FROM CAIRY OR CBIRY. */
/* MCONJ=SIGN OF AIMAG(Z), BUT IS AMBIGUOUS WHEN Z IS REAL AND */
/* MUST BE SPECIFIED. IPMTR=0 RETURNS ALL PARAMETERS. IPMTR= */
/* 1 COMPUTES ALL EXCEPT ASUM AND BSUM. */
/* ***SEE ALSO CBESI, CBESK */
/* ***ROUTINES CALLED R1MACH */
/* ***REVISION HISTORY (YYMMDD) */
/* 830501 DATE WRITTEN */
/* 910415 Prologue converted to Version 4.0 format. (BAB) */
/* ***END PROLOGUE CUNHJ */
/* ***FIRST EXECUTABLE STATEMENT CUNHJ */
rfnu = 1.f / *fnu;
/* ZB = Z*CMPLX(RFNU,0.0E0) */
/* ----------------------------------------------------------------------- */
/* OVERFLOW TEST (Z/FNU TOO SMALL) */
/* ----------------------------------------------------------------------- */
tstr = z__->r;
tsti = r_imag(z__);
test = r1mach_(&c__1) * 1e3f;
ac = *fnu * test;
if (dabs(tstr) > ac || dabs(tsti) > ac) {
goto L15;
}
ac = (r__1 = log(test), dabs(r__1)) * 2.f + *fnu;
q__1.r = ac, q__1.i = 0.f;
zeta1->r = q__1.r, zeta1->i = q__1.i;
q__1.r = *fnu, q__1.i = 0.f;
zeta2->r = q__1.r, zeta2->i = q__1.i;
phi->r = cone.r, phi->i = cone.i;
arg->r = cone.r, arg->i = cone.i;
return 0;
L15:
q__2.r = rfnu, q__2.i = 0.f;
q__1.r = z__->r * q__2.r - z__->i * q__2.i, q__1.i = z__->r * q__2.i +
z__->i * q__2.r;
zb.r = q__1.r, zb.i = q__1.i;
rfnu2 = rfnu * rfnu;
/* ----------------------------------------------------------------------- */
/* COMPUTE IN THE FOURTH QUADRANT */
/* ----------------------------------------------------------------------- */
d__1 = (doublereal) (*fnu);
d__2 = (doublereal) ex1;
fn13 = pow_dd(&d__1, &d__2);
fn23 = fn13 * fn13;
r__1 = 1.f / fn13;
q__1.r = r__1, q__1.i = 0.f;
rfn13.r = q__1.r, rfn13.i = q__1.i;
q__2.r = zb.r * zb.r - zb.i * zb.i, q__2.i = zb.r * zb.i + zb.i * zb.r;
q__1.r = cone.r - q__2.r, q__1.i = cone.i - q__2.i;
w2.r = q__1.r, w2.i = q__1.i;
aw2 = c_abs(&w2);
if (aw2 > .25f) {
goto L130;
}
/* ----------------------------------------------------------------------- */
/* POWER SERIES FOR ABS(W2).LE.0.25E0 */
/* ----------------------------------------------------------------------- */
k = 1;
p[0].r = cone.r, p[0].i = cone.i;
q__1.r = gama[0], q__1.i = 0.f;
suma.r = q__1.r, suma.i = q__1.i;
ap[0] = 1.f;
if (aw2 < *tol) {
goto L20;
}
for (k = 2; k <= 30; ++k) {
i__1 = k - 1;
i__2 = k - 2;
q__1.r = p[i__2].r * w2.r - p[i__2].i * w2.i, q__1.i = p[i__2].r *
w2.i + p[i__2].i * w2.r;
p[i__1].r = q__1.r, p[i__1].i = q__1.i;
i__1 = k - 1;
i__2 = k - 1;
q__3.r = gama[i__2], q__3.i = 0.f;
q__2.r = p[i__1].r * q__3.r - p[i__1].i * q__3.i, q__2.i = p[i__1].r *
q__3.i + p[i__1].i * q__3.r;
q__1.r = suma.r + q__2.r, q__1.i = suma.i + q__2.i;
suma.r = q__1.r, suma.i = q__1.i;
ap[k - 1] = ap[k - 2] * aw2;
if (ap[k - 1] < *tol) {
goto L20;
}
/* L10: */
}
k = 30;
L20:
kmax = k;
q__1.r = w2.r * suma.r - w2.i * suma.i, q__1.i = w2.r * suma.i + w2.i *
suma.r;
zeta.r = q__1.r, zeta.i = q__1.i;
q__2.r = fn23, q__2.i = 0.f;
q__1.r = zeta.r * q__2.r - zeta.i * q__2.i, q__1.i = zeta.r * q__2.i +
zeta.i * q__2.r;
arg->r = q__1.r, arg->i = q__1.i;
c_sqrt(&q__1, &suma);
za.r = q__1.r, za.i = q__1.i;
c_sqrt(&q__2, &w2);
q__3.r = *fnu, q__3.i = 0.f;
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;
zeta2->r = q__1.r, zeta2->i = q__1.i;
q__4.r = zeta.r * za.r - zeta.i * za.i, q__4.i = zeta.r * za.i + zeta.i *
za.r;
q__5.r = ex2, q__5.i = 0.f;
q__3.r = q__4.r * q__5.r - q__4.i * q__5.i, q__3.i = q__4.r * q__5.i +
q__4.i * q__5.r;
q__2.r = cone.r + q__3.r, q__2.i = cone.i + q__3.i;
q__1.r = zeta2->r * q__2.r - zeta2->i * q__2.i, q__1.i = zeta2->r *
q__2.i + zeta2->i * q__2.r;
zeta1->r = q__1.r, zeta1->i = q__1.i;
q__1.r = za.r + za.r, q__1.i = za.i + za.i;
za.r = q__1.r, za.i = q__1.i;
c_sqrt(&q__2, &za);
q__1.r = q__2.r * rfn13.r - q__2.i * rfn13.i, q__1.i = q__2.r * rfn13.i +
q__2.i * rfn13.r;
phi->r = q__1.r, phi->i = q__1.i;
if (*ipmtr == 1) {
goto L120;
}
/* ----------------------------------------------------------------------- */
/* SUM SERIES FOR ASUM AND BSUM */
/* ----------------------------------------------------------------------- */
sumb.r = czero.r, sumb.i = czero.i;
i__1 = kmax;
for (k = 1; k <= i__1; ++k) {
i__2 = k - 1;
i__3 = k - 1;
q__3.r = beta[i__3], q__3.i = 0.f;
q__2.r = p[i__2].r * q__3.r - p[i__2].i * q__3.i, q__2.i = p[i__2].r *
q__3.i + p[i__2].i * q__3.r;
q__1.r = sumb.r + q__2.r, q__1.i = sumb.i + q__2.i;
sumb.r = q__1.r, sumb.i = q__1.i;
/* L30: */
}
asum->r = czero.r, asum->i = czero.i;
bsum->r = sumb.r, bsum->i = sumb.i;
l1 = 0;
l2 = 30;
btol = *tol * c_abs(bsum);
atol = *tol;
pp = 1.f;
ias = 0;
ibs = 0;
if (rfnu2 < *tol) {
goto L110;
}
for (is = 2; is <= 7; ++is) {
atol /= rfnu2;
pp *= rfnu2;
if (ias == 1) {
goto L60;
}
suma.r = czero.r, suma.i = czero.i;
i__1 = kmax;
for (k = 1; k <= i__1; ++k) {
m = l1 + k;
i__2 = k - 1;
i__3 = m - 1;
q__3.r = alfa[i__3], q__3.i = 0.f;
q__2.r = p[i__2].r * q__3.r - p[i__2].i * q__3.i, q__2.i = p[i__2]
.r * q__3.i + p[i__2].i * q__3.r;
q__1.r = suma.r + q__2.r, q__1.i = suma.i + q__2.i;
suma.r = q__1.r, suma.i = q__1.i;
if (ap[k - 1] < atol) {
goto L50;
}
/* L40: */
}
L50:
q__3.r = pp, q__3.i = 0.f;
q__2.r = suma.r * q__3.r - suma.i * q__3.i, q__2.i = suma.r * q__3.i
+ suma.i * q__3.r;
q__1.r = asum->r + q__2.r, q__1.i = asum->i + q__2.i;
asum->r = q__1.r, asum->i = q__1.i;
if (pp < *tol) {
ias = 1;
}
L60:
if (ibs == 1) {
goto L90;
}
sumb.r = czero.r, sumb.i = czero.i;
i__1 = kmax;
for (k = 1; k <= i__1; ++k) {
m = l2 + k;
i__2 = k - 1;
i__3 = m - 1;
q__3.r = beta[i__3], q__3.i = 0.f;
q__2.r = p[i__2].r * q__3.r - p[i__2].i * q__3.i, q__2.i = p[i__2]
.r * q__3.i + p[i__2].i * q__3.r;
q__1.r = sumb.r + q__2.r, q__1.i = sumb.i + q__2.i;
sumb.r = q__1.r, sumb.i = q__1.i;
if (ap[k - 1] < atol) {
goto L80;
}
/* L70: */
}
L80:
q__3.r = pp, q__3.i = 0.f;
q__2.r = sumb.r * q__3.r - sumb.i * q__3.i, q__2.i = sumb.r * q__3.i
+ sumb.i * q__3.r;
q__1.r = bsum->r + q__2.r, q__1.i = bsum->i + q__2.i;
bsum->r = q__1.r, bsum->i = q__1.i;
if (pp < btol) {
ibs = 1;
}
L90:
if (ias == 1 && ibs == 1) {
goto L110;
}
l1 += 30;
l2 += 30;
/* L100: */
}
L110:
q__1.r = asum->r + cone.r, q__1.i = asum->i + cone.i;
asum->r = q__1.r, asum->i = q__1.i;
pp = rfnu * rfn13.r;
q__2.r = pp, q__2.i = 0.f;
q__1.r = bsum->r * q__2.r - bsum->i * q__2.i, q__1.i = bsum->r * q__2.i +
bsum->i * q__2.r;
bsum->r = q__1.r, bsum->i = q__1.i;
L120:
return 0;
/* ----------------------------------------------------------------------- */
/* ABS(W2).GT.0.25E0 */
/* ----------------------------------------------------------------------- */
L130:
c_sqrt(&q__1, &w2);
w.r = q__1.r, w.i = q__1.i;
wr = w.r;
wi = r_imag(&w);
if (wr < 0.f) {
wr = 0.f;
}
if (wi < 0.f) {
wi = 0.f;
}
q__1.r = wr, q__1.i = wi;
w.r = q__1.r, w.i = q__1.i;
q__2.r = cone.r + w.r, q__2.i = cone.i + w.i;
c_div(&q__1, &q__2, &zb);
za.r = q__1.r, za.i = q__1.i;
c_log(&q__1, &za);
zc.r = q__1.r, zc.i = q__1.i;
zcr = zc.r;
zci = r_imag(&zc);
if (zci < 0.f) {
zci = 0.f;
}
if (zci > hpi) {
zci = hpi;
}
if (zcr < 0.f) {
zcr = 0.f;
}
q__1.r = zcr, q__1.i = zci;
zc.r = q__1.r, zc.i = q__1.i;
q__2.r = zc.r - w.r, q__2.i = zc.i - w.i;
q__1.r = q__2.r * 1.5f - q__2.i * 0.f, q__1.i = q__2.r * 0.f + q__2.i *
1.5f;
zth.r = q__1.r, zth.i = q__1.i;
q__1.r = *fnu, q__1.i = 0.f;
cfnu.r = q__1.r, cfnu.i = q__1.i;
q__1.r = zc.r * cfnu.r - zc.i * cfnu.i, q__1.i = zc.r * cfnu.i + zc.i *
cfnu.r;
zeta1->r = q__1.r, zeta1->i = q__1.i;
q__1.r = w.r * cfnu.r - w.i * cfnu.i, q__1.i = w.r * cfnu.i + w.i *
cfnu.r;
zeta2->r = q__1.r, zeta2->i = q__1.i;
azth = c_abs(&zth);
zthr = zth.r;
zthi = r_imag(&zth);
ang = thpi;
if (zthr >= 0.f && zthi < 0.f) {
goto L140;
}
ang = hpi;
if (zthr == 0.f) {
goto L140;
}
ang = atan(zthi / zthr);
if (zthr < 0.f) {
ang += pi;
}
L140:
d__1 = (doublereal) azth;
d__2 = (doublereal) ex2;
pp = pow_dd(&d__1, &d__2);
ang *= ex2;
zetar = pp * cos(ang);
zetai = pp * sin(ang);
if (zetai < 0.f) {
zetai = 0.f;
}
q__1.r = zetar, q__1.i = zetai;
zeta.r = q__1.r, zeta.i = q__1.i;
q__2.r = fn23, q__2.i = 0.f;
q__1.r = zeta.r * q__2.r - zeta.i * q__2.i, q__1.i = zeta.r * q__2.i +
zeta.i * q__2.r;
arg->r = q__1.r, arg->i = q__1.i;
c_div(&q__1, &zth, &zeta);
rtzta.r = q__1.r, rtzta.i = q__1.i;
c_div(&q__1, &rtzta, &w);
za.r = q__1.r, za.i = q__1.i;
q__3.r = za.r + za.r, q__3.i = za.i + za.i;
c_sqrt(&q__2, &q__3);
q__1.r = q__2.r * rfn13.r - q__2.i * rfn13.i, q__1.i = q__2.r * rfn13.i +
q__2.i * rfn13.r;
phi->r = q__1.r, phi->i = q__1.i;
if (*ipmtr == 1) {
goto L120;
}
q__2.r = rfnu, q__2.i = 0.f;
c_div(&q__1, &q__2, &w);
tfn.r = q__1.r, tfn.i = q__1.i;
q__2.r = rfnu, q__2.i = 0.f;
c_div(&q__1, &q__2, &zth);
rzth.r = q__1.r, rzth.i = q__1.i;
q__2.r = ar[1], q__2.i = 0.f;
q__1.r = rzth.r * q__2.r - rzth.i * q__2.i, q__1.i = rzth.r * q__2.i +
rzth.i * q__2.r;
zc.r = q__1.r, zc.i = q__1.i;
c_div(&q__1, &cone, &w2);
t2.r = q__1.r, t2.i = q__1.i;
q__4.r = c__[1], q__4.i = 0.f;
q__3.r = t2.r * q__4.r - t2.i * q__4.i, q__3.i = t2.r * q__4.i + t2.i *
q__4.r;
q__5.r = c__[2], q__5.i = 0.f;
q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
q__1.r = q__2.r * tfn.r - q__2.i * tfn.i, q__1.i = q__2.r * tfn.i +
q__2.i * tfn.r;
up[1].r = q__1.r, up[1].i = q__1.i;
q__1.r = up[1].r + zc.r, q__1.i = up[1].i + zc.i;
bsum->r = q__1.r, bsum->i = q__1.i;
asum->r = czero.r, asum->i = czero.i;
if (rfnu < *tol) {
goto L220;
}
przth.r = rzth.r, przth.i = rzth.i;
ptfn.r = tfn.r, ptfn.i = tfn.i;
up[0].r = cone.r, up[0].i = cone.i;
pp = 1.f;
bsumr = bsum->r;
bsumi = r_imag(bsum);
btol = *tol * (dabs(bsumr) + dabs(bsumi));
ks = 0;
kp1 = 2;
l = 3;
ias = 0;
ibs = 0;
for (lr = 2; lr <= 12; lr += 2) {
lrp1 = lr + 1;
/* ----------------------------------------------------------------------- */
/* COMPUTE TWO ADDITIONAL CR, DR, AND UP FOR TWO MORE TERMS IN */
/* NEXT SUMA AND SUMB */
/* ----------------------------------------------------------------------- */
i__1 = lrp1;
for (k = lr; k <= i__1; ++k) {
++ks;
++kp1;
++l;
i__2 = l - 1;
q__1.r = c__[i__2], q__1.i = 0.f;
za.r = q__1.r, za.i = q__1.i;
i__2 = kp1;
for (j = 2; j <= i__2; ++j) {
++l;
q__2.r = za.r * t2.r - za.i * t2.i, q__2.i = za.r * t2.i +
za.i * t2.r;
i__3 = l - 1;
q__3.r = c__[i__3], q__3.i = 0.f;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
za.r = q__1.r, za.i = q__1.i;
/* L150: */
}
q__1.r = ptfn.r * tfn.r - ptfn.i * tfn.i, q__1.i = ptfn.r * tfn.i
+ ptfn.i * tfn.r;
ptfn.r = q__1.r, ptfn.i = q__1.i;
i__2 = kp1 - 1;
q__1.r = ptfn.r * za.r - ptfn.i * za.i, q__1.i = ptfn.r * za.i +
ptfn.i * za.r;
up[i__2].r = q__1.r, up[i__2].i = q__1.i;
i__2 = ks - 1;
i__3 = ks;
q__2.r = br[i__3], q__2.i = 0.f;
q__1.r = przth.r * q__2.r - przth.i * q__2.i, q__1.i = przth.r *
q__2.i + przth.i * q__2.r;
cr[i__2].r = q__1.r, cr[i__2].i = q__1.i;
q__1.r = przth.r * rzth.r - przth.i * rzth.i, q__1.i = przth.r *
rzth.i + przth.i * rzth.r;
przth.r = q__1.r, przth.i = q__1.i;
i__2 = ks - 1;
i__3 = ks + 1;
q__2.r = ar[i__3], q__2.i = 0.f;
q__1.r = przth.r * q__2.r - przth.i * q__2.i, q__1.i = przth.r *
q__2.i + przth.i * q__2.r;
dr[i__2].r = q__1.r, dr[i__2].i = q__1.i;
/* L160: */
}
pp *= rfnu2;
if (ias == 1) {
goto L180;
}
i__1 = lrp1 - 1;
suma.r = up[i__1].r, suma.i = up[i__1].i;
ju = lrp1;
i__1 = lr;
for (jr = 1; jr <= i__1; ++jr) {
--ju;
i__2 = jr - 1;
i__3 = ju - 1;
q__2.r = cr[i__2].r * up[i__3].r - cr[i__2].i * up[i__3].i,
q__2.i = cr[i__2].r * up[i__3].i + cr[i__2].i * up[i__3]
.r;
q__1.r = suma.r + q__2.r, q__1.i = suma.i + q__2.i;
suma.r = q__1.r, suma.i = q__1.i;
/* L170: */
}
q__1.r = asum->r + suma.r, q__1.i = asum->i + suma.i;
asum->r = q__1.r, asum->i = q__1.i;
asumr = asum->r;
asumi = r_imag(asum);
test = dabs(asumr) + dabs(asumi);
if (pp < *tol && test < *tol) {
ias = 1;
}
L180:
if (ibs == 1) {
goto L200;
}
i__1 = lr + 1;
i__2 = lrp1 - 1;
q__2.r = up[i__2].r * zc.r - up[i__2].i * zc.i, q__2.i = up[i__2].r *
zc.i + up[i__2].i * zc.r;
q__1.r = up[i__1].r + q__2.r, q__1.i = up[i__1].i + q__2.i;
sumb.r = q__1.r, sumb.i = q__1.i;
ju = lrp1;
i__1 = lr;
for (jr = 1; jr <= i__1; ++jr) {
--ju;
i__2 = jr - 1;
i__3 = ju - 1;
q__2.r = dr[i__2].r * up[i__3].r - dr[i__2].i * up[i__3].i,
q__2.i = dr[i__2].r * up[i__3].i + dr[i__2].i * up[i__3]
.r;
q__1.r = sumb.r + q__2.r, q__1.i = sumb.i + q__2.i;
sumb.r = q__1.r, sumb.i = q__1.i;
/* L190: */
}
q__1.r = bsum->r + sumb.r, q__1.i = bsum->i + sumb.i;
bsum->r = q__1.r, bsum->i = q__1.i;
bsumr = bsum->r;
bsumi = r_imag(bsum);
test = dabs(bsumr) + dabs(bsumi);
if (pp < btol && test < *tol) {
ibs = 1;
}
L200:
if (ias == 1 && ibs == 1) {
goto L220;
}
/* L210: */
}
L220:
q__1.r = asum->r + cone.r, q__1.i = asum->i + cone.i;
asum->r = q__1.r, asum->i = q__1.i;
q__3.r = -bsum->r, q__3.i = -bsum->i;
q__2.r = q__3.r * rfn13.r - q__3.i * rfn13.i, q__2.i = q__3.r * rfn13.i +
q__3.i * rfn13.r;
c_div(&q__1, &q__2, &rtzta);
bsum->r = q__1.r, bsum->i = q__1.i;
goto L120;
} /* cunhj_ */
/* Subroutine */ int claic1_(integer *job, integer *j, complex *x, real *sest,
complex *w, complex *gamma, real *sestpr, complex *s, complex *c__)
{
/* System generated locals */
real r__1, r__2;
complex q__1, q__2, q__3, q__4, q__5, q__6;
/* Local variables */
real b, t, s1, s2, scl, eps, tmp;
complex sine;
real test, zeta1, zeta2;
complex alpha;
real norma, absgam, absalp;
complex cosine;
real absest;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* CLAIC1 applies one step of incremental condition estimation in */
/* its simplest version: */
/* Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j */
/* lower triangular matrix L, such that */
/* twonorm(L*x) = sest */
/* Then CLAIC1 computes sestpr, s, c such that */
/* the vector */
/* [ s*x ] */
/* xhat = [ c ] */
/* is an approximate singular vector of */
/* [ L 0 ] */
/* Lhat = [ w' gamma ] */
/* in the sense that */
/* twonorm(Lhat*xhat) = sestpr. */
/* Depending on JOB, an estimate for the largest or smallest singular */
/* value is computed. */
/* Note that [s c]' and sestpr**2 is an eigenpair of the system */
/* diag(sest*sest, 0) + [alpha gamma] * [ conjg(alpha) ] */
/* [ conjg(gamma) ] */
/* where alpha = conjg(x)'*w. */
/* Arguments */
/* ========= */
/* JOB (input) INTEGER */
/* = 1: an estimate for the largest singular value is computed. */
/* = 2: an estimate for the smallest singular value is computed. */
/* J (input) INTEGER */
/* Length of X and W */
/* X (input) COMPLEX array, dimension (J) */
/* The j-vector x. */
/* SEST (input) REAL */
/* Estimated singular value of j by j matrix L */
/* W (input) COMPLEX array, dimension (J) */
/* The j-vector w. */
/* GAMMA (input) COMPLEX */
/* The diagonal element gamma. */
/* SESTPR (output) REAL */
/* Estimated singular value of (j+1) by (j+1) matrix Lhat. */
/* S (output) COMPLEX */
/* Sine needed in forming xhat. */
/* C (output) COMPLEX */
/* Cosine needed in forming xhat. */
/* ===================================================================== */
/* Parameter adjustments */
--w;
--x;
/* Function Body */
eps = slamch_("Epsilon");
cdotc_(&q__1, j, &x[1], &c__1, &w[1], &c__1);
alpha.r = q__1.r, alpha.i = q__1.i;
absalp = c_abs(&alpha);
absgam = c_abs(gamma);
absest = dabs(*sest);
if (*job == 1) {
/* Estimating largest singular value */
/* special cases */
if (*sest == 0.f) {
s1 = dmax(absgam,absalp);
if (s1 == 0.f) {
s->r = 0.f, s->i = 0.f;
c__->r = 1.f, c__->i = 0.f;
*sestpr = 0.f;
} else {
q__1.r = alpha.r / s1, q__1.i = alpha.i / s1;
s->r = q__1.r, s->i = q__1.i;
q__1.r = gamma->r / s1, q__1.i = gamma->i / s1;
c__->r = q__1.r, c__->i = q__1.i;
r_cnjg(&q__4, s);
q__3.r = s->r * q__4.r - s->i * q__4.i, q__3.i = s->r *
q__4.i + s->i * q__4.r;
r_cnjg(&q__6, c__);
q__5.r = c__->r * q__6.r - c__->i * q__6.i, q__5.i = c__->r *
q__6.i + c__->i * q__6.r;
q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
c_sqrt(&q__1, &q__2);
tmp = q__1.r;
q__1.r = s->r / tmp, q__1.i = s->i / tmp;
s->r = q__1.r, s->i = q__1.i;
q__1.r = c__->r / tmp, q__1.i = c__->i / tmp;
c__->r = q__1.r, c__->i = q__1.i;
*sestpr = s1 * tmp;
}
return 0;
} else if (absgam <= eps * absest) {
s->r = 1.f, s->i = 0.f;
c__->r = 0.f, c__->i = 0.f;
tmp = dmax(absest,absalp);
s1 = absest / tmp;
s2 = absalp / tmp;
*sestpr = tmp * sqrt(s1 * s1 + s2 * s2);
return 0;
} else if (absalp <= eps * absest) {
s1 = absgam;
s2 = absest;
if (s1 <= s2) {
s->r = 1.f, s->i = 0.f;
c__->r = 0.f, c__->i = 0.f;
*sestpr = s2;
} else {
s->r = 0.f, s->i = 0.f;
c__->r = 1.f, c__->i = 0.f;
*sestpr = s1;
}
return 0;
} else if (absest <= eps * absalp || absest <= eps * absgam) {
s1 = absgam;
s2 = absalp;
if (s1 <= s2) {
tmp = s1 / s2;
scl = sqrt(tmp * tmp + 1.f);
*sestpr = s2 * scl;
q__2.r = alpha.r / s2, q__2.i = alpha.i / s2;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
s->r = q__1.r, s->i = q__1.i;
q__2.r = gamma->r / s2, q__2.i = gamma->i / s2;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
c__->r = q__1.r, c__->i = q__1.i;
} else {
tmp = s2 / s1;
scl = sqrt(tmp * tmp + 1.f);
*sestpr = s1 * scl;
q__2.r = alpha.r / s1, q__2.i = alpha.i / s1;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
s->r = q__1.r, s->i = q__1.i;
q__2.r = gamma->r / s1, q__2.i = gamma->i / s1;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
c__->r = q__1.r, c__->i = q__1.i;
}
return 0;
} else {
/* normal case */
zeta1 = absalp / absest;
zeta2 = absgam / absest;
b = (1.f - zeta1 * zeta1 - zeta2 * zeta2) * .5f;
r__1 = zeta1 * zeta1;
c__->r = r__1, c__->i = 0.f;
if (b > 0.f) {
r__1 = b * b;
q__4.r = r__1 + c__->r, q__4.i = c__->i;
c_sqrt(&q__3, &q__4);
q__2.r = b + q__3.r, q__2.i = q__3.i;
c_div(&q__1, c__, &q__2);
t = q__1.r;
} else {
r__1 = b * b;
q__3.r = r__1 + c__->r, q__3.i = c__->i;
c_sqrt(&q__2, &q__3);
q__1.r = q__2.r - b, q__1.i = q__2.i;
t = q__1.r;
}
q__3.r = alpha.r / absest, q__3.i = alpha.i / absest;
q__2.r = -q__3.r, q__2.i = -q__3.i;
q__1.r = q__2.r / t, q__1.i = q__2.i / t;
sine.r = q__1.r, sine.i = q__1.i;
q__3.r = gamma->r / absest, q__3.i = gamma->i / absest;
q__2.r = -q__3.r, q__2.i = -q__3.i;
r__1 = t + 1.f;
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
cosine.r = q__1.r, cosine.i = q__1.i;
r_cnjg(&q__4, &sine);
q__3.r = sine.r * q__4.r - sine.i * q__4.i, q__3.i = sine.r *
q__4.i + sine.i * q__4.r;
r_cnjg(&q__6, &cosine);
q__5.r = cosine.r * q__6.r - cosine.i * q__6.i, q__5.i = cosine.r
* q__6.i + cosine.i * q__6.r;
q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
c_sqrt(&q__1, &q__2);
tmp = q__1.r;
q__1.r = sine.r / tmp, q__1.i = sine.i / tmp;
s->r = q__1.r, s->i = q__1.i;
q__1.r = cosine.r / tmp, q__1.i = cosine.i / tmp;
c__->r = q__1.r, c__->i = q__1.i;
*sestpr = sqrt(t + 1.f) * absest;
return 0;
}
} else if (*job == 2) {
/* Estimating smallest singular value */
/* special cases */
if (*sest == 0.f) {
*sestpr = 0.f;
if (dmax(absgam,absalp) == 0.f) {
sine.r = 1.f, sine.i = 0.f;
cosine.r = 0.f, cosine.i = 0.f;
} else {
r_cnjg(&q__2, gamma);
q__1.r = -q__2.r, q__1.i = -q__2.i;
sine.r = q__1.r, sine.i = q__1.i;
r_cnjg(&q__1, &alpha);
cosine.r = q__1.r, cosine.i = q__1.i;
}
/* Computing MAX */
r__1 = c_abs(&sine), r__2 = c_abs(&cosine);
s1 = dmax(r__1,r__2);
q__1.r = sine.r / s1, q__1.i = sine.i / s1;
s->r = q__1.r, s->i = q__1.i;
q__1.r = cosine.r / s1, q__1.i = cosine.i / s1;
c__->r = q__1.r, c__->i = q__1.i;
r_cnjg(&q__4, s);
q__3.r = s->r * q__4.r - s->i * q__4.i, q__3.i = s->r * q__4.i +
s->i * q__4.r;
r_cnjg(&q__6, c__);
q__5.r = c__->r * q__6.r - c__->i * q__6.i, q__5.i = c__->r *
q__6.i + c__->i * q__6.r;
q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
c_sqrt(&q__1, &q__2);
tmp = q__1.r;
q__1.r = s->r / tmp, q__1.i = s->i / tmp;
s->r = q__1.r, s->i = q__1.i;
q__1.r = c__->r / tmp, q__1.i = c__->i / tmp;
c__->r = q__1.r, c__->i = q__1.i;
return 0;
} else if (absgam <= eps * absest) {
s->r = 0.f, s->i = 0.f;
c__->r = 1.f, c__->i = 0.f;
*sestpr = absgam;
return 0;
} else if (absalp <= eps * absest) {
s1 = absgam;
s2 = absest;
if (s1 <= s2) {
s->r = 0.f, s->i = 0.f;
c__->r = 1.f, c__->i = 0.f;
*sestpr = s1;
} else {
s->r = 1.f, s->i = 0.f;
c__->r = 0.f, c__->i = 0.f;
*sestpr = s2;
}
return 0;
} else if (absest <= eps * absalp || absest <= eps * absgam) {
s1 = absgam;
s2 = absalp;
if (s1 <= s2) {
tmp = s1 / s2;
scl = sqrt(tmp * tmp + 1.f);
*sestpr = absest * (tmp / scl);
r_cnjg(&q__4, gamma);
q__3.r = q__4.r / s2, q__3.i = q__4.i / s2;
q__2.r = -q__3.r, q__2.i = -q__3.i;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
s->r = q__1.r, s->i = q__1.i;
r_cnjg(&q__3, &alpha);
q__2.r = q__3.r / s2, q__2.i = q__3.i / s2;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
c__->r = q__1.r, c__->i = q__1.i;
} else {
tmp = s2 / s1;
scl = sqrt(tmp * tmp + 1.f);
*sestpr = absest / scl;
r_cnjg(&q__4, gamma);
q__3.r = q__4.r / s1, q__3.i = q__4.i / s1;
q__2.r = -q__3.r, q__2.i = -q__3.i;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
s->r = q__1.r, s->i = q__1.i;
r_cnjg(&q__3, &alpha);
q__2.r = q__3.r / s1, q__2.i = q__3.i / s1;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
c__->r = q__1.r, c__->i = q__1.i;
}
return 0;
} else {
/* normal case */
zeta1 = absalp / absest;
zeta2 = absgam / absest;
/* Computing MAX */
r__1 = zeta1 * zeta1 + 1.f + zeta1 * zeta2, r__2 = zeta1 * zeta2
+ zeta2 * zeta2;
norma = dmax(r__1,r__2);
/* See if root is closer to zero or to ONE */
test = (zeta1 - zeta2) * 2.f * (zeta1 + zeta2) + 1.f;
if (test >= 0.f) {
/* root is close to zero, compute directly */
b = (zeta1 * zeta1 + zeta2 * zeta2 + 1.f) * .5f;
r__1 = zeta2 * zeta2;
c__->r = r__1, c__->i = 0.f;
r__2 = b * b;
q__2.r = r__2 - c__->r, q__2.i = -c__->i;
r__1 = b + sqrt(c_abs(&q__2));
q__1.r = c__->r / r__1, q__1.i = c__->i / r__1;
t = q__1.r;
q__2.r = alpha.r / absest, q__2.i = alpha.i / absest;
r__1 = 1.f - t;
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
sine.r = q__1.r, sine.i = q__1.i;
q__3.r = gamma->r / absest, q__3.i = gamma->i / absest;
q__2.r = -q__3.r, q__2.i = -q__3.i;
q__1.r = q__2.r / t, q__1.i = q__2.i / t;
cosine.r = q__1.r, cosine.i = q__1.i;
*sestpr = sqrt(t + eps * 4.f * eps * norma) * absest;
} else {
/* root is closer to ONE, shift by that amount */
b = (zeta2 * zeta2 + zeta1 * zeta1 - 1.f) * .5f;
r__1 = zeta1 * zeta1;
c__->r = r__1, c__->i = 0.f;
if (b >= 0.f) {
q__2.r = -c__->r, q__2.i = -c__->i;
r__1 = b * b;
q__5.r = r__1 + c__->r, q__5.i = c__->i;
c_sqrt(&q__4, &q__5);
q__3.r = b + q__4.r, q__3.i = q__4.i;
c_div(&q__1, &q__2, &q__3);
t = q__1.r;
} else {
r__1 = b * b;
q__3.r = r__1 + c__->r, q__3.i = c__->i;
c_sqrt(&q__2, &q__3);
q__1.r = b - q__2.r, q__1.i = -q__2.i;
t = q__1.r;
}
q__3.r = alpha.r / absest, q__3.i = alpha.i / absest;
q__2.r = -q__3.r, q__2.i = -q__3.i;
q__1.r = q__2.r / t, q__1.i = q__2.i / t;
sine.r = q__1.r, sine.i = q__1.i;
q__3.r = gamma->r / absest, q__3.i = gamma->i / absest;
q__2.r = -q__3.r, q__2.i = -q__3.i;
r__1 = t + 1.f;
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
cosine.r = q__1.r, cosine.i = q__1.i;
*sestpr = sqrt(t + 1.f + eps * 4.f * eps * norma) * absest;
}
r_cnjg(&q__4, &sine);
q__3.r = sine.r * q__4.r - sine.i * q__4.i, q__3.i = sine.r *
q__4.i + sine.i * q__4.r;
r_cnjg(&q__6, &cosine);
q__5.r = cosine.r * q__6.r - cosine.i * q__6.i, q__5.i = cosine.r
* q__6.i + cosine.i * q__6.r;
q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
c_sqrt(&q__1, &q__2);
tmp = q__1.r;
q__1.r = sine.r / tmp, q__1.i = sine.i / tmp;
s->r = q__1.r, s->i = q__1.i;
q__1.r = cosine.r / tmp, q__1.i = cosine.i / tmp;
c__->r = q__1.r, c__->i = q__1.i;
return 0;
}
}
return 0;
/* End of CLAIC1 */
} /* claic1_ */
/* Subroutine */ int claqr0_(logical *wantt, logical *wantz, integer *n,
integer *ilo, integer *ihi, complex *h__, integer *ldh, complex *w,
integer *iloz, integer *ihiz, complex *z__, integer *ldz, complex *
work, integer *lwork, integer *info)
{
/* System generated locals */
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8;
complex q__1, q__2, q__3, q__4, q__5;
/* Local variables */
integer i__, k;
real s;
complex aa, bb, cc, dd;
integer ld, nh, it, ks, kt, ku, kv, ls, ns, nw;
complex tr2, det;
integer inf, kdu, nho, nve, kwh, nsr, nwr, kwv, ndec, ndfl, kbot, nmin;
complex swap;
integer ktop;
complex zdum[1] /* was [1][1] */;
integer kacc22, itmax, nsmax, nwmax, kwtop;
integer nibble;
char jbcmpz[1];
complex rtdisc;
integer nwupbd;
logical sorted;
integer lwkopt;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* CLAQR0 computes the eigenvalues of a Hessenberg matrix H */
/* and, optionally, the matrices T and Z from the Schur decomposition */
/* H = Z T Z**H, where T is an upper triangular matrix (the */
/* Schur form), and Z is the unitary matrix of Schur vectors. */
/* Optionally Z may be postmultiplied into an input unitary */
/* matrix Q so that this routine can give the Schur factorization */
/* of a matrix A which has been reduced to the Hessenberg form H */
/* by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. */
/* 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 .GE. 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* It is assumed that H is already upper triangular in rows */
/* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, */
/* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a */
/* previous call to CGEBAL, and then passed to CGEHRD when the */
/* matrix output by CGEBAL is reduced to Hessenberg form. */
/* Otherwise, ILO and IHI should be set to 1 and N, */
/* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. */
/* If N = 0, then ILO = 1 and IHI = 0. */
/* H (input/output) COMPLEX array, dimension (LDH,N) */
/* On entry, the upper Hessenberg matrix H. */
/* On exit, if INFO = 0 and WANTT is .TRUE., then H */
/* contains the upper triangular matrix T from the Schur */
/* decomposition (the Schur form). If INFO = 0 and WANT is */
/* .FALSE., then the contents of H are unspecified on exit. */
/* (The output value of H when INFO.GT.0 is given under the */
/* description of INFO below.) */
/* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH .GE. max(1,N). */
/* W (output) COMPLEX array, dimension (N) */
/* The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored */
/* in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are */
/* stored in the same order as on the diagonal of the Schur */
/* form returned in H, with W(i) = H(i,i). */
/* Z (input/output) COMPLEX array, dimension (LDZ,IHI) */
/* If WANTZ is .FALSE., then Z is not referenced. */
/* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is */
/* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the */
/* orthogonal Schur factor of H(ILO:IHI,ILO:IHI). */
/* (The output value of Z when INFO.GT.0 is given under */
/* the description of INFO below.) */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. if WANTZ is .TRUE. */
/* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. */
/* WORK (workspace/output) COMPLEX array, dimension LWORK */
/* On exit, if LWORK = -1, WORK(1) returns an estimate of */
/* the optimal value for LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK .GE. max(1,N) */
/* is sufficient, but LWORK typically as large as 6*N may */
/* be required for optimal performance. A workspace query */
/* to determine the optimal workspace size is recommended. */
/* If LWORK = -1, then CLAQR0 does a workspace query. */
/* In this case, CLAQR0 checks the input parameters and */
/* estimates the optimal workspace size for the given */
/* values of N, ILO and IHI. The estimate is returned */
/* in WORK(1). No error message related to LWORK is */
/* issued by XERBLA. Neither H nor Z are accessed. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* .GT. 0: if INFO = i, CLAQR0 failed to compute all of */
/* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */
/* and WI contain those eigenvalues which have been */
/* successfully computed. (Failures are rare.) */
/* If INFO .GT. 0 and WANT is .FALSE., then on exit, */
/* the remaining unconverged eigenvalues are the eigen- */
/* values of the upper Hessenberg matrix rows and */
/* columns ILO through 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 a unitary 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(ILO:IHI,ILOZ:IHIZ) */
/* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U */
/* where U is the unitary matrix in (*) (regard- */
/* less of the value of WANTT.) */
/* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not */
/* accessed. */
/* ================================================================ */
/* Based on contributions by */
/* Karen Braman and Ralph Byers, Department of Mathematics, */
/* University of Kansas, USA */
/* ================================================================ */
/* References: */
/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
/* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */
/* Performance, SIAM Journal of Matrix Analysis, volume 23, pages */
/* 929--947, 2002. */
/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
/* Algorithm Part II: Aggressive Early Deflation, SIAM Journal */
/* of Matrix Analysis, volume 23, pages 948--973, 2002. */
/* ================================================================ */
/* ==== Matrices of order NTINY or smaller must be processed by */
/* . CLAHQR because of insufficient subdiagonal scratch space. */
/* . (This is a hard limit.) ==== */
/* ==== Exceptional deflation windows: try to cure rare */
/* . slow convergence by varying the size of the */
/* . deflation window after KEXNW iterations. ==== */
/* ==== Exceptional shifts: try to cure rare slow convergence */
/* . with ad-hoc exceptional shifts every KEXSH iterations. */
/* . ==== */
/* ==== The constant WILK1 is used to form the exceptional */
/* . shifts. ==== */
/* 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;
--work;
/* Function Body */
*info = 0;
/* ==== Quick return for N = 0: nothing to do. ==== */
if (*n == 0) {
work[1].r = 1.f, work[1].i = 0.f;
return 0;
}
if (*n <= 11) {
/* ==== Tiny matrices must use CLAHQR. ==== */
lwkopt = 1;
if (*lwork != -1) {
clahqr_(wantt, wantz, n, ilo, ihi, &h__[h_offset], ldh, &w[1],
iloz, ihiz, &z__[z_offset], ldz, info);
}
} else {
/* ==== Use small bulge multi-shift QR with aggressive early */
/* . deflation on larger-than-tiny matrices. ==== */
/* ==== Hope for the best. ==== */
*info = 0;
/* ==== Set up job flags for ILAENV. ==== */
if (*wantt) {
*(unsigned char *)jbcmpz = 'S';
} else {
*(unsigned char *)jbcmpz = 'E';
}
if (*wantz) {
*(unsigned char *)&jbcmpz[1] = 'V';
} else {
*(unsigned char *)&jbcmpz[1] = 'N';
}
/* ==== NWR = recommended deflation window size. At this */
/* . point, N .GT. NTINY = 11, so there is enough */
/* . subdiagonal workspace for NWR.GE.2 as required. */
/* . (In fact, there is enough subdiagonal space for */
/* . NWR.GE.3.) ==== */
nwr = ilaenv_(&c__13, "CLAQR0", jbcmpz, n, ilo, ihi, lwork);
nwr = max(2,nwr);
/* Computing MIN */
i__1 = *ihi - *ilo + 1, i__2 = (*n - 1) / 3, i__1 = min(i__1,i__2);
nwr = min(i__1,nwr);
/* ==== NSR = recommended number of simultaneous shifts. */
/* . At this point N .GT. NTINY = 11, so there is at */
/* . enough subdiagonal workspace for NSR to be even */
/* . and greater than or equal to two as required. ==== */
nsr = ilaenv_(&c__15, "CLAQR0", jbcmpz, n, ilo, ihi, lwork);
/* Computing MIN */
i__1 = nsr, i__2 = (*n + 6) / 9, i__1 = min(i__1,i__2), i__2 = *ihi -
*ilo;
nsr = min(i__1,i__2);
/* Computing MAX */
i__1 = 2, i__2 = nsr - nsr % 2;
nsr = max(i__1,i__2);
/* ==== Estimate optimal workspace ==== */
/* ==== Workspace query call to CLAQR3 ==== */
i__1 = nwr + 1;
claqr3_(wantt, wantz, n, ilo, ihi, &i__1, &h__[h_offset], ldh, iloz,
ihiz, &z__[z_offset], ldz, &ls, &ld, &w[1], &h__[h_offset],
ldh, n, &h__[h_offset], ldh, n, &h__[h_offset], ldh, &work[1],
&c_n1);
/* ==== Optimal workspace = MAX(CLAQR5, CLAQR3) ==== */
/* Computing MAX */
i__1 = nsr * 3 / 2, i__2 = (integer) work[1].r;
lwkopt = max(i__1,i__2);
/* ==== Quick return in case of workspace query. ==== */
if (*lwork == -1) {
r__1 = (real) lwkopt;
q__1.r = r__1, q__1.i = 0.f;
work[1].r = q__1.r, work[1].i = q__1.i;
return 0;
}
/* ==== CLAHQR/CLAQR0 crossover point ==== */
nmin = ilaenv_(&c__12, "CLAQR0", jbcmpz, n, ilo, ihi, lwork);
nmin = max(11,nmin);
/* ==== Nibble crossover point ==== */
nibble = ilaenv_(&c__14, "CLAQR0", jbcmpz, n, ilo, ihi, lwork);
nibble = max(0,nibble);
/* ==== Accumulate reflections during ttswp? Use block */
/* . 2-by-2 structure during matrix-matrix multiply? ==== */
kacc22 = ilaenv_(&c__16, "CLAQR0", jbcmpz, n, ilo, ihi, lwork);
kacc22 = max(0,kacc22);
kacc22 = min(2,kacc22);
/* ==== NWMAX = the largest possible deflation window for */
/* . which there is sufficient workspace. ==== */
/* Computing MIN */
i__1 = (*n - 1) / 3, i__2 = *lwork / 2;
nwmax = min(i__1,i__2);
nw = nwmax;
/* ==== NSMAX = the Largest number of simultaneous shifts */
/* . for which there is sufficient workspace. ==== */
/* Computing MIN */
i__1 = (*n + 6) / 9, i__2 = (*lwork << 1) / 3;
nsmax = min(i__1,i__2);
nsmax -= nsmax % 2;
/* ==== NDFL: an iteration count restarted at deflation. ==== */
ndfl = 1;
/* ==== ITMAX = iteration limit ==== */
/* Computing MAX */
i__1 = 10, i__2 = *ihi - *ilo + 1;
itmax = max(i__1,i__2) * 30;
/* ==== Last row and column in the active block ==== */
kbot = *ihi;
/* ==== Main Loop ==== */
i__1 = itmax;
for (it = 1; it <= i__1; ++it) {
/* ==== Done when KBOT falls below ILO ==== */
if (kbot < *ilo) {
goto L80;
}
/* ==== Locate active block ==== */
i__2 = *ilo + 1;
for (k = kbot; k >= i__2; --k) {
i__3 = k + (k - 1) * h_dim1;
if (h__[i__3].r == 0.f && h__[i__3].i == 0.f) {
goto L20;
}
}
k = *ilo;
L20:
ktop = k;
/* ==== Select deflation window size: */
/* . Typical Case: */
/* . If possible and advisable, nibble the entire */
/* . active block. If not, use size MIN(NWR,NWMAX) */
/* . or MIN(NWR+1,NWMAX) depending upon which has */
/* . the smaller corresponding subdiagonal entry */
/* . (a heuristic). */
/* . */
/* . Exceptional Case: */
/* . If there have been no deflations in KEXNW or */
/* . more iterations, then vary the deflation window */
/* . size. At first, because, larger windows are, */
/* . in general, more powerful than smaller ones, */
/* . rapidly increase the window to the maximum possible. */
/* . Then, gradually reduce the window size. ==== */
nh = kbot - ktop + 1;
nwupbd = min(nh,nwmax);
if (ndfl < 5) {
nw = min(nwupbd,nwr);
} else {
/* Computing MIN */
i__2 = nwupbd, i__3 = nw << 1;
nw = min(i__2,i__3);
}
if (nw < nwmax) {
if (nw >= nh - 1) {
nw = nh;
} else {
kwtop = kbot - nw + 1;
i__2 = kwtop + (kwtop - 1) * h_dim1;
i__3 = kwtop - 1 + (kwtop - 2) * h_dim1;
if ((r__1 = h__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
h__[kwtop + (kwtop - 1) * h_dim1]), dabs(r__2)) >
(r__3 = h__[i__3].r, dabs(r__3)) + (r__4 = r_imag(
&h__[kwtop - 1 + (kwtop - 2) * h_dim1]), dabs(
r__4))) {
++nw;
}
}
}
if (ndfl < 5) {
ndec = -1;
} else if (ndec >= 0 || nw >= nwupbd) {
++ndec;
if (nw - ndec < 2) {
ndec = 0;
}
nw -= ndec;
}
/* ==== Aggressive early deflation: */
/* . split workspace under the subdiagonal into */
/* . - an nw-by-nw work array V in the lower */
/* . left-hand-corner, */
/* . - an NW-by-at-least-NW-but-more-is-better */
/* . (NW-by-NHO) horizontal work array along */
/* . the bottom edge, */
/* . - an at-least-NW-but-more-is-better (NHV-by-NW) */
/* . vertical work array along the left-hand-edge. */
/* . ==== */
kv = *n - nw + 1;
kt = nw + 1;
nho = *n - nw - 1 - kt + 1;
kwv = nw + 2;
nve = *n - nw - kwv + 1;
/* ==== Aggressive early deflation ==== */
claqr3_(wantt, wantz, n, &ktop, &kbot, &nw, &h__[h_offset], ldh,
iloz, ihiz, &z__[z_offset], ldz, &ls, &ld, &w[1], &h__[kv
+ h_dim1], ldh, &nho, &h__[kv + kt * h_dim1], ldh, &nve, &
h__[kwv + h_dim1], ldh, &work[1], lwork);
/* ==== Adjust KBOT accounting for new deflations. ==== */
kbot -= ld;
/* ==== KS points to the shifts. ==== */
ks = kbot - ls + 1;
/* ==== Skip an expensive QR sweep if there is a (partly */
/* . heuristic) reason to expect that many eigenvalues */
/* . will deflate without it. Here, the QR sweep is */
/* . skipped if many eigenvalues have just been deflated */
/* . or if the remaining active block is small. */
if (ld == 0 || ld * 100 <= nw * nibble && kbot - ktop + 1 > min(
nmin,nwmax)) {
/* ==== NS = nominal number of simultaneous shifts. */
/* . This may be lowered (slightly) if CLAQR3 */
/* . did not provide that many shifts. ==== */
/* Computing MIN */
/* Computing MAX */
i__4 = 2, i__5 = kbot - ktop;
i__2 = min(nsmax,nsr), i__3 = max(i__4,i__5);
ns = min(i__2,i__3);
ns -= ns % 2;
/* ==== If there have been no deflations */
/* . in a multiple of KEXSH iterations, */
/* . then try exceptional shifts. */
/* . Otherwise use shifts provided by */
/* . CLAQR3 above or from the eigenvalues */
/* . of a trailing principal submatrix. ==== */
if (ndfl % 6 == 0) {
ks = kbot - ns + 1;
i__2 = ks + 1;
for (i__ = kbot; i__ >= i__2; i__ += -2) {
i__3 = i__;
i__4 = i__ + i__ * h_dim1;
i__5 = i__ + (i__ - 1) * h_dim1;
r__3 = ((r__1 = h__[i__5].r, dabs(r__1)) + (r__2 =
r_imag(&h__[i__ + (i__ - 1) * h_dim1]), dabs(
r__2))) * .75f;
q__1.r = h__[i__4].r + r__3, q__1.i = h__[i__4].i;
w[i__3].r = q__1.r, w[i__3].i = q__1.i;
i__3 = i__ - 1;
i__4 = i__;
w[i__3].r = w[i__4].r, w[i__3].i = w[i__4].i;
}
} else {
/* ==== Got NS/2 or fewer shifts? Use CLAQR4 or */
/* . CLAHQR on a trailing principal submatrix to */
/* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, */
/* . there is enough space below the subdiagonal */
/* . to fit an NS-by-NS scratch array.) ==== */
if (kbot - ks + 1 <= ns / 2) {
ks = kbot - ns + 1;
kt = *n - ns + 1;
clacpy_("A", &ns, &ns, &h__[ks + ks * h_dim1], ldh, &
h__[kt + h_dim1], ldh);
if (ns > nmin) {
claqr4_(&c_false, &c_false, &ns, &c__1, &ns, &h__[
kt + h_dim1], ldh, &w[ks], &c__1, &c__1,
zdum, &c__1, &work[1], lwork, &inf);
} else {
clahqr_(&c_false, &c_false, &ns, &c__1, &ns, &h__[
kt + h_dim1], ldh, &w[ks], &c__1, &c__1,
zdum, &c__1, &inf);
}
ks += inf;
/* ==== In case of a rare QR failure use */
/* . eigenvalues of the trailing 2-by-2 */
/* . principal submatrix. Scale to avoid */
/* . overflows, underflows and subnormals. */
/* . (The scale factor S can not be zero, */
/* . because H(KBOT,KBOT-1) is nonzero.) ==== */
if (ks >= kbot) {
i__2 = kbot - 1 + (kbot - 1) * h_dim1;
i__3 = kbot + (kbot - 1) * h_dim1;
i__4 = kbot - 1 + kbot * h_dim1;
i__5 = kbot + kbot * h_dim1;
s = (r__1 = h__[i__2].r, dabs(r__1)) + (r__2 =
r_imag(&h__[kbot - 1 + (kbot - 1) *
h_dim1]), dabs(r__2)) + ((r__3 = h__[i__3]
.r, dabs(r__3)) + (r__4 = r_imag(&h__[
kbot + (kbot - 1) * h_dim1]), dabs(r__4)))
+ ((r__5 = h__[i__4].r, dabs(r__5)) + (
r__6 = r_imag(&h__[kbot - 1 + kbot *
h_dim1]), dabs(r__6))) + ((r__7 = h__[
i__5].r, dabs(r__7)) + (r__8 = r_imag(&
h__[kbot + kbot * h_dim1]), dabs(r__8)));
i__2 = kbot - 1 + (kbot - 1) * h_dim1;
q__1.r = h__[i__2].r / s, q__1.i = h__[i__2].i /
s;
aa.r = q__1.r, aa.i = q__1.i;
i__2 = kbot + (kbot - 1) * h_dim1;
q__1.r = h__[i__2].r / s, q__1.i = h__[i__2].i /
s;
cc.r = q__1.r, cc.i = q__1.i;
i__2 = kbot - 1 + kbot * h_dim1;
q__1.r = h__[i__2].r / s, q__1.i = h__[i__2].i /
s;
bb.r = q__1.r, bb.i = q__1.i;
i__2 = kbot + kbot * h_dim1;
q__1.r = h__[i__2].r / s, q__1.i = h__[i__2].i /
s;
dd.r = q__1.r, dd.i = q__1.i;
q__2.r = aa.r + dd.r, q__2.i = aa.i + dd.i;
q__1.r = q__2.r / 2.f, q__1.i = q__2.i / 2.f;
tr2.r = q__1.r, tr2.i = q__1.i;
q__3.r = aa.r - tr2.r, q__3.i = aa.i - tr2.i;
q__4.r = dd.r - tr2.r, q__4.i = dd.i - tr2.i;
q__2.r = q__3.r * q__4.r - q__3.i * q__4.i,
q__2.i = q__3.r * q__4.i + q__3.i *
q__4.r;
q__5.r = bb.r * cc.r - bb.i * cc.i, q__5.i = bb.r
* cc.i + bb.i * cc.r;
q__1.r = q__2.r - q__5.r, q__1.i = q__2.i -
q__5.i;
det.r = q__1.r, det.i = q__1.i;
q__2.r = -det.r, q__2.i = -det.i;
c_sqrt(&q__1, &q__2);
rtdisc.r = q__1.r, rtdisc.i = q__1.i;
i__2 = kbot - 1;
q__2.r = tr2.r + rtdisc.r, q__2.i = tr2.i +
rtdisc.i;
q__1.r = s * q__2.r, q__1.i = s * q__2.i;
w[i__2].r = q__1.r, w[i__2].i = q__1.i;
i__2 = kbot;
q__2.r = tr2.r - rtdisc.r, q__2.i = tr2.i -
rtdisc.i;
q__1.r = s * q__2.r, q__1.i = s * q__2.i;
w[i__2].r = q__1.r, w[i__2].i = q__1.i;
ks = kbot - 1;
}
}
if (kbot - ks + 1 > ns) {
/* ==== Sort the shifts (Helps a little) ==== */
sorted = FALSE_;
i__2 = ks + 1;
for (k = kbot; k >= i__2; --k) {
if (sorted) {
goto L60;
}
sorted = TRUE_;
i__3 = k - 1;
for (i__ = ks; i__ <= i__3; ++i__) {
i__4 = i__;
i__5 = i__ + 1;
if ((r__1 = w[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&w[i__]), dabs(r__2)) < (r__3 =
w[i__5].r, dabs(r__3)) + (r__4 =
r_imag(&w[i__ + 1]), dabs(r__4))) {
sorted = FALSE_;
i__4 = i__;
swap.r = w[i__4].r, swap.i = w[i__4].i;
i__4 = i__;
i__5 = i__ + 1;
w[i__4].r = w[i__5].r, w[i__4].i = w[i__5]
.i;
i__4 = i__ + 1;
w[i__4].r = swap.r, w[i__4].i = swap.i;
}
}
}
L60:
;
}
}
/* ==== If there are only two shifts, then use */
/* . only one. ==== */
if (kbot - ks + 1 == 2) {
i__2 = kbot;
i__3 = kbot + kbot * h_dim1;
q__2.r = w[i__2].r - h__[i__3].r, q__2.i = w[i__2].i -
h__[i__3].i;
q__1.r = q__2.r, q__1.i = q__2.i;
i__4 = kbot - 1;
i__5 = kbot + kbot * h_dim1;
q__4.r = w[i__4].r - h__[i__5].r, q__4.i = w[i__4].i -
h__[i__5].i;
q__3.r = q__4.r, q__3.i = q__4.i;
if ((r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1),
dabs(r__2)) < (r__3 = q__3.r, dabs(r__3)) + (r__4
= r_imag(&q__3), dabs(r__4))) {
i__2 = kbot - 1;
i__3 = kbot;
w[i__2].r = w[i__3].r, w[i__2].i = w[i__3].i;
} else {
i__2 = kbot;
i__3 = kbot - 1;
w[i__2].r = w[i__3].r, w[i__2].i = w[i__3].i;
}
}
/* ==== Use up to NS of the the smallest magnatiude */
/* . shifts. If there aren't NS shifts available, */
/* . then use them all, possibly dropping one to */
/* . make the number of shifts even. ==== */
/* Computing MIN */
i__2 = ns, i__3 = kbot - ks + 1;
ns = min(i__2,i__3);
ns -= ns % 2;
ks = kbot - ns + 1;
/* ==== Small-bulge multi-shift QR sweep: */
/* . split workspace under the subdiagonal into */
/* . - a KDU-by-KDU work array U in the lower */
/* . left-hand-corner, */
/* . - a KDU-by-at-least-KDU-but-more-is-better */
/* . (KDU-by-NHo) horizontal work array WH along */
/* . the bottom edge, */
/* . - and an at-least-KDU-but-more-is-better-by-KDU */
/* . (NVE-by-KDU) vertical work WV arrow along */
/* . the left-hand-edge. ==== */
kdu = ns * 3 - 3;
ku = *n - kdu + 1;
kwh = kdu + 1;
nho = *n - kdu - 3 - (kdu + 1) + 1;
kwv = kdu + 4;
nve = *n - kdu - kwv + 1;
/* ==== Small-bulge multi-shift QR sweep ==== */
claqr5_(wantt, wantz, &kacc22, n, &ktop, &kbot, &ns, &w[ks], &
h__[h_offset], ldh, iloz, ihiz, &z__[z_offset], ldz, &
work[1], &c__3, &h__[ku + h_dim1], ldh, &nve, &h__[
kwv + h_dim1], ldh, &nho, &h__[ku + kwh * h_dim1],
ldh);
}
/* ==== Note progress (or the lack of it). ==== */
if (ld > 0) {
ndfl = 1;
} else {
++ndfl;
}
/* ==== End of main loop ==== */
}
/* ==== Iteration limit exceeded. Set INFO to show where */
/* . the problem occurred and exit. ==== */
*info = kbot;
L80:
;
}
/* ==== Return the optimal value of LWORK. ==== */
r__1 = (real) lwkopt;
q__1.r = r__1, q__1.i = 0.f;
work[1].r = q__1.r, work[1].i = q__1.i;
/* ==== End of CLAQR0 ==== */
return 0;
} /* claqr0_ */
void sqrtm(const emxArray_real_T *A, emxArray_creal_T *X, real_T *arg2)
{
emxArray_creal_T *T;
emxArray_creal_T *y;
boolean_T b0;
const mxArray *b_y;
static const int32_T iv40[2] = { 1, 19 };
const mxArray *m2;
char_T cv12[19];
int32_T i;
static const char_T cv13[19] = { 'C', 'o', 'd', 'e', 'r', ':', 'M', 'A', 'T',
'L', 'A', 'B', ':', 's', 'q', 'u', 'a', 'r', 'e' };
emxArray_creal_T *Q;
emxArray_creal_T *r25;
int32_T loop_ub;
int16_T iv41[2];
emxArray_creal_T *R;
real_T s_re;
real_T s_im;
int32_T k;
real_T R_re;
real_T R_im;
real_T T_re;
real_T T_im;
real_T brm;
int32_T i1;
int32_T b_loop_ub;
int32_T i2;
emxArray_creal_T *b_T;
emxArray_real_T *b_X;
emlrtHeapReferenceStackEnterFcnR2012b(emlrtRootTLSGlobal);
emxInit_creal_T(&T, 2, &k_emlrtRTEI, TRUE);
emxInit_creal_T(&y, 2, &k_emlrtRTEI, TRUE);
b0 = (A->size[0] == A->size[1]);
if (b0) {
} else {
emlrtPushRtStackR2012b(&hb_emlrtRSI, emlrtRootTLSGlobal);
emlrt_synchGlobalsToML();
b_y = NULL;
m2 = mxCreateCharArray(2, iv40);
for (i = 0; i < 19; i++) {
cv12[i] = cv13[i];
}
emlrtInitCharArrayR2013a(emlrtRootTLSGlobal, 19, m2, cv12);
emlrtAssign(&b_y, m2);
error(message(b_y, &f_emlrtMCI), &g_emlrtMCI);
emlrt_synchGlobalsFromML();
emlrtPopRtStackR2012b(&hb_emlrtRSI, emlrtRootTLSGlobal);
}
emxInit_creal_T(&Q, 2, &k_emlrtRTEI, TRUE);
emxInit_creal_T(&r25, 2, &k_emlrtRTEI, TRUE);
emlrtPushRtStackR2012b(&ib_emlrtRSI, emlrtRootTLSGlobal);
schur(A, Q, r25);
i = T->size[0] * T->size[1];
T->size[0] = r25->size[0];
T->size[1] = r25->size[1];
emxEnsureCapacity((emxArray__common *)T, i, (int32_T)sizeof(creal_T),
&k_emlrtRTEI);
loop_ub = r25->size[0] * r25->size[1];
for (i = 0; i < loop_ub; i++) {
T->data[i] = r25->data[i];
}
emxFree_creal_T(&r25);
emlrtPopRtStackR2012b(&ib_emlrtRSI, emlrtRootTLSGlobal);
for (i = 0; i < 2; i++) {
iv41[i] = (int16_T)T->size[i];
}
emxInit_creal_T(&R, 2, &l_emlrtRTEI, TRUE);
i = R->size[0] * R->size[1];
R->size[0] = iv41[0];
emxEnsureCapacity((emxArray__common *)R, i, (int32_T)sizeof(creal_T),
&k_emlrtRTEI);
i = R->size[0] * R->size[1];
R->size[1] = iv41[1];
emxEnsureCapacity((emxArray__common *)R, i, (int32_T)sizeof(creal_T),
&k_emlrtRTEI);
loop_ub = iv41[0] * iv41[1];
for (i = 0; i < loop_ub; i++) {
R->data[i].re = 0.0;
R->data[i].im = 0.0;
}
emlrtPushRtStackR2012b(&jb_emlrtRSI, emlrtRootTLSGlobal);
b0 = isUTmatD(T);
emlrtPopRtStackR2012b(&jb_emlrtRSI, emlrtRootTLSGlobal);
if (b0) {
emlrtPushRtStackR2012b(&kb_emlrtRSI, emlrtRootTLSGlobal);
emlrtPopRtStackR2012b(&kb_emlrtRSI, emlrtRootTLSGlobal);
for (loop_ub = 0; loop_ub + 1 <= A->size[0]; loop_ub++) {
R->data[loop_ub + R->size[0] * loop_ub] = T->data[loop_ub + T->size[0] *
loop_ub];
c_sqrt(&R->data[loop_ub + R->size[0] * loop_ub]);
}
} else {
emlrtPushRtStackR2012b(&lb_emlrtRSI, emlrtRootTLSGlobal);
emlrtPopRtStackR2012b(&lb_emlrtRSI, emlrtRootTLSGlobal);
for (loop_ub = 0; loop_ub + 1 <= A->size[0]; loop_ub++) {
R->data[loop_ub + R->size[0] * loop_ub] = T->data[loop_ub + T->size[0] *
loop_ub];
c_sqrt(&R->data[loop_ub + R->size[0] * loop_ub]);
for (i = loop_ub - 1; i + 1 > 0; i--) {
s_re = 0.0;
s_im = 0.0;
emlrtPushRtStackR2012b(&mb_emlrtRSI, emlrtRootTLSGlobal);
emlrtPopRtStackR2012b(&mb_emlrtRSI, emlrtRootTLSGlobal);
for (k = i + 1; k + 1 <= loop_ub; k++) {
R_re = R->data[i + R->size[0] * k].re * R->data[k + R->size[0] *
loop_ub].re - R->data[i + R->size[0] * k].im * R->data[k + R->size[0]
* loop_ub].im;
R_im = R->data[i + R->size[0] * k].re * R->data[k + R->size[0] *
loop_ub].im + R->data[i + R->size[0] * k].im * R->data[k + R->size[0]
* loop_ub].re;
s_re += R_re;
s_im += R_im;
}
T_re = T->data[i + T->size[0] * loop_ub].re - s_re;
T_im = T->data[i + T->size[0] * loop_ub].im - s_im;
R_re = R->data[i + R->size[0] * i].re + R->data[loop_ub + R->size[0] *
loop_ub].re;
R_im = R->data[i + R->size[0] * i].im + R->data[loop_ub + R->size[0] *
loop_ub].im;
if (R_im == 0.0) {
if (T_im == 0.0) {
R->data[i + R->size[0] * loop_ub].re = T_re / R_re;
R->data[i + R->size[0] * loop_ub].im = 0.0;
} else if (T_re == 0.0) {
R->data[i + R->size[0] * loop_ub].re = 0.0;
R->data[i + R->size[0] * loop_ub].im = T_im / R_re;
} else {
R->data[i + R->size[0] * loop_ub].re = T_re / R_re;
R->data[i + R->size[0] * loop_ub].im = T_im / R_re;
}
} else if (R_re == 0.0) {
if (T_re == 0.0) {
R->data[i + R->size[0] * loop_ub].re = T_im / R_im;
R->data[i + R->size[0] * loop_ub].im = 0.0;
} else if (T_im == 0.0) {
R->data[i + R->size[0] * loop_ub].re = 0.0;
R->data[i + R->size[0] * loop_ub].im = -(T_re / R_im);
} else {
R->data[i + R->size[0] * loop_ub].re = T_im / R_im;
R->data[i + R->size[0] * loop_ub].im = -(T_re / R_im);
}
} else {
brm = muDoubleScalarAbs(R_re);
s_re = muDoubleScalarAbs(R_im);
if (brm > s_re) {
s_re = R_im / R_re;
s_im = R_re + s_re * R_im;
R->data[i + R->size[0] * loop_ub].re = (T_re + s_re * T_im) / s_im;
R->data[i + R->size[0] * loop_ub].im = (T_im - s_re * T_re) / s_im;
} else if (s_re == brm) {
if (R_re > 0.0) {
s_im = 0.5;
} else {
s_im = -0.5;
}
if (R_im > 0.0) {
s_re = 0.5;
} else {
s_re = -0.5;
}
R->data[i + R->size[0] * loop_ub].re = (T_re * s_im + T_im * s_re) /
brm;
R->data[i + R->size[0] * loop_ub].im = (T_im * s_im - T_re * s_re) /
brm;
} else {
s_re = R_re / R_im;
s_im = R_im + s_re * R_re;
R->data[i + R->size[0] * loop_ub].re = (s_re * T_re + T_im) / s_im;
R->data[i + R->size[0] * loop_ub].im = (s_re * T_im - T_re) / s_im;
}
}
}
}
}
emlrtPushRtStackR2012b(&nb_emlrtRSI, emlrtRootTLSGlobal);
emlrtPushRtStackR2012b(&kh_emlrtRSI, emlrtRootTLSGlobal);
dynamic_size_checks(Q, R);
emlrtPopRtStackR2012b(&kh_emlrtRSI, emlrtRootTLSGlobal);
if ((Q->size[1] == 1) || (R->size[0] == 1)) {
i = y->size[0] * y->size[1];
y->size[0] = Q->size[0];
y->size[1] = R->size[1];
emxEnsureCapacity((emxArray__common *)y, i, (int32_T)sizeof(creal_T),
&k_emlrtRTEI);
loop_ub = Q->size[0];
for (i = 0; i < loop_ub; i++) {
k = R->size[1];
for (i1 = 0; i1 < k; i1++) {
y->data[i + y->size[0] * i1].re = 0.0;
y->data[i + y->size[0] * i1].im = 0.0;
b_loop_ub = Q->size[1];
for (i2 = 0; i2 < b_loop_ub; i2++) {
s_re = Q->data[i + Q->size[0] * i2].re * R->data[i2 + R->size[0] * i1]
.re - Q->data[i + Q->size[0] * i2].im * R->data[i2 + R->size[0] * i1]
.im;
s_im = Q->data[i + Q->size[0] * i2].re * R->data[i2 + R->size[0] * i1]
.im + Q->data[i + Q->size[0] * i2].im * R->data[i2 + R->size[0] * i1]
.re;
y->data[i + y->size[0] * i1].re += s_re;
y->data[i + y->size[0] * i1].im += s_im;
}
}
}
} else {
iv41[0] = (int16_T)Q->size[0];
iv41[1] = (int16_T)R->size[1];
emlrtPushRtStackR2012b(&jh_emlrtRSI, emlrtRootTLSGlobal);
i = y->size[0] * y->size[1];
y->size[0] = iv41[0];
emxEnsureCapacity((emxArray__common *)y, i, (int32_T)sizeof(creal_T),
&k_emlrtRTEI);
i = y->size[0] * y->size[1];
y->size[1] = iv41[1];
emxEnsureCapacity((emxArray__common *)y, i, (int32_T)sizeof(creal_T),
&k_emlrtRTEI);
loop_ub = iv41[0] * iv41[1];
for (i = 0; i < loop_ub; i++) {
y->data[i].re = 0.0;
y->data[i].im = 0.0;
}
eml_xgemm(Q->size[0], R->size[1], Q->size[1], Q, Q->size[0], R, Q->size[1],
y, Q->size[0]);
emlrtPopRtStackR2012b(&jh_emlrtRSI, emlrtRootTLSGlobal);
}
emxFree_creal_T(&R);
i = T->size[0] * T->size[1];
T->size[0] = Q->size[1];
T->size[1] = Q->size[0];
emxEnsureCapacity((emxArray__common *)T, i, (int32_T)sizeof(creal_T),
&k_emlrtRTEI);
loop_ub = Q->size[0];
for (i = 0; i < loop_ub; i++) {
k = Q->size[1];
for (i1 = 0; i1 < k; i1++) {
T->data[i1 + T->size[0] * i].re = Q->data[i + Q->size[0] * i1].re;
T->data[i1 + T->size[0] * i].im = -Q->data[i + Q->size[0] * i1].im;
}
}
emxFree_creal_T(&Q);
emlrtPushRtStackR2012b(&kh_emlrtRSI, emlrtRootTLSGlobal);
dynamic_size_checks(y, T);
emlrtPopRtStackR2012b(&kh_emlrtRSI, emlrtRootTLSGlobal);
if ((y->size[1] == 1) || (T->size[0] == 1)) {
i = X->size[0] * X->size[1];
X->size[0] = y->size[0];
X->size[1] = T->size[1];
emxEnsureCapacity((emxArray__common *)X, i, (int32_T)sizeof(creal_T),
&k_emlrtRTEI);
loop_ub = y->size[0];
for (i = 0; i < loop_ub; i++) {
k = T->size[1];
for (i1 = 0; i1 < k; i1++) {
X->data[i + X->size[0] * i1].re = 0.0;
X->data[i + X->size[0] * i1].im = 0.0;
b_loop_ub = y->size[1];
for (i2 = 0; i2 < b_loop_ub; i2++) {
s_re = y->data[i + y->size[0] * i2].re * T->data[i2 + T->size[0] * i1]
.re - y->data[i + y->size[0] * i2].im * T->data[i2 + T->size[0] * i1]
.im;
s_im = y->data[i + y->size[0] * i2].re * T->data[i2 + T->size[0] * i1]
.im + y->data[i + y->size[0] * i2].im * T->data[i2 + T->size[0] * i1]
.re;
X->data[i + X->size[0] * i1].re += s_re;
X->data[i + X->size[0] * i1].im += s_im;
}
}
}
} else {
iv41[0] = (int16_T)y->size[0];
iv41[1] = (int16_T)T->size[1];
emlrtPushRtStackR2012b(&jh_emlrtRSI, emlrtRootTLSGlobal);
i = X->size[0] * X->size[1];
X->size[0] = iv41[0];
emxEnsureCapacity((emxArray__common *)X, i, (int32_T)sizeof(creal_T),
&k_emlrtRTEI);
i = X->size[0] * X->size[1];
X->size[1] = iv41[1];
emxEnsureCapacity((emxArray__common *)X, i, (int32_T)sizeof(creal_T),
&k_emlrtRTEI);
loop_ub = iv41[0] * iv41[1];
for (i = 0; i < loop_ub; i++) {
X->data[i].re = 0.0;
X->data[i].im = 0.0;
}
eml_xgemm(y->size[0], T->size[1], y->size[1], y, y->size[0], T, y->size[1],
X, y->size[0]);
emlrtPopRtStackR2012b(&jh_emlrtRSI, emlrtRootTLSGlobal);
}
emlrtPopRtStackR2012b(&nb_emlrtRSI, emlrtRootTLSGlobal);
emlrtPushRtStackR2012b(&ob_emlrtRSI, emlrtRootTLSGlobal);
emlrtPushRtStackR2012b(&kh_emlrtRSI, emlrtRootTLSGlobal);
dynamic_size_checks(X, X);
emlrtPopRtStackR2012b(&kh_emlrtRSI, emlrtRootTLSGlobal);
if ((X->size[1] == 1) || (X->size[0] == 1)) {
i = T->size[0] * T->size[1];
T->size[0] = X->size[0];
T->size[1] = X->size[1];
emxEnsureCapacity((emxArray__common *)T, i, (int32_T)sizeof(creal_T),
&k_emlrtRTEI);
loop_ub = X->size[0];
for (i = 0; i < loop_ub; i++) {
k = X->size[1];
for (i1 = 0; i1 < k; i1++) {
T->data[i + T->size[0] * i1].re = 0.0;
T->data[i + T->size[0] * i1].im = 0.0;
b_loop_ub = X->size[1];
for (i2 = 0; i2 < b_loop_ub; i2++) {
s_re = X->data[i + X->size[0] * i2].re * X->data[i2 + X->size[0] * i1]
.re - X->data[i + X->size[0] * i2].im * X->data[i2 + X->size[0] * i1]
.im;
s_im = X->data[i + X->size[0] * i2].re * X->data[i2 + X->size[0] * i1]
.im + X->data[i + X->size[0] * i2].im * X->data[i2 + X->size[0] * i1]
.re;
T->data[i + T->size[0] * i1].re += s_re;
T->data[i + T->size[0] * i1].im += s_im;
}
}
}
} else {
iv41[0] = (int16_T)X->size[0];
iv41[1] = (int16_T)X->size[1];
emlrtPushRtStackR2012b(&jh_emlrtRSI, emlrtRootTLSGlobal);
i = T->size[0] * T->size[1];
T->size[0] = iv41[0];
emxEnsureCapacity((emxArray__common *)T, i, (int32_T)sizeof(creal_T),
&k_emlrtRTEI);
i = T->size[0] * T->size[1];
T->size[1] = iv41[1];
emxEnsureCapacity((emxArray__common *)T, i, (int32_T)sizeof(creal_T),
&k_emlrtRTEI);
loop_ub = iv41[0] * iv41[1];
for (i = 0; i < loop_ub; i++) {
T->data[i].re = 0.0;
T->data[i].im = 0.0;
}
eml_xgemm(X->size[0], X->size[1], X->size[1], X, X->size[0], X, X->size[1],
T, X->size[0]);
emlrtPopRtStackR2012b(&jh_emlrtRSI, emlrtRootTLSGlobal);
}
emxInit_creal_T(&b_T, 2, &k_emlrtRTEI, TRUE);
emlrtPopRtStackR2012b(&ob_emlrtRSI, emlrtRootTLSGlobal);
emlrtPushRtStackR2012b(&ob_emlrtRSI, emlrtRootTLSGlobal);
i = b_T->size[0] * b_T->size[1];
b_T->size[0] = T->size[0];
b_T->size[1] = T->size[1];
emxEnsureCapacity((emxArray__common *)b_T, i, (int32_T)sizeof(creal_T),
&k_emlrtRTEI);
loop_ub = T->size[0] * T->size[1];
for (i = 0; i < loop_ub; i++) {
b_T->data[i].re = T->data[i].re - A->data[i];
b_T->data[i].im = T->data[i].im;
}
emxInit_real_T(&b_X, 2, &k_emlrtRTEI, TRUE);
s_re = norm(b_T);
s_im = b_norm(A);
*arg2 = s_re / s_im;
emlrtPopRtStackR2012b(&ob_emlrtRSI, emlrtRootTLSGlobal);
i = b_X->size[0] * b_X->size[1];
b_X->size[0] = X->size[0];
b_X->size[1] = X->size[1];
emxEnsureCapacity((emxArray__common *)b_X, i, (int32_T)sizeof(real_T),
&k_emlrtRTEI);
loop_ub = X->size[0] * X->size[1];
emxFree_creal_T(&b_T);
for (i = 0; i < loop_ub; i++) {
b_X->data[i] = X->data[i].im;
}
if (c_norm(b_X) <= 10.0 * (real_T)A->size[0] * 2.2204460492503131E-16 * d_norm
(X)) {
emlrtPushRtStackR2012b(&pb_emlrtRSI, emlrtRootTLSGlobal);
emlrtPopRtStackR2012b(&pb_emlrtRSI, emlrtRootTLSGlobal);
for (loop_ub = 0; loop_ub + 1 <= A->size[0]; loop_ub++) {
emlrtPushRtStackR2012b(&qb_emlrtRSI, emlrtRootTLSGlobal);
emlrtPopRtStackR2012b(&qb_emlrtRSI, emlrtRootTLSGlobal);
for (i = 0; i + 1 <= A->size[0]; i++) {
s_re = X->data[i + X->size[0] * loop_ub].re;
X->data[i + X->size[0] * loop_ub].re = s_re;
X->data[i + X->size[0] * loop_ub].im = 0.0;
}
}
}
emxFree_real_T(&b_X);
emxFree_creal_T(&y);
emxFree_creal_T(&T);
emlrtHeapReferenceStackLeaveFcnR2012b(emlrtRootTLSGlobal);
}
/* 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_ */
