/* PURE _scale_sqrtz PURE */
doublecomplex _scale_sqrtz(doublecomplex arg)
{
/* make a call to the f2c sqrt function */
doublecomplex result;
z_sqrt(&result, &arg);
return result;
}
/* Subroutine */ int zhgeqz_(char *job, char *compq, char *compz, integer *n,
integer *ilo, integer *ihi, doublecomplex *a, integer *lda,
doublecomplex *b, integer *ldb, doublecomplex *alpha, doublecomplex *
beta, doublecomplex *q, integer *ldq, doublecomplex *z__, integer *
ldz, doublecomplex *work, integer *lwork, doublereal *rwork, integer *
info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
z_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
/* Builtin functions */
double z_abs(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
double d_imag(doublecomplex *);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *), pow_zi(
doublecomplex *, doublecomplex *, integer *), z_sqrt(
doublecomplex *, doublecomplex *);
/* Local variables */
static doublereal absb, atol, btol, temp, opst;
extern /* Subroutine */ int zrot_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, doublecomplex *);
static doublereal temp2, c__;
static integer j;
static doublecomplex s, t;
extern logical lsame_(char *, char *);
static doublecomplex ctemp;
static integer iiter, ilast, jiter;
static doublereal anorm;
static integer maxit;
static doublereal bnorm;
static doublecomplex shift;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
static doublereal tempr;
static doublecomplex ctemp2, ctemp3;
static logical ilazr2;
static integer jc, in;
static doublereal ascale, bscale;
static doublecomplex u12;
extern doublereal dlamch_(char *);
static integer jr, nq;
static doublecomplex signbc;
static integer nz;
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublecomplex eshift;
static logical ilschr;
static integer icompq, ilastm;
static doublecomplex rtdisc;
static integer ischur;
extern doublereal zlanhs_(char *, integer *, doublecomplex *, integer *,
doublereal *);
static logical ilazro;
static integer icompz, ifirst;
extern /* Subroutine */ int zlartg_(doublecomplex *, doublecomplex *,
doublereal *, doublecomplex *, doublecomplex *);
static integer ifrstm;
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
static integer istart;
static logical lquery;
static doublecomplex ad11, ad12, ad21, ad22;
static integer jch;
static logical ilq, ilz;
static doublereal ulp;
static doublecomplex abi22;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1
#define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)]
#define z___subscr(a_1,a_2) (a_2)*z_dim1 + a_1
#define z___ref(a_1,a_2) z__[z___subscr(a_1,a_2)]
/* -- LAPACK routine (instrumented to count operations, version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
----------------------- Begin Timing Code ------------------------
Common block to return operation count and iteration count
ITCNT is initialized to 0, OPS is only incremented
OPST is used to accumulate small contributions to OPS
to avoid roundoff error
------------------------ End Timing Code -------------------------
Purpose
=======
ZHGEQZ implements a single-shift version of the QZ
method for finding the generalized eigenvalues w(i)=ALPHA(i)/BETA(i)
of the equation
det( A - w(i) B ) = 0
If JOB='S', then the pair (A,B) is simultaneously
reduced to Schur form (i.e., A and B are both upper triangular) by
applying one unitary tranformation (usually called Q) on the left and
another (usually called Z) on the right. The diagonal elements of
A are then ALPHA(1),...,ALPHA(N), and of B are BETA(1),...,BETA(N).
If JOB='S' and COMPQ and COMPZ are 'V' or 'I', then the unitary
transformations used to reduce (A,B) are accumulated into the arrays
Q and Z s.t.:
Q(in) A(in) Z(in)* = Q(out) A(out) Z(out)*
Q(in) B(in) Z(in)* = Q(out) B(out) Z(out)*
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 only ALPHA and BETA. A and B will not
necessarily be put into generalized Schur form.
= 'S': put A and B into generalized Schur form, as well
as computing ALPHA and BETA.
COMPQ (input) CHARACTER*1
= 'N': do not modify Q.
= 'V': multiply the array Q on the right by the conjugate
transpose of the unitary tranformation that is
applied to the left side of A and B to reduce them
to Schur form.
= 'I': like COMPQ='V', except that Q will be initialized to
the identity first.
COMPZ (input) CHARACTER*1
= 'N': do not modify Z.
= 'V': multiply the array Z on the right by the unitary
tranformation that is applied to the right side of
A and B to reduce them to Schur form.
= 'I': like COMPZ='V', except that Z will be initialized to
the identity first.
N (input) INTEGER
The order of the matrices A, B, Q, and Z. N >= 0.
ILO (input) INTEGER
IHI (input) INTEGER
It is assumed that A is already upper triangular in rows and
columns 1:ILO-1 and IHI+1:N.
1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
A (input/output) COMPLEX*16 array, dimension (LDA, N)
On entry, the N-by-N upper Hessenberg matrix A. Elements
below the subdiagonal must be zero.
If JOB='S', then on exit A and B will have been
simultaneously reduced to upper triangular form.
If JOB='E', then on exit A will have been destroyed.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max( 1, N ).
B (input/output) COMPLEX*16 array, dimension (LDB, N)
On entry, the N-by-N upper triangular matrix B. Elements
below the diagonal must be zero.
If JOB='S', then on exit A and B will have been
simultaneously reduced to upper triangular form.
If JOB='E', then on exit B will have been destroyed.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max( 1, N ).
ALPHA (output) COMPLEX*16 array, dimension (N)
The diagonal elements of A when the pair (A,B) has been
reduced to Schur form. ALPHA(i)/BETA(i) i=1,...,N
are the generalized eigenvalues.
BETA (output) COMPLEX*16 array, dimension (N)
The diagonal elements of B when the pair (A,B) has been
reduced to Schur form. ALPHA(i)/BETA(i) i=1,...,N
are the generalized eigenvalues. A and B are normalized
so that BETA(1),...,BETA(N) are non-negative real numbers.
Q (input/output) COMPLEX*16 array, dimension (LDQ, N)
If COMPQ='N', then Q will not be referenced.
If COMPQ='V' or 'I', then the conjugate transpose of the
unitary transformations which are applied to A and B on
the left will be applied to the array Q on the right.
LDQ (input) INTEGER
The leading dimension of the array Q. LDQ >= 1.
If COMPQ='V' or 'I', then LDQ >= N.
Z (input/output) COMPLEX*16 array, dimension (LDZ, N)
If COMPZ='N', then Z will not be referenced.
If COMPZ='V' or 'I', then the unitary transformations which
are applied to A and B on the right will be applied to the
array Z on the right.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1.
If COMPZ='V' or 'I', then LDZ >= N.
WORK (workspace/output) COMPLEX*16 array, dimension (LWORK)
On exit, if INFO >= 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= max(1,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) DOUBLE PRECISION 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. (A,B) 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. (A,B) is not
in Schur form, but ALPHA(i) and BETA(i),
i=INFO-N+1,...,N should be correct.
> 2*N: various "impossible" errors.
Further Details
===============
We assume that complex ABS works as long as its value is less than
overflow.
=====================================================================
----------------------- Begin Timing Code ------------------------
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--alpha;
--beta;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
--rwork;
/* Function Body */
latime_1.itcnt = 0.;
/* ------------------------ End Timing Code -------------------------
Decode JOB, COMPQ, COMPZ */
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;
nq = 0;
} else if (lsame_(compq, "V")) {
ilq = TRUE_;
icompq = 2;
nq = *n;
} else if (lsame_(compq, "I")) {
ilq = TRUE_;
icompq = 3;
nq = *n;
} else {
icompq = 0;
}
if (lsame_(compz, "N")) {
ilz = FALSE_;
icompz = 1;
nz = 0;
} else if (lsame_(compz, "V")) {
ilz = TRUE_;
icompz = 2;
nz = *n;
} else if (lsame_(compz, "I")) {
ilz = TRUE_;
icompz = 3;
nz = *n;
} else {
icompz = 0;
}
/* Check Argument Values */
*info = 0;
i__1 = max(1,*n);
work[1].r = (doublereal) i__1, work[1].i = 0.;
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 (*lda < *n) {
*info = -8;
} else if (*ldb < *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_("ZHGEQZ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible
WORK( 1 ) = CMPLX( 1 ) */
if (*n <= 0) {
work[1].r = 1., work[1].i = 0.;
return 0;
}
/* Initialize Q and Z */
if (icompq == 3) {
zlaset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq);
}
if (icompz == 3) {
zlaset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz);
}
/* Machine Constants */
in = *ihi + 1 - *ilo;
safmin = dlamch_("S");
ulp = dlamch_("E") * dlamch_("B");
anorm = zlanhs_("F", &in, &a_ref(*ilo, *ilo), lda, &rwork[1]);
bnorm = zlanhs_("F", &in, &b_ref(*ilo, *ilo), ldb, &rwork[1]);
/* Computing MAX */
d__1 = safmin, d__2 = ulp * anorm;
atol = max(d__1,d__2);
/* Computing MAX */
d__1 = safmin, d__2 = ulp * bnorm;
btol = max(d__1,d__2);
ascale = 1. / max(safmin,anorm);
bscale = 1. / max(safmin,bnorm);
/* ---------------------- Begin Timing Code -------------------------
Count ops for norms, etc. */
opst = 0.;
/* Computing 2nd power */
i__1 = *n;
latime_1.ops += (doublereal) ((i__1 * i__1 << 2) + *n * 12 - 5);
/* ----------------------- End Timing Code --------------------------
Set Eigenvalues IHI+1:N */
i__1 = *n;
for (j = *ihi + 1; j <= i__1; ++j) {
absb = z_abs(&b_ref(j, j));
if (absb > safmin) {
i__2 = b_subscr(j, j);
z__2.r = b[i__2].r / absb, z__2.i = b[i__2].i / absb;
d_cnjg(&z__1, &z__2);
signbc.r = z__1.r, signbc.i = z__1.i;
i__2 = b_subscr(j, j);
b[i__2].r = absb, b[i__2].i = 0.;
if (ilschr) {
i__2 = j - 1;
zscal_(&i__2, &signbc, &b_ref(1, j), &c__1);
zscal_(&j, &signbc, &a_ref(1, j), &c__1);
/* ----------------- Begin Timing Code --------------------- */
opst += (doublereal) ((j - 1) * 12);
/* ------------------ End Timing Code ---------------------- */
} else {
i__2 = a_subscr(j, j);
i__3 = a_subscr(j, j);
z__1.r = a[i__3].r * signbc.r - a[i__3].i * signbc.i, z__1.i =
a[i__3].r * signbc.i + a[i__3].i * signbc.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
if (ilz) {
zscal_(n, &signbc, &z___ref(1, j), &c__1);
}
/* ------------------- Begin Timing Code ---------------------- */
opst += (doublereal) (nz * 6 + 13);
/* -------------------- End Timing Code ----------------------- */
} else {
i__2 = b_subscr(j, j);
b[i__2].r = 0., b[i__2].i = 0.;
}
i__2 = j;
i__3 = a_subscr(j, j);
alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i;
i__2 = j;
i__3 = b_subscr(j, j);
beta[i__2].r = b[i__3].r, beta[i__2].i = b[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., eshift.i = 0.;
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: A(j,j-1)=0 or j=ILO
2: B(j,j)=0
Special case: j=ILAST */
if (ilast == *ilo) {
goto L60;
} else {
i__2 = a_subscr(ilast, ilast - 1);
if ((d__1 = a[i__2].r, abs(d__1)) + (d__2 = d_imag(&a_ref(ilast,
ilast - 1)), abs(d__2)) <= atol) {
i__2 = a_subscr(ilast, ilast - 1);
a[i__2].r = 0., a[i__2].i = 0.;
goto L60;
}
}
if (z_abs(&b_ref(ilast, ilast)) <= btol) {
i__2 = b_subscr(ilast, ilast);
b[i__2].r = 0., b[i__2].i = 0.;
goto L50;
}
/* General case: j<ILAST */
i__2 = *ilo;
for (j = ilast - 1; j >= i__2; --j) {
/* Test 1: for A(j,j-1)=0 or j=ILO */
if (j == *ilo) {
ilazro = TRUE_;
} else {
i__3 = a_subscr(j, j - 1);
if ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a_ref(j,
j - 1)), abs(d__2)) <= atol) {
i__3 = a_subscr(j, j - 1);
a[i__3].r = 0., a[i__3].i = 0.;
ilazro = TRUE_;
} else {
ilazro = FALSE_;
}
}
/* Test 2: for B(j,j)=0 */
if (z_abs(&b_ref(j, j)) < btol) {
i__3 = b_subscr(j, j);
b[i__3].r = 0., b[i__3].i = 0.;
/* Test 1a: Check for 2 consecutive small subdiagonals in A */
ilazr2 = FALSE_;
if (! ilazro) {
i__3 = a_subscr(j, j - 1);
i__4 = a_subscr(j + 1, j);
i__5 = a_subscr(j, j);
if (((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&
a_ref(j, j - 1)), abs(d__2))) * (ascale * ((d__3 =
a[i__4].r, abs(d__3)) + (d__4 = d_imag(&a_ref(j
+ 1, j)), abs(d__4)))) <= ((d__5 = a[i__5].r, abs(
d__5)) + (d__6 = d_imag(&a_ref(j, j)), abs(d__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 = a_subscr(jch, jch);
ctemp.r = a[i__4].r, ctemp.i = a[i__4].i;
zlartg_(&ctemp, &a_ref(jch + 1, jch), &c__, &s, &
a_ref(jch, jch));
i__4 = a_subscr(jch + 1, jch);
a[i__4].r = 0., a[i__4].i = 0.;
i__4 = ilastm - jch;
zrot_(&i__4, &a_ref(jch, jch + 1), lda, &a_ref(jch +
1, jch + 1), lda, &c__, &s);
i__4 = ilastm - jch;
zrot_(&i__4, &b_ref(jch, jch + 1), ldb, &b_ref(jch +
1, jch + 1), ldb, &c__, &s);
if (ilq) {
d_cnjg(&z__1, &s);
zrot_(n, &q_ref(1, jch), &c__1, &q_ref(1, jch + 1)
, &c__1, &c__, &z__1);
}
if (ilazr2) {
i__4 = a_subscr(jch, jch - 1);
i__5 = a_subscr(jch, jch - 1);
z__1.r = c__ * a[i__5].r, z__1.i = c__ * a[i__5]
.i;
a[i__4].r = z__1.r, a[i__4].i = z__1.i;
}
ilazr2 = FALSE_;
/* --------------- Begin Timing Code ----------------- */
opst += (doublereal) ((ilastm - jch) * 40 + 32 + nq *
20);
/* ---------------- End Timing Code ------------------ */
i__4 = b_subscr(jch + 1, jch + 1);
if ((d__1 = b[i__4].r, abs(d__1)) + (d__2 = d_imag(&
b_ref(jch + 1, jch + 1)), abs(d__2)) >= btol)
{
if (jch + 1 >= ilast) {
goto L60;
} else {
ifirst = jch + 1;
goto L70;
}
}
i__4 = b_subscr(jch + 1, jch + 1);
b[i__4].r = 0., b[i__4].i = 0.;
/* L20: */
}
goto L50;
} else {
/* Only test 2 passed -- chase the zero to B(ILAST,ILAST)
Then process as in the case B(ILAST,ILAST)=0 */
i__3 = ilast - 1;
for (jch = j; jch <= i__3; ++jch) {
i__4 = b_subscr(jch, jch + 1);
ctemp.r = b[i__4].r, ctemp.i = b[i__4].i;
zlartg_(&ctemp, &b_ref(jch + 1, jch + 1), &c__, &s, &
b_ref(jch, jch + 1));
i__4 = b_subscr(jch + 1, jch + 1);
b[i__4].r = 0., b[i__4].i = 0.;
if (jch < ilastm - 1) {
i__4 = ilastm - jch - 1;
zrot_(&i__4, &b_ref(jch, jch + 2), ldb, &b_ref(
jch + 1, jch + 2), ldb, &c__, &s);
}
i__4 = ilastm - jch + 2;
zrot_(&i__4, &a_ref(jch, jch - 1), lda, &a_ref(jch +
1, jch - 1), lda, &c__, &s);
if (ilq) {
d_cnjg(&z__1, &s);
zrot_(n, &q_ref(1, jch), &c__1, &q_ref(1, jch + 1)
, &c__1, &c__, &z__1);
}
i__4 = a_subscr(jch + 1, jch);
ctemp.r = a[i__4].r, ctemp.i = a[i__4].i;
zlartg_(&ctemp, &a_ref(jch + 1, jch - 1), &c__, &s, &
a_ref(jch + 1, jch));
i__4 = a_subscr(jch + 1, jch - 1);
a[i__4].r = 0., a[i__4].i = 0.;
i__4 = jch + 1 - ifrstm;
zrot_(&i__4, &a_ref(ifrstm, jch), &c__1, &a_ref(
ifrstm, jch - 1), &c__1, &c__, &s);
i__4 = jch - ifrstm;
zrot_(&i__4, &b_ref(ifrstm, jch), &c__1, &b_ref(
ifrstm, jch - 1), &c__1, &c__, &s);
if (ilz) {
zrot_(n, &z___ref(1, jch), &c__1, &z___ref(1, jch
- 1), &c__1, &c__, &s);
}
/* L30: */
}
/* ---------------- Begin Timing Code ------------------- */
opst += (doublereal) ((ilastm + 1 - ifrstm) * 40 + 64 + (
nq + nz) * 20) * (doublereal) (ilast - j);
/* ----------------- End Timing Code -------------------- */
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;
/* B(ILAST,ILAST)=0 -- clear A(ILAST,ILAST-1) to split off a
1x1 block. */
L50:
i__2 = a_subscr(ilast, ilast);
ctemp.r = a[i__2].r, ctemp.i = a[i__2].i;
zlartg_(&ctemp, &a_ref(ilast, ilast - 1), &c__, &s, &a_ref(ilast,
ilast));
i__2 = a_subscr(ilast, ilast - 1);
a[i__2].r = 0., a[i__2].i = 0.;
i__2 = ilast - ifrstm;
zrot_(&i__2, &a_ref(ifrstm, ilast), &c__1, &a_ref(ifrstm, ilast - 1),
&c__1, &c__, &s);
i__2 = ilast - ifrstm;
zrot_(&i__2, &b_ref(ifrstm, ilast), &c__1, &b_ref(ifrstm, ilast - 1),
&c__1, &c__, &s);
if (ilz) {
zrot_(n, &z___ref(1, ilast), &c__1, &z___ref(1, ilast - 1), &c__1,
&c__, &s);
}
/* --------------------- Begin Timing Code ----------------------- */
opst += (doublereal) ((ilast - ifrstm) * 40 + 32 + nz * 20);
/* ---------------------- End Timing Code ------------------------
A(ILAST,ILAST-1)=0 -- Standardize B, set ALPHA and BETA */
L60:
absb = z_abs(&b_ref(ilast, ilast));
if (absb > safmin) {
i__2 = b_subscr(ilast, ilast);
z__2.r = b[i__2].r / absb, z__2.i = b[i__2].i / absb;
d_cnjg(&z__1, &z__2);
signbc.r = z__1.r, signbc.i = z__1.i;
i__2 = b_subscr(ilast, ilast);
b[i__2].r = absb, b[i__2].i = 0.;
if (ilschr) {
i__2 = ilast - ifrstm;
zscal_(&i__2, &signbc, &b_ref(ifrstm, ilast), &c__1);
i__2 = ilast + 1 - ifrstm;
zscal_(&i__2, &signbc, &a_ref(ifrstm, ilast), &c__1);
/* ----------------- Begin Timing Code --------------------- */
opst += (doublereal) ((ilast - ifrstm) * 12);
/* ------------------ End Timing Code ---------------------- */
} else {
i__2 = a_subscr(ilast, ilast);
i__3 = a_subscr(ilast, ilast);
z__1.r = a[i__3].r * signbc.r - a[i__3].i * signbc.i, z__1.i =
a[i__3].r * signbc.i + a[i__3].i * signbc.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
if (ilz) {
zscal_(n, &signbc, &z___ref(1, ilast), &c__1);
}
/* ------------------- Begin Timing Code ---------------------- */
opst += (doublereal) (nz * 6 + 13);
/* -------------------- End Timing Code ----------------------- */
} else {
i__2 = b_subscr(ilast, ilast);
b[i__2].r = 0., b[i__2].i = 0.;
}
i__2 = ilast;
i__3 = a_subscr(ilast, ilast);
alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i;
i__2 = ilast;
i__3 = b_subscr(ilast, ilast);
beta[i__2].r = b[i__3].r, beta[i__2].i = b[i__3].i;
/* Go to next block -- exit if finished. */
--ilast;
if (ilast < *ilo) {
goto L190;
}
/* Reset counters */
iiter = 0;
eshift.r = 0., eshift.i = 0.;
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
B(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 = b_subscr(ilast - 1, ilast);
z__2.r = bscale * b[i__2].r, z__2.i = bscale * b[i__2].i;
i__3 = b_subscr(ilast, ilast);
z__3.r = bscale * b[i__3].r, z__3.i = bscale * b[i__3].i;
z_div(&z__1, &z__2, &z__3);
u12.r = z__1.r, u12.i = z__1.i;
i__2 = a_subscr(ilast - 1, ilast - 1);
z__2.r = ascale * a[i__2].r, z__2.i = ascale * a[i__2].i;
i__3 = b_subscr(ilast - 1, ilast - 1);
z__3.r = bscale * b[i__3].r, z__3.i = bscale * b[i__3].i;
z_div(&z__1, &z__2, &z__3);
ad11.r = z__1.r, ad11.i = z__1.i;
i__2 = a_subscr(ilast, ilast - 1);
z__2.r = ascale * a[i__2].r, z__2.i = ascale * a[i__2].i;
i__3 = b_subscr(ilast - 1, ilast - 1);
z__3.r = bscale * b[i__3].r, z__3.i = bscale * b[i__3].i;
z_div(&z__1, &z__2, &z__3);
ad21.r = z__1.r, ad21.i = z__1.i;
i__2 = a_subscr(ilast - 1, ilast);
z__2.r = ascale * a[i__2].r, z__2.i = ascale * a[i__2].i;
i__3 = b_subscr(ilast, ilast);
z__3.r = bscale * b[i__3].r, z__3.i = bscale * b[i__3].i;
z_div(&z__1, &z__2, &z__3);
ad12.r = z__1.r, ad12.i = z__1.i;
i__2 = a_subscr(ilast, ilast);
z__2.r = ascale * a[i__2].r, z__2.i = ascale * a[i__2].i;
i__3 = b_subscr(ilast, ilast);
z__3.r = bscale * b[i__3].r, z__3.i = bscale * b[i__3].i;
z_div(&z__1, &z__2, &z__3);
ad22.r = z__1.r, ad22.i = z__1.i;
z__2.r = u12.r * ad21.r - u12.i * ad21.i, z__2.i = u12.r * ad21.i
+ u12.i * ad21.r;
z__1.r = ad22.r - z__2.r, z__1.i = ad22.i - z__2.i;
abi22.r = z__1.r, abi22.i = z__1.i;
z__2.r = ad11.r + abi22.r, z__2.i = ad11.i + abi22.i;
z__1.r = z__2.r * .5, z__1.i = z__2.i * .5;
t.r = z__1.r, t.i = z__1.i;
pow_zi(&z__4, &t, &c__2);
z__5.r = ad12.r * ad21.r - ad12.i * ad21.i, z__5.i = ad12.r *
ad21.i + ad12.i * ad21.r;
z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
z__6.r = ad11.r * ad22.r - ad11.i * ad22.i, z__6.i = ad11.r *
ad22.i + ad11.i * ad22.r;
z__2.r = z__3.r - z__6.r, z__2.i = z__3.i - z__6.i;
z_sqrt(&z__1, &z__2);
rtdisc.r = z__1.r, rtdisc.i = z__1.i;
z__1.r = t.r - abi22.r, z__1.i = t.i - abi22.i;
z__2.r = t.r - abi22.r, z__2.i = t.i - abi22.i;
temp = z__1.r * rtdisc.r + d_imag(&z__2) * d_imag(&rtdisc);
if (temp <= 0.) {
z__1.r = t.r + rtdisc.r, z__1.i = t.i + rtdisc.i;
shift.r = z__1.r, shift.i = z__1.i;
} else {
z__1.r = t.r - rtdisc.r, z__1.i = t.i - rtdisc.i;
shift.r = z__1.r, shift.i = z__1.i;
}
/* ------------------- Begin Timing Code ---------------------- */
opst += 116.;
/* -------------------- End Timing Code ----------------------- */
} else {
/* Exceptional shift. Chosen for no particularly good reason. */
i__2 = a_subscr(ilast - 1, ilast);
z__4.r = ascale * a[i__2].r, z__4.i = ascale * a[i__2].i;
i__3 = b_subscr(ilast - 1, ilast - 1);
z__5.r = bscale * b[i__3].r, z__5.i = bscale * b[i__3].i;
z_div(&z__3, &z__4, &z__5);
d_cnjg(&z__2, &z__3);
z__1.r = eshift.r + z__2.r, z__1.i = eshift.i + z__2.i;
eshift.r = z__1.r, eshift.i = z__1.i;
shift.r = eshift.r, shift.i = eshift.i;
/* ------------------- Begin Timing Code ---------------------- */
opst += 15.;
/* -------------------- End Timing Code ----------------------- */
}
/* Now check for two consecutive small subdiagonals. */
i__2 = ifirst + 1;
for (j = ilast - 1; j >= i__2; --j) {
istart = j;
i__3 = a_subscr(j, j);
z__2.r = ascale * a[i__3].r, z__2.i = ascale * a[i__3].i;
i__4 = b_subscr(j, j);
z__4.r = bscale * b[i__4].r, z__4.i = bscale * b[i__4].i;
z__3.r = shift.r * z__4.r - shift.i * z__4.i, z__3.i = shift.r *
z__4.i + shift.i * z__4.r;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
ctemp.r = z__1.r, ctemp.i = z__1.i;
temp = (d__1 = ctemp.r, abs(d__1)) + (d__2 = d_imag(&ctemp), abs(
d__2));
i__3 = a_subscr(j + 1, j);
temp2 = ascale * ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&
a_ref(j + 1, j)), abs(d__2)));
tempr = max(temp,temp2);
if (tempr < 1. && tempr != 0.) {
temp /= tempr;
temp2 /= tempr;
}
i__3 = a_subscr(j, j - 1);
if (((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a_ref(j, j -
1)), abs(d__2))) * temp2 <= temp * atol) {
goto L90;
}
/* L80: */
}
istart = ifirst;
i__2 = a_subscr(ifirst, ifirst);
z__2.r = ascale * a[i__2].r, z__2.i = ascale * a[i__2].i;
i__3 = b_subscr(ifirst, ifirst);
z__4.r = bscale * b[i__3].r, z__4.i = bscale * b[i__3].i;
z__3.r = shift.r * z__4.r - shift.i * z__4.i, z__3.i = shift.r *
z__4.i + shift.i * z__4.r;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
ctemp.r = z__1.r, ctemp.i = z__1.i;
/* --------------------- Begin Timing Code ----------------------- */
opst += -6.;
/* ---------------------- End Timing Code ------------------------ */
L90:
/* Do an implicit-shift QZ sweep.
Initial Q */
i__2 = a_subscr(istart + 1, istart);
z__1.r = ascale * a[i__2].r, z__1.i = ascale * a[i__2].i;
ctemp2.r = z__1.r, ctemp2.i = z__1.i;
/* --------------------- Begin Timing Code ----------------------- */
opst += (doublereal) ((ilast - istart) * 18 + 2);
/* ---------------------- End Timing Code ------------------------ */
zlartg_(&ctemp, &ctemp2, &c__, &s, &ctemp3);
/* Sweep */
i__2 = ilast - 1;
for (j = istart; j <= i__2; ++j) {
if (j > istart) {
i__3 = a_subscr(j, j - 1);
ctemp.r = a[i__3].r, ctemp.i = a[i__3].i;
zlartg_(&ctemp, &a_ref(j + 1, j - 1), &c__, &s, &a_ref(j, j -
1));
i__3 = a_subscr(j + 1, j - 1);
a[i__3].r = 0., a[i__3].i = 0.;
}
i__3 = ilastm;
for (jc = j; jc <= i__3; ++jc) {
i__4 = a_subscr(j, jc);
z__2.r = c__ * a[i__4].r, z__2.i = c__ * a[i__4].i;
i__5 = a_subscr(j + 1, jc);
z__3.r = s.r * a[i__5].r - s.i * a[i__5].i, z__3.i = s.r * a[
i__5].i + s.i * a[i__5].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__4 = a_subscr(j + 1, jc);
d_cnjg(&z__4, &s);
z__3.r = -z__4.r, z__3.i = -z__4.i;
i__5 = a_subscr(j, jc);
z__2.r = z__3.r * a[i__5].r - z__3.i * a[i__5].i, z__2.i =
z__3.r * a[i__5].i + z__3.i * a[i__5].r;
i__6 = a_subscr(j + 1, jc);
z__5.r = c__ * a[i__6].r, z__5.i = c__ * a[i__6].i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
a[i__4].r = z__1.r, a[i__4].i = z__1.i;
i__4 = a_subscr(j, jc);
a[i__4].r = ctemp.r, a[i__4].i = ctemp.i;
i__4 = b_subscr(j, jc);
z__2.r = c__ * b[i__4].r, z__2.i = c__ * b[i__4].i;
i__5 = b_subscr(j + 1, jc);
z__3.r = s.r * b[i__5].r - s.i * b[i__5].i, z__3.i = s.r * b[
i__5].i + s.i * b[i__5].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
ctemp2.r = z__1.r, ctemp2.i = z__1.i;
i__4 = b_subscr(j + 1, jc);
d_cnjg(&z__4, &s);
z__3.r = -z__4.r, z__3.i = -z__4.i;
i__5 = b_subscr(j, jc);
z__2.r = z__3.r * b[i__5].r - z__3.i * b[i__5].i, z__2.i =
z__3.r * b[i__5].i + z__3.i * b[i__5].r;
i__6 = b_subscr(j + 1, jc);
z__5.r = c__ * b[i__6].r, z__5.i = c__ * b[i__6].i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
b[i__4].r = z__1.r, b[i__4].i = z__1.i;
i__4 = b_subscr(j, jc);
b[i__4].r = ctemp2.r, b[i__4].i = ctemp2.i;
/* L100: */
}
if (ilq) {
i__3 = *n;
for (jr = 1; jr <= i__3; ++jr) {
i__4 = q_subscr(jr, j);
z__2.r = c__ * q[i__4].r, z__2.i = c__ * q[i__4].i;
d_cnjg(&z__4, &s);
i__5 = q_subscr(jr, j + 1);
z__3.r = z__4.r * q[i__5].r - z__4.i * q[i__5].i, z__3.i =
z__4.r * q[i__5].i + z__4.i * q[i__5].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__4 = q_subscr(jr, j + 1);
z__3.r = -s.r, z__3.i = -s.i;
i__5 = q_subscr(jr, j);
z__2.r = z__3.r * q[i__5].r - z__3.i * q[i__5].i, z__2.i =
z__3.r * q[i__5].i + z__3.i * q[i__5].r;
i__6 = q_subscr(jr, j + 1);
z__4.r = c__ * q[i__6].r, z__4.i = c__ * q[i__6].i;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
q[i__4].r = z__1.r, q[i__4].i = z__1.i;
i__4 = q_subscr(jr, j);
q[i__4].r = ctemp.r, q[i__4].i = ctemp.i;
/* L110: */
}
}
i__3 = b_subscr(j + 1, j + 1);
ctemp.r = b[i__3].r, ctemp.i = b[i__3].i;
zlartg_(&ctemp, &b_ref(j + 1, j), &c__, &s, &b_ref(j + 1, j + 1));
i__3 = b_subscr(j + 1, j);
b[i__3].r = 0., b[i__3].i = 0.;
/* Computing MIN */
i__4 = j + 2;
i__3 = min(i__4,ilast);
for (jr = ifrstm; jr <= i__3; ++jr) {
i__4 = a_subscr(jr, j + 1);
z__2.r = c__ * a[i__4].r, z__2.i = c__ * a[i__4].i;
i__5 = a_subscr(jr, j);
z__3.r = s.r * a[i__5].r - s.i * a[i__5].i, z__3.i = s.r * a[
i__5].i + s.i * a[i__5].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__4 = a_subscr(jr, j);
d_cnjg(&z__4, &s);
z__3.r = -z__4.r, z__3.i = -z__4.i;
i__5 = a_subscr(jr, j + 1);
z__2.r = z__3.r * a[i__5].r - z__3.i * a[i__5].i, z__2.i =
z__3.r * a[i__5].i + z__3.i * a[i__5].r;
i__6 = a_subscr(jr, j);
z__5.r = c__ * a[i__6].r, z__5.i = c__ * a[i__6].i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
a[i__4].r = z__1.r, a[i__4].i = z__1.i;
i__4 = a_subscr(jr, j + 1);
a[i__4].r = ctemp.r, a[i__4].i = ctemp.i;
/* L120: */
}
i__3 = j;
for (jr = ifrstm; jr <= i__3; ++jr) {
i__4 = b_subscr(jr, j + 1);
z__2.r = c__ * b[i__4].r, z__2.i = c__ * b[i__4].i;
i__5 = b_subscr(jr, j);
z__3.r = s.r * b[i__5].r - s.i * b[i__5].i, z__3.i = s.r * b[
i__5].i + s.i * b[i__5].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__4 = b_subscr(jr, j);
d_cnjg(&z__4, &s);
z__3.r = -z__4.r, z__3.i = -z__4.i;
i__5 = b_subscr(jr, j + 1);
z__2.r = z__3.r * b[i__5].r - z__3.i * b[i__5].i, z__2.i =
z__3.r * b[i__5].i + z__3.i * b[i__5].r;
i__6 = b_subscr(jr, j);
z__5.r = c__ * b[i__6].r, z__5.i = c__ * b[i__6].i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
b[i__4].r = z__1.r, b[i__4].i = z__1.i;
i__4 = b_subscr(jr, j + 1);
b[i__4].r = ctemp.r, b[i__4].i = ctemp.i;
/* L130: */
}
if (ilz) {
i__3 = *n;
for (jr = 1; jr <= i__3; ++jr) {
i__4 = z___subscr(jr, j + 1);
z__2.r = c__ * z__[i__4].r, z__2.i = c__ * z__[i__4].i;
i__5 = z___subscr(jr, j);
z__3.r = s.r * z__[i__5].r - s.i * z__[i__5].i, z__3.i =
s.r * z__[i__5].i + s.i * z__[i__5].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__4 = z___subscr(jr, j);
d_cnjg(&z__4, &s);
z__3.r = -z__4.r, z__3.i = -z__4.i;
i__5 = z___subscr(jr, j + 1);
z__2.r = z__3.r * z__[i__5].r - z__3.i * z__[i__5].i,
z__2.i = z__3.r * z__[i__5].i + z__3.i * z__[i__5]
.r;
i__6 = z___subscr(jr, j);
z__5.r = c__ * z__[i__6].r, z__5.i = c__ * z__[i__6].i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
i__4 = z___subscr(jr, j + 1);
z__[i__4].r = ctemp.r, z__[i__4].i = ctemp.i;
/* L140: */
}
}
/* L150: */
}
/* --------------------- Begin Timing Code ----------------------- */
opst += (doublereal) (ilast - istart) * (doublereal) ((ilastm -
ifrstm) * 40 + 184 + (nq + nz) * 20) - 20;
/* ---------------------- End Timing Code ------------------------ */
L160:
/* --------------------- Begin Timing Code -----------------------
End of iteration -- add in "small" contributions. */
latime_1.ops += opst;
opst = 0.;
/* ---------------------- End Timing Code ------------------------
L170: */
}
/* Drop-through = non-convergence */
L180:
*info = ilast;
/* ---------------------- Begin Timing Code ------------------------- */
latime_1.ops += opst;
opst = 0.;
/* ----------------------- End Timing Code -------------------------- */
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 = z_abs(&b_ref(j, j));
if (absb > safmin) {
i__2 = b_subscr(j, j);
z__2.r = b[i__2].r / absb, z__2.i = b[i__2].i / absb;
d_cnjg(&z__1, &z__2);
signbc.r = z__1.r, signbc.i = z__1.i;
i__2 = b_subscr(j, j);
b[i__2].r = absb, b[i__2].i = 0.;
if (ilschr) {
i__2 = j - 1;
zscal_(&i__2, &signbc, &b_ref(1, j), &c__1);
zscal_(&j, &signbc, &a_ref(1, j), &c__1);
/* ----------------- Begin Timing Code --------------------- */
opst += (doublereal) ((j - 1) * 12);
/* ------------------ End Timing Code ---------------------- */
} else {
i__2 = a_subscr(j, j);
i__3 = a_subscr(j, j);
z__1.r = a[i__3].r * signbc.r - a[i__3].i * signbc.i, z__1.i =
a[i__3].r * signbc.i + a[i__3].i * signbc.r;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
if (ilz) {
zscal_(n, &signbc, &z___ref(1, j), &c__1);
}
/* ------------------- Begin Timing Code ---------------------- */
opst += (doublereal) (nz * 6 + 13);
/* -------------------- End Timing Code ----------------------- */
} else {
i__2 = b_subscr(j, j);
b[i__2].r = 0., b[i__2].i = 0.;
}
i__2 = j;
i__3 = a_subscr(j, j);
alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i;
i__2 = j;
i__3 = b_subscr(j, j);
beta[i__2].r = b[i__3].r, beta[i__2].i = b[i__3].i;
/* L200: */
}
/* Normal Termination */
*info = 0;
/* Exit (other than argument error) -- return optimal workspace size */
L210:
/* ---------------------- Begin Timing Code ------------------------- */
latime_1.ops += opst;
opst = 0.;
latime_1.itcnt = (doublereal) jiter;
/* ----------------------- End Timing Code -------------------------- */
z__1.r = (doublereal) (*n), z__1.i = 0.;
work[1].r = z__1.r, work[1].i = z__1.i;
return 0;
/* End of ZHGEQZ */
} /* zhgeqz_ */
/* Subroutine */ int zlatdf_(integer *ijob, integer *n, doublecomplex *z__,
integer *ldz, doublecomplex *rhs, doublereal *rdsum, doublereal *
rdscal, integer *ipiv, integer *jpiv)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
double z_abs(doublecomplex *);
void z_sqrt(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j, k;
doublecomplex bm, bp, xm[2], xp[2];
integer info;
doublecomplex temp, work[8];
doublereal scale;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
doublecomplex pmone;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
doublereal rtemp, sminu, rwork[2];
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
doublereal splus;
extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *), zgesc2_(
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
integer *, doublereal *), zgecon_(char *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *,
doublecomplex *, doublereal *, integer *);
extern doublereal dzasum_(integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
doublereal *, doublereal *), zlaswp_(integer *, doublecomplex *,
integer *, integer *, integer *, integer *, integer *);
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLATDF computes the contribution to the reciprocal Dif-estimate */
/* by solving for x in Z * x = b, where b is chosen such that the norm */
/* of x is as large as possible. It is assumed that LU decomposition */
/* of Z has been computed by ZGETC2. On entry RHS = f holds the */
/* contribution from earlier solved sub-systems, and on return RHS = x. */
/* The factorization of Z returned by ZGETC2 has the form */
/* Z = P * L * U * Q, where P and Q are permutation matrices. L is lower */
/* triangular with unit diagonal elements and U is upper triangular. */
/* Arguments */
/* ========= */
/* IJOB (input) INTEGER */
/* IJOB = 2: First compute an approximative null-vector e */
/* of Z using ZGECON, e is normalized and solve for */
/* Zx = +-e - f with the sign giving the greater value of */
/* 2-norm(x). About 5 times as expensive as Default. */
/* IJOB .ne. 2: Local look ahead strategy where */
/* all entries of the r.h.s. b is choosen as either +1 or */
/* -1. Default. */
/* N (input) INTEGER */
/* The number of columns of the matrix Z. */
/* Z (input) DOUBLE PRECISION array, dimension (LDZ, N) */
/* On entry, the LU part of the factorization of the n-by-n */
/* matrix Z computed by ZGETC2: Z = P * L * U * Q */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDA >= max(1, N). */
/* RHS (input/output) DOUBLE PRECISION array, dimension (N). */
/* On entry, RHS contains contributions from other subsystems. */
/* On exit, RHS contains the solution of the subsystem with */
/* entries according to the value of IJOB (see above). */
/* RDSUM (input/output) DOUBLE PRECISION */
/* On entry, the sum of squares of computed contributions to */
/* the Dif-estimate under computation by ZTGSYL, where the */
/* scaling factor RDSCAL (see below) has been factored out. */
/* On exit, the corresponding sum of squares updated with the */
/* contributions from the current sub-system. */
/* If TRANS = 'T' RDSUM is not touched. */
/* NOTE: RDSUM only makes sense when ZTGSY2 is called by CTGSYL. */
/* RDSCAL (input/output) DOUBLE PRECISION */
/* On entry, scaling factor used to prevent overflow in RDSUM. */
/* On exit, RDSCAL is updated w.r.t. the current contributions */
/* in RDSUM. */
/* If TRANS = 'T', RDSCAL is not touched. */
/* NOTE: RDSCAL only makes sense when ZTGSY2 is called by */
/* ZTGSYL. */
/* IPIV (input) INTEGER array, dimension (N). */
/* The pivot indices; for 1 <= i <= N, row i of the */
/* matrix has been interchanged with row IPIV(i). */
/* JPIV (input) INTEGER array, dimension (N). */
/* The pivot indices; for 1 <= j <= N, column j of the */
/* matrix has been interchanged with column JPIV(j). */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
/* Umea University, S-901 87 Umea, Sweden. */
/* This routine is a further developed implementation of algorithm */
/* BSOLVE in [1] using complete pivoting in the LU factorization. */
/* [1] Bo Kagstrom and Lars Westin, */
/* Generalized Schur Methods with Condition Estimators for */
/* Solving the Generalized Sylvester Equation, IEEE Transactions */
/* on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751. */
/* [2] Peter Poromaa, */
/* On Efficient and Robust Estimators for the Separation */
/* between two Regular Matrix Pairs with Applications in */
/* Condition Estimation. Report UMINF-95.05, Department of */
/* Computing Science, Umea University, S-901 87 Umea, Sweden, */
/* 1995. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--rhs;
--ipiv;
--jpiv;
/* Function Body */
if (*ijob != 2) {
/* Apply permutations IPIV to RHS */
i__1 = *n - 1;
zlaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &ipiv[1], &c__1);
/* Solve for L-part choosing RHS either to +1 or -1. */
z__1.r = -1., z__1.i = -0.;
pmone.r = z__1.r, pmone.i = z__1.i;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
z__1.r = rhs[i__2].r + 1., z__1.i = rhs[i__2].i + 0.;
bp.r = z__1.r, bp.i = z__1.i;
i__2 = j;
z__1.r = rhs[i__2].r - 1., z__1.i = rhs[i__2].i - 0.;
bm.r = z__1.r, bm.i = z__1.i;
splus = 1.;
/* Lockahead for L- part RHS(1:N-1) = +-1 */
/* SPLUS and SMIN computed more efficiently than in BSOLVE[1]. */
i__2 = *n - j;
zdotc_(&z__1, &i__2, &z__[j + 1 + j * z_dim1], &c__1, &z__[j + 1
+ j * z_dim1], &c__1);
splus += z__1.r;
i__2 = *n - j;
zdotc_(&z__1, &i__2, &z__[j + 1 + j * z_dim1], &c__1, &rhs[j + 1],
&c__1);
sminu = z__1.r;
i__2 = j;
splus *= rhs[i__2].r;
if (splus > sminu) {
i__2 = j;
rhs[i__2].r = bp.r, rhs[i__2].i = bp.i;
} else if (sminu > splus) {
i__2 = j;
rhs[i__2].r = bm.r, rhs[i__2].i = bm.i;
} else {
/* In this case the updating sums are equal and we can */
/* choose RHS(J) +1 or -1. The first time this happens we */
/* choose -1, thereafter +1. This is a simple way to get */
/* good estimates of matrices like Byers well-known example */
/* (see [1]). (Not done in BSOLVE.) */
i__2 = j;
i__3 = j;
z__1.r = rhs[i__3].r + pmone.r, z__1.i = rhs[i__3].i +
pmone.i;
rhs[i__2].r = z__1.r, rhs[i__2].i = z__1.i;
pmone.r = 1., pmone.i = 0.;
}
/* Compute the remaining r.h.s. */
i__2 = j;
z__1.r = -rhs[i__2].r, z__1.i = -rhs[i__2].i;
temp.r = z__1.r, temp.i = z__1.i;
i__2 = *n - j;
zaxpy_(&i__2, &temp, &z__[j + 1 + j * z_dim1], &c__1, &rhs[j + 1],
&c__1);
/* L10: */
}
/* Solve for U- part, lockahead for RHS(N) = +-1. This is not done */
/* In BSOLVE and will hopefully give us a better estimate because */
/* any ill-conditioning of the original matrix is transfered to U */
/* and not to L. U(N, N) is an approximation to sigma_min(LU). */
i__1 = *n - 1;
zcopy_(&i__1, &rhs[1], &c__1, work, &c__1);
i__1 = *n - 1;
i__2 = *n;
z__1.r = rhs[i__2].r + 1., z__1.i = rhs[i__2].i + 0.;
work[i__1].r = z__1.r, work[i__1].i = z__1.i;
i__1 = *n;
i__2 = *n;
z__1.r = rhs[i__2].r - 1., z__1.i = rhs[i__2].i - 0.;
rhs[i__1].r = z__1.r, rhs[i__1].i = z__1.i;
splus = 0.;
sminu = 0.;
for (i__ = *n; i__ >= 1; --i__) {
z_div(&z__1, &c_b1, &z__[i__ + i__ * z_dim1]);
temp.r = z__1.r, temp.i = z__1.i;
i__1 = i__ - 1;
i__2 = i__ - 1;
z__1.r = work[i__2].r * temp.r - work[i__2].i * temp.i, z__1.i =
work[i__2].r * temp.i + work[i__2].i * temp.r;
work[i__1].r = z__1.r, work[i__1].i = z__1.i;
i__1 = i__;
i__2 = i__;
z__1.r = rhs[i__2].r * temp.r - rhs[i__2].i * temp.i, z__1.i =
rhs[i__2].r * temp.i + rhs[i__2].i * temp.r;
rhs[i__1].r = z__1.r, rhs[i__1].i = z__1.i;
i__1 = *n;
for (k = i__ + 1; k <= i__1; ++k) {
i__2 = i__ - 1;
i__3 = i__ - 1;
i__4 = k - 1;
i__5 = i__ + k * z_dim1;
z__3.r = z__[i__5].r * temp.r - z__[i__5].i * temp.i, z__3.i =
z__[i__5].r * temp.i + z__[i__5].i * temp.r;
z__2.r = work[i__4].r * z__3.r - work[i__4].i * z__3.i,
z__2.i = work[i__4].r * z__3.i + work[i__4].i *
z__3.r;
z__1.r = work[i__3].r - z__2.r, z__1.i = work[i__3].i -
z__2.i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
i__2 = i__;
i__3 = i__;
i__4 = k;
i__5 = i__ + k * z_dim1;
z__3.r = z__[i__5].r * temp.r - z__[i__5].i * temp.i, z__3.i =
z__[i__5].r * temp.i + z__[i__5].i * temp.r;
z__2.r = rhs[i__4].r * z__3.r - rhs[i__4].i * z__3.i, z__2.i =
rhs[i__4].r * z__3.i + rhs[i__4].i * z__3.r;
z__1.r = rhs[i__3].r - z__2.r, z__1.i = rhs[i__3].i - z__2.i;
rhs[i__2].r = z__1.r, rhs[i__2].i = z__1.i;
/* L20: */
}
splus += z_abs(&work[i__ - 1]);
sminu += z_abs(&rhs[i__]);
/* L30: */
}
if (splus > sminu) {
zcopy_(n, work, &c__1, &rhs[1], &c__1);
}
/* Apply the permutations JPIV to the computed solution (RHS) */
i__1 = *n - 1;
zlaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &jpiv[1], &c_n1);
/* Compute the sum of squares */
zlassq_(n, &rhs[1], &c__1, rdscal, rdsum);
return 0;
}
/* ENTRY IJOB = 2 */
/* Compute approximate nullvector XM of Z */
zgecon_("I", n, &z__[z_offset], ldz, &c_b24, &rtemp, work, rwork, &info);
zcopy_(n, &work[*n], &c__1, xm, &c__1);
/* Compute RHS */
i__1 = *n - 1;
zlaswp_(&c__1, xm, ldz, &c__1, &i__1, &ipiv[1], &c_n1);
zdotc_(&z__3, n, xm, &c__1, xm, &c__1);
z_sqrt(&z__2, &z__3);
z_div(&z__1, &c_b1, &z__2);
temp.r = z__1.r, temp.i = z__1.i;
zscal_(n, &temp, xm, &c__1);
zcopy_(n, xm, &c__1, xp, &c__1);
zaxpy_(n, &c_b1, &rhs[1], &c__1, xp, &c__1);
z__1.r = -1., z__1.i = -0.;
zaxpy_(n, &z__1, xm, &c__1, &rhs[1], &c__1);
zgesc2_(n, &z__[z_offset], ldz, &rhs[1], &ipiv[1], &jpiv[1], &scale);
zgesc2_(n, &z__[z_offset], ldz, xp, &ipiv[1], &jpiv[1], &scale);
if (dzasum_(n, xp, &c__1) > dzasum_(n, &rhs[1], &c__1)) {
zcopy_(n, xp, &c__1, &rhs[1], &c__1);
}
/* Compute the sum of squares */
zlassq_(n, &rhs[1], &c__1, rdscal, rdsum);
return 0;
/* End of ZLATDF */
} /* zlatdf_ */
/* Subroutine */ int zlaesy_(doublecomplex *a, doublecomplex *b,
doublecomplex *c__, doublecomplex *rt1, doublecomplex *rt2,
doublecomplex *evscal, doublecomplex *cs1, doublecomplex *sn1)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZLAESY 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*16
The ( 1, 1 ) element of input matrix.
B (input) COMPLEX*16
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*16
The ( 2, 2 ) element of input matrix.
RT1 (output) COMPLEX*16
The eigenvalue of larger modulus.
RT2 (output) COMPLEX*16
The eigenvalue of smaller modulus.
EVSCAL (output) COMPLEX*16
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*16
SN1 (output) COMPLEX*16
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 doublecomplex c_b1 = {1.,0.};
static integer c__2 = 2;
/* System generated locals */
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7;
/* Builtin functions */
double z_abs(doublecomplex *);
void pow_zi(doublecomplex *, doublecomplex *, integer *), z_sqrt(
doublecomplex *, doublecomplex *), z_div(doublecomplex *,
doublecomplex *, doublecomplex *);
/* Local variables */
static doublereal babs, tabs;
static doublecomplex s, t;
static doublereal z__, evnorm;
static doublecomplex tmp;
if (z_abs(b) == 0.) {
rt1->r = a->r, rt1->i = a->i;
rt2->r = c__->r, rt2->i = c__->i;
if (z_abs(rt1) < z_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., cs1->i = 0.;
sn1->r = 1., sn1->i = 0.;
} else {
cs1->r = 1., cs1->i = 0.;
sn1->r = 0., sn1->i = 0.;
}
} 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. */
z__2.r = a->r + c__->r, z__2.i = a->i + c__->i;
z__1.r = z__2.r * .5, z__1.i = z__2.i * .5;
s.r = z__1.r, s.i = z__1.i;
z__2.r = a->r - c__->r, z__2.i = a->i - c__->i;
z__1.r = z__2.r * .5, z__1.i = z__2.i * .5;
t.r = z__1.r, t.i = z__1.i;
/* Take the square root carefully to avoid over/under flow. */
babs = z_abs(b);
tabs = z_abs(&t);
z__ = max(babs,tabs);
if (z__ > 0.) {
z__5.r = t.r / z__, z__5.i = t.i / z__;
pow_zi(&z__4, &z__5, &c__2);
z__7.r = b->r / z__, z__7.i = b->i / z__;
pow_zi(&z__6, &z__7, &c__2);
z__3.r = z__4.r + z__6.r, z__3.i = z__4.i + z__6.i;
z_sqrt(&z__2, &z__3);
z__1.r = z__ * z__2.r, z__1.i = z__ * z__2.i;
t.r = z__1.r, t.i = z__1.i;
}
/* Compute the two eigenvalues. RT1 and RT2 are exchanged
if necessary so that RT1 will have the greater magnitude. */
z__1.r = s.r + t.r, z__1.i = s.i + t.i;
rt1->r = z__1.r, rt1->i = z__1.i;
z__1.r = s.r - t.r, z__1.i = s.i - t.i;
rt2->r = z__1.r, rt2->i = z__1.i;
if (z_abs(rt1) < z_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 THRESH.) */
z__2.r = rt1->r - a->r, z__2.i = rt1->i - a->i;
z_div(&z__1, &z__2, b);
sn1->r = z__1.r, sn1->i = z__1.i;
tabs = z_abs(sn1);
if (tabs > 1.) {
/* Computing 2nd power */
d__2 = 1. / tabs;
d__1 = d__2 * d__2;
z__5.r = sn1->r / tabs, z__5.i = sn1->i / tabs;
pow_zi(&z__4, &z__5, &c__2);
z__3.r = d__1 + z__4.r, z__3.i = z__4.i;
z_sqrt(&z__2, &z__3);
z__1.r = tabs * z__2.r, z__1.i = tabs * z__2.i;
t.r = z__1.r, t.i = z__1.i;
} else {
z__3.r = sn1->r * sn1->r - sn1->i * sn1->i, z__3.i = sn1->r *
sn1->i + sn1->i * sn1->r;
z__2.r = z__3.r + 1., z__2.i = z__3.i + 0.;
z_sqrt(&z__1, &z__2);
t.r = z__1.r, t.i = z__1.i;
}
evnorm = z_abs(&t);
if (evnorm >= .1) {
z_div(&z__1, &c_b1, &t);
evscal->r = z__1.r, evscal->i = z__1.i;
cs1->r = evscal->r, cs1->i = evscal->i;
z__1.r = sn1->r * evscal->r - sn1->i * evscal->i, z__1.i = sn1->r
* evscal->i + sn1->i * evscal->r;
sn1->r = z__1.r, sn1->i = z__1.i;
} else {
evscal->r = 0., evscal->i = 0.;
}
}
return 0;
/* End of ZLAESY */
} /* zlaesy_ */
/* Subroutine */ int zlaqr4_(logical *wantt, logical *wantz, integer *n,
integer *ilo, integer *ihi, doublecomplex *h__, integer *ldh,
doublecomplex *w, integer *iloz, integer *ihiz, doublecomplex *z__,
integer *ldz, doublecomplex *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;
doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8;
doublecomplex z__1, z__2, z__3, z__4, z__5;
/* Builtin functions */
double d_imag(doublecomplex *);
void z_sqrt(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, k;
doublereal s;
doublecomplex aa, bb, cc, dd;
integer ld, nh, it, ks, kt, ku, kv, ls, ns, nw;
doublecomplex tr2, det;
integer inf, kdu, nho, nve, kwh, nsr, nwr, kwv, ndec, ndfl, kbot, nmin;
doublecomplex swap;
integer ktop;
doublecomplex zdum[1] /* was [1][1] */;
integer kacc22, itmax, nsmax, nwmax, kwtop;
extern /* Subroutine */ int zlaqr2_(logical *, logical *, integer *,
integer *, integer *, integer *, doublecomplex *, integer *,
integer *, integer *, doublecomplex *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *, integer *,
doublecomplex *, integer *, integer *, doublecomplex *, integer *
, doublecomplex *, integer *), zlaqr5_(logical *, logical *,
integer *, integer *, integer *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, doublecomplex *, integer *,
integer *, doublecomplex *, integer *);
integer nibble;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
char jbcmpz[1];
doublecomplex rtdisc;
integer nwupbd;
logical sorted;
extern /* Subroutine */ int zlahqr_(logical *, logical *, integer *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *, integer *, doublecomplex *, integer *, integer *),
zlacpy_(char *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
integer lwkopt;
/* -- 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 .. */
/* .. */
/* This subroutine implements one level of recursion for ZLAQR0. */
/* It is a complete implementation of the small bulge multi-shift */
/* QR algorithm. It may be called by ZLAQR0 and, for large enough */
/* deflation window size, it may be called by ZLAQR3. This */
/* subroutine is identical to ZLAQR0 except that it calls ZLAQR2 */
/* instead of ZLAQR3. */
/* Purpose */
/* ======= */
/* ZLAQR4 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 ZGEBAL, and then passed to ZGEHRD when the */
/* matrix output by ZGEBAL 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*16 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 */
/* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH .GE. max(1,N). */
/* W (output) COMPLEX*16 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*16 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*16 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 ZLAQR4 does a workspace query. */
/* In this case, ZLAQR4 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, ZLAQR4 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. */
/* ================================================================ */
/* .. Parameters .. */
/* ==== Matrices of order NTINY or smaller must be processed by */
/* . ZLAHQR 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. ==== */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement 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;
--work;
/* Function Body */
*info = 0;
/* ==== Quick return for N = 0: nothing to do. ==== */
if (*n == 0) {
work[1].r = 1., work[1].i = 0.;
return 0;
}
if (*n <= 11) {
/* ==== Tiny matrices must use ZLAHQR. ==== */
lwkopt = 1;
if (*lwork != -1) {
zlahqr_(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, "ZLAQR4", 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, "ZLAQR4", 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 ZLAQR2 ==== */
i__1 = nwr + 1;
zlaqr2_(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(ZLAQR5, ZLAQR2) ==== */
/* 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) {
d__1 = (doublereal) lwkopt;
z__1.r = d__1, z__1.i = 0.;
work[1].r = z__1.r, work[1].i = z__1.i;
return 0;
}
/* ==== ZLAHQR/ZLAQR0 crossover point ==== */
nmin = ilaenv_(&c__12, "ZLAQR4", jbcmpz, n, ilo, ihi, lwork);
nmin = max(11,nmin);
/* ==== Nibble crossover point ==== */
nibble = ilaenv_(&c__14, "ZLAQR4", 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, "ZLAQR4", 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. && h__[i__3].i == 0.) {
goto L20;
}
/* L10: */
}
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 ((d__1 = h__[i__2].r, abs(d__1)) + (d__2 = d_imag(&h__[
kwtop + (kwtop - 1) * h_dim1]), abs(d__2)) > (
d__3 = h__[i__3].r, abs(d__3)) + (d__4 = d_imag(&
h__[kwtop - 1 + (kwtop - 2) * h_dim1]), abs(d__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 ==== */
zlaqr2_(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 ZLAQR2 */
/* . 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 */
/* . ZLAQR2 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;
d__3 = ((d__1 = h__[i__5].r, abs(d__1)) + (d__2 =
d_imag(&h__[i__ + (i__ - 1) * h_dim1]), abs(
d__2))) * .75;
z__1.r = h__[i__4].r + d__3, z__1.i = h__[i__4].i;
w[i__3].r = z__1.r, w[i__3].i = z__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;
/* L30: */
}
} else {
/* ==== Got NS/2 or fewer shifts? Use ZLAHQR */
/* . 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;
zlacpy_("A", &ns, &ns, &h__[ks + ks * h_dim1], ldh, &
h__[kt + h_dim1], ldh);
zlahqr_(&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 = (d__1 = h__[i__2].r, abs(d__1)) + (d__2 =
d_imag(&h__[kbot - 1 + (kbot - 1) *
h_dim1]), abs(d__2)) + ((d__3 = h__[i__3]
.r, abs(d__3)) + (d__4 = d_imag(&h__[kbot
+ (kbot - 1) * h_dim1]), abs(d__4))) + ((
d__5 = h__[i__4].r, abs(d__5)) + (d__6 =
d_imag(&h__[kbot - 1 + kbot * h_dim1]),
abs(d__6))) + ((d__7 = h__[i__5].r, abs(
d__7)) + (d__8 = d_imag(&h__[kbot + kbot *
h_dim1]), abs(d__8)));
i__2 = kbot - 1 + (kbot - 1) * h_dim1;
z__1.r = h__[i__2].r / s, z__1.i = h__[i__2].i /
s;
aa.r = z__1.r, aa.i = z__1.i;
i__2 = kbot + (kbot - 1) * h_dim1;
z__1.r = h__[i__2].r / s, z__1.i = h__[i__2].i /
s;
cc.r = z__1.r, cc.i = z__1.i;
i__2 = kbot - 1 + kbot * h_dim1;
z__1.r = h__[i__2].r / s, z__1.i = h__[i__2].i /
s;
bb.r = z__1.r, bb.i = z__1.i;
i__2 = kbot + kbot * h_dim1;
z__1.r = h__[i__2].r / s, z__1.i = h__[i__2].i /
s;
dd.r = z__1.r, dd.i = z__1.i;
z__2.r = aa.r + dd.r, z__2.i = aa.i + dd.i;
z__1.r = z__2.r / 2., z__1.i = z__2.i / 2.;
tr2.r = z__1.r, tr2.i = z__1.i;
z__3.r = aa.r - tr2.r, z__3.i = aa.i - tr2.i;
z__4.r = dd.r - tr2.r, z__4.i = dd.i - tr2.i;
z__2.r = z__3.r * z__4.r - z__3.i * z__4.i,
z__2.i = z__3.r * z__4.i + z__3.i *
z__4.r;
z__5.r = bb.r * cc.r - bb.i * cc.i, z__5.i = bb.r
* cc.i + bb.i * cc.r;
z__1.r = z__2.r - z__5.r, z__1.i = z__2.i -
z__5.i;
det.r = z__1.r, det.i = z__1.i;
z__2.r = -det.r, z__2.i = -det.i;
z_sqrt(&z__1, &z__2);
rtdisc.r = z__1.r, rtdisc.i = z__1.i;
i__2 = kbot - 1;
z__2.r = tr2.r + rtdisc.r, z__2.i = tr2.i +
rtdisc.i;
z__1.r = s * z__2.r, z__1.i = s * z__2.i;
w[i__2].r = z__1.r, w[i__2].i = z__1.i;
i__2 = kbot;
z__2.r = tr2.r - rtdisc.r, z__2.i = tr2.i -
rtdisc.i;
z__1.r = s * z__2.r, z__1.i = s * z__2.i;
w[i__2].r = z__1.r, w[i__2].i = z__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 ((d__1 = w[i__4].r, abs(d__1)) + (d__2 =
d_imag(&w[i__]), abs(d__2)) < (d__3 =
w[i__5].r, abs(d__3)) + (d__4 =
d_imag(&w[i__ + 1]), abs(d__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;
}
/* L40: */
}
/* L50: */
}
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;
z__2.r = w[i__2].r - h__[i__3].r, z__2.i = w[i__2].i -
h__[i__3].i;
z__1.r = z__2.r, z__1.i = z__2.i;
i__4 = kbot - 1;
i__5 = kbot + kbot * h_dim1;
z__4.r = w[i__4].r - h__[i__5].r, z__4.i = w[i__4].i -
h__[i__5].i;
z__3.r = z__4.r, z__3.i = z__4.i;
if ((d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1),
abs(d__2)) < (d__3 = z__3.r, abs(d__3)) + (d__4 =
d_imag(&z__3), abs(d__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 ==== */
zlaqr5_(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 ==== */
/* L70: */
}
/* ==== Iteration limit exceeded. Set INFO to show where */
/* . the problem occurred and exit. ==== */
*info = kbot;
L80:
;
}
/* ==== Return the optimal value of LWORK. ==== */
d__1 = (doublereal) lwkopt;
z__1.r = d__1, z__1.i = 0.;
work[1].r = z__1.r, work[1].i = z__1.i;
/* ==== End of ZLAQR4 ==== */
return 0;
} /* zlaqr4_ */
/* Subroutine */ int zlaic1_(integer *job, integer *j, doublecomplex *x,
doublereal *sest, doublecomplex *w, doublecomplex *gamma, doublereal *
sestpr, doublecomplex *s, doublecomplex *c)
{
/* -- LAPACK auxiliary routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
ZLAIC1 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 ZLAIC1 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*16 array, dimension (J)
The j-vector x.
SEST (input) DOUBLE PRECISION
Estimated singular value of j by j matrix L
W (input) COMPLEX*16 array, dimension (J)
The j-vector w.
GAMMA (input) COMPLEX*16
The diagonal element gamma.
SEDTPR (output) DOUBLE PRECISION
Estimated singular value of (j+1) by (j+1) matrix Lhat.
S (output) COMPLEX*16
Sine needed in forming xhat.
C (output) COMPLEX*16
Cosine needed in forming xhat.
=====================================================================
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
/* Builtin functions */
double z_abs(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *), z_sqrt(doublecomplex *,
doublecomplex *);
double sqrt(doublereal);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
/* Local variables */
static doublecomplex sine;
static doublereal test, zeta1, zeta2, b, t;
static doublecomplex alpha;
static doublereal norma;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static doublereal s1, s2;
extern doublereal dlamch_(char *);
static doublereal absgam, absalp;
static doublecomplex cosine;
static doublereal absest, scl, eps, tmp;
#define W(I) w[(I)-1]
#define X(I) x[(I)-1]
eps = dlamch_("Epsilon");
zdotc_(&z__1, j, &X(1), &c__1, &W(1), &c__1);
alpha.r = z__1.r, alpha.i = z__1.i;
absalp = z_abs(&alpha);
absgam = z_abs(gamma);
absest = abs(*sest);
if (*job == 1) {
/* Estimating largest singular value
special cases */
if (*sest == 0.) {
s1 = max(absgam,absalp);
if (s1 == 0.) {
s->r = 0., s->i = 0.;
c->r = 1., c->i = 0.;
*sestpr = 0.;
} else {
z__1.r = alpha.r / s1, z__1.i = alpha.i / s1;
s->r = z__1.r, s->i = z__1.i;
z__1.r = gamma->r / s1, z__1.i = gamma->i / s1;
c->r = z__1.r, c->i = z__1.i;
d_cnjg(&z__4, s);
z__3.r = s->r * z__4.r - s->i * z__4.i, z__3.i = s->r *
z__4.i + s->i * z__4.r;
d_cnjg(&z__6, c);
z__5.r = c->r * z__6.r - c->i * z__6.i, z__5.i = c->r *
z__6.i + c->i * z__6.r;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
z_sqrt(&z__1, &z__2);
tmp = z__1.r;
z__1.r = s->r / tmp, z__1.i = s->i / tmp;
s->r = z__1.r, s->i = z__1.i;
z__1.r = c->r / tmp, z__1.i = c->i / tmp;
c->r = z__1.r, c->i = z__1.i;
*sestpr = s1 * tmp;
}
return 0;
} else if (absgam <= eps * absest) {
s->r = 1., s->i = 0.;
c->r = 0., c->i = 0.;
tmp = max(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., s->i = 0.;
c->r = 0., c->i = 0.;
*sestpr = s2;
} else {
s->r = 0., s->i = 0.;
c->r = 1., c->i = 0.;
*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.);
*sestpr = s2 * scl;
z__2.r = alpha.r / s2, z__2.i = alpha.i / s2;
z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
s->r = z__1.r, s->i = z__1.i;
z__2.r = gamma->r / s2, z__2.i = gamma->i / s2;
z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
c->r = z__1.r, c->i = z__1.i;
} else {
tmp = s2 / s1;
scl = sqrt(tmp * tmp + 1.);
*sestpr = s1 * scl;
z__2.r = alpha.r / s1, z__2.i = alpha.i / s1;
z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
s->r = z__1.r, s->i = z__1.i;
z__2.r = gamma->r / s1, z__2.i = gamma->i / s1;
z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
c->r = z__1.r, c->i = z__1.i;
}
return 0;
} else {
/* normal case */
zeta1 = absalp / absest;
zeta2 = absgam / absest;
b = (1. - zeta1 * zeta1 - zeta2 * zeta2) * .5;
d__1 = zeta1 * zeta1;
c->r = d__1, c->i = 0.;
if (b > 0.) {
d__1 = b * b;
z__4.r = d__1 + c->r, z__4.i = c->i;
z_sqrt(&z__3, &z__4);
z__2.r = b + z__3.r, z__2.i = z__3.i;
z_div(&z__1, c, &z__2);
t = z__1.r;
} else {
d__1 = b * b;
z__3.r = d__1 + c->r, z__3.i = c->i;
z_sqrt(&z__2, &z__3);
z__1.r = z__2.r - b, z__1.i = z__2.i;
t = z__1.r;
}
z__3.r = alpha.r / absest, z__3.i = alpha.i / absest;
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__1.r = z__2.r / t, z__1.i = z__2.i / t;
sine.r = z__1.r, sine.i = z__1.i;
z__3.r = gamma->r / absest, z__3.i = gamma->i / absest;
z__2.r = -z__3.r, z__2.i = -z__3.i;
d__1 = t + 1.;
z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
cosine.r = z__1.r, cosine.i = z__1.i;
d_cnjg(&z__4, &sine);
z__3.r = sine.r * z__4.r - sine.i * z__4.i, z__3.i = sine.r *
z__4.i + sine.i * z__4.r;
d_cnjg(&z__6, &cosine);
z__5.r = cosine.r * z__6.r - cosine.i * z__6.i, z__5.i = cosine.r
* z__6.i + cosine.i * z__6.r;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
z_sqrt(&z__1, &z__2);
tmp = z__1.r;
z__1.r = sine.r / tmp, z__1.i = sine.i / tmp;
s->r = z__1.r, s->i = z__1.i;
z__1.r = cosine.r / tmp, z__1.i = cosine.i / tmp;
c->r = z__1.r, c->i = z__1.i;
*sestpr = sqrt(t + 1.) * absest;
return 0;
}
} else if (*job == 2) {
/* Estimating smallest singular value
special cases */
if (*sest == 0.) {
*sestpr = 0.;
if (max(absgam,absalp) == 0.) {
sine.r = 1., sine.i = 0.;
cosine.r = 0., cosine.i = 0.;
} else {
d_cnjg(&z__2, gamma);
z__1.r = -z__2.r, z__1.i = -z__2.i;
sine.r = z__1.r, sine.i = z__1.i;
d_cnjg(&z__1, &alpha);
cosine.r = z__1.r, cosine.i = z__1.i;
}
/* Computing MAX */
d__1 = z_abs(&sine), d__2 = z_abs(&cosine);
s1 = max(d__1,d__2);
z__1.r = sine.r / s1, z__1.i = sine.i / s1;
s->r = z__1.r, s->i = z__1.i;
z__1.r = cosine.r / s1, z__1.i = cosine.i / s1;
c->r = z__1.r, c->i = z__1.i;
d_cnjg(&z__4, s);
z__3.r = s->r * z__4.r - s->i * z__4.i, z__3.i = s->r * z__4.i +
s->i * z__4.r;
d_cnjg(&z__6, c);
z__5.r = c->r * z__6.r - c->i * z__6.i, z__5.i = c->r * z__6.i +
c->i * z__6.r;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
z_sqrt(&z__1, &z__2);
tmp = z__1.r;
z__1.r = s->r / tmp, z__1.i = s->i / tmp;
s->r = z__1.r, s->i = z__1.i;
z__1.r = c->r / tmp, z__1.i = c->i / tmp;
c->r = z__1.r, c->i = z__1.i;
return 0;
} else if (absgam <= eps * absest) {
s->r = 0., s->i = 0.;
c->r = 1., c->i = 0.;
*sestpr = absgam;
return 0;
} else if (absalp <= eps * absest) {
s1 = absgam;
s2 = absest;
if (s1 <= s2) {
s->r = 0., s->i = 0.;
c->r = 1., c->i = 0.;
*sestpr = s1;
} else {
s->r = 1., s->i = 0.;
c->r = 0., c->i = 0.;
*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.);
*sestpr = absest * (tmp / scl);
d_cnjg(&z__4, gamma);
z__3.r = z__4.r / s2, z__3.i = z__4.i / s2;
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
s->r = z__1.r, s->i = z__1.i;
d_cnjg(&z__3, &alpha);
z__2.r = z__3.r / s2, z__2.i = z__3.i / s2;
z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
c->r = z__1.r, c->i = z__1.i;
} else {
tmp = s2 / s1;
scl = sqrt(tmp * tmp + 1.);
*sestpr = absest / scl;
d_cnjg(&z__4, gamma);
z__3.r = z__4.r / s1, z__3.i = z__4.i / s1;
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
s->r = z__1.r, s->i = z__1.i;
d_cnjg(&z__3, &alpha);
z__2.r = z__3.r / s1, z__2.i = z__3.i / s1;
z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
c->r = z__1.r, c->i = z__1.i;
}
return 0;
} else {
/* normal case */
zeta1 = absalp / absest;
zeta2 = absgam / absest;
/* Computing MAX */
d__1 = zeta1 * zeta1 + 1. + zeta1 * zeta2, d__2 = zeta1 * zeta2 +
zeta2 * zeta2;
norma = max(d__1,d__2);
/* See if root is closer to zero or to ONE */
test = (zeta1 - zeta2) * 2. * (zeta1 + zeta2) + 1.;
if (test >= 0.) {
/* root is close to zero, compute directly */
b = (zeta1 * zeta1 + zeta2 * zeta2 + 1.) * .5;
d__1 = zeta2 * zeta2;
c->r = d__1, c->i = 0.;
d__2 = b * b;
z__2.r = d__2 - c->r, z__2.i = -c->i;
d__1 = b + sqrt(z_abs(&z__2));
z__1.r = c->r / d__1, z__1.i = c->i / d__1;
t = z__1.r;
z__2.r = alpha.r / absest, z__2.i = alpha.i / absest;
d__1 = 1. - t;
z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
sine.r = z__1.r, sine.i = z__1.i;
z__3.r = gamma->r / absest, z__3.i = gamma->i / absest;
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__1.r = z__2.r / t, z__1.i = z__2.i / t;
cosine.r = z__1.r, cosine.i = z__1.i;
*sestpr = sqrt(t + eps * 4. * eps * norma) * absest;
} else {
/* root is closer to ONE, shift by that amount */
b = (zeta2 * zeta2 + zeta1 * zeta1 - 1.) * .5;
d__1 = zeta1 * zeta1;
c->r = d__1, c->i = 0.;
if (b >= 0.) {
z__2.r = -c->r, z__2.i = -c->i;
d__1 = b * b;
z__5.r = d__1 + c->r, z__5.i = c->i;
z_sqrt(&z__4, &z__5);
z__3.r = b + z__4.r, z__3.i = z__4.i;
z_div(&z__1, &z__2, &z__3);
t = z__1.r;
} else {
d__1 = b * b;
z__3.r = d__1 + c->r, z__3.i = c->i;
z_sqrt(&z__2, &z__3);
z__1.r = b - z__2.r, z__1.i = -z__2.i;
t = z__1.r;
}
z__3.r = alpha.r / absest, z__3.i = alpha.i / absest;
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__1.r = z__2.r / t, z__1.i = z__2.i / t;
sine.r = z__1.r, sine.i = z__1.i;
z__3.r = gamma->r / absest, z__3.i = gamma->i / absest;
z__2.r = -z__3.r, z__2.i = -z__3.i;
d__1 = t + 1.;
z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
cosine.r = z__1.r, cosine.i = z__1.i;
*sestpr = sqrt(t + 1. + eps * 4. * eps * norma) * absest;
}
d_cnjg(&z__4, &sine);
z__3.r = sine.r * z__4.r - sine.i * z__4.i, z__3.i = sine.r *
z__4.i + sine.i * z__4.r;
d_cnjg(&z__6, &cosine);
z__5.r = cosine.r * z__6.r - cosine.i * z__6.i, z__5.i = cosine.r
* z__6.i + cosine.i * z__6.r;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
z_sqrt(&z__1, &z__2);
tmp = z__1.r;
z__1.r = sine.r / tmp, z__1.i = sine.i / tmp;
s->r = z__1.r, s->i = z__1.i;
z__1.r = cosine.r / tmp, z__1.i = cosine.i / tmp;
c->r = z__1.r, c->i = z__1.i;
return 0;
}
}
return 0;
/* End of ZLAIC1 */
} /* zlaic1_ */
/* Subroutine */ int zlaic1_(integer *job, integer *j, doublecomplex *x,
doublereal *sest, doublecomplex *w, doublecomplex *gamma, doublereal *
sestpr, doublecomplex *s, doublecomplex *c__)
{
/* System generated locals */
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
/* Builtin functions */
double z_abs(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *), z_sqrt(doublecomplex *,
doublecomplex *);
double sqrt(doublereal);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
/* Local variables */
doublereal b, t, s1, s2, scl, eps, tmp;
doublecomplex sine;
doublereal test, zeta1, zeta2;
doublecomplex alpha;
doublereal norma;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal dlamch_(char *);
doublereal absgam, absalp;
doublecomplex cosine;
doublereal absest;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLAIC1 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 ZLAIC1 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*16 array, dimension (J) */
/* The j-vector x. */
/* SEST (input) DOUBLE PRECISION */
/* Estimated singular value of j by j matrix L */
/* W (input) COMPLEX*16 array, dimension (J) */
/* The j-vector w. */
/* GAMMA (input) COMPLEX*16 */
/* The diagonal element gamma. */
/* SESTPR (output) DOUBLE PRECISION */
/* Estimated singular value of (j+1) by (j+1) matrix Lhat. */
/* S (output) COMPLEX*16 */
/* Sine needed in forming xhat. */
/* C (output) COMPLEX*16 */
/* Cosine needed in forming xhat. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--w;
--x;
/* Function Body */
eps = dlamch_("Epsilon");
zdotc_(&z__1, j, &x[1], &c__1, &w[1], &c__1);
alpha.r = z__1.r, alpha.i = z__1.i;
absalp = z_abs(&alpha);
absgam = z_abs(gamma);
absest = abs(*sest);
if (*job == 1) {
/* Estimating largest singular value */
/* special cases */
if (*sest == 0.) {
s1 = max(absgam,absalp);
if (s1 == 0.) {
s->r = 0., s->i = 0.;
c__->r = 1., c__->i = 0.;
*sestpr = 0.;
} else {
z__1.r = alpha.r / s1, z__1.i = alpha.i / s1;
s->r = z__1.r, s->i = z__1.i;
z__1.r = gamma->r / s1, z__1.i = gamma->i / s1;
c__->r = z__1.r, c__->i = z__1.i;
d_cnjg(&z__4, s);
z__3.r = s->r * z__4.r - s->i * z__4.i, z__3.i = s->r *
z__4.i + s->i * z__4.r;
d_cnjg(&z__6, c__);
z__5.r = c__->r * z__6.r - c__->i * z__6.i, z__5.i = c__->r *
z__6.i + c__->i * z__6.r;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
z_sqrt(&z__1, &z__2);
tmp = z__1.r;
z__1.r = s->r / tmp, z__1.i = s->i / tmp;
s->r = z__1.r, s->i = z__1.i;
z__1.r = c__->r / tmp, z__1.i = c__->i / tmp;
c__->r = z__1.r, c__->i = z__1.i;
*sestpr = s1 * tmp;
}
return 0;
} else if (absgam <= eps * absest) {
s->r = 1., s->i = 0.;
c__->r = 0., c__->i = 0.;
tmp = max(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., s->i = 0.;
c__->r = 0., c__->i = 0.;
*sestpr = s2;
} else {
s->r = 0., s->i = 0.;
c__->r = 1., c__->i = 0.;
*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.);
*sestpr = s2 * scl;
z__2.r = alpha.r / s2, z__2.i = alpha.i / s2;
z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
s->r = z__1.r, s->i = z__1.i;
z__2.r = gamma->r / s2, z__2.i = gamma->i / s2;
z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
c__->r = z__1.r, c__->i = z__1.i;
} else {
tmp = s2 / s1;
scl = sqrt(tmp * tmp + 1.);
*sestpr = s1 * scl;
z__2.r = alpha.r / s1, z__2.i = alpha.i / s1;
z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
s->r = z__1.r, s->i = z__1.i;
z__2.r = gamma->r / s1, z__2.i = gamma->i / s1;
z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
c__->r = z__1.r, c__->i = z__1.i;
}
return 0;
} else {
/* normal case */
zeta1 = absalp / absest;
zeta2 = absgam / absest;
b = (1. - zeta1 * zeta1 - zeta2 * zeta2) * .5;
d__1 = zeta1 * zeta1;
c__->r = d__1, c__->i = 0.;
if (b > 0.) {
d__1 = b * b;
z__4.r = d__1 + c__->r, z__4.i = c__->i;
z_sqrt(&z__3, &z__4);
z__2.r = b + z__3.r, z__2.i = z__3.i;
z_div(&z__1, c__, &z__2);
t = z__1.r;
} else {
d__1 = b * b;
z__3.r = d__1 + c__->r, z__3.i = c__->i;
z_sqrt(&z__2, &z__3);
z__1.r = z__2.r - b, z__1.i = z__2.i;
t = z__1.r;
}
z__3.r = alpha.r / absest, z__3.i = alpha.i / absest;
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__1.r = z__2.r / t, z__1.i = z__2.i / t;
sine.r = z__1.r, sine.i = z__1.i;
z__3.r = gamma->r / absest, z__3.i = gamma->i / absest;
z__2.r = -z__3.r, z__2.i = -z__3.i;
d__1 = t + 1.;
z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
cosine.r = z__1.r, cosine.i = z__1.i;
d_cnjg(&z__4, &sine);
z__3.r = sine.r * z__4.r - sine.i * z__4.i, z__3.i = sine.r *
z__4.i + sine.i * z__4.r;
d_cnjg(&z__6, &cosine);
z__5.r = cosine.r * z__6.r - cosine.i * z__6.i, z__5.i = cosine.r
* z__6.i + cosine.i * z__6.r;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
z_sqrt(&z__1, &z__2);
tmp = z__1.r;
z__1.r = sine.r / tmp, z__1.i = sine.i / tmp;
s->r = z__1.r, s->i = z__1.i;
z__1.r = cosine.r / tmp, z__1.i = cosine.i / tmp;
c__->r = z__1.r, c__->i = z__1.i;
*sestpr = sqrt(t + 1.) * absest;
return 0;
}
} else if (*job == 2) {
/* Estimating smallest singular value */
/* special cases */
if (*sest == 0.) {
*sestpr = 0.;
if (max(absgam,absalp) == 0.) {
sine.r = 1., sine.i = 0.;
cosine.r = 0., cosine.i = 0.;
} else {
d_cnjg(&z__2, gamma);
z__1.r = -z__2.r, z__1.i = -z__2.i;
sine.r = z__1.r, sine.i = z__1.i;
d_cnjg(&z__1, &alpha);
cosine.r = z__1.r, cosine.i = z__1.i;
}
/* Computing MAX */
d__1 = z_abs(&sine), d__2 = z_abs(&cosine);
s1 = max(d__1,d__2);
z__1.r = sine.r / s1, z__1.i = sine.i / s1;
s->r = z__1.r, s->i = z__1.i;
z__1.r = cosine.r / s1, z__1.i = cosine.i / s1;
c__->r = z__1.r, c__->i = z__1.i;
d_cnjg(&z__4, s);
z__3.r = s->r * z__4.r - s->i * z__4.i, z__3.i = s->r * z__4.i +
s->i * z__4.r;
d_cnjg(&z__6, c__);
z__5.r = c__->r * z__6.r - c__->i * z__6.i, z__5.i = c__->r *
z__6.i + c__->i * z__6.r;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
z_sqrt(&z__1, &z__2);
tmp = z__1.r;
z__1.r = s->r / tmp, z__1.i = s->i / tmp;
s->r = z__1.r, s->i = z__1.i;
z__1.r = c__->r / tmp, z__1.i = c__->i / tmp;
c__->r = z__1.r, c__->i = z__1.i;
return 0;
} else if (absgam <= eps * absest) {
s->r = 0., s->i = 0.;
c__->r = 1., c__->i = 0.;
*sestpr = absgam;
return 0;
} else if (absalp <= eps * absest) {
s1 = absgam;
s2 = absest;
if (s1 <= s2) {
s->r = 0., s->i = 0.;
c__->r = 1., c__->i = 0.;
*sestpr = s1;
} else {
s->r = 1., s->i = 0.;
c__->r = 0., c__->i = 0.;
*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.);
*sestpr = absest * (tmp / scl);
d_cnjg(&z__4, gamma);
z__3.r = z__4.r / s2, z__3.i = z__4.i / s2;
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
s->r = z__1.r, s->i = z__1.i;
d_cnjg(&z__3, &alpha);
z__2.r = z__3.r / s2, z__2.i = z__3.i / s2;
z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
c__->r = z__1.r, c__->i = z__1.i;
} else {
tmp = s2 / s1;
scl = sqrt(tmp * tmp + 1.);
*sestpr = absest / scl;
d_cnjg(&z__4, gamma);
z__3.r = z__4.r / s1, z__3.i = z__4.i / s1;
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
s->r = z__1.r, s->i = z__1.i;
d_cnjg(&z__3, &alpha);
z__2.r = z__3.r / s1, z__2.i = z__3.i / s1;
z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
c__->r = z__1.r, c__->i = z__1.i;
}
return 0;
} else {
/* normal case */
zeta1 = absalp / absest;
zeta2 = absgam / absest;
/* Computing MAX */
d__1 = zeta1 * zeta1 + 1. + zeta1 * zeta2, d__2 = zeta1 * zeta2 +
zeta2 * zeta2;
norma = max(d__1,d__2);
/* See if root is closer to zero or to ONE */
test = (zeta1 - zeta2) * 2. * (zeta1 + zeta2) + 1.;
if (test >= 0.) {
/* root is close to zero, compute directly */
b = (zeta1 * zeta1 + zeta2 * zeta2 + 1.) * .5;
d__1 = zeta2 * zeta2;
c__->r = d__1, c__->i = 0.;
d__2 = b * b;
z__2.r = d__2 - c__->r, z__2.i = -c__->i;
d__1 = b + sqrt(z_abs(&z__2));
z__1.r = c__->r / d__1, z__1.i = c__->i / d__1;
t = z__1.r;
z__2.r = alpha.r / absest, z__2.i = alpha.i / absest;
d__1 = 1. - t;
z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
sine.r = z__1.r, sine.i = z__1.i;
z__3.r = gamma->r / absest, z__3.i = gamma->i / absest;
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__1.r = z__2.r / t, z__1.i = z__2.i / t;
cosine.r = z__1.r, cosine.i = z__1.i;
*sestpr = sqrt(t + eps * 4. * eps * norma) * absest;
} else {
/* root is closer to ONE, shift by that amount */
b = (zeta2 * zeta2 + zeta1 * zeta1 - 1.) * .5;
d__1 = zeta1 * zeta1;
c__->r = d__1, c__->i = 0.;
if (b >= 0.) {
z__2.r = -c__->r, z__2.i = -c__->i;
d__1 = b * b;
z__5.r = d__1 + c__->r, z__5.i = c__->i;
z_sqrt(&z__4, &z__5);
z__3.r = b + z__4.r, z__3.i = z__4.i;
z_div(&z__1, &z__2, &z__3);
t = z__1.r;
} else {
d__1 = b * b;
z__3.r = d__1 + c__->r, z__3.i = c__->i;
z_sqrt(&z__2, &z__3);
z__1.r = b - z__2.r, z__1.i = -z__2.i;
t = z__1.r;
}
z__3.r = alpha.r / absest, z__3.i = alpha.i / absest;
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__1.r = z__2.r / t, z__1.i = z__2.i / t;
sine.r = z__1.r, sine.i = z__1.i;
z__3.r = gamma->r / absest, z__3.i = gamma->i / absest;
z__2.r = -z__3.r, z__2.i = -z__3.i;
d__1 = t + 1.;
z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
cosine.r = z__1.r, cosine.i = z__1.i;
*sestpr = sqrt(t + 1. + eps * 4. * eps * norma) * absest;
}
d_cnjg(&z__4, &sine);
z__3.r = sine.r * z__4.r - sine.i * z__4.i, z__3.i = sine.r *
z__4.i + sine.i * z__4.r;
d_cnjg(&z__6, &cosine);
z__5.r = cosine.r * z__6.r - cosine.i * z__6.i, z__5.i = cosine.r
* z__6.i + cosine.i * z__6.r;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
z_sqrt(&z__1, &z__2);
tmp = z__1.r;
z__1.r = sine.r / tmp, z__1.i = sine.i / tmp;
s->r = z__1.r, s->i = z__1.i;
z__1.r = cosine.r / tmp, z__1.i = cosine.i / tmp;
c__->r = z__1.r, c__->i = z__1.i;
return 0;
}
}
return 0;
/* End of ZLAIC1 */
} /* zlaic1_ */
/* Subroutine */ int brlzon_(doublereal *fmatrx, doublereal *fmat2d, integer *
n3, complex *sec, complex *vec, doublereal *b, integer *mono3,
doublereal *step, integer *mode)
{
/* System generated locals */
integer fmat2d_dim1, fmat2d_offset, b_dim1, b_offset, sec_dim1,
sec_offset, vec_dim1, vec_offset, i__1, i__2, i__3, i__4, i__5,
i__6, i__7, i__8;
doublereal d__1, d__2, d__3;
doublecomplex z__1, z__2, z__3, z__4, z__5;
/* Builtin functions */
double acos(doublereal);
void z_sqrt(doublecomplex *, doublecomplex *), z_exp(doublecomplex *,
doublecomplex *);
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_stop(char *, ftnlen);
/* Local variables */
static doublereal c__;
static integer i__, j, k, m, ii, jj;
static doublereal ri;
static integer iii;
static doublereal cay, top, fact;
static real eigs[360];
extern /* Subroutine */ int dofs_(doublereal *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
static integer loop;
extern /* Subroutine */ int cdiag_(complex *, real *, complex *, integer *
, integer *);
static complex phase;
static doublereal twopi;
static integer ncells;
static doublereal bottom;
/* Fortran I/O blocks */
static cilist io___19 = { 0, 6, 0, "(//,A,F6.3,/)", 0 };
static cilist io___20 = { 0, 6, 0, "(/,A,I4,/)", 0 };
static cilist io___21 = { 0, 6, 0, "(6(F6.3,F7.1))", 0 };
static cilist io___22 = { 0, 6, 0, "(//,A,F6.3,/)", 0 };
static cilist io___23 = { 0, 6, 0, "(A,/,A,I4,/,A)", 0 };
static cilist io___24 = { 0, 6, 0, "(6(F6.3,F7.2))", 0 };
/* COMDECK SIZES */
/* *********************************************************************** */
/* THIS FILE CONTAINS ALL THE ARRAY SIZES FOR USE IN MOPAC. */
/* THERE ARE ONLY 5 PARAMETERS THAT THE PROGRAMMER NEED SET: */
/* MAXHEV = MAXIMUM NUMBER OF HEAVY ATOMS (HEAVY: NON-HYDROGEN ATOMS) */
/* MAXLIT = MAXIMUM NUMBER OF HYDROGEN ATOMS. */
/* MAXTIM = DEFAULT TIME FOR A JOB. (SECONDS) */
/* MAXDMP = DEFAULT TIME FOR AUTOMATIC RESTART FILE GENERATION (SECS) */
/* ISYBYL = 1 IF MOPAC IS TO BE USED IN THE SYBYL PACKAGE, =0 OTHERWISE */
/* SEE ALSO NMECI, NPULAY AND MESP AT THE END OF THIS FILE */
/* *********************************************************************** */
/* THE FOLLOWING CODE DOES NOT NEED TO BE ALTERED BY THE PROGRAMMER */
/* *********************************************************************** */
/* ALL OTHER PARAMETERS ARE DERIVED FUNCTIONS OF THESE TWO PARAMETERS */
/* NAME DEFINITION */
/* NUMATM MAXIMUM NUMBER OF ATOMS ALLOWED. */
/* MAXORB MAXIMUM NUMBER OF ORBITALS ALLOWED. */
/* MAXPAR MAXIMUM NUMBER OF PARAMETERS FOR OPTIMISATION. */
/* N2ELEC MAXIMUM NUMBER OF TWO ELECTRON INTEGRALS ALLOWED. */
/* MPACK AREA OF LOWER HALF TRIANGLE OF DENSITY MATRIX. */
/* MORB2 SQUARE OF THE MAXIMUM NUMBER OF ORBITALS ALLOWED. */
/* MAXHES AREA OF HESSIAN MATRIX */
/* MAXALL LARGER THAN MAXORB OR MAXPAR. */
/* *********************************************************************** */
/* *********************************************************************** */
/* DECK MOPAC */
/* ********************************************************************** */
/* IF MODE IS 1 THEN */
/* BRLZON COMPUTES THE PHONON SPECTRUM OF A LINEAR POLYMER GIVEN */
/* THE WEIGHTED HESSIAN MATRIX. */
/* IF MODE IS 2 THEN */
/* BRLZON COMPUTES THE ELECTRONIC ENERGY BAND STRUCTURE OF A LINEAR */
/* POLYMER GIVEN THE FOCK MATRIX. */
/* ON INPUT */
/* IF MODE IS 1 THEN */
/* FMATRX IS THE MASS-WEIGHTED HESSIAN MATRIX, PACKED LOWER */
/* HALF TRIANGLE */
/* N3 IS 3*(NUMBER OF ATOMS IN UNIT CELL) = SIZE OF FMATRX */
/* MONO3 IS 3*(NUMBER OF ATOMS IN PRIMITIVE UNIT CELL) */
/* FMAT2D, SEC, VEC ARE SCRATCH ARRAYS */
/* IF MODE IS 2 THEN */
/* FMATRX IS THE FOCK MATRIX, PACKED LOWER HALF TRIANGLE */
/* N3 IS NUMBER OF ATOMIC ORBITALS IN SYSTEM = SIZE OF FMATRX */
/* MONO3 IS NUMBER OF ATOMIC ORBITALS IN FUNDAMENTAL UNIT CELL */
/* FMAT2D, SEC, VEC ARE SCRATCH ARRAYS */
/* ********************************************************************** */
/* Parameter adjustments */
fmat2d_dim1 = *n3;
fmat2d_offset = 1 + fmat2d_dim1 * 1;
fmat2d -= fmat2d_offset;
--fmatrx;
b_dim1 = *mono3;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
vec_dim1 = *mono3;
vec_offset = 1 + vec_dim1 * 1;
vec -= vec_offset;
sec_dim1 = *mono3;
sec_offset = 1 + sec_dim1 * 1;
sec -= sec_offset;
/* Function Body */
fact = 6.023e23;
c__ = 2.998e10;
twopi = acos(-1.) * 2.;
/* NCELLS IS THE NUMBER OF PRIMITIVE UNIT CELLS IN THE UNIT CELL */
ncells = *n3 / *mono3;
/* PUT THE ENERGY MATRIX INTO SQUARE MATRIX FORM */
k = 0;
i__1 = *n3;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
++k;
/* L10: */
fmat2d[i__ + j * fmat2d_dim1] = fmatrx[k];
}
}
/* STEP IS THE STEP SIZE IN THE BRILLOUIN ZONE (BOUNDARIES: 0.0 - 0.5), */
/* THERE ARE M OF THESE. */
/* MONO3 IS THE SIZE OF ONE MER (MONOMERIC UNIT) */
m = (integer) (.5 / *step + 1);
i__2 = m;
for (loop = 1; loop <= i__2; ++loop) {
i__1 = *mono3;
for (i__ = 1; i__ <= i__1; ++i__) {
i__3 = *mono3;
for (j = 1; j <= i__3; ++j) {
/* L20: */
i__4 = i__ + j * sec_dim1;
sec[i__4].r = 0.f, sec[i__4].i = 0.f;
}
}
cay = (loop - 1) * *step;
i__4 = *n3;
i__3 = *mono3;
for (i__ = 1; i__3 < 0 ? i__ >= i__4 : i__ <= i__4; i__ += i__3) {
ri = (doublereal) ((i__ - 1) / *mono3);
/* IF THE PRIMITIVE UNIT CELL IS MORE THAN HALF WAY ACROSS THE UNIT CELL, */
/* CONSIDER IT AS BEING LESS THAN HALF WAY ACROSS, BUT IN THE OPPOSITE */
/* DIRECTION. */
if (ri > (doublereal) (ncells / 2)) {
ri -= ncells;
}
/* PHASE IS THE COMPLEX PHASE EXP(I.K.R(I)*(2PI)) */
z_sqrt(&z__5, &c_b6);
z__4.r = cay * z__5.r, z__4.i = cay * z__5.i;
z__3.r = ri * z__4.r, z__3.i = ri * z__4.i;
z__2.r = twopi * z__3.r, z__2.i = twopi * z__3.i;
z_exp(&z__1, &z__2);
phase.r = z__1.r, phase.i = z__1.i;
i__1 = *mono3;
for (ii = 1; ii <= i__1; ++ii) {
iii = ii + i__ - 1;
i__5 = ii;
for (jj = 1; jj <= i__5; ++jj) {
/* L30: */
i__6 = ii + jj * sec_dim1;
i__7 = ii + jj * sec_dim1;
i__8 = iii + jj * fmat2d_dim1;
z__2.r = fmat2d[i__8] * phase.r, z__2.i = fmat2d[i__8] *
phase.i;
z__1.r = sec[i__7].r + z__2.r, z__1.i = sec[i__7].i +
z__2.i;
sec[i__6].r = z__1.r, sec[i__6].i = z__1.i;
}
}
/* L40: */
}
cdiag_(&sec[sec_offset], eigs, &vec[vec_offset], mono3, &c__0);
if (*mode == 1) {
/* CONVERT INTO RECIPRICAL CENTIMETERS */
i__3 = *mono3;
for (i__ = 1; i__ <= i__3; ++i__) {
/* L50: */
d__2 = sqrt(fact * (d__1 = eigs[i__ - 1] * 1e5, abs(d__1))) /
(c__ * twopi);
d__3 = (doublereal) eigs[i__ - 1];
b[i__ + loop * b_dim1] = d_sign(&d__2, &d__3);
}
} else {
i__3 = *mono3;
for (i__ = 1; i__ <= i__3; ++i__) {
/* L60: */
b[i__ + loop * b_dim1] = eigs[i__ - 1];
}
}
/* L70: */
}
bottom = 1e6;
top = -1e6;
i__2 = *mono3;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = m;
for (j = 1; j <= i__3; ++j) {
/* Computing MIN */
d__1 = bottom, d__2 = b[i__ + j * b_dim1];
bottom = min(d__1,d__2);
/* L80: */
/* Computing MAX */
d__1 = top, d__2 = b[i__ + j * b_dim1];
top = max(d__1,d__2);
}
}
if (*mode == 1) {
s_wsfe(&io___19);
do_fio(&c__1, " FREQUENCIES IN CM(-1) FOR PHONON SPECTRUM ACROSS BRI"
"LLOUIN ZONE", (ftnlen)64);
e_wsfe();
i__3 = *mono3;
for (i__ = 1; i__ <= i__3; ++i__) {
s_wsfe(&io___20);
do_fio(&c__1, " BAND:", (ftnlen)7);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
e_wsfe();
/* L90: */
s_wsfe(&io___21);
i__2 = m;
for (j = 1; j <= i__2; ++j) {
d__1 = (j - 1) * *step;
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&b[i__ + j * b_dim1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
}
s_stop("", (ftnlen)0);
} else {
s_wsfe(&io___22);
do_fio(&c__1, " ENERGIES (IN EV) OF ELECTRONIC BANDS IN BAND STRUCTU"
"RE", (ftnlen)55);
e_wsfe();
i__2 = *mono3;
for (i__ = 1; i__ <= i__2; ++i__) {
s_wsfe(&io___23);
do_fio(&c__1, " .", (ftnlen)3);
do_fio(&c__1, " CURVE", (ftnlen)7);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__1, "CURVE DATA ARE", (ftnlen)14);
e_wsfe();
/* L100: */
s_wsfe(&io___24);
i__3 = m;
for (j = 1; j <= i__3; ++j) {
d__1 = (j - 1) * *step;
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&b[i__ + j * b_dim1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
}
}
dofs_(&b[b_offset], mono3, &m, &fmat2d[fmat2d_offset], &c__500, &bottom, &
top);
return 0;
} /* brlzon_ */
/* Subroutine */ int zlahqr_(logical *wantt, logical *wantz, integer *n,
integer *ilo, integer *ihi, doublecomplex *h__, integer *ldh,
doublecomplex *w, integer *iloz, integer *ihiz, doublecomplex *z__,
integer *ldz, integer *info)
{
/* System generated locals */
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double d_imag(doublecomplex *);
void z_sqrt(doublecomplex *, doublecomplex *), d_cnjg(doublecomplex *,
doublecomplex *);
double z_abs(doublecomplex *);
/* Local variables */
static doublecomplex temp;
static doublereal opst;
static integer i__, j, k, l, m;
static doublereal s;
static doublecomplex t, u, v[2], x, y;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
static doublereal rtemp;
static integer i1, i2;
static doublereal rwork[1];
static doublecomplex t1;
static doublereal t2;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
static doublecomplex v2;
static doublereal h10;
static doublecomplex h11;
static doublereal h21;
static doublecomplex h22;
static integer nh;
extern doublereal dlamch_(char *);
static integer nz;
extern /* Subroutine */ int zlarfg_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *);
extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *,
doublecomplex *);
extern doublereal zlanhs_(char *, integer *, doublecomplex *, integer *,
doublereal *);
static doublereal smlnum;
static doublecomplex h11s;
static integer itn, its;
static doublereal ulp;
static doublecomplex sum;
static doublereal tst1;
#define h___subscr(a_1,a_2) (a_2)*h_dim1 + a_1
#define h___ref(a_1,a_2) h__[h___subscr(a_1,a_2)]
#define z___subscr(a_1,a_2) (a_2)*z_dim1 + a_1
#define z___ref(a_1,a_2) z__[z___subscr(a_1,a_2)]
/* -- LAPACK auxiliary routine (instrumented to count operations) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Common block to return operation count.
Purpose
=======
ZLAHQR is an auxiliary routine called by ZHSEQR to update the
eigenvalues and Schur decomposition already computed by ZHSEQR, by
dealing with the Hessenberg submatrix in rows and columns ILO to IHI.
Arguments
=========
WANTT (input) LOGICAL
= .TRUE. : the full Schur form T is required;
= .FALSE.: only eigenvalues are required.
WANTZ (input) LOGICAL
= .TRUE. : the matrix of Schur vectors Z is required;
= .FALSE.: Schur vectors are not required.
N (input) INTEGER
The order of the matrix H. N >= 0.
ILO (input) INTEGER
IHI (input) INTEGER
It is assumed that H is already upper triangular in rows and
columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1).
ZLAHQR works primarily with the Hessenberg submatrix in rows
and columns ILO to IHI, but applies transformations to all of
H if WANTT is .TRUE..
1 <= ILO <= max(1,IHI); IHI <= N.
H (input/output) COMPLEX*16 array, dimension (LDH,N)
On entry, the upper Hessenberg matrix H.
On exit, if WANTT is .TRUE., H is upper triangular in rows
and columns ILO:IHI, with any 2-by-2 diagonal blocks in
standard form. If WANTT is .FALSE., the contents of H are
unspecified on exit.
LDH (input) INTEGER
The leading dimension of the array H. LDH >= max(1,N).
W (output) COMPLEX*16 array, dimension (N)
The computed eigenvalues ILO to IHI are stored in the
corresponding elements of W. If WANTT is .TRUE., the
eigenvalues are stored in the same order as on the diagonal
of the Schur form returned in H, with W(i) = H(i,i).
ILOZ (input) INTEGER
IHIZ (input) INTEGER
Specify the rows of Z to which transformations must be
applied if WANTZ is .TRUE..
1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
Z (input/output) COMPLEX*16 array, dimension (LDZ,N)
If WANTZ is .TRUE., on entry Z must contain the current
matrix Z of transformations accumulated by ZHSEQR, and on
exit Z has been updated; transformations are applied only to
the submatrix Z(ILOZ:IHIZ,ILO:IHI).
If WANTZ is .FALSE., Z is not referenced.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
> 0: if INFO = i, ZLAHQR failed to compute all the
eigenvalues ILO to IHI in a total of 30*(IHI-ILO+1)
iterations; elements i+1:ihi of W contain those
eigenvalues which have been successfully computed.
=====================================================================
Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1 * 1;
h__ -= h_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
/* Function Body */
*info = 0;
/* **
Initialize */
opst = 0.;
/* **
Quick return if possible */
if (*n == 0) {
return 0;
}
if (*ilo == *ihi) {
i__1 = *ilo;
i__2 = h___subscr(*ilo, *ilo);
w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i;
return 0;
}
nh = *ihi - *ilo + 1;
nz = *ihiz - *iloz + 1;
/* Set machine-dependent constants for the stopping criterion.
If norm(H) <= sqrt(OVFL), overflow should not occur. */
ulp = dlamch_("Precision");
smlnum = dlamch_("Safe minimum") / ulp;
/* I1 and I2 are the indices of the first row and last column of H
to which transformations must be applied. If eigenvalues only are
being computed, I1 and I2 are set inside the main loop. */
if (*wantt) {
i1 = 1;
i2 = *n;
}
/* ITN is the total number of QR iterations allowed. */
itn = nh * 30;
/* The main loop begins here. I is the loop index and decreases from
IHI to ILO in steps of 1. Each iteration of the loop works
with the active submatrix in rows and columns L to I.
Eigenvalues I+1 to IHI have already converged. Either L = ILO, or
H(L,L-1) is negligible so that the matrix splits. */
i__ = *ihi;
L10:
if (i__ < *ilo) {
goto L130;
}
/* Perform QR iterations on rows and columns ILO to I until a
submatrix of order 1 splits off at the bottom because a
subdiagonal element has become negligible. */
l = *ilo;
i__1 = itn;
for (its = 0; its <= i__1; ++its) {
/* Look for a single small subdiagonal element. */
i__2 = l + 1;
for (k = i__; k >= i__2; --k) {
i__3 = h___subscr(k - 1, k - 1);
i__4 = h___subscr(k, k);
tst1 = (d__1 = h__[i__3].r, abs(d__1)) + (d__2 = d_imag(&h___ref(
k - 1, k - 1)), abs(d__2)) + ((d__3 = h__[i__4].r, abs(
d__3)) + (d__4 = d_imag(&h___ref(k, k)), abs(d__4)));
if (tst1 == 0.) {
i__3 = i__ - l + 1;
tst1 = zlanhs_("1", &i__3, &h___ref(l, l), ldh, rwork);
/* **
Increment op count */
latime_1.ops += (i__ - l + 1) * 5 * (i__ - l) / 2;
/* ** */
}
i__3 = h___subscr(k, k - 1);
/* Computing MAX */
d__2 = ulp * tst1;
if ((d__1 = h__[i__3].r, abs(d__1)) <= max(d__2,smlnum)) {
goto L30;
}
/* L20: */
}
L30:
l = k;
/* **
Increment op count */
opst += (i__ - l + 1) * 5;
/* ** */
if (l > *ilo) {
/* H(L,L-1) is negligible */
i__2 = h___subscr(l, l - 1);
h__[i__2].r = 0., h__[i__2].i = 0.;
}
/* Exit from loop if a submatrix of order 1 has split off. */
if (l >= i__) {
goto L120;
}
/* Now the active submatrix is in rows and columns L to I. If
eigenvalues only are being computed, only the active submatrix
need be transformed. */
if (! (*wantt)) {
i1 = l;
i2 = i__;
}
if (its == 10 || its == 20) {
/* Exceptional shift. */
i__2 = h___subscr(i__, i__ - 1);
s = (d__1 = h__[i__2].r, abs(d__1)) * .75;
i__2 = h___subscr(i__, i__);
z__1.r = s + h__[i__2].r, z__1.i = h__[i__2].i;
t.r = z__1.r, t.i = z__1.i;
/* **
Increment op count */
opst += 1;
/* ** */
} else {
/* Wilkinson's shift. */
i__2 = h___subscr(i__, i__);
t.r = h__[i__2].r, t.i = h__[i__2].i;
i__2 = h___subscr(i__ - 1, i__);
i__3 = h___subscr(i__, i__ - 1);
d__1 = h__[i__3].r;
z__1.r = d__1 * h__[i__2].r, z__1.i = d__1 * h__[i__2].i;
u.r = z__1.r, u.i = z__1.i;
/* **
Increment op count */
opst += 2;
/* ** */
if (u.r != 0. || u.i != 0.) {
i__2 = h___subscr(i__ - 1, i__ - 1);
z__2.r = h__[i__2].r - t.r, z__2.i = h__[i__2].i - t.i;
z__1.r = z__2.r * .5, z__1.i = z__2.i * .5;
x.r = z__1.r, x.i = z__1.i;
z__3.r = x.r * x.r - x.i * x.i, z__3.i = x.r * x.i + x.i *
x.r;
z__2.r = z__3.r + u.r, z__2.i = z__3.i + u.i;
z_sqrt(&z__1, &z__2);
y.r = z__1.r, y.i = z__1.i;
if (x.r * y.r + d_imag(&x) * d_imag(&y) < 0.) {
z__1.r = -y.r, z__1.i = -y.i;
y.r = z__1.r, y.i = z__1.i;
}
z__3.r = x.r + y.r, z__3.i = x.i + y.i;
zladiv_(&z__2, &u, &z__3);
z__1.r = t.r - z__2.r, z__1.i = t.i - z__2.i;
t.r = z__1.r, t.i = z__1.i;
/* **
Increment op count */
opst += 20;
/* ** */
}
}
/* Look for two consecutive small subdiagonal elements. */
i__2 = l + 1;
for (m = i__ - 1; m >= i__2; --m) {
/* Determine the effect of starting the single-shift QR
iteration at row M, and see if this would make H(M,M-1)
negligible. */
i__3 = h___subscr(m, m);
h11.r = h__[i__3].r, h11.i = h__[i__3].i;
i__3 = h___subscr(m + 1, m + 1);
h22.r = h__[i__3].r, h22.i = h__[i__3].i;
z__1.r = h11.r - t.r, z__1.i = h11.i - t.i;
h11s.r = z__1.r, h11s.i = z__1.i;
i__3 = h___subscr(m + 1, m);
h21 = h__[i__3].r;
s = (d__1 = h11s.r, abs(d__1)) + (d__2 = d_imag(&h11s), abs(d__2))
+ abs(h21);
z__1.r = h11s.r / s, z__1.i = h11s.i / s;
h11s.r = z__1.r, h11s.i = z__1.i;
h21 /= s;
v[0].r = h11s.r, v[0].i = h11s.i;
v[1].r = h21, v[1].i = 0.;
i__3 = h___subscr(m, m - 1);
h10 = h__[i__3].r;
tst1 = ((d__1 = h11s.r, abs(d__1)) + (d__2 = d_imag(&h11s), abs(
d__2))) * ((d__3 = h11.r, abs(d__3)) + (d__4 = d_imag(&
h11), abs(d__4)) + ((d__5 = h22.r, abs(d__5)) + (d__6 =
d_imag(&h22), abs(d__6))));
if ((d__1 = h10 * h21, abs(d__1)) <= ulp * tst1) {
goto L50;
}
/* L40: */
}
i__2 = h___subscr(l, l);
h11.r = h__[i__2].r, h11.i = h__[i__2].i;
i__2 = h___subscr(l + 1, l + 1);
h22.r = h__[i__2].r, h22.i = h__[i__2].i;
z__1.r = h11.r - t.r, z__1.i = h11.i - t.i;
h11s.r = z__1.r, h11s.i = z__1.i;
i__2 = h___subscr(l + 1, l);
h21 = h__[i__2].r;
s = (d__1 = h11s.r, abs(d__1)) + (d__2 = d_imag(&h11s), abs(d__2)) +
abs(h21);
z__1.r = h11s.r / s, z__1.i = h11s.i / s;
h11s.r = z__1.r, h11s.i = z__1.i;
h21 /= s;
v[0].r = h11s.r, v[0].i = h11s.i;
v[1].r = h21, v[1].i = 0.;
L50:
/* **
Increment op count */
opst += (i__ - m) * 14;
/* **
Single-shift QR step */
i__2 = i__ - 1;
for (k = m; k <= i__2; ++k) {
/* The first iteration of this loop determines a reflection G
from the vector V and applies it from left and right to H,
thus creating a nonzero bulge below the subdiagonal.
Each subsequent iteration determines a reflection G to
restore the Hessenberg form in the (K-1)th column, and thus
chases the bulge one step toward the bottom of the active
submatrix.
V(2) is always real before the call to ZLARFG, and hence
after the call T2 ( = T1*V(2) ) is also real. */
if (k > m) {
zcopy_(&c__2, &h___ref(k, k - 1), &c__1, v, &c__1);
}
zlarfg_(&c__2, v, &v[1], &c__1, &t1);
/* **
Increment op count */
opst += 38;
/* ** */
if (k > m) {
i__3 = h___subscr(k, k - 1);
h__[i__3].r = v[0].r, h__[i__3].i = v[0].i;
i__3 = h___subscr(k + 1, k - 1);
h__[i__3].r = 0., h__[i__3].i = 0.;
}
v2.r = v[1].r, v2.i = v[1].i;
z__1.r = t1.r * v2.r - t1.i * v2.i, z__1.i = t1.r * v2.i + t1.i *
v2.r;
t2 = z__1.r;
/* Apply G from the left to transform the rows of the matrix
in columns K to I2. */
i__3 = i2;
for (j = k; j <= i__3; ++j) {
d_cnjg(&z__3, &t1);
i__4 = h___subscr(k, j);
z__2.r = z__3.r * h__[i__4].r - z__3.i * h__[i__4].i, z__2.i =
z__3.r * h__[i__4].i + z__3.i * h__[i__4].r;
i__5 = h___subscr(k + 1, j);
z__4.r = t2 * h__[i__5].r, z__4.i = t2 * h__[i__5].i;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
sum.r = z__1.r, sum.i = z__1.i;
i__4 = h___subscr(k, j);
i__5 = h___subscr(k, j);
z__1.r = h__[i__5].r - sum.r, z__1.i = h__[i__5].i - sum.i;
h__[i__4].r = z__1.r, h__[i__4].i = z__1.i;
i__4 = h___subscr(k + 1, j);
i__5 = h___subscr(k + 1, j);
z__2.r = sum.r * v2.r - sum.i * v2.i, z__2.i = sum.r * v2.i +
sum.i * v2.r;
z__1.r = h__[i__5].r - z__2.r, z__1.i = h__[i__5].i - z__2.i;
h__[i__4].r = z__1.r, h__[i__4].i = z__1.i;
/* L60: */
}
/* Apply G from the right to transform the columns of the
matrix in rows I1 to min(K+2,I).
Computing MIN */
i__4 = k + 2;
i__3 = min(i__4,i__);
for (j = i1; j <= i__3; ++j) {
i__4 = h___subscr(j, k);
z__2.r = t1.r * h__[i__4].r - t1.i * h__[i__4].i, z__2.i =
t1.r * h__[i__4].i + t1.i * h__[i__4].r;
i__5 = h___subscr(j, k + 1);
z__3.r = t2 * h__[i__5].r, z__3.i = t2 * h__[i__5].i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
sum.r = z__1.r, sum.i = z__1.i;
i__4 = h___subscr(j, k);
i__5 = h___subscr(j, k);
z__1.r = h__[i__5].r - sum.r, z__1.i = h__[i__5].i - sum.i;
h__[i__4].r = z__1.r, h__[i__4].i = z__1.i;
i__4 = h___subscr(j, k + 1);
i__5 = h___subscr(j, k + 1);
d_cnjg(&z__3, &v2);
z__2.r = sum.r * z__3.r - sum.i * z__3.i, z__2.i = sum.r *
z__3.i + sum.i * z__3.r;
z__1.r = h__[i__5].r - z__2.r, z__1.i = h__[i__5].i - z__2.i;
h__[i__4].r = z__1.r, h__[i__4].i = z__1.i;
/* L70: */
}
/* **
Increment op count
Computing MIN */
i__3 = 2, i__4 = i__ - k;
latime_1.ops += (i2 - i1 + 2 + min(i__3,i__4)) * 20;
/* ** */
if (*wantz) {
/* Accumulate transformations in the matrix Z */
i__3 = *ihiz;
for (j = *iloz; j <= i__3; ++j) {
i__4 = z___subscr(j, k);
z__2.r = t1.r * z__[i__4].r - t1.i * z__[i__4].i, z__2.i =
t1.r * z__[i__4].i + t1.i * z__[i__4].r;
i__5 = z___subscr(j, k + 1);
z__3.r = t2 * z__[i__5].r, z__3.i = t2 * z__[i__5].i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
sum.r = z__1.r, sum.i = z__1.i;
i__4 = z___subscr(j, k);
i__5 = z___subscr(j, k);
z__1.r = z__[i__5].r - sum.r, z__1.i = z__[i__5].i -
sum.i;
z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
i__4 = z___subscr(j, k + 1);
i__5 = z___subscr(j, k + 1);
d_cnjg(&z__3, &v2);
z__2.r = sum.r * z__3.r - sum.i * z__3.i, z__2.i = sum.r *
z__3.i + sum.i * z__3.r;
z__1.r = z__[i__5].r - z__2.r, z__1.i = z__[i__5].i -
z__2.i;
z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
/* L80: */
}
/* **
Increment op count */
latime_1.ops += nz * 20;
/* ** */
}
if (k == m && m > l) {
/* If the QR step was started at row M > L because two
consecutive small subdiagonals were found, then extra
scaling must be performed to ensure that H(M,M-1) remains
real. */
z__1.r = 1. - t1.r, z__1.i = 0. - t1.i;
temp.r = z__1.r, temp.i = z__1.i;
d__1 = z_abs(&temp);
z__1.r = temp.r / d__1, z__1.i = temp.i / d__1;
temp.r = z__1.r, temp.i = z__1.i;
i__3 = h___subscr(m + 1, m);
i__4 = h___subscr(m + 1, m);
d_cnjg(&z__2, &temp);
z__1.r = h__[i__4].r * z__2.r - h__[i__4].i * z__2.i, z__1.i =
h__[i__4].r * z__2.i + h__[i__4].i * z__2.r;
h__[i__3].r = z__1.r, h__[i__3].i = z__1.i;
if (m + 2 <= i__) {
i__3 = h___subscr(m + 2, m + 1);
i__4 = h___subscr(m + 2, m + 1);
z__1.r = h__[i__4].r * temp.r - h__[i__4].i * temp.i,
z__1.i = h__[i__4].r * temp.i + h__[i__4].i *
temp.r;
h__[i__3].r = z__1.r, h__[i__3].i = z__1.i;
}
i__3 = i__;
for (j = m; j <= i__3; ++j) {
if (j != m + 1) {
if (i2 > j) {
i__4 = i2 - j;
zscal_(&i__4, &temp, &h___ref(j, j + 1), ldh);
}
i__4 = j - i1;
d_cnjg(&z__1, &temp);
zscal_(&i__4, &z__1, &h___ref(i1, j), &c__1);
/* **
Increment op count */
opst += (i2 - i1 + 3) * 6;
/* ** */
if (*wantz) {
d_cnjg(&z__1, &temp);
zscal_(&nz, &z__1, &z___ref(*iloz, j), &c__1);
/* **
Increment op count */
opst += nz * 6;
/* ** */
}
}
/* L90: */
}
}
/* L100: */
}
/* Ensure that H(I,I-1) is real. */
i__2 = h___subscr(i__, i__ - 1);
temp.r = h__[i__2].r, temp.i = h__[i__2].i;
if (d_imag(&temp) != 0.) {
rtemp = z_abs(&temp);
i__2 = h___subscr(i__, i__ - 1);
h__[i__2].r = rtemp, h__[i__2].i = 0.;
z__1.r = temp.r / rtemp, z__1.i = temp.i / rtemp;
temp.r = z__1.r, temp.i = z__1.i;
if (i2 > i__) {
i__2 = i2 - i__;
d_cnjg(&z__1, &temp);
zscal_(&i__2, &z__1, &h___ref(i__, i__ + 1), ldh);
}
i__2 = i__ - i1;
zscal_(&i__2, &temp, &h___ref(i1, i__), &c__1);
/* **
Increment op count */
opst += (i2 - i1 + 1) * 6;
/* ** */
if (*wantz) {
zscal_(&nz, &temp, &z___ref(*iloz, i__), &c__1);
/* **
Increment op count */
opst += nz * 6;
/* ** */
}
}
/* L110: */
}
/* Failure to converge in remaining number of iterations */
*info = i__;
return 0;
L120:
/* H(I,I-1) is negligible: one eigenvalue has converged. */
i__1 = i__;
i__2 = h___subscr(i__, i__);
w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i;
/* Decrement number of remaining iterations, and return to start of
the main loop with new value of I. */
itn -= its;
i__ = l - 1;
goto L10;
L130:
/* **
Compute final op count */
latime_1.ops += opst;
/* ** */
return 0;
/* End of ZLAHQR */
} /* zlahqr_ */
/* Subroutine */ int hank103a_(doublecomplex *z__, doublecomplex *h0,
doublecomplex *h1, integer *ifexpon)
{
/* Initialized data */
static doublecomplex ima = {0.,1.};
static doublereal pi = 3.1415926535897932;
static doublereal done = 1.;
static doublecomplex cdumb = {.70710678118654757,-.70710678118654746};
static doublereal p[18] = { 1.,-.0703125,.112152099609375,
-.5725014209747314,6.074042001273483,-110.0171402692467,
3038.090510922384,-118838.4262567833,6252951.493434797,
-425939216.5047669,36468400807.06556,-3833534661393.944,
485401468685290.1,-72868573493776570.,1.279721941975975e19,
-2.599382102726235e21,6.046711487532401e23,-1.597065525294211e26 }
;
static doublereal q[18] = { -.125,.0732421875,-.2271080017089844,
1.727727502584457,-24.38052969955606,551.3358961220206,
-18257.75547429317,832859.3040162893,-50069589.53198893,
3836255180.230434,-364901081884.9834,42189715702840.96,
-5827244631566907.,9.47628809926011e17,-1.792162323051699e20,
3.900121292034e22,-9.677028801069847e24,2.715581773544907e27 };
static doublereal p1[18] = { 1.,.1171875,-.144195556640625,
.6765925884246826,-6.883914268109947,121.5978918765359,
-3302.272294480852,127641.2726461746,-6656367.718817687,
450278600.3050393,-38338575207.42789,4011838599133.198,
-506056850331472.6,75726164611179570.,-1.326257285320556e19,
2.687496750276277e21,-6.2386705823747e23,1.644739123064188e26 };
static doublereal q1[18] = { .375,-.1025390625,.2775764465332031,
-1.993531733751297,27.24882731126854,-603.8440767050702,
19718.37591223663,-890297.8767070679,53104110.10968522,
-4043620325.107754,382701134659.8606,-44064814178522.79,
6065091351222699.,-9.83388387659068e17,1.855045211579829e20,
-4.027994121281017e22,9.974783533410457e24,-2.794294288720121e27 }
;
/* System generated locals */
integer i__1;
doublereal d__1;
doublecomplex z__1, z__2, z__3, z__4, z__5;
static doublecomplex equiv_0[1];
/* Builtin functions */
void z_div(doublecomplex *, doublecomplex *, doublecomplex *), pow_zi(
doublecomplex *, doublecomplex *, integer *), z_exp(doublecomplex
*, doublecomplex *), z_sqrt(doublecomplex *, doublecomplex *);
/* Local variables */
static integer i__, m;
static doublecomplex pp, qq, pp1, qq1, cdd;
#define rea ((doublereal *)equiv_0)
#define com (equiv_0)
static doublecomplex zinv, zinv22, cccexp;
/* evaluate the asymptotic expansion for h0,h1 at */
/* the user-supplied point z, provided it is not */
/* in the fourth quadrant */
m = 10;
z__2.r = done, z__2.i = 0.;
z_div(&z__1, &z__2, z__);
zinv.r = z__1.r, zinv.i = z__1.i;
i__1 = m - 1;
pp.r = p[i__1], pp.i = 0.;
i__1 = m - 1;
pp1.r = p1[i__1], pp1.i = 0.;
pow_zi(&z__1, &zinv, &c__2);
zinv22.r = z__1.r, zinv22.i = z__1.i;
i__1 = m - 1;
qq.r = q[i__1], qq.i = 0.;
i__1 = m - 1;
qq1.r = q1[i__1], qq1.i = 0.;
for (i__ = m - 1; i__ >= 1; --i__) {
z__2.r = pp.r * zinv22.r - pp.i * zinv22.i, z__2.i = pp.r * zinv22.i
+ pp.i * zinv22.r;
i__1 = i__ - 1;
z__1.r = z__2.r + p[i__1], z__1.i = z__2.i;
pp.r = z__1.r, pp.i = z__1.i;
z__2.r = pp1.r * zinv22.r - pp1.i * zinv22.i, z__2.i = pp1.r *
zinv22.i + pp1.i * zinv22.r;
i__1 = i__ - 1;
z__1.r = z__2.r + p1[i__1], z__1.i = z__2.i;
pp1.r = z__1.r, pp1.i = z__1.i;
z__2.r = qq.r * zinv22.r - qq.i * zinv22.i, z__2.i = qq.r * zinv22.i
+ qq.i * zinv22.r;
i__1 = i__ - 1;
z__1.r = z__2.r + q[i__1], z__1.i = z__2.i;
qq.r = z__1.r, qq.i = z__1.i;
z__2.r = qq1.r * zinv22.r - qq1.i * zinv22.i, z__2.i = qq1.r *
zinv22.i + qq1.i * zinv22.r;
i__1 = i__ - 1;
z__1.r = z__2.r + q1[i__1], z__1.i = z__2.i;
qq1.r = z__1.r, qq1.i = z__1.i;
/* L1600: */
}
z__1.r = qq.r * zinv.r - qq.i * zinv.i, z__1.i = qq.r * zinv.i + qq.i *
zinv.r;
qq.r = z__1.r, qq.i = z__1.i;
z__1.r = qq1.r * zinv.r - qq1.i * zinv.i, z__1.i = qq1.r * zinv.i + qq1.i
* zinv.r;
qq1.r = z__1.r, qq1.i = z__1.i;
cccexp.r = 1., cccexp.i = 0.;
if (*ifexpon == 1) {
z__2.r = ima.r * z__->r - ima.i * z__->i, z__2.i = ima.r * z__->i +
ima.i * z__->r;
z_exp(&z__1, &z__2);
cccexp.r = z__1.r, cccexp.i = z__1.i;
}
d__1 = 2 / pi;
z__2.r = d__1 * zinv.r, z__2.i = d__1 * zinv.i;
z_sqrt(&z__1, &z__2);
cdd.r = z__1.r, cdd.i = z__1.i;
z__2.r = ima.r * qq.r - ima.i * qq.i, z__2.i = ima.r * qq.i + ima.i *
qq.r;
z__1.r = pp.r + z__2.r, z__1.i = pp.i + z__2.i;
h0->r = z__1.r, h0->i = z__1.i;
z__3.r = cdd.r * cdumb.r - cdd.i * cdumb.i, z__3.i = cdd.r * cdumb.i +
cdd.i * cdumb.r;
z__2.r = z__3.r * cccexp.r - z__3.i * cccexp.i, z__2.i = z__3.r *
cccexp.i + z__3.i * cccexp.r;
z__1.r = z__2.r * h0->r - z__2.i * h0->i, z__1.i = z__2.r * h0->i +
z__2.i * h0->r;
h0->r = z__1.r, h0->i = z__1.i;
z__2.r = ima.r * qq1.r - ima.i * qq1.i, z__2.i = ima.r * qq1.i + ima.i *
qq1.r;
z__1.r = pp1.r + z__2.r, z__1.i = pp1.i + z__2.i;
h1->r = z__1.r, h1->i = z__1.i;
z__5.r = -cdd.r, z__5.i = -cdd.i;
z__4.r = z__5.r * cccexp.r - z__5.i * cccexp.i, z__4.i = z__5.r *
cccexp.i + z__5.i * cccexp.r;
z__3.r = z__4.r * cdumb.r - z__4.i * cdumb.i, z__3.i = z__4.r * cdumb.i +
z__4.i * cdumb.r;
z__2.r = z__3.r * h1->r - z__3.i * h1->i, z__2.i = z__3.r * h1->i +
z__3.i * h1->r;
z__1.r = z__2.r * ima.r - z__2.i * ima.i, z__1.i = z__2.r * ima.i +
z__2.i * ima.r;
h1->r = z__1.r, h1->i = z__1.i;
return 0;
} /* hank103a_ */
/* Subroutine */ int hank103u_(doublecomplex *z__, integer *ier,
doublecomplex *h0, doublecomplex *h1, integer *ifexpon)
{
/* Initialized data */
static doublecomplex ima = {0.,1.};
static struct {
doublereal e_1[70];
} equiv_1 = { -6.619836118357782e-13, -6.619836118612709e-13,
-7.3075142647542e-22, 3.928160926261892e-11,
5.712712520172854e-10, -5.712712519967086e-10,
-1.083820384008718e-8, -1.894529309455499e-19,
7.528123700585197e-8, 7.528123700841491e-8,
1.356544045548053e-17, -8.147940452202855e-7,
-3.568198575016769e-6, 3.568198574899888e-6,
2.592083111345422e-5, 4.2090748700194e-16,
-7.935843289157352e-5, -7.935843289415642e-5,
-6.848330800445365e-15, 4.136028298630129e-4,
9.210433149997867e-4, -9.210433149680665e-4,
-.003495306809056563, -6.469844672213905e-14,
.005573890502766937, .005573890503000873,
3.76734185797815e-13, -.01439178509436339,
-.01342403524448708, .01342403524340215, .008733016209933828,
1.400653553627576e-12, .02987361261932706, .02987361261607835,
-3.388096836339433e-12, -.1690673895793793,
.2838366762606121, -.2838366762542546, .7045107746587499,
-5.363893133864181e-12, -.7788044738211666, -.778804473813036,
5.524779104964783e-12, 1.146003459721775, .6930697486173089,
-.6930697486240221, -.7218270272305891, 3.633022466839301e-12,
.3280924142354455, .3280924142319602, -1.472323059106612e-12,
-.2608421334424268, -.09031397649230536, .09031397649339185,
.05401342784296321, -3.464095071668884e-13,
-.01377057052946721, -.01377057052927901,
4.273263742980154e-14, .005877224130705015,
.001022508471962664, -.001022508471978459,
-2.789107903871137e-4, 2.283984571396129e-15,
2.799719727019427e-5, 2.7997197269709e-5,
-3.371218242141487e-17, -3.682310515545645e-6,
-1.191412910090512e-7, 1.191412910113518e-7 };
static struct {
doublereal e_1[70];
} equiv_4 = { 4.428361927253983e-13, -4.428361927153559e-13,
-2.575693161635231e-11, -2.878656317479645e-22,
3.658696304107867e-10, 3.658696304188925e-10,
7.463138750413651e-20, -6.748894854135266e-9,
-4.530098210372099e-8, 4.530098210271137e-8,
4.698787882823243e-7, 5.343848349451927e-18,
-1.948662942158171e-6, -1.948662942204214e-6,
-1.658085463182409e-16, 1.31690610049657e-5,
3.645368564036497e-5, -3.645368563934748e-5,
-1.63345854781839e-4, -2.697770638600506e-15,
2.81678497655166e-4, 2.816784976676616e-4,
2.54867335118006e-14, -6.106478245116582e-4,
2.054057459296899e-4, -2.054057460218446e-4,
-.00625496236729126, 1.484073406594994e-13,
.01952900562500057, .01952900562457318,
-5.517611343746895e-13, -.08528074392467523,
-.1495138141086974, .1495138141099772, .4394907314508377,
-1.334677126491326e-12, -1.113740586940341,
-1.113740586937837, 2.113005088866033e-12, 1.170212831401968,
1.262152242318805, -1.262152242322008, -1.557810619605511,
2.176383208521897e-12, .8560741701626648, .8560741701600203,
-1.431161194996653e-12, -.8386735092525187, -.365181917659929,
.3651819176613019, .2811692367666517, -5.799941348040361e-13,
-.0949463018293728, -.0949463018289448,
1.364615527772751e-13, .05564896498129176, .01395239688792536,
-.0139523968879995, -.005871314703753967,
1.683372473682212e-14, .001009157100083457,
.001009157100077235, -8.997331160162008e-16,
-2.723724213360371e-4, -2.708696587599713e-5,
2.70869658761883e-5, 3.533092798326666e-6,
-1.328028586935163e-17, -1.134616446885126e-7,
-1.134616446876064e-7 };
static struct {
doublereal e_1[62];
} equiv_6 = { .5641895835516786, -.564189583551601,
-3.902447089770041e-10, -3.334441074447365e-12,
-.07052368835911731, -.07052368821797083, 1.95729931508537e-9,
-3.126801711815631e-7, -.03967331737107949,
.03967327747706934, 6.902866639752817e-5,
3.178420816292497e-7, .0408045716606128, .04080045784614144,
-2.218731025620065e-5, .006518438331871517,
.09798339748600499, -.09778028374972253, -.3151825524811773,
-7.995603166188139e-4, 1.111323666639636, 1.11679117899433,
.01635711249533488, -8.527067497983841, -25.95553689471247,
25.86942834408207, 134.5583522428299, .2002017907999571,
-308.6364384881525, -309.4609382885628, -1.505974589617013,
1250.150715797207, 2205.210257679573, -2200.328091885836,
-6724.941072552172, -7.018887749450317, 8873.498980910335,
8891.369384353965, 20.08805099643591, -20306.81426035686,
-20100.17782384992, 20060.46282661137, 34279.41581102808,
34.32892927181724, -25114.17407338804, -25165.67363193558,
-33.18253740485142, 31439.40826027085, 16584.66564673543,
-16548.43151976437, -14463.4504132651, -16.45433213663233,
5094.709396573681, 5106.816671258367, 3.470692471612145,
-2797.902324245621, -561.5581955514127, 560.1021281020627,
146.3856702925587, .1990076422327786, -9.334741618922085,
-9.361368967669095 };
static struct {
doublereal e_1[62];
} equiv_8 = { -.5641895835446003, -.5641895835437973,
3.473016376419171e-11, -3.710264617214559e-10,
.2115710836381847, -.2115710851180242, 3.132928887334847e-7,
2.064187785625558e-8, -.06611954881267806, -.0661199717690031,
-3.38600489318156e-6, 7.146557892862998e-5,
-.05728505088320786, .05732906930408979, -.006884187195973806,
-2.383737409286457e-4, .1170452203794729, .1192356405185651,
.008652871239920498, -.3366165876561572, -1.203989383538728,
1.144625888281483, 9.153684260534125, .1781426600949249,
-27.40411284066946, -28.34461441294877, -2.19261107160634,
144.5470231392735, 336.1116314072906, -327.0584743216529,
-1339.254798224146, -16.57618537130453, 2327.097844591252,
2380.960024514808, 77.60611776965994, -7162.513471480693,
-9520.608696419367, 9322.604506839242, 21440.33447577134,
223.0232555182369, -20875.84364240919, -21317.62020653283,
-382.5699231499171, 35829.76792594737, 26426.32405857713,
-25851.37938787267, -32514.46505037506, -371.0875194432116,
16838.05377643986, 17243.93921722052, 184.6128226280221,
-14797.35877145448, -5258.288893282565, 5122.237462705988,
2831.540486197358, 39.05972651440027, -556.2781548969544,
-572.6891190727206, -2.246192560136119, 146.5347141877978,
9.456733342595993, -9.155767836700837 };
/* System generated locals */
doublecomplex z__1, z__2, z__3;
static doublecomplex equiv_2[1];
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *), z_sqrt(doublecomplex *,
doublecomplex *), z_div(doublecomplex *, doublecomplex *,
doublecomplex *), z_exp(doublecomplex *, doublecomplex *), pow_zi(
doublecomplex *, doublecomplex *, integer *);
/* Local variables */
static doublereal d__;
static integer m;
static doublecomplex cd;
#define c0p1 ((doublereal *)&equiv_1)
#define c1p1 ((doublereal *)&equiv_4)
#define c0p2 ((doublereal *)&equiv_6)
#define rea ((doublereal *)equiv_2)
#define c1p2 ((doublereal *)&equiv_8)
#define com (equiv_2)
#define c0p1b ((doublereal *)&equiv_1 + 34)
#define c1p1b ((doublereal *)&equiv_4 + 34)
#define c0p2b ((doublereal *)&equiv_6 + 34)
#define c1p2b ((doublereal *)&equiv_8 + 34)
#define buf01 ((doublereal *)&equiv_1 + 33)
#define buf11 ((doublereal *)&equiv_4 + 33)
#define buf02 ((doublereal *)&equiv_6 + 33)
#define buf12 ((doublereal *)&equiv_8 + 33)
static doublecomplex ccex;
static doublereal done;
static doublecomplex zzz9;
extern /* Subroutine */ int hank103a_(doublecomplex *, doublecomplex *,
doublecomplex *, integer *), hank103l_(doublecomplex *,
doublecomplex *, doublecomplex *, integer *), hank103p_(
doublereal *, integer *, doublecomplex *, doublecomplex *);
static doublereal thresh1, thresh2, thresh3;
/* this subroutine evaluates the hankel functions H_0^1, H_1^1 */
/* for a user-specified complex number z in the upper half-plane. */
/* it is reasonably accurate (14-digit relative accuracy) */
/* and reasonably fast. */
/* input parameters: */
/* z - the complex number for which the hankel functions */
/* H_0, H_1 are to be evaluated */
/* output parameters: */
/* ier - error return code. */
/* ier=0 means successful conclusion */
/* ier=4 means that z is not in the upper half-plane */
/* h0, h1 - the said Hankel functions */
/* if the user-specified z is in the lower half-plane */
/* - bomb out */
*ier = 0;
com->r = z__->r, com->i = z__->i;
if (rea[1] >= 0.) {
goto L1200;
}
*ier = 4;
return 0;
L1200:
done = 1.;
thresh1 = 1.;
thresh2 = 13.690000000000001f;
thresh3 = 400.;
/* check if if the user-specified z is in one of the */
/* intermediate regimes */
d_cnjg(&z__2, z__);
z__1.r = z__->r * z__2.r - z__->i * z__2.i, z__1.i = z__->r * z__2.i +
z__->i * z__2.r;
d__ = z__1.r;
if (d__ < thresh1 || d__ > thresh3) {
goto L3000;
}
/* the user-specified z is in one of the intermediate regimes. */
/* act accordingly */
if (d__ > thresh2) {
goto L2000;
}
/* z is in the first intermediate regime: its absolute value is */
/* between 1 and 3.7. act accordingly */
/* . . . evaluate the expansion */
z__2.r = done, z__2.i = 0.;
z_sqrt(&z__3, z__);
z_div(&z__1, &z__2, &z__3);
cd.r = z__1.r, cd.i = z__1.i;
ccex.r = cd.r, ccex.i = cd.i;
if (*ifexpon == 1) {
z__3.r = ima.r * z__->r - ima.i * z__->i, z__3.i = ima.r * z__->i +
ima.i * z__->r;
z_exp(&z__2, &z__3);
z__1.r = ccex.r * z__2.r - ccex.i * z__2.i, z__1.i = ccex.r * z__2.i
+ ccex.i * z__2.r;
ccex.r = z__1.r, ccex.i = z__1.i;
}
pow_zi(&z__1, z__, &c__9);
zzz9.r = z__1.r, zzz9.i = z__1.i;
m = 35;
hank103p_(c0p1, &m, &cd, h0);
z__2.r = h0->r * ccex.r - h0->i * ccex.i, z__2.i = h0->r * ccex.i + h0->i
* ccex.r;
z__1.r = z__2.r * zzz9.r - z__2.i * zzz9.i, z__1.i = z__2.r * zzz9.i +
z__2.i * zzz9.r;
h0->r = z__1.r, h0->i = z__1.i;
hank103p_(c1p1, &m, &cd, h1);
z__2.r = h1->r * ccex.r - h1->i * ccex.i, z__2.i = h1->r * ccex.i + h1->i
* ccex.r;
z__1.r = z__2.r * zzz9.r - z__2.i * zzz9.i, z__1.i = z__2.r * zzz9.i +
z__2.i * zzz9.r;
h1->r = z__1.r, h1->i = z__1.i;
return 0;
L2000:
/* z is in the second intermediate regime: its absolute value is */
/* between 3.7 and 20. act accordingly. */
z__2.r = done, z__2.i = 0.;
z_sqrt(&z__3, z__);
z_div(&z__1, &z__2, &z__3);
cd.r = z__1.r, cd.i = z__1.i;
ccex.r = cd.r, ccex.i = cd.i;
if (*ifexpon == 1) {
z__3.r = ima.r * z__->r - ima.i * z__->i, z__3.i = ima.r * z__->i +
ima.i * z__->r;
z_exp(&z__2, &z__3);
z__1.r = ccex.r * z__2.r - ccex.i * z__2.i, z__1.i = ccex.r * z__2.i
+ ccex.i * z__2.r;
ccex.r = z__1.r, ccex.i = z__1.i;
}
m = 31;
hank103p_(c0p2, &m, &cd, h0);
z__1.r = h0->r * ccex.r - h0->i * ccex.i, z__1.i = h0->r * ccex.i + h0->i
* ccex.r;
h0->r = z__1.r, h0->i = z__1.i;
m = 31;
hank103p_(c1p2, &m, &cd, h1);
z__1.r = h1->r * ccex.r - h1->i * ccex.i, z__1.i = h1->r * ccex.i + h1->i
* ccex.r;
h1->r = z__1.r, h1->i = z__1.i;
return 0;
L3000:
/* z is either in the local regime or the asymptotic one. */
/* if it is in the local regime - act accordingly. */
if (d__ > 50.) {
goto L4000;
}
hank103l_(z__, h0, h1, ifexpon);
return 0;
/* z is in the asymptotic regime. act accordingly. */
L4000:
hank103a_(z__, h0, h1, ifexpon);
return 0;
} /* hank103u_ */
/* Subroutine */ int hank103r_(doublecomplex *z__, integer *ier,
doublecomplex *h0, doublecomplex *h1, integer *ifexpon)
{
/* Initialized data */
static doublecomplex ima = {0.,1.};
static struct {
doublereal e_1[70];
} equiv_1 = { -4.268441995428495e-24, 4.374027848105921e-24,
9.876152216238049e-24, -1.065264808278614e-21,
6.240598085551175e-20, 6.65852998549011e-20,
-5.107210870050163e-18, -2.931746613593983e-19,
1.611018217758854e-16, -1.359809022054077e-16,
-7.718746693707326e-16, 6.759496139812828e-15,
-1.067620915195442e-13, -1.434699000145826e-13,
3.868453040754264e-12, 7.06185339258518e-13,
-6.220133527871203e-11, 3.957226744337817e-11,
3.080863675628417e-10, -1.1546184312819e-9,
7.793319486868695e-9, 1.502570745460228e-8,
-1.97809085263843e-7, -7.39669187349903e-8,
2.175857247417038e-6, -8.473534855334919e-7,
-1.05338132760972e-5, 2.042555121261223e-5,
-4.812568848956982e-5, -1.961519090873697e-4,
.001291714391689374, 9.23442238495005e-4, -.01113890671502769,
9.053687375483149e-4, .05030666896877862,
-.04923119348218356, .5202355973926321, -.1705244841954454,
-1.134990486611273, -1.747542851820576, 8.308174484970718,
2.952358687641577, -32.86074510100263, 11.26542966971545,
65.76015458463394, -100.6116996293757, 32.16834899377392,
361.4005342307463, -665.3878500833375, -688.3582242804924,
2193.362007156572, 242.3724600546293, -3665.925878308203,
2474.933189642588, 1987.663383445796, -7382.586600895061,
4991.253411017503, 10085.05017740918, -12852.84928905621,
-5153.67482166847, 13016.56757246985, -4821.250366504323,
-4982.112643422311, 9694.070195648748, -1685.723189234701,
-6065.143678129265, 2029.510635584355, 1244.402339119502,
-433.6682903961364, 89.23209875101459 };
static struct {
doublereal e_1[70];
} equiv_4 = { -4.019450270734195e-24, -4.819240943285824e-24,
1.087220822839791e-21, 1.219058342725899e-22,
-7.458149572694168e-20, 5.677825613414602e-20,
8.351815799518541e-19, -5.188585543982425e-18,
1.221075065755962e-16, 1.789261470637227e-16,
-6.829972121890858e-15, -1.497462301804588e-15,
1.579028042950957e-13, -9.4149603037588e-14,
-1.127570848999746e-12, 3.883137940932639e-12,
-3.397569083776586e-11, -6.779059427459179e-11,
1.149529442506273e-9, 4.363087909873751e-10,
-1.620182360840298e-8, 6.404695607668289e-9,
9.651461037419628e-8, -1.948572160668177e-7,
6.397881896749446e-7, 2.318661930507743e-6,
-1.983192412396578e-5, -1.294811208715315e-5,
2.062663873080766e-4, -2.867633324735777e-5,
-.001084309075952914, .001227880935969686,
2.538406015667726e-4, -.01153316815955356, .04520140008266983,
.05693944718258218, -.9640790976658534, -.6517135574036008,
2.051491829570049, -1.124151010077572, -3.977380460328048,
8.200665483661009, -7.950131652215817, -35.03037697046647,
96.07320812492044, 78.9407968985807, -374.9002890488298,
-8.153831134140778, 782.4282518763973, -603.5276543352174,
-500.4685759675768, 2219.009060854551, -2111.301101664672,
-4035.632271617418, 7319.737262526823, 2878.734389521922,
-10874.04934318719, 3945.740567322783, 6727.823761148537,
-12535.55346597302, 3440.468371829973, 13832.40926370073,
-9324.927373036743, -6181.580304530313, 6376.198146666679,
-1033.615527971958, -1497.604891055181, 1929.025541588262,
-42.19760183545219, -452.1162915353207 };
static struct {
doublereal e_1[54];
} equiv_6 = { .5641895835569398, -.5641895835321127,
-.07052370223565544, -.07052369923405479, -.03966909368581382,
.03966934297088857, .04130698137268744, .04136196771522681,
.06240742346896508, -.06553556513852438, -.03258849904760676,
-.07998036854222177, -3.98800631195527, 1.327373751674479,
61.21789346915312, -92.51865216627577, 424.7064992018806,
2692.55333348915, -43746.91601489926, -36252.48208112831,
1010975.818048476, -28593.60062580096, -11389702.41206912,
10510979.79526042, 22840388.99211195, -203801251.5235694,
1325194353.842857, 1937443530.361381, -22459990186.52171,
-5998903865.344352, 179323705487.6609, -86251598823.06147,
-588776304273.5203, 1345331284205.28, -2743432269370.813,
-8894942160272.255, 42764631137945.64, 26650198866477.81,
-228072742395549.8, 36869087905539.73, 563984631816861.5,
-684152905161570.3, 99014267999660.38, 2798406605978152.,
-4910062244008171., -5126937967581805., 13872929519367560.,
1043295727224325., -15652041206872650., 12152628069735770.,
3133802397107054., -18013945508070780., 4427598668012807.,
6923499968336864. };
static struct {
doublereal e_1[62];
} equiv_8 = { -.564189583543198, -.5641895835508094,
.2115710934750869, -.2115710923186134, -.06611607335011594,
-.06611615414079688, -.05783289433408652, .05785737744023628,
.08018419623822896, .08189816020440689, .1821045296781145,
-.217973897300874, .5544705668143094, 2.22446631644444,
-85.63271248520645, -43.94325758429441, 2720.62754707134,
-670.5390850875292, -39362.2196060077, 57917.30432605451,
-197678.7738827811, -1502498.631245144, 21553178.23990686,
18709537.96705298, -470399571.1098311, 3716595.90645319,
5080557859.012385, -4534199223.888966, -10644382116.47413,
86122438937.45942, -546601768778.5078, -807095038664.0701,
9337074941225.827, 2458379240643.264, -75486921712445.79,
37510931699543.36, 246067743135003.9, -599191937288191.1,
1425679408434606., 4132221939781502., -22475064694689690.,
-12697710781650260., 129733629274902600., -28026269097913080.,
-346713722281301700., 477395521558219200.,
-234716577658020600., -2.233638097535785e18,
5.382350866778548e18, 4.820328886922998e18,
-1.928978948099345e19, 157549874775090700.,
3.049162180215152e19, -2.837046201123502e19,
-5.429391644354291e18, 6.974653380104308e19,
-5.322120857794536e19, -6.739879079691706e19,
6.780343087166473e19, 1.053455984204666e19,
-2.218784058435737e19, 1.505391868530062e19 };
/* System generated locals */
doublecomplex z__1, z__2, z__3;
static doublecomplex equiv_2[1];
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *), z_exp(doublecomplex *,
doublecomplex *), z_sqrt(doublecomplex *, doublecomplex *), z_div(
doublecomplex *, doublecomplex *, doublecomplex *), pow_zi(
doublecomplex *, doublecomplex *, integer *);
/* Local variables */
static doublereal d__;
static integer m;
static doublecomplex cd, cdd;
#define c0p1 ((doublereal *)&equiv_1)
#define c1p1 ((doublereal *)&equiv_4)
#define c0p2 ((doublereal *)&equiv_6)
#define rea ((doublereal *)equiv_2)
#define c1p2 ((doublereal *)&equiv_8)
#define com (equiv_2)
static doublecomplex zz18;
#define c0p1b ((doublereal *)&equiv_1 + 34)
#define c1p1b ((doublereal *)&equiv_4 + 34)
#define c0p2b ((doublereal *)&equiv_6 + 34)
#define c1p2b ((doublereal *)&equiv_8 + 34)
#define buf01 ((doublereal *)&equiv_1 + 33)
#define buf11 ((doublereal *)&equiv_4 + 33)
#define buf02 ((doublereal *)&equiv_6 + 33)
#define buf12 ((doublereal *)&equiv_8 + 33)
static doublereal done;
static doublecomplex cccexp;
extern /* Subroutine */ int hank103a_(doublecomplex *, doublecomplex *,
doublecomplex *, integer *), hank103l_(doublecomplex *,
doublecomplex *, doublecomplex *, integer *), hank103p_(
doublecomplex *, integer *, doublecomplex *, doublecomplex *);
static doublereal thresh1, thresh2, thresh3;
/* this subroutine evaluates the hankel functions H_0^1, H_1^1 */
/* for a user-specified complex number z in the right lower */
/* quadrant. it is reasonably accurate (14-digit relative */
/* accuracy) and reasonably fast. */
/* input parameters: */
/* z - the complex number for which the hankel functions */
/* H_0, H_1 are to be evaluated */
/* output parameters: */
/* ier - error return code. */
/* ier=0 means successful conclusion */
/* ier=4 means that z is not in the right lower quadrant */
/* h0, h1 - the said Hankel functions */
/* if z is not in the right lower quadrant - bomb out */
*ier = 0;
com->r = z__->r, com->i = z__->i;
if (rea[0] >= 0. && rea[1] <= 0.) {
goto L1400;
}
*ier = 4;
return 0;
L1400:
done = 1.;
thresh1 = 16.;
thresh2 = 64.;
thresh3 = 400.;
/* check if if the user-specified z is in one of the */
/* intermediate regimes */
d_cnjg(&z__2, z__);
z__1.r = z__->r * z__2.r - z__->i * z__2.i, z__1.i = z__->r * z__2.i +
z__->i * z__2.r;
d__ = z__1.r;
if (d__ < thresh1 || d__ > thresh3) {
goto L3000;
}
/* if the user-specified z is in the first intermediate regime */
/* (i.e. if its absolute value is between 4 and 8), act accordingly */
if (d__ > thresh2) {
goto L2000;
}
cccexp.r = 1., cccexp.i = 0.;
if (*ifexpon == 1) {
z__2.r = ima.r * z__->r - ima.i * z__->i, z__2.i = ima.r * z__->i +
ima.i * z__->r;
z_exp(&z__1, &z__2);
cccexp.r = z__1.r, cccexp.i = z__1.i;
}
z__2.r = done, z__2.i = 0.;
z_sqrt(&z__3, z__);
z_div(&z__1, &z__2, &z__3);
cdd.r = z__1.r, cdd.i = z__1.i;
z__2.r = done, z__2.i = 0.;
z_div(&z__1, &z__2, z__);
cd.r = z__1.r, cd.i = z__1.i;
pow_zi(&z__1, z__, &c__18);
zz18.r = z__1.r, zz18.i = z__1.i;
m = 35;
hank103p_((doublecomplex*)c0p1, &m, &cd, h0);
z__3.r = h0->r * cdd.r - h0->i * cdd.i, z__3.i = h0->r * cdd.i + h0->i *
cdd.r;
z__2.r = z__3.r * cccexp.r - z__3.i * cccexp.i, z__2.i = z__3.r *
cccexp.i + z__3.i * cccexp.r;
z__1.r = z__2.r * zz18.r - z__2.i * zz18.i, z__1.i = z__2.r * zz18.i +
z__2.i * zz18.r;
h0->r = z__1.r, h0->i = z__1.i;
hank103p_((doublecomplex*)c1p1, &m, &cd, h1);
z__3.r = h1->r * cdd.r - h1->i * cdd.i, z__3.i = h1->r * cdd.i + h1->i *
cdd.r;
z__2.r = z__3.r * cccexp.r - z__3.i * cccexp.i, z__2.i = z__3.r *
cccexp.i + z__3.i * cccexp.r;
z__1.r = z__2.r * zz18.r - z__2.i * zz18.i, z__1.i = z__2.r * zz18.i +
z__2.i * zz18.r;
h1->r = z__1.r, h1->i = z__1.i;
return 0;
L2000:
/* z is in the second intermediate regime (i.e. its */
/* absolute value is between 8 and 20). act accordingly. */
z__2.r = done, z__2.i = 0.;
z_div(&z__1, &z__2, z__);
cd.r = z__1.r, cd.i = z__1.i;
z_sqrt(&z__1, &cd);
cdd.r = z__1.r, cdd.i = z__1.i;
cccexp.r = 1., cccexp.i = 0.;
if (*ifexpon == 1) {
z__2.r = ima.r * z__->r - ima.i * z__->i, z__2.i = ima.r * z__->i +
ima.i * z__->r;
z_exp(&z__1, &z__2);
cccexp.r = z__1.r, cccexp.i = z__1.i;
}
m = 27;
hank103p_((doublecomplex*)c0p2, &m, &cd, h0);
z__2.r = h0->r * cccexp.r - h0->i * cccexp.i, z__2.i = h0->r * cccexp.i +
h0->i * cccexp.r;
z__1.r = z__2.r * cdd.r - z__2.i * cdd.i, z__1.i = z__2.r * cdd.i +
z__2.i * cdd.r;
h0->r = z__1.r, h0->i = z__1.i;
m = 31;
hank103p_((doublecomplex*)c1p2, &m, &cd, h1);
z__2.r = h1->r * cccexp.r - h1->i * cccexp.i, z__2.i = h1->r * cccexp.i +
h1->i * cccexp.r;
z__1.r = z__2.r * cdd.r - z__2.i * cdd.i, z__1.i = z__2.r * cdd.i +
z__2.i * cdd.r;
h1->r = z__1.r, h1->i = z__1.i;
return 0;
L3000:
/* z is either in the local regime or the asymptotic one. */
/* if it is in the local regime - act accordingly. */
if (d__ > 50.) {
goto L4000;
}
hank103l_(z__, h0, h1, ifexpon);
return 0;
/* z is in the asymptotic regime. act accordingly. */
L4000:
hank103a_(z__, h0, h1, ifexpon);
return 0;
} /* hank103r_ */
