void small_conducting_Mie(double x,struct c_complex m,double*mu,
long nangles,struct c_complex*s1,
struct c_complex*s2,double*qext,double*qsca,
double*qback,double*g)
/*:31*/
#line 448 "./mie.w"
{
struct c_complex ahat1,ahat2,bhat1,bhat2;
struct c_complex ss1;
double x2,x3,x4,muj,angle;
long j;
if((s1==NULL)||(s2==NULL))nangles= 0;
m.re+= 0.0;
x2= x*x;
x3= x2*x;
x4= x2*x2;
ahat1= c_div(c_set(0.0,2.0/3.0*(1.0-0.2*x2)),c_set(1.0-0.5*x2,2.0/3.0*x3));
bhat1= c_div(c_set(0.0,(x2-10.0)/30.0),c_set(1+0.5*x2,-x3/3.0));
ahat2= c_set(0.0,x2/30.);
bhat2= c_set(0.0,-x2/45.);
*qsca= 6.0*x4*(c_norm(ahat1)+c_norm(bhat1)+
(5.0/3.0)*(c_norm(ahat2)+c_norm(bhat2)));
*qext= *qsca;
*g= 6.0*x4*(ahat1.im*(ahat2.im+bhat1.im)+
bhat2.im*(5.0/9.0*ahat2.im+bhat1.im)+
ahat1.re*bhat1.re)/(*qsca);
ss1.re= 1.5*x2*(ahat1.re-bhat1.re);
ss1.im= 1.5*x2*(ahat1.im-bhat1.im-(5.0/3.0)*(ahat2.im+bhat2.im));
*qback= 4*c_norm(ss1);
x3*= 1.5;
ahat1.re*= x3;
ahat1.im*= x3;
bhat1.re*= x3;
bhat1.im*= x3;
ahat2.im*= x3*(5.0/3.0);
bhat2.im*= x3*(5.0/3.0);
for(j= 0;j<nangles;j++){
muj= mu[j];
angle= 2.0*muj*muj-1.0;
s1[j].re= ahat1.re+(bhat1.re)*muj;
s1[j].im= ahat1.im+(bhat1.im+ahat2.im)*muj+bhat2.im*angle;;
s2[j].re= bhat1.re+(ahat1.re)*muj;
s2[j].im= bhat1.im+(ahat1.im+bhat2.im)*muj+ahat2.im*angle;
}
}
struct c_complex Lentz_Dn(struct c_complex z,long n)
/*:10*/
#line 126 "./mie.w"
{
struct c_complex alpha_j1,alpha_j2,zinv,aj;
struct c_complex alpha,result,ratio,runratio;
/*12:*/
#line 156 "./mie.w"
zinv= c_sdiv(2.0,z);
alpha= c_smul(n+0.5,zinv);
aj= c_smul(-n-1.5,zinv);
alpha_j1= c_add(aj,c_inv(alpha));
alpha_j2= aj;
ratio= c_div(alpha_j1,alpha_j2);
runratio= c_mul(alpha,ratio);
/*:12*/
#line 131 "./mie.w"
do
/*13:*/
#line 179 "./mie.w"
{
aj.re= zinv.re-aj.re;
aj.im= zinv.im-aj.im;
alpha_j1= c_add(c_inv(alpha_j1),aj);
alpha_j2= c_add(c_inv(alpha_j2),aj);
ratio= c_div(alpha_j1,alpha_j2);
zinv.re*= -1;
zinv.im*= -1;
runratio= c_mul(ratio,runratio);
}
/*:13*/
#line 134 "./mie.w"
while(fabs(c_abs(ratio)-1.0)> 1e-12);
result= c_add(c_sdiv((double)-n,z),runratio);
return result;
}
static struct polynom *pol_div(struct polynom *p,struct polynom *q,struct polynom *p1,struct polynom *p2)
{
int i,j;
struct complex z,z1;
z.x=0; z.y=0; // RS 7.2.2013
p->n=p1->n-p2->n;
if (p->n<0)
{
sur_print("\nDegree of dividend < Degree of divisor");
WAIT; return(p);
}
for (i=0; i<=p->n; ++i)
p->a[i].x=p->a[i].y=0.0;
for (i=0; i<=p1->n; ++i)
{ q->a[i].x=p1->a[i].x; q->a[i].y=p1->a[i].y; }
for (i=p1->n; i>=p2->n; --i)
{
if (c_zero(&(q->a[i]))) continue;
c_div(&z,&(q->a[i]),&(p2->a[p2->n]));
p->a[i-p2->n].x=z.x; p->a[i-p2->n].y=z.y;
q->a[i].x=q->a[i].y=0.0;
for (j=i-1; j>=i-p2->n; --j)
c_sub(&(q->a[j]),&(q->a[j]),
c_mult(&z1,&z,&(p2->a[p2->n-i+j])));
}
i=p2->n-1;
while (c_zero(&(q->a[i])) && i>0) --i;
q->n=i;
return(p);
}
/**
* \brief Expand pole product
* \param c resulting filter coefficients
* \param poles pole locations
* \param K number of poles
* \ingroup vyv_gaussian
*
* This routine expands the product to obtain the filter coefficients:
* \f[ \prod_{k=0}^{K-1}\frac{\mathrm{poles}[k]-1}{\mathrm{poles}[k]-z^{-1}}
= \frac{c[0]}{1+\sum_{k=1}^K c[k] z^{-k}}. \f]
*/
static void expand_pole_product(double *c, const complex4c *poles, int K)
{
complex4c denom[VYV_MAX_K + 1];
int k, j;
assert(K <= VYV_MAX_K);
denom[0] = poles[0];
denom[1] = make_complex(-1, 0);
for (k = 1; k < K; ++k)
{
denom[k + 1] = c_neg(denom[k]);
for (j = k; j > 0; --j)
denom[j] = c_sub(c_mul(denom[j], poles[k]), denom[j - 1]);
denom[0] = c_mul(denom[0], poles[k]);
}
for (k = 1; k <= K; ++k)
c[k] = c_div(denom[k], denom[0]).real;
for (c[0] = 1, k = 1; k <= K; ++k)
c[0] += c[k];
return;
}
void dd (header *hd)
{ header *st=hd,*hd1,*result;
int c1,c2,i,j,r;
double *m1,*m2,*mr;
complex *mc1,*mc2,*mcr,hc1,hc2;
interval *mi1,*mi2,*mir,hi1,hi2;
hd1=next_param(st);
equal_params_2(&hd,&hd1); if (error) return;
getmatrix(hd,&r,&c1,&m1); if (r!=1) wrong_arg();
getmatrix(hd1,&r,&c2,&m2); if (r!=1) wrong_arg();
if (c1!=c2) wrong_arg();
if (iscomplex(hd)) /* complex values */
{ mc1=(complex *)m1; mc2=(complex *)m2;
result=new_cmatrix(1,c1,""); if (error) return;
mcr=(complex *)matrixof(result);
memmove((char *)mcr,(char *)mc2,c1*sizeof(complex));
for (i=1; i<c1; i++)
{ for (j=c1-1; j>=i; j--)
{ if (mc1[j][0]==mc1[j-i][0] &&
mc1[j][1]==mc1[j-i][1]) wrong_arg();
c_sub(mcr[j],mcr[j-1],hc1);
c_sub(mc1[j],mc1[j-i],hc2);
c_div(hc1,hc2,mcr[j]);
}
}
}
else if (isinterval(hd)) /* complex values */
{ mi1=(complex *)m1; mi2=(complex *)m2;
result=new_imatrix(1,c1,""); if (error) return;
mir=(interval *)matrixof(result);
memmove((char *)mir,(char *)mi2,c1*sizeof(interval));
for (i=1; i<c1; i++)
{ for (j=c1-1; j>=i; j--)
{ i_sub(mir[j],mir[j-1],hi1);
if (hi1[0]<=0 && hi1[1]>=0)
{ output("Interval points coincide\n");
error=1; return;
}
i_sub(mi1[j],mi1[j-i],hi2);
i_div(hi1,hi2,mir[j]);
}
}
}
else if (isreal(hd))
{ result=new_matrix(1,c1,""); if (error) return;
mr=matrixof(result);
memmove((char *)mr,(char *)m2,c1*sizeof(double));
for (i=1; i<c1; i++)
{ for (j=c1-1; j>=i; j--)
{ if (m1[j]==m1[j-i]) wrong_arg();
mr[j]=(mr[j]-mr[j-1])/(m1[j]-m1[j-i]);
}
}
}
else wrong_arg();
moveresult(st,result);
}
/**
* \brief Compute the variance of the impulse response
* \param poles0 unscaled pole locations
* \param q rescaling parameter
* \param K number of poles
* \return variance achieved by poles = poles0^(1/q)
* \ingroup vyv_gaussian
*/
static double variance(const complex4c *poles0, int K, double q)
{
complex4c sum = { 0, 0 };
int k;
for (k = 0; k < K; ++k)
{
complex4c z = c_real_pow(poles0[k], 1 / q), denom = z;
denom.real -= 1;
/* Compute sum += z / (z - 1)^2. */
sum = c_add(sum, c_div(z, c_mul(denom, denom)));
}
return 2 * sum.real;
}
/**
* \brief Derivative of variance with respect to q
* \param poles0 unscaled pole locations
* \param q rescaling parameter
* \param K number of poles
* \return derivative of variance with respect to q
* \ingroup vyv_gaussian
*
* This function is used by compute_q() in solving for q.
*/
static double dq_variance(const complex4c *poles0, int K, double q)
{
complex4c sum = { 0, 0 };
int k;
for (k = 0; k < K; ++k)
{
complex4c z = c_real_pow(poles0[k], 1 / q), w = z, denom = z;
w.real += 1;
denom.real -= 1;
/* Compute sum += z log(z) (z + 1) / (z - 1)^3 */
sum = c_add(sum, c_div(c_mul(c_mul(z, c_log(z)), w),
c_real_pow(denom, 3)));
}
return (2 / q) * sum.real;
}
int
cpivotL(
const int jcol, /* in */
const float u, /* in - diagonal pivoting threshold */
int *usepr, /* re-use the pivot sequence given by perm_r/iperm_r */
int *perm_r, /* may be modified */
int *iperm_r, /* in - inverse of perm_r */
int *iperm_c, /* in - used to find diagonal of Pc*A*Pc' */
int *pivrow, /* out */
GlobalLU_t *Glu, /* modified - global LU data structures */
SuperLUStat_t *stat /* output */
)
{
complex one = {1.0, 0.0};
int fsupc; /* first column in the supernode */
int nsupc; /* no of columns in the supernode */
int nsupr; /* no of rows in the supernode */
int lptr; /* points to the starting subscript of the supernode */
int pivptr, old_pivptr, diag, diagind;
float pivmax, rtemp, thresh;
complex temp;
complex *lu_sup_ptr;
complex *lu_col_ptr;
int *lsub_ptr;
int isub, icol, k, itemp;
int *lsub, *xlsub;
complex *lusup;
int *xlusup;
flops_t *ops = stat->ops;
/* Initialize pointers */
lsub = Glu->lsub;
xlsub = Glu->xlsub;
lusup = Glu->lusup;
xlusup = Glu->xlusup;
fsupc = (Glu->xsup)[(Glu->supno)[jcol]];
nsupc = jcol - fsupc; /* excluding jcol; nsupc >= 0 */
lptr = xlsub[fsupc];
nsupr = xlsub[fsupc+1] - lptr;
lu_sup_ptr = &lusup[xlusup[fsupc]]; /* start of the current supernode */
lu_col_ptr = &lusup[xlusup[jcol]]; /* start of jcol in the supernode */
lsub_ptr = &lsub[lptr]; /* start of row indices of the supernode */
#ifdef DEBUG
if ( jcol == MIN_COL ) {
printf(_T("Before cdiv: col %d\n"), jcol);
for (k = nsupc; k < nsupr; k++)
printf(_T(" lu[%d] %f\n"), lsub_ptr[k], lu_col_ptr[k]);
}
#endif
/* Determine the largest abs numerical value for partial pivoting;
Also search for user-specified pivot, and diagonal element. */
if ( *usepr ) *pivrow = iperm_r[jcol];
diagind = iperm_c[jcol];
pivmax = 0.0;
pivptr = nsupc;
diag = EMPTY;
old_pivptr = nsupc;
for (isub = nsupc; isub < nsupr; ++isub) {
rtemp = c_abs1 (&lu_col_ptr[isub]);
if ( rtemp > pivmax ) {
pivmax = rtemp;
pivptr = isub;
}
if ( *usepr && lsub_ptr[isub] == *pivrow ) old_pivptr = isub;
if ( lsub_ptr[isub] == diagind ) diag = isub;
}
/* Test for singularity */
if ( pivmax == 0.0 ) {
*pivrow = lsub_ptr[pivptr];
perm_r[*pivrow] = jcol;
*usepr = 0;
return (jcol+1);
}
thresh = u * pivmax;
/* Choose appropriate pivotal element by our policy. */
if ( *usepr ) {
rtemp = c_abs1 (&lu_col_ptr[old_pivptr]);
if ( rtemp != 0.0 && rtemp >= thresh )
pivptr = old_pivptr;
else
*usepr = 0;
}
if ( *usepr == 0 ) {
/* Use diagonal pivot? */
if ( diag >= 0 ) { /* diagonal exists */
rtemp = c_abs1 (&lu_col_ptr[diag]);
if ( rtemp != 0.0 && rtemp >= thresh ) pivptr = diag;
}
*pivrow = lsub_ptr[pivptr];
}
/* Record pivot row */
perm_r[*pivrow] = jcol;
/* Interchange row subscripts */
if ( pivptr != nsupc ) {
itemp = lsub_ptr[pivptr];
lsub_ptr[pivptr] = lsub_ptr[nsupc];
lsub_ptr[nsupc] = itemp;
/* Interchange numerical values as well, for the whole snode, such
* that L is indexed the same way as A.
*/
for (icol = 0; icol <= nsupc; icol++) {
itemp = pivptr + icol * nsupr;
temp = lu_sup_ptr[itemp];
lu_sup_ptr[itemp] = lu_sup_ptr[nsupc + icol*nsupr];
lu_sup_ptr[nsupc + icol*nsupr] = temp;
}
} /* if */
/* cdiv operation */
ops[FACT] += 10 * (nsupr - nsupc);
c_div(&temp, &one, &lu_col_ptr[nsupc]);
for (k = nsupc+1; k < nsupr; k++)
cc_mult(&lu_col_ptr[k], &lu_col_ptr[k], &temp);
return 0;
}
/* Subroutine */ int ctrti2_(char *uplo, char *diag, integer *n, complex *a,
integer *lda, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
complex q__1;
/* Local variables */
integer j;
complex ajj;
logical upper;
logical nounit;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* CTRTI2 computes the inverse of a complex upper or lower triangular */
/* matrix. */
/* This is the Level 2 BLAS version of the algorithm. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A is upper or lower triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* DIAG (input) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the triangular matrix A. If UPLO = 'U', the */
/* leading n by n upper triangular part of the array A contains */
/* the upper triangular matrix, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading n by n lower triangular part of the array A contains */
/* the lower triangular matrix, and the strictly upper */
/* triangular part of A is not referenced. If DIAG = 'U', the */
/* diagonal elements of A are also not referenced and are */
/* assumed to be 1. */
/* On exit, the (triangular) inverse of the original matrix, in */
/* the same storage format. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* ===================================================================== */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTRTI2", &i__1);
return 0;
}
if (upper) {
/* Compute inverse of upper triangular matrix. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (nounit) {
i__2 = j + j * a_dim1;
c_div(&q__1, &c_b1, &a[j + j * a_dim1]);
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
i__2 = j + j * a_dim1;
q__1.r = -a[i__2].r, q__1.i = -a[i__2].i;
ajj.r = q__1.r, ajj.i = q__1.i;
} else {
q__1.r = -1.f, q__1.i = -0.f;
ajj.r = q__1.r, ajj.i = q__1.i;
}
/* Compute elements 1:j-1 of j-th column. */
i__2 = j - 1;
ctrmv_("Upper", "No transpose", diag, &i__2, &a[a_offset], lda, &
a[j * a_dim1 + 1], &c__1);
i__2 = j - 1;
cscal_(&i__2, &ajj, &a[j * a_dim1 + 1], &c__1);
}
} else {
/* Compute inverse of lower triangular matrix. */
for (j = *n; j >= 1; --j) {
if (nounit) {
i__1 = j + j * a_dim1;
c_div(&q__1, &c_b1, &a[j + j * a_dim1]);
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
i__1 = j + j * a_dim1;
q__1.r = -a[i__1].r, q__1.i = -a[i__1].i;
ajj.r = q__1.r, ajj.i = q__1.i;
} else {
q__1.r = -1.f, q__1.i = -0.f;
ajj.r = q__1.r, ajj.i = q__1.i;
}
if (j < *n) {
/* Compute elements j+1:n of j-th column. */
i__1 = *n - j;
ctrmv_("Lower", "No transpose", diag, &i__1, &a[j + 1 + (j +
1) * a_dim1], lda, &a[j + 1 + j * a_dim1], &c__1);
i__1 = *n - j;
cscal_(&i__1, &ajj, &a[j + 1 + j * a_dim1], &c__1);
}
}
}
return 0;
/* End of CTRTI2 */
} /* ctrti2_ */
/* Subroutine */ int claic1_(integer *job, integer *j, complex *x, real *sest,
complex *w, complex *gamma, real *sestpr, complex *s, complex *c__)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
CLAIC1 applies one step of incremental condition estimation in
its simplest version:
Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j
lower triangular matrix L, such that
twonorm(L*x) = sest
Then CLAIC1 computes sestpr, s, c such that
the vector
[ s*x ]
xhat = [ c ]
is an approximate singular vector of
[ L 0 ]
Lhat = [ w' gamma ]
in the sense that
twonorm(Lhat*xhat) = sestpr.
Depending on JOB, an estimate for the largest or smallest singular
value is computed.
Note that [s c]' and sestpr**2 is an eigenpair of the system
diag(sest*sest, 0) + [alpha gamma] * [ conjg(alpha) ]
[ conjg(gamma) ]
where alpha = conjg(x)'*w.
Arguments
=========
JOB (input) INTEGER
= 1: an estimate for the largest singular value is computed.
= 2: an estimate for the smallest singular value is computed.
J (input) INTEGER
Length of X and W
X (input) COMPLEX array, dimension (J)
The j-vector x.
SEST (input) REAL
Estimated singular value of j by j matrix L
W (input) COMPLEX array, dimension (J)
The j-vector w.
GAMMA (input) COMPLEX
The diagonal element gamma.
SESTPR (output) REAL
Estimated singular value of (j+1) by (j+1) matrix Lhat.
S (output) COMPLEX
Sine needed in forming xhat.
C (output) COMPLEX
Cosine needed in forming xhat.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
real r__1, r__2;
complex q__1, q__2, q__3, q__4, q__5, q__6;
/* Builtin functions */
double c_abs(complex *);
void r_cnjg(complex *, complex *), c_sqrt(complex *, complex *);
double sqrt(doublereal);
void c_div(complex *, complex *, complex *);
/* Local variables */
static complex sine;
static real test, zeta1, zeta2, b, t;
static complex alpha;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
static real norma, s1, s2, absgam, absalp;
extern doublereal slamch_(char *);
static complex cosine;
static real absest, scl, eps, tmp;
--w;
--x;
/* Function Body */
eps = slamch_("Epsilon");
cdotc_(&q__1, j, &x[1], &c__1, &w[1], &c__1);
alpha.r = q__1.r, alpha.i = q__1.i;
absalp = c_abs(&alpha);
absgam = c_abs(gamma);
absest = dabs(*sest);
if (*job == 1) {
/* Estimating largest singular value
special cases */
if (*sest == 0.f) {
s1 = dmax(absgam,absalp);
if (s1 == 0.f) {
s->r = 0.f, s->i = 0.f;
c__->r = 1.f, c__->i = 0.f;
*sestpr = 0.f;
} else {
q__1.r = alpha.r / s1, q__1.i = alpha.i / s1;
s->r = q__1.r, s->i = q__1.i;
q__1.r = gamma->r / s1, q__1.i = gamma->i / s1;
c__->r = q__1.r, c__->i = q__1.i;
r_cnjg(&q__4, s);
q__3.r = s->r * q__4.r - s->i * q__4.i, q__3.i = s->r *
q__4.i + s->i * q__4.r;
r_cnjg(&q__6, c__);
q__5.r = c__->r * q__6.r - c__->i * q__6.i, q__5.i = c__->r *
q__6.i + c__->i * q__6.r;
q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
c_sqrt(&q__1, &q__2);
tmp = q__1.r;
q__1.r = s->r / tmp, q__1.i = s->i / tmp;
s->r = q__1.r, s->i = q__1.i;
q__1.r = c__->r / tmp, q__1.i = c__->i / tmp;
c__->r = q__1.r, c__->i = q__1.i;
*sestpr = s1 * tmp;
}
return 0;
} else if (absgam <= eps * absest) {
s->r = 1.f, s->i = 0.f;
c__->r = 0.f, c__->i = 0.f;
tmp = dmax(absest,absalp);
s1 = absest / tmp;
s2 = absalp / tmp;
*sestpr = tmp * sqrt(s1 * s1 + s2 * s2);
return 0;
} else if (absalp <= eps * absest) {
s1 = absgam;
s2 = absest;
if (s1 <= s2) {
s->r = 1.f, s->i = 0.f;
c__->r = 0.f, c__->i = 0.f;
*sestpr = s2;
} else {
s->r = 0.f, s->i = 0.f;
c__->r = 1.f, c__->i = 0.f;
*sestpr = s1;
}
return 0;
} else if (absest <= eps * absalp || absest <= eps * absgam) {
s1 = absgam;
s2 = absalp;
if (s1 <= s2) {
tmp = s1 / s2;
scl = sqrt(tmp * tmp + 1.f);
*sestpr = s2 * scl;
q__2.r = alpha.r / s2, q__2.i = alpha.i / s2;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
s->r = q__1.r, s->i = q__1.i;
q__2.r = gamma->r / s2, q__2.i = gamma->i / s2;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
c__->r = q__1.r, c__->i = q__1.i;
} else {
tmp = s2 / s1;
scl = sqrt(tmp * tmp + 1.f);
*sestpr = s1 * scl;
q__2.r = alpha.r / s1, q__2.i = alpha.i / s1;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
s->r = q__1.r, s->i = q__1.i;
q__2.r = gamma->r / s1, q__2.i = gamma->i / s1;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
c__->r = q__1.r, c__->i = q__1.i;
}
return 0;
} else {
/* normal case */
zeta1 = absalp / absest;
zeta2 = absgam / absest;
b = (1.f - zeta1 * zeta1 - zeta2 * zeta2) * .5f;
r__1 = zeta1 * zeta1;
c__->r = r__1, c__->i = 0.f;
if (b > 0.f) {
r__1 = b * b;
q__4.r = r__1 + c__->r, q__4.i = c__->i;
c_sqrt(&q__3, &q__4);
q__2.r = b + q__3.r, q__2.i = q__3.i;
c_div(&q__1, c__, &q__2);
t = q__1.r;
} else {
r__1 = b * b;
q__3.r = r__1 + c__->r, q__3.i = c__->i;
c_sqrt(&q__2, &q__3);
q__1.r = q__2.r - b, q__1.i = q__2.i;
t = q__1.r;
}
q__3.r = alpha.r / absest, q__3.i = alpha.i / absest;
q__2.r = -q__3.r, q__2.i = -q__3.i;
q__1.r = q__2.r / t, q__1.i = q__2.i / t;
sine.r = q__1.r, sine.i = q__1.i;
q__3.r = gamma->r / absest, q__3.i = gamma->i / absest;
q__2.r = -q__3.r, q__2.i = -q__3.i;
r__1 = t + 1.f;
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
cosine.r = q__1.r, cosine.i = q__1.i;
r_cnjg(&q__4, &sine);
q__3.r = sine.r * q__4.r - sine.i * q__4.i, q__3.i = sine.r *
q__4.i + sine.i * q__4.r;
r_cnjg(&q__6, &cosine);
q__5.r = cosine.r * q__6.r - cosine.i * q__6.i, q__5.i = cosine.r
* q__6.i + cosine.i * q__6.r;
q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
c_sqrt(&q__1, &q__2);
tmp = q__1.r;
q__1.r = sine.r / tmp, q__1.i = sine.i / tmp;
s->r = q__1.r, s->i = q__1.i;
q__1.r = cosine.r / tmp, q__1.i = cosine.i / tmp;
c__->r = q__1.r, c__->i = q__1.i;
*sestpr = sqrt(t + 1.f) * absest;
return 0;
}
} else if (*job == 2) {
/* Estimating smallest singular value
special cases */
if (*sest == 0.f) {
*sestpr = 0.f;
if (dmax(absgam,absalp) == 0.f) {
sine.r = 1.f, sine.i = 0.f;
cosine.r = 0.f, cosine.i = 0.f;
} else {
r_cnjg(&q__2, gamma);
q__1.r = -q__2.r, q__1.i = -q__2.i;
sine.r = q__1.r, sine.i = q__1.i;
r_cnjg(&q__1, &alpha);
cosine.r = q__1.r, cosine.i = q__1.i;
}
/* Computing MAX */
r__1 = c_abs(&sine), r__2 = c_abs(&cosine);
s1 = dmax(r__1,r__2);
q__1.r = sine.r / s1, q__1.i = sine.i / s1;
s->r = q__1.r, s->i = q__1.i;
q__1.r = cosine.r / s1, q__1.i = cosine.i / s1;
c__->r = q__1.r, c__->i = q__1.i;
r_cnjg(&q__4, s);
q__3.r = s->r * q__4.r - s->i * q__4.i, q__3.i = s->r * q__4.i +
s->i * q__4.r;
r_cnjg(&q__6, c__);
q__5.r = c__->r * q__6.r - c__->i * q__6.i, q__5.i = c__->r *
q__6.i + c__->i * q__6.r;
q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
c_sqrt(&q__1, &q__2);
tmp = q__1.r;
q__1.r = s->r / tmp, q__1.i = s->i / tmp;
s->r = q__1.r, s->i = q__1.i;
q__1.r = c__->r / tmp, q__1.i = c__->i / tmp;
c__->r = q__1.r, c__->i = q__1.i;
return 0;
} else if (absgam <= eps * absest) {
s->r = 0.f, s->i = 0.f;
c__->r = 1.f, c__->i = 0.f;
*sestpr = absgam;
return 0;
} else if (absalp <= eps * absest) {
s1 = absgam;
s2 = absest;
if (s1 <= s2) {
s->r = 0.f, s->i = 0.f;
c__->r = 1.f, c__->i = 0.f;
*sestpr = s1;
} else {
s->r = 1.f, s->i = 0.f;
c__->r = 0.f, c__->i = 0.f;
*sestpr = s2;
}
return 0;
} else if (absest <= eps * absalp || absest <= eps * absgam) {
s1 = absgam;
s2 = absalp;
if (s1 <= s2) {
tmp = s1 / s2;
scl = sqrt(tmp * tmp + 1.f);
*sestpr = absest * (tmp / scl);
r_cnjg(&q__4, gamma);
q__3.r = q__4.r / s2, q__3.i = q__4.i / s2;
q__2.r = -q__3.r, q__2.i = -q__3.i;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
s->r = q__1.r, s->i = q__1.i;
r_cnjg(&q__3, &alpha);
q__2.r = q__3.r / s2, q__2.i = q__3.i / s2;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
c__->r = q__1.r, c__->i = q__1.i;
} else {
tmp = s2 / s1;
scl = sqrt(tmp * tmp + 1.f);
*sestpr = absest / scl;
r_cnjg(&q__4, gamma);
q__3.r = q__4.r / s1, q__3.i = q__4.i / s1;
q__2.r = -q__3.r, q__2.i = -q__3.i;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
s->r = q__1.r, s->i = q__1.i;
r_cnjg(&q__3, &alpha);
q__2.r = q__3.r / s1, q__2.i = q__3.i / s1;
q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
c__->r = q__1.r, c__->i = q__1.i;
}
return 0;
} else {
/* normal case */
zeta1 = absalp / absest;
zeta2 = absgam / absest;
/* Computing MAX */
r__1 = zeta1 * zeta1 + 1.f + zeta1 * zeta2, r__2 = zeta1 * zeta2
+ zeta2 * zeta2;
norma = dmax(r__1,r__2);
/* See if root is closer to zero or to ONE */
test = (zeta1 - zeta2) * 2.f * (zeta1 + zeta2) + 1.f;
if (test >= 0.f) {
/* root is close to zero, compute directly */
b = (zeta1 * zeta1 + zeta2 * zeta2 + 1.f) * .5f;
r__1 = zeta2 * zeta2;
c__->r = r__1, c__->i = 0.f;
r__2 = b * b;
q__2.r = r__2 - c__->r, q__2.i = -c__->i;
r__1 = b + sqrt(c_abs(&q__2));
q__1.r = c__->r / r__1, q__1.i = c__->i / r__1;
t = q__1.r;
q__2.r = alpha.r / absest, q__2.i = alpha.i / absest;
r__1 = 1.f - t;
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
sine.r = q__1.r, sine.i = q__1.i;
q__3.r = gamma->r / absest, q__3.i = gamma->i / absest;
q__2.r = -q__3.r, q__2.i = -q__3.i;
q__1.r = q__2.r / t, q__1.i = q__2.i / t;
cosine.r = q__1.r, cosine.i = q__1.i;
*sestpr = sqrt(t + eps * 4.f * eps * norma) * absest;
} else {
/* root is closer to ONE, shift by that amount */
b = (zeta2 * zeta2 + zeta1 * zeta1 - 1.f) * .5f;
r__1 = zeta1 * zeta1;
c__->r = r__1, c__->i = 0.f;
if (b >= 0.f) {
q__2.r = -c__->r, q__2.i = -c__->i;
r__1 = b * b;
q__5.r = r__1 + c__->r, q__5.i = c__->i;
c_sqrt(&q__4, &q__5);
q__3.r = b + q__4.r, q__3.i = q__4.i;
c_div(&q__1, &q__2, &q__3);
t = q__1.r;
} else {
r__1 = b * b;
q__3.r = r__1 + c__->r, q__3.i = c__->i;
c_sqrt(&q__2, &q__3);
q__1.r = b - q__2.r, q__1.i = -q__2.i;
t = q__1.r;
}
q__3.r = alpha.r / absest, q__3.i = alpha.i / absest;
q__2.r = -q__3.r, q__2.i = -q__3.i;
q__1.r = q__2.r / t, q__1.i = q__2.i / t;
sine.r = q__1.r, sine.i = q__1.i;
q__3.r = gamma->r / absest, q__3.i = gamma->i / absest;
q__2.r = -q__3.r, q__2.i = -q__3.i;
r__1 = t + 1.f;
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
cosine.r = q__1.r, cosine.i = q__1.i;
*sestpr = sqrt(t + 1.f + eps * 4.f * eps * norma) * absest;
}
r_cnjg(&q__4, &sine);
q__3.r = sine.r * q__4.r - sine.i * q__4.i, q__3.i = sine.r *
q__4.i + sine.i * q__4.r;
r_cnjg(&q__6, &cosine);
q__5.r = cosine.r * q__6.r - cosine.i * q__6.i, q__5.i = cosine.r
* q__6.i + cosine.i * q__6.r;
q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
c_sqrt(&q__1, &q__2);
tmp = q__1.r;
q__1.r = sine.r / tmp, q__1.i = sine.i / tmp;
s->r = q__1.r, s->i = q__1.i;
q__1.r = cosine.r / tmp, q__1.i = cosine.i / tmp;
c__->r = q__1.r, c__->i = q__1.i;
return 0;
}
}
return 0;
/* End of CLAIC1 */
} /* claic1_ */
/* Subroutine */ int cgttrf_(integer *n, complex *dl, complex *d__, complex *
du, complex *du2, integer *ipiv, integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4;
real r__1, r__2, r__3, r__4;
complex q__1, q__2;
/* Builtin functions */
double r_imag(complex *);
void c_div(complex *, complex *, complex *);
/* Local variables */
integer i__;
complex fact, temp;
extern /* Subroutine */ int xerbla_(char *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGTTRF computes an LU factorization of a complex tridiagonal matrix A */
/* using elimination with partial pivoting and row interchanges. */
/* The factorization has the form */
/* A = L * U */
/* where L is a product of permutation and unit lower bidiagonal */
/* matrices and U is upper triangular with nonzeros in only the main */
/* diagonal and first two superdiagonals. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. */
/* DL (input/output) COMPLEX array, dimension (N-1) */
/* On entry, DL must contain the (n-1) sub-diagonal elements of */
/* A. */
/* On exit, DL is overwritten by the (n-1) multipliers that */
/* define the matrix L from the LU factorization of A. */
/* D (input/output) COMPLEX array, dimension (N) */
/* On entry, D must contain the diagonal elements of A. */
/* On exit, D is overwritten by the n diagonal elements of the */
/* upper triangular matrix U from the LU factorization of A. */
/* DU (input/output) COMPLEX array, dimension (N-1) */
/* On entry, DU must contain the (n-1) super-diagonal elements */
/* of A. */
/* On exit, DU is overwritten by the (n-1) elements of the first */
/* super-diagonal of U. */
/* DU2 (output) COMPLEX array, dimension (N-2) */
/* On exit, DU2 is overwritten by the (n-2) elements of the */
/* second super-diagonal of U. */
/* IPIV (output) INTEGER array, dimension (N) */
/* The pivot indices; for 1 <= i <= n, row i of the matrix was */
/* interchanged with row IPIV(i). IPIV(i) will always be either */
/* i or i+1; IPIV(i) = i indicates a row interchange was not */
/* required. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* > 0: if INFO = k, U(k,k) is exactly zero. The factorization */
/* has been completed, but the factor U is exactly */
/* singular, and division by zero will occur if it is used */
/* to solve a system of equations. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--ipiv;
--du2;
--du;
--d__;
--dl;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
i__1 = -(*info);
xerbla_("CGTTRF", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Initialize IPIV(i) = i and DU2(i) = 0 */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
ipiv[i__] = i__;
/* L10: */
}
i__1 = *n - 2;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
du2[i__2].r = 0.f, du2[i__2].i = 0.f;
/* L20: */
}
i__1 = *n - 2;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__;
if ((r__1 = d__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&d__[i__]),
dabs(r__2)) >= (r__3 = dl[i__3].r, dabs(r__3)) + (r__4 =
r_imag(&dl[i__]), dabs(r__4))) {
/* No row interchange required, eliminate DL(I) */
i__2 = i__;
if ((r__1 = d__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&d__[i__]),
dabs(r__2)) != 0.f) {
c_div(&q__1, &dl[i__], &d__[i__]);
fact.r = q__1.r, fact.i = q__1.i;
i__2 = i__;
dl[i__2].r = fact.r, dl[i__2].i = fact.i;
i__2 = i__ + 1;
i__3 = i__ + 1;
i__4 = i__;
q__2.r = fact.r * du[i__4].r - fact.i * du[i__4].i, q__2.i =
fact.r * du[i__4].i + fact.i * du[i__4].r;
q__1.r = d__[i__3].r - q__2.r, q__1.i = d__[i__3].i - q__2.i;
d__[i__2].r = q__1.r, d__[i__2].i = q__1.i;
}
} else {
/* Interchange rows I and I+1, eliminate DL(I) */
c_div(&q__1, &d__[i__], &dl[i__]);
fact.r = q__1.r, fact.i = q__1.i;
i__2 = i__;
i__3 = i__;
d__[i__2].r = dl[i__3].r, d__[i__2].i = dl[i__3].i;
i__2 = i__;
dl[i__2].r = fact.r, dl[i__2].i = fact.i;
i__2 = i__;
temp.r = du[i__2].r, temp.i = du[i__2].i;
i__2 = i__;
i__3 = i__ + 1;
du[i__2].r = d__[i__3].r, du[i__2].i = d__[i__3].i;
i__2 = i__ + 1;
i__3 = i__ + 1;
q__2.r = fact.r * d__[i__3].r - fact.i * d__[i__3].i, q__2.i =
fact.r * d__[i__3].i + fact.i * d__[i__3].r;
q__1.r = temp.r - q__2.r, q__1.i = temp.i - q__2.i;
d__[i__2].r = q__1.r, d__[i__2].i = q__1.i;
i__2 = i__;
i__3 = i__ + 1;
du2[i__2].r = du[i__3].r, du2[i__2].i = du[i__3].i;
i__2 = i__ + 1;
q__2.r = -fact.r, q__2.i = -fact.i;
i__3 = i__ + 1;
q__1.r = q__2.r * du[i__3].r - q__2.i * du[i__3].i, q__1.i =
q__2.r * du[i__3].i + q__2.i * du[i__3].r;
du[i__2].r = q__1.r, du[i__2].i = q__1.i;
ipiv[i__] = i__ + 1;
}
/* L30: */
}
if (*n > 1) {
i__ = *n - 1;
i__1 = i__;
i__2 = i__;
if ((r__1 = d__[i__1].r, dabs(r__1)) + (r__2 = r_imag(&d__[i__]),
dabs(r__2)) >= (r__3 = dl[i__2].r, dabs(r__3)) + (r__4 =
r_imag(&dl[i__]), dabs(r__4))) {
i__1 = i__;
if ((r__1 = d__[i__1].r, dabs(r__1)) + (r__2 = r_imag(&d__[i__]),
dabs(r__2)) != 0.f) {
c_div(&q__1, &dl[i__], &d__[i__]);
fact.r = q__1.r, fact.i = q__1.i;
i__1 = i__;
dl[i__1].r = fact.r, dl[i__1].i = fact.i;
i__1 = i__ + 1;
i__2 = i__ + 1;
i__3 = i__;
q__2.r = fact.r * du[i__3].r - fact.i * du[i__3].i, q__2.i =
fact.r * du[i__3].i + fact.i * du[i__3].r;
q__1.r = d__[i__2].r - q__2.r, q__1.i = d__[i__2].i - q__2.i;
d__[i__1].r = q__1.r, d__[i__1].i = q__1.i;
}
} else {
c_div(&q__1, &d__[i__], &dl[i__]);
fact.r = q__1.r, fact.i = q__1.i;
i__1 = i__;
i__2 = i__;
d__[i__1].r = dl[i__2].r, d__[i__1].i = dl[i__2].i;
i__1 = i__;
dl[i__1].r = fact.r, dl[i__1].i = fact.i;
i__1 = i__;
temp.r = du[i__1].r, temp.i = du[i__1].i;
i__1 = i__;
i__2 = i__ + 1;
du[i__1].r = d__[i__2].r, du[i__1].i = d__[i__2].i;
i__1 = i__ + 1;
i__2 = i__ + 1;
q__2.r = fact.r * d__[i__2].r - fact.i * d__[i__2].i, q__2.i =
fact.r * d__[i__2].i + fact.i * d__[i__2].r;
q__1.r = temp.r - q__2.r, q__1.i = temp.i - q__2.i;
d__[i__1].r = q__1.r, d__[i__1].i = q__1.i;
ipiv[i__] = i__ + 1;
}
}
/* Check for a zero on the diagonal of U. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
if ((r__1 = d__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&d__[i__]),
dabs(r__2)) == 0.f) {
*info = i__;
goto L50;
}
/* L40: */
}
L50:
return 0;
/* End of CGTTRF */
} /* cgttrf_ */
/*< subroutine csvdc(x,ldx,n,p,s,e,u,ldu,v,ldv,work,job,info) >*/
/* Subroutine */ int csvdc_(complex *x, integer *ldx, integer *n, integer *p,
complex *s, complex *e, complex *u, integer *ldu, complex *v, integer
*ldv, complex *work, integer *job, integer *info)
{
/* System generated locals */
integer x_dim1, x_offset, u_dim1, u_offset, v_dim1, v_offset, i__1, i__2,
i__3, i__4;
real r__1, r__2, r__3, r__4;
complex q__1, q__2, q__3;
/* Builtin functions */
double r_imag(complex *), c_abs(complex *);
void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *);
double sqrt(doublereal);
/* Local variables */
real b, c__, f, g;
integer i__, j, k, l=0, m;
complex r__, t;
real t1, el;
integer kk;
real cs;
integer ll, mm, ls=0;
real sl;
integer lu;
real sm, sn;
integer lm1, mm1, lp1, mp1, nct, ncu, lls, nrt;
real emm1, smm1;
integer kase, jobu, iter;
real test;
integer nctp1, nrtp1;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
real scale;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
real shift;
extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
complex *, integer *);
integer maxit;
extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *), csrot_(integer *, complex *,
integer *, complex *, integer *, real *, real *);
logical wantu, wantv;
extern /* Subroutine */ int srotg_(real *, real *, real *, real *);
real ztest;
extern doublereal scnrm2_(integer *, complex *, integer *);
/*< integer ldx,n,p,ldu,ldv,job,info >*/
/*< complex x(ldx,1),s(1),e(1),u(ldu,1),v(ldv,1),work(1) >*/
/* csvdc is a subroutine to reduce a complex nxp matrix x by */
/* unitary transformations u and v to diagonal form. the */
/* diagonal elements s(i) are the singular values of x. the */
/* columns of u are the corresponding left singular vectors, */
/* and the columns of v the right singular vectors. */
/* on entry */
/* x complex(ldx,p), where ldx.ge.n. */
/* x contains the matrix whose singular value */
/* decomposition is to be computed. x is */
/* destroyed by csvdc. */
/* ldx integer. */
/* ldx is the leading dimension of the array x. */
/* n integer. */
/* n is the number of rows of the matrix x. */
/* p integer. */
/* p is the number of columns of the matrix x. */
/* ldu integer. */
/* ldu is the leading dimension of the array u */
/* (see below). */
/* ldv integer. */
/* ldv is the leading dimension of the array v */
/* (see below). */
/* work complex(n). */
/* work is a scratch array. */
/* job integer. */
/* job controls the computation of the singular */
/* vectors. it has the decimal expansion ab */
/* with the following meaning */
/* a.eq.0 do not compute the left singular */
/* vectors. */
/* a.eq.1 return the n left singular vectors */
/* in u. */
/* a.ge.2 returns the first min(n,p) */
/* left singular vectors in u. */
/* b.eq.0 do not compute the right singular */
/* vectors. */
/* b.eq.1 return the right singular vectors */
/* in v. */
/* on return */
/* s complex(mm), where mm=min(n+1,p). */
/* the first min(n,p) entries of s contain the */
/* singular values of x arranged in descending */
/* order of magnitude. */
/* e complex(p). */
/* e ordinarily contains zeros. however see the */
/* discussion of info for exceptions. */
/* u complex(ldu,k), where ldu.ge.n. if joba.eq.1 then */
/* k.eq.n, if joba.ge.2 then */
/* k.eq.min(n,p). */
/* u contains the matrix of left singular vectors. */
/* u is not referenced if joba.eq.0. if n.le.p */
/* or if joba.gt.2, then u may be identified with x */
/* in the subroutine call. */
/* v complex(ldv,p), where ldv.ge.p. */
/* v contains the matrix of right singular vectors. */
/* v is not referenced if jobb.eq.0. if p.le.n, */
/* then v may be identified whth x in the */
/* subroutine call. */
/* info integer. */
/* the singular values (and their corresponding */
/* singular vectors) s(info+1),s(info+2),...,s(m) */
/* are correct (here m=min(n,p)). thus if */
/* info.eq.0, all the singular values and their */
/* vectors are correct. in any event, the matrix */
/* b = ctrans(u)*x*v is the bidiagonal matrix */
/* with the elements of s on its diagonal and the */
/* elements of e on its super-diagonal (ctrans(u) */
/* is the conjugate-transpose of u). thus the */
/* singular values of x and b are the same. */
/* linpack. this version dated 03/19/79 . */
/* correction to shift calculation made 2/85. */
/* g.w. stewart, university of maryland, argonne national lab. */
/* csvdc uses the following functions and subprograms. */
/* external csrot */
/* blas caxpy,cdotc,cscal,cswap,scnrm2,srotg */
/* fortran abs,aimag,amax1,cabs,cmplx */
/* fortran conjg,max0,min0,mod,real,sqrt */
/* internal variables */
/*< >*/
/*< complex cdotc,t,r >*/
/*< >*/
/*< logical wantu,wantv >*/
/*< complex csign,zdum,zdum1,zdum2 >*/
/*< real cabs1 >*/
/*< cabs1(zdum) = abs(real(zdum)) + abs(aimag(zdum)) >*/
/*< csign(zdum1,zdum2) = cabs(zdum1)*(zdum2/cabs(zdum2)) >*/
/* set the maximum number of iterations. */
/*< maxit = 1000 >*/
/* Parameter adjustments */
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--s;
--e;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--work;
/* Function Body */
maxit = 1000;
/* determine what is to be computed. */
/*< wantu = .false. >*/
wantu = FALSE_;
/*< wantv = .false. >*/
wantv = FALSE_;
/*< jobu = mod(job,100)/10 >*/
jobu = *job % 100 / 10;
/*< ncu = n >*/
ncu = *n;
/*< if (jobu .gt. 1) ncu = min0(n,p) >*/
if (jobu > 1) {
ncu = min(*n,*p);
}
/*< if (jobu .ne. 0) wantu = .true. >*/
if (jobu != 0) {
wantu = TRUE_;
}
/*< if (mod(job,10) .ne. 0) wantv = .true. >*/
if (*job % 10 != 0) {
wantv = TRUE_;
}
/* reduce x to bidiagonal form, storing the diagonal elements */
/* in s and the super-diagonal elements in e. */
/*< info = 0 >*/
*info = 0;
/*< nct = min0(n-1,p) >*/
/* Computing MIN */
i__1 = *n - 1;
nct = min(i__1,*p);
/*< nrt = max0(0,min0(p-2,n)) >*/
/* Computing MAX */
/* Computing MIN */
i__3 = *p - 2;
i__1 = 0, i__2 = min(i__3,*n);
nrt = max(i__1,i__2);
/*< lu = max0(nct,nrt) >*/
lu = max(nct,nrt);
/*< if (lu .lt. 1) go to 170 >*/
if (lu < 1) {
goto L170;
}
/*< do 160 l = 1, lu >*/
i__1 = lu;
for (l = 1; l <= i__1; ++l) {
/*< lp1 = l + 1 >*/
lp1 = l + 1;
/*< if (l .gt. nct) go to 20 >*/
if (l > nct) {
goto L20;
}
/* compute the transformation for the l-th column and */
/* place the l-th diagonal in s(l). */
/*< s(l) = cmplx(scnrm2(n-l+1,x(l,l),1),0.0e0) >*/
i__2 = l;
i__3 = *n - l + 1;
r__1 = scnrm2_(&i__3, &x[l + l * x_dim1], &c__1);
q__1.r = r__1, q__1.i = (float)0.;
s[i__2].r = q__1.r, s[i__2].i = q__1.i;
/*< if (cabs1(s(l)) .eq. 0.0e0) go to 10 >*/
i__2 = l;
if ((r__1 = s[i__2].r, dabs(r__1)) + (r__2 = r_imag(&s[l]), dabs(r__2)
) == (float)0.) {
goto L10;
}
/*< if (cabs1(x(l,l)) .ne. 0.0e0) s(l) = csign(s(l),x(l,l)) >*/
i__2 = l + l * x_dim1;
if ((r__1 = x[i__2].r, dabs(r__1)) + (r__2 = r_imag(&x[l + l * x_dim1]
), dabs(r__2)) != (float)0.) {
i__3 = l;
r__3 = c_abs(&s[l]);
i__4 = l + l * x_dim1;
r__4 = c_abs(&x[l + l * x_dim1]);
q__2.r = x[i__4].r / r__4, q__2.i = x[i__4].i / r__4;
q__1.r = r__3 * q__2.r, q__1.i = r__3 * q__2.i;
s[i__3].r = q__1.r, s[i__3].i = q__1.i;
}
/*< call cscal(n-l+1,1.0e0/s(l),x(l,l),1) >*/
i__2 = *n - l + 1;
c_div(&q__1, &c_b8, &s[l]);
cscal_(&i__2, &q__1, &x[l + l * x_dim1], &c__1);
/*< x(l,l) = (1.0e0,0.0e0) + x(l,l) >*/
i__2 = l + l * x_dim1;
i__3 = l + l * x_dim1;
q__1.r = x[i__3].r + (float)1., q__1.i = x[i__3].i + (float)0.;
x[i__2].r = q__1.r, x[i__2].i = q__1.i;
/*< 10 continue >*/
L10:
/*< s(l) = -s(l) >*/
i__2 = l;
i__3 = l;
q__1.r = -s[i__3].r, q__1.i = -s[i__3].i;
s[i__2].r = q__1.r, s[i__2].i = q__1.i;
/*< 20 continue >*/
L20:
/*< if (p .lt. lp1) go to 50 >*/
if (*p < lp1) {
goto L50;
}
/*< do 40 j = lp1, p >*/
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
/*< if (l .gt. nct) go to 30 >*/
if (l > nct) {
goto L30;
}
/*< if (cabs1(s(l)) .eq. 0.0e0) go to 30 >*/
i__3 = l;
if ((r__1 = s[i__3].r, dabs(r__1)) + (r__2 = r_imag(&s[l]), dabs(
r__2)) == (float)0.) {
goto L30;
}
/* apply the transformation. */
/*< t = -cdotc(n-l+1,x(l,l),1,x(l,j),1)/x(l,l) >*/
i__3 = *n - l + 1;
cdotc_(&q__3, &i__3, &x[l + l * x_dim1], &c__1, &x[l + j * x_dim1]
, &c__1);
q__2.r = -q__3.r, q__2.i = -q__3.i;
c_div(&q__1, &q__2, &x[l + l * x_dim1]);
t.r = q__1.r, t.i = q__1.i;
/*< call caxpy(n-l+1,t,x(l,l),1,x(l,j),1) >*/
i__3 = *n - l + 1;
caxpy_(&i__3, &t, &x[l + l * x_dim1], &c__1, &x[l + j * x_dim1], &
c__1);
/*< 30 continue >*/
L30:
/* place the l-th row of x into e for the */
/* subsequent calculation of the row transformation. */
/*< e(j) = conjg(x(l,j)) >*/
i__3 = j;
r_cnjg(&q__1, &x[l + j * x_dim1]);
e[i__3].r = q__1.r, e[i__3].i = q__1.i;
/*< 40 continue >*/
/* L40: */
}
/*< 50 continue >*/
L50:
/*< if (.not.wantu .or. l .gt. nct) go to 70 >*/
if (! wantu || l > nct) {
goto L70;
}
/* place the transformation in u for subsequent back */
/* multiplication. */
/*< do 60 i = l, n >*/
i__2 = *n;
for (i__ = l; i__ <= i__2; ++i__) {
/*< u(i,l) = x(i,l) >*/
i__3 = i__ + l * u_dim1;
i__4 = i__ + l * x_dim1;
u[i__3].r = x[i__4].r, u[i__3].i = x[i__4].i;
/*< 60 continue >*/
/* L60: */
}
/*< 70 continue >*/
L70:
/*< if (l .gt. nrt) go to 150 >*/
if (l > nrt) {
goto L150;
}
/* compute the l-th row transformation and place the */
/* l-th super-diagonal in e(l). */
/*< e(l) = cmplx(scnrm2(p-l,e(lp1),1),0.0e0) >*/
i__2 = l;
i__3 = *p - l;
r__1 = scnrm2_(&i__3, &e[lp1], &c__1);
q__1.r = r__1, q__1.i = (float)0.;
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
/*< if (cabs1(e(l)) .eq. 0.0e0) go to 80 >*/
i__2 = l;
if ((r__1 = e[i__2].r, dabs(r__1)) + (r__2 = r_imag(&e[l]), dabs(r__2)
) == (float)0.) {
goto L80;
}
/*< if (cabs1(e(lp1)) .ne. 0.0e0) e(l) = csign(e(l),e(lp1)) >*/
i__2 = lp1;
if ((r__1 = e[i__2].r, dabs(r__1)) + (r__2 = r_imag(&e[lp1]), dabs(
r__2)) != (float)0.) {
i__3 = l;
r__3 = c_abs(&e[l]);
i__4 = lp1;
r__4 = c_abs(&e[lp1]);
q__2.r = e[i__4].r / r__4, q__2.i = e[i__4].i / r__4;
q__1.r = r__3 * q__2.r, q__1.i = r__3 * q__2.i;
e[i__3].r = q__1.r, e[i__3].i = q__1.i;
}
/*< call cscal(p-l,1.0e0/e(l),e(lp1),1) >*/
i__2 = *p - l;
c_div(&q__1, &c_b8, &e[l]);
cscal_(&i__2, &q__1, &e[lp1], &c__1);
/*< e(lp1) = (1.0e0,0.0e0) + e(lp1) >*/
i__2 = lp1;
i__3 = lp1;
q__1.r = e[i__3].r + (float)1., q__1.i = e[i__3].i + (float)0.;
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
/*< 80 continue >*/
L80:
/*< e(l) = -conjg(e(l)) >*/
i__2 = l;
r_cnjg(&q__2, &e[l]);
q__1.r = -q__2.r, q__1.i = -q__2.i;
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
/*< if (lp1 .gt. n .or. cabs1(e(l)) .eq. 0.0e0) go to 120 >*/
i__2 = l;
if (lp1 > *n || (r__1 = e[i__2].r, dabs(r__1)) + (r__2 = r_imag(&e[l])
, dabs(r__2)) == (float)0.) {
goto L120;
}
/* apply the transformation. */
/*< do 90 i = lp1, n >*/
i__2 = *n;
for (i__ = lp1; i__ <= i__2; ++i__) {
/*< work(i) = (0.0e0,0.0e0) >*/
i__3 = i__;
work[i__3].r = (float)0., work[i__3].i = (float)0.;
/*< 90 continue >*/
/* L90: */
}
/*< do 100 j = lp1, p >*/
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
/*< call caxpy(n-l,e(j),x(lp1,j),1,work(lp1),1) >*/
i__3 = *n - l;
caxpy_(&i__3, &e[j], &x[lp1 + j * x_dim1], &c__1, &work[lp1], &
c__1);
/*< 100 continue >*/
/* L100: */
}
/*< do 110 j = lp1, p >*/
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
/*< >*/
i__3 = *n - l;
i__4 = j;
q__3.r = -e[i__4].r, q__3.i = -e[i__4].i;
c_div(&q__2, &q__3, &e[lp1]);
r_cnjg(&q__1, &q__2);
caxpy_(&i__3, &q__1, &work[lp1], &c__1, &x[lp1 + j * x_dim1], &
c__1);
/*< 110 continue >*/
/* L110: */
}
/*< 120 continue >*/
L120:
/*< if (.not.wantv) go to 140 >*/
if (! wantv) {
goto L140;
}
/* place the transformation in v for subsequent */
/* back multiplication. */
/*< do 130 i = lp1, p >*/
i__2 = *p;
for (i__ = lp1; i__ <= i__2; ++i__) {
/*< v(i,l) = e(i) >*/
i__3 = i__ + l * v_dim1;
i__4 = i__;
v[i__3].r = e[i__4].r, v[i__3].i = e[i__4].i;
/*< 130 continue >*/
/* L130: */
}
/*< 140 continue >*/
L140:
/*< 150 continue >*/
L150:
/*< 160 continue >*/
/* L160: */
;
}
/*< 170 continue >*/
L170:
/* set up the final bidiagonal matrix or order m. */
/*< m = min0(p,n+1) >*/
/* Computing MIN */
i__1 = *p, i__2 = *n + 1;
m = min(i__1,i__2);
/*< nctp1 = nct + 1 >*/
nctp1 = nct + 1;
/*< nrtp1 = nrt + 1 >*/
nrtp1 = nrt + 1;
/*< if (nct .lt. p) s(nctp1) = x(nctp1,nctp1) >*/
if (nct < *p) {
i__1 = nctp1;
i__2 = nctp1 + nctp1 * x_dim1;
s[i__1].r = x[i__2].r, s[i__1].i = x[i__2].i;
}
/*< if (n .lt. m) s(m) = (0.0e0,0.0e0) >*/
if (*n < m) {
i__1 = m;
s[i__1].r = (float)0., s[i__1].i = (float)0.;
}
/*< if (nrtp1 .lt. m) e(nrtp1) = x(nrtp1,m) >*/
if (nrtp1 < m) {
i__1 = nrtp1;
i__2 = nrtp1 + m * x_dim1;
e[i__1].r = x[i__2].r, e[i__1].i = x[i__2].i;
}
/*< e(m) = (0.0e0,0.0e0) >*/
i__1 = m;
e[i__1].r = (float)0., e[i__1].i = (float)0.;
/* if required, generate u. */
/*< if (.not.wantu) go to 300 >*/
if (! wantu) {
goto L300;
}
/*< if (ncu .lt. nctp1) go to 200 >*/
if (ncu < nctp1) {
goto L200;
}
/*< do 190 j = nctp1, ncu >*/
i__1 = ncu;
for (j = nctp1; j <= i__1; ++j) {
/*< do 180 i = 1, n >*/
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/*< u(i,j) = (0.0e0,0.0e0) >*/
i__3 = i__ + j * u_dim1;
u[i__3].r = (float)0., u[i__3].i = (float)0.;
/*< 180 continue >*/
/* L180: */
}
/*< u(j,j) = (1.0e0,0.0e0) >*/
i__2 = j + j * u_dim1;
u[i__2].r = (float)1., u[i__2].i = (float)0.;
/*< 190 continue >*/
/* L190: */
}
/*< 200 continue >*/
L200:
/*< if (nct .lt. 1) go to 290 >*/
if (nct < 1) {
goto L290;
}
/*< do 280 ll = 1, nct >*/
i__1 = nct;
for (ll = 1; ll <= i__1; ++ll) {
/*< l = nct - ll + 1 >*/
l = nct - ll + 1;
/*< if (cabs1(s(l)) .eq. 0.0e0) go to 250 >*/
i__2 = l;
if ((r__1 = s[i__2].r, dabs(r__1)) + (r__2 = r_imag(&s[l]), dabs(r__2)
) == (float)0.) {
goto L250;
}
/*< lp1 = l + 1 >*/
lp1 = l + 1;
/*< if (ncu .lt. lp1) go to 220 >*/
if (ncu < lp1) {
goto L220;
}
/*< do 210 j = lp1, ncu >*/
i__2 = ncu;
for (j = lp1; j <= i__2; ++j) {
/*< t = -cdotc(n-l+1,u(l,l),1,u(l,j),1)/u(l,l) >*/
i__3 = *n - l + 1;
cdotc_(&q__3, &i__3, &u[l + l * u_dim1], &c__1, &u[l + j * u_dim1]
, &c__1);
q__2.r = -q__3.r, q__2.i = -q__3.i;
c_div(&q__1, &q__2, &u[l + l * u_dim1]);
t.r = q__1.r, t.i = q__1.i;
/*< call caxpy(n-l+1,t,u(l,l),1,u(l,j),1) >*/
i__3 = *n - l + 1;
caxpy_(&i__3, &t, &u[l + l * u_dim1], &c__1, &u[l + j * u_dim1], &
c__1);
/*< 210 continue >*/
/* L210: */
}
/*< 220 continue >*/
L220:
/*< call cscal(n-l+1,(-1.0e0,0.0e0),u(l,l),1) >*/
i__2 = *n - l + 1;
cscal_(&i__2, &c_b53, &u[l + l * u_dim1], &c__1);
/*< u(l,l) = (1.0e0,0.0e0) + u(l,l) >*/
i__2 = l + l * u_dim1;
i__3 = l + l * u_dim1;
q__1.r = u[i__3].r + (float)1., q__1.i = u[i__3].i + (float)0.;
u[i__2].r = q__1.r, u[i__2].i = q__1.i;
/*< lm1 = l - 1 >*/
lm1 = l - 1;
/*< if (lm1 .lt. 1) go to 240 >*/
if (lm1 < 1) {
goto L240;
}
/*< do 230 i = 1, lm1 >*/
i__2 = lm1;
for (i__ = 1; i__ <= i__2; ++i__) {
/*< u(i,l) = (0.0e0,0.0e0) >*/
i__3 = i__ + l * u_dim1;
u[i__3].r = (float)0., u[i__3].i = (float)0.;
/*< 230 continue >*/
/* L230: */
}
/*< 240 continue >*/
L240:
/*< go to 270 >*/
goto L270;
/*< 250 continue >*/
L250:
/*< do 260 i = 1, n >*/
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/*< u(i,l) = (0.0e0,0.0e0) >*/
i__3 = i__ + l * u_dim1;
u[i__3].r = (float)0., u[i__3].i = (float)0.;
/*< 260 continue >*/
/* L260: */
}
/*< u(l,l) = (1.0e0,0.0e0) >*/
i__2 = l + l * u_dim1;
u[i__2].r = (float)1., u[i__2].i = (float)0.;
/*< 270 continue >*/
L270:
/*< 280 continue >*/
/* L280: */
;
}
/*< 290 continue >*/
L290:
/*< 300 continue >*/
L300:
/* if it is required, generate v. */
/*< if (.not.wantv) go to 350 >*/
if (! wantv) {
goto L350;
}
/*< do 340 ll = 1, p >*/
i__1 = *p;
for (ll = 1; ll <= i__1; ++ll) {
/*< l = p - ll + 1 >*/
l = *p - ll + 1;
/*< lp1 = l + 1 >*/
lp1 = l + 1;
/*< if (l .gt. nrt) go to 320 >*/
if (l > nrt) {
goto L320;
}
/*< if (cabs1(e(l)) .eq. 0.0e0) go to 320 >*/
i__2 = l;
if ((r__1 = e[i__2].r, dabs(r__1)) + (r__2 = r_imag(&e[l]), dabs(r__2)
) == (float)0.) {
goto L320;
}
/*< do 310 j = lp1, p >*/
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
/*< t = -cdotc(p-l,v(lp1,l),1,v(lp1,j),1)/v(lp1,l) >*/
i__3 = *p - l;
cdotc_(&q__3, &i__3, &v[lp1 + l * v_dim1], &c__1, &v[lp1 + j *
v_dim1], &c__1);
q__2.r = -q__3.r, q__2.i = -q__3.i;
c_div(&q__1, &q__2, &v[lp1 + l * v_dim1]);
t.r = q__1.r, t.i = q__1.i;
/*< call caxpy(p-l,t,v(lp1,l),1,v(lp1,j),1) >*/
i__3 = *p - l;
caxpy_(&i__3, &t, &v[lp1 + l * v_dim1], &c__1, &v[lp1 + j *
v_dim1], &c__1);
/*< 310 continue >*/
/* L310: */
}
/*< 320 continue >*/
L320:
/*< do 330 i = 1, p >*/
i__2 = *p;
for (i__ = 1; i__ <= i__2; ++i__) {
/*< v(i,l) = (0.0e0,0.0e0) >*/
i__3 = i__ + l * v_dim1;
v[i__3].r = (float)0., v[i__3].i = (float)0.;
/*< 330 continue >*/
/* L330: */
}
/*< v(l,l) = (1.0e0,0.0e0) >*/
i__2 = l + l * v_dim1;
v[i__2].r = (float)1., v[i__2].i = (float)0.;
/*< 340 continue >*/
/* L340: */
}
/*< 350 continue >*/
L350:
/* transform s and e so that they are real. */
/*< do 380 i = 1, m >*/
i__1 = m;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< if (cabs1(s(i)) .eq. 0.0e0) go to 360 >*/
i__2 = i__;
if ((r__1 = s[i__2].r, dabs(r__1)) + (r__2 = r_imag(&s[i__]), dabs(
r__2)) == (float)0.) {
goto L360;
}
/*< t = cmplx(cabs(s(i)),0.0e0) >*/
r__1 = c_abs(&s[i__]);
q__1.r = r__1, q__1.i = (float)0.;
t.r = q__1.r, t.i = q__1.i;
/*< r = s(i)/t >*/
c_div(&q__1, &s[i__], &t);
r__.r = q__1.r, r__.i = q__1.i;
/*< s(i) = t >*/
i__2 = i__;
s[i__2].r = t.r, s[i__2].i = t.i;
/*< if (i .lt. m) e(i) = e(i)/r >*/
if (i__ < m) {
i__2 = i__;
c_div(&q__1, &e[i__], &r__);
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
}
/*< if (wantu) call cscal(n,r,u(1,i),1) >*/
if (wantu) {
cscal_(n, &r__, &u[i__ * u_dim1 + 1], &c__1);
}
/*< 360 continue >*/
L360:
/* ...exit */
/*< if (i .eq. m) go to 390 >*/
if (i__ == m) {
goto L390;
}
/*< if (cabs1(e(i)) .eq. 0.0e0) go to 370 >*/
i__2 = i__;
if ((r__1 = e[i__2].r, dabs(r__1)) + (r__2 = r_imag(&e[i__]), dabs(
r__2)) == (float)0.) {
goto L370;
}
/*< t = cmplx(cabs(e(i)),0.0e0) >*/
r__1 = c_abs(&e[i__]);
q__1.r = r__1, q__1.i = (float)0.;
t.r = q__1.r, t.i = q__1.i;
/*< r = t/e(i) >*/
c_div(&q__1, &t, &e[i__]);
r__.r = q__1.r, r__.i = q__1.i;
/*< e(i) = t >*/
i__2 = i__;
e[i__2].r = t.r, e[i__2].i = t.i;
/*< s(i+1) = s(i+1)*r >*/
i__2 = i__ + 1;
i__3 = i__ + 1;
q__1.r = s[i__3].r * r__.r - s[i__3].i * r__.i, q__1.i = s[i__3].r *
r__.i + s[i__3].i * r__.r;
s[i__2].r = q__1.r, s[i__2].i = q__1.i;
/*< if (wantv) call cscal(p,r,v(1,i+1),1) >*/
if (wantv) {
cscal_(p, &r__, &v[(i__ + 1) * v_dim1 + 1], &c__1);
}
/*< 370 continue >*/
L370:
/*< 380 continue >*/
/* L380: */
;
}
/*< 390 continue >*/
L390:
/* main iteration loop for the singular values. */
/*< mm = m >*/
mm = m;
/*< iter = 0 >*/
iter = 0;
/*< 400 continue >*/
L400:
/* quit if all the singular values have been found. */
/* ...exit */
/*< if (m .eq. 0) go to 660 >*/
if (m == 0) {
goto L660;
}
/* if too many iterations have been performed, set */
/* flag and return. */
/*< if (iter .lt. maxit) go to 410 >*/
if (iter < maxit) {
goto L410;
}
/*< info = m >*/
*info = m;
/* ......exit */
/*< go to 660 >*/
goto L660;
/*< 410 continue >*/
L410:
/* this section of the program inspects for */
/* negligible elements in the s and e arrays. on */
/* completion the variables kase and l are set as follows. */
/* kase = 1 if s(m) and e(l-1) are negligible and l.lt.m */
/* kase = 2 if s(l) is negligible and l.lt.m */
/* kase = 3 if e(l-1) is negligible, l.lt.m, and */
/* s(l), ..., s(m) are not negligible (qr step). */
/* kase = 4 if e(m-1) is negligible (convergence). */
/*< do 430 ll = 1, m >*/
i__1 = m;
for (ll = 1; ll <= i__1; ++ll) {
/*< l = m - ll >*/
l = m - ll;
/* ...exit */
/*< if (l .eq. 0) go to 440 >*/
if (l == 0) {
goto L440;
}
/*< test = cabs(s(l)) + cabs(s(l+1)) >*/
test = c_abs(&s[l]) + c_abs(&s[l + 1]);
/*< ztest = test + cabs(e(l)) >*/
ztest = test + c_abs(&e[l]);
/*< if (ztest .ne. test) go to 420 >*/
if (ztest != test) {
goto L420;
}
/*< e(l) = (0.0e0,0.0e0) >*/
i__2 = l;
e[i__2].r = (float)0., e[i__2].i = (float)0.;
/* ......exit */
/*< go to 440 >*/
goto L440;
/*< 420 continue >*/
L420:
/*< 430 continue >*/
/* L430: */
;
}
/*< 440 continue >*/
L440:
/*< if (l .ne. m - 1) go to 450 >*/
if (l != m - 1) {
goto L450;
}
/*< kase = 4 >*/
kase = 4;
/*< go to 520 >*/
goto L520;
/*< 450 continue >*/
L450:
/*< lp1 = l + 1 >*/
lp1 = l + 1;
/*< mp1 = m + 1 >*/
mp1 = m + 1;
/*< do 470 lls = lp1, mp1 >*/
i__1 = mp1;
for (lls = lp1; lls <= i__1; ++lls) {
/*< ls = m - lls + lp1 >*/
ls = m - lls + lp1;
/* ...exit */
/*< if (ls .eq. l) go to 480 >*/
if (ls == l) {
goto L480;
}
/*< test = 0.0e0 >*/
test = (float)0.;
/*< if (ls .ne. m) test = test + cabs(e(ls)) >*/
if (ls != m) {
test += c_abs(&e[ls]);
}
/*< if (ls .ne. l + 1) test = test + cabs(e(ls-1)) >*/
if (ls != l + 1) {
test += c_abs(&e[ls - 1]);
}
/*< ztest = test + cabs(s(ls)) >*/
ztest = test + c_abs(&s[ls]);
/*< if (ztest .ne. test) go to 460 >*/
if (ztest != test) {
goto L460;
}
/*< s(ls) = (0.0e0,0.0e0) >*/
i__2 = ls;
s[i__2].r = (float)0., s[i__2].i = (float)0.;
/* ......exit */
/*< go to 480 >*/
goto L480;
/*< 460 continue >*/
L460:
/*< 470 continue >*/
/* L470: */
;
}
/*< 480 continue >*/
L480:
/*< if (ls .ne. l) go to 490 >*/
if (ls != l) {
goto L490;
}
/*< kase = 3 >*/
kase = 3;
/*< go to 510 >*/
goto L510;
/*< 490 continue >*/
L490:
/*< if (ls .ne. m) go to 500 >*/
if (ls != m) {
goto L500;
}
/*< kase = 1 >*/
kase = 1;
/*< go to 510 >*/
goto L510;
/*< 500 continue >*/
L500:
/*< kase = 2 >*/
kase = 2;
/*< l = ls >*/
l = ls;
/*< 510 continue >*/
L510:
/*< 520 continue >*/
L520:
/*< l = l + 1 >*/
++l;
/* perform the task indicated by kase. */
/*< go to (530, 560, 580, 610), kase >*/
switch (kase) {
case 1: goto L530;
case 2: goto L560;
case 3: goto L580;
case 4: goto L610;
}
/* deflate negligible s(m). */
/*< 530 continue >*/
L530:
/*< mm1 = m - 1 >*/
mm1 = m - 1;
/*< f = real(e(m-1)) >*/
i__1 = m - 1;
f = e[i__1].r;
/*< e(m-1) = (0.0e0,0.0e0) >*/
i__1 = m - 1;
e[i__1].r = (float)0., e[i__1].i = (float)0.;
/*< do 550 kk = l, mm1 >*/
i__1 = mm1;
for (kk = l; kk <= i__1; ++kk) {
/*< k = mm1 - kk + l >*/
k = mm1 - kk + l;
/*< t1 = real(s(k)) >*/
i__2 = k;
t1 = s[i__2].r;
/*< call srotg(t1,f,cs,sn) >*/
srotg_(&t1, &f, &cs, &sn);
/*< s(k) = cmplx(t1,0.0e0) >*/
i__2 = k;
q__1.r = t1, q__1.i = (float)0.;
s[i__2].r = q__1.r, s[i__2].i = q__1.i;
/*< if (k .eq. l) go to 540 >*/
if (k == l) {
goto L540;
}
/*< f = -sn*real(e(k-1)) >*/
i__2 = k - 1;
f = -sn * e[i__2].r;
/*< e(k-1) = cs*e(k-1) >*/
i__2 = k - 1;
i__3 = k - 1;
q__1.r = cs * e[i__3].r, q__1.i = cs * e[i__3].i;
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
/*< 540 continue >*/
L540:
/*< if (wantv) call csrot(p,v(1,k),1,v(1,m),1,cs,sn) >*/
if (wantv) {
csrot_(p, &v[k * v_dim1 + 1], &c__1, &v[m * v_dim1 + 1], &c__1, &
cs, &sn);
}
/*< 550 continue >*/
/* L550: */
}
/*< go to 650 >*/
goto L650;
/* split at negligible s(l). */
/*< 560 continue >*/
L560:
/*< f = real(e(l-1)) >*/
i__1 = l - 1;
f = e[i__1].r;
/*< e(l-1) = (0.0e0,0.0e0) >*/
i__1 = l - 1;
e[i__1].r = (float)0., e[i__1].i = (float)0.;
/*< do 570 k = l, m >*/
i__1 = m;
for (k = l; k <= i__1; ++k) {
/*< t1 = real(s(k)) >*/
i__2 = k;
t1 = s[i__2].r;
/*< call srotg(t1,f,cs,sn) >*/
srotg_(&t1, &f, &cs, &sn);
/*< s(k) = cmplx(t1,0.0e0) >*/
i__2 = k;
q__1.r = t1, q__1.i = (float)0.;
s[i__2].r = q__1.r, s[i__2].i = q__1.i;
/*< f = -sn*real(e(k)) >*/
i__2 = k;
f = -sn * e[i__2].r;
/*< e(k) = cs*e(k) >*/
i__2 = k;
i__3 = k;
q__1.r = cs * e[i__3].r, q__1.i = cs * e[i__3].i;
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
/*< if (wantu) call csrot(n,u(1,k),1,u(1,l-1),1,cs,sn) >*/
if (wantu) {
csrot_(n, &u[k * u_dim1 + 1], &c__1, &u[(l - 1) * u_dim1 + 1], &
c__1, &cs, &sn);
}
/*< 570 continue >*/
/* L570: */
}
/*< go to 650 >*/
goto L650;
/* perform one qr step. */
/*< 580 continue >*/
L580:
/* calculate the shift. */
/*< >*/
/* Computing MAX */
r__1 = c_abs(&s[m]), r__2 = c_abs(&s[m - 1]), r__1 = max(r__1,r__2), r__2
= c_abs(&e[m - 1]), r__1 = max(r__1,r__2), r__2 = c_abs(&s[l]),
r__1 = max(r__1,r__2), r__2 = c_abs(&e[l]);
scale = dmax(r__1,r__2);
/*< sm = real(s(m))/scale >*/
i__1 = m;
sm = s[i__1].r / scale;
/*< smm1 = real(s(m-1))/scale >*/
i__1 = m - 1;
smm1 = s[i__1].r / scale;
/*< emm1 = real(e(m-1))/scale >*/
i__1 = m - 1;
emm1 = e[i__1].r / scale;
/*< sl = real(s(l))/scale >*/
i__1 = l;
sl = s[i__1].r / scale;
/*< el = real(e(l))/scale >*/
i__1 = l;
el = e[i__1].r / scale;
/*< b = ((smm1 + sm)*(smm1 - sm) + emm1**2)/2.0e0 >*/
/* Computing 2nd power */
r__1 = emm1;
b = ((smm1 + sm) * (smm1 - sm) + r__1 * r__1) / (float)2.;
/*< c = (sm*emm1)**2 >*/
/* Computing 2nd power */
r__1 = sm * emm1;
c__ = r__1 * r__1;
/*< shift = 0.0e0 >*/
shift = (float)0.;
/*< if (b .eq. 0.0e0 .and. c .eq. 0.0e0) go to 590 >*/
if (b == (float)0. && c__ == (float)0.) {
goto L590;
}
/*< shift = sqrt(b**2+c) >*/
/* Computing 2nd power */
r__1 = b;
shift = sqrt(r__1 * r__1 + c__);
/*< if (b .lt. 0.0e0) shift = -shift >*/
if (b < (float)0.) {
shift = -shift;
}
/*< shift = c/(b + shift) >*/
shift = c__ / (b + shift);
/*< 590 continue >*/
L590:
/*< f = (sl + sm)*(sl - sm) + shift >*/
f = (sl + sm) * (sl - sm) + shift;
/*< g = sl*el >*/
g = sl * el;
/* chase zeros. */
/*< mm1 = m - 1 >*/
mm1 = m - 1;
/*< do 600 k = l, mm1 >*/
i__1 = mm1;
for (k = l; k <= i__1; ++k) {
/*< call srotg(f,g,cs,sn) >*/
srotg_(&f, &g, &cs, &sn);
/*< if (k .ne. l) e(k-1) = cmplx(f,0.0e0) >*/
if (k != l) {
i__2 = k - 1;
q__1.r = f, q__1.i = (float)0.;
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
}
/*< f = cs*real(s(k)) + sn*real(e(k)) >*/
i__2 = k;
i__3 = k;
f = cs * s[i__2].r + sn * e[i__3].r;
/*< e(k) = cs*e(k) - sn*s(k) >*/
i__2 = k;
i__3 = k;
q__2.r = cs * e[i__3].r, q__2.i = cs * e[i__3].i;
i__4 = k;
q__3.r = sn * s[i__4].r, q__3.i = sn * s[i__4].i;
q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
/*< g = sn*real(s(k+1)) >*/
i__2 = k + 1;
g = sn * s[i__2].r;
/*< s(k+1) = cs*s(k+1) >*/
i__2 = k + 1;
i__3 = k + 1;
q__1.r = cs * s[i__3].r, q__1.i = cs * s[i__3].i;
s[i__2].r = q__1.r, s[i__2].i = q__1.i;
/*< if (wantv) call csrot(p,v(1,k),1,v(1,k+1),1,cs,sn) >*/
if (wantv) {
csrot_(p, &v[k * v_dim1 + 1], &c__1, &v[(k + 1) * v_dim1 + 1], &
c__1, &cs, &sn);
}
/*< call srotg(f,g,cs,sn) >*/
srotg_(&f, &g, &cs, &sn);
/*< s(k) = cmplx(f,0.0e0) >*/
i__2 = k;
q__1.r = f, q__1.i = (float)0.;
s[i__2].r = q__1.r, s[i__2].i = q__1.i;
/*< f = cs*real(e(k)) + sn*real(s(k+1)) >*/
i__2 = k;
i__3 = k + 1;
f = cs * e[i__2].r + sn * s[i__3].r;
/*< s(k+1) = -sn*e(k) + cs*s(k+1) >*/
i__2 = k + 1;
r__1 = -sn;
i__3 = k;
q__2.r = r__1 * e[i__3].r, q__2.i = r__1 * e[i__3].i;
i__4 = k + 1;
q__3.r = cs * s[i__4].r, q__3.i = cs * s[i__4].i;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
s[i__2].r = q__1.r, s[i__2].i = q__1.i;
/*< g = sn*real(e(k+1)) >*/
i__2 = k + 1;
g = sn * e[i__2].r;
/*< e(k+1) = cs*e(k+1) >*/
i__2 = k + 1;
i__3 = k + 1;
q__1.r = cs * e[i__3].r, q__1.i = cs * e[i__3].i;
e[i__2].r = q__1.r, e[i__2].i = q__1.i;
/*< >*/
if (wantu && k < *n) {
csrot_(n, &u[k * u_dim1 + 1], &c__1, &u[(k + 1) * u_dim1 + 1], &
c__1, &cs, &sn);
}
/*< 600 continue >*/
/* L600: */
}
/*< e(m-1) = cmplx(f,0.0e0) >*/
i__1 = m - 1;
q__1.r = f, q__1.i = (float)0.;
e[i__1].r = q__1.r, e[i__1].i = q__1.i;
/*< iter = iter + 1 >*/
++iter;
/*< go to 650 >*/
goto L650;
/* convergence. */
/*< 610 continue >*/
L610:
/* make the singular value positive */
/*< if (real(s(l)) .ge. 0.0e0) go to 620 >*/
i__1 = l;
if (s[i__1].r >= (float)0.) {
goto L620;
}
/*< s(l) = -s(l) >*/
i__1 = l;
i__2 = l;
q__1.r = -s[i__2].r, q__1.i = -s[i__2].i;
s[i__1].r = q__1.r, s[i__1].i = q__1.i;
/*< if (wantv) call cscal(p,(-1.0e0,0.0e0),v(1,l),1) >*/
if (wantv) {
cscal_(p, &c_b53, &v[l * v_dim1 + 1], &c__1);
}
/*< 620 continue >*/
L620:
/* order the singular value. */
/*< 630 if (l .eq. mm) go to 640 >*/
L630:
if (l == mm) {
goto L640;
}
/* ...exit */
/*< if (real(s(l)) .ge. real(s(l+1))) go to 640 >*/
i__1 = l;
i__2 = l + 1;
if (s[i__1].r >= s[i__2].r) {
goto L640;
}
/*< t = s(l) >*/
i__1 = l;
t.r = s[i__1].r, t.i = s[i__1].i;
/*< s(l) = s(l+1) >*/
i__1 = l;
i__2 = l + 1;
s[i__1].r = s[i__2].r, s[i__1].i = s[i__2].i;
/*< s(l+1) = t >*/
i__1 = l + 1;
s[i__1].r = t.r, s[i__1].i = t.i;
/*< >*/
if (wantv && l < *p) {
cswap_(p, &v[l * v_dim1 + 1], &c__1, &v[(l + 1) * v_dim1 + 1], &c__1);
}
/*< >*/
if (wantu && l < *n) {
cswap_(n, &u[l * u_dim1 + 1], &c__1, &u[(l + 1) * u_dim1 + 1], &c__1);
}
/*< l = l + 1 >*/
++l;
/*< go to 630 >*/
goto L630;
/*< 640 continue >*/
L640:
/*< iter = 0 >*/
iter = 0;
/*< m = m - 1 >*/
--m;
/*< 650 continue >*/
L650:
/*< go to 400 >*/
goto L400;
/*< 660 continue >*/
L660:
/*< return >*/
return 0;
/*< end >*/
} /* csvdc_ */
/** CHETRF_ROOK_REC2 computes a partial factorization of a complex Hermitian indefinite matrix using the boun ded Bunch-Kaufman ("rook") diagonal pivoting method
*
* This routine is a minor modification of LAPACK's clahef_rook.
* It serves as an unblocked kernel in the recursive algorithms.
* The blocked BLAS Level 3 updates were removed and moved to the
* recursive algorithm.
* */
/* Subroutine */ void RELAPACK_chetrf_rook_rec2(char *uplo, int *n,
int *nb, int *kb, complex *a, int *lda, int *ipiv,
complex *w, int *ldw, int *info, ftnlen uplo_len)
{
/* System generated locals */
int a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4;
float r__1, r__2;
complex q__1, q__2, q__3, q__4, q__5;
/* Builtin functions */
double sqrt(double), r_imag(complex *);
void r_cnjg(complex *, complex *), c_div(complex *, complex *, complex *);
/* Local variables */
static int j, k, p;
static float t, r1;
static complex d11, d21, d22;
static int ii, jj, kk, kp, kw, jp1, jp2, kkw;
static logical done;
static int imax, jmax;
static float alpha;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int cgemv_(char *, int *, int *, complex *
, complex *, int *, complex *, int *, complex *, complex *
, int *, ftnlen);
static float sfmin;
extern /* Subroutine */ int ccopy_(int *, complex *, int *,
complex *, int *);
static int itemp;
extern /* Subroutine */ int cswap_(int *, complex *, int *,
complex *, int *);
static int kstep;
static float stemp, absakk;
extern /* Subroutine */ int clacgv_(int *, complex *, int *);
extern int icamax_(int *, complex *, int *);
extern double slamch_(char *, ftnlen);
extern /* Subroutine */ int csscal_(int *, float *, complex *, int
*);
static float colmax, rowmax;
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
w_dim1 = *ldw;
w_offset = 1 + w_dim1;
w -= w_offset;
/* Function Body */
*info = 0;
alpha = (sqrt(17.f) + 1.f) / 8.f;
sfmin = slamch_("S", (ftnlen)1);
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
k = *n;
L10:
kw = *nb + k - *n;
if ((k <= *n - *nb + 1 && *nb < *n) || k < 1) {
goto L30;
}
kstep = 1;
p = k;
if (k > 1) {
i__1 = k - 1;
ccopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &
c__1);
}
i__1 = k + kw * w_dim1;
i__2 = k + k * a_dim1;
r__1 = a[i__2].r;
w[i__1].r = r__1, w[i__1].i = 0.f;
if (k < *n) {
i__1 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &k, &i__1, &q__1, &a[(k + 1) * a_dim1 + 1],
lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b1, &w[kw *
w_dim1 + 1], &c__1, (ftnlen)12);
i__1 = k + kw * w_dim1;
i__2 = k + kw * w_dim1;
r__1 = w[i__2].r;
w[i__1].r = r__1, w[i__1].i = 0.f;
}
i__1 = k + kw * w_dim1;
absakk = (r__1 = w[i__1].r, dabs(r__1));
if (k > 1) {
i__1 = k - 1;
imax = icamax_(&i__1, &w[kw * w_dim1 + 1], &c__1);
i__1 = imax + kw * w_dim1;
colmax = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[imax
+ kw * w_dim1]), dabs(r__2));
} else {
colmax = 0.f;
}
if (dmax(absakk,colmax) == 0.f) {
if (*info == 0) {
*info = k;
}
kp = k;
i__1 = k + k * a_dim1;
i__2 = k + kw * w_dim1;
r__1 = w[i__2].r;
a[i__1].r = r__1, a[i__1].i = 0.f;
if (k > 1) {
i__1 = k - 1;
ccopy_(&i__1, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1],
&c__1);
}
} else {
if (! (absakk < alpha * colmax)) {
kp = k;
} else {
done = FALSE_;
L12:
if (imax > 1) {
i__1 = imax - 1;
ccopy_(&i__1, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) *
w_dim1 + 1], &c__1);
}
i__1 = imax + (kw - 1) * w_dim1;
i__2 = imax + imax * a_dim1;
r__1 = a[i__2].r;
w[i__1].r = r__1, w[i__1].i = 0.f;
i__1 = k - imax;
ccopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax +
1 + (kw - 1) * w_dim1], &c__1);
i__1 = k - imax;
clacgv_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1], &c__1);
if (k < *n) {
i__1 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &k, &i__1, &q__1, &a[(k + 1) *
a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1],
ldw, &c_b1, &w[(kw - 1) * w_dim1 + 1], &c__1, (
ftnlen)12);
i__1 = imax + (kw - 1) * w_dim1;
i__2 = imax + (kw - 1) * w_dim1;
r__1 = w[i__2].r;
w[i__1].r = r__1, w[i__1].i = 0.f;
}
if (imax != k) {
i__1 = k - imax;
jmax = imax + icamax_(&i__1, &w[imax + 1 + (kw - 1) *
w_dim1], &c__1);
i__1 = jmax + (kw - 1) * w_dim1;
rowmax = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&
w[jmax + (kw - 1) * w_dim1]), dabs(r__2));
} else {
rowmax = 0.f;
}
if (imax > 1) {
i__1 = imax - 1;
itemp = icamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1);
i__1 = itemp + (kw - 1) * w_dim1;
stemp = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&
w[itemp + (kw - 1) * w_dim1]), dabs(r__2));
if (stemp > rowmax) {
rowmax = stemp;
jmax = itemp;
}
}
i__1 = imax + (kw - 1) * w_dim1;
if (! ((r__1 = w[i__1].r, dabs(r__1)) < alpha * rowmax)) {
kp = imax;
ccopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw *
w_dim1 + 1], &c__1);
done = TRUE_;
} else if (p == jmax || rowmax <= colmax) {
kp = imax;
kstep = 2;
done = TRUE_;
} else {
p = imax;
colmax = rowmax;
imax = jmax;
ccopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw *
w_dim1 + 1], &c__1);
}
if (! done) {
goto L12;
}
}
kk = k - kstep + 1;
kkw = *nb + kk - *n;
if (kstep == 2 && p != k) {
i__1 = p + p * a_dim1;
i__2 = k + k * a_dim1;
r__1 = a[i__2].r;
a[i__1].r = r__1, a[i__1].i = 0.f;
i__1 = k - 1 - p;
ccopy_(&i__1, &a[p + 1 + k * a_dim1], &c__1, &a[p + (p + 1) *
a_dim1], lda);
i__1 = k - 1 - p;
clacgv_(&i__1, &a[p + (p + 1) * a_dim1], lda);
if (p > 1) {
i__1 = p - 1;
ccopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[p * a_dim1 +
1], &c__1);
}
if (k < *n) {
i__1 = *n - k;
cswap_(&i__1, &a[k + (k + 1) * a_dim1], lda, &a[p + (k +
1) * a_dim1], lda);
}
i__1 = *n - kk + 1;
cswap_(&i__1, &w[k + kkw * w_dim1], ldw, &w[p + kkw * w_dim1],
ldw);
}
if (kp != kk) {
i__1 = kp + kp * a_dim1;
i__2 = kk + kk * a_dim1;
r__1 = a[i__2].r;
a[i__1].r = r__1, a[i__1].i = 0.f;
i__1 = kk - 1 - kp;
ccopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp +
1) * a_dim1], lda);
i__1 = kk - 1 - kp;
clacgv_(&i__1, &a[kp + (kp + 1) * a_dim1], lda);
if (kp > 1) {
i__1 = kp - 1;
ccopy_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1
+ 1], &c__1);
}
if (k < *n) {
i__1 = *n - k;
cswap_(&i__1, &a[kk + (k + 1) * a_dim1], lda, &a[kp + (k
+ 1) * a_dim1], lda);
}
i__1 = *n - kk + 1;
cswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw *
w_dim1], ldw);
}
if (kstep == 1) {
ccopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &
c__1);
if (k > 1) {
i__1 = k + k * a_dim1;
t = a[i__1].r;
if (dabs(t) >= sfmin) {
r1 = 1.f / t;
i__1 = k - 1;
csscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1);
} else {
i__1 = k - 1;
for (ii = 1; ii <= i__1; ++ii) {
i__2 = ii + k * a_dim1;
i__3 = ii + k * a_dim1;
q__1.r = a[i__3].r / t, q__1.i = a[i__3].i / t;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
/* L14: */
}
}
i__1 = k - 1;
clacgv_(&i__1, &w[kw * w_dim1 + 1], &c__1);
}
} else {
if (k > 2) {
i__1 = k - 1 + kw * w_dim1;
d21.r = w[i__1].r, d21.i = w[i__1].i;
r_cnjg(&q__2, &d21);
c_div(&q__1, &w[k + kw * w_dim1], &q__2);
d11.r = q__1.r, d11.i = q__1.i;
c_div(&q__1, &w[k - 1 + (kw - 1) * w_dim1], &d21);
d22.r = q__1.r, d22.i = q__1.i;
q__1.r = d11.r * d22.r - d11.i * d22.i, q__1.i = d11.r *
d22.i + d11.i * d22.r;
t = 1.f / (q__1.r - 1.f);
i__1 = k - 2;
for (j = 1; j <= i__1; ++j) {
i__2 = j + (k - 1) * a_dim1;
i__3 = j + (kw - 1) * w_dim1;
q__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i,
q__4.i = d11.r * w[i__3].i + d11.i * w[i__3]
.r;
i__4 = j + kw * w_dim1;
q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4]
.i;
c_div(&q__2, &q__3, &d21);
q__1.r = t * q__2.r, q__1.i = t * q__2.i;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
i__2 = j + k * a_dim1;
i__3 = j + kw * w_dim1;
q__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i,
q__4.i = d22.r * w[i__3].i + d22.i * w[i__3]
.r;
i__4 = j + (kw - 1) * w_dim1;
q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4]
.i;
r_cnjg(&q__5, &d21);
c_div(&q__2, &q__3, &q__5);
q__1.r = t * q__2.r, q__1.i = t * q__2.i;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
/* L20: */
}
}
i__1 = k - 1 + (k - 1) * a_dim1;
i__2 = k - 1 + (kw - 1) * w_dim1;
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = k - 1 + k * a_dim1;
i__2 = k - 1 + kw * w_dim1;
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = k + k * a_dim1;
i__2 = k + kw * w_dim1;
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = k - 1;
clacgv_(&i__1, &w[kw * w_dim1 + 1], &c__1);
i__1 = k - 2;
clacgv_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1);
}
}
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -p;
ipiv[k - 1] = -kp;
}
k -= kstep;
goto L10;
L30:
j = k + 1;
L60:
kstep = 1;
jp1 = 1;
jj = j;
jp2 = ipiv[j];
if (jp2 < 0) {
jp2 = -jp2;
++j;
jp1 = -ipiv[j];
kstep = 2;
}
++j;
if (jp2 != jj && j <= *n) {
i__1 = *n - j + 1;
cswap_(&i__1, &a[jp2 + j * a_dim1], lda, &a[jj + j * a_dim1], lda)
;
}
++jj;
if (kstep == 2 && jp1 != jj && j <= *n) {
i__1 = *n - j + 1;
cswap_(&i__1, &a[jp1 + j * a_dim1], lda, &a[jj + j * a_dim1], lda)
;
}
if (j < *n) {
goto L60;
}
*kb = *n - k;
} else {
k = 1;
L70:
if ((k >= *nb && *nb < *n) || k > *n) {
goto L90;
}
kstep = 1;
p = k;
i__1 = k + k * w_dim1;
i__2 = k + k * a_dim1;
r__1 = a[i__2].r;
w[i__1].r = r__1, w[i__1].i = 0.f;
if (k < *n) {
i__1 = *n - k;
ccopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &w[k + 1 + k *
w_dim1], &c__1);
}
if (k > 1) {
i__1 = *n - k + 1;
i__2 = k - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &i__1, &i__2, &q__1, &a[k + a_dim1], lda, &
w[k + w_dim1], ldw, &c_b1, &w[k + k * w_dim1], &c__1, (
ftnlen)12);
i__1 = k + k * w_dim1;
i__2 = k + k * w_dim1;
r__1 = w[i__2].r;
w[i__1].r = r__1, w[i__1].i = 0.f;
}
i__1 = k + k * w_dim1;
absakk = (r__1 = w[i__1].r, dabs(r__1));
if (k < *n) {
i__1 = *n - k;
imax = k + icamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1);
i__1 = imax + k * w_dim1;
colmax = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[imax
+ k * w_dim1]), dabs(r__2));
} else {
colmax = 0.f;
}
if (dmax(absakk,colmax) == 0.f) {
if (*info == 0) {
*info = k;
}
kp = k;
i__1 = k + k * a_dim1;
i__2 = k + k * w_dim1;
r__1 = w[i__2].r;
a[i__1].r = r__1, a[i__1].i = 0.f;
if (k < *n) {
i__1 = *n - k;
ccopy_(&i__1, &w[k + 1 + k * w_dim1], &c__1, &a[k + 1 + k *
a_dim1], &c__1);
}
} else {
if (! (absakk < alpha * colmax)) {
kp = k;
} else {
done = FALSE_;
L72:
i__1 = imax - k;
ccopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) *
w_dim1], &c__1);
i__1 = imax - k;
clacgv_(&i__1, &w[k + (k + 1) * w_dim1], &c__1);
i__1 = imax + (k + 1) * w_dim1;
i__2 = imax + imax * a_dim1;
r__1 = a[i__2].r;
w[i__1].r = r__1, w[i__1].i = 0.f;
if (imax < *n) {
i__1 = *n - imax;
ccopy_(&i__1, &a[imax + 1 + imax * a_dim1], &c__1, &w[
imax + 1 + (k + 1) * w_dim1], &c__1);
}
if (k > 1) {
i__1 = *n - k + 1;
i__2 = k - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &i__1, &i__2, &q__1, &a[k + a_dim1]
, lda, &w[imax + w_dim1], ldw, &c_b1, &w[k + (k +
1) * w_dim1], &c__1, (ftnlen)12);
i__1 = imax + (k + 1) * w_dim1;
i__2 = imax + (k + 1) * w_dim1;
r__1 = w[i__2].r;
w[i__1].r = r__1, w[i__1].i = 0.f;
}
if (imax != k) {
i__1 = imax - k;
jmax = k - 1 + icamax_(&i__1, &w[k + (k + 1) * w_dim1], &
c__1);
i__1 = jmax + (k + 1) * w_dim1;
rowmax = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&
w[jmax + (k + 1) * w_dim1]), dabs(r__2));
} else {
rowmax = 0.f;
}
if (imax < *n) {
i__1 = *n - imax;
itemp = imax + icamax_(&i__1, &w[imax + 1 + (k + 1) *
w_dim1], &c__1);
i__1 = itemp + (k + 1) * w_dim1;
stemp = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&
w[itemp + (k + 1) * w_dim1]), dabs(r__2));
if (stemp > rowmax) {
rowmax = stemp;
jmax = itemp;
}
}
i__1 = imax + (k + 1) * w_dim1;
if (! ((r__1 = w[i__1].r, dabs(r__1)) < alpha * rowmax)) {
kp = imax;
i__1 = *n - k + 1;
ccopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k *
w_dim1], &c__1);
done = TRUE_;
} else if (p == jmax || rowmax <= colmax) {
kp = imax;
kstep = 2;
done = TRUE_;
} else {
p = imax;
colmax = rowmax;
imax = jmax;
i__1 = *n - k + 1;
ccopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k *
w_dim1], &c__1);
}
if (! done) {
goto L72;
}
}
kk = k + kstep - 1;
if (kstep == 2 && p != k) {
i__1 = p + p * a_dim1;
i__2 = k + k * a_dim1;
r__1 = a[i__2].r;
a[i__1].r = r__1, a[i__1].i = 0.f;
i__1 = p - k - 1;
ccopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[p + (k + 1) *
a_dim1], lda);
i__1 = p - k - 1;
clacgv_(&i__1, &a[p + (k + 1) * a_dim1], lda);
if (p < *n) {
i__1 = *n - p;
ccopy_(&i__1, &a[p + 1 + k * a_dim1], &c__1, &a[p + 1 + p
* a_dim1], &c__1);
}
if (k > 1) {
i__1 = k - 1;
cswap_(&i__1, &a[k + a_dim1], lda, &a[p + a_dim1], lda);
}
cswap_(&kk, &w[k + w_dim1], ldw, &w[p + w_dim1], ldw);
}
if (kp != kk) {
i__1 = kp + kp * a_dim1;
i__2 = kk + kk * a_dim1;
r__1 = a[i__2].r;
a[i__1].r = r__1, a[i__1].i = 0.f;
i__1 = kp - kk - 1;
ccopy_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk +
1) * a_dim1], lda);
i__1 = kp - kk - 1;
clacgv_(&i__1, &a[kp + (kk + 1) * a_dim1], lda);
if (kp < *n) {
i__1 = *n - kp;
ccopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1
+ kp * a_dim1], &c__1);
}
if (k > 1) {
i__1 = k - 1;
cswap_(&i__1, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda);
}
cswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw);
}
if (kstep == 1) {
i__1 = *n - k + 1;
ccopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], &
c__1);
if (k < *n) {
i__1 = k + k * a_dim1;
t = a[i__1].r;
if (dabs(t) >= sfmin) {
r1 = 1.f / t;
i__1 = *n - k;
csscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1);
} else {
i__1 = *n;
for (ii = k + 1; ii <= i__1; ++ii) {
i__2 = ii + k * a_dim1;
i__3 = ii + k * a_dim1;
q__1.r = a[i__3].r / t, q__1.i = a[i__3].i / t;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
/* L74: */
}
}
i__1 = *n - k;
clacgv_(&i__1, &w[k + 1 + k * w_dim1], &c__1);
}
} else {
if (k < *n - 1) {
i__1 = k + 1 + k * w_dim1;
d21.r = w[i__1].r, d21.i = w[i__1].i;
c_div(&q__1, &w[k + 1 + (k + 1) * w_dim1], &d21);
d11.r = q__1.r, d11.i = q__1.i;
r_cnjg(&q__2, &d21);
c_div(&q__1, &w[k + k * w_dim1], &q__2);
d22.r = q__1.r, d22.i = q__1.i;
q__1.r = d11.r * d22.r - d11.i * d22.i, q__1.i = d11.r *
d22.i + d11.i * d22.r;
t = 1.f / (q__1.r - 1.f);
i__1 = *n;
for (j = k + 2; j <= i__1; ++j) {
i__2 = j + k * a_dim1;
i__3 = j + k * w_dim1;
q__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i,
q__4.i = d11.r * w[i__3].i + d11.i * w[i__3]
.r;
i__4 = j + (k + 1) * w_dim1;
q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4]
.i;
r_cnjg(&q__5, &d21);
c_div(&q__2, &q__3, &q__5);
q__1.r = t * q__2.r, q__1.i = t * q__2.i;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
i__2 = j + (k + 1) * a_dim1;
i__3 = j + (k + 1) * w_dim1;
q__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i,
q__4.i = d22.r * w[i__3].i + d22.i * w[i__3]
.r;
i__4 = j + k * w_dim1;
q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4]
.i;
c_div(&q__2, &q__3, &d21);
q__1.r = t * q__2.r, q__1.i = t * q__2.i;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
/* L80: */
}
}
i__1 = k + k * a_dim1;
i__2 = k + k * w_dim1;
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = k + 1 + k * a_dim1;
i__2 = k + 1 + k * w_dim1;
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = k + 1 + (k + 1) * a_dim1;
i__2 = k + 1 + (k + 1) * w_dim1;
a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
i__1 = *n - k;
clacgv_(&i__1, &w[k + 1 + k * w_dim1], &c__1);
i__1 = *n - k - 1;
clacgv_(&i__1, &w[k + 2 + (k + 1) * w_dim1], &c__1);
}
}
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -p;
ipiv[k + 1] = -kp;
}
k += kstep;
goto L70;
L90:
j = k - 1;
L120:
kstep = 1;
jp1 = 1;
jj = j;
jp2 = ipiv[j];
if (jp2 < 0) {
jp2 = -jp2;
--j;
jp1 = -ipiv[j];
kstep = 2;
}
--j;
if (jp2 != jj && j >= 1) {
cswap_(&j, &a[jp2 + a_dim1], lda, &a[jj + a_dim1], lda);
}
--jj;
if (kstep == 2 && jp1 != jj && j >= 1) {
cswap_(&j, &a[jp1 + a_dim1], lda, &a[jj + a_dim1], lda);
}
if (j > 1) {
goto L120;
}
*kb = k - 1;
}
return;
}
static int polroot(
struct polynom *p,
struct complex *pz, /* pointer to root */
struct complex *pz0 /* pointer to initial value */
)
{
int i;
int n_iter;
struct polynom d;
struct complex v,v0,vd,delta,zmin;
double y,ymin;
// extern struct polynom *pol_der();
// extern struct complex *pol_value();
delta.x=0; delta.y=0; // RS 7.2.2013
//printf("\np->n=%d",p->n); getch();
if (p->n==1)
{
c_div(pz,&(p->a[0]),&(p->a[1]));
pz->x=-(pz->x); pz->y=-(pz->y);
return(1);
}
//printf("\nr2");
pol_value(p,pz0,&v0);
//printf("\nr3");
if (c_zero(&v0))
{
pz->x=pz0->x;
pz->y=pz0->y;
return(1);
}
//printf("\nr4");
zmin.x=pz0->x; zmin.y=pz0->y;
ymin=v0.x*v0.x+v0.y*v0.y;
pol_der(&d,p);
//printf("\nr5");
n_iter=0;
while (1)
{
pol_value(&d,pz0,&vd);
c_div(&delta,&v0,&vd);
c_sub(pz,pz0,&delta);
pol_value(p,pz,&v);
v0.x=v.x; v0.y=v.y;
pz0->x=pz->x; pz0->y=pz->y;
++n_iter;
PR_UP;
sprintf(sbuf,"\npolroot: N=%d Re=%e Im=%e",n_iter,pz->x,pz->y); sur_print(sbuf); // RS CHA Rprintf
/* Rprintf("zero: %d\n",c_zero(pz)); getch(); */
/* if (c_zero(&pz)) break; */
if (c_zero(pz)) break;
y=v.x*v.x+v.y*v.y;
if (y<ymin)
{ ymin=y; zmin.x=pz->x; zmin.y=pz->y; }
if (fabs(delta.x)<roots_eps && fabs(delta.y)<roots_eps) break;
if (n_iter>roots_max_iter)
{
pz->x=zmin.x; pz->y=zmin.y;
break;
}
if (sur_kbhit())
{
pz->x=zmin.x; pz->y=zmin.y;
i=sur_getch(); if (i=='.') break;
}
}
return (n_iter);
}
/* Subroutine */ int clarge_(integer *n, complex *a, integer *lda, integer *
iseed, complex *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1;
real r__1;
complex q__1;
/* Builtin functions */
double c_abs(complex *);
void c_div(complex *, complex *, complex *);
/* Local variables */
static integer i__;
extern /* Subroutine */ int cgerc_(integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *),
cscal_(integer *, complex *, complex *, integer *), cgemv_(char *
, integer *, integer *, complex *, complex *, integer *, complex *
, integer *, complex *, complex *, integer *);
extern doublereal scnrm2_(integer *, complex *, integer *);
static complex wa, wb;
static real wn;
extern /* Subroutine */ int xerbla_(char *, integer *), clarnv_(
integer *, integer *, integer *, complex *);
static complex tau;
#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)]
/* -- LAPACK auxiliary test 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
=======
CLARGE pre- and post-multiplies a complex general n by n matrix A
with a random unitary matrix: A = U*D*U'.
Arguments
=========
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) COMPLEX array, dimension (LDA,N)
On entry, the original n by n matrix A.
On exit, A is overwritten by U*A*U' for some random
unitary matrix U.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= N.
ISEED (input/output) INTEGER array, dimension (4)
On entry, the seed of the random number generator; the array
elements must be between 0 and 4095, and ISEED(4) must be
odd.
On exit, the seed is updated.
WORK (workspace) COMPLEX array, dimension (2*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input arguments
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--iseed;
--work;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*lda < max(1,*n)) {
*info = -3;
}
if (*info < 0) {
i__1 = -(*info);
xerbla_("CLARGE", &i__1);
return 0;
}
/* pre- and post-multiply A by random unitary matrix */
for (i__ = *n; i__ >= 1; --i__) {
/* generate random reflection */
i__1 = *n - i__ + 1;
clarnv_(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *n - i__ + 1;
wn = scnrm2_(&i__1, &work[1], &c__1);
r__1 = wn / c_abs(&work[1]);
q__1.r = r__1 * work[1].r, q__1.i = r__1 * work[1].i;
wa.r = q__1.r, wa.i = q__1.i;
if (wn == 0.f) {
tau.r = 0.f, tau.i = 0.f;
} else {
q__1.r = work[1].r + wa.r, q__1.i = work[1].i + wa.i;
wb.r = q__1.r, wb.i = q__1.i;
i__1 = *n - i__;
c_div(&q__1, &c_b2, &wb);
cscal_(&i__1, &q__1, &work[2], &c__1);
work[1].r = 1.f, work[1].i = 0.f;
c_div(&q__1, &wb, &wa);
r__1 = q__1.r;
tau.r = r__1, tau.i = 0.f;
}
/* multiply A(i:n,1:n) by random reflection from the left */
i__1 = *n - i__ + 1;
cgemv_("Conjugate transpose", &i__1, n, &c_b2, &a_ref(i__, 1), lda, &
work[1], &c__1, &c_b1, &work[*n + 1], &c__1);
i__1 = *n - i__ + 1;
q__1.r = -tau.r, q__1.i = -tau.i;
cgerc_(&i__1, n, &q__1, &work[1], &c__1, &work[*n + 1], &c__1, &a_ref(
i__, 1), lda);
/* multiply A(1:n,i:n) by random reflection from the right */
i__1 = *n - i__ + 1;
cgemv_("No transpose", n, &i__1, &c_b2, &a_ref(1, i__), lda, &work[1],
&c__1, &c_b1, &work[*n + 1], &c__1);
i__1 = *n - i__ + 1;
q__1.r = -tau.r, q__1.i = -tau.i;
cgerc_(n, &i__1, &q__1, &work[*n + 1], &c__1, &work[1], &c__1, &a_ref(
1, i__), lda);
/* L10: */
}
return 0;
/* End of CLARGE */
} /* clarge_ */
/* Subroutine */ int cebchvxx_(real *thresh, char *path)
{
/* Format strings */
static char fmt_8000[] = "(\002 C\002,a2,\002SVXX: N =\002,i2,\002, INFO"
" = \002,i3,\002, ORCOND = \002,g12.5,\002, real RCOND = \002,g12"
".5)";
static char fmt_9996[] = "(3x,i2,\002: Normwise guaranteed forward erro"
"r\002,/5x,\002Guaranteed case: if norm ( abs( Xc - Xt )\002,\002"
" / norm ( Xt ) .LE. ERRBND( *, nwise_i, bnd_i ), then\002,/5x"
",\002ERRBND( *, nwise_i, bnd_i ) .LE. MAX(SQRT(N), 10) * EPS\002)"
;
static char fmt_9995[] = "(3x,i2,\002: Componentwise guaranteed forward "
"error\002)";
static char fmt_9994[] = "(3x,i2,\002: Backwards error\002)";
static char fmt_9993[] = "(3x,i2,\002: Reciprocal condition number\002)";
static char fmt_9992[] = "(3x,i2,\002: Reciprocal normwise condition num"
"ber\002)";
static char fmt_9991[] = "(3x,i2,\002: Raw normwise error estimate\002)";
static char fmt_9990[] = "(3x,i2,\002: Reciprocal componentwise conditio"
"n number\002)";
static char fmt_9989[] = "(3x,i2,\002: Raw componentwise error estimat"
"e\002)";
static char fmt_9999[] = "(\002 C\002,a2,\002SVXX: N =\002,i2,\002, RHS "
"= \002,i2,\002, NWISE GUAR. = \002,a,\002, CWISE GUAR. = \002,a"
",\002 test(\002,i1,\002) =\002,g12.5)";
static char fmt_9998[] = "(\002 C\002,a2,\002SVXX: \002,i6,\002 out of"
" \002,i6,\002 tests failed to pass the threshold\002)";
static char fmt_9997[] = "(\002 C\002,a2,\002SVXX passed the tests of er"
"ror bounds\002)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5, i__6;
real r__1, r__2, r__3, r__4, r__5;
complex q__1, q__2, q__3;
/* Local variables */
real errbnd_c__[18], errbnd_n__[18];
complex a[36] /* was [6][6] */, b[36] /* was [6][6] */;
real c__[6];
integer i__, j, k;
real m;
integer n;
real r__[6], s[6];
complex x[36] /* was [6][6] */;
real cwise_bnd__;
char c2[2];
real nwise_bnd__, cwise_err__, nwise_err__, errthresh;
complex ab[66] /* was [11][6] */, af[36] /* was [6][6] */;
integer kl, ku;
real condthresh;
complex afb[96] /* was [16][6] */;
integer lda;
real eps, cwise_rcond__, nwise_rcond__;
integer n_aux_tests__, ldab;
real diff[36] /* was [6][6] */;
char fact[1];
real berr[6];
integer info, ipiv[6], nrhs;
real rinv[6];
char uplo[1];
complex work[90];
real sumr;
integer ldafb;
real ccond;
integer nfail;
char cguar[3];
real ncond;
char equed[1];
real rcond;
complex acopy[36] /* was [6][6] */;
char nguar[3], trans[1];
real rnorm, normt, sumri, rwork[18];
logical printed_guide__;
complex abcopy[66] /* was [11][6] */;
real params[2], orcond, rinorm, tstrat[6], rpvgrw;
complex invhilb[36] /* was [6][6] */;
real normdif;
/* Fortran I/O blocks */
static cilist io___42 = { 0, 6, 0, fmt_8000, 0 };
static cilist io___66 = { 0, 6, 0, 0, 0 };
static cilist io___67 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___68 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___69 = { 0, 6, 0, fmt_9994, 0 };
static cilist io___70 = { 0, 6, 0, fmt_9993, 0 };
static cilist io___71 = { 0, 6, 0, fmt_9992, 0 };
static cilist io___72 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___73 = { 0, 6, 0, fmt_9990, 0 };
static cilist io___74 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___75 = { 0, 6, 0, 0, 0 };
static cilist io___76 = { 0, 6, 0, fmt_9999, 0 };
static cilist io___77 = { 0, 6, 0, 0, 0 };
static cilist io___78 = { 0, 6, 0, fmt_9998, 0 };
static cilist io___79 = { 0, 6, 0, fmt_9997, 0 };
/* .. Scalar Arguments .. */
/* Purpose */
/* ====== */
/* CEBCHVXX will run CGESVXX on a series of Hilbert matrices and then */
/* compare the error bounds returned by CGESVXX to see if the returned */
/* answer indeed falls within those bounds. */
/* Eight test ratios will be computed. The tests will pass if they are .LT. */
/* THRESH. There are two cases that are determined by 1 / (SQRT( N ) * EPS). */
/* If that value is .LE. to the component wise reciprocal condition number, */
/* it uses the guaranteed case, other wise it uses the unguaranteed case. */
/* Test ratios: */
/* Let Xc be X_computed and Xt be X_truth. */
/* The norm used is the infinity norm. */
/* Let A be the guaranteed case and B be the unguaranteed case. */
/* 1. Normwise guaranteed forward error bound. */
/* A: norm ( abs( Xc - Xt ) / norm ( Xt ) .LE. ERRBND( *, nwise_i, bnd_i ) and */
/* ERRBND( *, nwise_i, bnd_i ) .LE. MAX(SQRT(N),10) * EPS. */
/* If these conditions are met, the test ratio is set to be */
/* ERRBND( *, nwise_i, bnd_i ) / MAX(SQRT(N), 10). Otherwise it is 1/EPS. */
/* B: For this case, CGESVXX should just return 1. If it is less than */
/* one, treat it the same as in 1A. Otherwise it fails. (Set test */
/* ratio to ERRBND( *, nwise_i, bnd_i ) * THRESH?) */
/* 2. Componentwise guaranteed forward error bound. */
/* A: norm ( abs( Xc(j) - Xt(j) ) ) / norm (Xt(j)) .LE. ERRBND( *, cwise_i, bnd_i ) */
/* for all j .AND. ERRBND( *, cwise_i, bnd_i ) .LE. MAX(SQRT(N), 10) * EPS. */
/* If these conditions are met, the test ratio is set to be */
/* ERRBND( *, cwise_i, bnd_i ) / MAX(SQRT(N), 10). Otherwise it is 1/EPS. */
/* B: Same as normwise test ratio. */
/* 3. Backwards error. */
/* A: The test ratio is set to BERR/EPS. */
/* B: Same test ratio. */
/* 4. Reciprocal condition number. */
/* A: A condition number is computed with Xt and compared with the one */
/* returned from CGESVXX. Let RCONDc be the RCOND returned by CGESVXX */
/* and RCONDt be the RCOND from the truth value. Test ratio is set to */
/* MAX(RCONDc/RCONDt, RCONDt/RCONDc). */
/* B: Test ratio is set to 1 / (EPS * RCONDc). */
/* 5. Reciprocal normwise condition number. */
/* A: The test ratio is set to */
/* MAX(ERRBND( *, nwise_i, cond_i ) / NCOND, NCOND / ERRBND( *, nwise_i, cond_i )). */
/* B: Test ratio is set to 1 / (EPS * ERRBND( *, nwise_i, cond_i )). */
/* 6. Reciprocal componentwise condition number. */
/* A: Test ratio is set to */
/* MAX(ERRBND( *, cwise_i, cond_i ) / CCOND, CCOND / ERRBND( *, cwise_i, cond_i )). */
/* B: Test ratio is set to 1 / (EPS * ERRBND( *, cwise_i, cond_i )). */
/* .. Parameters .. */
/* NMAX is determined by the largest number in the inverse of the hilbert */
/* matrix. Precision is exhausted when the largest entry in it is greater */
/* than 2 to the power of the number of bits in the fraction of the data */
/* type used plus one, which is 24 for single precision. */
/* NMAX should be 6 for single and 11 for double. */
/* .. Local Scalars .. */
/* .. Local Arrays .. */
/* .. External Functions .. */
/* .. External Subroutines .. */
/* .. Intrinsic Functions .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function Definitions .. */
/* .. Parameters .. */
/* Create the loop to test out the Hilbert matrices */
*(unsigned char *)fact = 'E';
*(unsigned char *)uplo = 'U';
*(unsigned char *)trans = 'N';
*(unsigned char *)equed = 'N';
eps = slamch_("Epsilon");
nfail = 0;
n_aux_tests__ = 0;
lda = 6;
ldab = 11;
ldafb = 16;
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
/* Main loop to test the different Hilbert Matrices. */
printed_guide__ = FALSE_;
for (n = 1; n <= 6; ++n) {
params[0] = -1.f;
params[1] = -1.f;
kl = n - 1;
ku = n - 1;
nrhs = n;
/* Computing MAX */
r__1 = sqrt((real) n);
m = dmax(r__1,10.f);
/* Generate the Hilbert matrix, its inverse, and the */
/* right hand side, all scaled by the LCM(1,..,2N-1). */
clahilb_(&n, &n, a, &lda, invhilb, &lda, b, &lda, work, &info, path);
/* Copy A into ACOPY. */
clacpy_("ALL", &n, &n, a, &c__6, acopy, &c__6);
/* Store A in band format for GB tests */
i__1 = n;
for (j = 1; j <= i__1; ++j) {
i__2 = kl + ku + 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * 11 - 12;
ab[i__3].r = 0.f, ab[i__3].i = 0.f;
}
}
i__1 = n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = 1, i__3 = j - ku;
/* Computing MIN */
i__5 = n, i__6 = j + kl;
i__4 = min(i__5,i__6);
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
i__2 = ku + 1 + i__ - j + j * 11 - 12;
i__3 = i__ + j * 6 - 7;
ab[i__2].r = a[i__3].r, ab[i__2].i = a[i__3].i;
}
}
/* Copy AB into ABCOPY. */
i__1 = n;
for (j = 1; j <= i__1; ++j) {
i__4 = kl + ku + 1;
for (i__ = 1; i__ <= i__4; ++i__) {
i__2 = i__ + j * 11 - 12;
abcopy[i__2].r = 0.f, abcopy[i__2].i = 0.f;
}
}
i__1 = kl + ku + 1;
dlacpy_("ALL", &i__1, &n, ab, &ldab, abcopy, &ldab);
/* Call C**SVXX with default PARAMS and N_ERR_BND = 3. */
if (lsamen_(&c__2, c2, "SY")) {
csysvxx_(fact, uplo, &n, &nrhs, acopy, &lda, af, &lda, ipiv,
equed, s, b, &lda, x, &lda, &orcond, &rpvgrw, berr, &c__3,
errbnd_n__, errbnd_c__, &c__2, params, work, rwork, &
info);
} else if (lsamen_(&c__2, c2, "PO")) {
cposvxx_(fact, uplo, &n, &nrhs, acopy, &lda, af, &lda, equed, s,
b, &lda, x, &lda, &orcond, &rpvgrw, berr, &c__3,
errbnd_n__, errbnd_c__, &c__2, params, work, rwork, &info);
} else if (lsamen_(&c__2, c2, "HE")) {
chesvxx_(fact, uplo, &n, &nrhs, acopy, &lda, af, &lda, ipiv,
equed, s, b, &lda, x, &lda, &orcond, &rpvgrw, berr, &c__3,
errbnd_n__, errbnd_c__, &c__2, params, work, rwork, &
info);
} else if (lsamen_(&c__2, c2, "GB")) {
cgbsvxx_(fact, trans, &n, &kl, &ku, &nrhs, abcopy, &ldab, afb, &
ldafb, ipiv, equed, r__, c__, b, &lda, x, &lda, &orcond, &
rpvgrw, berr, &c__3, errbnd_n__, errbnd_c__, &c__2,
params, work, rwork, &info);
} else {
cgesvxx_(fact, trans, &n, &nrhs, acopy, &lda, af, &lda, ipiv,
equed, r__, c__, b, &lda, x, &lda, &orcond, &rpvgrw, berr,
&c__3, errbnd_n__, errbnd_c__, &c__2, params, work,
rwork, &info);
}
++n_aux_tests__;
if (orcond < eps) {
/* Either factorization failed or the matrix is flagged, and 1 <= */
/* INFO <= N+1. We don't decide based on rcond anymore. */
/* IF (INFO .EQ. 0 .OR. INFO .GT. N+1) THEN */
/* NFAIL = NFAIL + 1 */
/* WRITE (*, FMT=8000) N, INFO, ORCOND, RCOND */
/* END IF */
} else {
/* Either everything succeeded (INFO == 0) or some solution failed */
/* to converge (INFO > N+1). */
if (info > 0 && info <= n + 1) {
++nfail;
s_wsfe(&io___42);
do_fio(&c__1, c2, (ftnlen)2);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&orcond, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&rcond, (ftnlen)sizeof(real));
e_wsfe();
}
}
/* Calculating the difference between C**SVXX's X and the true X. */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__4 = nrhs;
for (j = 1; j <= i__4; ++j) {
i__2 = i__ + j * 6 - 7;
i__3 = i__ + j * 6 - 7;
i__5 = i__ + j * 6 - 7;
q__1.r = x[i__3].r - invhilb[i__5].r, q__1.i = x[i__3].i -
invhilb[i__5].i;
diff[i__2] = q__1.r;
}
}
/* Calculating the RCOND */
rnorm = 0.f;
rinorm = 0.f;
if (lsamen_(&c__2, c2, "PO") || lsamen_(&c__2,
c2, "SY") || lsamen_(&c__2, c2, "HE")) {
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
sumr = 0.f;
sumri = 0.f;
i__4 = n;
for (j = 1; j <= i__4; ++j) {
i__2 = i__ + j * 6 - 7;
sumr += s[i__ - 1] * ((r__1 = a[i__2].r, dabs(r__1)) + (
r__2 = r_imag(&a[i__ + j * 6 - 7]), dabs(r__2))) *
s[j - 1];
i__2 = i__ + j * 6 - 7;
sumri += ((r__1 = invhilb[i__2].r, dabs(r__1)) + (r__2 =
r_imag(&invhilb[i__ + j * 6 - 7]), dabs(r__2))) /
(s[j - 1] * s[i__ - 1]);
}
rnorm = dmax(rnorm,sumr);
rinorm = dmax(rinorm,sumri);
}
} else if (lsamen_(&c__2, c2, "GE") || lsamen_(&
c__2, c2, "GB")) {
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
sumr = 0.f;
sumri = 0.f;
i__4 = n;
for (j = 1; j <= i__4; ++j) {
i__2 = i__ + j * 6 - 7;
sumr += r__[i__ - 1] * ((r__1 = a[i__2].r, dabs(r__1)) + (
r__2 = r_imag(&a[i__ + j * 6 - 7]), dabs(r__2))) *
c__[j - 1];
i__2 = i__ + j * 6 - 7;
sumri += ((r__1 = invhilb[i__2].r, dabs(r__1)) + (r__2 =
r_imag(&invhilb[i__ + j * 6 - 7]), dabs(r__2))) /
(r__[j - 1] * c__[i__ - 1]);
}
rnorm = dmax(rnorm,sumr);
rinorm = dmax(rinorm,sumri);
}
}
rnorm /= (r__1 = a[0].r, dabs(r__1)) + (r__2 = r_imag(a), dabs(r__2));
rcond = 1.f / (rnorm * rinorm);
/* Calculating the R for normwise rcond. */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
rinv[i__ - 1] = 0.f;
}
i__1 = n;
for (j = 1; j <= i__1; ++j) {
i__4 = n;
for (i__ = 1; i__ <= i__4; ++i__) {
i__2 = i__ + j * 6 - 7;
rinv[i__ - 1] += (r__1 = a[i__2].r, dabs(r__1)) + (r__2 =
r_imag(&a[i__ + j * 6 - 7]), dabs(r__2));
}
}
/* Calculating the Normwise rcond. */
rinorm = 0.f;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
sumri = 0.f;
i__4 = n;
for (j = 1; j <= i__4; ++j) {
i__2 = i__ + j * 6 - 7;
i__3 = j - 1;
q__2.r = rinv[i__3] * invhilb[i__2].r, q__2.i = rinv[i__3] *
invhilb[i__2].i;
q__1.r = q__2.r, q__1.i = q__2.i;
sumri += (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1),
dabs(r__2));
}
rinorm = dmax(rinorm,sumri);
}
/* invhilb is the inverse *unscaled* Hilbert matrix, so scale its norm */
/* by 1/A(1,1) to make the scaling match A (the scaled Hilbert matrix) */
ncond = ((r__1 = a[0].r, dabs(r__1)) + (r__2 = r_imag(a), dabs(r__2)))
/ rinorm;
condthresh = m * eps;
errthresh = m * eps;
i__1 = nrhs;
for (k = 1; k <= i__1; ++k) {
normt = 0.f;
normdif = 0.f;
cwise_err__ = 0.f;
i__4 = n;
for (i__ = 1; i__ <= i__4; ++i__) {
/* Computing MAX */
i__2 = i__ + k * 6 - 7;
r__3 = (r__1 = invhilb[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
invhilb[i__ + k * 6 - 7]), dabs(r__2));
normt = dmax(r__3,normt);
i__2 = i__ + k * 6 - 7;
i__3 = i__ + k * 6 - 7;
q__2.r = x[i__2].r - invhilb[i__3].r, q__2.i = x[i__2].i -
invhilb[i__3].i;
q__1.r = q__2.r, q__1.i = q__2.i;
/* Computing MAX */
r__3 = (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1),
dabs(r__2));
normdif = dmax(r__3,normdif);
i__2 = i__ + k * 6 - 7;
if (invhilb[i__2].r != 0.f || invhilb[i__2].i != 0.f) {
i__2 = i__ + k * 6 - 7;
i__3 = i__ + k * 6 - 7;
q__2.r = x[i__2].r - invhilb[i__3].r, q__2.i = x[i__2].i
- invhilb[i__3].i;
q__1.r = q__2.r, q__1.i = q__2.i;
/* Computing MAX */
i__5 = i__ + k * 6 - 7;
r__5 = ((r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&
q__1), dabs(r__2))) / ((r__3 = invhilb[i__5].r,
dabs(r__3)) + (r__4 = r_imag(&invhilb[i__ + k * 6
- 7]), dabs(r__4)));
cwise_err__ = dmax(r__5,cwise_err__);
} else /* if(complicated condition) */ {
i__2 = i__ + k * 6 - 7;
if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
cwise_err__ = slamch_("OVERFLOW");
}
}
}
if (normt != 0.f) {
nwise_err__ = normdif / normt;
} else if (normdif != 0.f) {
nwise_err__ = slamch_("OVERFLOW");
} else {
nwise_err__ = 0.f;
}
i__4 = n;
for (i__ = 1; i__ <= i__4; ++i__) {
rinv[i__ - 1] = 0.f;
}
i__4 = n;
for (j = 1; j <= i__4; ++j) {
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * 6 - 7;
i__5 = j + k * 6 - 7;
q__2.r = a[i__3].r * invhilb[i__5].r - a[i__3].i *
invhilb[i__5].i, q__2.i = a[i__3].r * invhilb[
i__5].i + a[i__3].i * invhilb[i__5].r;
q__1.r = q__2.r, q__1.i = q__2.i;
rinv[i__ - 1] += (r__1 = q__1.r, dabs(r__1)) + (r__2 =
r_imag(&q__1), dabs(r__2));
}
}
rinorm = 0.f;
i__4 = n;
for (i__ = 1; i__ <= i__4; ++i__) {
sumri = 0.f;
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = i__ + j * 6 - 7;
i__5 = j - 1;
q__3.r = rinv[i__5] * invhilb[i__3].r, q__3.i = rinv[i__5]
* invhilb[i__3].i;
c_div(&q__2, &q__3, &invhilb[i__ + k * 6 - 7]);
q__1.r = q__2.r, q__1.i = q__2.i;
sumri += (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&
q__1), dabs(r__2));
}
rinorm = dmax(rinorm,sumri);
}
/* invhilb is the inverse *unscaled* Hilbert matrix, so scale its norm */
/* by 1/A(1,1) to make the scaling match A (the scaled Hilbert matrix) */
ccond = ((r__1 = a[0].r, dabs(r__1)) + (r__2 = r_imag(a), dabs(
r__2))) / rinorm;
/* Forward error bound tests */
nwise_bnd__ = errbnd_n__[k + nrhs - 1];
cwise_bnd__ = errbnd_c__[k + nrhs - 1];
nwise_rcond__ = errbnd_n__[k + (nrhs << 1) - 1];
cwise_rcond__ = errbnd_c__[k + (nrhs << 1) - 1];
/* write (*,*) 'nwise : ', n, k, ncond, nwise_rcond, */
/* $ condthresh, ncond.ge.condthresh */
/* write (*,*) 'nwise2: ', k, nwise_bnd, nwise_err, errthresh */
if (ncond >= condthresh) {
s_copy(nguar, "YES", (ftnlen)3, (ftnlen)3);
if (nwise_bnd__ > errthresh) {
tstrat[0] = 1 / (eps * 2.f);
} else {
if (nwise_bnd__ != 0.f) {
tstrat[0] = nwise_err__ / nwise_bnd__;
} else if (nwise_err__ != 0.f) {
tstrat[0] = 1 / (eps * 16.f);
} else {
tstrat[0] = 0.f;
}
if (tstrat[0] > 1.f) {
tstrat[0] = 1 / (eps * 4.f);
}
}
} else {
s_copy(nguar, "NO", (ftnlen)3, (ftnlen)2);
if (nwise_bnd__ < 1.f) {
tstrat[0] = 1 / (eps * 8.f);
} else {
tstrat[0] = 1.f;
}
}
/* write (*,*) 'cwise : ', n, k, ccond, cwise_rcond, */
/* $ condthresh, ccond.ge.condthresh */
/* write (*,*) 'cwise2: ', k, cwise_bnd, cwise_err, errthresh */
if (ccond >= condthresh) {
s_copy(cguar, "YES", (ftnlen)3, (ftnlen)3);
if (cwise_bnd__ > errthresh) {
tstrat[1] = 1 / (eps * 2.f);
} else {
if (cwise_bnd__ != 0.f) {
tstrat[1] = cwise_err__ / cwise_bnd__;
} else if (cwise_err__ != 0.f) {
tstrat[1] = 1 / (eps * 16.f);
} else {
tstrat[1] = 0.f;
}
if (tstrat[1] > 1.f) {
tstrat[1] = 1 / (eps * 4.f);
}
}
} else {
s_copy(cguar, "NO", (ftnlen)3, (ftnlen)2);
if (cwise_bnd__ < 1.f) {
tstrat[1] = 1 / (eps * 8.f);
} else {
tstrat[1] = 1.f;
}
}
/* Backwards error test */
tstrat[2] = berr[k - 1] / eps;
/* Condition number tests */
tstrat[3] = rcond / orcond;
if (rcond >= condthresh && tstrat[3] < 1.f) {
tstrat[3] = 1.f / tstrat[3];
}
tstrat[4] = ncond / nwise_rcond__;
if (ncond >= condthresh && tstrat[4] < 1.f) {
tstrat[4] = 1.f / tstrat[4];
}
tstrat[5] = ccond / nwise_rcond__;
if (ccond >= condthresh && tstrat[5] < 1.f) {
tstrat[5] = 1.f / tstrat[5];
}
for (i__ = 1; i__ <= 6; ++i__) {
if (tstrat[i__ - 1] > *thresh) {
if (! printed_guide__) {
s_wsle(&io___66);
e_wsle();
s_wsfe(&io___67);
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
e_wsfe();
s_wsfe(&io___68);
do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
e_wsfe();
s_wsfe(&io___69);
do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
e_wsfe();
s_wsfe(&io___70);
do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
e_wsfe();
s_wsfe(&io___71);
do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
e_wsfe();
s_wsfe(&io___72);
do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
e_wsfe();
s_wsfe(&io___73);
do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
e_wsfe();
s_wsfe(&io___74);
do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
e_wsfe();
s_wsle(&io___75);
e_wsle();
printed_guide__ = TRUE_;
}
s_wsfe(&io___76);
do_fio(&c__1, c2, (ftnlen)2);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, nguar, (ftnlen)3);
do_fio(&c__1, cguar, (ftnlen)3);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&tstrat[i__ - 1], (ftnlen)sizeof(
real));
e_wsfe();
++nfail;
}
}
}
/* $$$ WRITE(*,*) */
/* $$$ WRITE(*,*) 'Normwise Error Bounds' */
/* $$$ WRITE(*,*) 'Guaranteed error bound: ',ERRBND(NRHS,nwise_i,bnd_i) */
/* $$$ WRITE(*,*) 'Reciprocal condition number: ',ERRBND(NRHS,nwise_i,cond_i) */
/* $$$ WRITE(*,*) 'Raw error estimate: ',ERRBND(NRHS,nwise_i,rawbnd_i) */
/* $$$ WRITE(*,*) */
/* $$$ WRITE(*,*) 'Componentwise Error Bounds' */
/* $$$ WRITE(*,*) 'Guaranteed error bound: ',ERRBND(NRHS,cwise_i,bnd_i) */
/* $$$ WRITE(*,*) 'Reciprocal condition number: ',ERRBND(NRHS,cwise_i,cond_i) */
/* $$$ WRITE(*,*) 'Raw error estimate: ',ERRBND(NRHS,cwise_i,rawbnd_i) */
/* $$$ print *, 'Info: ', info */
/* $$$ WRITE(*,*) */
/* WRITE(*,*) 'TSTRAT: ',TSTRAT */
}
s_wsle(&io___77);
e_wsle();
if (nfail > 0) {
s_wsfe(&io___78);
do_fio(&c__1, c2, (ftnlen)2);
do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
i__1 = n * 6 + n_aux_tests__;
do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer));
e_wsfe();
} else {
s_wsfe(&io___79);
do_fio(&c__1, c2, (ftnlen)2);
e_wsfe();
}
/* Test ratios. */
return 0;
} /* cebchvxx_ */
/* Subroutine */ int csytrs_(char *uplo, integer *n, integer *nrhs, complex *
a, integer *lda, integer *ipiv, complex *b, integer *ldb, integer *
info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
complex q__1, q__2, q__3;
/* Builtin functions */
void c_div(complex *, complex *, complex *);
/* Local variables */
integer j, k;
complex ak, bk;
integer kp;
complex akm1, bkm1, akm1k;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
extern logical lsame_(char *, char *);
complex denom;
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *), cgeru_(integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *),
cswap_(integer *, complex *, integer *, complex *, integer *);
logical upper;
extern /* Subroutine */ int xerbla_(char *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CSYTRS solves a system of linear equations A*X = B with a complex */
/* symmetric matrix A using the factorization A = U*D*U**T or */
/* A = L*D*L**T computed by CSYTRF. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the details of the factorization are stored */
/* as an upper or lower triangular matrix. */
/* = 'U': Upper triangular, form is A = U*D*U**T; */
/* = 'L': Lower triangular, form is A = L*D*L**T. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrix B. NRHS >= 0. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The block diagonal matrix D and the multipliers used to */
/* obtain the factor U or L as computed by CSYTRF. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* IPIV (input) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D */
/* as determined by CSYTRF. */
/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
/* On entry, the right hand side matrix B. */
/* On exit, the solution matrix X. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CSYTRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
return 0;
}
if (upper) {
/* Solve A*X = B, where A = U*D*U'. */
/* First solve U*D*X = B, overwriting B with X. */
/* K is the main loop index, decreasing from N to 1 in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = *n;
L10:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L30;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
/* Multiply by inv(U(K)), where U(K) is the transformation */
/* stored in column K of A. */
i__1 = k - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgeru_(&i__1, nrhs, &q__1, &a[k * a_dim1 + 1], &c__1, &b[k +
b_dim1], ldb, &b[b_dim1 + 1], ldb);
/* Multiply by the inverse of the diagonal block. */
c_div(&q__1, &c_b1, &a[k + k * a_dim1]);
cscal_(nrhs, &q__1, &b[k + b_dim1], ldb);
--k;
} else {
/* 2 x 2 diagonal block */
/* Interchange rows K-1 and -IPIV(K). */
kp = -ipiv[k];
if (kp != k - 1) {
cswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
/* Multiply by inv(U(K)), where U(K) is the transformation */
/* stored in columns K-1 and K of A. */
i__1 = k - 2;
q__1.r = -1.f, q__1.i = -0.f;
cgeru_(&i__1, nrhs, &q__1, &a[k * a_dim1 + 1], &c__1, &b[k +
b_dim1], ldb, &b[b_dim1 + 1], ldb);
i__1 = k - 2;
q__1.r = -1.f, q__1.i = -0.f;
cgeru_(&i__1, nrhs, &q__1, &a[(k - 1) * a_dim1 + 1], &c__1, &b[k
- 1 + b_dim1], ldb, &b[b_dim1 + 1], ldb);
/* Multiply by the inverse of the diagonal block. */
i__1 = k - 1 + k * a_dim1;
akm1k.r = a[i__1].r, akm1k.i = a[i__1].i;
c_div(&q__1, &a[k - 1 + (k - 1) * a_dim1], &akm1k);
akm1.r = q__1.r, akm1.i = q__1.i;
c_div(&q__1, &a[k + k * a_dim1], &akm1k);
ak.r = q__1.r, ak.i = q__1.i;
q__2.r = akm1.r * ak.r - akm1.i * ak.i, q__2.i = akm1.r * ak.i +
akm1.i * ak.r;
q__1.r = q__2.r - 1.f, q__1.i = q__2.i - 0.f;
denom.r = q__1.r, denom.i = q__1.i;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
c_div(&q__1, &b[k - 1 + j * b_dim1], &akm1k);
bkm1.r = q__1.r, bkm1.i = q__1.i;
c_div(&q__1, &b[k + j * b_dim1], &akm1k);
bk.r = q__1.r, bk.i = q__1.i;
i__2 = k - 1 + j * b_dim1;
q__3.r = ak.r * bkm1.r - ak.i * bkm1.i, q__3.i = ak.r *
bkm1.i + ak.i * bkm1.r;
q__2.r = q__3.r - bk.r, q__2.i = q__3.i - bk.i;
c_div(&q__1, &q__2, &denom);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = k + j * b_dim1;
q__3.r = akm1.r * bk.r - akm1.i * bk.i, q__3.i = akm1.r *
bk.i + akm1.i * bk.r;
q__2.r = q__3.r - bkm1.r, q__2.i = q__3.i - bkm1.i;
c_div(&q__1, &q__2, &denom);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L20: */
}
k += -2;
}
goto L10;
L30:
/* Next solve U'*X = B, overwriting B with X. */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = 1;
L40:
/* If K > N, exit from loop. */
if (k > *n) {
goto L50;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Multiply by inv(U'(K)), where U(K) is the transformation */
/* stored in column K of A. */
i__1 = k - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("Transpose", &i__1, nrhs, &q__1, &b[b_offset], ldb, &a[k *
a_dim1 + 1], &c__1, &c_b1, &b[k + b_dim1], ldb)
;
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
++k;
} else {
/* 2 x 2 diagonal block */
/* Multiply by inv(U'(K+1)), where U(K+1) is the transformation */
/* stored in columns K and K+1 of A. */
i__1 = k - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("Transpose", &i__1, nrhs, &q__1, &b[b_offset], ldb, &a[k *
a_dim1 + 1], &c__1, &c_b1, &b[k + b_dim1], ldb)
;
i__1 = k - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("Transpose", &i__1, nrhs, &q__1, &b[b_offset], ldb, &a[(k
+ 1) * a_dim1 + 1], &c__1, &c_b1, &b[k + 1 + b_dim1], ldb);
/* Interchange rows K and -IPIV(K). */
kp = -ipiv[k];
if (kp != k) {
cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
k += 2;
}
goto L40;
L50:
;
} else {
/* Solve A*X = B, where A = L*D*L'. */
/* First solve L*D*X = B, overwriting B with X. */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = 1;
L60:
/* If K > N, exit from loop. */
if (k > *n) {
goto L80;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
/* Multiply by inv(L(K)), where L(K) is the transformation */
/* stored in column K of A. */
if (k < *n) {
i__1 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
cgeru_(&i__1, nrhs, &q__1, &a[k + 1 + k * a_dim1], &c__1, &b[
k + b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
}
/* Multiply by the inverse of the diagonal block. */
c_div(&q__1, &c_b1, &a[k + k * a_dim1]);
cscal_(nrhs, &q__1, &b[k + b_dim1], ldb);
++k;
} else {
/* 2 x 2 diagonal block */
/* Interchange rows K+1 and -IPIV(K). */
kp = -ipiv[k];
if (kp != k + 1) {
cswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
/* Multiply by inv(L(K)), where L(K) is the transformation */
/* stored in columns K and K+1 of A. */
if (k < *n - 1) {
i__1 = *n - k - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgeru_(&i__1, nrhs, &q__1, &a[k + 2 + k * a_dim1], &c__1, &b[
k + b_dim1], ldb, &b[k + 2 + b_dim1], ldb);
i__1 = *n - k - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgeru_(&i__1, nrhs, &q__1, &a[k + 2 + (k + 1) * a_dim1], &
c__1, &b[k + 1 + b_dim1], ldb, &b[k + 2 + b_dim1],
ldb);
}
/* Multiply by the inverse of the diagonal block. */
i__1 = k + 1 + k * a_dim1;
akm1k.r = a[i__1].r, akm1k.i = a[i__1].i;
c_div(&q__1, &a[k + k * a_dim1], &akm1k);
akm1.r = q__1.r, akm1.i = q__1.i;
c_div(&q__1, &a[k + 1 + (k + 1) * a_dim1], &akm1k);
ak.r = q__1.r, ak.i = q__1.i;
q__2.r = akm1.r * ak.r - akm1.i * ak.i, q__2.i = akm1.r * ak.i +
akm1.i * ak.r;
q__1.r = q__2.r - 1.f, q__1.i = q__2.i - 0.f;
denom.r = q__1.r, denom.i = q__1.i;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
c_div(&q__1, &b[k + j * b_dim1], &akm1k);
bkm1.r = q__1.r, bkm1.i = q__1.i;
c_div(&q__1, &b[k + 1 + j * b_dim1], &akm1k);
bk.r = q__1.r, bk.i = q__1.i;
i__2 = k + j * b_dim1;
q__3.r = ak.r * bkm1.r - ak.i * bkm1.i, q__3.i = ak.r *
bkm1.i + ak.i * bkm1.r;
q__2.r = q__3.r - bk.r, q__2.i = q__3.i - bk.i;
c_div(&q__1, &q__2, &denom);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = k + 1 + j * b_dim1;
q__3.r = akm1.r * bk.r - akm1.i * bk.i, q__3.i = akm1.r *
bk.i + akm1.i * bk.r;
q__2.r = q__3.r - bkm1.r, q__2.i = q__3.i - bkm1.i;
c_div(&q__1, &q__2, &denom);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L70: */
}
k += 2;
}
goto L60;
L80:
/* Next solve L'*X = B, overwriting B with X. */
/* K is the main loop index, decreasing from N to 1 in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = *n;
L90:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L100;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Multiply by inv(L'(K)), where L(K) is the transformation */
/* stored in column K of A. */
if (k < *n) {
i__1 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("Transpose", &i__1, nrhs, &q__1, &b[k + 1 + b_dim1],
ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b1, &b[k +
b_dim1], ldb);
}
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
--k;
} else {
/* 2 x 2 diagonal block */
/* Multiply by inv(L'(K-1)), where L(K-1) is the transformation */
/* stored in columns K-1 and K of A. */
if (k < *n) {
i__1 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("Transpose", &i__1, nrhs, &q__1, &b[k + 1 + b_dim1],
ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b1, &b[k +
b_dim1], ldb);
i__1 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("Transpose", &i__1, nrhs, &q__1, &b[k + 1 + b_dim1],
ldb, &a[k + 1 + (k - 1) * a_dim1], &c__1, &c_b1, &b[k
- 1 + b_dim1], ldb);
}
/* Interchange rows K and -IPIV(K). */
kp = -ipiv[k];
if (kp != k) {
cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
k += -2;
}
goto L90;
L100:
;
}
return 0;
/* End of CSYTRS */
} /* csytrs_ */
int
ilu_cpivotL(
const int jcol, /* in */
const double u, /* in - diagonal pivoting threshold */
int *usepr, /* re-use the pivot sequence given by
* perm_r/iperm_r */
int *perm_r, /* may be modified */
int diagind, /* diagonal of Pc*A*Pc' */
int *swap, /* in/out record the row permutation */
int *iswap, /* in/out inverse of swap, it is the same as
perm_r after the factorization */
int *marker, /* in */
int *pivrow, /* in/out, as an input if *usepr!=0 */
double fill_tol, /* in - fill tolerance of current column
* used for a singular column */
milu_t milu, /* in */
complex drop_sum, /* in - computed in ilu_ccopy_to_ucol()
(MILU only) */
GlobalLU_t *Glu, /* modified - global LU data structures */
SuperLUStat_t *stat /* output */
)
{
int n; /* number of columns */
int fsupc; /* first column in the supernode */
int nsupc; /* no of columns in the supernode */
int nsupr; /* no of rows in the supernode */
int lptr; /* points to the starting subscript of the supernode */
register int pivptr;
int old_pivptr, diag, ptr0;
register float pivmax, rtemp;
float thresh;
complex temp;
complex *lu_sup_ptr;
complex *lu_col_ptr;
int *lsub_ptr;
register int isub, icol, k, itemp;
int *lsub, *xlsub;
complex *lusup;
int *xlusup;
flops_t *ops = stat->ops;
int info;
complex one = {1.0, 0.0};
/* Initialize pointers */
n = Glu->n;
lsub = Glu->lsub;
xlsub = Glu->xlsub;
lusup = Glu->lusup;
xlusup = Glu->xlusup;
fsupc = (Glu->xsup)[(Glu->supno)[jcol]];
nsupc = jcol - fsupc; /* excluding jcol; nsupc >= 0 */
lptr = xlsub[fsupc];
nsupr = xlsub[fsupc+1] - lptr;
lu_sup_ptr = &lusup[xlusup[fsupc]]; /* start of the current supernode */
lu_col_ptr = &lusup[xlusup[jcol]]; /* start of jcol in the supernode */
lsub_ptr = &lsub[lptr]; /* start of row indices of the supernode */
/* Determine the largest abs numerical value for partial pivoting;
Also search for user-specified pivot, and diagonal element. */
pivmax = -1.0;
pivptr = nsupc;
diag = EMPTY;
old_pivptr = nsupc;
ptr0 = EMPTY;
for (isub = nsupc; isub < nsupr; ++isub) {
if (marker[lsub_ptr[isub]] > jcol)
continue; /* do not overlap with a later relaxed supernode */
switch (milu) {
case SMILU_1:
c_add(&temp, &lu_col_ptr[isub], &drop_sum);
rtemp = c_abs1(&temp);
break;
case SMILU_2:
case SMILU_3:
/* In this case, drop_sum contains the sum of the abs. value */
rtemp = c_abs1(&lu_col_ptr[isub]);
break;
case SILU:
default:
rtemp = c_abs1(&lu_col_ptr[isub]);
break;
}
if (rtemp > pivmax) { pivmax = rtemp; pivptr = isub; }
if (*usepr && lsub_ptr[isub] == *pivrow) old_pivptr = isub;
if (lsub_ptr[isub] == diagind) diag = isub;
if (ptr0 == EMPTY) ptr0 = isub;
}
if (milu == SMILU_2 || milu == SMILU_3) pivmax += drop_sum.r;
/* Test for singularity */
if (pivmax < 0.0) {
fprintf(stderr, "[0]: jcol=%d, SINGULAR!!!\n", jcol);
fflush(stderr);
exit(1);
}
if ( pivmax == 0.0 ) {
if (diag != EMPTY)
*pivrow = lsub_ptr[pivptr = diag];
else if (ptr0 != EMPTY)
*pivrow = lsub_ptr[pivptr = ptr0];
else {
/* look for the first row which does not
belong to any later supernodes */
for (icol = jcol; icol < n; icol++)
if (marker[swap[icol]] <= jcol) break;
if (icol >= n) {
fprintf(stderr, "[1]: jcol=%d, SINGULAR!!!\n", jcol);
fflush(stderr);
exit(1);
}
*pivrow = swap[icol];
/* pick up the pivot row */
for (isub = nsupc; isub < nsupr; ++isub)
if ( lsub_ptr[isub] == *pivrow ) { pivptr = isub; break; }
}
pivmax = fill_tol;
lu_col_ptr[pivptr].r = pivmax;
lu_col_ptr[pivptr].i = 0.0;
*usepr = 0;
#ifdef DEBUG
printf("[0] ZERO PIVOT: FILL (%d, %d).\n", *pivrow, jcol);
fflush(stdout);
#endif
info =jcol + 1;
} /* if (*pivrow == 0.0) */
else {
thresh = u * pivmax;
/* Choose appropriate pivotal element by our policy. */
if ( *usepr ) {
switch (milu) {
case SMILU_1:
c_add(&temp, &lu_col_ptr[old_pivptr], &drop_sum);
rtemp = c_abs1(&temp);
break;
case SMILU_2:
case SMILU_3:
rtemp = c_abs1(&lu_col_ptr[old_pivptr]) + drop_sum.r;
break;
case SILU:
default:
rtemp = c_abs1(&lu_col_ptr[old_pivptr]);
break;
}
if ( rtemp != 0.0 && rtemp >= thresh ) pivptr = old_pivptr;
else *usepr = 0;
}
if ( *usepr == 0 ) {
/* Use diagonal pivot? */
if ( diag >= 0 ) { /* diagonal exists */
switch (milu) {
case SMILU_1:
c_add(&temp, &lu_col_ptr[diag], &drop_sum);
rtemp = c_abs1(&temp);
break;
case SMILU_2:
case SMILU_3:
rtemp = c_abs1(&lu_col_ptr[diag]) + drop_sum.r;
break;
case SILU:
default:
rtemp = c_abs1(&lu_col_ptr[diag]);
break;
}
if ( rtemp != 0.0 && rtemp >= thresh ) pivptr = diag;
}
*pivrow = lsub_ptr[pivptr];
}
info = 0;
/* Reset the diagonal */
switch (milu) {
case SMILU_1:
c_add(&lu_col_ptr[pivptr], &lu_col_ptr[pivptr], &drop_sum);
break;
case SMILU_2:
case SMILU_3:
temp = c_sgn(&lu_col_ptr[pivptr]);
cc_mult(&temp, &temp, &drop_sum);
c_add(&lu_col_ptr[pivptr], &lu_col_ptr[pivptr], &drop_sum);
break;
case SILU:
default:
break;
}
} /* else */
/* Record pivot row */
perm_r[*pivrow] = jcol;
if (jcol < n - 1) {
register int t1, t2, t;
t1 = iswap[*pivrow]; t2 = jcol;
if (t1 != t2) {
t = swap[t1]; swap[t1] = swap[t2]; swap[t2] = t;
t1 = swap[t1]; t2 = t;
t = iswap[t1]; iswap[t1] = iswap[t2]; iswap[t2] = t;
}
} /* if (jcol < n - 1) */
/* Interchange row subscripts */
if ( pivptr != nsupc ) {
itemp = lsub_ptr[pivptr];
lsub_ptr[pivptr] = lsub_ptr[nsupc];
lsub_ptr[nsupc] = itemp;
/* Interchange numerical values as well, for the whole snode, such
* that L is indexed the same way as A.
*/
for (icol = 0; icol <= nsupc; icol++) {
itemp = pivptr + icol * nsupr;
temp = lu_sup_ptr[itemp];
lu_sup_ptr[itemp] = lu_sup_ptr[nsupc + icol*nsupr];
lu_sup_ptr[nsupc + icol*nsupr] = temp;
}
} /* if */
/* cdiv operation */
ops[FACT] += 10 * (nsupr - nsupc);
c_div(&temp, &one, &lu_col_ptr[nsupc]);
for (k = nsupc+1; k < nsupr; k++)
cc_mult(&lu_col_ptr[k], &lu_col_ptr[k], &temp);
return info;
}
int csptri_(char *uplo, int *n, complex *ap, int *
ipiv, complex *work, int *info)
{
/* System generated locals */
int i__1, i__2, i__3;
complex q__1, q__2, q__3;
/* Builtin functions */
void c_div(complex *, complex *, complex *);
/* Local variables */
complex d__;
int j, k;
complex t, ak;
int kc, kp, kx, kpc, npp;
complex akp1, temp, akkp1;
extern int lsame_(char *, char *);
extern int ccopy_(int *, complex *, int *,
complex *, int *);
extern /* Complex */ VOID cdotu_(complex *, int *, complex *, int
*, complex *, int *);
extern int cswap_(int *, complex *, int *,
complex *, int *);
int kstep;
extern int cspmv_(char *, int *, complex *, complex *
, complex *, int *, complex *, complex *, int *);
int upper;
extern int xerbla_(char *, int *);
int kcnext;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CSPTRI computes the inverse of a complex symmetric indefinite matrix */
/* A in packed storage using the factorization A = U*D*U**T or */
/* A = L*D*L**T computed by CSPTRF. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the details of the factorization are stored */
/* as an upper or lower triangular matrix. */
/* = 'U': Upper triangular, form is A = U*D*U**T; */
/* = 'L': Lower triangular, form is A = L*D*L**T. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
/* On entry, the block diagonal matrix D and the multipliers */
/* used to obtain the factor U or L as computed by CSPTRF, */
/* stored as a packed triangular matrix. */
/* On exit, if INFO = 0, the (symmetric) inverse of the original */
/* matrix, stored as a packed triangular matrix. The j-th column */
/* of inv(A) is stored in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j; */
/* if UPLO = 'L', */
/* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n. */
/* IPIV (input) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D */
/* as determined by CSPTRF. */
/* WORK (workspace) COMPLEX array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its */
/* inverse could not be computed. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--work;
--ipiv;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CSPTRI", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Check that the diagonal matrix D is nonsingular. */
if (upper) {
/* Upper triangular storage: examine D from bottom to top */
kp = *n * (*n + 1) / 2;
for (*info = *n; *info >= 1; --(*info)) {
i__1 = kp;
if (ipiv[*info] > 0 && (ap[i__1].r == 0.f && ap[i__1].i == 0.f)) {
return 0;
}
kp -= *info;
/* L10: */
}
} else {
/* Lower triangular storage: examine D from top to bottom. */
kp = 1;
i__1 = *n;
for (*info = 1; *info <= i__1; ++(*info)) {
i__2 = kp;
if (ipiv[*info] > 0 && (ap[i__2].r == 0.f && ap[i__2].i == 0.f)) {
return 0;
}
kp = kp + *n - *info + 1;
/* L20: */
}
}
*info = 0;
if (upper) {
/* Compute inv(A) from the factorization A = U*D*U'. */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = 1;
kc = 1;
L30:
/* If K > N, exit from loop. */
if (k > *n) {
goto L50;
}
kcnext = kc + k;
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Invert the diagonal block. */
i__1 = kc + k - 1;
c_div(&q__1, &c_b1, &ap[kc + k - 1]);
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
/* Compute column K of the inverse. */
if (k > 1) {
i__1 = k - 1;
ccopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1);
i__1 = k - 1;
q__1.r = -1.f, q__1.i = -0.f;
cspmv_(uplo, &i__1, &q__1, &ap[1], &work[1], &c__1, &c_b2, &
ap[kc], &c__1);
i__1 = kc + k - 1;
i__2 = kc + k - 1;
i__3 = k - 1;
cdotu_(&q__2, &i__3, &work[1], &c__1, &ap[kc], &c__1);
q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i;
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
}
kstep = 1;
} else {
/* 2 x 2 diagonal block */
/* Invert the diagonal block. */
i__1 = kcnext + k - 1;
t.r = ap[i__1].r, t.i = ap[i__1].i;
c_div(&q__1, &ap[kc + k - 1], &t);
ak.r = q__1.r, ak.i = q__1.i;
c_div(&q__1, &ap[kcnext + k], &t);
akp1.r = q__1.r, akp1.i = q__1.i;
c_div(&q__1, &ap[kcnext + k - 1], &t);
akkp1.r = q__1.r, akkp1.i = q__1.i;
q__3.r = ak.r * akp1.r - ak.i * akp1.i, q__3.i = ak.r * akp1.i +
ak.i * akp1.r;
q__2.r = q__3.r - 1.f, q__2.i = q__3.i - 0.f;
q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * q__2.i + t.i
* q__2.r;
d__.r = q__1.r, d__.i = q__1.i;
i__1 = kc + k - 1;
c_div(&q__1, &akp1, &d__);
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
i__1 = kcnext + k;
c_div(&q__1, &ak, &d__);
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
i__1 = kcnext + k - 1;
q__2.r = -akkp1.r, q__2.i = -akkp1.i;
c_div(&q__1, &q__2, &d__);
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
/* Compute columns K and K+1 of the inverse. */
if (k > 1) {
i__1 = k - 1;
ccopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1);
i__1 = k - 1;
q__1.r = -1.f, q__1.i = -0.f;
cspmv_(uplo, &i__1, &q__1, &ap[1], &work[1], &c__1, &c_b2, &
ap[kc], &c__1);
i__1 = kc + k - 1;
i__2 = kc + k - 1;
i__3 = k - 1;
cdotu_(&q__2, &i__3, &work[1], &c__1, &ap[kc], &c__1);
q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i;
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
i__1 = kcnext + k - 1;
i__2 = kcnext + k - 1;
i__3 = k - 1;
cdotu_(&q__2, &i__3, &ap[kc], &c__1, &ap[kcnext], &c__1);
q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i;
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
i__1 = k - 1;
ccopy_(&i__1, &ap[kcnext], &c__1, &work[1], &c__1);
i__1 = k - 1;
q__1.r = -1.f, q__1.i = -0.f;
cspmv_(uplo, &i__1, &q__1, &ap[1], &work[1], &c__1, &c_b2, &
ap[kcnext], &c__1);
i__1 = kcnext + k;
i__2 = kcnext + k;
i__3 = k - 1;
cdotu_(&q__2, &i__3, &work[1], &c__1, &ap[kcnext], &c__1);
q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i;
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
}
kstep = 2;
kcnext = kcnext + k + 1;
}
kp = (i__1 = ipiv[k], ABS(i__1));
if (kp != k) {
/* Interchange rows and columns K and KP in the leading */
/* submatrix A(1:k+1,1:k+1) */
kpc = (kp - 1) * kp / 2 + 1;
i__1 = kp - 1;
cswap_(&i__1, &ap[kc], &c__1, &ap[kpc], &c__1);
kx = kpc + kp - 1;
i__1 = k - 1;
for (j = kp + 1; j <= i__1; ++j) {
kx = kx + j - 1;
i__2 = kc + j - 1;
temp.r = ap[i__2].r, temp.i = ap[i__2].i;
i__2 = kc + j - 1;
i__3 = kx;
ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i;
i__2 = kx;
ap[i__2].r = temp.r, ap[i__2].i = temp.i;
/* L40: */
}
i__1 = kc + k - 1;
temp.r = ap[i__1].r, temp.i = ap[i__1].i;
i__1 = kc + k - 1;
i__2 = kpc + kp - 1;
ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
i__1 = kpc + kp - 1;
ap[i__1].r = temp.r, ap[i__1].i = temp.i;
if (kstep == 2) {
i__1 = kc + k + k - 1;
temp.r = ap[i__1].r, temp.i = ap[i__1].i;
i__1 = kc + k + k - 1;
i__2 = kc + k + kp - 1;
ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
i__1 = kc + k + kp - 1;
ap[i__1].r = temp.r, ap[i__1].i = temp.i;
}
}
k += kstep;
kc = kcnext;
goto L30;
L50:
;
} else {
/* Compute inv(A) from the factorization A = L*D*L'. */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
npp = *n * (*n + 1) / 2;
k = *n;
kc = npp;
L60:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L80;
}
kcnext = kc - (*n - k + 2);
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Invert the diagonal block. */
i__1 = kc;
c_div(&q__1, &c_b1, &ap[kc]);
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
/* Compute column K of the inverse. */
if (k < *n) {
i__1 = *n - k;
ccopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1);
i__1 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
cspmv_(uplo, &i__1, &q__1, &ap[kc + *n - k + 1], &work[1], &
c__1, &c_b2, &ap[kc + 1], &c__1);
i__1 = kc;
i__2 = kc;
i__3 = *n - k;
cdotu_(&q__2, &i__3, &work[1], &c__1, &ap[kc + 1], &c__1);
q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i;
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
}
kstep = 1;
} else {
/* 2 x 2 diagonal block */
/* Invert the diagonal block. */
i__1 = kcnext + 1;
t.r = ap[i__1].r, t.i = ap[i__1].i;
c_div(&q__1, &ap[kcnext], &t);
ak.r = q__1.r, ak.i = q__1.i;
c_div(&q__1, &ap[kc], &t);
akp1.r = q__1.r, akp1.i = q__1.i;
c_div(&q__1, &ap[kcnext + 1], &t);
akkp1.r = q__1.r, akkp1.i = q__1.i;
q__3.r = ak.r * akp1.r - ak.i * akp1.i, q__3.i = ak.r * akp1.i +
ak.i * akp1.r;
q__2.r = q__3.r - 1.f, q__2.i = q__3.i - 0.f;
q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * q__2.i + t.i
* q__2.r;
d__.r = q__1.r, d__.i = q__1.i;
i__1 = kcnext;
c_div(&q__1, &akp1, &d__);
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
i__1 = kc;
c_div(&q__1, &ak, &d__);
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
i__1 = kcnext + 1;
q__2.r = -akkp1.r, q__2.i = -akkp1.i;
c_div(&q__1, &q__2, &d__);
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
/* Compute columns K-1 and K of the inverse. */
if (k < *n) {
i__1 = *n - k;
ccopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1);
i__1 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
cspmv_(uplo, &i__1, &q__1, &ap[kc + (*n - k + 1)], &work[1], &
c__1, &c_b2, &ap[kc + 1], &c__1);
i__1 = kc;
i__2 = kc;
i__3 = *n - k;
cdotu_(&q__2, &i__3, &work[1], &c__1, &ap[kc + 1], &c__1);
q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i;
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
i__1 = kcnext + 1;
i__2 = kcnext + 1;
i__3 = *n - k;
cdotu_(&q__2, &i__3, &ap[kc + 1], &c__1, &ap[kcnext + 2], &
c__1);
q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i;
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
i__1 = *n - k;
ccopy_(&i__1, &ap[kcnext + 2], &c__1, &work[1], &c__1);
i__1 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
cspmv_(uplo, &i__1, &q__1, &ap[kc + (*n - k + 1)], &work[1], &
c__1, &c_b2, &ap[kcnext + 2], &c__1);
i__1 = kcnext;
i__2 = kcnext;
i__3 = *n - k;
cdotu_(&q__2, &i__3, &work[1], &c__1, &ap[kcnext + 2], &c__1);
q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i;
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
}
kstep = 2;
kcnext -= *n - k + 3;
}
kp = (i__1 = ipiv[k], ABS(i__1));
if (kp != k) {
/* Interchange rows and columns K and KP in the trailing */
/* submatrix A(k-1:n,k-1:n) */
kpc = npp - (*n - kp + 1) * (*n - kp + 2) / 2 + 1;
if (kp < *n) {
i__1 = *n - kp;
cswap_(&i__1, &ap[kc + kp - k + 1], &c__1, &ap[kpc + 1], &
c__1);
}
kx = kc + kp - k;
i__1 = kp - 1;
for (j = k + 1; j <= i__1; ++j) {
kx = kx + *n - j + 1;
i__2 = kc + j - k;
temp.r = ap[i__2].r, temp.i = ap[i__2].i;
i__2 = kc + j - k;
i__3 = kx;
ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i;
i__2 = kx;
ap[i__2].r = temp.r, ap[i__2].i = temp.i;
/* L70: */
}
i__1 = kc;
temp.r = ap[i__1].r, temp.i = ap[i__1].i;
i__1 = kc;
i__2 = kpc;
ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
i__1 = kpc;
ap[i__1].r = temp.r, ap[i__1].i = temp.i;
if (kstep == 2) {
i__1 = kc - *n + k - 1;
temp.r = ap[i__1].r, temp.i = ap[i__1].i;
i__1 = kc - *n + k - 1;
i__2 = kc - *n + kp - 1;
ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
i__1 = kc - *n + kp - 1;
ap[i__1].r = temp.r, ap[i__1].i = temp.i;
}
}
k -= kstep;
kc = kcnext;
goto L60;
L80:
;
}
return 0;
/* End of CSPTRI */
} /* csptri_ */
/* DECK CSPSL */
/* Subroutine */ int cspsl_(complex *ap, integer *n, integer *kpvt, complex *
b)
{
/* System generated locals */
integer i__1, i__2, i__3;
complex q__1, q__2, q__3;
/* Local variables */
static integer k;
static complex ak, bk;
static integer ik, kk, kp;
static complex akm1, bkm1;
static integer ikm1, km1k, ikp1;
static complex temp;
static integer km1km1;
static complex denom;
extern /* Complex */ void cdotu_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
/* ***BEGIN PROLOGUE CSPSL */
/* ***PURPOSE Solve a complex symmetric system using the factors obtained */
/* from CSPFA. */
/* ***LIBRARY SLATEC (LINPACK) */
/* ***CATEGORY D2C1 */
/* ***TYPE COMPLEX (SSPSL-S, DSPSL-D, CHPSL-C, CSPSL-C) */
/* ***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, PACKED, SOLVE, SYMMETRIC */
/* ***AUTHOR Bunch, J., (UCSD) */
/* ***DESCRIPTION */
/* CSISL solves the complex symmetric system */
/* A * X = B */
/* using the factors computed by CSPFA. */
/* On Entry */
/* AP COMPLEX(N*(N+1)/2) */
/* the output from CSPFA. */
/* N INTEGER */
/* the order of the matrix A . */
/* KVPT INTEGER(N) */
/* the pivot vector from CSPFA. */
/* B COMPLEX(N) */
/* the right hand side vector. */
/* On Return */
/* B the solution vector X . */
/* Error Condition */
/* A division by zero may occur if CSPCO has set RCOND .EQ. 0.0 */
/* or CSPFA has set INFO .NE. 0 . */
/* To compute INVERSE(A) * C where C is a matrix */
/* with P columns */
/* CALL CSPFA(AP,N,KVPT,INFO) */
/* IF (INFO .NE. 0) GO TO ... */
/* DO 10 J = 1, P */
/* CALL CSPSL(AP,N,KVPT,C(1,J)) */
/* 10 CONTINUE */
/* ***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. */
/* Stewart, LINPACK Users' Guide, SIAM, 1979. */
/* ***ROUTINES CALLED CAXPY, CDOTU */
/* ***REVISION HISTORY (YYMMDD) */
/* 780814 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890831 Modified array declarations. (WRB) */
/* 891107 Corrected category and modified routine equivalence */
/* list. (WRB) */
/* 891107 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900326 Removed duplicate information from DESCRIPTION section. */
/* (WRB) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE CSPSL */
/* LOOP BACKWARD APPLYING THE TRANSFORMATIONS AND */
/* D INVERSE TO B. */
/* ***FIRST EXECUTABLE STATEMENT CSPSL */
/* Parameter adjustments */
--b;
--kpvt;
--ap;
/* Function Body */
k = *n;
ik = *n * (*n - 1) / 2;
L10:
if (k == 0) {
goto L80;
}
kk = ik + k;
if (kpvt[k] < 0) {
goto L40;
}
/* 1 X 1 PIVOT BLOCK. */
if (k == 1) {
goto L30;
}
kp = kpvt[k];
if (kp == k) {
goto L20;
}
/* INTERCHANGE. */
i__1 = k;
temp.r = b[i__1].r, temp.i = b[i__1].i;
i__1 = k;
i__2 = kp;
b[i__1].r = b[i__2].r, b[i__1].i = b[i__2].i;
i__1 = kp;
b[i__1].r = temp.r, b[i__1].i = temp.i;
L20:
/* APPLY THE TRANSFORMATION. */
i__1 = k - 1;
caxpy_(&i__1, &b[k], &ap[ik + 1], &c__1, &b[1], &c__1);
L30:
/* APPLY D INVERSE. */
i__1 = k;
c_div(&q__1, &b[k], &ap[kk]);
b[i__1].r = q__1.r, b[i__1].i = q__1.i;
--k;
ik -= k;
goto L70;
L40:
/* 2 X 2 PIVOT BLOCK. */
ikm1 = ik - (k - 1);
if (k == 2) {
goto L60;
}
kp = (i__1 = kpvt[k], abs(i__1));
if (kp == k - 1) {
goto L50;
}
/* INTERCHANGE. */
i__1 = k - 1;
temp.r = b[i__1].r, temp.i = b[i__1].i;
i__1 = k - 1;
i__2 = kp;
b[i__1].r = b[i__2].r, b[i__1].i = b[i__2].i;
i__1 = kp;
b[i__1].r = temp.r, b[i__1].i = temp.i;
L50:
/* APPLY THE TRANSFORMATION. */
i__1 = k - 2;
caxpy_(&i__1, &b[k], &ap[ik + 1], &c__1, &b[1], &c__1);
i__1 = k - 2;
caxpy_(&i__1, &b[k - 1], &ap[ikm1 + 1], &c__1, &b[1], &c__1);
L60:
/* APPLY D INVERSE. */
km1k = ik + k - 1;
kk = ik + k;
c_div(&q__1, &ap[kk], &ap[km1k]);
ak.r = q__1.r, ak.i = q__1.i;
km1km1 = ikm1 + k - 1;
c_div(&q__1, &ap[km1km1], &ap[km1k]);
akm1.r = q__1.r, akm1.i = q__1.i;
c_div(&q__1, &b[k], &ap[km1k]);
bk.r = q__1.r, bk.i = q__1.i;
c_div(&q__1, &b[k - 1], &ap[km1k]);
bkm1.r = q__1.r, bkm1.i = q__1.i;
q__2.r = ak.r * akm1.r - ak.i * akm1.i, q__2.i = ak.r * akm1.i + ak.i *
akm1.r;
q__1.r = q__2.r - 1.f, q__1.i = q__2.i;
denom.r = q__1.r, denom.i = q__1.i;
i__1 = k;
q__3.r = akm1.r * bk.r - akm1.i * bk.i, q__3.i = akm1.r * bk.i + akm1.i *
bk.r;
q__2.r = q__3.r - bkm1.r, q__2.i = q__3.i - bkm1.i;
c_div(&q__1, &q__2, &denom);
b[i__1].r = q__1.r, b[i__1].i = q__1.i;
i__1 = k - 1;
q__3.r = ak.r * bkm1.r - ak.i * bkm1.i, q__3.i = ak.r * bkm1.i + ak.i *
bkm1.r;
q__2.r = q__3.r - bk.r, q__2.i = q__3.i - bk.i;
c_div(&q__1, &q__2, &denom);
b[i__1].r = q__1.r, b[i__1].i = q__1.i;
k += -2;
ik = ik - (k + 1) - k;
L70:
goto L10;
L80:
/* LOOP FORWARD APPLYING THE TRANSFORMATIONS. */
k = 1;
ik = 0;
L90:
if (k > *n) {
goto L160;
}
if (kpvt[k] < 0) {
goto L120;
}
/* 1 X 1 PIVOT BLOCK. */
if (k == 1) {
goto L110;
}
/* APPLY THE TRANSFORMATION. */
i__1 = k;
i__2 = k;
i__3 = k - 1;
cdotu_(&q__2, &i__3, &ap[ik + 1], &c__1, &b[1], &c__1);
q__1.r = b[i__2].r + q__2.r, q__1.i = b[i__2].i + q__2.i;
b[i__1].r = q__1.r, b[i__1].i = q__1.i;
kp = kpvt[k];
if (kp == k) {
goto L100;
}
/* INTERCHANGE. */
i__1 = k;
temp.r = b[i__1].r, temp.i = b[i__1].i;
i__1 = k;
i__2 = kp;
b[i__1].r = b[i__2].r, b[i__1].i = b[i__2].i;
i__1 = kp;
b[i__1].r = temp.r, b[i__1].i = temp.i;
L100:
L110:
ik += k;
++k;
goto L150;
L120:
/* 2 X 2 PIVOT BLOCK. */
if (k == 1) {
goto L140;
}
/* APPLY THE TRANSFORMATION. */
i__1 = k;
i__2 = k;
i__3 = k - 1;
cdotu_(&q__2, &i__3, &ap[ik + 1], &c__1, &b[1], &c__1);
q__1.r = b[i__2].r + q__2.r, q__1.i = b[i__2].i + q__2.i;
b[i__1].r = q__1.r, b[i__1].i = q__1.i;
ikp1 = ik + k;
i__1 = k + 1;
i__2 = k + 1;
i__3 = k - 1;
cdotu_(&q__2, &i__3, &ap[ikp1 + 1], &c__1, &b[1], &c__1);
q__1.r = b[i__2].r + q__2.r, q__1.i = b[i__2].i + q__2.i;
b[i__1].r = q__1.r, b[i__1].i = q__1.i;
kp = (i__1 = kpvt[k], abs(i__1));
if (kp == k) {
goto L130;
}
/* INTERCHANGE. */
i__1 = k;
temp.r = b[i__1].r, temp.i = b[i__1].i;
i__1 = k;
i__2 = kp;
b[i__1].r = b[i__2].r, b[i__1].i = b[i__2].i;
i__1 = kp;
b[i__1].r = temp.r, b[i__1].i = temp.i;
L130:
L140:
ik = ik + k + k + 1;
k += 2;
L150:
goto L90;
L160:
return 0;
} /* cspsl_ */
/* DECK CDSTP */
/* Subroutine */ int cdstp_(real *eps, S_fp f, U_fp fa, real *hmax, integer *
impl, integer *ierror, U_fp jacobn, integer *matdim, integer *maxord,
integer *mint, integer *miter, integer *ml, integer *mu, integer *n,
integer *nde, complex *ywt, real *uround, U_fp users, real *avgh,
real *avgord, real *h__, real *hused, integer *jtask, integer *mntold,
integer *mtrold, integer *nfe, integer *nje, integer *nqused,
integer *nstep, real *t, complex *y, complex *yh, complex *a, logical
*convrg, complex *dfdy, real *el, complex *fac, real *hold, integer *
ipvt, integer *jstate, integer *jstepl, integer *nq, integer *nwait,
real *rc, real *rmax, complex *save1, complex *save2, real *tq, real *
trend, integer *iswflg, integer *mtrsv, integer *mxrdsv)
{
/* Initialized data */
static logical ier = FALSE_;
/* System generated locals */
integer a_dim1, a_offset, dfdy_dim1, dfdy_offset, yh_dim1, yh_offset,
i__1, i__2, i__3, i__4, i__5, i__6;
real r__1, r__2, r__3;
doublereal d__1, d__2;
complex q__1, q__2;
/* Local variables */
static real d__;
static integer i__, j;
static real d1, hn, rh, hs, rh1, rh2, rh3, bnd;
static integer nsv;
static real erdn, told;
static integer iter;
static real erup;
static integer ntry;
static real y0nrm;
extern /* Subroutine */ int cdscl_(real *, integer *, integer *, real *,
real *, real *, real *, complex *);
static integer nfail;
extern /* Subroutine */ int cdcor_(complex *, real *, U_fp, real *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, real *, U_fp, complex
*, complex *, complex *, logical *, complex *, complex *, complex
*, real *, integer *), cdpsc_(integer *, integer *, integer *,
complex *), cdcst_(integer *, integer *, integer *, real *, real *
);
static real denom;
extern /* Subroutine */ int cdntl_(real *, S_fp, U_fp, real *, real *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, complex *, real *,
real *, U_fp, complex *, complex *, real *, integer *, integer *,
integer *, real *, complex *, complex *, logical *, real *,
complex *, logical *, integer *, integer *, integer *, real *,
real *, complex *, real *, real *, integer *, integer *), cdpst_(
real *, S_fp, U_fp, real *, integer *, U_fp, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, complex *,
real *, U_fp, complex *, complex *, complex *, real *, integer *,
integer *, complex *, complex *, complex *, logical *, integer *,
complex *, integer *, real *, integer *);
static real ctest, etest, numer;
extern doublereal scnrm2_(integer *, complex *, integer *);
static logical evalfa, evaljc, switch__;
/* ***BEGIN PROLOGUE CDSTP */
/* ***SUBSIDIARY */
/* ***PURPOSE CDSTP performs one step of the integration of an initial */
/* value problem for a system of ordinary differential */
/* equations. */
/* ***LIBRARY SLATEC (SDRIVE) */
/* ***TYPE COMPLEX (SDSTP-S, DDSTP-D, CDSTP-C) */
/* ***AUTHOR Kahaner, D. K., (NIST) */
/* National Institute of Standards and Technology */
/* Gaithersburg, MD 20899 */
/* Sutherland, C. D., (LANL) */
/* Mail Stop D466 */
/* Los Alamos National Laboratory */
/* Los Alamos, NM 87545 */
/* ***DESCRIPTION */
/* Communication with CDSTP is done with the following variables: */
/* YH An N by MAXORD+1 array containing the dependent variables */
/* and their scaled derivatives. MAXORD, the maximum order */
/* used, is currently 12 for the Adams methods and 5 for the */
/* Gear methods. YH(I,J+1) contains the J-th derivative of */
/* Y(I), scaled by H**J/factorial(J). Only Y(I), */
/* 1 .LE. I .LE. N, need be set by the calling program on */
/* the first entry. The YH array should not be altered by */
/* the calling program. When referencing YH as a */
/* 2-dimensional array, use a column length of N, as this is */
/* the value used in CDSTP. */
/* DFDY A block of locations used for partial derivatives if MITER */
/* is not 0. If MITER is 1 or 2 its length must be at least */
/* N*N. If MITER is 4 or 5 its length must be at least */
/* (2*ML+MU+1)*N. */
/* YWT An array of N locations used in convergence and error tests */
/* SAVE1 */
/* SAVE2 Arrays of length N used for temporary storage. */
/* IPVT An integer array of length N used by the linear system */
/* solvers for the storage of row interchange information. */
/* A A block of locations used to store the matrix A, when using */
/* the implicit method. If IMPL is 1, A is a MATDIM by N */
/* array. If MITER is 1 or 2 MATDIM is N, and if MITER is 4 */
/* or 5 MATDIM is 2*ML+MU+1. If IMPL is 2 its length is N. */
/* If IMPL is 3, A is a MATDIM by NDE array. */
/* JTASK An integer used on input. */
/* It has the following values and meanings: */
/* .EQ. 0 Perform the first step. This value enables */
/* the subroutine to initialize itself. */
/* .GT. 0 Take a new step continuing from the last. */
/* Assumes the last step was successful and */
/* user has not changed any parameters. */
/* .LT. 0 Take a new step with a new value of H and/or */
/* MINT and/or MITER. */
/* JSTATE A completion code with the following meanings: */
/* 1 The step was successful. */
/* 2 A solution could not be obtained with H .NE. 0. */
/* 3 A solution was not obtained in MXTRY attempts. */
/* 4 For IMPL .NE. 0, the matrix A is singular. */
/* On a return with JSTATE .GT. 1, the values of T and */
/* the YH array are as of the beginning of the last */
/* step, and H is the last step size attempted. */
/* ***ROUTINES CALLED CDCOR, CDCST, CDNTL, CDPSC, CDPST, CDSCL, SCNRM2 */
/* ***REVISION HISTORY (YYMMDD) */
/* 790601 DATE WRITTEN */
/* 900329 Initial submission to SLATEC. */
/* ***END PROLOGUE CDSTP */
/* Parameter adjustments */
dfdy_dim1 = *matdim;
dfdy_offset = 1 + dfdy_dim1;
dfdy -= dfdy_offset;
a_dim1 = *matdim;
a_offset = 1 + a_dim1;
a -= a_offset;
yh_dim1 = *n;
yh_offset = 1 + yh_dim1;
yh -= yh_offset;
--ywt;
--y;
el -= 14;
--fac;
--ipvt;
--save1;
--save2;
tq -= 4;
/* Function Body */
/* ***FIRST EXECUTABLE STATEMENT CDSTP */
nsv = *n;
bnd = 0.f;
switch__ = FALSE_;
ntry = 0;
told = *t;
nfail = 0;
if (*jtask <= 0) {
cdntl_(eps, (S_fp)f, (U_fp)fa, hmax, hold, impl, jtask, matdim,
maxord, mint, miter, ml, mu, n, nde, &save1[1], t, uround, (
U_fp)users, &y[1], &ywt[1], h__, mntold, mtrold, nfe, rc, &yh[
yh_offset], &a[a_offset], convrg, &el[14], &fac[1], &ier, &
ipvt[1], nq, nwait, &rh, rmax, &save2[1], &tq[4], trend,
iswflg, jstate);
if (*n == 0) {
goto L440;
}
if (*h__ == 0.f) {
goto L400;
}
if (ier) {
goto L420;
}
}
L100:
++ntry;
if (ntry > 50) {
goto L410;
}
*t += *h__;
cdpsc_(&c__1, n, nq, &yh[yh_offset]);
evaljc = ((r__1 = *rc - 1.f, dabs(r__1)) > .3f || *nstep >= *jstepl + 10)
&& *miter != 0;
evalfa = ! evaljc;
L110:
iter = 0;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L115: */
i__2 = i__;
i__3 = i__ + yh_dim1;
y[i__2].r = yh[i__3].r, y[i__2].i = yh[i__3].i;
}
(*f)(n, t, &y[1], &save2[1]);
if (*n == 0) {
*jstate = 6;
goto L430;
}
++(*nfe);
if (evaljc || ier) {
cdpst_(&el[14], (S_fp)f, (U_fp)fa, h__, impl, (U_fp)jacobn, matdim,
miter, ml, mu, n, nde, nq, &save2[1], t, (U_fp)users, &y[1], &
yh[yh_offset], &ywt[1], uround, nfe, nje, &a[a_offset], &dfdy[
dfdy_offset], &fac[1], &ier, &ipvt[1], &save1[1], iswflg, &
bnd, jstate);
if (*n == 0) {
goto L430;
}
if (ier) {
goto L160;
}
*convrg = FALSE_;
*rc = 1.f;
*jstepl = *nstep;
}
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* L125: */
i__3 = i__;
save1[i__3].r = 0.f, save1[i__3].i = 0.f;
}
/* Up to MXITER corrector iterations are taken. */
/* Convergence is tested by requiring the r.m.s. */
/* norm of changes to be less than EPS. The sum of */
/* the corrections is accumulated in the vector */
/* SAVE1(I). It is approximately equal to the L-th */
/* derivative of Y multiplied by */
/* H**L/(factorial(L-1)*EL(L,NQ)), and is thus */
/* proportional to the actual errors to the lowest */
/* power of H present (H**L). The YH array is not */
/* altered in the correction loop. The norm of the */
/* iterate difference is stored in D. If */
/* ITER .GT. 0, an estimate of the convergence rate */
/* constant is stored in TREND, and this is used in */
/* the convergence test. */
L130:
cdcor_(&dfdy[dfdy_offset], &el[14], (U_fp)fa, h__, ierror, impl, &ipvt[1],
matdim, miter, ml, mu, n, nde, nq, t, (U_fp)users, &y[1], &yh[
yh_offset], &ywt[1], &evalfa, &save1[1], &save2[1], &a[a_offset],
&d__, jstate);
if (*n == 0) {
goto L430;
}
if (*iswflg == 3 && *mint == 1) {
if (iter == 0) {
numer = scnrm2_(n, &save1[1], &c__1);
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
/* L132: */
i__2 = i__ * dfdy_dim1 + 1;
i__1 = i__;
dfdy[i__2].r = save1[i__1].r, dfdy[i__2].i = save1[i__1].i;
}
y0nrm = scnrm2_(n, &yh[yh_offset], &c__1);
} else {
denom = numer;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* L134: */
i__1 = i__ * dfdy_dim1 + 1;
i__3 = i__;
i__4 = i__ * dfdy_dim1 + 1;
q__1.r = save1[i__3].r - dfdy[i__4].r, q__1.i = save1[i__3].i
- dfdy[i__4].i;
dfdy[i__1].r = q__1.r, dfdy[i__1].i = q__1.i;
}
numer = scnrm2_(n, &dfdy[dfdy_offset], matdim);
if (el[*nq * 13 + 1] * numer <= *uround * 100.f * y0nrm) {
if (*rmax == 2.f) {
switch__ = TRUE_;
goto L170;
}
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L136: */
i__3 = i__ * dfdy_dim1 + 1;
i__4 = i__;
dfdy[i__3].r = save1[i__4].r, dfdy[i__3].i = save1[i__4].i;
}
if (denom != 0.f) {
/* Computing MAX */
r__1 = bnd, r__2 = numer / (denom * dabs(*h__) * el[*nq * 13
+ 1]);
bnd = dmax(r__1,r__2);
}
}
}
if (iter > 0) {
/* Computing MAX */
r__1 = *trend * .9f, r__2 = d__ / d1;
*trend = dmax(r__1,r__2);
}
d1 = d__;
/* Computing MIN */
r__1 = *trend * 2.f;
ctest = dmin(r__1,1.f) * d__;
if (ctest <= *eps) {
goto L170;
}
++iter;
if (iter < 3) {
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
/* L140: */
i__4 = i__;
i__1 = i__ + yh_dim1;
i__2 = *nq * 13 + 1;
i__5 = i__;
q__2.r = el[i__2] * save1[i__5].r, q__2.i = el[i__2] * save1[i__5]
.i;
q__1.r = yh[i__1].r + q__2.r, q__1.i = yh[i__1].i + q__2.i;
y[i__4].r = q__1.r, y[i__4].i = q__1.i;
}
(*f)(n, t, &y[1], &save2[1]);
if (*n == 0) {
*jstate = 6;
goto L430;
}
++(*nfe);
goto L130;
}
/* The corrector iteration failed to converge in */
/* MXITER tries. If partials are involved but are */
/* not up to date, they are reevaluated for the next */
/* try. Otherwise the YH array is retracted to its */
/* values before prediction, and H is reduced, if */
/* possible. If not, a no-convergence exit is taken. */
if (*convrg) {
evaljc = TRUE_;
evalfa = FALSE_;
goto L110;
}
L160:
*t = told;
cdpsc_(&c_n1, n, nq, &yh[yh_offset]);
*nwait = *nq + 2;
if (*jtask != 0 && *jtask != 2) {
*rmax = 2.f;
}
if (iter == 0) {
rh = .3f;
} else {
d__1 = (doublereal) (*eps / ctest);
rh = pow_dd(&d__1, &c_b22) * .9f;
}
if (rh * *h__ == 0.f) {
goto L400;
}
cdscl_(hmax, n, nq, rmax, h__, rc, &rh, &yh[yh_offset]);
goto L100;
/* The corrector has converged. CONVRG is set */
/* to .TRUE. if partial derivatives were used, */
/* to indicate that they may need updating on */
/* subsequent steps. The error test is made. */
L170:
*convrg = *miter != 0;
if (*ierror == 1 || *ierror == 5) {
i__4 = *nde;
for (i__ = 1; i__ <= i__4; ++i__) {
/* L180: */
i__1 = i__;
c_div(&q__1, &save1[i__], &ywt[i__]);
save2[i__1].r = q__1.r, save2[i__1].i = q__1.i;
}
} else {
i__1 = *nde;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L185: */
i__4 = i__;
i__2 = i__;
/* Computing MAX */
r__2 = c_abs(&y[i__]), r__3 = c_abs(&ywt[i__]);
r__1 = dmax(r__2,r__3);
q__1.r = save1[i__2].r / r__1, q__1.i = save1[i__2].i / r__1;
save2[i__4].r = q__1.r, save2[i__4].i = q__1.i;
}
}
etest = scnrm2_(nde, &save2[1], &c__1) / (tq[*nq * 3 + 2] * sqrt((real) (*
nde)));
/* The error test failed. NFAIL keeps track of */
/* multiple failures. Restore T and the YH */
/* array to their previous values, and prepare */
/* to try the step again. Compute the optimum */
/* step size for this or one lower order. */
if (etest > *eps) {
*t = told;
cdpsc_(&c_n1, n, nq, &yh[yh_offset]);
++nfail;
if (nfail < 3 || *nq == 1) {
if (*jtask != 0 && *jtask != 2) {
*rmax = 2.f;
}
d__1 = (doublereal) (etest / *eps);
d__2 = (doublereal) (1.f / (*nq + 1));
rh2 = 1.f / (pow_dd(&d__1, &d__2) * 1.2f);
if (*nq > 1) {
if (*ierror == 1 || *ierror == 5) {
i__4 = *nde;
for (i__ = 1; i__ <= i__4; ++i__) {
/* L190: */
i__2 = i__;
c_div(&q__1, &yh[i__ + (*nq + 1) * yh_dim1], &ywt[i__]
);
save2[i__2].r = q__1.r, save2[i__2].i = q__1.i;
}
} else {
i__2 = *nde;
for (i__ = 1; i__ <= i__2; ++i__) {
/* L195: */
i__4 = i__;
i__1 = i__ + (*nq + 1) * yh_dim1;
/* Computing MAX */
r__2 = c_abs(&y[i__]), r__3 = c_abs(&ywt[i__]);
r__1 = dmax(r__2,r__3);
q__1.r = yh[i__1].r / r__1, q__1.i = yh[i__1].i /
r__1;
save2[i__4].r = q__1.r, save2[i__4].i = q__1.i;
}
}
erdn = scnrm2_(nde, &save2[1], &c__1) / (tq[*nq * 3 + 1] *
sqrt((real) (*nde)));
/* Computing MAX */
d__1 = (doublereal) (erdn / *eps);
d__2 = (doublereal) (1.f / *nq);
r__1 = 1.f, r__2 = pow_dd(&d__1, &d__2) * 1.3f;
rh1 = 1.f / dmax(r__1,r__2);
if (rh2 < rh1) {
--(*nq);
*rc = *rc * el[*nq * 13 + 1] / el[(*nq + 1) * 13 + 1];
rh = rh1;
} else {
rh = rh2;
}
} else {
rh = rh2;
}
*nwait = *nq + 2;
if (rh * *h__ == 0.f) {
goto L400;
}
cdscl_(hmax, n, nq, rmax, h__, rc, &rh, &yh[yh_offset]);
goto L100;
}
/* Control reaches this section if the error test has */
/* failed MXFAIL or more times. It is assumed that the */
/* derivatives that have accumulated in the YH array have */
/* errors of the wrong order. Hence the first derivative */
/* is recomputed, the order is set to 1, and the step is */
/* retried. */
nfail = 0;
*jtask = 2;
i__4 = *n;
for (i__ = 1; i__ <= i__4; ++i__) {
/* L215: */
i__1 = i__;
i__2 = i__ + yh_dim1;
y[i__1].r = yh[i__2].r, y[i__1].i = yh[i__2].i;
}
cdntl_(eps, (S_fp)f, (U_fp)fa, hmax, hold, impl, jtask, matdim,
maxord, mint, miter, ml, mu, n, nde, &save1[1], t, uround, (
U_fp)users, &y[1], &ywt[1], h__, mntold, mtrold, nfe, rc, &yh[
yh_offset], &a[a_offset], convrg, &el[14], &fac[1], &ier, &
ipvt[1], nq, nwait, &rh, rmax, &save2[1], &tq[4], trend,
iswflg, jstate);
*rmax = 10.f;
if (*n == 0) {
goto L440;
}
if (*h__ == 0.f) {
goto L400;
}
if (ier) {
goto L420;
}
goto L100;
}
/* After a successful step, update the YH array. */
++(*nstep);
*hused = *h__;
*nqused = *nq;
*avgh = ((*nstep - 1) * *avgh + *h__) / *nstep;
*avgord = ((*nstep - 1) * *avgord + *nq) / *nstep;
i__1 = *nq + 1;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* L230: */
i__4 = i__ + j * yh_dim1;
i__5 = i__ + j * yh_dim1;
i__3 = j + *nq * 13;
i__6 = i__;
q__2.r = el[i__3] * save1[i__6].r, q__2.i = el[i__3] * save1[i__6]
.i;
q__1.r = yh[i__5].r + q__2.r, q__1.i = yh[i__5].i + q__2.i;
yh[i__4].r = q__1.r, yh[i__4].i = q__1.i;
}
}
i__4 = *n;
for (i__ = 1; i__ <= i__4; ++i__) {
/* L235: */
i__5 = i__;
i__3 = i__ + yh_dim1;
y[i__5].r = yh[i__3].r, y[i__5].i = yh[i__3].i;
}
/* If ISWFLG is 3, consider */
/* changing integration methods. */
if (*iswflg == 3) {
if (bnd != 0.f) {
if (*mint == 1 && *nq <= 5) {
/* Computing MAX */
d__1 = (doublereal) (etest / *eps);
d__2 = (doublereal) (1.f / (*nq + 1));
r__1 = *uround, r__2 = pow_dd(&d__1, &d__2);
hn = dabs(*h__) / dmax(r__1,r__2);
/* Computing MIN */
r__1 = hn, r__2 = 1.f / (el[*nq * 13 + 1] * 2.f * bnd);
hn = dmin(r__1,r__2);
/* Computing MAX */
d__1 = (doublereal) (etest / (*eps * el[*nq + 14]));
d__2 = (doublereal) (1.f / (*nq + 1));
r__1 = *uround, r__2 = pow_dd(&d__1, &d__2);
hs = dabs(*h__) / dmax(r__1,r__2);
if (hs > hn * 1.2f) {
*mint = 2;
*mntold = *mint;
*miter = *mtrsv;
*mtrold = *miter;
*maxord = min(*mxrdsv,5);
*rc = 0.f;
*rmax = 10.f;
*trend = 1.f;
cdcst_(maxord, mint, iswflg, &el[14], &tq[4]);
*nwait = *nq + 2;
}
} else if (*mint == 2) {
/* Computing MAX */
d__1 = (doublereal) (etest / *eps);
d__2 = (doublereal) (1.f / (*nq + 1));
r__1 = *uround, r__2 = pow_dd(&d__1, &d__2);
hs = dabs(*h__) / dmax(r__1,r__2);
/* Computing MAX */
d__1 = (doublereal) (etest * el[*nq + 14] / *eps);
d__2 = (doublereal) (1.f / (*nq + 1));
r__1 = *uround, r__2 = pow_dd(&d__1, &d__2);
hn = dabs(*h__) / dmax(r__1,r__2);
/* Computing MIN */
r__1 = hn, r__2 = 1.f / (el[*nq * 13 + 1] * 2.f * bnd);
hn = dmin(r__1,r__2);
if (hn >= hs) {
*mint = 1;
*mntold = *mint;
*miter = 0;
*mtrold = *miter;
*maxord = min(*mxrdsv,12);
*rmax = 10.f;
*trend = 1.f;
*convrg = FALSE_;
cdcst_(maxord, mint, iswflg, &el[14], &tq[4]);
*nwait = *nq + 2;
}
}
}
}
if (switch__) {
*mint = 2;
*mntold = *mint;
*miter = *mtrsv;
*mtrold = *miter;
*maxord = min(*mxrdsv,5);
*nq = min(*nq,*maxord);
*rc = 0.f;
*rmax = 10.f;
*trend = 1.f;
cdcst_(maxord, mint, iswflg, &el[14], &tq[4]);
*nwait = *nq + 2;
}
/* Consider changing H if NWAIT = 1. Otherwise */
/* decrease NWAIT by 1. If NWAIT is then 1 and */
/* NQ.LT.MAXORD, then SAVE1 is saved for use in */
/* a possible order increase on the next step. */
if (*jtask == 0 || *jtask == 2) {
/* Computing MAX */
d__1 = (doublereal) (etest / *eps);
d__2 = (doublereal) (1.f / (*nq + 1));
r__1 = *uround, r__2 = pow_dd(&d__1, &d__2) * 1.2f;
rh = 1.f / dmax(r__1,r__2);
if (rh > 1.f) {
cdscl_(hmax, n, nq, rmax, h__, rc, &rh, &yh[yh_offset]);
}
} else if (*nwait > 1) {
--(*nwait);
if (*nwait == 1 && *nq < *maxord) {
i__5 = *nde;
for (i__ = 1; i__ <= i__5; ++i__) {
/* L250: */
i__3 = i__ + (*maxord + 1) * yh_dim1;
i__4 = i__;
yh[i__3].r = save1[i__4].r, yh[i__3].i = save1[i__4].i;
}
}
/* If a change in H is considered, an increase or decrease in */
/* order by one is considered also. A change in H is made */
/* only if it is by a factor of at least TRSHLD. Factors */
/* RH1, RH2, and RH3 are computed, by which H could be */
/* multiplied at order NQ - 1, order NQ, or order NQ + 1, */
/* respectively. The largest of these is determined and the */
/* new order chosen accordingly. If the order is to be */
/* increased, we compute one additional scaled derivative. */
/* If there is a change of order, reset NQ and the */
/* coefficients. In any case H is reset according to RH and */
/* the YH array is rescaled. */
} else {
if (*nq == 1) {
rh1 = 0.f;
} else {
if (*ierror == 1 || *ierror == 5) {
i__3 = *nde;
for (i__ = 1; i__ <= i__3; ++i__) {
/* L270: */
i__4 = i__;
c_div(&q__1, &yh[i__ + (*nq + 1) * yh_dim1], &ywt[i__]);
save2[i__4].r = q__1.r, save2[i__4].i = q__1.i;
}
} else {
i__4 = *nde;
for (i__ = 1; i__ <= i__4; ++i__) {
/* L275: */
i__3 = i__;
i__5 = i__ + (*nq + 1) * yh_dim1;
/* Computing MAX */
r__2 = c_abs(&y[i__]), r__3 = c_abs(&ywt[i__]);
r__1 = dmax(r__2,r__3);
q__1.r = yh[i__5].r / r__1, q__1.i = yh[i__5].i / r__1;
save2[i__3].r = q__1.r, save2[i__3].i = q__1.i;
}
}
erdn = scnrm2_(nde, &save2[1], &c__1) / (tq[*nq * 3 + 1] * sqrt((
real) (*nde)));
/* Computing MAX */
d__1 = (doublereal) (erdn / *eps);
d__2 = (doublereal) (1.f / *nq);
r__1 = *uround, r__2 = pow_dd(&d__1, &d__2) * 1.3f;
rh1 = 1.f / dmax(r__1,r__2);
}
/* Computing MAX */
d__1 = (doublereal) (etest / *eps);
d__2 = (doublereal) (1.f / (*nq + 1));
r__1 = *uround, r__2 = pow_dd(&d__1, &d__2) * 1.2f;
rh2 = 1.f / dmax(r__1,r__2);
if (*nq == *maxord) {
rh3 = 0.f;
} else {
if (*ierror == 1 || *ierror == 5) {
i__3 = *nde;
for (i__ = 1; i__ <= i__3; ++i__) {
/* L290: */
i__5 = i__;
i__4 = i__;
i__6 = i__ + (*maxord + 1) * yh_dim1;
q__2.r = save1[i__4].r - yh[i__6].r, q__2.i = save1[i__4]
.i - yh[i__6].i;
c_div(&q__1, &q__2, &ywt[i__]);
save2[i__5].r = q__1.r, save2[i__5].i = q__1.i;
}
} else {
i__5 = *nde;
for (i__ = 1; i__ <= i__5; ++i__) {
i__4 = i__;
i__6 = i__;
i__3 = i__ + (*maxord + 1) * yh_dim1;
q__2.r = save1[i__6].r - yh[i__3].r, q__2.i = save1[i__6]
.i - yh[i__3].i;
/* Computing MAX */
r__2 = c_abs(&y[i__]), r__3 = c_abs(&ywt[i__]);
r__1 = dmax(r__2,r__3);
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
save2[i__4].r = q__1.r, save2[i__4].i = q__1.i;
/* L295: */
}
}
erup = scnrm2_(nde, &save2[1], &c__1) / (tq[*nq * 3 + 3] * sqrt((
real) (*nde)));
/* Computing MAX */
d__1 = (doublereal) (erup / *eps);
d__2 = (doublereal) (1.f / (*nq + 2));
r__1 = *uround, r__2 = pow_dd(&d__1, &d__2) * 1.4f;
rh3 = 1.f / dmax(r__1,r__2);
}
if (rh1 > rh2 && rh1 >= rh3) {
rh = rh1;
if (rh <= 1.f) {
goto L380;
}
--(*nq);
*rc = *rc * el[*nq * 13 + 1] / el[(*nq + 1) * 13 + 1];
} else if (rh2 >= rh1 && rh2 >= rh3) {
rh = rh2;
if (rh <= 1.f) {
goto L380;
}
} else {
rh = rh3;
if (rh <= 1.f) {
goto L380;
}
i__5 = *n;
for (i__ = 1; i__ <= i__5; ++i__) {
/* L360: */
i__4 = i__ + (*nq + 2) * yh_dim1;
i__6 = i__;
i__3 = *nq + 1 + *nq * 13;
q__2.r = el[i__3] * save1[i__6].r, q__2.i = el[i__3] * save1[
i__6].i;
i__2 = *nq + 1;
d__1 = (doublereal) i__2;
q__1.r = q__2.r / d__1, q__1.i = q__2.i / d__1;
yh[i__4].r = q__1.r, yh[i__4].i = q__1.i;
}
++(*nq);
*rc = *rc * el[*nq * 13 + 1] / el[(*nq - 1) * 13 + 1];
}
if (*iswflg == 3 && *mint == 1) {
if (bnd != 0.f) {
/* Computing MIN */
r__1 = rh, r__2 = 1.f / (el[*nq * 13 + 1] * 2.f * bnd * dabs(*
h__));
rh = dmin(r__1,r__2);
}
}
cdscl_(hmax, n, nq, rmax, h__, rc, &rh, &yh[yh_offset]);
*rmax = 10.f;
L380:
*nwait = *nq + 2;
}
/* All returns are made through this section. H is saved */
/* in HOLD to allow the caller to change H on the next step */
*jstate = 1;
*hold = *h__;
return 0;
L400:
*jstate = 2;
*hold = *h__;
i__4 = *n;
for (i__ = 1; i__ <= i__4; ++i__) {
/* L405: */
i__6 = i__;
i__3 = i__ + yh_dim1;
y[i__6].r = yh[i__3].r, y[i__6].i = yh[i__3].i;
}
return 0;
L410:
*jstate = 3;
*hold = *h__;
return 0;
L420:
*jstate = 4;
*hold = *h__;
return 0;
L430:
*t = told;
cdpsc_(&c_n1, &nsv, nq, &yh[yh_offset]);
i__6 = nsv;
for (i__ = 1; i__ <= i__6; ++i__) {
/* L435: */
i__3 = i__;
i__4 = i__ + yh_dim1;
y[i__3].r = yh[i__4].r, y[i__3].i = yh[i__4].i;
}
L440:
*hold = *h__;
return 0;
} /* cdstp_ */
/* Subroutine */ int ctrsv_(char *uplo, char *trans, char *diag, integer *n,
complex *a, integer *lda, complex *x, integer *incx)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
complex q__1, q__2, q__3;
/* Builtin functions */
void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *);
/* Local variables */
static integer info;
static complex temp;
static integer i__, j;
extern logical lsame_(char *, char *);
static integer ix, jx, kx;
extern /* Subroutine */ int xerbla_(char *, integer *);
static logical noconj, nounit;
#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)]
/* Purpose
=======
CTRSV solves one of the systems of equations
A*x = b, or A'*x = b, or conjg( A' )*x = b,
where b and x are n element vectors and A is an n by n unit, or
non-unit, upper or lower triangular matrix.
No test for singularity or near-singularity is included in this
routine. Such tests must be performed before calling this routine.
Parameters
==========
UPLO - CHARACTER*1.
On entry, UPLO specifies whether the matrix is an upper or
lower triangular matrix as follows:
UPLO = 'U' or 'u' A is an upper triangular matrix.
UPLO = 'L' or 'l' A is a lower triangular matrix.
Unchanged on exit.
TRANS - CHARACTER*1.
On entry, TRANS specifies the equations to be solved as
follows:
TRANS = 'N' or 'n' A*x = b.
TRANS = 'T' or 't' A'*x = b.
TRANS = 'C' or 'c' conjg( A' )*x = b.
Unchanged on exit.
DIAG - CHARACTER*1.
On entry, DIAG specifies whether or not A is unit
triangular as follows:
DIAG = 'U' or 'u' A is assumed to be unit triangular.
DIAG = 'N' or 'n' A is not assumed to be unit
triangular.
Unchanged on exit.
N - INTEGER.
On entry, N specifies the order of the matrix A.
N must be at least zero.
Unchanged on exit.
A - COMPLEX array of DIMENSION ( LDA, n ).
Before entry with UPLO = 'U' or 'u', the leading n by n
upper triangular part of the array A must contain the upper
triangular matrix and the strictly lower triangular part of
A is not referenced.
Before entry with UPLO = 'L' or 'l', the leading n by n
lower triangular part of the array A must contain the lower
triangular matrix and the strictly upper triangular part of
A is not referenced.
Note that when DIAG = 'U' or 'u', the diagonal elements of
A are not referenced either, but are assumed to be unity.
Unchanged on exit.
LDA - INTEGER.
On entry, LDA specifies the first dimension of A as declared
in the calling (sub) program. LDA must be at least
max( 1, n ).
Unchanged on exit.
X - COMPLEX array of dimension at least
( 1 + ( n - 1 )*abs( INCX ) ).
Before entry, the incremented array X must contain the n
element right-hand side vector b. On exit, X is overwritten
with the solution vector x.
INCX - INTEGER.
On entry, INCX specifies the increment for the elements of
X. INCX must not be zero.
Unchanged on exit.
Level 2 Blas routine.
-- Written on 22-October-1986.
Jack Dongarra, Argonne National Lab.
Jeremy Du Croz, Nag Central Office.
Sven Hammarling, Nag Central Office.
Richard Hanson, Sandia National Labs.
Test the input parameters.
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--x;
/* Function Body */
info = 0;
if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
info = 1;
} else if (! lsame_(trans, "N") && ! lsame_(trans,
"T") && ! lsame_(trans, "C")) {
info = 2;
} else if (! lsame_(diag, "U") && ! lsame_(diag,
"N")) {
info = 3;
} else if (*n < 0) {
info = 4;
} else if (*lda < max(1,*n)) {
info = 6;
} else if (*incx == 0) {
info = 8;
}
if (info != 0) {
xerbla_("CTRSV ", &info);
return 0;
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
noconj = lsame_(trans, "T");
nounit = lsame_(diag, "N");
/* Set up the start point in X if the increment is not unity. This
will be ( N - 1 )*INCX too small for descending loops. */
if (*incx <= 0) {
kx = 1 - (*n - 1) * *incx;
} else if (*incx != 1) {
kx = 1;
}
/* Start the operations. In this version the elements of A are
accessed sequentially with one pass through A. */
if (lsame_(trans, "N")) {
/* Form x := inv( A )*x. */
if (lsame_(uplo, "U")) {
if (*incx == 1) {
for (j = *n; j >= 1; --j) {
i__1 = j;
if (x[i__1].r != 0.f || x[i__1].i != 0.f) {
if (nounit) {
i__1 = j;
c_div(&q__1, &x[j], &a_ref(j, j));
x[i__1].r = q__1.r, x[i__1].i = q__1.i;
}
i__1 = j;
temp.r = x[i__1].r, temp.i = x[i__1].i;
for (i__ = j - 1; i__ >= 1; --i__) {
i__1 = i__;
i__2 = i__;
i__3 = a_subscr(i__, j);
q__2.r = temp.r * a[i__3].r - temp.i * a[i__3].i,
q__2.i = temp.r * a[i__3].i + temp.i * a[
i__3].r;
q__1.r = x[i__2].r - q__2.r, q__1.i = x[i__2].i -
q__2.i;
x[i__1].r = q__1.r, x[i__1].i = q__1.i;
/* L10: */
}
}
/* L20: */
}
} else {
jx = kx + (*n - 1) * *incx;
for (j = *n; j >= 1; --j) {
i__1 = jx;
if (x[i__1].r != 0.f || x[i__1].i != 0.f) {
if (nounit) {
i__1 = jx;
c_div(&q__1, &x[jx], &a_ref(j, j));
x[i__1].r = q__1.r, x[i__1].i = q__1.i;
}
i__1 = jx;
temp.r = x[i__1].r, temp.i = x[i__1].i;
ix = jx;
for (i__ = j - 1; i__ >= 1; --i__) {
ix -= *incx;
i__1 = ix;
i__2 = ix;
i__3 = a_subscr(i__, j);
q__2.r = temp.r * a[i__3].r - temp.i * a[i__3].i,
q__2.i = temp.r * a[i__3].i + temp.i * a[
i__3].r;
q__1.r = x[i__2].r - q__2.r, q__1.i = x[i__2].i -
q__2.i;
x[i__1].r = q__1.r, x[i__1].i = q__1.i;
/* L30: */
}
}
jx -= *incx;
/* L40: */
}
}
} else {
if (*incx == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
if (nounit) {
i__2 = j;
c_div(&q__1, &x[j], &a_ref(j, j));
x[i__2].r = q__1.r, x[i__2].i = q__1.i;
}
i__2 = j;
temp.r = x[i__2].r, temp.i = x[i__2].i;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = a_subscr(i__, j);
q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
q__2.i = temp.r * a[i__5].i + temp.i * a[
i__5].r;
q__1.r = x[i__4].r - q__2.r, q__1.i = x[i__4].i -
q__2.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
/* L50: */
}
}
/* L60: */
}
} else {
jx = kx;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = jx;
if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
if (nounit) {
i__2 = jx;
c_div(&q__1, &x[jx], &a_ref(j, j));
x[i__2].r = q__1.r, x[i__2].i = q__1.i;
}
i__2 = jx;
temp.r = x[i__2].r, temp.i = x[i__2].i;
ix = jx;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
ix += *incx;
i__3 = ix;
i__4 = ix;
i__5 = a_subscr(i__, j);
q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
q__2.i = temp.r * a[i__5].i + temp.i * a[
i__5].r;
q__1.r = x[i__4].r - q__2.r, q__1.i = x[i__4].i -
q__2.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
/* L70: */
}
}
jx += *incx;
/* L80: */
}
}
}
} else {
/* Form x := inv( A' )*x or x := inv( conjg( A' ) )*x. */
if (lsame_(uplo, "U")) {
if (*incx == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
temp.r = x[i__2].r, temp.i = x[i__2].i;
if (noconj) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = a_subscr(i__, j);
i__4 = i__;
q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[
i__4].i, q__2.i = a[i__3].r * x[i__4].i +
a[i__3].i * x[i__4].r;
q__1.r = temp.r - q__2.r, q__1.i = temp.i -
q__2.i;
temp.r = q__1.r, temp.i = q__1.i;
/* L90: */
}
if (nounit) {
c_div(&q__1, &temp, &a_ref(j, j));
temp.r = q__1.r, temp.i = q__1.i;
}
} else {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
r_cnjg(&q__3, &a_ref(i__, j));
i__3 = i__;
q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i,
q__2.i = q__3.r * x[i__3].i + q__3.i * x[
i__3].r;
q__1.r = temp.r - q__2.r, q__1.i = temp.i -
q__2.i;
temp.r = q__1.r, temp.i = q__1.i;
/* L100: */
}
if (nounit) {
r_cnjg(&q__2, &a_ref(j, j));
c_div(&q__1, &temp, &q__2);
temp.r = q__1.r, temp.i = q__1.i;
}
}
i__2 = j;
x[i__2].r = temp.r, x[i__2].i = temp.i;
/* L110: */
}
} else {
jx = kx;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
ix = kx;
i__2 = jx;
temp.r = x[i__2].r, temp.i = x[i__2].i;
if (noconj) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = a_subscr(i__, j);
i__4 = ix;
q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[
i__4].i, q__2.i = a[i__3].r * x[i__4].i +
a[i__3].i * x[i__4].r;
q__1.r = temp.r - q__2.r, q__1.i = temp.i -
q__2.i;
temp.r = q__1.r, temp.i = q__1.i;
ix += *incx;
/* L120: */
}
if (nounit) {
c_div(&q__1, &temp, &a_ref(j, j));
temp.r = q__1.r, temp.i = q__1.i;
}
} else {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
r_cnjg(&q__3, &a_ref(i__, j));
i__3 = ix;
q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i,
q__2.i = q__3.r * x[i__3].i + q__3.i * x[
i__3].r;
q__1.r = temp.r - q__2.r, q__1.i = temp.i -
q__2.i;
temp.r = q__1.r, temp.i = q__1.i;
ix += *incx;
/* L130: */
}
if (nounit) {
r_cnjg(&q__2, &a_ref(j, j));
c_div(&q__1, &temp, &q__2);
temp.r = q__1.r, temp.i = q__1.i;
}
}
i__2 = jx;
x[i__2].r = temp.r, x[i__2].i = temp.i;
jx += *incx;
/* L140: */
}
}
} else {
if (*incx == 1) {
for (j = *n; j >= 1; --j) {
i__1 = j;
temp.r = x[i__1].r, temp.i = x[i__1].i;
if (noconj) {
i__1 = j + 1;
for (i__ = *n; i__ >= i__1; --i__) {
i__2 = a_subscr(i__, j);
i__3 = i__;
q__2.r = a[i__2].r * x[i__3].r - a[i__2].i * x[
i__3].i, q__2.i = a[i__2].r * x[i__3].i +
a[i__2].i * x[i__3].r;
q__1.r = temp.r - q__2.r, q__1.i = temp.i -
q__2.i;
temp.r = q__1.r, temp.i = q__1.i;
/* L150: */
}
if (nounit) {
c_div(&q__1, &temp, &a_ref(j, j));
temp.r = q__1.r, temp.i = q__1.i;
}
} else {
i__1 = j + 1;
for (i__ = *n; i__ >= i__1; --i__) {
r_cnjg(&q__3, &a_ref(i__, j));
i__2 = i__;
q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i,
q__2.i = q__3.r * x[i__2].i + q__3.i * x[
i__2].r;
q__1.r = temp.r - q__2.r, q__1.i = temp.i -
q__2.i;
temp.r = q__1.r, temp.i = q__1.i;
/* L160: */
}
if (nounit) {
r_cnjg(&q__2, &a_ref(j, j));
c_div(&q__1, &temp, &q__2);
temp.r = q__1.r, temp.i = q__1.i;
}
}
i__1 = j;
x[i__1].r = temp.r, x[i__1].i = temp.i;
/* L170: */
}
} else {
kx += (*n - 1) * *incx;
jx = kx;
for (j = *n; j >= 1; --j) {
ix = kx;
i__1 = jx;
temp.r = x[i__1].r, temp.i = x[i__1].i;
if (noconj) {
i__1 = j + 1;
for (i__ = *n; i__ >= i__1; --i__) {
i__2 = a_subscr(i__, j);
i__3 = ix;
q__2.r = a[i__2].r * x[i__3].r - a[i__2].i * x[
i__3].i, q__2.i = a[i__2].r * x[i__3].i +
a[i__2].i * x[i__3].r;
q__1.r = temp.r - q__2.r, q__1.i = temp.i -
q__2.i;
temp.r = q__1.r, temp.i = q__1.i;
ix -= *incx;
/* L180: */
}
if (nounit) {
c_div(&q__1, &temp, &a_ref(j, j));
temp.r = q__1.r, temp.i = q__1.i;
}
} else {
i__1 = j + 1;
for (i__ = *n; i__ >= i__1; --i__) {
r_cnjg(&q__3, &a_ref(i__, j));
i__2 = ix;
q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i,
q__2.i = q__3.r * x[i__2].i + q__3.i * x[
i__2].r;
q__1.r = temp.r - q__2.r, q__1.i = temp.i -
q__2.i;
temp.r = q__1.r, temp.i = q__1.i;
ix -= *incx;
/* L190: */
}
if (nounit) {
r_cnjg(&q__2, &a_ref(j, j));
c_div(&q__1, &temp, &q__2);
temp.r = q__1.r, temp.i = q__1.i;
}
}
i__1 = jx;
x[i__1].r = temp.r, x[i__1].i = temp.i;
jx -= *incx;
/* L200: */
}
}
}
}
return 0;
/* End of CTRSV . */
} /* ctrsv_ */
/* Complex */ VOID clatm2_slu(complex * ret_val, integer *m, integer *n, integer
*i, integer *j, integer *kl, integer *ku, integer *idist, integer *
iseed, complex *d, integer *igrade, complex *dl, complex *dr, integer
*ipvtng, integer *iwork, real *sparse)
{
/* System generated locals */
integer i__1, i__2;
complex q__1, q__2, q__3;
/* Builtin functions */
void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *);
/* Local variables */
static integer isub, jsub;
static complex ctemp;
extern /* Complex */ VOID clarnd_slu(complex *, integer *, integer *);
extern doublereal dlaran_sluslu(integer *);
/* -- LAPACK auxiliary test routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
CLATM2 returns the (I,J) entry of a random matrix of dimension
(M, N) described by the other paramters. It is called by the
CLATMR routine in order to build random test matrices. No error
checking on parameters is done, because this routine is called in
a tight loop by CLATMR which has already checked the parameters.
Use of CLATM2 differs from CLATM3 in the order in which the random
number generator is called to fill in random matrix entries.
With CLATM2, the generator is called to fill in the pivoted matrix
columnwise. With CLATM3, the generator is called to fill in the
matrix columnwise, after which it is pivoted. Thus, CLATM3 can
be used to construct random matrices which differ only in their
order of rows and/or columns. CLATM2 is used to construct band
matrices while avoiding calling the random number generator for
entries outside the band (and therefore generating random numbers
The matrix whose (I,J) entry is returned is constructed as
follows (this routine only computes one entry):
If I is outside (1..M) or J is outside (1..N), return zero
(this is convenient for generating matrices in band format).
Generate a matrix A with random entries of distribution IDIST.
Set the diagonal to D.
Grade the matrix, if desired, from the left (by DL) and/or
from the right (by DR or DL) as specified by IGRADE.
Permute, if desired, the rows and/or columns as specified by
IPVTNG and IWORK.
Band the matrix to have lower bandwidth KL and upper
bandwidth KU.
Set random entries to zero as specified by SPARSE.
Arguments
=========
M - INTEGER
Number of rows of matrix. Not modified.
N - INTEGER
Number of columns of matrix. Not modified.
I - INTEGER
Row of entry to be returned. Not modified.
J - INTEGER
Column of entry to be returned. Not modified.
KL - INTEGER
Lower bandwidth. Not modified.
KU - INTEGER
Upper bandwidth. Not modified.
IDIST - INTEGER
On entry, IDIST specifies the type of distribution to be
used to generate a random matrix .
1 => real and imaginary parts each UNIFORM( 0, 1 )
2 => real and imaginary parts each UNIFORM( -1, 1 )
3 => real and imaginary parts each NORMAL( 0, 1 )
4 => complex number uniform in DISK( 0 , 1 )
Not modified.
ISEED - INTEGER array of dimension ( 4 )
Seed for random number generator.
Changed on exit.
D - COMPLEX array of dimension ( MIN( I , J ) )
Diagonal entries of matrix. Not modified.
IGRADE - INTEGER
Specifies grading of matrix as follows:
0 => no grading
1 => matrix premultiplied by diag( DL )
2 => matrix postmultiplied by diag( DR )
3 => matrix premultiplied by diag( DL ) and
postmultiplied by diag( DR )
4 => matrix premultiplied by diag( DL ) and
postmultiplied by inv( diag( DL ) )
5 => matrix premultiplied by diag( DL ) and
postmultiplied by diag( CONJG(DL) )
6 => matrix premultiplied by diag( DL ) and
postmultiplied by diag( DL )
Not modified.
DL - COMPLEX array ( I or J, as appropriate )
Left scale factors for grading matrix. Not modified.
DR - COMPLEX array ( I or J, as appropriate )
Right scale factors for grading matrix. Not modified.
IPVTNG - INTEGER
On entry specifies pivoting permutations as follows:
0 => none.
1 => row pivoting.
2 => column pivoting.
3 => full pivoting, i.e., on both sides.
Not modified.
IWORK - INTEGER array ( I or J, as appropriate )
This array specifies the permutation used. The
row (or column) in position K was originally in
position IWORK( K ).
This differs from IWORK for CLATM3. Not modified.
SPARSE - REAL between 0. and 1.
On entry specifies the sparsity of the matrix
if sparse matix is to be generated.
SPARSE should lie between 0 and 1.
A uniform ( 0, 1 ) random number x is generated and
compared to SPARSE; if x is larger the matrix entry
is unchanged and if x is smaller the entry is set
to zero. Thus on the average a fraction SPARSE of the
entries will be set to zero.
Not modified.
=====================================================================
-----------------------------------------------------------------------
Check for I and J in range
Parameter adjustments */
--iwork;
--dr;
--dl;
--d;
--iseed;
/* Function Body */
if (*i < 1 || *i > *m || *j < 1 || *j > *n) {
ret_val->r = 0.f, ret_val->i = 0.f;
return ;
}
/* Check for banding */
if (*j > *i + *ku || *j < *i - *kl) {
ret_val->r = 0.f, ret_val->i = 0.f;
return ;
}
/* Check for sparsity */
if (*sparse > 0.f) {
if (dlaran_sluslu(&iseed[1]) < *sparse) {
ret_val->r = 0.f, ret_val->i = 0.f;
return ;
}
}
/* Compute subscripts depending on IPVTNG */
if (*ipvtng == 0) {
isub = *i;
jsub = *j;
} else if (*ipvtng == 1) {
isub = iwork[*i];
jsub = *j;
} else if (*ipvtng == 2) {
isub = *i;
jsub = iwork[*j];
} else if (*ipvtng == 3) {
isub = iwork[*i];
jsub = iwork[*j];
}
/* Compute entry and grade it according to IGRADE */
if (isub == jsub) {
i__1 = isub;
ctemp.r = d[i__1].r, ctemp.i = d[i__1].i;
} else {
clarnd_slu(&q__1, idist, &iseed[1]);
ctemp.r = q__1.r, ctemp.i = q__1.i;
}
if (*igrade == 1) {
i__1 = isub;
q__1.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__1.i =
ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
ctemp.r = q__1.r, ctemp.i = q__1.i;
} else if (*igrade == 2) {
i__1 = jsub;
q__1.r = ctemp.r * dr[i__1].r - ctemp.i * dr[i__1].i, q__1.i =
ctemp.r * dr[i__1].i + ctemp.i * dr[i__1].r;
ctemp.r = q__1.r, ctemp.i = q__1.i;
} else if (*igrade == 3) {
i__1 = isub;
q__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__2.i =
ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
i__2 = jsub;
q__1.r = q__2.r * dr[i__2].r - q__2.i * dr[i__2].i, q__1.i = q__2.r *
dr[i__2].i + q__2.i * dr[i__2].r;
ctemp.r = q__1.r, ctemp.i = q__1.i;
} else if (*igrade == 4 && isub != jsub) {
i__1 = isub;
q__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__2.i =
ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
c_div(&q__1, &q__2, &dl[jsub]);
ctemp.r = q__1.r, ctemp.i = q__1.i;
} else if (*igrade == 5) {
i__1 = isub;
q__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__2.i =
ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
r_cnjg(&q__3, &dl[jsub]);
q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = q__2.r * q__3.i
+ q__2.i * q__3.r;
ctemp.r = q__1.r, ctemp.i = q__1.i;
} else if (*igrade == 6) {
i__1 = isub;
q__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__2.i =
ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
i__2 = jsub;
q__1.r = q__2.r * dl[i__2].r - q__2.i * dl[i__2].i, q__1.i = q__2.r *
dl[i__2].i + q__2.i * dl[i__2].r;
ctemp.r = q__1.r, ctemp.i = q__1.i;
}
ret_val->r = ctemp.r, ret_val->i = ctemp.i;
return ;
/* End of CLATM2 */
} /* clatm2_slu */
/* Subroutine */ int clagsy_(integer *n, integer *k, real *d, complex *a,
integer *lda, integer *iseed, complex *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8,
i__9;
doublereal d__1;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */
double c_abs(complex *);
void c_div(complex *, complex *, complex *);
/* Local variables */
static integer i, j;
extern /* Subroutine */ int cgerc_(integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *);
static complex alpha;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *), caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *), csymv_(char *, integer *,
complex *, complex *, integer *, complex *, integer *, complex *,
complex *, integer *);
extern real scnrm2_(integer *, complex *, integer *);
static integer ii, jj;
static complex wa, wb;
extern /* Subroutine */ int clacgv_(integer *, complex *, integer *);
static real wn;
extern /* Subroutine */ int xerbla_(char *, integer *), clarnv_(
integer *, integer *, integer *, complex *);
static complex tau;
/* -- LAPACK auxiliary test 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
=======
CLAGSY generates a complex symmetric matrix A, by pre- and post-
multiplying a real diagonal matrix D with a random unitary matrix:
A = U*D*U**T. The semi-bandwidth may then be reduced to k by
additional unitary transformations.
Arguments
=========
N (input) INTEGER
The order of the matrix A. N >= 0.
K (input) INTEGER
The number of nonzero subdiagonals within the band of A.
0 <= K <= N-1.
D (input) REAL array, dimension (N)
The diagonal elements of the diagonal matrix D.
A (output) COMPLEX array, dimension (LDA,N)
The generated n by n symmetric matrix A (the full matrix is
stored).
LDA (input) INTEGER
The leading dimension of the array A. LDA >= N.
ISEED (input/output) INTEGER array, dimension (4)
On entry, the seed of the random number generator; the array
elements must be between 0 and 4095, and ISEED(4) must be
odd.
On exit, the seed is updated.
WORK (workspace) COMPLEX array, dimension (2*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input arguments
Parameter adjustments */
--d;
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--iseed;
--work;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*k < 0 || *k > *n - 1) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info < 0) {
i__1 = -(*info);
xerbla_("CLAGSY", &i__1);
return 0;
}
/* initialize lower triangle of A to diagonal matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i = j + 1; i <= i__2; ++i) {
i__3 = i + j * a_dim1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
/* L10: */
}
/* L20: */
}
i__1 = *n;
for (i = 1; i <= i__1; ++i) {
i__2 = i + i * a_dim1;
i__3 = i;
a[i__2].r = d[i__3], a[i__2].i = 0.f;
/* L30: */
}
/* Generate lower triangle of symmetric matrix */
for (i = *n - 1; i >= 1; --i) {
/* generate random reflection */
i__1 = *n - i + 1;
clarnv_(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *n - i + 1;
wn = scnrm2_(&i__1, &work[1], &c__1);
d__1 = wn / c_abs(&work[1]);
q__1.r = d__1 * work[1].r, q__1.i = d__1 * work[1].i;
wa.r = q__1.r, wa.i = q__1.i;
if (wn == 0.f) {
tau.r = 0.f, tau.i = 0.f;
} else {
q__1.r = work[1].r + wa.r, q__1.i = work[1].i + wa.i;
wb.r = q__1.r, wb.i = q__1.i;
i__1 = *n - i;
c_div(&q__1, &c_b2, &wb);
cscal_(&i__1, &q__1, &work[2], &c__1);
work[1].r = 1.f, work[1].i = 0.f;
c_div(&q__1, &wb, &wa);
d__1 = q__1.r;
tau.r = d__1, tau.i = 0.f;
}
/* apply random reflection to A(i:n,i:n) from the left
and the right
compute y := tau * A * conjg(u) */
i__1 = *n - i + 1;
clacgv_(&i__1, &work[1], &c__1);
i__1 = *n - i + 1;
csymv_("Lower", &i__1, &tau, &a[i + i * a_dim1], lda, &work[1], &c__1,
&c_b1, &work[*n + 1], &c__1);
i__1 = *n - i + 1;
clacgv_(&i__1, &work[1], &c__1);
/* compute v := y - 1/2 * tau * ( u, y ) * u */
q__3.r = -.5f, q__3.i = 0.f;
q__2.r = q__3.r * tau.r - q__3.i * tau.i, q__2.i = q__3.r * tau.i +
q__3.i * tau.r;
i__1 = *n - i + 1;
cdotc_(&q__4, &i__1, &work[1], &c__1, &work[*n + 1], &c__1);
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i
+ q__2.i * q__4.r;
alpha.r = q__1.r, alpha.i = q__1.i;
i__1 = *n - i + 1;
caxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1);
/* apply the transformation as a rank-2 update to A(i:n,i:n)
CALL CSYR2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1,
$ A( I, I ), LDA ) */
i__1 = *n;
for (jj = i; jj <= i__1; ++jj) {
i__2 = *n;
for (ii = jj; ii <= i__2; ++ii) {
i__3 = ii + jj * a_dim1;
i__4 = ii + jj * a_dim1;
i__5 = ii - i + 1;
i__6 = *n + jj - i + 1;
q__3.r = work[i__5].r * work[i__6].r - work[i__5].i * work[
i__6].i, q__3.i = work[i__5].r * work[i__6].i + work[
i__5].i * work[i__6].r;
q__2.r = a[i__4].r - q__3.r, q__2.i = a[i__4].i - q__3.i;
i__7 = *n + ii - i + 1;
i__8 = jj - i + 1;
q__4.r = work[i__7].r * work[i__8].r - work[i__7].i * work[
i__8].i, q__4.i = work[i__7].r * work[i__8].i + work[
i__7].i * work[i__8].r;
q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
a[i__3].r = q__1.r, a[i__3].i = q__1.i;
/* L40: */
}
/* L50: */
}
/* L60: */
}
/* Reduce number of subdiagonals to K */
i__1 = *n - 1 - *k;
for (i = 1; i <= i__1; ++i) {
/* generate reflection to annihilate A(k+i+1:n,i) */
i__2 = *n - *k - i + 1;
wn = scnrm2_(&i__2, &a[*k + i + i * a_dim1], &c__1);
d__1 = wn / c_abs(&a[*k + i + i * a_dim1]);
i__2 = *k + i + i * a_dim1;
q__1.r = d__1 * a[i__2].r, q__1.i = d__1 * a[i__2].i;
wa.r = q__1.r, wa.i = q__1.i;
if (wn == 0.f) {
tau.r = 0.f, tau.i = 0.f;
} else {
i__2 = *k + i + i * a_dim1;
q__1.r = a[i__2].r + wa.r, q__1.i = a[i__2].i + wa.i;
wb.r = q__1.r, wb.i = q__1.i;
i__2 = *n - *k - i;
c_div(&q__1, &c_b2, &wb);
cscal_(&i__2, &q__1, &a[*k + i + 1 + i * a_dim1], &c__1);
i__2 = *k + i + i * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
c_div(&q__1, &wb, &wa);
d__1 = q__1.r;
tau.r = d__1, tau.i = 0.f;
}
/* apply reflection to A(k+i:n,i+1:k+i-1) from the left */
i__2 = *n - *k - i + 1;
i__3 = *k - 1;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i + (i + 1)
* a_dim1], lda, &a[*k + i + i * a_dim1], &c__1, &c_b1, &work[
1], &c__1);
i__2 = *n - *k - i + 1;
i__3 = *k - 1;
q__1.r = -(doublereal)tau.r, q__1.i = -(doublereal)tau.i;
cgerc_(&i__2, &i__3, &q__1, &a[*k + i + i * a_dim1], &c__1, &work[1],
&c__1, &a[*k + i + (i + 1) * a_dim1], lda);
/* apply reflection to A(k+i:n,k+i:n) from the left and the rig
ht
compute y := tau * A * conjg(u) */
i__2 = *n - *k - i + 1;
clacgv_(&i__2, &a[*k + i + i * a_dim1], &c__1);
i__2 = *n - *k - i + 1;
csymv_("Lower", &i__2, &tau, &a[*k + i + (*k + i) * a_dim1], lda, &a[*
k + i + i * a_dim1], &c__1, &c_b1, &work[1], &c__1);
i__2 = *n - *k - i + 1;
clacgv_(&i__2, &a[*k + i + i * a_dim1], &c__1);
/* compute v := y - 1/2 * tau * ( u, y ) * u */
q__3.r = -.5f, q__3.i = 0.f;
q__2.r = q__3.r * tau.r - q__3.i * tau.i, q__2.i = q__3.r * tau.i +
q__3.i * tau.r;
i__2 = *n - *k - i + 1;
cdotc_(&q__4, &i__2, &a[*k + i + i * a_dim1], &c__1, &work[1], &c__1);
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i
+ q__2.i * q__4.r;
alpha.r = q__1.r, alpha.i = q__1.i;
i__2 = *n - *k - i + 1;
caxpy_(&i__2, &alpha, &a[*k + i + i * a_dim1], &c__1, &work[1], &c__1)
;
/* apply symmetric rank-2 update to A(k+i:n,k+i:n)
CALL CSYR2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1,
$ A( K+I, K+I ), LDA ) */
i__2 = *n;
for (jj = *k + i; jj <= i__2; ++jj) {
i__3 = *n;
for (ii = jj; ii <= i__3; ++ii) {
i__4 = ii + jj * a_dim1;
i__5 = ii + jj * a_dim1;
i__6 = ii + i * a_dim1;
i__7 = jj - *k - i + 1;
q__3.r = a[i__6].r * work[i__7].r - a[i__6].i * work[i__7].i,
q__3.i = a[i__6].r * work[i__7].i + a[i__6].i * work[
i__7].r;
q__2.r = a[i__5].r - q__3.r, q__2.i = a[i__5].i - q__3.i;
i__8 = ii - *k - i + 1;
i__9 = jj + i * a_dim1;
q__4.r = work[i__8].r * a[i__9].r - work[i__8].i * a[i__9].i,
q__4.i = work[i__8].r * a[i__9].i + work[i__8].i * a[
i__9].r;
q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
a[i__4].r = q__1.r, a[i__4].i = q__1.i;
/* L70: */
}
/* L80: */
}
i__2 = *k + i + i * a_dim1;
q__1.r = -(doublereal)wa.r, q__1.i = -(doublereal)wa.i;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
i__2 = *n;
for (j = *k + i + 1; j <= i__2; ++j) {
i__3 = j + i * a_dim1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
/* L90: */
}
/* L100: */
}
/* Store full symmetric matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i = j + 1; i <= i__2; ++i) {
i__3 = j + i * a_dim1;
i__4 = i + j * a_dim1;
a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i;
/* L110: */
}
/* L120: */
}
return 0;
/* End of CLAGSY */
} /* clagsy_ */
/* DECK CSIDI */
/* Subroutine */ int csidi_(complex *a, integer *lda, integer *n, integer *
kpvt, complex *det, complex *work, integer *job)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
real r__1, r__2;
complex q__1, q__2, q__3;
/* Local variables */
static complex d__;
static integer j, k;
static complex t, ak;
static integer jb, ks, km1;
static real ten;
static complex akp1, temp, akkp1;
static logical nodet;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *);
extern /* Complex */ void cdotu_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
complex *, integer *), caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
static integer kstep;
static logical noinv;
/* ***BEGIN PROLOGUE CSIDI */
/* ***PURPOSE Compute the determinant and inverse of a complex symmetric */
/* matrix using the factors from CSIFA. */
/* ***LIBRARY SLATEC (LINPACK) */
/* ***CATEGORY D2C1, D3C1 */
/* ***TYPE COMPLEX (SSIDI-S, DSIDI-D, CHIDI-C, CSIDI-C) */
/* ***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX, */
/* SYMMETRIC */
/* ***AUTHOR Bunch, J., (UCSD) */
/* ***DESCRIPTION */
/* CSIDI computes the determinant and inverse */
/* of a complex symmetric matrix using the factors from CSIFA. */
/* On Entry */
/* A COMPLEX(LDA,N) */
/* the output from CSIFA. */
/* LDA INTEGER */
/* the leading dimension of the array A . */
/* N INTEGER */
/* the order of the matrix A . */
/* KVPT INTEGER(N) */
/* the pivot vector from CSIFA. */
/* WORK COMPLEX(N) */
/* work vector. Contents destroyed. */
/* JOB INTEGER */
/* JOB has the decimal expansion AB where */
/* If B .NE. 0, the inverse is computed, */
/* If A .NE. 0, the determinant is computed, */
/* For example, JOB = 11 gives both. */
/* On Return */
/* Variables not requested by JOB are not used. */
/* A contains the upper triangle of the inverse of */
/* the original matrix. The strict lower triangle */
/* is never referenced. */
/* DET COMPLEX(2) */
/* determinant of original matrix. */
/* Determinant = DET(1) * 10.0**DET(2) */
/* with 1.0 .LE. ABS(DET(1)) .LT. 10.0 */
/* or DET(1) = 0.0. */
/* Error Condition */
/* A division by zero may occur if the inverse is requested */
/* and CSICO has set RCOND .EQ. 0.0 */
/* or CSIFA has set INFO .NE. 0 . */
/* ***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. */
/* Stewart, LINPACK Users' Guide, SIAM, 1979. */
/* ***ROUTINES CALLED CAXPY, CCOPY, CDOTU, CSWAP */
/* ***REVISION HISTORY (YYMMDD) */
/* 780814 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890831 Modified array declarations. (WRB) */
/* 891107 Corrected category and modified routine equivalence */
/* list. (WRB) */
/* 891107 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900326 Removed duplicate information from DESCRIPTION section. */
/* (WRB) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE CSIDI */
/* ***FIRST EXECUTABLE STATEMENT CSIDI */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--kpvt;
--det;
--work;
/* Function Body */
noinv = *job % 10 == 0;
nodet = *job % 100 / 10 == 0;
if (nodet) {
goto L100;
}
det[1].r = 1.f, det[1].i = 0.f;
det[2].r = 0.f, det[2].i = 0.f;
ten = 10.f;
t.r = 0.f, t.i = 0.f;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
i__2 = k + k * a_dim1;
d__.r = a[i__2].r, d__.i = a[i__2].i;
/* CHECK IF 1 BY 1 */
if (kpvt[k] > 0) {
goto L30;
}
/* 2 BY 2 BLOCK */
/* USE DET (D T) = (D/T * C - T) * T */
/* (T C) */
/* TO AVOID UNDERFLOW/OVERFLOW TROUBLES. */
/* TAKE TWO PASSES THROUGH SCALING. USE T FOR FLAG. */
if ((r__1 = t.r, dabs(r__1)) + (r__2 = r_imag(&t), dabs(r__2)) != 0.f)
{
goto L10;
}
i__2 = k + (k + 1) * a_dim1;
t.r = a[i__2].r, t.i = a[i__2].i;
c_div(&q__3, &d__, &t);
i__2 = k + 1 + (k + 1) * a_dim1;
q__2.r = q__3.r * a[i__2].r - q__3.i * a[i__2].i, q__2.i = q__3.r * a[
i__2].i + q__3.i * a[i__2].r;
q__1.r = q__2.r - t.r, q__1.i = q__2.i - t.i;
d__.r = q__1.r, d__.i = q__1.i;
goto L20;
L10:
d__.r = t.r, d__.i = t.i;
t.r = 0.f, t.i = 0.f;
L20:
L30:
q__1.r = d__.r * det[1].r - d__.i * det[1].i, q__1.i = d__.r * det[1]
.i + d__.i * det[1].r;
det[1].r = q__1.r, det[1].i = q__1.i;
if ((r__1 = det[1].r, dabs(r__1)) + (r__2 = r_imag(&det[1]), dabs(
r__2)) == 0.f) {
goto L80;
}
L40:
if ((r__1 = det[1].r, dabs(r__1)) + (r__2 = r_imag(&det[1]), dabs(
r__2)) >= 1.f) {
goto L50;
}
q__2.r = ten, q__2.i = 0.f;
q__1.r = q__2.r * det[1].r - q__2.i * det[1].i, q__1.i = q__2.r * det[
1].i + q__2.i * det[1].r;
det[1].r = q__1.r, det[1].i = q__1.i;
q__1.r = det[2].r - 1.f, q__1.i = det[2].i - 0.f;
det[2].r = q__1.r, det[2].i = q__1.i;
goto L40;
L50:
L60:
if ((r__1 = det[1].r, dabs(r__1)) + (r__2 = r_imag(&det[1]), dabs(
r__2)) < ten) {
goto L70;
}
q__2.r = ten, q__2.i = 0.f;
c_div(&q__1, &det[1], &q__2);
det[1].r = q__1.r, det[1].i = q__1.i;
q__1.r = det[2].r + 1.f, q__1.i = det[2].i + 0.f;
det[2].r = q__1.r, det[2].i = q__1.i;
goto L60;
L70:
L80:
/* L90: */
;
}
L100:
/* COMPUTE INVERSE(A) */
if (noinv) {
goto L230;
}
k = 1;
L110:
if (k > *n) {
goto L220;
}
km1 = k - 1;
if (kpvt[k] < 0) {
goto L140;
}
/* 1 BY 1 */
i__1 = k + k * a_dim1;
c_div(&q__1, &c_b3, &a[k + k * a_dim1]);
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
if (km1 < 1) {
goto L130;
}
ccopy_(&km1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
i__1 = km1;
for (j = 1; j <= i__1; ++j) {
i__2 = j + k * a_dim1;
cdotu_(&q__1, &j, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
i__2 = j - 1;
caxpy_(&i__2, &work[j], &a[j * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1],
&c__1);
/* L120: */
}
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
cdotu_(&q__2, &km1, &work[1], &c__1, &a[k * a_dim1 + 1], &c__1);
q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i;
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
L130:
kstep = 1;
goto L180;
L140:
/* 2 BY 2 */
i__1 = k + (k + 1) * a_dim1;
t.r = a[i__1].r, t.i = a[i__1].i;
c_div(&q__1, &a[k + k * a_dim1], &t);
ak.r = q__1.r, ak.i = q__1.i;
c_div(&q__1, &a[k + 1 + (k + 1) * a_dim1], &t);
akp1.r = q__1.r, akp1.i = q__1.i;
c_div(&q__1, &a[k + (k + 1) * a_dim1], &t);
akkp1.r = q__1.r, akkp1.i = q__1.i;
q__3.r = ak.r * akp1.r - ak.i * akp1.i, q__3.i = ak.r * akp1.i + ak.i *
akp1.r;
q__2.r = q__3.r - 1.f, q__2.i = q__3.i - 0.f;
q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * q__2.i + t.i *
q__2.r;
d__.r = q__1.r, d__.i = q__1.i;
i__1 = k + k * a_dim1;
c_div(&q__1, &akp1, &d__);
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
i__1 = k + 1 + (k + 1) * a_dim1;
c_div(&q__1, &ak, &d__);
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
i__1 = k + (k + 1) * a_dim1;
q__2.r = -akkp1.r, q__2.i = -akkp1.i;
c_div(&q__1, &q__2, &d__);
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
if (km1 < 1) {
goto L170;
}
ccopy_(&km1, &a[(k + 1) * a_dim1 + 1], &c__1, &work[1], &c__1);
i__1 = km1;
for (j = 1; j <= i__1; ++j) {
i__2 = j + (k + 1) * a_dim1;
cdotu_(&q__1, &j, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
i__2 = j - 1;
caxpy_(&i__2, &work[j], &a[j * a_dim1 + 1], &c__1, &a[(k + 1) *
a_dim1 + 1], &c__1);
/* L150: */
}
i__1 = k + 1 + (k + 1) * a_dim1;
i__2 = k + 1 + (k + 1) * a_dim1;
cdotu_(&q__2, &km1, &work[1], &c__1, &a[(k + 1) * a_dim1 + 1], &c__1);
q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i;
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
i__1 = k + (k + 1) * a_dim1;
i__2 = k + (k + 1) * a_dim1;
cdotu_(&q__2, &km1, &a[k * a_dim1 + 1], &c__1, &a[(k + 1) * a_dim1 + 1], &
c__1);
q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i;
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
ccopy_(&km1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
i__1 = km1;
for (j = 1; j <= i__1; ++j) {
i__2 = j + k * a_dim1;
cdotu_(&q__1, &j, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
i__2 = j - 1;
caxpy_(&i__2, &work[j], &a[j * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1],
&c__1);
/* L160: */
}
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
cdotu_(&q__2, &km1, &work[1], &c__1, &a[k * a_dim1 + 1], &c__1);
q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i;
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
L170:
kstep = 2;
L180:
/* SWAP */
ks = (i__1 = kpvt[k], abs(i__1));
if (ks == k) {
goto L210;
}
cswap_(&ks, &a[ks * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1);
i__1 = k;
for (jb = ks; jb <= i__1; ++jb) {
j = k + ks - jb;
i__2 = j + k * a_dim1;
temp.r = a[i__2].r, temp.i = a[i__2].i;
i__2 = j + k * a_dim1;
i__3 = ks + j * a_dim1;
a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
i__2 = ks + j * a_dim1;
a[i__2].r = temp.r, a[i__2].i = temp.i;
/* L190: */
}
if (kstep == 1) {
goto L200;
}
i__1 = ks + (k + 1) * a_dim1;
temp.r = a[i__1].r, temp.i = a[i__1].i;
i__1 = ks + (k + 1) * a_dim1;
i__2 = k + (k + 1) * a_dim1;
a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
i__1 = k + (k + 1) * a_dim1;
a[i__1].r = temp.r, a[i__1].i = temp.i;
L200:
L210:
k += kstep;
goto L110;
L220:
L230:
return 0;
} /* csidi_ */
/* Subroutine */ int cgtsv_(integer *n, integer *nrhs, complex *dl, complex *
d__, complex *du, complex *b, integer *ldb, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
real r__1, r__2, r__3, r__4;
complex q__1, q__2, q__3, q__4, q__5;
/* Builtin functions */
double r_imag(complex *);
void c_div(complex *, complex *, complex *);
/* Local variables */
integer j, k;
complex temp, mult;
extern /* Subroutine */ int xerbla_(char *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGTSV solves the equation */
/* A*X = B, */
/* where A is an N-by-N tridiagonal matrix, by Gaussian elimination with */
/* partial pivoting. */
/* Note that the equation A'*X = B may be solved by interchanging the */
/* order of the arguments DU and DL. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrix B. NRHS >= 0. */
/* DL (input/output) COMPLEX array, dimension (N-1) */
/* On entry, DL must contain the (n-1) subdiagonal elements of */
/* A. */
/* On exit, DL is overwritten by the (n-2) elements of the */
/* second superdiagonal of the upper triangular matrix U from */
/* the LU factorization of A, in DL(1), ..., DL(n-2). */
/* D (input/output) COMPLEX array, dimension (N) */
/* On entry, D must contain the diagonal elements of A. */
/* On exit, D is overwritten by the n diagonal elements of U. */
/* DU (input/output) COMPLEX array, dimension (N-1) */
/* On entry, DU must contain the (n-1) superdiagonal elements */
/* of A. */
/* On exit, DU is overwritten by the (n-1) elements of the first */
/* superdiagonal of U. */
/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
/* On entry, the N-by-NRHS right hand side matrix B. */
/* On exit, if INFO = 0, the N-by-NRHS solution matrix X. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, U(i,i) is exactly zero, and the solution */
/* has not been computed. The factorization has not been */
/* completed unless i = N. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--dl;
--d__;
--du;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*nrhs < 0) {
*info = -2;
} else if (*ldb < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGTSV ", &i__1);
return 0;
}
if (*n == 0) {
return 0;
}
i__1 = *n - 1;
for (k = 1; k <= i__1; ++k) {
i__2 = k;
if (dl[i__2].r == 0.f && dl[i__2].i == 0.f) {
/* Subdiagonal is zero, no elimination is required. */
i__2 = k;
if (d__[i__2].r == 0.f && d__[i__2].i == 0.f) {
/* Diagonal is zero: set INFO = K and return; a unique */
/* solution can not be found. */
*info = k;
return 0;
}
} else { /* if(complicated condition) */
i__2 = k;
i__3 = k;
if ((r__1 = d__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&d__[k]),
dabs(r__2)) >= (r__3 = dl[i__3].r, dabs(r__3)) + (r__4 =
r_imag(&dl[k]), dabs(r__4))) {
/* No row interchange required */
c_div(&q__1, &dl[k], &d__[k]);
mult.r = q__1.r, mult.i = q__1.i;
i__2 = k + 1;
i__3 = k + 1;
i__4 = k;
q__2.r = mult.r * du[i__4].r - mult.i * du[i__4].i, q__2.i =
mult.r * du[i__4].i + mult.i * du[i__4].r;
q__1.r = d__[i__3].r - q__2.r, q__1.i = d__[i__3].i - q__2.i;
d__[i__2].r = q__1.r, d__[i__2].i = q__1.i;
i__2 = *nrhs;
for (j = 1; j <= i__2; ++j) {
i__3 = k + 1 + j * b_dim1;
i__4 = k + 1 + j * b_dim1;
i__5 = k + j * b_dim1;
q__2.r = mult.r * b[i__5].r - mult.i * b[i__5].i, q__2.i =
mult.r * b[i__5].i + mult.i * b[i__5].r;
q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i - q__2.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L10: */
}
if (k < *n - 1) {
i__2 = k;
dl[i__2].r = 0.f, dl[i__2].i = 0.f;
}
} else {
/* Interchange rows K and K+1 */
c_div(&q__1, &d__[k], &dl[k]);
mult.r = q__1.r, mult.i = q__1.i;
i__2 = k;
i__3 = k;
d__[i__2].r = dl[i__3].r, d__[i__2].i = dl[i__3].i;
i__2 = k + 1;
temp.r = d__[i__2].r, temp.i = d__[i__2].i;
i__2 = k + 1;
i__3 = k;
q__2.r = mult.r * temp.r - mult.i * temp.i, q__2.i = mult.r *
temp.i + mult.i * temp.r;
q__1.r = du[i__3].r - q__2.r, q__1.i = du[i__3].i - q__2.i;
d__[i__2].r = q__1.r, d__[i__2].i = q__1.i;
if (k < *n - 1) {
i__2 = k;
i__3 = k + 1;
dl[i__2].r = du[i__3].r, dl[i__2].i = du[i__3].i;
i__2 = k + 1;
q__2.r = -mult.r, q__2.i = -mult.i;
i__3 = k;
q__1.r = q__2.r * dl[i__3].r - q__2.i * dl[i__3].i,
q__1.i = q__2.r * dl[i__3].i + q__2.i * dl[i__3]
.r;
du[i__2].r = q__1.r, du[i__2].i = q__1.i;
}
i__2 = k;
du[i__2].r = temp.r, du[i__2].i = temp.i;
i__2 = *nrhs;
for (j = 1; j <= i__2; ++j) {
i__3 = k + j * b_dim1;
temp.r = b[i__3].r, temp.i = b[i__3].i;
i__3 = k + j * b_dim1;
i__4 = k + 1 + j * b_dim1;
b[i__3].r = b[i__4].r, b[i__3].i = b[i__4].i;
i__3 = k + 1 + j * b_dim1;
i__4 = k + 1 + j * b_dim1;
q__2.r = mult.r * b[i__4].r - mult.i * b[i__4].i, q__2.i =
mult.r * b[i__4].i + mult.i * b[i__4].r;
q__1.r = temp.r - q__2.r, q__1.i = temp.i - q__2.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L20: */
}
}
}
/* L30: */
}
i__1 = *n;
if (d__[i__1].r == 0.f && d__[i__1].i == 0.f) {
*info = *n;
return 0;
}
/* Back solve with the matrix U from the factorization. */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n + j * b_dim1;
c_div(&q__1, &b[*n + j * b_dim1], &d__[*n]);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
if (*n > 1) {
i__2 = *n - 1 + j * b_dim1;
i__3 = *n - 1 + j * b_dim1;
i__4 = *n - 1;
i__5 = *n + j * b_dim1;
q__3.r = du[i__4].r * b[i__5].r - du[i__4].i * b[i__5].i, q__3.i =
du[i__4].r * b[i__5].i + du[i__4].i * b[i__5].r;
q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i;
c_div(&q__1, &q__2, &d__[*n - 1]);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
}
for (k = *n - 2; k >= 1; --k) {
i__2 = k + j * b_dim1;
i__3 = k + j * b_dim1;
i__4 = k;
i__5 = k + 1 + j * b_dim1;
q__4.r = du[i__4].r * b[i__5].r - du[i__4].i * b[i__5].i, q__4.i =
du[i__4].r * b[i__5].i + du[i__4].i * b[i__5].r;
q__3.r = b[i__3].r - q__4.r, q__3.i = b[i__3].i - q__4.i;
i__6 = k;
i__7 = k + 2 + j * b_dim1;
q__5.r = dl[i__6].r * b[i__7].r - dl[i__6].i * b[i__7].i, q__5.i =
dl[i__6].r * b[i__7].i + dl[i__6].i * b[i__7].r;
q__2.r = q__3.r - q__5.r, q__2.i = q__3.i - q__5.i;
c_div(&q__1, &q__2, &d__[k]);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L40: */
}
/* L50: */
}
return 0;
/* End of CGTSV */
} /* cgtsv_ */
/* DECK CSPCO */
/* Subroutine */ int cspco_(complex *ap, integer *n, integer *kpvt, real *
rcond, complex *z__)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8;
complex q__1, q__2, q__3;
/* Local variables */
static integer i__, j, k;
static real s;
static complex t;
static integer j1;
static complex ak, bk, ek;
static integer ij, ik, kk, kp, ks, jm1, kps;
static complex akm1, bkm1;
static integer ikm1, km1k, ikp1, info;
extern /* Subroutine */ int cspfa_(complex *, integer *, integer *,
integer *);
static integer km1km1;
static complex denom;
static real anorm;
extern /* Complex */ void cdotu_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
static real ynorm;
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*);
extern doublereal scasum_(integer *, complex *, integer *);
/* ***BEGIN PROLOGUE CSPCO */
/* ***PURPOSE Factor a complex symmetric matrix stored in packed form */
/* by elimination with symmetric pivoting and estimate the */
/* condition number of the matrix. */
/* ***LIBRARY SLATEC (LINPACK) */
/* ***CATEGORY D2C1 */
/* ***TYPE COMPLEX (SSPCO-S, DSPCO-D, CHPCO-C, CSPCO-C) */
/* ***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, */
/* MATRIX FACTORIZATION, PACKED, SYMMETRIC */
/* ***AUTHOR Moler, C. B., (U. of New Mexico) */
/* ***DESCRIPTION */
/* CSPCO factors a complex symmetric matrix stored in packed */
/* form by elimination with symmetric pivoting and estimates */
/* the condition of the matrix. */
/* If RCOND is not needed, CSPFA is slightly faster. */
/* To solve A*X = B , follow CSPCO by CSPSL. */
/* To compute INVERSE(A)*C , follow CSPCO by CSPSL. */
/* To compute INVERSE(A) , follow CSPCO by CSPDI. */
/* To compute DETERMINANT(A) , follow CSPCO by CSPDI. */
/* On Entry */
/* AP COMPLEX (N*(N+1)/2) */
/* the packed form of a symmetric matrix A . The */
/* columns of the upper triangle are stored sequentially */
/* in a one-dimensional array of length N*(N+1)/2 . */
/* See comments below for details. */
/* N INTEGER */
/* the order of the matrix A . */
/* On Return */
/* AP a block diagonal matrix and the multipliers which */
/* were used to obtain it stored in packed form. */
/* The factorization can be written A = U*D*TRANS(U) */
/* where U is a product of permutation and unit */
/* upper triangular matrices , TRANS(U) is the */
/* transpose of U , and D is block diagonal */
/* with 1 by 1 and 2 by 2 blocks. */
/* KVPT INTEGER(N) */
/* an integer vector of pivot indices. */
/* RCOND REAL */
/* an estimate of the reciprocal condition of A . */
/* For the system A*X = B , relative perturbations */
/* in A and B of size EPSILON may cause */
/* relative perturbations in X of size EPSILON/RCOND . */
/* If RCOND is so small that the logical expression */
/* 1.0 + RCOND .EQ. 1.0 */
/* is true, then A may be singular to working */
/* precision. In particular, RCOND is zero if */
/* exact singularity is detected or the estimate */
/* underflows. */
/* Z COMPLEX(N) */
/* a work vector whose contents are usually unimportant. */
/* If A is close to a singular matrix, then Z is */
/* an approximate null vector in the sense that */
/* NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . */
/* Packed Storage */
/* The following program segment will pack the upper */
/* triangle of a symmetric matrix. */
/* K = 0 */
/* DO 20 J = 1, N */
/* DO 10 I = 1, J */
/* K = K + 1 */
/* AP(K) = A(I,J) */
/* 10 CONTINUE */
/* 20 CONTINUE */
/* ***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. */
/* Stewart, LINPACK Users' Guide, SIAM, 1979. */
/* ***ROUTINES CALLED CAXPY, CDOTU, CSPFA, CSSCAL, SCASUM */
/* ***REVISION HISTORY (YYMMDD) */
/* 780814 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890831 Modified array declarations. (WRB) */
/* 891107 Corrected category and modified routine equivalence */
/* list. (WRB) */
/* 891107 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900326 Removed duplicate information from DESCRIPTION section. */
/* (WRB) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE CSPCO */
/* FIND NORM OF A USING ONLY UPPER HALF */
/* ***FIRST EXECUTABLE STATEMENT CSPCO */
/* Parameter adjustments */
--z__;
--kpvt;
--ap;
/* Function Body */
j1 = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
r__1 = scasum_(&j, &ap[j1], &c__1);
q__1.r = r__1, q__1.i = 0.f;
z__[i__2].r = q__1.r, z__[i__2].i = q__1.i;
ij = j1;
j1 += j;
jm1 = j - 1;
if (jm1 < 1) {
goto L20;
}
i__2 = jm1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = ij;
r__3 = z__[i__4].r + ((r__1 = ap[i__5].r, dabs(r__1)) + (r__2 =
r_imag(&ap[ij]), dabs(r__2)));
q__1.r = r__3, q__1.i = 0.f;
z__[i__3].r = q__1.r, z__[i__3].i = q__1.i;
++ij;
/* L10: */
}
L20:
/* L30: */
;
}
anorm = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = j;
r__1 = anorm, r__2 = z__[i__2].r;
anorm = dmax(r__1,r__2);
/* L40: */
}
/* FACTOR */
cspfa_(&ap[1], n, &kpvt[1], &info);
/* RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . */
/* ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . */
/* THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL */
/* GROWTH IN THE ELEMENTS OF W WHERE U*D*W = E . */
/* THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. */
/* SOLVE U*D*W = E */
ek.r = 1.f, ek.i = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
z__[i__2].r = 0.f, z__[i__2].i = 0.f;
/* L50: */
}
k = *n;
ik = *n * (*n - 1) / 2;
L60:
if (k == 0) {
goto L120;
}
kk = ik + k;
ikm1 = ik - (k - 1);
ks = 1;
if (kpvt[k] < 0) {
ks = 2;
}
kp = (i__1 = kpvt[k], abs(i__1));
kps = k + 1 - ks;
if (kp == kps) {
goto L70;
}
i__1 = kps;
t.r = z__[i__1].r, t.i = z__[i__1].i;
i__1 = kps;
i__2 = kp;
z__[i__1].r = z__[i__2].r, z__[i__1].i = z__[i__2].i;
i__1 = kp;
z__[i__1].r = t.r, z__[i__1].i = t.i;
L70:
i__1 = k;
if ((r__1 = z__[i__1].r, dabs(r__1)) + (r__2 = r_imag(&z__[k]), dabs(r__2)
) != 0.f) {
r__7 = (r__3 = ek.r, dabs(r__3)) + (r__4 = r_imag(&ek), dabs(r__4));
i__2 = k;
i__3 = k;
r__8 = (r__5 = z__[i__3].r, dabs(r__5)) + (r__6 = r_imag(&z__[k]),
dabs(r__6));
q__2.r = z__[i__2].r / r__8, q__2.i = z__[i__2].i / r__8;
q__1.r = r__7 * q__2.r, q__1.i = r__7 * q__2.i;
ek.r = q__1.r, ek.i = q__1.i;
}
i__1 = k;
i__2 = k;
q__1.r = z__[i__2].r + ek.r, q__1.i = z__[i__2].i + ek.i;
z__[i__1].r = q__1.r, z__[i__1].i = q__1.i;
i__1 = k - ks;
caxpy_(&i__1, &z__[k], &ap[ik + 1], &c__1, &z__[1], &c__1);
if (ks == 1) {
goto L80;
}
i__1 = k - 1;
if ((r__1 = z__[i__1].r, dabs(r__1)) + (r__2 = r_imag(&z__[k - 1]), dabs(
r__2)) != 0.f) {
r__7 = (r__3 = ek.r, dabs(r__3)) + (r__4 = r_imag(&ek), dabs(r__4));
i__2 = k - 1;
i__3 = k - 1;
r__8 = (r__5 = z__[i__3].r, dabs(r__5)) + (r__6 = r_imag(&z__[k - 1]),
dabs(r__6));
q__2.r = z__[i__2].r / r__8, q__2.i = z__[i__2].i / r__8;
q__1.r = r__7 * q__2.r, q__1.i = r__7 * q__2.i;
ek.r = q__1.r, ek.i = q__1.i;
}
i__1 = k - 1;
i__2 = k - 1;
q__1.r = z__[i__2].r + ek.r, q__1.i = z__[i__2].i + ek.i;
z__[i__1].r = q__1.r, z__[i__1].i = q__1.i;
i__1 = k - ks;
caxpy_(&i__1, &z__[k - 1], &ap[ikm1 + 1], &c__1, &z__[1], &c__1);
L80:
if (ks == 2) {
goto L100;
}
i__1 = k;
i__2 = kk;
if ((r__1 = z__[i__1].r, dabs(r__1)) + (r__2 = r_imag(&z__[k]), dabs(r__2)
) <= (r__3 = ap[i__2].r, dabs(r__3)) + (r__4 = r_imag(&ap[kk]),
dabs(r__4))) {
goto L90;
}
i__1 = kk;
i__2 = k;
s = ((r__1 = ap[i__1].r, dabs(r__1)) + (r__2 = r_imag(&ap[kk]), dabs(r__2)
)) / ((r__3 = z__[i__2].r, dabs(r__3)) + (r__4 = r_imag(&z__[k]),
dabs(r__4)));
csscal_(n, &s, &z__[1], &c__1);
q__2.r = s, q__2.i = 0.f;
q__1.r = q__2.r * ek.r - q__2.i * ek.i, q__1.i = q__2.r * ek.i + q__2.i *
ek.r;
ek.r = q__1.r, ek.i = q__1.i;
L90:
i__1 = kk;
if ((r__1 = ap[i__1].r, dabs(r__1)) + (r__2 = r_imag(&ap[kk]), dabs(r__2))
!= 0.f) {
i__2 = k;
c_div(&q__1, &z__[k], &ap[kk]);
z__[i__2].r = q__1.r, z__[i__2].i = q__1.i;
}
i__1 = kk;
if ((r__1 = ap[i__1].r, dabs(r__1)) + (r__2 = r_imag(&ap[kk]), dabs(r__2))
== 0.f) {
i__2 = k;
z__[i__2].r = 1.f, z__[i__2].i = 0.f;
}
goto L110;
L100:
km1k = ik + k - 1;
km1km1 = ikm1 + k - 1;
c_div(&q__1, &ap[kk], &ap[km1k]);
ak.r = q__1.r, ak.i = q__1.i;
c_div(&q__1, &ap[km1km1], &ap[km1k]);
akm1.r = q__1.r, akm1.i = q__1.i;
c_div(&q__1, &z__[k], &ap[km1k]);
bk.r = q__1.r, bk.i = q__1.i;
c_div(&q__1, &z__[k - 1], &ap[km1k]);
bkm1.r = q__1.r, bkm1.i = q__1.i;
q__2.r = ak.r * akm1.r - ak.i * akm1.i, q__2.i = ak.r * akm1.i + ak.i *
akm1.r;
q__1.r = q__2.r - 1.f, q__1.i = q__2.i;
denom.r = q__1.r, denom.i = q__1.i;
i__1 = k;
q__3.r = akm1.r * bk.r - akm1.i * bk.i, q__3.i = akm1.r * bk.i + akm1.i *
bk.r;
q__2.r = q__3.r - bkm1.r, q__2.i = q__3.i - bkm1.i;
c_div(&q__1, &q__2, &denom);
z__[i__1].r = q__1.r, z__[i__1].i = q__1.i;
i__1 = k - 1;
q__3.r = ak.r * bkm1.r - ak.i * bkm1.i, q__3.i = ak.r * bkm1.i + ak.i *
bkm1.r;
q__2.r = q__3.r - bk.r, q__2.i = q__3.i - bk.i;
c_div(&q__1, &q__2, &denom);
z__[i__1].r = q__1.r, z__[i__1].i = q__1.i;
L110:
k -= ks;
ik -= k;
if (ks == 2) {
ik -= k + 1;
}
goto L60;
L120:
s = 1.f / scasum_(n, &z__[1], &c__1);
csscal_(n, &s, &z__[1], &c__1);
/* SOLVE TRANS(U)*Y = W */
k = 1;
ik = 0;
L130:
if (k > *n) {
goto L160;
}
ks = 1;
if (kpvt[k] < 0) {
ks = 2;
}
if (k == 1) {
goto L150;
}
i__1 = k;
i__2 = k;
i__3 = k - 1;
cdotu_(&q__2, &i__3, &ap[ik + 1], &c__1, &z__[1], &c__1);
q__1.r = z__[i__2].r + q__2.r, q__1.i = z__[i__2].i + q__2.i;
z__[i__1].r = q__1.r, z__[i__1].i = q__1.i;
ikp1 = ik + k;
if (ks == 2) {
i__1 = k + 1;
i__2 = k + 1;
i__3 = k - 1;
cdotu_(&q__2, &i__3, &ap[ikp1 + 1], &c__1, &z__[1], &c__1);
q__1.r = z__[i__2].r + q__2.r, q__1.i = z__[i__2].i + q__2.i;
z__[i__1].r = q__1.r, z__[i__1].i = q__1.i;
}
kp = (i__1 = kpvt[k], abs(i__1));
if (kp == k) {
goto L140;
}
i__1 = k;
t.r = z__[i__1].r, t.i = z__[i__1].i;
i__1 = k;
i__2 = kp;
z__[i__1].r = z__[i__2].r, z__[i__1].i = z__[i__2].i;
i__1 = kp;
z__[i__1].r = t.r, z__[i__1].i = t.i;
L140:
L150:
ik += k;
if (ks == 2) {
ik += k + 1;
}
k += ks;
goto L130;
L160:
s = 1.f / scasum_(n, &z__[1], &c__1);
csscal_(n, &s, &z__[1], &c__1);
ynorm = 1.f;
/* SOLVE U*D*V = Y */
k = *n;
ik = *n * (*n - 1) / 2;
L170:
if (k == 0) {
goto L230;
}
kk = ik + k;
ikm1 = ik - (k - 1);
ks = 1;
if (kpvt[k] < 0) {
ks = 2;
}
if (k == ks) {
goto L190;
}
kp = (i__1 = kpvt[k], abs(i__1));
kps = k + 1 - ks;
if (kp == kps) {
goto L180;
}
i__1 = kps;
t.r = z__[i__1].r, t.i = z__[i__1].i;
i__1 = kps;
i__2 = kp;
z__[i__1].r = z__[i__2].r, z__[i__1].i = z__[i__2].i;
i__1 = kp;
z__[i__1].r = t.r, z__[i__1].i = t.i;
L180:
i__1 = k - ks;
caxpy_(&i__1, &z__[k], &ap[ik + 1], &c__1, &z__[1], &c__1);
if (ks == 2) {
i__1 = k - ks;
caxpy_(&i__1, &z__[k - 1], &ap[ikm1 + 1], &c__1, &z__[1], &c__1);
}
L190:
if (ks == 2) {
goto L210;
}
i__1 = k;
i__2 = kk;
if ((r__1 = z__[i__1].r, dabs(r__1)) + (r__2 = r_imag(&z__[k]), dabs(r__2)
) <= (r__3 = ap[i__2].r, dabs(r__3)) + (r__4 = r_imag(&ap[kk]),
dabs(r__4))) {
goto L200;
}
i__1 = kk;
i__2 = k;
s = ((r__1 = ap[i__1].r, dabs(r__1)) + (r__2 = r_imag(&ap[kk]), dabs(r__2)
)) / ((r__3 = z__[i__2].r, dabs(r__3)) + (r__4 = r_imag(&z__[k]),
dabs(r__4)));
csscal_(n, &s, &z__[1], &c__1);
ynorm = s * ynorm;
L200:
i__1 = kk;
if ((r__1 = ap[i__1].r, dabs(r__1)) + (r__2 = r_imag(&ap[kk]), dabs(r__2))
!= 0.f) {
i__2 = k;
c_div(&q__1, &z__[k], &ap[kk]);
z__[i__2].r = q__1.r, z__[i__2].i = q__1.i;
}
i__1 = kk;
if ((r__1 = ap[i__1].r, dabs(r__1)) + (r__2 = r_imag(&ap[kk]), dabs(r__2))
== 0.f) {
i__2 = k;
z__[i__2].r = 1.f, z__[i__2].i = 0.f;
}
goto L220;
L210:
km1k = ik + k - 1;
km1km1 = ikm1 + k - 1;
c_div(&q__1, &ap[kk], &ap[km1k]);
ak.r = q__1.r, ak.i = q__1.i;
c_div(&q__1, &ap[km1km1], &ap[km1k]);
akm1.r = q__1.r, akm1.i = q__1.i;
c_div(&q__1, &z__[k], &ap[km1k]);
bk.r = q__1.r, bk.i = q__1.i;
c_div(&q__1, &z__[k - 1], &ap[km1k]);
bkm1.r = q__1.r, bkm1.i = q__1.i;
q__2.r = ak.r * akm1.r - ak.i * akm1.i, q__2.i = ak.r * akm1.i + ak.i *
akm1.r;
q__1.r = q__2.r - 1.f, q__1.i = q__2.i;
denom.r = q__1.r, denom.i = q__1.i;
i__1 = k;
q__3.r = akm1.r * bk.r - akm1.i * bk.i, q__3.i = akm1.r * bk.i + akm1.i *
bk.r;
q__2.r = q__3.r - bkm1.r, q__2.i = q__3.i - bkm1.i;
c_div(&q__1, &q__2, &denom);
z__[i__1].r = q__1.r, z__[i__1].i = q__1.i;
i__1 = k - 1;
q__3.r = ak.r * bkm1.r - ak.i * bkm1.i, q__3.i = ak.r * bkm1.i + ak.i *
bkm1.r;
q__2.r = q__3.r - bk.r, q__2.i = q__3.i - bk.i;
c_div(&q__1, &q__2, &denom);
z__[i__1].r = q__1.r, z__[i__1].i = q__1.i;
L220:
k -= ks;
ik -= k;
if (ks == 2) {
ik -= k + 1;
}
goto L170;
L230:
s = 1.f / scasum_(n, &z__[1], &c__1);
csscal_(n, &s, &z__[1], &c__1);
ynorm = s * ynorm;
/* SOLVE TRANS(U)*Z = V */
k = 1;
ik = 0;
L240:
if (k > *n) {
goto L270;
}
ks = 1;
if (kpvt[k] < 0) {
ks = 2;
}
if (k == 1) {
goto L260;
}
i__1 = k;
i__2 = k;
i__3 = k - 1;
cdotu_(&q__2, &i__3, &ap[ik + 1], &c__1, &z__[1], &c__1);
q__1.r = z__[i__2].r + q__2.r, q__1.i = z__[i__2].i + q__2.i;
z__[i__1].r = q__1.r, z__[i__1].i = q__1.i;
ikp1 = ik + k;
if (ks == 2) {
i__1 = k + 1;
i__2 = k + 1;
i__3 = k - 1;
cdotu_(&q__2, &i__3, &ap[ikp1 + 1], &c__1, &z__[1], &c__1);
q__1.r = z__[i__2].r + q__2.r, q__1.i = z__[i__2].i + q__2.i;
z__[i__1].r = q__1.r, z__[i__1].i = q__1.i;
}
kp = (i__1 = kpvt[k], abs(i__1));
if (kp == k) {
goto L250;
}
i__1 = k;
t.r = z__[i__1].r, t.i = z__[i__1].i;
i__1 = k;
i__2 = kp;
z__[i__1].r = z__[i__2].r, z__[i__1].i = z__[i__2].i;
i__1 = kp;
z__[i__1].r = t.r, z__[i__1].i = t.i;
L250:
L260:
ik += k;
if (ks == 2) {
ik += k + 1;
}
k += ks;
goto L240;
L270:
/* MAKE ZNORM = 1.0 */
s = 1.f / scasum_(n, &z__[1], &c__1);
csscal_(n, &s, &z__[1], &c__1);
ynorm = s * ynorm;
if (anorm != 0.f) {
*rcond = ynorm / anorm;
}
if (anorm == 0.f) {
*rcond = 0.f;
}
return 0;
} /* cspco_ */
/* Subroutine */ int claesy_(complex *a, complex *b, complex *c, complex *rt1,
complex *rt2, complex *evscal, complex *cs1, complex *sn1)
{
/* -- LAPACK auxiliary routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CLAESY computes the eigendecomposition of a 2-by-2 symmetric matrix
( ( A, B );( B, C ) )
provided the norm of the matrix of eigenvectors is larger than
some threshold value.
RT1 is the eigenvalue of larger absolute value, and RT2 of
smaller absolute value. If the eigenvectors are computed, then
on return ( CS1, SN1 ) is the unit eigenvector for RT1, hence
[ CS1 SN1 ] . [ A B ] . [ CS1 -SN1 ] = [ RT1 0 ]
[ -SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]
Arguments
=========
A (input) COMPLEX
The ( 1, 1 ) element of input matrix.
B (input) COMPLEX
The ( 1, 2 ) element of input matrix. The ( 2, 1 ) element
is also given by B, since the 2-by-2 matrix is symmetric.
C (input) COMPLEX
The ( 2, 2 ) element of input matrix.
RT1 (output) COMPLEX
The eigenvalue of larger modulus.
RT2 (output) COMPLEX
The eigenvalue of smaller modulus.
EVSCAL (output) COMPLEX
The complex value by which the eigenvector matrix was scaled
to make it orthonormal. If EVSCAL is zero, the eigenvectors
were not computed. This means one of two things: the 2-by-2
matrix could not be diagonalized, or the norm of the matrix
of eigenvectors before scaling was larger than the threshold
value THRESH (set below).
CS1 (output) COMPLEX
SN1 (output) COMPLEX
If EVSCAL .NE. 0, ( CS1, SN1 ) is the unit right eigenvector
for RT1.
=====================================================================
Special case: The matrix is actually diagonal.
To avoid divide by zero later, we treat this case separately. */
/* Table of constant values */
static complex c_b1 = {1.f,0.f};
static integer c__2 = 2;
/* System generated locals */
real r__1;
doublereal d__1;
complex q__1, q__2, q__3, q__4, q__5, q__6, q__7;
/* Builtin functions */
double c_abs(complex *);
void pow_ci(complex *, complex *, integer *), c_sqrt(complex *, complex *)
, c_div(complex *, complex *, complex *);
/* Local variables */
static real babs, tabs;
static complex s, t;
static real z, evnorm;
static complex tmp;
if (c_abs(b) == 0.f) {
rt1->r = a->r, rt1->i = a->i;
rt2->r = c->r, rt2->i = c->i;
if (c_abs(rt1) < c_abs(rt2)) {
tmp.r = rt1->r, tmp.i = rt1->i;
rt1->r = rt2->r, rt1->i = rt2->i;
rt2->r = tmp.r, rt2->i = tmp.i;
cs1->r = 0.f, cs1->i = 0.f;
sn1->r = 1.f, sn1->i = 0.f;
} else {
cs1->r = 1.f, cs1->i = 0.f;
sn1->r = 0.f, sn1->i = 0.f;
}
} else {
/* Compute the eigenvalues and eigenvectors.
The characteristic equation is
lambda **2 - (A+C) lambda + (A*C - B*B)
and we solve it using the quadratic formula. */
q__2.r = a->r + c->r, q__2.i = a->i + c->i;
q__1.r = q__2.r * .5f, q__1.i = q__2.i * .5f;
s.r = q__1.r, s.i = q__1.i;
q__2.r = a->r - c->r, q__2.i = a->i - c->i;
q__1.r = q__2.r * .5f, q__1.i = q__2.i * .5f;
t.r = q__1.r, t.i = q__1.i;
/* Take the square root carefully to avoid over/under flow. */
babs = c_abs(b);
tabs = c_abs(&t);
z = dmax(babs,tabs);
if (z > 0.f) {
q__5.r = t.r / z, q__5.i = t.i / z;
pow_ci(&q__4, &q__5, &c__2);
q__7.r = b->r / z, q__7.i = b->i / z;
pow_ci(&q__6, &q__7, &c__2);
q__3.r = q__4.r + q__6.r, q__3.i = q__4.i + q__6.i;
c_sqrt(&q__2, &q__3);
q__1.r = z * q__2.r, q__1.i = z * q__2.i;
t.r = q__1.r, t.i = q__1.i;
}
/* Compute the two eigenvalues. RT1 and RT2 are exchanged
if necessary so that RT1 will have the greater magnitude. */
q__1.r = s.r + t.r, q__1.i = s.i + t.i;
rt1->r = q__1.r, rt1->i = q__1.i;
q__1.r = s.r - t.r, q__1.i = s.i - t.i;
rt2->r = q__1.r, rt2->i = q__1.i;
if (c_abs(rt1) < c_abs(rt2)) {
tmp.r = rt1->r, tmp.i = rt1->i;
rt1->r = rt2->r, rt1->i = rt2->i;
rt2->r = tmp.r, rt2->i = tmp.i;
}
/* Choose CS1 = 1 and SN1 to satisfy the first equation, then
scale the components of this eigenvector so that the matrix
of eigenvectors X satisfies X * X' = I . (No scaling is
done if the norm of the eigenvalue matrix is less than THRES
H.) */
q__2.r = rt1->r - a->r, q__2.i = rt1->i - a->i;
c_div(&q__1, &q__2, b);
sn1->r = q__1.r, sn1->i = q__1.i;
tabs = c_abs(sn1);
if (tabs > 1.f) {
/* Computing 2nd power */
r__1 = 1.f / tabs;
d__1 = r__1 * r__1;
q__5.r = sn1->r / tabs, q__5.i = sn1->i / tabs;
pow_ci(&q__4, &q__5, &c__2);
q__3.r = d__1 + q__4.r, q__3.i = q__4.i;
c_sqrt(&q__2, &q__3);
q__1.r = tabs * q__2.r, q__1.i = tabs * q__2.i;
t.r = q__1.r, t.i = q__1.i;
} else {
q__3.r = sn1->r * sn1->r - sn1->i * sn1->i, q__3.i = sn1->r *
sn1->i + sn1->i * sn1->r;
q__2.r = q__3.r + 1.f, q__2.i = q__3.i + 0.f;
c_sqrt(&q__1, &q__2);
t.r = q__1.r, t.i = q__1.i;
}
evnorm = c_abs(&t);
if (evnorm >= .1f) {
c_div(&q__1, &c_b1, &t);
evscal->r = q__1.r, evscal->i = q__1.i;
cs1->r = evscal->r, cs1->i = evscal->i;
q__1.r = sn1->r * evscal->r - sn1->i * evscal->i, q__1.i = sn1->r
* evscal->i + sn1->i * evscal->r;
sn1->r = q__1.r, sn1->i = q__1.i;
} else {
evscal->r = 0.f, evscal->i = 0.f;
}
}
return 0;
/* End of CLAESY */
} /* claesy_ */
int chgeqz_(char *job, char *compq, char *compz, int *n,
int *ilo, int *ihi, complex *h__, int *ldh, complex *t,
int *ldt, complex *alpha, complex *beta, complex *q, int *ldq,
complex *z__, int *ldz, complex *work, int *lwork, float *
rwork, int *info)
{
/* System generated locals */
int h_dim1, h_offset, q_dim1, q_offset, t_dim1, t_offset, z_dim1,
z_offset, i__1, i__2, i__3, i__4, i__5, i__6;
float r__1, r__2, r__3, r__4, r__5, r__6;
complex q__1, q__2, q__3, q__4, q__5, q__6;
/* Builtin functions */
double c_abs(complex *);
void r_cnjg(complex *, complex *);
double r_imag(complex *);
void c_div(complex *, complex *, complex *), pow_ci(complex *, complex *,
int *), c_sqrt(complex *, complex *);
/* Local variables */
float c__;
int j;
complex s, t1;
int jc, in;
complex u12;
int jr;
complex ad11, ad12, ad21, ad22;
int jch;
int ilq, ilz;
float ulp;
complex abi22;
float absb, atol, btol, temp;
extern int crot_(int *, complex *, int *,
complex *, int *, float *, complex *);
float temp2;
extern int cscal_(int *, complex *, complex *,
int *);
extern int lsame_(char *, char *);
complex ctemp;
int iiter, ilast, jiter;
float anorm, bnorm;
int maxit;
complex shift;
float tempr;
complex ctemp2, ctemp3;
int ilazr2;
float ascale, bscale;
complex signbc;
extern double slamch_(char *), clanhs_(char *, int *,
complex *, int *, float *);
extern int claset_(char *, int *, int *, complex
*, complex *, complex *, int *), clartg_(complex *,
complex *, float *, complex *, complex *);
float safmin;
extern int xerbla_(char *, int *);
complex eshift;
int ilschr;
int icompq, ilastm;
complex rtdisc;
int ischur;
int ilazro;
int icompz, ifirst, ifrstm, istart;
int lquery;
/* -- LAPACK routine (version 3.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHGEQZ computes the eigenvalues of a complex matrix pair (H,T), */
/* where H is an upper Hessenberg matrix and T is upper triangular, */
/* using the single-shift QZ method. */
/* Matrix pairs of this type are produced by the reduction to */
/* generalized upper Hessenberg form of a complex matrix pair (A,B): */
/* A = Q1*H*Z1**H, B = Q1*T*Z1**H, */
/* as computed by CGGHRD. */
/* If JOB='S', then the Hessenberg-triangular pair (H,T) is */
/* also reduced to generalized Schur form, */
/* H = Q*S*Z**H, T = Q*P*Z**H, */
/* where Q and Z are unitary matrices and S and P are upper triangular. */
/* Optionally, the unitary matrix Q from the generalized Schur */
/* factorization may be postmultiplied into an input matrix Q1, and the */
/* unitary matrix Z may be postmultiplied into an input matrix Z1. */
/* If Q1 and Z1 are the unitary matrices from CGGHRD that reduced */
/* the matrix pair (A,B) to generalized Hessenberg form, then the output */
/* matrices Q1*Q and Z1*Z are the unitary factors from the generalized */
/* Schur factorization of (A,B): */
/* A = (Q1*Q)*S*(Z1*Z)**H, B = (Q1*Q)*P*(Z1*Z)**H. */
/* To avoid overflow, eigenvalues of the matrix pair (H,T) */
/* (equivalently, of (A,B)) are computed as a pair of complex values */
/* (alpha,beta). If beta is nonzero, lambda = alpha / beta is an */
/* eigenvalue of the generalized nonsymmetric eigenvalue problem (GNEP) */
/* A*x = lambda*B*x */
/* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the */
/* alternate form of the GNEP */
/* mu*A*y = B*y. */
/* The values of alpha and beta for the i-th eigenvalue can be read */
/* directly from the generalized Schur form: alpha = S(i,i), */
/* beta = P(i,i). */
/* Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix */
/* Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), */
/* pp. 241--256. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* = 'E': Compute eigenvalues only; */
/* = 'S': Computer eigenvalues and the Schur form. */
/* COMPQ (input) CHARACTER*1 */
/* = 'N': Left Schur vectors (Q) are not computed; */
/* = 'I': Q is initialized to the unit matrix and the matrix Q */
/* of left Schur vectors of (H,T) is returned; */
/* = 'V': Q must contain a unitary matrix Q1 on entry and */
/* the product Q1*Q is returned. */
/* COMPZ (input) CHARACTER*1 */
/* = 'N': Right Schur vectors (Z) are not computed; */
/* = 'I': Q is initialized to the unit matrix and the matrix Z */
/* of right Schur vectors of (H,T) is returned; */
/* = 'V': Z must contain a unitary matrix Z1 on entry and */
/* the product Z1*Z is returned. */
/* N (input) INTEGER */
/* The order of the matrices H, T, Q, and Z. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* ILO and IHI mark the rows and columns of H which are in */
/* Hessenberg form. It is assumed that A is already upper */
/* triangular in rows and columns 1:ILO-1 and IHI+1:N. */
/* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. */
/* H (input/output) COMPLEX array, dimension (LDH, N) */
/* On entry, the N-by-N upper Hessenberg matrix H. */
/* On exit, if JOB = 'S', H contains the upper triangular */
/* matrix S from the generalized Schur factorization. */
/* If JOB = 'E', the diagonal of H matches that of S, but */
/* the rest of H is unspecified. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH >= MAX( 1, N ). */
/* T (input/output) COMPLEX array, dimension (LDT, N) */
/* On entry, the N-by-N upper triangular matrix T. */
/* On exit, if JOB = 'S', T contains the upper triangular */
/* matrix P from the generalized Schur factorization. */
/* If JOB = 'E', the diagonal of T matches that of P, but */
/* the rest of T is unspecified. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= MAX( 1, N ). */
/* ALPHA (output) COMPLEX array, dimension (N) */
/* The complex scalars alpha that define the eigenvalues of */
/* GNEP. ALPHA(i) = S(i,i) in the generalized Schur */
/* factorization. */
/* BETA (output) COMPLEX array, dimension (N) */
/* The float non-negative scalars beta that define the */
/* eigenvalues of GNEP. BETA(i) = P(i,i) in the generalized */
/* Schur factorization. */
/* Together, the quantities alpha = ALPHA(j) and beta = BETA(j) */
/* represent the j-th eigenvalue of the matrix pair (A,B), in */
/* one of the forms lambda = alpha/beta or mu = beta/alpha. */
/* Since either lambda or mu may overflow, they should not, */
/* in general, be computed. */
/* Q (input/output) COMPLEX array, dimension (LDQ, N) */
/* On entry, if COMPZ = 'V', the unitary matrix Q1 used in the */
/* reduction of (A,B) to generalized Hessenberg form. */
/* On exit, if COMPZ = 'I', the unitary matrix of left Schur */
/* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of */
/* left Schur vectors of (A,B). */
/* Not referenced if COMPZ = 'N'. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= 1. */
/* If COMPQ='V' or 'I', then LDQ >= N. */
/* Z (input/output) COMPLEX array, dimension (LDZ, N) */
/* On entry, if COMPZ = 'V', the unitary matrix Z1 used in the */
/* reduction of (A,B) to generalized Hessenberg form. */
/* On exit, if COMPZ = 'I', the unitary matrix of right Schur */
/* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of */
/* right Schur vectors of (A,B). */
/* Not referenced if COMPZ = 'N'. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1. */
/* If COMPZ='V' or 'I', then LDZ >= N. */
/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO >= 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= MAX(1,N). */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* RWORK (workspace) REAL array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* = 1,...,N: the QZ iteration did not converge. (H,T) is not */
/* in Schur form, but ALPHA(i) and BETA(i), */
/* i=INFO+1,...,N should be correct. */
/* = N+1,...,2*N: the shift calculation failed. (H,T) is not */
/* in Schur form, but ALPHA(i) and BETA(i), */
/* i=INFO-N+1,...,N should be correct. */
/* Further Details */
/* =============== */
/* We assume that complex ABS works as long as its value is less than */
/* overflow. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode JOB, COMPQ, COMPZ */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
--alpha;
--beta;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--rwork;
/* Function Body */
if (lsame_(job, "E")) {
ilschr = FALSE;
ischur = 1;
} else if (lsame_(job, "S")) {
ilschr = TRUE;
ischur = 2;
} else {
ischur = 0;
}
if (lsame_(compq, "N")) {
ilq = FALSE;
icompq = 1;
} else if (lsame_(compq, "V")) {
ilq = TRUE;
icompq = 2;
} else if (lsame_(compq, "I")) {
ilq = TRUE;
icompq = 3;
} else {
icompq = 0;
}
if (lsame_(compz, "N")) {
ilz = FALSE;
icompz = 1;
} else if (lsame_(compz, "V")) {
ilz = TRUE;
icompz = 2;
} else if (lsame_(compz, "I")) {
ilz = TRUE;
icompz = 3;
} else {
icompz = 0;
}
/* Check Argument Values */
*info = 0;
i__1 = MAX(1,*n);
work[1].r = (float) i__1, work[1].i = 0.f;
lquery = *lwork == -1;
if (ischur == 0) {
*info = -1;
} else if (icompq == 0) {
*info = -2;
} else if (icompz == 0) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*ilo < 1) {
*info = -5;
} else if (*ihi > *n || *ihi < *ilo - 1) {
*info = -6;
} else if (*ldh < *n) {
*info = -8;
} else if (*ldt < *n) {
*info = -10;
} else if (*ldq < 1 || ilq && *ldq < *n) {
*info = -14;
} else if (*ldz < 1 || ilz && *ldz < *n) {
*info = -16;
} else if (*lwork < MAX(1,*n) && ! lquery) {
*info = -18;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHGEQZ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
/* WORK( 1 ) = CMPLX( 1 ) */
if (*n <= 0) {
work[1].r = 1.f, work[1].i = 0.f;
return 0;
}
/* Initialize Q and Z */
if (icompq == 3) {
claset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq);
}
if (icompz == 3) {
claset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz);
}
/* Machine Constants */
in = *ihi + 1 - *ilo;
safmin = slamch_("S");
ulp = slamch_("E") * slamch_("B");
anorm = clanhs_("F", &in, &h__[*ilo + *ilo * h_dim1], ldh, &rwork[1]);
bnorm = clanhs_("F", &in, &t[*ilo + *ilo * t_dim1], ldt, &rwork[1]);
/* Computing MAX */
r__1 = safmin, r__2 = ulp * anorm;
atol = MAX(r__1,r__2);
/* Computing MAX */
r__1 = safmin, r__2 = ulp * bnorm;
btol = MAX(r__1,r__2);
ascale = 1.f / MAX(safmin,anorm);
bscale = 1.f / MAX(safmin,bnorm);
/* Set Eigenvalues IHI+1:N */
i__1 = *n;
for (j = *ihi + 1; j <= i__1; ++j) {
absb = c_abs(&t[j + j * t_dim1]);
if (absb > safmin) {
i__2 = j + j * t_dim1;
q__2.r = t[i__2].r / absb, q__2.i = t[i__2].i / absb;
r_cnjg(&q__1, &q__2);
signbc.r = q__1.r, signbc.i = q__1.i;
i__2 = j + j * t_dim1;
t[i__2].r = absb, t[i__2].i = 0.f;
if (ilschr) {
i__2 = j - 1;
cscal_(&i__2, &signbc, &t[j * t_dim1 + 1], &c__1);
cscal_(&j, &signbc, &h__[j * h_dim1 + 1], &c__1);
} else {
i__2 = j + j * h_dim1;
i__3 = j + j * h_dim1;
q__1.r = h__[i__3].r * signbc.r - h__[i__3].i * signbc.i,
q__1.i = h__[i__3].r * signbc.i + h__[i__3].i *
signbc.r;
h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
}
if (ilz) {
cscal_(n, &signbc, &z__[j * z_dim1 + 1], &c__1);
}
} else {
i__2 = j + j * t_dim1;
t[i__2].r = 0.f, t[i__2].i = 0.f;
}
i__2 = j;
i__3 = j + j * h_dim1;
alpha[i__2].r = h__[i__3].r, alpha[i__2].i = h__[i__3].i;
i__2 = j;
i__3 = j + j * t_dim1;
beta[i__2].r = t[i__3].r, beta[i__2].i = t[i__3].i;
/* L10: */
}
/* If IHI < ILO, skip QZ steps */
if (*ihi < *ilo) {
goto L190;
}
/* MAIN QZ ITERATION LOOP */
/* Initialize dynamic indices */
/* Eigenvalues ILAST+1:N have been found. */
/* Column operations modify rows IFRSTM:whatever */
/* Row operations modify columns whatever:ILASTM */
/* If only eigenvalues are being computed, then */
/* IFRSTM is the row of the last splitting row above row ILAST; */
/* this is always at least ILO. */
/* IITER counts iterations since the last eigenvalue was found, */
/* to tell when to use an extraordinary shift. */
/* MAXIT is the maximum number of QZ sweeps allowed. */
ilast = *ihi;
if (ilschr) {
ifrstm = 1;
ilastm = *n;
} else {
ifrstm = *ilo;
ilastm = *ihi;
}
iiter = 0;
eshift.r = 0.f, eshift.i = 0.f;
maxit = (*ihi - *ilo + 1) * 30;
i__1 = maxit;
for (jiter = 1; jiter <= i__1; ++jiter) {
/* Check for too many iterations. */
if (jiter > maxit) {
goto L180;
}
/* Split the matrix if possible. */
/* Two tests: */
/* 1: H(j,j-1)=0 or j=ILO */
/* 2: T(j,j)=0 */
/* Special case: j=ILAST */
if (ilast == *ilo) {
goto L60;
} else {
i__2 = ilast + (ilast - 1) * h_dim1;
if ((r__1 = h__[i__2].r, ABS(r__1)) + (r__2 = r_imag(&h__[ilast
+ (ilast - 1) * h_dim1]), ABS(r__2)) <= atol) {
i__2 = ilast + (ilast - 1) * h_dim1;
h__[i__2].r = 0.f, h__[i__2].i = 0.f;
goto L60;
}
}
if (c_abs(&t[ilast + ilast * t_dim1]) <= btol) {
i__2 = ilast + ilast * t_dim1;
t[i__2].r = 0.f, t[i__2].i = 0.f;
goto L50;
}
/* General case: j<ILAST */
i__2 = *ilo;
for (j = ilast - 1; j >= i__2; --j) {
/* Test 1: for H(j,j-1)=0 or j=ILO */
if (j == *ilo) {
ilazro = TRUE;
} else {
i__3 = j + (j - 1) * h_dim1;
if ((r__1 = h__[i__3].r, ABS(r__1)) + (r__2 = r_imag(&h__[j
+ (j - 1) * h_dim1]), ABS(r__2)) <= atol) {
i__3 = j + (j - 1) * h_dim1;
h__[i__3].r = 0.f, h__[i__3].i = 0.f;
ilazro = TRUE;
} else {
ilazro = FALSE;
}
}
/* Test 2: for T(j,j)=0 */
if (c_abs(&t[j + j * t_dim1]) < btol) {
i__3 = j + j * t_dim1;
t[i__3].r = 0.f, t[i__3].i = 0.f;
/* Test 1a: Check for 2 consecutive small subdiagonals in A */
ilazr2 = FALSE;
if (! ilazro) {
i__3 = j + (j - 1) * h_dim1;
i__4 = j + 1 + j * h_dim1;
i__5 = j + j * h_dim1;
if (((r__1 = h__[i__3].r, ABS(r__1)) + (r__2 = r_imag(&
h__[j + (j - 1) * h_dim1]), ABS(r__2))) * (
ascale * ((r__3 = h__[i__4].r, ABS(r__3)) + (
r__4 = r_imag(&h__[j + 1 + j * h_dim1]), ABS(
r__4)))) <= ((r__5 = h__[i__5].r, ABS(r__5)) + (
r__6 = r_imag(&h__[j + j * h_dim1]), ABS(r__6)))
* (ascale * atol)) {
ilazr2 = TRUE;
}
}
/* If both tests pass (1 & 2), i.e., the leading diagonal */
/* element of B in the block is zero, split a 1x1 block off */
/* at the top. (I.e., at the J-th row/column) The leading */
/* diagonal element of the remainder can also be zero, so */
/* this may have to be done repeatedly. */
if (ilazro || ilazr2) {
i__3 = ilast - 1;
for (jch = j; jch <= i__3; ++jch) {
i__4 = jch + jch * h_dim1;
ctemp.r = h__[i__4].r, ctemp.i = h__[i__4].i;
clartg_(&ctemp, &h__[jch + 1 + jch * h_dim1], &c__, &
s, &h__[jch + jch * h_dim1]);
i__4 = jch + 1 + jch * h_dim1;
h__[i__4].r = 0.f, h__[i__4].i = 0.f;
i__4 = ilastm - jch;
crot_(&i__4, &h__[jch + (jch + 1) * h_dim1], ldh, &
h__[jch + 1 + (jch + 1) * h_dim1], ldh, &c__,
&s);
i__4 = ilastm - jch;
crot_(&i__4, &t[jch + (jch + 1) * t_dim1], ldt, &t[
jch + 1 + (jch + 1) * t_dim1], ldt, &c__, &s);
if (ilq) {
r_cnjg(&q__1, &s);
crot_(n, &q[jch * q_dim1 + 1], &c__1, &q[(jch + 1)
* q_dim1 + 1], &c__1, &c__, &q__1);
}
if (ilazr2) {
i__4 = jch + (jch - 1) * h_dim1;
i__5 = jch + (jch - 1) * h_dim1;
q__1.r = c__ * h__[i__5].r, q__1.i = c__ * h__[
i__5].i;
h__[i__4].r = q__1.r, h__[i__4].i = q__1.i;
}
ilazr2 = FALSE;
i__4 = jch + 1 + (jch + 1) * t_dim1;
if ((r__1 = t[i__4].r, ABS(r__1)) + (r__2 = r_imag(&
t[jch + 1 + (jch + 1) * t_dim1]), ABS(r__2))
>= btol) {
if (jch + 1 >= ilast) {
goto L60;
} else {
ifirst = jch + 1;
goto L70;
}
}
i__4 = jch + 1 + (jch + 1) * t_dim1;
t[i__4].r = 0.f, t[i__4].i = 0.f;
/* L20: */
}
goto L50;
} else {
/* Only test 2 passed -- chase the zero to T(ILAST,ILAST) */
/* Then process as in the case T(ILAST,ILAST)=0 */
i__3 = ilast - 1;
for (jch = j; jch <= i__3; ++jch) {
i__4 = jch + (jch + 1) * t_dim1;
ctemp.r = t[i__4].r, ctemp.i = t[i__4].i;
clartg_(&ctemp, &t[jch + 1 + (jch + 1) * t_dim1], &
c__, &s, &t[jch + (jch + 1) * t_dim1]);
i__4 = jch + 1 + (jch + 1) * t_dim1;
t[i__4].r = 0.f, t[i__4].i = 0.f;
if (jch < ilastm - 1) {
i__4 = ilastm - jch - 1;
crot_(&i__4, &t[jch + (jch + 2) * t_dim1], ldt, &
t[jch + 1 + (jch + 2) * t_dim1], ldt, &
c__, &s);
}
i__4 = ilastm - jch + 2;
crot_(&i__4, &h__[jch + (jch - 1) * h_dim1], ldh, &
h__[jch + 1 + (jch - 1) * h_dim1], ldh, &c__,
&s);
if (ilq) {
r_cnjg(&q__1, &s);
crot_(n, &q[jch * q_dim1 + 1], &c__1, &q[(jch + 1)
* q_dim1 + 1], &c__1, &c__, &q__1);
}
i__4 = jch + 1 + jch * h_dim1;
ctemp.r = h__[i__4].r, ctemp.i = h__[i__4].i;
clartg_(&ctemp, &h__[jch + 1 + (jch - 1) * h_dim1], &
c__, &s, &h__[jch + 1 + jch * h_dim1]);
i__4 = jch + 1 + (jch - 1) * h_dim1;
h__[i__4].r = 0.f, h__[i__4].i = 0.f;
i__4 = jch + 1 - ifrstm;
crot_(&i__4, &h__[ifrstm + jch * h_dim1], &c__1, &h__[
ifrstm + (jch - 1) * h_dim1], &c__1, &c__, &s)
;
i__4 = jch - ifrstm;
crot_(&i__4, &t[ifrstm + jch * t_dim1], &c__1, &t[
ifrstm + (jch - 1) * t_dim1], &c__1, &c__, &s)
;
if (ilz) {
crot_(n, &z__[jch * z_dim1 + 1], &c__1, &z__[(jch
- 1) * z_dim1 + 1], &c__1, &c__, &s);
}
/* L30: */
}
goto L50;
}
} else if (ilazro) {
/* Only test 1 passed -- work on J:ILAST */
ifirst = j;
goto L70;
}
/* Neither test passed -- try next J */
/* L40: */
}
/* (Drop-through is "impossible") */
*info = (*n << 1) + 1;
goto L210;
/* T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a */
/* 1x1 block. */
L50:
i__2 = ilast + ilast * h_dim1;
ctemp.r = h__[i__2].r, ctemp.i = h__[i__2].i;
clartg_(&ctemp, &h__[ilast + (ilast - 1) * h_dim1], &c__, &s, &h__[
ilast + ilast * h_dim1]);
i__2 = ilast + (ilast - 1) * h_dim1;
h__[i__2].r = 0.f, h__[i__2].i = 0.f;
i__2 = ilast - ifrstm;
crot_(&i__2, &h__[ifrstm + ilast * h_dim1], &c__1, &h__[ifrstm + (
ilast - 1) * h_dim1], &c__1, &c__, &s);
i__2 = ilast - ifrstm;
crot_(&i__2, &t[ifrstm + ilast * t_dim1], &c__1, &t[ifrstm + (ilast -
1) * t_dim1], &c__1, &c__, &s);
if (ilz) {
crot_(n, &z__[ilast * z_dim1 + 1], &c__1, &z__[(ilast - 1) *
z_dim1 + 1], &c__1, &c__, &s);
}
/* H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHA and BETA */
L60:
absb = c_abs(&t[ilast + ilast * t_dim1]);
if (absb > safmin) {
i__2 = ilast + ilast * t_dim1;
q__2.r = t[i__2].r / absb, q__2.i = t[i__2].i / absb;
r_cnjg(&q__1, &q__2);
signbc.r = q__1.r, signbc.i = q__1.i;
i__2 = ilast + ilast * t_dim1;
t[i__2].r = absb, t[i__2].i = 0.f;
if (ilschr) {
i__2 = ilast - ifrstm;
cscal_(&i__2, &signbc, &t[ifrstm + ilast * t_dim1], &c__1);
i__2 = ilast + 1 - ifrstm;
cscal_(&i__2, &signbc, &h__[ifrstm + ilast * h_dim1], &c__1);
} else {
i__2 = ilast + ilast * h_dim1;
i__3 = ilast + ilast * h_dim1;
q__1.r = h__[i__3].r * signbc.r - h__[i__3].i * signbc.i,
q__1.i = h__[i__3].r * signbc.i + h__[i__3].i *
signbc.r;
h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
}
if (ilz) {
cscal_(n, &signbc, &z__[ilast * z_dim1 + 1], &c__1);
}
} else {
i__2 = ilast + ilast * t_dim1;
t[i__2].r = 0.f, t[i__2].i = 0.f;
}
i__2 = ilast;
i__3 = ilast + ilast * h_dim1;
alpha[i__2].r = h__[i__3].r, alpha[i__2].i = h__[i__3].i;
i__2 = ilast;
i__3 = ilast + ilast * t_dim1;
beta[i__2].r = t[i__3].r, beta[i__2].i = t[i__3].i;
/* Go to next block -- exit if finished. */
--ilast;
if (ilast < *ilo) {
goto L190;
}
/* Reset counters */
iiter = 0;
eshift.r = 0.f, eshift.i = 0.f;
if (! ilschr) {
ilastm = ilast;
if (ifrstm > ilast) {
ifrstm = *ilo;
}
}
goto L160;
/* QZ step */
/* This iteration only involves rows/columns IFIRST:ILAST. We */
/* assume IFIRST < ILAST, and that the diagonal of B is non-zero. */
L70:
++iiter;
if (! ilschr) {
ifrstm = ifirst;
}
/* Compute the Shift. */
/* At this point, IFIRST < ILAST, and the diagonal elements of */
/* T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in */
/* magnitude) */
if (iiter / 10 * 10 != iiter) {
/* The Wilkinson shift (AEP p.512), i.e., the eigenvalue of */
/* the bottom-right 2x2 block of A inv(B) which is nearest to */
/* the bottom-right element. */
/* We factor B as U*D, where U has unit diagonals, and */
/* compute (A*inv(D))*inv(U). */
i__2 = ilast - 1 + ilast * t_dim1;
q__2.r = bscale * t[i__2].r, q__2.i = bscale * t[i__2].i;
i__3 = ilast + ilast * t_dim1;
q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
c_div(&q__1, &q__2, &q__3);
u12.r = q__1.r, u12.i = q__1.i;
i__2 = ilast - 1 + (ilast - 1) * h_dim1;
q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
i__3 = ilast - 1 + (ilast - 1) * t_dim1;
q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
c_div(&q__1, &q__2, &q__3);
ad11.r = q__1.r, ad11.i = q__1.i;
i__2 = ilast + (ilast - 1) * h_dim1;
q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
i__3 = ilast - 1 + (ilast - 1) * t_dim1;
q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
c_div(&q__1, &q__2, &q__3);
ad21.r = q__1.r, ad21.i = q__1.i;
i__2 = ilast - 1 + ilast * h_dim1;
q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
i__3 = ilast + ilast * t_dim1;
q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
c_div(&q__1, &q__2, &q__3);
ad12.r = q__1.r, ad12.i = q__1.i;
i__2 = ilast + ilast * h_dim1;
q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
i__3 = ilast + ilast * t_dim1;
q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
c_div(&q__1, &q__2, &q__3);
ad22.r = q__1.r, ad22.i = q__1.i;
q__2.r = u12.r * ad21.r - u12.i * ad21.i, q__2.i = u12.r * ad21.i
+ u12.i * ad21.r;
q__1.r = ad22.r - q__2.r, q__1.i = ad22.i - q__2.i;
abi22.r = q__1.r, abi22.i = q__1.i;
q__2.r = ad11.r + abi22.r, q__2.i = ad11.i + abi22.i;
q__1.r = q__2.r * .5f, q__1.i = q__2.i * .5f;
t1.r = q__1.r, t1.i = q__1.i;
pow_ci(&q__4, &t1, &c__2);
q__5.r = ad12.r * ad21.r - ad12.i * ad21.i, q__5.i = ad12.r *
ad21.i + ad12.i * ad21.r;
q__3.r = q__4.r + q__5.r, q__3.i = q__4.i + q__5.i;
q__6.r = ad11.r * ad22.r - ad11.i * ad22.i, q__6.i = ad11.r *
ad22.i + ad11.i * ad22.r;
q__2.r = q__3.r - q__6.r, q__2.i = q__3.i - q__6.i;
c_sqrt(&q__1, &q__2);
rtdisc.r = q__1.r, rtdisc.i = q__1.i;
q__1.r = t1.r - abi22.r, q__1.i = t1.i - abi22.i;
q__2.r = t1.r - abi22.r, q__2.i = t1.i - abi22.i;
temp = q__1.r * rtdisc.r + r_imag(&q__2) * r_imag(&rtdisc);
if (temp <= 0.f) {
q__1.r = t1.r + rtdisc.r, q__1.i = t1.i + rtdisc.i;
shift.r = q__1.r, shift.i = q__1.i;
} else {
q__1.r = t1.r - rtdisc.r, q__1.i = t1.i - rtdisc.i;
shift.r = q__1.r, shift.i = q__1.i;
}
} else {
/* Exceptional shift. Chosen for no particularly good reason. */
i__2 = ilast - 1 + ilast * h_dim1;
q__4.r = ascale * h__[i__2].r, q__4.i = ascale * h__[i__2].i;
i__3 = ilast - 1 + (ilast - 1) * t_dim1;
q__5.r = bscale * t[i__3].r, q__5.i = bscale * t[i__3].i;
c_div(&q__3, &q__4, &q__5);
r_cnjg(&q__2, &q__3);
q__1.r = eshift.r + q__2.r, q__1.i = eshift.i + q__2.i;
eshift.r = q__1.r, eshift.i = q__1.i;
shift.r = eshift.r, shift.i = eshift.i;
}
/* Now check for two consecutive small subdiagonals. */
i__2 = ifirst + 1;
for (j = ilast - 1; j >= i__2; --j) {
istart = j;
i__3 = j + j * h_dim1;
q__2.r = ascale * h__[i__3].r, q__2.i = ascale * h__[i__3].i;
i__4 = j + j * t_dim1;
q__4.r = bscale * t[i__4].r, q__4.i = bscale * t[i__4].i;
q__3.r = shift.r * q__4.r - shift.i * q__4.i, q__3.i = shift.r *
q__4.i + shift.i * q__4.r;
q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
temp = (r__1 = ctemp.r, ABS(r__1)) + (r__2 = r_imag(&ctemp),
ABS(r__2));
i__3 = j + 1 + j * h_dim1;
temp2 = ascale * ((r__1 = h__[i__3].r, ABS(r__1)) + (r__2 =
r_imag(&h__[j + 1 + j * h_dim1]), ABS(r__2)));
tempr = MAX(temp,temp2);
if (tempr < 1.f && tempr != 0.f) {
temp /= tempr;
temp2 /= tempr;
}
i__3 = j + (j - 1) * h_dim1;
if (((r__1 = h__[i__3].r, ABS(r__1)) + (r__2 = r_imag(&h__[j + (
j - 1) * h_dim1]), ABS(r__2))) * temp2 <= temp * atol) {
goto L90;
}
/* L80: */
}
istart = ifirst;
i__2 = ifirst + ifirst * h_dim1;
q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
i__3 = ifirst + ifirst * t_dim1;
q__4.r = bscale * t[i__3].r, q__4.i = bscale * t[i__3].i;
q__3.r = shift.r * q__4.r - shift.i * q__4.i, q__3.i = shift.r *
q__4.i + shift.i * q__4.r;
q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
L90:
/* Do an implicit-shift QZ sweep. */
/* Initial Q */
i__2 = istart + 1 + istart * h_dim1;
q__1.r = ascale * h__[i__2].r, q__1.i = ascale * h__[i__2].i;
ctemp2.r = q__1.r, ctemp2.i = q__1.i;
clartg_(&ctemp, &ctemp2, &c__, &s, &ctemp3);
/* Sweep */
i__2 = ilast - 1;
for (j = istart; j <= i__2; ++j) {
if (j > istart) {
i__3 = j + (j - 1) * h_dim1;
ctemp.r = h__[i__3].r, ctemp.i = h__[i__3].i;
clartg_(&ctemp, &h__[j + 1 + (j - 1) * h_dim1], &c__, &s, &
h__[j + (j - 1) * h_dim1]);
i__3 = j + 1 + (j - 1) * h_dim1;
h__[i__3].r = 0.f, h__[i__3].i = 0.f;
}
i__3 = ilastm;
for (jc = j; jc <= i__3; ++jc) {
i__4 = j + jc * h_dim1;
q__2.r = c__ * h__[i__4].r, q__2.i = c__ * h__[i__4].i;
i__5 = j + 1 + jc * h_dim1;
q__3.r = s.r * h__[i__5].r - s.i * h__[i__5].i, q__3.i = s.r *
h__[i__5].i + s.i * h__[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__4 = j + 1 + jc * h_dim1;
r_cnjg(&q__4, &s);
q__3.r = -q__4.r, q__3.i = -q__4.i;
i__5 = j + jc * h_dim1;
q__2.r = q__3.r * h__[i__5].r - q__3.i * h__[i__5].i, q__2.i =
q__3.r * h__[i__5].i + q__3.i * h__[i__5].r;
i__6 = j + 1 + jc * h_dim1;
q__5.r = c__ * h__[i__6].r, q__5.i = c__ * h__[i__6].i;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
h__[i__4].r = q__1.r, h__[i__4].i = q__1.i;
i__4 = j + jc * h_dim1;
h__[i__4].r = ctemp.r, h__[i__4].i = ctemp.i;
i__4 = j + jc * t_dim1;
q__2.r = c__ * t[i__4].r, q__2.i = c__ * t[i__4].i;
i__5 = j + 1 + jc * t_dim1;
q__3.r = s.r * t[i__5].r - s.i * t[i__5].i, q__3.i = s.r * t[
i__5].i + s.i * t[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
ctemp2.r = q__1.r, ctemp2.i = q__1.i;
i__4 = j + 1 + jc * t_dim1;
r_cnjg(&q__4, &s);
q__3.r = -q__4.r, q__3.i = -q__4.i;
i__5 = j + jc * t_dim1;
q__2.r = q__3.r * t[i__5].r - q__3.i * t[i__5].i, q__2.i =
q__3.r * t[i__5].i + q__3.i * t[i__5].r;
i__6 = j + 1 + jc * t_dim1;
q__5.r = c__ * t[i__6].r, q__5.i = c__ * t[i__6].i;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
t[i__4].r = q__1.r, t[i__4].i = q__1.i;
i__4 = j + jc * t_dim1;
t[i__4].r = ctemp2.r, t[i__4].i = ctemp2.i;
/* L100: */
}
if (ilq) {
i__3 = *n;
for (jr = 1; jr <= i__3; ++jr) {
i__4 = jr + j * q_dim1;
q__2.r = c__ * q[i__4].r, q__2.i = c__ * q[i__4].i;
r_cnjg(&q__4, &s);
i__5 = jr + (j + 1) * q_dim1;
q__3.r = q__4.r * q[i__5].r - q__4.i * q[i__5].i, q__3.i =
q__4.r * q[i__5].i + q__4.i * q[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__4 = jr + (j + 1) * q_dim1;
q__3.r = -s.r, q__3.i = -s.i;
i__5 = jr + j * q_dim1;
q__2.r = q__3.r * q[i__5].r - q__3.i * q[i__5].i, q__2.i =
q__3.r * q[i__5].i + q__3.i * q[i__5].r;
i__6 = jr + (j + 1) * q_dim1;
q__4.r = c__ * q[i__6].r, q__4.i = c__ * q[i__6].i;
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
q[i__4].r = q__1.r, q[i__4].i = q__1.i;
i__4 = jr + j * q_dim1;
q[i__4].r = ctemp.r, q[i__4].i = ctemp.i;
/* L110: */
}
}
i__3 = j + 1 + (j + 1) * t_dim1;
ctemp.r = t[i__3].r, ctemp.i = t[i__3].i;
clartg_(&ctemp, &t[j + 1 + j * t_dim1], &c__, &s, &t[j + 1 + (j +
1) * t_dim1]);
i__3 = j + 1 + j * t_dim1;
t[i__3].r = 0.f, t[i__3].i = 0.f;
/* Computing MIN */
i__4 = j + 2;
i__3 = MIN(i__4,ilast);
for (jr = ifrstm; jr <= i__3; ++jr) {
i__4 = jr + (j + 1) * h_dim1;
q__2.r = c__ * h__[i__4].r, q__2.i = c__ * h__[i__4].i;
i__5 = jr + j * h_dim1;
q__3.r = s.r * h__[i__5].r - s.i * h__[i__5].i, q__3.i = s.r *
h__[i__5].i + s.i * h__[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__4 = jr + j * h_dim1;
r_cnjg(&q__4, &s);
q__3.r = -q__4.r, q__3.i = -q__4.i;
i__5 = jr + (j + 1) * h_dim1;
q__2.r = q__3.r * h__[i__5].r - q__3.i * h__[i__5].i, q__2.i =
q__3.r * h__[i__5].i + q__3.i * h__[i__5].r;
i__6 = jr + j * h_dim1;
q__5.r = c__ * h__[i__6].r, q__5.i = c__ * h__[i__6].i;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
h__[i__4].r = q__1.r, h__[i__4].i = q__1.i;
i__4 = jr + (j + 1) * h_dim1;
h__[i__4].r = ctemp.r, h__[i__4].i = ctemp.i;
/* L120: */
}
i__3 = j;
for (jr = ifrstm; jr <= i__3; ++jr) {
i__4 = jr + (j + 1) * t_dim1;
q__2.r = c__ * t[i__4].r, q__2.i = c__ * t[i__4].i;
i__5 = jr + j * t_dim1;
q__3.r = s.r * t[i__5].r - s.i * t[i__5].i, q__3.i = s.r * t[
i__5].i + s.i * t[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__4 = jr + j * t_dim1;
r_cnjg(&q__4, &s);
q__3.r = -q__4.r, q__3.i = -q__4.i;
i__5 = jr + (j + 1) * t_dim1;
q__2.r = q__3.r * t[i__5].r - q__3.i * t[i__5].i, q__2.i =
q__3.r * t[i__5].i + q__3.i * t[i__5].r;
i__6 = jr + j * t_dim1;
q__5.r = c__ * t[i__6].r, q__5.i = c__ * t[i__6].i;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
t[i__4].r = q__1.r, t[i__4].i = q__1.i;
i__4 = jr + (j + 1) * t_dim1;
t[i__4].r = ctemp.r, t[i__4].i = ctemp.i;
/* L130: */
}
if (ilz) {
i__3 = *n;
for (jr = 1; jr <= i__3; ++jr) {
i__4 = jr + (j + 1) * z_dim1;
q__2.r = c__ * z__[i__4].r, q__2.i = c__ * z__[i__4].i;
i__5 = jr + j * z_dim1;
q__3.r = s.r * z__[i__5].r - s.i * z__[i__5].i, q__3.i =
s.r * z__[i__5].i + s.i * z__[i__5].r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__4 = jr + j * z_dim1;
r_cnjg(&q__4, &s);
q__3.r = -q__4.r, q__3.i = -q__4.i;
i__5 = jr + (j + 1) * z_dim1;
q__2.r = q__3.r * z__[i__5].r - q__3.i * z__[i__5].i,
q__2.i = q__3.r * z__[i__5].i + q__3.i * z__[i__5]
.r;
i__6 = jr + j * z_dim1;
q__5.r = c__ * z__[i__6].r, q__5.i = c__ * z__[i__6].i;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
z__[i__4].r = q__1.r, z__[i__4].i = q__1.i;
i__4 = jr + (j + 1) * z_dim1;
z__[i__4].r = ctemp.r, z__[i__4].i = ctemp.i;
/* L140: */
}
}
/* L150: */
}
L160:
/* L170: */
;
}
/* Drop-through = non-convergence */
L180:
*info = ilast;
goto L210;
/* Successful completion of all QZ steps */
L190:
/* Set Eigenvalues 1:ILO-1 */
i__1 = *ilo - 1;
for (j = 1; j <= i__1; ++j) {
absb = c_abs(&t[j + j * t_dim1]);
if (absb > safmin) {
i__2 = j + j * t_dim1;
q__2.r = t[i__2].r / absb, q__2.i = t[i__2].i / absb;
r_cnjg(&q__1, &q__2);
signbc.r = q__1.r, signbc.i = q__1.i;
i__2 = j + j * t_dim1;
t[i__2].r = absb, t[i__2].i = 0.f;
if (ilschr) {
i__2 = j - 1;
cscal_(&i__2, &signbc, &t[j * t_dim1 + 1], &c__1);
cscal_(&j, &signbc, &h__[j * h_dim1 + 1], &c__1);
} else {
i__2 = j + j * h_dim1;
i__3 = j + j * h_dim1;
q__1.r = h__[i__3].r * signbc.r - h__[i__3].i * signbc.i,
q__1.i = h__[i__3].r * signbc.i + h__[i__3].i *
signbc.r;
h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
}
if (ilz) {
cscal_(n, &signbc, &z__[j * z_dim1 + 1], &c__1);
}
} else {
i__2 = j + j * t_dim1;
t[i__2].r = 0.f, t[i__2].i = 0.f;
}
i__2 = j;
i__3 = j + j * h_dim1;
alpha[i__2].r = h__[i__3].r, alpha[i__2].i = h__[i__3].i;
i__2 = j;
i__3 = j + j * t_dim1;
beta[i__2].r = t[i__3].r, beta[i__2].i = t[i__3].i;
/* L200: */
}
/* Normal Termination */
*info = 0;
/* Exit (other than argument error) -- return optimal workspace size */
L210:
q__1.r = (float) (*n), q__1.i = 0.f;
work[1].r = q__1.r, work[1].i = q__1.i;
return 0;
/* End of CHGEQZ */
} /* chgeqz_ */
/* DECK CUNK1 */
/* Subroutine */ int cunk1_(complex *z__, real *fnu, integer *kode, integer *
mr, integer *n, complex *y, integer *nz, real *tol, real *elim, real *
alim)
{
/* Initialized data */
static complex czero = {0.f,0.f};
static complex cone = {1.f,0.f};
static real pi = 3.14159265358979324f;
/* System generated locals */
integer i__1, i__2, i__3;
real r__1, r__2;
complex q__1, q__2, q__3, q__4, q__5;
/* Local variables */
static integer i__, j, k, m;
static real x;
static complex c1, c2, s1, s2;
static integer ib, ic;
static complex ck;
static real fn;
static integer il;
static complex cs;
static integer kk;
static complex cy[2];
static integer nw;
static complex rz, zr;
static real c2i, c2m, c2r, rs1, ang;
static complex cfn;
static real asc, fnf;
static integer ifn;
static complex phi[2];
static real cpn;
static integer iuf;
static real fmr;
static complex csr[3], css[3];
static real sgn;
static integer inu;
static real bry[3], spn;
static complex sum[2];
static real aphi;
static complex cscl, phid, crsc, csgn;
extern /* Subroutine */ int cs1s2_(complex *, complex *, complex *,
integer *, real *, real *, integer *);
static complex cspn;
static integer init[2];
static complex cwrk[48] /* was [16][3] */, sumd, zeta1[2], zeta2[2];
static integer iflag, kflag;
static real ascle;
static integer kdflg;
extern /* Subroutine */ int cuchk_(complex *, integer *, real *, real *);
static integer ipard, initd;
extern /* Subroutine */ int cunik_(complex *, real *, integer *, integer *
, real *, integer *, complex *, complex *, complex *, complex *,
complex *);
extern doublereal r1mach_(integer *);
static complex zeta1d, zeta2d;
/* ***BEGIN PROLOGUE CUNK1 */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to CBESK */
/* ***LIBRARY SLATEC */
/* ***TYPE ALL (CUNK1-A, ZUNK1-A) */
/* ***AUTHOR Amos, D. E., (SNL) */
/* ***DESCRIPTION */
/* CUNK1 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE */
/* RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE */
/* UNIFORM ASYMPTOTIC EXPANSION. */
/* MR INDICATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION. */
/* NZ=-1 MEANS AN OVERFLOW WILL OCCUR */
/* ***SEE ALSO CBESK */
/* ***ROUTINES CALLED CS1S2, CUCHK, CUNIK, R1MACH */
/* ***REVISION HISTORY (YYMMDD) */
/* 830501 DATE WRITTEN */
/* 910415 Prologue converted to Version 4.0 format. (BAB) */
/* ***END PROLOGUE CUNK1 */
/* Parameter adjustments */
--y;
/* Function Body */
/* ***FIRST EXECUTABLE STATEMENT CUNK1 */
kdflg = 1;
*nz = 0;
/* ----------------------------------------------------------------------- */
/* EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN */
/* THE UNDERFLOW LIMIT */
/* ----------------------------------------------------------------------- */
r__1 = 1.f / *tol;
q__1.r = r__1, q__1.i = 0.f;
cscl.r = q__1.r, cscl.i = q__1.i;
q__1.r = *tol, q__1.i = 0.f;
crsc.r = q__1.r, crsc.i = q__1.i;
css[0].r = cscl.r, css[0].i = cscl.i;
css[1].r = cone.r, css[1].i = cone.i;
css[2].r = crsc.r, css[2].i = crsc.i;
csr[0].r = crsc.r, csr[0].i = crsc.i;
csr[1].r = cone.r, csr[1].i = cone.i;
csr[2].r = cscl.r, csr[2].i = cscl.i;
bry[0] = r1mach_(&c__1) * 1e3f / *tol;
bry[1] = 1.f / bry[0];
bry[2] = r1mach_(&c__2);
x = z__->r;
zr.r = z__->r, zr.i = z__->i;
if (x < 0.f) {
q__1.r = -z__->r, q__1.i = -z__->i;
zr.r = q__1.r, zr.i = q__1.i;
}
j = 2;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* ----------------------------------------------------------------------- */
/* J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J */
/* ----------------------------------------------------------------------- */
j = 3 - j;
fn = *fnu + (i__ - 1);
init[j - 1] = 0;
cunik_(&zr, &fn, &c__2, &c__0, tol, &init[j - 1], &phi[j - 1], &zeta1[
j - 1], &zeta2[j - 1], &sum[j - 1], &cwrk[(j << 4) - 16]);
if (*kode == 1) {
goto L20;
}
q__1.r = fn, q__1.i = 0.f;
cfn.r = q__1.r, cfn.i = q__1.i;
i__2 = j - 1;
i__3 = j - 1;
q__4.r = zr.r + zeta2[i__3].r, q__4.i = zr.i + zeta2[i__3].i;
c_div(&q__3, &cfn, &q__4);
q__2.r = cfn.r * q__3.r - cfn.i * q__3.i, q__2.i = cfn.r * q__3.i +
cfn.i * q__3.r;
q__1.r = zeta1[i__2].r - q__2.r, q__1.i = zeta1[i__2].i - q__2.i;
s1.r = q__1.r, s1.i = q__1.i;
goto L30;
L20:
i__2 = j - 1;
i__3 = j - 1;
q__1.r = zeta1[i__2].r - zeta2[i__3].r, q__1.i = zeta1[i__2].i -
zeta2[i__3].i;
s1.r = q__1.r, s1.i = q__1.i;
L30:
/* ----------------------------------------------------------------------- */
/* TEST FOR UNDERFLOW AND OVERFLOW */
/* ----------------------------------------------------------------------- */
rs1 = s1.r;
if (dabs(rs1) > *elim) {
goto L60;
}
if (kdflg == 1) {
kflag = 2;
}
if (dabs(rs1) < *alim) {
goto L40;
}
/* ----------------------------------------------------------------------- */
/* REFINE TEST AND SCALE */
/* ----------------------------------------------------------------------- */
aphi = c_abs(&phi[j - 1]);
rs1 += log(aphi);
if (dabs(rs1) > *elim) {
goto L60;
}
if (kdflg == 1) {
kflag = 1;
}
if (rs1 < 0.f) {
goto L40;
}
if (kdflg == 1) {
kflag = 3;
}
L40:
/* ----------------------------------------------------------------------- */
/* SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR */
/* EXPONENT EXTREMES */
/* ----------------------------------------------------------------------- */
i__2 = j - 1;
i__3 = j - 1;
q__1.r = phi[i__2].r * sum[i__3].r - phi[i__2].i * sum[i__3].i,
q__1.i = phi[i__2].r * sum[i__3].i + phi[i__2].i * sum[i__3]
.r;
s2.r = q__1.r, s2.i = q__1.i;
c2r = s1.r;
c2i = r_imag(&s1);
i__2 = kflag - 1;
c2m = exp(c2r) * css[i__2].r;
q__2.r = c2m, q__2.i = 0.f;
r__1 = cos(c2i);
r__2 = sin(c2i);
q__3.r = r__1, q__3.i = r__2;
q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = q__2.r * q__3.i
+ q__2.i * q__3.r;
s1.r = q__1.r, s1.i = q__1.i;
q__1.r = s2.r * s1.r - s2.i * s1.i, q__1.i = s2.r * s1.i + s2.i *
s1.r;
s2.r = q__1.r, s2.i = q__1.i;
if (kflag != 1) {
goto L50;
}
cuchk_(&s2, &nw, bry, tol);
if (nw != 0) {
goto L60;
}
L50:
i__2 = kdflg - 1;
cy[i__2].r = s2.r, cy[i__2].i = s2.i;
i__2 = i__;
i__3 = kflag - 1;
q__1.r = s2.r * csr[i__3].r - s2.i * csr[i__3].i, q__1.i = s2.r * csr[
i__3].i + s2.i * csr[i__3].r;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
if (kdflg == 2) {
goto L75;
}
kdflg = 2;
goto L70;
L60:
if (rs1 > 0.f) {
goto L290;
}
/* ----------------------------------------------------------------------- */
/* FOR X.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW */
/* ----------------------------------------------------------------------- */
if (x < 0.f) {
goto L290;
}
kdflg = 1;
i__2 = i__;
y[i__2].r = czero.r, y[i__2].i = czero.i;
++(*nz);
if (i__ == 1) {
goto L70;
}
i__2 = i__ - 1;
if (y[i__2].r == czero.r && y[i__2].i == czero.i) {
goto L70;
}
i__2 = i__ - 1;
y[i__2].r = czero.r, y[i__2].i = czero.i;
++(*nz);
L70:
;
}
i__ = *n;
L75:
c_div(&q__1, &c_b14, &zr);
rz.r = q__1.r, rz.i = q__1.i;
q__2.r = fn, q__2.i = 0.f;
q__1.r = q__2.r * rz.r - q__2.i * rz.i, q__1.i = q__2.r * rz.i + q__2.i *
rz.r;
ck.r = q__1.r, ck.i = q__1.i;
ib = i__ + 1;
if (*n < ib) {
goto L160;
}
/* ----------------------------------------------------------------------- */
/* TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW, SET SEQUENCE TO ZERO */
/* ON UNDERFLOW */
/* ----------------------------------------------------------------------- */
fn = *fnu + (*n - 1);
ipard = 1;
if (*mr != 0) {
ipard = 0;
}
initd = 0;
cunik_(&zr, &fn, &c__2, &ipard, tol, &initd, &phid, &zeta1d, &zeta2d, &
sumd, &cwrk[32]);
if (*kode == 1) {
goto L80;
}
q__1.r = fn, q__1.i = 0.f;
cfn.r = q__1.r, cfn.i = q__1.i;
q__4.r = zr.r + zeta2d.r, q__4.i = zr.i + zeta2d.i;
c_div(&q__3, &cfn, &q__4);
q__2.r = cfn.r * q__3.r - cfn.i * q__3.i, q__2.i = cfn.r * q__3.i + cfn.i
* q__3.r;
q__1.r = zeta1d.r - q__2.r, q__1.i = zeta1d.i - q__2.i;
s1.r = q__1.r, s1.i = q__1.i;
goto L90;
L80:
q__1.r = zeta1d.r - zeta2d.r, q__1.i = zeta1d.i - zeta2d.i;
s1.r = q__1.r, s1.i = q__1.i;
L90:
rs1 = s1.r;
if (dabs(rs1) > *elim) {
goto L95;
}
if (dabs(rs1) < *alim) {
goto L100;
}
/* ----------------------------------------------------------------------- */
/* REFINE ESTIMATE AND TEST */
/* ----------------------------------------------------------------------- */
aphi = c_abs(&phid);
rs1 += log(aphi);
if (dabs(rs1) < *elim) {
goto L100;
}
L95:
if (rs1 > 0.f) {
goto L290;
}
/* ----------------------------------------------------------------------- */
/* FOR X.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW */
/* ----------------------------------------------------------------------- */
if (x < 0.f) {
goto L290;
}
*nz = *n;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
y[i__2].r = czero.r, y[i__2].i = czero.i;
/* L96: */
}
return 0;
L100:
/* ----------------------------------------------------------------------- */
/* RECUR FORWARD FOR REMAINDER OF THE SEQUENCE */
/* ----------------------------------------------------------------------- */
s1.r = cy[0].r, s1.i = cy[0].i;
s2.r = cy[1].r, s2.i = cy[1].i;
i__1 = kflag - 1;
c1.r = csr[i__1].r, c1.i = csr[i__1].i;
ascle = bry[kflag - 1];
i__1 = *n;
for (i__ = ib; i__ <= i__1; ++i__) {
c2.r = s2.r, c2.i = s2.i;
q__2.r = ck.r * s2.r - ck.i * s2.i, q__2.i = ck.r * s2.i + ck.i *
s2.r;
q__1.r = q__2.r + s1.r, q__1.i = q__2.i + s1.i;
s2.r = q__1.r, s2.i = q__1.i;
s1.r = c2.r, s1.i = c2.i;
q__1.r = ck.r + rz.r, q__1.i = ck.i + rz.i;
ck.r = q__1.r, ck.i = q__1.i;
q__1.r = s2.r * c1.r - s2.i * c1.i, q__1.i = s2.r * c1.i + s2.i *
c1.r;
c2.r = q__1.r, c2.i = q__1.i;
i__2 = i__;
y[i__2].r = c2.r, y[i__2].i = c2.i;
if (kflag >= 3) {
goto L120;
}
c2r = c2.r;
c2i = r_imag(&c2);
c2r = dabs(c2r);
c2i = dabs(c2i);
c2m = dmax(c2r,c2i);
if (c2m <= ascle) {
goto L120;
}
++kflag;
ascle = bry[kflag - 1];
q__1.r = s1.r * c1.r - s1.i * c1.i, q__1.i = s1.r * c1.i + s1.i *
c1.r;
s1.r = q__1.r, s1.i = q__1.i;
s2.r = c2.r, s2.i = c2.i;
i__2 = kflag - 1;
q__1.r = s1.r * css[i__2].r - s1.i * css[i__2].i, q__1.i = s1.r * css[
i__2].i + s1.i * css[i__2].r;
s1.r = q__1.r, s1.i = q__1.i;
i__2 = kflag - 1;
q__1.r = s2.r * css[i__2].r - s2.i * css[i__2].i, q__1.i = s2.r * css[
i__2].i + s2.i * css[i__2].r;
s2.r = q__1.r, s2.i = q__1.i;
i__2 = kflag - 1;
c1.r = csr[i__2].r, c1.i = csr[i__2].i;
L120:
;
}
L160:
if (*mr == 0) {
return 0;
}
/* ----------------------------------------------------------------------- */
/* ANALYTIC CONTINUATION FOR RE(Z).LT.0.0E0 */
/* ----------------------------------------------------------------------- */
*nz = 0;
fmr = (real) (*mr);
sgn = -r_sign(&pi, &fmr);
/* ----------------------------------------------------------------------- */
/* CSPN AND CSGN ARE COEFF OF K AND I FUNCTIONS RESP. */
/* ----------------------------------------------------------------------- */
q__1.r = 0.f, q__1.i = sgn;
csgn.r = q__1.r, csgn.i = q__1.i;
inu = *fnu;
fnf = *fnu - inu;
ifn = inu + *n - 1;
ang = fnf * sgn;
cpn = cos(ang);
spn = sin(ang);
q__1.r = cpn, q__1.i = spn;
cspn.r = q__1.r, cspn.i = q__1.i;
if (ifn % 2 == 1) {
q__1.r = -cspn.r, q__1.i = -cspn.i;
cspn.r = q__1.r, cspn.i = q__1.i;
}
asc = bry[0];
kk = *n;
iuf = 0;
kdflg = 1;
--ib;
ic = ib - 1;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
fn = *fnu + (kk - 1);
/* ----------------------------------------------------------------------- */
/* LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K */
/* FUNCTION ABOVE */
/* ----------------------------------------------------------------------- */
m = 3;
if (*n > 2) {
goto L175;
}
L170:
initd = init[j - 1];
i__2 = j - 1;
phid.r = phi[i__2].r, phid.i = phi[i__2].i;
i__2 = j - 1;
zeta1d.r = zeta1[i__2].r, zeta1d.i = zeta1[i__2].i;
i__2 = j - 1;
zeta2d.r = zeta2[i__2].r, zeta2d.i = zeta2[i__2].i;
i__2 = j - 1;
sumd.r = sum[i__2].r, sumd.i = sum[i__2].i;
m = j;
j = 3 - j;
goto L180;
L175:
if (kk == *n && ib < *n) {
goto L180;
}
if (kk == ib || kk == ic) {
goto L170;
}
initd = 0;
L180:
cunik_(&zr, &fn, &c__1, &c__0, tol, &initd, &phid, &zeta1d, &zeta2d, &
sumd, &cwrk[(m << 4) - 16]);
if (*kode == 1) {
goto L190;
}
q__1.r = fn, q__1.i = 0.f;
cfn.r = q__1.r, cfn.i = q__1.i;
q__2.r = -zeta1d.r, q__2.i = -zeta1d.i;
q__5.r = zr.r + zeta2d.r, q__5.i = zr.i + zeta2d.i;
c_div(&q__4, &cfn, &q__5);
q__3.r = cfn.r * q__4.r - cfn.i * q__4.i, q__3.i = cfn.r * q__4.i +
cfn.i * q__4.r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
s1.r = q__1.r, s1.i = q__1.i;
goto L200;
L190:
q__2.r = -zeta1d.r, q__2.i = -zeta1d.i;
q__1.r = q__2.r + zeta2d.r, q__1.i = q__2.i + zeta2d.i;
s1.r = q__1.r, s1.i = q__1.i;
L200:
/* ----------------------------------------------------------------------- */
/* TEST FOR UNDERFLOW AND OVERFLOW */
/* ----------------------------------------------------------------------- */
rs1 = s1.r;
if (dabs(rs1) > *elim) {
goto L250;
}
if (kdflg == 1) {
iflag = 2;
}
if (dabs(rs1) < *alim) {
goto L210;
}
/* ----------------------------------------------------------------------- */
/* REFINE TEST AND SCALE */
/* ----------------------------------------------------------------------- */
aphi = c_abs(&phid);
rs1 += log(aphi);
if (dabs(rs1) > *elim) {
goto L250;
}
if (kdflg == 1) {
iflag = 1;
}
if (rs1 < 0.f) {
goto L210;
}
if (kdflg == 1) {
iflag = 3;
}
L210:
q__2.r = csgn.r * phid.r - csgn.i * phid.i, q__2.i = csgn.r * phid.i
+ csgn.i * phid.r;
q__1.r = q__2.r * sumd.r - q__2.i * sumd.i, q__1.i = q__2.r * sumd.i
+ q__2.i * sumd.r;
s2.r = q__1.r, s2.i = q__1.i;
c2r = s1.r;
c2i = r_imag(&s1);
i__2 = iflag - 1;
c2m = exp(c2r) * css[i__2].r;
q__2.r = c2m, q__2.i = 0.f;
r__1 = cos(c2i);
r__2 = sin(c2i);
q__3.r = r__1, q__3.i = r__2;
q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = q__2.r * q__3.i
+ q__2.i * q__3.r;
s1.r = q__1.r, s1.i = q__1.i;
q__1.r = s2.r * s1.r - s2.i * s1.i, q__1.i = s2.r * s1.i + s2.i *
s1.r;
s2.r = q__1.r, s2.i = q__1.i;
if (iflag != 1) {
goto L220;
}
cuchk_(&s2, &nw, bry, tol);
if (nw != 0) {
s2.r = 0.f, s2.i = 0.f;
}
L220:
i__2 = kdflg - 1;
cy[i__2].r = s2.r, cy[i__2].i = s2.i;
c2.r = s2.r, c2.i = s2.i;
i__2 = iflag - 1;
q__1.r = s2.r * csr[i__2].r - s2.i * csr[i__2].i, q__1.i = s2.r * csr[
i__2].i + s2.i * csr[i__2].r;
s2.r = q__1.r, s2.i = q__1.i;
/* ----------------------------------------------------------------------- */
/* ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N */
/* ----------------------------------------------------------------------- */
i__2 = kk;
s1.r = y[i__2].r, s1.i = y[i__2].i;
if (*kode == 1) {
goto L240;
}
cs1s2_(&zr, &s1, &s2, &nw, &asc, alim, &iuf);
*nz += nw;
L240:
i__2 = kk;
q__2.r = s1.r * cspn.r - s1.i * cspn.i, q__2.i = s1.r * cspn.i + s1.i
* cspn.r;
q__1.r = q__2.r + s2.r, q__1.i = q__2.i + s2.i;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
--kk;
q__1.r = -cspn.r, q__1.i = -cspn.i;
cspn.r = q__1.r, cspn.i = q__1.i;
if (c2.r != czero.r || c2.i != czero.i) {
goto L245;
}
kdflg = 1;
goto L260;
L245:
if (kdflg == 2) {
goto L265;
}
kdflg = 2;
goto L260;
L250:
if (rs1 > 0.f) {
goto L290;
}
s2.r = czero.r, s2.i = czero.i;
goto L220;
L260:
;
}
k = *n;
L265:
il = *n - k;
if (il == 0) {
return 0;
}
/* ----------------------------------------------------------------------- */
/* RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE */
/* K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP */
/* INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES. */
/* ----------------------------------------------------------------------- */
s1.r = cy[0].r, s1.i = cy[0].i;
s2.r = cy[1].r, s2.i = cy[1].i;
i__1 = iflag - 1;
cs.r = csr[i__1].r, cs.i = csr[i__1].i;
ascle = bry[iflag - 1];
fn = (real) (inu + il);
i__1 = il;
for (i__ = 1; i__ <= i__1; ++i__) {
c2.r = s2.r, c2.i = s2.i;
r__1 = fn + fnf;
q__4.r = r__1, q__4.i = 0.f;
q__3.r = q__4.r * rz.r - q__4.i * rz.i, q__3.i = q__4.r * rz.i +
q__4.i * rz.r;
q__2.r = q__3.r * s2.r - q__3.i * s2.i, q__2.i = q__3.r * s2.i +
q__3.i * s2.r;
q__1.r = s1.r + q__2.r, q__1.i = s1.i + q__2.i;
s2.r = q__1.r, s2.i = q__1.i;
s1.r = c2.r, s1.i = c2.i;
fn += -1.f;
q__1.r = s2.r * cs.r - s2.i * cs.i, q__1.i = s2.r * cs.i + s2.i *
cs.r;
c2.r = q__1.r, c2.i = q__1.i;
ck.r = c2.r, ck.i = c2.i;
i__2 = kk;
c1.r = y[i__2].r, c1.i = y[i__2].i;
if (*kode == 1) {
goto L270;
}
cs1s2_(&zr, &c1, &c2, &nw, &asc, alim, &iuf);
*nz += nw;
L270:
i__2 = kk;
q__2.r = c1.r * cspn.r - c1.i * cspn.i, q__2.i = c1.r * cspn.i + c1.i
* cspn.r;
q__1.r = q__2.r + c2.r, q__1.i = q__2.i + c2.i;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
--kk;
q__1.r = -cspn.r, q__1.i = -cspn.i;
cspn.r = q__1.r, cspn.i = q__1.i;
if (iflag >= 3) {
goto L280;
}
c2r = ck.r;
c2i = r_imag(&ck);
c2r = dabs(c2r);
c2i = dabs(c2i);
c2m = dmax(c2r,c2i);
if (c2m <= ascle) {
goto L280;
}
++iflag;
ascle = bry[iflag - 1];
q__1.r = s1.r * cs.r - s1.i * cs.i, q__1.i = s1.r * cs.i + s1.i *
cs.r;
s1.r = q__1.r, s1.i = q__1.i;
s2.r = ck.r, s2.i = ck.i;
i__2 = iflag - 1;
q__1.r = s1.r * css[i__2].r - s1.i * css[i__2].i, q__1.i = s1.r * css[
i__2].i + s1.i * css[i__2].r;
s1.r = q__1.r, s1.i = q__1.i;
i__2 = iflag - 1;
q__1.r = s2.r * css[i__2].r - s2.i * css[i__2].i, q__1.i = s2.r * css[
i__2].i + s2.i * css[i__2].r;
s2.r = q__1.r, s2.i = q__1.i;
i__2 = iflag - 1;
cs.r = csr[i__2].r, cs.i = csr[i__2].i;
L280:
;
}
return 0;
L290:
*nz = -1;
return 0;
} /* cunk1_ */
