/* Normalizes a complex vector to have an L2 norm of 1.0 */
void normalize_stack(complex *z,int nz)
{
complex cmag;
cmag = cdotc(nz,z,1,z,1);
cmag.r = (float)(1.0/sqrt((double)cmag.r));
#ifdef SUNPERF6
cscal(nz,cmag,z,1);
#else
cscal(nz,&cmag,z,1);
#endif
}
/* This function applies a time weight function across the matrix built by
the function immediately above. That is, it scales the ith column of z by
w[i].
*/
void MWapply_time_window(complex *z,
int n1z,
int nrows,
int ncol,
double *w)
{
complex cweight;
int i;
cweight.i = 0.0;
for(i=0;i<ncol;++i)
{
cweight.r = w[i];
#ifdef SUNPERF6
cscal(nrows,cweight,z+i*n1z,1);
#else
cscal(nrows,&cweight,z+i*n1z,1);
#endif
}
}
/* This function produces a robust stack of an ensemble of multiwavelet
transformed signals stored in the input array z. The algorithm used here
is novel, or perhaps more appropriately called experimental. It was
written to replace the principal component method used in the Bear and
Pavlis paper for computing phased array stacks. That method repeatly
showed instability problems that hard to track. Entirely possible
this was only a buggy program, but the very concept of the pc method
seemed inherently unstable to me. Furthermore, it clearly would not
work right in an extension to correlation of data from clusters of
events (source arrays) because the size of signals in that situation
can vary by orders of magnitude.
This algorithm uses a different approach that is like M-estimators
but with the loss function that does not require a statistical model.
I don't know the proper term for this approach, but I'm sure there
is one in the mathematical literature. i.e. I'm fairly sure is a
reinvention of a concept used elsewhere. Haven't found it yet is all.
Key elements of the algorithm are:
1. We form the solution as a weighted stack of an ensemble of complex
valued traces passed through the 3D z array of complex numbers.
2. The initial solution is a median stack.
3. The parent loss function used to compute the weights has not
been derived, but the solution is based on weights computed as follows:
| 1/(residual amp) if residual amp > noise level
w_channel = |
| 1/noise otherwise
This is something like weighting each element by coherence, but it
is normalized differently and made more aggressive by the reciprocal
relationship. Because the traces are not normalized prior to the
stack this weighting is effectively an approximate weighting by signal
to noise ratio if the underlying signals to be stacked are perfectly coherent.
However, when there is a large misfit due to any reason the 1/residual
form will dominate and a signal gets downweighted quickly.
4. The MWstack object returns a set of complex amplitudes coefficients.
The modulus of these numbers are the relative amplitude numbers for
each channel and the phase can be used to estimate a time shift as
described in the Bear and Pavlis papers. These factors are computed
as a complex dot product between the final stack and each of the parent,
multiwavelet transformed signals. Nonparametric statistics can be applied
to these estimates to estimate uncertainties in the relative amplitudes
and timing.
5. The algorith allows one to pass in channel weights. This can be used
to produce variable array apertures with frequency to compensate for
coherence loss with the spatial separation of receivers. This vector
should be all ones if one does not wish to use this feature.
Arguments:
z - 3D C array of multiwavelet transform data to be stacked.
z[i][j][k] is assumed to be the kth time sample from
channel j of wavelet number i.
nwavelet - number of multiwavelets in transform
nchan - number of channels to be stacked
nt - number of time samples to stack
NOTE: z is thus assumed of size z[nwavelet][nchan][nt]
t0 - relative time of sample 0 of input matrices.
dt - dample interval
chanweight - base channel weight. Always used to scale
each channel in the stack, but ignored for statistical
estimates.
timeweight - vector of length nt of time window weights
to be applied (input) in computing stack
noise - nwavelet by nchan C matrix of estimate of single sample
noise level for each wavelet and each channel.
Author: Gary L. Pavlis
Written: December 2001
*/
MWstack *MWrobuststack(complex ***z,
int nwavelets,
int nchan,
int nt,
double t0,
double dt,
double *chanweight,
double *timeweight,
double **noise)
{
MWstack *s;
int ts,te; /* index of first and last nonzero element of timeweight */
int nt_used;
int i,j,k,l;
/* These are matrix work spaces. All are created as 1d vectors with
virtual indexing ala fortran. Sizes are as noted*/
complex *zwork, *residuals; /* per wavelet workspace: nwavelet X nt_used*/
double **amps; /*scalar amplitude factors nwavelets x nchan */
complex *window_stacks; /* accumulation space for stack with time weights applied
size is nt_used by nwavelets (note transpose from others) */
complex *wstack_last; /* window_stacks from previous iteration */
/* vector work spaces */
double *resnorms; /* Used to accumulate residual norms across all wavelets */
complex *stack; /* Used to accumulate full stack without windowing -- copied to
MWstack object */
double *reswt; /* working vector of robust weights derived from residuals */
complex cscale;
double sum_column_weights,sum_chan_weights; /* required normalizations */
double weight;
complex cwork;
double cmag;
int iteration;
double dzmod,ctest;
/* We scan for the first and last number in timeweight that are nonzero.
We need to use a reduced workspace to build stack to avoid biasing statistics
with 0 weight samples */
for(ts=0;ts<nt;++ts) if(timeweight[ts]!= 0.0) break;
if(ts>=nt)
{
elog_complain(0,"Invalid time weight function--all zeros\n");
return(NULL);
}
/* we don't need to test from the reverse direction, although we could
end up with as few as 1 nonzero weight */
for(te=nt-1;te>=0;--te) if(timeweight[te]!=0.0) break;
nt_used = te-ts+1;
for(i=ts,sum_column_weights=0.0;i<=te;++i)
sum_column_weights += fabs(timeweight[i]);
s = create_MWstack(nwavelets,nchan,nt);
s->tstart = t0;
s->dt = dt;
s->tend = t0 + dt*((double)(nt-1));
for(i=0;i<nt;++i)s->timeweight[i]=timeweight[i];
/* work spaces */
allot(complex *,zwork,nchan*nt_used);
allot(complex *,residuals,nchan*nt_used);
allot(double **,amps,nwavelets);
for(i=0;i<nwavelets;++i) allot(double *,amps[i],nchan);
allot(double *,resnorms,nchan);
allot(complex *,window_stacks,nchan*nt_used);
allot(complex *,wstack_last,nchan*nt_used);
allot(complex *,stack,nt);
allot(double *,reswt,nchan);
/* Use a median stack as a starting point. We don't apply channel
weights here as it will bias the results */
for(i=0;i<nwavelets;++i)
{
MWcopy_one_wavelet_matrix(z,i,zwork,nchan,ts,nt_used);
MWapply_time_window(zwork,nchan,nchan,nt_used,timeweight+ts);
MWmedian_stack_complex(zwork,nchan,nchan,nt_used,window_stacks+i*nt_used);
/* cdotc of a complex vector with itself gives the L2 norm squared.
We use this as a measure of raw signal strength. It only needs
to be computed once. Note sqrt and normalization by window weights*/
for(j=0;j<nchan;++j)
{
cwork = cdotc(nt_used,zwork+j,nchan,zwork+j,nchan);
/* cwork will only have a nonzero real part that is the sume
of the moduli of all the components of the zwork vector */
amps[i][j]=sqrt((double)cwork.r);
amps[i][j] /= sum_column_weights;
}
/* We normalize the stacks to unit L2 norm because otherwise computing
relative amplitudes gets problematic. */
normalize_stack(window_stacks+i*nt_used,nt_used);
}
iteration = 0;
do
{
/* We can do this because we packed this matrix into continguous block.
It saves the last stack value for comparison at the bottom of the loop. */
ccopy(nt_used*nwavelets,window_stacks,1,wstack_last,1);
/* We first have to accumulate residuals for all channels across all
wavelets for the current stack. */
for(j=0;j<nchan;++j)
{
resnorms[j]=0.0;
reswt[j]=0.0;
}
for(i=0;i<nwavelets;++i)
{
MWcopy_one_wavelet_matrix(z,i,zwork,nchan,ts,nt_used);
MWapply_time_window(zwork,nchan,nchan,nt_used,timeweight+ts);
for(j=0;j<nchan;++j)
{
ccopy(nt_used,zwork+j,nchan,residuals+j,nchan);
if(chanweight[j]!=1.0)
{
cscale.r = chanweight[j];
cscale.i = 0.0;
#ifdef SUNPERF6
cscal(nt_used,cscale,residuals+j,nchan);
#else
cscal(nt_used,&cscale,residuals+j,nchan);
#endif
}
/* This complex pointer stuff happens because of the use of
implicit fortran type matrices in contiguous blocks. The
cdotc call computes the dot product between the current
stack and data. caxpy call computes the residual derived by
computing difference between data and this scaled version of
the stack. */
s->amp[i][j] = cdotc(nt_used,zwork+j,nchan,window_stacks+i*nt_used,1);
cwork.r = -(s->amp[i][j].r);
cwork.i = -(s->amp[i][j].i);
cmag=hypot((double)cwork.r,(double)cwork.i);
#ifdef SUNPERF6
caxpy(nt_used,cwork,window_stacks+i*nt_used,1,
residuals+j,nchan);
#else
caxpy(nt_used,&cwork,window_stacks+i*nt_used,1,
residuals+j,nchan);
#endif
if(chanweight[j]>0.0)
{
cwork = cdotc(nt_used,residuals+j,nchan,
residuals+j,nchan);
resnorms[i] += sqrt((double)(cwork.r));
}
}
}
for(i=0;i<nwavelets;++i)
{
resnorms[i] /= sum_column_weights;
/* When chanweight is 0 the associated row is 0.0 so computing residuals
is not only pointless, but could cause inf errors */
for(j=0;j<nchan;++j)
{
if(chanweight[j]==0.0)
reswt[j] = 0.0;
else
{
if(resnorms[i]>noise[i][j])
reswt[j] += amps[i][j]/resnorms[i];
else
reswt[j] += amps[i][j]/noise[i][j];
}
reswt[j] /= ((double)nwavelets);
}
}
/* we now form weighted stacks */
cwork.i = 0.0;
for(i=0;i<nwavelets;++i)
{
for(k=0;k<nt;++k)
{
s->z[i][k].r = 0.0;
s->z[i][k].i = 0.0;
}
for(j=0,sum_chan_weights=0.0;j<nchan;++j)
{
weight = reswt[j]*chanweight[j];
s->weights[j]=weight;
sum_chan_weights += weight;
cwork.r = weight;
#ifdef SUNPERF6
caxpy(nt,cwork,z[i][j],1,s->z[i],1);
#else
caxpy(nt,&cwork,z[i][j],1,s->z[i],1);
#endif
}
cwork.r = 1.0/sum_chan_weights;
#ifdef SUNPERF6
cscal(nt,cwork,s->z[i],1);
#else
cscal(nt,&cwork,s->z[i],1);
#endif
/* That is the full window stack, when we loop back we
use the windowed version so we have to form it. I
use explicit indexing here to make this clearer rather
than use the the BLAS for something this simple to compute.
The indexing is ugly enough this way.*/
for(k=ts,l=0;k<=te;++k,++l)
{
window_stacks[i*nt_used + l].r = (s->z[i][k].r)*timeweight[k];
window_stacks[i*nt_used + l].i = (s->z[i][k].i)*timeweight[k];
}
normalize_stack(window_stacks+i*nt_used,nt_used);
}
/* convergence is defined by ratio of correction vector to norm of stack
across all wavelets. The stacks are normalized in each pass to unit norm
so this becomes simply the norm of the correction vector. This
crude loop works because we assume the window_stack matrices are in a
packed storage arrangement and can be dealt with as one long vector */
for(l=0,ctest=0.0;l<nt_used*nwavelets;++l)
{
dzmod = hypot((double)(window_stacks[l].r - wstack_last[l].r),
(double)(window_stacks[l].i - wstack_last[l].i));
ctest += dzmod*dzmod;
}
ctest /= ((double)((cwork.r)*(cwork.r)));
++iteration;
} while ( (ctest>CONVERGENCE_RATIO) && (iteration<=MAXIT));
/* We perhaps should recompute the amp factors before exiting, but if the
algorithm converges properly this should not be an issue. */
if(iteration>MAXIT)
{
elog_complain(0,"MWrobuststack: iterative loop did not converge\n");
s->stack_is_valid=0;
}
else
s->stack_is_valid=1;
free(zwork);
free(residuals);
for(i=0;i<nwavelets;++i)free(amps[i]);
free(amps);
free(resnorms);
free(window_stacks);
free(wstack_last);
free(stack);
free(reswt);
return(s);
}
void chseqr(char *job, char *compz, int n__, int ilo,
int ihi, fcomplex *h, int ldh, fcomplex *w, fcomplex *z,
int ldz, fcomplex *work, int lwork, int *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CHSEQR computes the eigenvalues of a complex upper 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)*T*(QZ)**H.
Arguments
=========
JOB (input) CHARACTER*1
= 'E': compute eigenvalues only;
= 'S': compute eigenvalues and the Schur form T.
COMPZ (input) CHARACTER*1
= 'N': no Schur vectors are computed;
= 'I': Z is initialized to the unit matrix and the matrix Z
of Schur vectors of H is returned;
= 'V': Z must contain an unitary matrix Q on entry, and
the product Q*Z is returned.
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 1:ILO-1 and IHI+1:N. ILO and IHI are normally
set by a previous call to CGEBAL, and then passed to CGEHRD
when the matrix output by CGEBAL is reduced to Hessenberg
form. Otherwise ILO and IHI should be set to 1 and N
respectively.
1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
H (input/output) COMPLEX array, dimension (LDH,N)
On entry, the upper Hessenberg matrix H.
On exit, if JOB = 'S', H contains the upper triangular matrix
T from the Schur decomposition (the Schur form). If
JOB = 'E', 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 array, dimension (N)
The computed eigenvalues. If JOB = 'S', the eigenvalues are
stored in the same order as on the diagonal of the Schur form
returned in H, with W(i) = H(i,i).
Z (input/output) COMPLEX array, dimension (LDZ,N)
If COMPZ = 'N': Z is not referenced.
If COMPZ = 'I': on entry, Z need not be set, and on exit, Z
contains the unitary matrix Z of the Schur vectors of H.
If COMPZ = 'V': on entry Z must contain an N-by-N matrix Q,
which is assumed to be equal to the unit matrix except for
the submatrix Z(ILO:IHI,ILO:IHI); on exit Z contains Q*Z.
Normally Q is the unitary matrix generated by CUNGHR after
the call to CGEHRD which formed the Hessenberg matrix H.
LDZ (input) INTEGER
The leading dimension of the array Z.
LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise.
WORK (workspace) COMPLEX array, dimension (N)
LWORK (input) INTEGER
This argument is currently redundant.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, CHSEQR failed to compute all the
eigenvalues in a total of 30*(IHI-ILO+1) iterations;
elements 1:ilo-1 and i+1:n of W contain those
eigenvalues which have been successfully computed.
=====================================================================
Decode and test the input parameters
Parameter adjustments
Function Body */
/* Table of constant values */
static fcomplex c_b1 = {0.f,0.f};
static fcomplex c_b2 = {1.f,0.f};
static int c__1 = 1;
static int c__4 = 4;
static int c_n1 = -1;
static int c__2 = 2;
static int c__8 = 8;
static int c__15 = 15;
static int c_false = FALSE;
/* System generated locals */
char* a__1[2];
int h_dim1, i__1, i__2, i__3, i__4[2],
i__5, i__6;
float r__1, r__2, r__3, r__4;
double d__1;
fcomplex q__1;
char ch__1[2];
/* Builtin functions */
/* Local variables */
static int maxb, ierr;
static float unfl;
static fcomplex temp;
static float ovfl;
static int i, j, k, l;
static fcomplex s[225] /* was [15][15] */;
static fcomplex v[16];
static int itemp;
static float rtemp;
static int i1, i2;
static int initz, wantt, wantz;
static float rwork[1];
static int ii, nh;
static int nr, ns;
static int nv;
static fcomplex vv[16];
static float smlnum;
static int itn;
static fcomplex tau;
static int its;
static float ulp, tst1;
#define W(I) w[(I)-1]
#define WORK(I) work[(I)-1]
#define H(I,J) h[(I)-1 + ((J)-1)* ( ldh)]
#define Z(I,J) z[(I)-1 + ((J)-1)* ( ldz)]
h_dim1 = ldh;
wantt = lsame(job, "S");
initz = lsame(compz, "I");
wantz = initz || lsame(compz, "V");
*info = 0;
if (! lsame(job, "E") && ! wantt) {
*info = -1;
} else if (! lsame(compz, "N") && ! wantz) {
*info = -2;
} else if (n__ < 0) {
*info = -3;
} else if (ilo < 1 || ilo > max(1,n__)) {
*info = -4;
} else if (ihi < min(ilo,n__) || ihi > n__) {
*info = -5;
} else if (ldh < max(1,n__)) {
*info = -7;
} else if (ldz < 1 || (wantz && ldz < max(1,n__))) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
return ;
}
/* Initialize Z, if necessary */
if (initz) {
claset("Full", n__, n__, c_b1, c_b2, &Z(1,1), ldz);
}
/* Store the eigenvalues isolated by CGEBAL. */
i__1 = ilo - 1;
for (i = 1; i <= ilo-1; ++i) {
i__2 = i;
i__3 = i + i * h_dim1;
W(i).r = H(i,i).r, W(i).i = H(i,i).i;
}
i__1 = n__;
for (i = ihi + 1; i <= n__; ++i) {
i__2 = i;
i__3 = i + i * h_dim1;
W(i).r = H(i,i).r, W(i).i = H(i,i).i;
}
/* Quick return if possible. */
if (n__ == 0) {
return ;
}
if (ilo == ihi) {
i__1 = ilo;
i__2 = ilo + ilo * h_dim1;
W(ilo).r = H(ilo,ilo).r, W(ilo).i = H(ilo,ilo).i;
return ;
}
/* Set rows and columns ILO to IHI to zero below the first
subdiagonal. */
i__1 = ihi - 2;
for (j = ilo; j <= ihi-2; ++j) {
i__2 = n__;
for (i = j + 2; i <= n__; ++i) {
i__3 = i + j * h_dim1;
H(i,j).r = 0.f, H(i,j).i = 0.f;
}
}
nh = ihi - ilo + 1;
/* 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 re-set inside the main loop. */
if (wantt) {
i1 = 1;
i2 = n__;
} else {
i1 = ilo;
i2 = ihi;
}
/* Ensure that the subdiagonal elements are real. */
i__1 = ihi;
for (i = ilo + 1; i <= ihi; ++i) {
i__2 = i + (i - 1) * h_dim1;
temp.r = H(i,i-1).r, temp.i = H(i,i-1).i;
if (temp.i != 0.f) {
r__1 = temp.r;
r__2 = temp.i;
rtemp = slapy2(r__1, r__2);
i__2 = i + (i - 1) * h_dim1;
H(i,i-1).r = rtemp, H(i,i-1).i = 0.f;
q__1.r = temp.r / rtemp, q__1.i = temp.i / rtemp;
temp.r = q__1.r, temp.i = q__1.i;
if (i2 > i) {
i__2 = i2 - i;
r_cnjg(&q__1, &temp);
cscal(i__2, q__1, &H(i,i+1), ldh);
}
i__2 = i - i1;
cscal(i__2, temp, &H(i1,i), c__1);
if (i < ihi) {
i__2 = i + 1 + i * h_dim1;
i__3 = i + 1 + i * h_dim1;
q__1.r = temp.r * H(i+1,i).r - temp.i * H(i+1,i).i, q__1.i =
temp.r * H(i+1,i).i + temp.i * H(i+1,i).r;
H(i+1,i).r = q__1.r, H(i+1,i).i = q__1.i;
}
if (wantz) {
cscal(nh, temp, &Z(ilo,i), c__1);
}
}
}
/* Determine the order of the multi-shift QR algorithm to be used.
Writing concatenation */
i__4[0] = 1, a__1[0] = job;
i__4[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__4, &c__2, 2L);
ns = ilaenv(c__4, "CHSEQR", ch__1, n__, ilo, ihi, c_n1, 6L, 2L);
/* Writing concatenation */
i__4[0] = 1, a__1[0] = job;
i__4[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__4, &c__2, 2L);
maxb = ilaenv(c__8, "CHSEQR", ch__1, n__, ilo, ihi, c_n1, 6L, 2L);
if (ns <= 1 || ns > nh || maxb >= nh) {
/* Use the standard double-shift algorithm */
clahqr(wantt, wantz, n__, ilo, ihi, &H(1,1), ldh, &W(1), ilo,
ihi, &Z(1,1), ldz, info);
return ;
}
maxb = max(2,maxb);
/* Computing MIN */
i__1 = min(ns,maxb);
ns = min(i__1,15);
/* Now 1 < NS <= MAXB < NH.
Set machine-dependent constants for the stopping criterion.
If norm(H) <= sqrt(OVFL), overflow should not occur. */
unfl = slamch("Safe minimum");
ovfl = 1.f / unfl;
slabad(&unfl, &ovfl);
ulp = slamch("Precision");
smlnum = unfl * (nh / ulp);
/* ITN is the total number of multiple-shift 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 at most MAXB. 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;
L60:
if (i < ilo) {
goto L180;
}
/* Perform multiple-shift QR iterations on rows and columns ILO to I
until a submatrix of order at most MAXB splits off at the bottom
because a subdiagonal element has become negligible. */
l = ilo;
i__1 = itn;
for (its = 0; its <= itn; ++its) {
/* Look for a single small subdiagonal element. */
i__2 = l + 1;
for (k = i; k >= l+1; --k) {
i__3 = k - 1 + (k - 1) * h_dim1;
i__5 = k + k * h_dim1;
tst1 = (r__1 = H(k-1,k-1).r, fabs(r__1)) + (r__2 = H(k-1,k-1).i, fabs(r__2)) + ((r__3 = H(k,k).r,
fabs(r__3)) + (r__4 = H(k,k).i, fabs(
r__4)));
if (tst1 == 0.f) {
i__3 = i - l + 1;
tst1 = clanhs("1", i__3, &H(l,l), ldh, rwork);
}
i__3 = k + (k - 1) * h_dim1;
/* Computing MAX */
r__2 = ulp * tst1;
if ((r__1 = H(k,k-1).r, fabs(r__1)) <= max(r__2,smlnum)) {
goto L80;
}
}
L80:
l = k;
if (l > ilo) {
/* H(L,L-1) is negligible. */
i__2 = l + (l - 1) * h_dim1;
H(l,l-1).r = 0.f, H(l,l-1).i = 0.f;
}
/* Exit from loop if a submatrix of order <= MAXB has split off. */
if (l >= i - maxb + 1) {
goto L170;
}
/* 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 == 20 || its == 30) {
/* Exceptional shifts. */
i__2 = i;
for (ii = i - ns + 1; ii <= i; ++ii) {
i__3 = ii;
i__5 = ii + (ii - 1) * h_dim1;
i__6 = ii + ii * h_dim1;
d__1 = ((r__1 = H(ii,ii-1).r, fabs(r__1)) + (r__2 = H(ii,ii).r,
fabs(r__2))) * 1.5f;
W(ii).r = d__1, W(ii).i = 0.f;
}
} else {
/* Use eigenvalues of trailing submatrix of order NS as shifts. */
clacpy("Full", ns, ns, &H(i-ns+1,i-ns+1),
ldh, s, c__15);
clahqr(c_false, c_false, ns, c__1, ns, s, c__15, &W(i - ns
+ 1), c__1, ns, &Z(1,1), ldz, &ierr);
if (ierr > 0) {
/* If CLAHQR failed to compute all NS eigenvalues, use the
unconverged diagonal elements as the remaining shifts. */
i__2 = ierr;
for (ii = 1; ii <= ierr; ++ii) {
i__3 = i - ns + ii;
i__5 = ii + ii * 15 - 16;
W(i-ns+ii).r = s[ii+ii*15-16].r, W(i-ns+ii).i = s[ii+ii*15-16].i;
}
}
}
/* Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns))
where G is the Hessenberg submatrix H(L:I,L:I) and w is
the vector of shifts (stored in W). The result is
stored in the local array V. */
v[0].r = 1.f, v[0].i = 0.f;
i__2 = ns + 1;
for (ii = 2; ii <= ns+1; ++ii) {
i__3 = ii - 1;
v[ii-1].r = 0.f, v[ii-1].i = 0.f;
}
nv = 1;
i__2 = i;
for (j = i - ns + 1; j <= i; ++j) {
i__3 = nv + 1;
ccopy(i__3, v,c__1, vv, c__1);
i__3 = nv + 1;
i__5 = j;
q__1.r = -(double)W(j).r, q__1.i = -(double)W(j).i;
cgemv("No transpose", i__3, nv, c_b2, &H(l,l), ldh,
vv, c__1, q__1, v, c__1);
++nv;
/* Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero,
reset it to the unit vector. */
itemp = icamax(nv, v, c__1);
i__3 = itemp - 1;
rtemp = (r__1 = v[itemp-1].r, fabs(r__1)) + (r__2 = v[itemp
- 1].i, fabs(r__2));
if (rtemp == 0.f) {
v[0].r = 1.f, v[0].i = 0.f;
i__3 = nv;
for (ii = 2; ii <= nv; ++ii) {
i__5 = ii - 1;
v[ii-1].r = 0.f, v[ii-1].i = 0.f;
}
} else {
rtemp = max(rtemp,smlnum);
r__1 = 1.f / rtemp;
csscal(nv, r__1, v, c__1);
}
}
/* Multiple-shift QR step */
i__2 = i - 1;
for (k = l; k <= i-1; ++k) {
/* The first iteration of this loop determines a reflection G
from the vector V and applies it from left and right to H,
thus creating a nonzero bulge below the subdiagonal.
Each subsequent iteration determines a reflection G to
restore the Hessenberg form in the (K-1)th column, and thus
chases the bulge one step toward the bottom of the active
submatrix. NR is the order of G.
Computing MIN */
i__3 = ns + 1, i__5 = i - k + 1;
nr = min(i__3,i__5);
if (k > l) {
ccopy(nr, &H(k,k-1), c__1, v, c__1);
}
clarfg(nr, v, &v[1], c__1, &tau);
if (k > l) {
i__3 = k + (k - 1) * h_dim1;
H(k,k-1).r = v[0].r, H(k,k-1).i = v[0].i;
i__3 = i;
for (ii = k + 1; ii <= i; ++ii) {
i__5 = ii + (k - 1) * h_dim1;
H(ii,k-1).r = 0.f, H(ii,k-1).i = 0.f;
}
}
v[0].r = 1.f, v[0].i = 0.f;
/* Apply G' from the left to transform the rows of the matrix
in columns K to I2. */
i__3 = i2 - k + 1;
r_cnjg(&q__1, &tau);
clarfx("Left", nr, i__3, v, q__1, &H(k,k), ldh, &
WORK(1));
/* Apply G from the right to transform the columns of the
matrix in rows I1 to min(K+NR,I).
Computing MIN */
i__5 = k + nr;
i__3 = min(i__5,i) - i1 + 1;
clarfx("Right", i__3, nr, v, tau, &H(i1,k), ldh, &
WORK(1));
if (wantz) {
/* Accumulate transformations in the matrix Z */
clarfx("Right", nh, nr, v, tau, &Z(ilo,k),
ldz, &WORK(1));
}
}
/* Ensure that H(I,I-1) is real. */
i__2 = i + (i - 1) * h_dim1;
temp.r = H(i,i-1).r, temp.i = H(i,i-1).i;
if (temp.i != 0.f) {
r__1 = temp.r;
r__2 = temp.i;
rtemp = slapy2(r__1, r__2);
i__2 = i + (i - 1) * h_dim1;
H(i,i-1).r = rtemp, H(i,i-1).i = 0.f;
q__1.r = temp.r / rtemp, q__1.i = temp.i / rtemp;
temp.r = q__1.r, temp.i = q__1.i;
if (i2 > i) {
i__2 = i2 - i;
r_cnjg(&q__1, &temp);
cscal(i__2, q__1, &H(i,i+1), ldh);
}
i__2 = i - i1;
cscal(i__2, temp, &H(i1,i), c__1);
if (wantz) {
cscal(nh, temp, &Z(ilo,i), c__1);
}
}
}
/* Failure to converge in remaining number of iterations */
*info = i;
return ;
L170:
/* A submatrix of order <= MAXB in rows and columns L to I has split
off. Use the double-shift QR algorithm to handle it. */
clahqr(wantt, wantz, n__, l, i, &H(1,1), ldh, &W(1), ilo, ihi,
&Z(1,1), ldz, info);
if (*info > 0) {
return ;
}
/* Decrement number of remaining iterations, and return to start of
the main loop with a new value of I. */
itn -= its;
i = l - 1;
goto L60;
L180:
return ;
}
