doublereal qwgts_(real *x, real *a, real *b, real *alfa, real *beta, integer *
integr)
{
/* System generated locals */
real ret_val;
doublereal d__1, d__2, d__3, d__4;
/* Builtin functions */
double pow_dd(doublereal *, doublereal *), log(doublereal);
/* Local variables */
real xma, bmx;
/* ***begin prologue qwgts */
/* ***refer to qk15w */
/* ***routines called (none) */
/* ***revision date 810101 (yymmdd) */
/* ***keywords weight function, algebraico-logarithmic */
/* end-point singularities */
/* ***author piessens,robert,appl. math. & progr. div. - k.u.leuven */
/* de doncker,elise,appl. math. & progr. div. - k.u.leuven */
/* ***purpose this function subprogram is used together with the */
/* routine qaws and defines the weight function. */
/* ***end prologue qwgts */
/* ***first executable statement */
xma = *x - *a;
bmx = *b - *x;
d__1 = (doublereal) xma;
d__2 = (doublereal) (*alfa);
d__3 = (doublereal) bmx;
d__4 = (doublereal) (*beta);
ret_val = pow_dd(&d__1, &d__2) * pow_dd(&d__3, &d__4);
switch (*integr) {
case 1: goto L40;
case 2: goto L10;
case 3: goto L20;
case 4: goto L30;
}
L10:
ret_val *= log(xma);
goto L40;
L20:
ret_val *= log(bmx);
goto L40;
L30:
ret_val = ret_val * log(xma) * log(bmx);
L40:
return ret_val;
} /* qwgts_ */
int CPrecipPSD::CalcAgglomCoeff(double *x, double *akf, long *npts, double *aggl_coeff__)
{
long i__1;
double d__1;
// Builtin functions
double exp(double), pow_dd(double , double );
double xend;
long i;
double d1, d2;
// ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
//
// i counter in do loop
// akf agglomeration parameter
// d1 agglomeration parameter
// d2 agglomeration parameter
// xend agglomeration parameter
// ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
//
// Parameter adjustments
--aggl_coeff__;
--akf;
--x;
// Function Body
d1 = akf[1];
d2 = akf[2];
xend = akf[3]*1e6;
i__1 = *npts;
for(i = 1; i <= i__1; ++i)
{
if(x[i] <= xend)
{
aggl_coeff__[i] = 1.;
}
else
{
aggl_coeff__[i] = 0.;
}
if(d1 != 0.)
{
aggl_coeff__[i] *= Exps(-x[i] / d1);
}
if(d2 != 0.)
{
d__1 = x[i] / d2;
aggl_coeff__[i] *= Exps(-pow_dd(d__1, c_b4));
}
}
return 0;
} // CalcAgglomCoeff
int CPrecipPSD::MassToNumber(double *dist, long *npts, double *x)
{
long i__1;
double d__1;
double pow_dd(double , double );
long ii;
double sum;
double scl;
// ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
//
// npts number of points in discretization of psd
// x midpoints of discretization
// const normalizing factor
// dist particle size distribution
// ii counter in do loop
// ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
//
// Functions Used
// Moment Calculates moments from psd
// ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
//
// Parameter adjustments
--x;
--dist;
sum=0;
i__1 = *npts;
for(ii = 1; ii <= i__1; ++ii)
{
// Computing 3rd power
d__1 = x[ii];
dist[ii] = dist[ii]/pow_dd(d__1, 3.0);
if (dist[ii]<0)
{
int xxx=0;
}
sum+=dist[ii];
}
if (sum >= 1e-20)
scl= 1/sum;
else
scl=0.0;
for(ii = 1; ii <= i__1; ++ii)
dist[ii] *= scl;
return 0;
} // NumberToMass
int CPrecipPSD::SetGrid(double *xmin, long *q, long *npts, double *x)
{
long i__1;
double d__1;
// Builtin functions
double pow_dd(double , double );
long i;
double ratio;
// ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
//
// x midpoints of discretization
// xmin minimum particle size midpoint
// npts number of points in discretization of psd
// ratio ratio of successive gridpoints
// i counter in do loop
// ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
//
// Parameter adjustments
--x;
// Function Body
d__1 = 1. / ((double) (*q) * 3.);
ratio = pow_dd(c_b4, d__1);
// grid space ratio
x[1] = *xmin;
i__1 = *npts - 1;
for(i = 1; i <= i__1; ++i)
{
x[i + 1] = ratio * x[i]; // calc midpoints in geom grid
}
return 0;
} // SetGrid
/* Subroutine */
int fcon_eqdf(integer ntst, integer ndim,
integer ncol, double *dtm, double *ups,
double *eqf, integer iper)
{
/* System generated locals */
double d2;
/* Local variables */
double dtav, e;
integer i, j, k;
logical small;
integer k1;
double sc;
double *wh = MALLOC(sizeof(double) * (ncol + 1));
double *hd = MALLOC(sizeof(double) * (ntst + 1) * ncol * ndim);
integer jp1;
double pwr;
/* Function Body */
fcon_cntdif(ncol, wh);
small = TRUE_;
for (j = 0; j < ntst; ++j) {
jp1 = j + 1;
sc = 1. / pow_di(&dtm[j], &ncol);
for (i = 0; i < ndim; ++i) {
hd[j + i * (ntst + 1)] = wh[ncol] * ups[jp1 + i * (ntst + 1)];
for (k = 0; k < ncol; ++k) {
k1 = i + k * ndim;
hd[j + i * (ntst + 1)] += wh[k] * ups[j + k1 * (ntst + 1)];
}
hd[j + i * (ntst + 1)] = sc * hd[j + i * (ntst + 1)];
if (fabs(hd[j + i * (ntst + 1)]) > HMACH) {
small = FALSE_;
}
}
}
/* Take care of "small derivative" case. */
if (small) {
for (i = 0; i < ntst + 1; ++i) {
eqf[i] = (double) i;
}
return 0;
}
if (iper != 1) {
/* Extend by extrapolation : */
for (i = 0; i < ndim; ++i) {
hd[ntst + i * (ntst + 1)] = hd[(ntst - 1) + i * (ntst + 1)] * 2 - hd[ntst - 2 + i * (ntst + 1)];
}
dtm[ntst] = dtm[-1 + ntst];
} else {
/* Extend by periodicity : */
for (i = 0; i < ndim; ++i) {
hd[ntst + i * (ntst + 1)] = hd[i * (ntst + 1)];
}
dtm[ntst] = dtm[0];
}
/* Compute approximation to (NCOL+1)-st derivative : */
for (j = 0; j < ntst; ++j) {
jp1 = j + 1;
dtav = (dtm[j] + dtm[j + 1]) * .5;
sc = 1. / dtav;
for (i = 0; i < ndim; ++i) {
hd[j + i * (ntst + 1)] = sc * (hd[jp1 + i * (ntst + 1)] - hd[j + i * (ntst + 1)]);
}
}
/* Define the equidistribution function : */
pwr = 1. / (ncol + 1.);
eqf[0] = 0.;
for (j = 0; j < ntst; ++j) {
e = 0.;
for (i = 0; i < ndim; ++i) {
d2 = fabs(hd[j + i * (ntst + 1)]);
e += pow_dd(&d2, &pwr);
}
eqf[j + 1] = eqf[j] + dtm[j] * e;
}
FREE(wh);
FREE(hd);
return 0;
} /* fcon_eqdf_ */
/* Subroutine */ int zlatm4_(integer *itype, integer *n, integer *nz1,
integer *nz2, logical *rsign, doublereal *amagn, doublereal *rcond,
doublereal *triang, integer *idist, integer *iseed, doublecomplex *a,
integer *lda)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
doublecomplex z__1, z__2;
/* Local variables */
integer i__, k, jc, jd, jr, kbeg, isdb, kend, isde, klen;
doublereal alpha;
doublecomplex ctemp;
extern doublereal dlaran_(integer *);
extern /* Double Complex */ void zlarnd_(doublecomplex *, integer *,
integer *);
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
/* -- LAPACK auxiliary test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLATM4 generates basic square matrices, which may later be */
/* multiplied by others in order to produce test matrices. It is */
/* intended mainly to be used to test the generalized eigenvalue */
/* routines. */
/* It first generates the diagonal and (possibly) subdiagonal, */
/* according to the value of ITYPE, NZ1, NZ2, RSIGN, AMAGN, and RCOND. */
/* It then fills in the upper triangle with random numbers, if TRIANG is */
/* non-zero. */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* The "type" of matrix on the diagonal and sub-diagonal. */
/* If ITYPE < 0, then type abs(ITYPE) is generated and then */
/* swapped end for end (A(I,J) := A'(N-J,N-I).) See also */
/* the description of AMAGN and RSIGN. */
/* Special types: */
/* = 0: the zero matrix. */
/* = 1: the identity. */
/* = 2: a transposed Jordan block. */
/* = 3: If N is odd, then a k+1 x k+1 transposed Jordan block */
/* followed by a k x k identity block, where k=(N-1)/2. */
/* If N is even, then k=(N-2)/2, and a zero diagonal entry */
/* is tacked onto the end. */
/* Diagonal types. The diagonal consists of NZ1 zeros, then */
/* k=N-NZ1-NZ2 nonzeros. The subdiagonal is zero. ITYPE */
/* specifies the nonzero diagonal entries as follows: */
/* = 4: 1, ..., k */
/* = 5: 1, RCOND, ..., RCOND */
/* = 6: 1, ..., 1, RCOND */
/* = 7: 1, a, a^2, ..., a^(k-1)=RCOND */
/* = 8: 1, 1-d, 1-2*d, ..., 1-(k-1)*d=RCOND */
/* = 9: random numbers chosen from (RCOND,1) */
/* = 10: random numbers with distribution IDIST (see ZLARND.) */
/* N (input) INTEGER */
/* The order of the matrix. */
/* NZ1 (input) INTEGER */
/* If abs(ITYPE) > 3, then the first NZ1 diagonal entries will */
/* be zero. */
/* NZ2 (input) INTEGER */
/* If abs(ITYPE) > 3, then the last NZ2 diagonal entries will */
/* be zero. */
/* RSIGN (input) LOGICAL */
/* = .TRUE.: The diagonal and subdiagonal entries will be */
/* multiplied by random numbers of magnitude 1. */
/* = .FALSE.: The diagonal and subdiagonal entries will be */
/* left as they are (usually non-negative real.) */
/* AMAGN (input) DOUBLE PRECISION */
/* The diagonal and subdiagonal entries will be multiplied by */
/* AMAGN. */
/* RCOND (input) DOUBLE PRECISION */
/* If abs(ITYPE) > 4, then the smallest diagonal entry will be */
/* RCOND. RCOND must be between 0 and 1. */
/* TRIANG (input) DOUBLE PRECISION */
/* The entries above the diagonal will be random numbers with */
/* magnitude bounded by TRIANG (i.e., random numbers multiplied */
/* by TRIANG.) */
/* IDIST (input) INTEGER */
/* On entry, DIST 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 ) */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The values of ISEED are changed on exit, and can */
/* be used in the next call to ZLATM4 to continue the same */
/* random number sequence. */
/* Note: ISEED(4) should be odd, for the random number generator */
/* used at present. */
/* A (output) COMPLEX*16 array, dimension (LDA, N) */
/* Array to be computed. */
/* LDA (input) INTEGER */
/* Leading dimension of A. Must be at least 1 and at least N. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--iseed;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
if (*n <= 0) {
return 0;
}
zlaset_("Full", n, n, &c_b1, &c_b1, &a[a_offset], lda);
/* Insure a correct ISEED */
if (iseed[4] % 2 != 1) {
++iseed[4];
}
/* Compute diagonal and subdiagonal according to ITYPE, NZ1, NZ2, */
/* and RCOND */
if (*itype != 0) {
if (abs(*itype) >= 4) {
/* Computing MAX */
/* Computing MIN */
i__3 = *n, i__4 = *nz1 + 1;
i__1 = 1, i__2 = min(i__3,i__4);
kbeg = max(i__1,i__2);
/* Computing MAX */
/* Computing MIN */
i__3 = *n, i__4 = *n - *nz2;
i__1 = kbeg, i__2 = min(i__3,i__4);
kend = max(i__1,i__2);
klen = kend + 1 - kbeg;
} else {
kbeg = 1;
kend = *n;
klen = *n;
}
isdb = 1;
isde = 0;
switch (abs(*itype)) {
case 1: goto L10;
case 2: goto L30;
case 3: goto L50;
case 4: goto L80;
case 5: goto L100;
case 6: goto L120;
case 7: goto L140;
case 8: goto L160;
case 9: goto L180;
case 10: goto L200;
}
/* abs(ITYPE) = 1: Identity */
L10:
i__1 = *n;
for (jd = 1; jd <= i__1; ++jd) {
i__2 = jd + jd * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* L20: */
}
goto L220;
/* abs(ITYPE) = 2: Transposed Jordan block */
L30:
i__1 = *n - 1;
for (jd = 1; jd <= i__1; ++jd) {
i__2 = jd + 1 + jd * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* L40: */
}
isdb = 1;
isde = *n - 1;
goto L220;
/* abs(ITYPE) = 3: Transposed Jordan block, followed by the */
/* identity. */
L50:
k = (*n - 1) / 2;
i__1 = k;
for (jd = 1; jd <= i__1; ++jd) {
i__2 = jd + 1 + jd * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* L60: */
}
isdb = 1;
isde = k;
i__1 = (k << 1) + 1;
for (jd = k + 2; jd <= i__1; ++jd) {
i__2 = jd + jd * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* L70: */
}
goto L220;
/* abs(ITYPE) = 4: 1,...,k */
L80:
i__1 = kend;
for (jd = kbeg; jd <= i__1; ++jd) {
i__2 = jd + jd * a_dim1;
i__3 = jd - *nz1;
z__1.r = (doublereal) i__3, z__1.i = 0.;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L90: */
}
goto L220;
/* abs(ITYPE) = 5: One large D value: */
L100:
i__1 = kend;
for (jd = kbeg + 1; jd <= i__1; ++jd) {
i__2 = jd + jd * a_dim1;
z__1.r = *rcond, z__1.i = 0.;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L110: */
}
i__1 = kbeg + kbeg * a_dim1;
a[i__1].r = 1., a[i__1].i = 0.;
goto L220;
/* abs(ITYPE) = 6: One small D value: */
L120:
i__1 = kend - 1;
for (jd = kbeg; jd <= i__1; ++jd) {
i__2 = jd + jd * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* L130: */
}
i__1 = kend + kend * a_dim1;
z__1.r = *rcond, z__1.i = 0.;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
goto L220;
/* abs(ITYPE) = 7: Exponentially distributed D values: */
L140:
i__1 = kbeg + kbeg * a_dim1;
a[i__1].r = 1., a[i__1].i = 0.;
if (klen > 1) {
d__1 = 1. / (doublereal) (klen - 1);
alpha = pow_dd(rcond, &d__1);
i__1 = klen;
for (i__ = 2; i__ <= i__1; ++i__) {
i__2 = *nz1 + i__ + (*nz1 + i__) * a_dim1;
d__2 = (doublereal) (i__ - 1);
d__1 = pow_dd(&alpha, &d__2);
z__1.r = d__1, z__1.i = 0.;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L150: */
}
}
goto L220;
/* abs(ITYPE) = 8: Arithmetically distributed D values: */
L160:
i__1 = kbeg + kbeg * a_dim1;
a[i__1].r = 1., a[i__1].i = 0.;
if (klen > 1) {
alpha = (1. - *rcond) / (doublereal) (klen - 1);
i__1 = klen;
for (i__ = 2; i__ <= i__1; ++i__) {
i__2 = *nz1 + i__ + (*nz1 + i__) * a_dim1;
d__1 = (doublereal) (klen - i__) * alpha + *rcond;
z__1.r = d__1, z__1.i = 0.;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L170: */
}
}
goto L220;
/* abs(ITYPE) = 9: Randomly distributed D values on ( RCOND, 1): */
L180:
alpha = log(*rcond);
i__1 = kend;
for (jd = kbeg; jd <= i__1; ++jd) {
i__2 = jd + jd * a_dim1;
d__1 = exp(alpha * dlaran_(&iseed[1]));
a[i__2].r = d__1, a[i__2].i = 0.;
/* L190: */
}
goto L220;
/* abs(ITYPE) = 10: Randomly distributed D values from DIST */
L200:
i__1 = kend;
for (jd = kbeg; jd <= i__1; ++jd) {
i__2 = jd + jd * a_dim1;
zlarnd_(&z__1, idist, &iseed[1]);
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L210: */
}
L220:
/* Scale by AMAGN */
i__1 = kend;
for (jd = kbeg; jd <= i__1; ++jd) {
i__2 = jd + jd * a_dim1;
i__3 = jd + jd * a_dim1;
d__1 = *amagn * a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
/* L230: */
}
i__1 = isde;
for (jd = isdb; jd <= i__1; ++jd) {
i__2 = jd + 1 + jd * a_dim1;
i__3 = jd + 1 + jd * a_dim1;
d__1 = *amagn * a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
/* L240: */
}
/* If RSIGN = .TRUE., assign random signs to diagonal and */
/* subdiagonal */
if (*rsign) {
i__1 = kend;
for (jd = kbeg; jd <= i__1; ++jd) {
i__2 = jd + jd * a_dim1;
if (a[i__2].r != 0.) {
zlarnd_(&z__1, &c__3, &iseed[1]);
ctemp.r = z__1.r, ctemp.i = z__1.i;
d__1 = z_abs(&ctemp);
z__1.r = ctemp.r / d__1, z__1.i = ctemp.i / d__1;
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__2 = jd + jd * a_dim1;
i__3 = jd + jd * a_dim1;
d__1 = a[i__3].r;
z__1.r = d__1 * ctemp.r, z__1.i = d__1 * ctemp.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
/* L250: */
}
i__1 = isde;
for (jd = isdb; jd <= i__1; ++jd) {
i__2 = jd + 1 + jd * a_dim1;
if (a[i__2].r != 0.) {
zlarnd_(&z__1, &c__3, &iseed[1]);
ctemp.r = z__1.r, ctemp.i = z__1.i;
d__1 = z_abs(&ctemp);
z__1.r = ctemp.r / d__1, z__1.i = ctemp.i / d__1;
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__2 = jd + 1 + jd * a_dim1;
i__3 = jd + 1 + jd * a_dim1;
d__1 = a[i__3].r;
z__1.r = d__1 * ctemp.r, z__1.i = d__1 * ctemp.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
/* L260: */
}
}
/* Reverse if ITYPE < 0 */
if (*itype < 0) {
i__1 = (kbeg + kend - 1) / 2;
for (jd = kbeg; jd <= i__1; ++jd) {
i__2 = jd + jd * a_dim1;
ctemp.r = a[i__2].r, ctemp.i = a[i__2].i;
i__2 = jd + jd * a_dim1;
i__3 = kbeg + kend - jd + (kbeg + kend - jd) * a_dim1;
a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
i__2 = kbeg + kend - jd + (kbeg + kend - jd) * a_dim1;
a[i__2].r = ctemp.r, a[i__2].i = ctemp.i;
/* L270: */
}
i__1 = (*n - 1) / 2;
for (jd = 1; jd <= i__1; ++jd) {
i__2 = jd + 1 + jd * a_dim1;
ctemp.r = a[i__2].r, ctemp.i = a[i__2].i;
i__2 = jd + 1 + jd * a_dim1;
i__3 = *n + 1 - jd + (*n - jd) * a_dim1;
a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
i__2 = *n + 1 - jd + (*n - jd) * a_dim1;
a[i__2].r = ctemp.r, a[i__2].i = ctemp.i;
/* L280: */
}
}
}
/* Fill in upper triangle */
if (*triang != 0.) {
i__1 = *n;
for (jc = 2; jc <= i__1; ++jc) {
i__2 = jc - 1;
for (jr = 1; jr <= i__2; ++jr) {
i__3 = jr + jc * a_dim1;
zlarnd_(&z__2, idist, &iseed[1]);
z__1.r = *triang * z__2.r, z__1.i = *triang * z__2.i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L290: */
}
/* L300: */
}
}
return 0;
/* End of ZLATM4 */
} /* zlatm4_ */
/* Subroutine */ int slatm4_(integer *itype, integer *n, integer *nz1,
integer *nz2, integer *isign, real *amagn, real *rcond, real *triang,
integer *idist, integer *iseed, real *a, integer *lda)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
real r__1, r__2, r__3, r__4;
doublereal d__1, d__2;
/* Builtin functions */
double pow_dd(doublereal *, doublereal *), pow_ri(real *, integer *), log(
doublereal), exp(doublereal), sqrt(doublereal);
/* Local variables */
static integer kbeg, isdb, kend, ioff, isde, klen;
static real temp;
static integer i__, k;
static real alpha;
static integer jc, jd;
static real cl, cr;
static integer jr;
static real sl, sr;
extern doublereal slamch_(char *);
static real safmin;
extern doublereal slaran_(integer *), slarnd_(integer *, integer *);
extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
real *, real *, integer *);
static real sv1, sv2;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
/* -- 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
=======
SLATM4 generates basic square matrices, which may later be
multiplied by others in order to produce test matrices. It is
intended mainly to be used to test the generalized eigenvalue
routines.
It first generates the diagonal and (possibly) subdiagonal,
according to the value of ITYPE, NZ1, NZ2, ISIGN, AMAGN, and RCOND.
It then fills in the upper triangle with random numbers, if TRIANG is
non-zero.
Arguments
=========
ITYPE (input) INTEGER
The "type" of matrix on the diagonal and sub-diagonal.
If ITYPE < 0, then type abs(ITYPE) is generated and then
swapped end for end (A(I,J) := A'(N-J,N-I).) See also
the description of AMAGN and ISIGN.
Special types:
= 0: the zero matrix.
= 1: the identity.
= 2: a transposed Jordan block.
= 3: If N is odd, then a k+1 x k+1 transposed Jordan block
followed by a k x k identity block, where k=(N-1)/2.
If N is even, then k=(N-2)/2, and a zero diagonal entry
is tacked onto the end.
Diagonal types. The diagonal consists of NZ1 zeros, then
k=N-NZ1-NZ2 nonzeros. The subdiagonal is zero. ITYPE
specifies the nonzero diagonal entries as follows:
= 4: 1, ..., k
= 5: 1, RCOND, ..., RCOND
= 6: 1, ..., 1, RCOND
= 7: 1, a, a^2, ..., a^(k-1)=RCOND
= 8: 1, 1-d, 1-2*d, ..., 1-(k-1)*d=RCOND
= 9: random numbers chosen from (RCOND,1)
= 10: random numbers with distribution IDIST (see SLARND.)
N (input) INTEGER
The order of the matrix.
NZ1 (input) INTEGER
If abs(ITYPE) > 3, then the first NZ1 diagonal entries will
be zero.
NZ2 (input) INTEGER
If abs(ITYPE) > 3, then the last NZ2 diagonal entries will
be zero.
ISIGN (input) INTEGER
= 0: The sign of the diagonal and subdiagonal entries will
be left unchanged.
= 1: The diagonal and subdiagonal entries will have their
sign changed at random.
= 2: If ITYPE is 2 or 3, then the same as ISIGN=1.
Otherwise, with probability 0.5, odd-even pairs of
diagonal entries A(2*j-1,2*j-1), A(2*j,2*j) will be
converted to a 2x2 block by pre- and post-multiplying
by distinct random orthogonal rotations. The remaining
diagonal entries will have their sign changed at random.
AMAGN (input) REAL
The diagonal and subdiagonal entries will be multiplied by
AMAGN.
RCOND (input) REAL
If abs(ITYPE) > 4, then the smallest diagonal entry will be
entry will be RCOND. RCOND must be between 0 and 1.
TRIANG (input) REAL
The entries above the diagonal will be random numbers with
magnitude bounded by TRIANG (i.e., random numbers multiplied
by TRIANG.)
IDIST (input) INTEGER
Specifies the type of distribution to be used to generate a
random matrix.
= 1: UNIFORM( 0, 1 )
= 2: UNIFORM( -1, 1 )
= 3: NORMAL ( 0, 1 )
ISEED (input/output) INTEGER array, dimension (4)
On entry ISEED specifies the seed of the random number
generator. The values of ISEED are changed on exit, and can
be used in the next call to SLATM4 to continue the same
random number sequence.
Note: ISEED(4) should be odd, for the random number generator
used at present.
A (output) REAL array, dimension (LDA, N)
Array to be computed.
LDA (input) INTEGER
Leading dimension of A. Must be at least 1 and at least N.
=====================================================================
Parameter adjustments */
--iseed;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
/* Function Body */
if (*n <= 0) {
return 0;
}
slaset_("Full", n, n, &c_b3, &c_b3, &a[a_offset], lda);
/* Insure a correct ISEED */
if (iseed[4] % 2 != 1) {
++iseed[4];
}
/* Compute diagonal and subdiagonal according to ITYPE, NZ1, NZ2,
and RCOND */
if (*itype != 0) {
if (abs(*itype) >= 4) {
/* Computing MAX
Computing MIN */
i__3 = *n, i__4 = *nz1 + 1;
i__1 = 1, i__2 = min(i__3,i__4);
kbeg = max(i__1,i__2);
/* Computing MAX
Computing MIN */
i__3 = *n, i__4 = *n - *nz2;
i__1 = kbeg, i__2 = min(i__3,i__4);
kend = max(i__1,i__2);
klen = kend + 1 - kbeg;
} else {
kbeg = 1;
kend = *n;
klen = *n;
}
isdb = 1;
isde = 0;
switch (abs(*itype)) {
case 1: goto L10;
case 2: goto L30;
case 3: goto L50;
case 4: goto L80;
case 5: goto L100;
case 6: goto L120;
case 7: goto L140;
case 8: goto L160;
case 9: goto L180;
case 10: goto L200;
}
/* |ITYPE| = 1: Identity */
L10:
i__1 = *n;
for (jd = 1; jd <= i__1; ++jd) {
a_ref(jd, jd) = 1.f;
/* L20: */
}
goto L220;
/* |ITYPE| = 2: Transposed Jordan block */
L30:
i__1 = *n - 1;
for (jd = 1; jd <= i__1; ++jd) {
a_ref(jd + 1, jd) = 1.f;
/* L40: */
}
isdb = 1;
isde = *n - 1;
goto L220;
/* |ITYPE| = 3: Transposed Jordan block, followed by the identity. */
L50:
k = (*n - 1) / 2;
i__1 = k;
for (jd = 1; jd <= i__1; ++jd) {
a_ref(jd + 1, jd) = 1.f;
/* L60: */
}
isdb = 1;
isde = k;
i__1 = (k << 1) + 1;
for (jd = k + 2; jd <= i__1; ++jd) {
a_ref(jd, jd) = 1.f;
/* L70: */
}
goto L220;
/* |ITYPE| = 4: 1,...,k */
L80:
i__1 = kend;
for (jd = kbeg; jd <= i__1; ++jd) {
a_ref(jd, jd) = (real) (jd - *nz1);
/* L90: */
}
goto L220;
/* |ITYPE| = 5: One large D value: */
L100:
i__1 = kend;
for (jd = kbeg + 1; jd <= i__1; ++jd) {
a_ref(jd, jd) = *rcond;
/* L110: */
}
a_ref(kbeg, kbeg) = 1.f;
goto L220;
/* |ITYPE| = 6: One small D value: */
L120:
i__1 = kend - 1;
for (jd = kbeg; jd <= i__1; ++jd) {
a_ref(jd, jd) = 1.f;
/* L130: */
}
a_ref(kend, kend) = *rcond;
goto L220;
/* |ITYPE| = 7: Exponentially distributed D values: */
L140:
a_ref(kbeg, kbeg) = 1.f;
if (klen > 1) {
d__1 = (doublereal) (*rcond);
d__2 = (doublereal) (1.f / (real) (klen - 1));
alpha = pow_dd(&d__1, &d__2);
i__1 = klen;
for (i__ = 2; i__ <= i__1; ++i__) {
i__2 = i__ - 1;
a_ref(*nz1 + i__, *nz1 + i__) = pow_ri(&alpha, &i__2);
/* L150: */
}
}
goto L220;
/* |ITYPE| = 8: Arithmetically distributed D values: */
L160:
a_ref(kbeg, kbeg) = 1.f;
if (klen > 1) {
alpha = (1.f - *rcond) / (real) (klen - 1);
i__1 = klen;
for (i__ = 2; i__ <= i__1; ++i__) {
a_ref(*nz1 + i__, *nz1 + i__) = (real) (klen - i__) * alpha +
*rcond;
/* L170: */
}
}
goto L220;
/* |ITYPE| = 9: Randomly distributed D values on ( RCOND, 1): */
L180:
alpha = log(*rcond);
i__1 = kend;
for (jd = kbeg; jd <= i__1; ++jd) {
a_ref(jd, jd) = exp(alpha * slaran_(&iseed[1]));
/* L190: */
}
goto L220;
/* |ITYPE| = 10: Randomly distributed D values from DIST */
L200:
i__1 = kend;
for (jd = kbeg; jd <= i__1; ++jd) {
a_ref(jd, jd) = slarnd_(idist, &iseed[1]);
/* L210: */
}
L220:
/* Scale by AMAGN */
i__1 = kend;
for (jd = kbeg; jd <= i__1; ++jd) {
a_ref(jd, jd) = *amagn * a_ref(jd, jd);
/* L230: */
}
i__1 = isde;
for (jd = isdb; jd <= i__1; ++jd) {
a_ref(jd + 1, jd) = *amagn * a_ref(jd + 1, jd);
/* L240: */
}
/* If ISIGN = 1 or 2, assign random signs to diagonal and
subdiagonal */
if (*isign > 0) {
i__1 = kend;
for (jd = kbeg; jd <= i__1; ++jd) {
if (a_ref(jd, jd) != 0.f) {
if (slaran_(&iseed[1]) > .5f) {
a_ref(jd, jd) = -a_ref(jd, jd);
}
}
/* L250: */
}
i__1 = isde;
for (jd = isdb; jd <= i__1; ++jd) {
if (a_ref(jd + 1, jd) != 0.f) {
if (slaran_(&iseed[1]) > .5f) {
a_ref(jd + 1, jd) = -a_ref(jd + 1, jd);
}
}
/* L260: */
}
}
/* Reverse if ITYPE < 0 */
if (*itype < 0) {
i__1 = (kbeg + kend - 1) / 2;
for (jd = kbeg; jd <= i__1; ++jd) {
temp = a_ref(jd, jd);
a_ref(jd, jd) = a_ref(kbeg + kend - jd, kbeg + kend - jd);
a_ref(kbeg + kend - jd, kbeg + kend - jd) = temp;
/* L270: */
}
i__1 = (*n - 1) / 2;
for (jd = 1; jd <= i__1; ++jd) {
temp = a_ref(jd + 1, jd);
a_ref(jd + 1, jd) = a_ref(*n + 1 - jd, *n - jd);
a_ref(*n + 1 - jd, *n - jd) = temp;
/* L280: */
}
}
/* If ISIGN = 2, and no subdiagonals already, then apply
random rotations to make 2x2 blocks. */
if (*isign == 2 && *itype != 2 && *itype != 3) {
safmin = slamch_("S");
i__1 = kend - 1;
for (jd = kbeg; jd <= i__1; jd += 2) {
if (slaran_(&iseed[1]) > .5f) {
/* Rotation on left. */
cl = slaran_(&iseed[1]) * 2.f - 1.f;
sl = slaran_(&iseed[1]) * 2.f - 1.f;
/* Computing MAX
Computing 2nd power */
r__3 = cl;
/* Computing 2nd power */
r__4 = sl;
r__1 = safmin, r__2 = sqrt(r__3 * r__3 + r__4 * r__4);
temp = 1.f / dmax(r__1,r__2);
cl *= temp;
sl *= temp;
/* Rotation on right. */
cr = slaran_(&iseed[1]) * 2.f - 1.f;
sr = slaran_(&iseed[1]) * 2.f - 1.f;
/* Computing MAX
Computing 2nd power */
r__3 = cr;
/* Computing 2nd power */
r__4 = sr;
r__1 = safmin, r__2 = sqrt(r__3 * r__3 + r__4 * r__4);
temp = 1.f / dmax(r__1,r__2);
cr *= temp;
sr *= temp;
/* Apply */
sv1 = a_ref(jd, jd);
sv2 = a_ref(jd + 1, jd + 1);
a_ref(jd, jd) = cl * cr * sv1 + sl * sr * sv2;
a_ref(jd + 1, jd) = -sl * cr * sv1 + cl * sr * sv2;
a_ref(jd, jd + 1) = -cl * sr * sv1 + sl * cr * sv2;
a_ref(jd + 1, jd + 1) = sl * sr * sv1 + cl * cr * sv2;
}
/* L290: */
}
}
}
/* Fill in upper triangle (except for 2x2 blocks) */
if (*triang != 0.f) {
if (*isign != 2 || *itype == 2 || *itype == 3) {
ioff = 1;
} else {
ioff = 2;
i__1 = *n - 1;
for (jr = 1; jr <= i__1; ++jr) {
if (a_ref(jr + 1, jr) == 0.f) {
a_ref(jr, jr + 1) = *triang * slarnd_(idist, &iseed[1]);
}
/* L300: */
}
}
i__1 = *n;
for (jc = 2; jc <= i__1; ++jc) {
i__2 = jc - ioff;
for (jr = 1; jr <= i__2; ++jr) {
a_ref(jr, jc) = *triang * slarnd_(idist, &iseed[1]);
/* L310: */
}
/* L320: */
}
}
return 0;
/* End of SLATM4 */
} /* slatm4_ */
/* Subroutine */ int pdnaup2_(integer *comm, integer *ido, char *bmat,
integer *n, char *which, integer *nev, integer *np, doublereal *tol,
doublereal *resid, integer *mode, integer *iupd, integer *ishift,
integer *mxiter, doublereal *v, integer *ldv, doublereal *h__,
integer *ldh, doublereal *ritzr, doublereal *ritzi, doublereal *
bounds, doublereal *q, integer *ldq, doublereal *workl, integer *
ipntr, doublereal *workd, integer *info, ftnlen bmat_len, ftnlen
which_len)
{
/* System generated locals */
integer h_dim1, h_offset, q_dim1, q_offset, v_dim1, v_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double pow_dd(doublereal *, doublereal *);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double sqrt(doublereal);
/* Local variables */
static integer j;
static real t0, t1, t2, t3;
static doublereal rnorm_buf__;
static integer kp[4], np0, nev0;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static doublereal eps23;
static integer ierr, iter;
static doublereal temp;
static logical getv0, cnorm;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
static integer nconv;
static logical initv;
static doublereal rnorm;
extern /* Subroutine */ int dvout_(integer *, integer *, doublereal *,
integer *, char *, ftnlen), mpi_allreduce__(doublereal *,
doublereal *, integer *, integer *, integer *, integer *, integer
*);
extern doublereal dlapy2_(doublereal *, doublereal *);
static integer nevbef;
static char wprime[2];
static logical update, ushift;
static integer kplusp, msglvl, nptemp, numcnv;
extern /* Subroutine */ int dnconv_(integer *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *), pdvout_(integer *,
integer *, integer *, doublereal *, integer *, char *, ftnlen),
pivout_(integer *, integer *, integer *, integer *, integer *,
char *, ftnlen), second_(real *), dsortc_(char *, logical *,
integer *, doublereal *, doublereal *, doublereal *, ftnlen),
pdmout_(integer *, integer *, integer *, integer *, doublereal *,
integer *, integer *, char *, ftnlen), pdgetv0_(integer *,
integer *, char *, integer *, logical *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, integer *, ftnlen);
extern doublereal pdnorm2_(integer *, integer *, doublereal *, integer *),
pdlamch_(integer *, char *, ftnlen);
extern /* Subroutine */ int pdneigh_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *), pdnaitr_(
integer *, integer *, char *, integer *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *, integer *, doublereal *, doublereal *,
integer *, ftnlen), pdngets_(integer *, integer *, char *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, ftnlen), pdnapps_(integer *, integer *
, integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, doublereal *);
/* %---------------% */
/* | MPI Variables | */
/* %---------------% */
/* /+ */
/* * */
/* * (C) 1993 by Argonne National Laboratory and Mississipi State University. */
/* * All rights reserved. See COPYRIGHT in top-level directory. */
/* +/ */
/* /+ user include file for MPI programs, with no dependencies +/ */
/* /+ return codes +/ */
/* We handle datatypes by putting the variables that hold them into */
/* common. This way, a Fortran program can directly use the various */
/* datatypes and can even give them to C programs. */
/* MPI_BOTTOM needs to be a known address; here we put it at the */
/* beginning of the common block. The point-to-point and collective */
/* routines know about MPI_BOTTOM, but MPI_TYPE_STRUCT as yet does not. */
/* The types MPI_INTEGER1,2,4 and MPI_REAL4,8 are OPTIONAL. */
/* Their values are zero if they are not available. Note that */
/* using these reduces the portability of code (though may enhance */
/* portability between Crays and other systems) */
/* All other MPI routines are subroutines */
/* The attribute copy/delete functions are symbols that can be passed */
/* to MPI routines */
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %---------------% */
/* | Local Scalars | */
/* %---------------% */
/* %-----------------------% */
/* | Local array arguments | */
/* %-----------------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %---------------------% */
/* | Intrinsic Functions | */
/* %---------------------% */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
/* Parameter adjustments */
--workd;
--resid;
--workl;
--bounds;
--ritzi;
--ritzr;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--ipntr;
/* Function Body */
if (*ido == 0) {
second_(&t0);
msglvl = debug_1.mnaup2;
/* %-------------------------------------% */
/* | Get the machine dependent constant. | */
/* %-------------------------------------% */
eps23 = pdlamch_(comm, "Epsilon-Machine", (ftnlen)15);
eps23 = pow_dd(&eps23, &c_b3);
nev0 = *nev;
np0 = *np;
/* %-------------------------------------% */
/* | kplusp is the bound on the largest | */
/* | Lanczos factorization built. | */
/* | nconv is the current number of | */
/* | "converged" eigenvlues. | */
/* | iter is the counter on the current | */
/* | iteration step. | */
/* %-------------------------------------% */
kplusp = *nev + *np;
nconv = 0;
iter = 0;
/* %---------------------------------------% */
/* | Set flags for computing the first NEV | */
/* | steps of the Arnoldi factorization. | */
/* %---------------------------------------% */
getv0 = TRUE_;
update = FALSE_;
ushift = FALSE_;
cnorm = FALSE_;
if (*info != 0) {
/* %--------------------------------------------% */
/* | User provides the initial residual vector. | */
/* %--------------------------------------------% */
initv = TRUE_;
*info = 0;
} else {
initv = FALSE_;
}
}
/* %---------------------------------------------% */
/* | Get a possibly random starting vector and | */
/* | force it into the range of the operator OP. | */
/* %---------------------------------------------% */
/* L10: */
if (getv0) {
pdgetv0_(comm, ido, bmat, &c__1, &initv, n, &c__1, &v[v_offset], ldv,
&resid[1], &rnorm, &ipntr[1], &workd[1], &workl[1], info, (
ftnlen)1);
if (*ido != 99) {
goto L9000;
}
if (rnorm == 0.) {
/* %-----------------------------------------% */
/* | The initial vector is zero. Error exit. | */
/* %-----------------------------------------% */
*info = -9;
goto L1100;
}
getv0 = FALSE_;
*ido = 0;
}
/* %-----------------------------------% */
/* | Back from reverse communication : | */
/* | continue with update step | */
/* %-----------------------------------% */
if (update) {
goto L20;
}
/* %-------------------------------------------% */
/* | Back from computing user specified shifts | */
/* %-------------------------------------------% */
if (ushift) {
goto L50;
}
/* %-------------------------------------% */
/* | Back from computing residual norm | */
/* | at the end of the current iteration | */
/* %-------------------------------------% */
if (cnorm) {
goto L100;
}
/* %----------------------------------------------------------% */
/* | Compute the first NEV steps of the Arnoldi factorization | */
/* %----------------------------------------------------------% */
pdnaitr_(comm, ido, bmat, n, &c__0, nev, mode, &resid[1], &rnorm, &v[
v_offset], ldv, &h__[h_offset], ldh, &ipntr[1], &workd[1], &workl[
1], info, (ftnlen)1);
/* %---------------------------------------------------% */
/* | ido .ne. 99 implies use of reverse communication | */
/* | to compute operations involving OP and possibly B | */
/* %---------------------------------------------------% */
if (*ido != 99) {
goto L9000;
}
if (*info > 0) {
*np = *info;
*mxiter = iter;
*info = -9999;
goto L1200;
}
/* %--------------------------------------------------------------% */
/* | | */
/* | M A I N ARNOLDI I T E R A T I O N L O O P | */
/* | Each iteration implicitly restarts the Arnoldi | */
/* | factorization in place. | */
/* | | */
/* %--------------------------------------------------------------% */
L1000:
++iter;
if (msglvl > 0) {
pivout_(comm, &debug_1.logfil, &c__1, &iter, &debug_1.ndigit, "_naup"
"2: **** Start of major iteration number ****", (ftnlen)49);
}
/* %-----------------------------------------------------------% */
/* | Compute NP additional steps of the Arnoldi factorization. | */
/* | Adjust NP since NEV might have been updated by last call | */
/* | to the shift application routine pdnapps . | */
/* %-----------------------------------------------------------% */
*np = kplusp - *nev;
if (msglvl > 1) {
pivout_(comm, &debug_1.logfil, &c__1, nev, &debug_1.ndigit, "_naup2:"
" The length of the current Arnoldi factorization", (ftnlen)55)
;
pivout_(comm, &debug_1.logfil, &c__1, np, &debug_1.ndigit, "_naup2: "
"Extend the Arnoldi factorization by", (ftnlen)43);
}
/* %-----------------------------------------------------------% */
/* | Compute NP additional steps of the Arnoldi factorization. | */
/* %-----------------------------------------------------------% */
*ido = 0;
L20:
update = TRUE_;
pdnaitr_(comm, ido, bmat, n, nev, np, mode, &resid[1], &rnorm, &v[
v_offset], ldv, &h__[h_offset], ldh, &ipntr[1], &workd[1], &workl[
1], info, (ftnlen)1);
/* %---------------------------------------------------% */
/* | ido .ne. 99 implies use of reverse communication | */
/* | to compute operations involving OP and possibly B | */
/* %---------------------------------------------------% */
if (*ido != 99) {
goto L9000;
}
if (*info > 0) {
*np = *info;
*mxiter = iter;
*info = -9999;
goto L1200;
}
update = FALSE_;
if (msglvl > 1) {
pdvout_(comm, &debug_1.logfil, &c__1, &rnorm, &debug_1.ndigit, "_nau"
"p2: Corresponding B-norm of the residual", (ftnlen)44);
}
/* %--------------------------------------------------------% */
/* | Compute the eigenvalues and corresponding error bounds | */
/* | of the current upper Hessenberg matrix. | */
/* %--------------------------------------------------------% */
pdneigh_(comm, &rnorm, &kplusp, &h__[h_offset], ldh, &ritzr[1], &ritzi[1],
&bounds[1], &q[q_offset], ldq, &workl[1], &ierr);
if (ierr != 0) {
*info = -8;
goto L1200;
}
/* %----------------------------------------------------% */
/* | Make a copy of eigenvalues and corresponding error | */
/* | bounds obtained from pdneigh . | */
/* %----------------------------------------------------% */
/* Computing 2nd power */
i__1 = kplusp;
dcopy_(&kplusp, &ritzr[1], &c__1, &workl[i__1 * i__1 + 1], &c__1);
/* Computing 2nd power */
i__1 = kplusp;
dcopy_(&kplusp, &ritzi[1], &c__1, &workl[i__1 * i__1 + kplusp + 1], &c__1)
;
/* Computing 2nd power */
i__1 = kplusp;
dcopy_(&kplusp, &bounds[1], &c__1, &workl[i__1 * i__1 + (kplusp << 1) + 1]
, &c__1);
/* %---------------------------------------------------% */
/* | Select the wanted Ritz values and their bounds | */
/* | to be used in the convergence test. | */
/* | The wanted part of the spectrum and corresponding | */
/* | error bounds are in the last NEV loc. of RITZR, | */
/* | RITZI and BOUNDS respectively. The variables NEV | */
/* | and NP may be updated if the NEV-th wanted Ritz | */
/* | value has a non zero imaginary part. In this case | */
/* | NEV is increased by one and NP decreased by one. | */
/* | NOTE: The last two arguments of pdngets are no | */
/* | longer used as of version 2.1. | */
/* %---------------------------------------------------% */
*nev = nev0;
*np = np0;
numcnv = *nev;
pdngets_(comm, ishift, which, nev, np, &ritzr[1], &ritzi[1], &bounds[1], &
workl[1], &workl[*np + 1], (ftnlen)2);
if (*nev == nev0 + 1) {
numcnv = nev0 + 1;
}
/* %-------------------% */
/* | Convergence test. | */
/* %-------------------% */
dcopy_(nev, &bounds[*np + 1], &c__1, &workl[(*np << 1) + 1], &c__1);
dnconv_(nev, &ritzr[*np + 1], &ritzi[*np + 1], &workl[(*np << 1) + 1],
tol, &nconv);
if (msglvl > 2) {
kp[0] = *nev;
kp[1] = *np;
kp[2] = numcnv;
kp[3] = nconv;
pivout_(comm, &debug_1.logfil, &c__4, kp, &debug_1.ndigit, "_naup2: "
"NEV, NP, NUMCNV, NCONV are", (ftnlen)34);
pdvout_(comm, &debug_1.logfil, &kplusp, &ritzr[1], &debug_1.ndigit,
"_naup2: Real part of the eigenvalues of H", (ftnlen)41);
pdvout_(comm, &debug_1.logfil, &kplusp, &ritzi[1], &debug_1.ndigit,
"_naup2: Imaginary part of the eigenvalues of H", (ftnlen)46);
pdvout_(comm, &debug_1.logfil, &kplusp, &bounds[1], &debug_1.ndigit,
"_naup2: Ritz estimates of the current NCV Ritz values", (
ftnlen)53);
}
/* %---------------------------------------------------------% */
/* | Count the number of unwanted Ritz values that have zero | */
/* | Ritz estimates. If any Ritz estimates are equal to zero | */
/* | then a leading block of H of order equal to at least | */
/* | the number of Ritz values with zero Ritz estimates has | */
/* | split off. None of these Ritz values may be removed by | */
/* | shifting. Decrease NP the number of shifts to apply. If | */
/* | no shifts may be applied, then prepare to exit | */
/* %---------------------------------------------------------% */
nptemp = *np;
i__1 = nptemp;
for (j = 1; j <= i__1; ++j) {
if (bounds[j] == 0.) {
--(*np);
++(*nev);
}
/* L30: */
}
if (nconv >= numcnv || iter > *mxiter || *np == 0) {
if (msglvl > 4) {
/* Computing 2nd power */
i__1 = kplusp;
dvout_(&debug_1.logfil, &kplusp, &workl[i__1 * i__1 + 1], &
debug_1.ndigit, "_naup2: Real part of the eig computed b"
"y _neigh:", (ftnlen)48);
/* Computing 2nd power */
i__1 = kplusp;
dvout_(&debug_1.logfil, &kplusp, &workl[i__1 * i__1 + kplusp + 1],
&debug_1.ndigit, "_naup2: Imag part of the eig computed"
" by _neigh:", (ftnlen)48);
/* Computing 2nd power */
i__1 = kplusp;
dvout_(&debug_1.logfil, &kplusp, &workl[i__1 * i__1 + (kplusp <<
1) + 1], &debug_1.ndigit, "_naup2: Ritz estimates comput"
"ed by _neigh:", (ftnlen)42);
}
/* %------------------------------------------------% */
/* | Prepare to exit. Put the converged Ritz values | */
/* | and corresponding bounds in RITZ(1:NCONV) and | */
/* | BOUNDS(1:NCONV) respectively. Then sort. Be | */
/* | careful when NCONV > NP | */
/* %------------------------------------------------% */
/* %------------------------------------------% */
/* | Use h( 3,1 ) as storage to communicate | */
/* | rnorm to _neupd if needed | */
/* %------------------------------------------% */
h__[h_dim1 + 3] = rnorm;
/* %----------------------------------------------% */
/* | To be consistent with dngets , we first do a | */
/* | pre-processing sort in order to keep complex | */
/* | conjugate pairs together. This is similar | */
/* | to the pre-processing sort used in dngets | */
/* | except that the sort is done in the opposite | */
/* | order. | */
/* %----------------------------------------------% */
if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "SR", (ftnlen)2, (ftnlen)2);
}
if (s_cmp(which, "SM", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "LR", (ftnlen)2, (ftnlen)2);
}
if (s_cmp(which, "LR", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "SM", (ftnlen)2, (ftnlen)2);
}
if (s_cmp(which, "SR", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "LM", (ftnlen)2, (ftnlen)2);
}
if (s_cmp(which, "LI", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "SM", (ftnlen)2, (ftnlen)2);
}
if (s_cmp(which, "SI", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "LM", (ftnlen)2, (ftnlen)2);
}
dsortc_(wprime, &c_true, &kplusp, &ritzr[1], &ritzi[1], &bounds[1], (
ftnlen)2);
/* %----------------------------------------------% */
/* | Now sort Ritz values so that converged Ritz | */
/* | values appear within the first NEV locations | */
/* | of ritzr, ritzi and bounds, and the most | */
/* | desired one appears at the front. | */
/* %----------------------------------------------% */
if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "SM", (ftnlen)2, (ftnlen)2);
}
if (s_cmp(which, "SM", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "LM", (ftnlen)2, (ftnlen)2);
}
if (s_cmp(which, "LR", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "SR", (ftnlen)2, (ftnlen)2);
}
if (s_cmp(which, "SR", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "LR", (ftnlen)2, (ftnlen)2);
}
if (s_cmp(which, "LI", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "SI", (ftnlen)2, (ftnlen)2);
}
if (s_cmp(which, "SI", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "LI", (ftnlen)2, (ftnlen)2);
}
dsortc_(wprime, &c_true, &kplusp, &ritzr[1], &ritzi[1], &bounds[1], (
ftnlen)2);
/* %--------------------------------------------------% */
/* | Scale the Ritz estimate of each Ritz value | */
/* | by 1 / max(eps23,magnitude of the Ritz value). | */
/* %--------------------------------------------------% */
i__1 = numcnv;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
d__1 = eps23, d__2 = dlapy2_(&ritzr[j], &ritzi[j]);
temp = max(d__1,d__2);
bounds[j] /= temp;
/* L35: */
}
/* %----------------------------------------------------% */
/* | Sort the Ritz values according to the scaled Ritz | */
/* | esitmates. This will push all the converged ones | */
/* | towards the front of ritzr, ritzi, bounds | */
/* | (in the case when NCONV < NEV.) | */
/* %----------------------------------------------------% */
s_copy(wprime, "LR", (ftnlen)2, (ftnlen)2);
dsortc_(wprime, &c_true, &numcnv, &bounds[1], &ritzr[1], &ritzi[1], (
ftnlen)2);
/* %----------------------------------------------% */
/* | Scale the Ritz estimate back to its original | */
/* | value. | */
/* %----------------------------------------------% */
i__1 = numcnv;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
d__1 = eps23, d__2 = dlapy2_(&ritzr[j], &ritzi[j]);
temp = max(d__1,d__2);
bounds[j] *= temp;
/* L40: */
}
/* %------------------------------------------------% */
/* | Sort the converged Ritz values again so that | */
/* | the "threshold" value appears at the front of | */
/* | ritzr, ritzi and bound. | */
/* %------------------------------------------------% */
dsortc_(which, &c_true, &nconv, &ritzr[1], &ritzi[1], &bounds[1], (
ftnlen)2);
if (msglvl > 1) {
dvout_(&debug_1.logfil, &kplusp, &ritzr[1], &debug_1.ndigit,
"_naup2: Sorted real part of the eigenvalues", (ftnlen)43)
;
dvout_(&debug_1.logfil, &kplusp, &ritzi[1], &debug_1.ndigit,
"_naup2: Sorted imaginary part of the eigenvalues", (
ftnlen)48);
dvout_(&debug_1.logfil, &kplusp, &bounds[1], &debug_1.ndigit,
"_naup2: Sorted ritz estimates.", (ftnlen)30);
}
/* %------------------------------------% */
/* | Max iterations have been exceeded. | */
/* %------------------------------------% */
if (iter > *mxiter && nconv < numcnv) {
*info = 1;
}
/* %---------------------% */
/* | No shifts to apply. | */
/* %---------------------% */
if (*np == 0 && nconv < numcnv) {
*info = 2;
}
*np = nconv;
goto L1100;
} else if (nconv < numcnv && *ishift == 1) {
/* %-------------------------------------------------% */
/* | Do not have all the requested eigenvalues yet. | */
/* | To prevent possible stagnation, adjust the size | */
/* | of NEV. | */
/* %-------------------------------------------------% */
nevbef = *nev;
/* Computing MIN */
i__1 = nconv, i__2 = *np / 2;
*nev += min(i__1,i__2);
if (*nev == 1 && kplusp >= 6) {
*nev = kplusp / 2;
} else if (*nev == 1 && kplusp > 3) {
*nev = 2;
}
*np = kplusp - *nev;
/* %---------------------------------------% */
/* | If the size of NEV was just increased | */
/* | resort the eigenvalues. | */
/* %---------------------------------------% */
if (nevbef < *nev) {
pdngets_(comm, ishift, which, nev, np, &ritzr[1], &ritzi[1], &
bounds[1], &workl[1], &workl[*np + 1], (ftnlen)2);
}
}
if (msglvl > 0) {
pivout_(comm, &debug_1.logfil, &c__1, &nconv, &debug_1.ndigit, "_nau"
"p2: no. of \"converged\" Ritz values at this iter.", (ftnlen)
52);
if (msglvl > 1) {
kp[0] = *nev;
kp[1] = *np;
pivout_(comm, &debug_1.logfil, &c__2, kp, &debug_1.ndigit, "_nau"
"p2: NEV and NP are", (ftnlen)22);
pdvout_(comm, &debug_1.logfil, nev, &ritzr[*np + 1], &
debug_1.ndigit, "_naup2: \"wanted\" Ritz values -- real "
"part", (ftnlen)41);
pdvout_(comm, &debug_1.logfil, nev, &ritzi[*np + 1], &
debug_1.ndigit, "_naup2: \"wanted\" Ritz values -- imag "
"part", (ftnlen)41);
pdvout_(comm, &debug_1.logfil, nev, &bounds[*np + 1], &
debug_1.ndigit, "_naup2: Ritz estimates of the \"wante"
"d\" values ", (ftnlen)46);
}
}
if (*ishift == 0) {
/* %-------------------------------------------------------% */
/* | User specified shifts: reverse comminucation to | */
/* | compute the shifts. They are returned in the first | */
/* | 2*NP locations of WORKL. | */
/* %-------------------------------------------------------% */
ushift = TRUE_;
*ido = 3;
goto L9000;
}
L50:
/* %------------------------------------% */
/* | Back from reverse communication; | */
/* | User specified shifts are returned | */
/* | in WORKL(1:2*NP) | */
/* %------------------------------------% */
ushift = FALSE_;
if (*ishift == 0) {
/* %----------------------------------% */
/* | Move the NP shifts from WORKL to | */
/* | RITZR, RITZI to free up WORKL | */
/* | for non-exact shift case. | */
/* %----------------------------------% */
dcopy_(np, &workl[1], &c__1, &ritzr[1], &c__1);
dcopy_(np, &workl[*np + 1], &c__1, &ritzi[1], &c__1);
}
if (msglvl > 2) {
pivout_(comm, &debug_1.logfil, &c__1, np, &debug_1.ndigit, "_naup2: "
"The number of shifts to apply ", (ftnlen)38);
pdvout_(comm, &debug_1.logfil, np, &ritzr[1], &debug_1.ndigit, "_nau"
"p2: Real part of the shifts", (ftnlen)31);
pdvout_(comm, &debug_1.logfil, np, &ritzi[1], &debug_1.ndigit, "_nau"
"p2: Imaginary part of the shifts", (ftnlen)36);
if (*ishift == 1) {
pdvout_(comm, &debug_1.logfil, np, &bounds[1], &debug_1.ndigit,
"_naup2: Ritz estimates of the shifts", (ftnlen)36);
}
}
/* %---------------------------------------------------------% */
/* | Apply the NP implicit shifts by QR bulge chasing. | */
/* | Each shift is applied to the whole upper Hessenberg | */
/* | matrix H. | */
/* | The first 2*N locations of WORKD are used as workspace. | */
/* %---------------------------------------------------------% */
pdnapps_(comm, n, nev, np, &ritzr[1], &ritzi[1], &v[v_offset], ldv, &h__[
h_offset], ldh, &resid[1], &q[q_offset], ldq, &workl[1], &workd[1]
);
/* %---------------------------------------------% */
/* | Compute the B-norm of the updated residual. | */
/* | Keep B*RESID in WORKD(1:N) to be used in | */
/* | the first step of the next call to pdnaitr . | */
/* %---------------------------------------------% */
cnorm = TRUE_;
second_(&t2);
if (*(unsigned char *)bmat == 'G') {
++timing_1.nbx;
dcopy_(n, &resid[1], &c__1, &workd[*n + 1], &c__1);
ipntr[1] = *n + 1;
ipntr[2] = 1;
*ido = 2;
/* %----------------------------------% */
/* | Exit in order to compute B*RESID | */
/* %----------------------------------% */
goto L9000;
} else if (*(unsigned char *)bmat == 'I') {
dcopy_(n, &resid[1], &c__1, &workd[1], &c__1);
}
L100:
/* %----------------------------------% */
/* | Back from reverse communication; | */
/* | WORKD(1:N) := B*RESID | */
/* %----------------------------------% */
if (*(unsigned char *)bmat == 'G') {
second_(&t3);
timing_1.tmvbx += t3 - t2;
}
if (*(unsigned char *)bmat == 'G') {
rnorm_buf__ = ddot_(n, &resid[1], &c__1, &workd[1], &c__1);
mpi_allreduce__(&rnorm_buf__, &rnorm, &c__1, &
mpipriv_1.mpi_double_precision__, &mpipriv_1.mpi_sum__, comm,
&ierr);
rnorm = sqrt((abs(rnorm)));
} else if (*(unsigned char *)bmat == 'I') {
rnorm = pdnorm2_(comm, n, &resid[1], &c__1);
}
cnorm = FALSE_;
if (msglvl > 2) {
pdvout_(comm, &debug_1.logfil, &c__1, &rnorm, &debug_1.ndigit, "_nau"
"p2: B-norm of residual for compressed factorization", (ftnlen)
55);
pdmout_(comm, &debug_1.logfil, nev, nev, &h__[h_offset], ldh, &
debug_1.ndigit, "_naup2: Compressed upper Hessenberg matrix H"
, (ftnlen)44);
}
goto L1000;
/* %---------------------------------------------------------------% */
/* | | */
/* | E N D O F M A I N I T E R A T I O N L O O P | */
/* | | */
/* %---------------------------------------------------------------% */
L1100:
*mxiter = iter;
*nev = numcnv;
L1200:
*ido = 99;
/* %------------% */
/* | Error Exit | */
/* %------------% */
second_(&t1);
timing_1.tnaup2 = t1 - t0;
L9000:
/* %----------------% */
/* | End of pdnaup2 | */
/* %----------------% */
return 0;
} /* pdnaup2_ */
/* ----------------------------------------------------------------------| */
/* Subroutine */ int zgexpv(integer *n, integer *m, doublereal *t,
doublecomplex *v, doublecomplex *w, doublereal *tol, doublereal *
anorm, doublecomplex *wsp, integer *lwsp, integer *iwsp, integer *
liwsp, S_fp matvec, void *matvecdata, integer *itrace, integer *iflag)
{
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1;
complex q__1;
doublecomplex z__1;
/* Builtin functions */
/* Subroutine */ int s_stop(char *, ftnlen);
double sqrt(doublereal), d_sign(doublereal *, doublereal *), pow_di(
doublereal *, integer *), pow_dd(doublereal *, doublereal *),
d_lg10(doublereal *);
integer i_dnnt(doublereal *);
double d_int(doublereal *);
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle();
double z_abs(doublecomplex *);
/* Local variables */
static integer ibrkflag;
static doublereal step_min__, step_max__;
static integer i__, j;
static doublereal break_tol__;
static integer k1;
static doublereal p1, p2, p3;
static integer ih, mh, iv, ns, mx;
static doublereal xm;
static integer j1v;
static doublecomplex hij;
static doublereal sgn, eps, hj1j, sqr1, beta, hump;
static integer ifree, lfree;
static doublereal t_old__;
static integer iexph;
static doublereal t_new__;
static integer nexph;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static doublereal t_now__;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, ftnlen);
static integer nstep;
static doublereal t_out__;
static integer nmult;
static doublereal vnorm;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
static integer nscale;
static doublereal rndoff;
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *), zgpadm_(integer *, integer *,
doublereal *, doublecomplex *, integer *, doublecomplex *,
integer *, integer *, integer *, integer *, integer *), znchbv_(
integer *, doublereal *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *);
static doublereal t_step__, avnorm;
static integer ireject;
static doublereal err_loc__;
static integer nreject, mbrkdwn;
static doublereal tbrkdwn, s_error__, x_error__;
/* Fortran I/O blocks */
static cilist io___40 = { 0, 6, 0, 0, 0 };
static cilist io___48 = { 0, 6, 0, 0, 0 };
static cilist io___49 = { 0, 6, 0, 0, 0 };
static cilist io___50 = { 0, 6, 0, 0, 0 };
static cilist io___51 = { 0, 6, 0, 0, 0 };
static cilist io___52 = { 0, 6, 0, 0, 0 };
static cilist io___53 = { 0, 6, 0, 0, 0 };
static cilist io___54 = { 0, 6, 0, 0, 0 };
static cilist io___55 = { 0, 6, 0, 0, 0 };
static cilist io___56 = { 0, 6, 0, 0, 0 };
static cilist io___57 = { 0, 6, 0, 0, 0 };
static cilist io___58 = { 0, 6, 0, 0, 0 };
static cilist io___59 = { 0, 6, 0, 0, 0 };
/* -----Purpose----------------------------------------------------------| */
/* --- ZGEXPV computes w = exp(t*A)*v */
/* for a Zomplex (i.e., complex double precision) matrix A */
/* It does not compute the matrix exponential in isolation but */
/* instead, it computes directly the action of the exponential */
/* operator on the operand vector. This way of doing so allows */
/* for addressing large sparse problems. */
/* The method used is based on Krylov subspace projection */
/* techniques and the matrix under consideration interacts only */
/* via the external routine `matvec' performing the matrix-vector */
/* product (matrix-free method). */
/* -----Arguments--------------------------------------------------------| */
/* n : (input) order of the principal matrix A. */
/* m : (input) maximum size for the Krylov basis. */
/* t : (input) time at wich the solution is needed (can be < 0). */
/* v(n) : (input) given operand vector. */
/* w(n) : (output) computed approximation of exp(t*A)*v. */
/* tol : (input/output) the requested accuracy tolerance on w. */
/* If on input tol=0.0d0 or tol is too small (tol.le.eps) */
/* the internal value sqrt(eps) is used, and tol is set to */
/* sqrt(eps) on output (`eps' denotes the machine epsilon). */
/* (`Happy breakdown' is assumed if h(j+1,j) .le. anorm*tol) */
/* anorm : (input) an approximation of some norm of A. */
/* wsp(lwsp): (workspace) lwsp .ge. n*(m+1)+n+(m+2)^2+4*(m+2)^2+ideg+1 */
/* +---------+-------+---------------+ */
/* (actually, ideg=6) V H wsp for PADE */
/* iwsp(liwsp): (workspace) liwsp .ge. m+2 */
/* matvec : external subroutine for matrix-vector multiplication. */
/* synopsis: matvec( x, y ) */
/* complex*16 x(*), y(*) */
/* computes: y(1:n) <- A*x(1:n) */
/* where A is the principal matrix. */
/* itrace : (input) running mode. 0=silent, 1=print step-by-step info */
/* iflag : (output) exit flag. */
/* <0 - bad input arguments */
/* 0 - no problem */
/* 1 - maximum number of steps reached without convergence */
/* 2 - requested tolerance was too high */
/* -----Accounts on the computation--------------------------------------| */
/* Upon exit, an interested user may retrieve accounts on the */
/* computations. They are located in the workspace arrays wsp and */
/* iwsp as indicated below: */
/* location mnemonic description */
/* -----------------------------------------------------------------| */
/* iwsp(1) = nmult, number of matrix-vector multiplications used */
/* iwsp(2) = nexph, number of Hessenberg matrix exponential evaluated */
/* iwsp(3) = nscale, number of repeated squaring involved in Pade */
/* iwsp(4) = nstep, number of integration steps used up to completion */
/* iwsp(5) = nreject, number of rejected step-sizes */
/* iwsp(6) = ibrkflag, set to 1 if `happy breakdown' and 0 otherwise */
/* iwsp(7) = mbrkdwn, if `happy brkdown', basis-size when it occured */
/* -----------------------------------------------------------------| */
/* wsp(1) = step_min, minimum step-size used during integration */
/* wsp(2) = step_max, maximum step-size used during integration */
/* wsp(3) = x_round, maximum among all roundoff errors (lower bound) */
/* wsp(4) = s_round, sum of roundoff errors (lower bound) */
/* wsp(5) = x_error, maximum among all local truncation errors */
/* wsp(6) = s_error, global sum of local truncation errors */
/* wsp(7) = tbrkdwn, if `happy breakdown', time when it occured */
/* wsp(8) = t_now, integration domain successfully covered */
/* wsp(9) = hump, i.e., max||exp(sA)||, s in [0,t] (or [t,0] if t<0) */
/* wsp(10) = ||w||/||v||, scaled norm of the solution w. */
/* -----------------------------------------------------------------| */
/* The `hump' is a measure of the conditioning of the problem. The */
/* matrix exponential is well-conditioned if hump = 1, whereas it is */
/* poorly-conditioned if hump >> 1. However the solution can still be */
/* relatively fairly accurate even when the hump is large (the hump */
/* is an upper bound), especially when the hump and the scaled norm */
/* of w [this is also computed and returned in wsp(10)] are of the */
/* same order of magnitude (further details in reference below). */
/* ----------------------------------------------------------------------| */
/* -----The following parameters may also be adjusted herein-------------| */
/* mxstep : maximum allowable number of integration steps. */
/* The value 0 means an infinite number of steps. */
/* mxreject: maximum allowable number of rejections at each step. */
/* The value 0 means an infinite number of rejections. */
/* ideg : the Pade approximation of type (ideg,ideg) is used as */
/* an approximation to exp(H). The value 0 switches to the */
/* uniform rational Chebyshev approximation of type (14,14) */
/* delta : local truncation error `safety factor' */
/* gamma : stepsize `shrinking factor' */
/* ----------------------------------------------------------------------| */
/* Roger B. Sidje ([email protected]) */
/* EXPOKIT: Software Package for Computing Matrix Exponentials. */
/* ACM - Transactions On Mathematical Software, 24(1):130-156, 1998 */
/* ----------------------------------------------------------------------| */
/* --- check restrictions on input parameters ... */
/* Parameter adjustments */
--w;
--v;
--wsp;
--iwsp;
/* Function Body */
*iflag = 0;
/* Computing 2nd power */
i__1 = *m + 2;
if (*lwsp < *n * (*m + 2) + i__1 * i__1 * 5 + 7) {
*iflag = -1;
}
if (*liwsp < *m + 2) {
*iflag = -2;
}
if (*m >= *n || *m <= 0) {
*iflag = -3;
}
if (*iflag != 0) {
s_stop("bad sizes (in input of ZGEXPV)", (ftnlen)30);
}
/* --- initialisations ... */
k1 = 2;
mh = *m + 2;
iv = 1;
ih = iv + *n * (*m + 1) + *n;
ifree = ih + mh * mh;
lfree = *lwsp - ifree + 1;
ibrkflag = 0;
mbrkdwn = *m;
nmult = 0;
nreject = 0;
nexph = 0;
nscale = 0;
t_out__ = abs(*t);
tbrkdwn = 0.;
step_min__ = t_out__;
step_max__ = 0.;
nstep = 0;
s_error__ = 0.;
x_error__ = 0.;
t_now__ = 0.;
t_new__ = 0.;
p1 = 1.3333333333333333;
L1:
p2 = p1 - 1.;
p3 = p2 + p2 + p2;
eps = (d__1 = p3 - 1., abs(d__1));
if (eps == 0.) {
goto L1;
}
if (*tol <= eps) {
*tol = sqrt(eps);
}
rndoff = eps * *anorm;
break_tol__ = 1e-7;
/* >>> break_tol = tol */
/* >>> break_tol = anorm*tol */
sgn = d_sign(&c_b6, t);
zcopy_(n, &v[1], &c__1, &w[1], &c__1);
beta = dznrm2_(n, &w[1], &c__1);
vnorm = beta;
hump = beta;
/* --- obtain the very first stepsize ... */
sqr1 = sqrt(.1);
xm = 1. / (doublereal) (*m);
d__1 = (*m + 1) / 2.72;
i__1 = *m + 1;
p2 = *tol * pow_di(&d__1, &i__1) * sqrt((*m + 1) * 6.2800000000000002);
d__1 = p2 / (beta * 4. * *anorm);
t_new__ = 1. / *anorm * pow_dd(&d__1, &xm);
d__1 = d_lg10(&t_new__) - sqr1;
i__1 = i_dnnt(&d__1) - 1;
p1 = pow_di(&c_b10, &i__1);
d__1 = t_new__ / p1 + .55;
t_new__ = d_int(&d__1) * p1;
/* --- step-by-step integration ... */
L100:
if (t_now__ >= t_out__) {
goto L500;
}
++nstep;
/* Computing MIN */
d__1 = t_out__ - t_now__;
t_step__ = min(d__1,t_new__);
p1 = 1. / beta;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iv + i__ - 1;
i__3 = i__;
z__1.r = p1 * w[i__3].r, z__1.i = p1 * w[i__3].i;
wsp[i__2].r = z__1.r, wsp[i__2].i = z__1.i;
}
i__1 = mh * mh;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = ih + i__ - 1;
wsp[i__2].r = 0., wsp[i__2].i = 0.;
}
/* --- Arnoldi loop ... */
j1v = iv + *n;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
++nmult;
(*matvec)(matvecdata, &wsp[j1v - *n], &wsp[j1v]);
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
zdotc_(&z__1, n, &wsp[iv + (i__ - 1) * *n], &c__1, &wsp[j1v], &
c__1);
hij.r = z__1.r, hij.i = z__1.i;
z__1.r = -hij.r, z__1.i = -hij.i;
zaxpy_(n, &z__1, &wsp[iv + (i__ - 1) * *n], &c__1, &wsp[j1v], &
c__1);
i__3 = ih + (j - 1) * mh + i__ - 1;
wsp[i__3].r = hij.r, wsp[i__3].i = hij.i;
}
hj1j = dznrm2_(n, &wsp[j1v], &c__1);
/* --- if `happy breakdown' go straightforward at the end ... */
if (hj1j <= break_tol__) {
s_wsle(&io___40);
do_lio(&c__9, &c__1, "happy breakdown: mbrkdwn =", (ftnlen)26);
do_lio(&c__3, &c__1, (char *)&j, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, " h =", (ftnlen)4);
do_lio(&c__5, &c__1, (char *)&hj1j, (ftnlen)sizeof(doublereal));
e_wsle();
k1 = 0;
ibrkflag = 1;
mbrkdwn = j;
tbrkdwn = t_now__;
t_step__ = t_out__ - t_now__;
goto L300;
}
i__2 = ih + (j - 1) * mh + j;
q__1.r = hj1j, q__1.i = (float)0.;
wsp[i__2].r = q__1.r, wsp[i__2].i = q__1.i;
d__1 = 1. / hj1j;
zdscal_(n, &d__1, &wsp[j1v], &c__1);
j1v += *n;
/* L200: */
}
++nmult;
(*matvec)(matvecdata, &wsp[j1v - *n], &wsp[j1v]);
avnorm = dznrm2_(n, &wsp[j1v], &c__1);
/* --- set 1 for the 2-corrected scheme ... */
L300:
i__1 = ih + *m * mh + *m + 1;
wsp[i__1].r = 1., wsp[i__1].i = 0.;
/* --- loop while ireject<mxreject until the tolerance is reached ... */
ireject = 0;
L401:
/* --- compute w = beta*V*exp(t_step*H)*e1 ... */
++nexph;
mx = mbrkdwn + k1;
if (TRUE_) {
/* --- irreducible rational Pade approximation ... */
d__1 = sgn * t_step__;
zgpadm_(&c__6, &mx, &d__1, &wsp[ih], &mh, &wsp[ifree], &lfree, &iwsp[
1], &iexph, &ns, iflag);
iexph = ifree + iexph - 1;
nscale += ns;
} else {
/* --- uniform rational Chebyshev approximation ... */
iexph = ifree;
i__1 = mx;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = iexph + i__ - 1;
wsp[i__2].r = 0., wsp[i__2].i = 0.;
}
i__1 = iexph;
wsp[i__1].r = 1., wsp[i__1].i = 0.;
d__1 = sgn * t_step__;
znchbv_(&mx, &d__1, &wsp[ih], &mh, &wsp[iexph], &wsp[ifree + mx]);
}
/* L402: */
/* --- error estimate ... */
if (k1 == 0) {
err_loc__ = *tol;
} else {
p1 = z_abs(&wsp[iexph + *m]) * beta;
p2 = z_abs(&wsp[iexph + *m + 1]) * beta * avnorm;
if (p1 > p2 * 10.) {
err_loc__ = p2;
xm = 1. / (doublereal) (*m);
} else if (p1 > p2) {
err_loc__ = p1 * p2 / (p1 - p2);
xm = 1. / (doublereal) (*m);
} else {
err_loc__ = p1;
xm = 1. / (doublereal) (*m - 1);
}
}
/* --- reject the step-size if the error is not acceptable ... */
if (k1 != 0 && err_loc__ > t_step__ * 1.2 * *tol) {
t_old__ = t_step__;
d__1 = t_step__ * *tol / err_loc__;
t_step__ = t_step__ * .9 * pow_dd(&d__1, &xm);
d__1 = d_lg10(&t_step__) - sqr1;
i__1 = i_dnnt(&d__1) - 1;
p1 = pow_di(&c_b10, &i__1);
d__1 = t_step__ / p1 + .55;
t_step__ = d_int(&d__1) * p1;
if (*itrace != 0) {
s_wsle(&io___48);
do_lio(&c__9, &c__1, "t_step =", (ftnlen)8);
do_lio(&c__5, &c__1, (char *)&t_old__, (ftnlen)sizeof(doublereal))
;
e_wsle();
s_wsle(&io___49);
do_lio(&c__9, &c__1, "err_loc =", (ftnlen)9);
do_lio(&c__5, &c__1, (char *)&err_loc__, (ftnlen)sizeof(
doublereal));
e_wsle();
s_wsle(&io___50);
do_lio(&c__9, &c__1, "err_required =", (ftnlen)14);
d__1 = t_old__ * 1.2 * *tol;
do_lio(&c__5, &c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
e_wsle();
s_wsle(&io___51);
do_lio(&c__9, &c__1, "stepsize rejected, stepping down to:", (
ftnlen)36);
do_lio(&c__5, &c__1, (char *)&t_step__, (ftnlen)sizeof(doublereal)
);
e_wsle();
}
++ireject;
++nreject;
if (FALSE_) {
s_wsle(&io___52);
do_lio(&c__9, &c__1, "Failure in ZGEXPV: ---", (ftnlen)22);
e_wsle();
s_wsle(&io___53);
do_lio(&c__9, &c__1, "The requested tolerance is too high.", (
ftnlen)36);
e_wsle();
s_wsle(&io___54);
do_lio(&c__9, &c__1, "Rerun with a smaller value.", (ftnlen)27);
e_wsle();
*iflag = 2;
return 0;
}
goto L401;
}
/* --- now update w = beta*V*exp(t_step*H)*e1 and the hump ... */
/* Computing MAX */
i__1 = 0, i__2 = k1 - 1;
mx = mbrkdwn + max(i__1,i__2);
q__1.r = beta, q__1.i = (float)0.;
hij.r = q__1.r, hij.i = q__1.i;
zgemv_("n", n, &mx, &hij, &wsp[iv], n, &wsp[iexph], &c__1, &c_b1, &w[1], &
c__1, (ftnlen)1);
beta = dznrm2_(n, &w[1], &c__1);
hump = max(hump,beta);
/* --- suggested value for the next stepsize ... */
d__1 = t_step__ * *tol / err_loc__;
t_new__ = t_step__ * .9 * pow_dd(&d__1, &xm);
d__1 = d_lg10(&t_new__) - sqr1;
i__1 = i_dnnt(&d__1) - 1;
p1 = pow_di(&c_b10, &i__1);
d__1 = t_new__ / p1 + .55;
t_new__ = d_int(&d__1) * p1;
err_loc__ = max(err_loc__,rndoff);
/* --- update the time covered ... */
t_now__ += t_step__;
/* --- display and keep some information ... */
if (*itrace != 0) {
s_wsle(&io___55);
do_lio(&c__9, &c__1, "integration", (ftnlen)11);
do_lio(&c__3, &c__1, (char *)&nstep, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, "---------------------------------", (ftnlen)33);
e_wsle();
s_wsle(&io___56);
do_lio(&c__9, &c__1, "scale-square =", (ftnlen)14);
do_lio(&c__3, &c__1, (char *)&ns, (ftnlen)sizeof(integer));
e_wsle();
s_wsle(&io___57);
do_lio(&c__9, &c__1, "step_size =", (ftnlen)11);
do_lio(&c__5, &c__1, (char *)&t_step__, (ftnlen)sizeof(doublereal));
e_wsle();
s_wsle(&io___58);
do_lio(&c__9, &c__1, "err_loc =", (ftnlen)11);
do_lio(&c__5, &c__1, (char *)&err_loc__, (ftnlen)sizeof(doublereal));
e_wsle();
s_wsle(&io___59);
do_lio(&c__9, &c__1, "next_step =", (ftnlen)11);
do_lio(&c__5, &c__1, (char *)&t_new__, (ftnlen)sizeof(doublereal));
e_wsle();
}
step_min__ = min(step_min__,t_step__);
step_max__ = max(step_max__,t_step__);
s_error__ += err_loc__;
x_error__ = max(x_error__,err_loc__);
if (nstep < 500) {
goto L100;
}
*iflag = 1;
L500:
iwsp[1] = nmult;
iwsp[2] = nexph;
iwsp[3] = nscale;
iwsp[4] = nstep;
iwsp[5] = nreject;
iwsp[6] = ibrkflag;
iwsp[7] = mbrkdwn;
q__1.r = step_min__, q__1.i = (float)0.;
wsp[1].r = q__1.r, wsp[1].i = q__1.i;
q__1.r = step_max__, q__1.i = (float)0.;
wsp[2].r = q__1.r, wsp[2].i = q__1.i;
wsp[3].r = (float)0., wsp[3].i = (float)0.;
wsp[4].r = (float)0., wsp[4].i = (float)0.;
q__1.r = x_error__, q__1.i = (float)0.;
wsp[5].r = q__1.r, wsp[5].i = q__1.i;
q__1.r = s_error__, q__1.i = (float)0.;
wsp[6].r = q__1.r, wsp[6].i = q__1.i;
q__1.r = tbrkdwn, q__1.i = (float)0.;
wsp[7].r = q__1.r, wsp[7].i = q__1.i;
d__1 = sgn * t_now__;
q__1.r = d__1, q__1.i = (float)0.;
wsp[8].r = q__1.r, wsp[8].i = q__1.i;
d__1 = hump / vnorm;
q__1.r = d__1, q__1.i = (float)0.;
wsp[9].r = q__1.r, wsp[9].i = q__1.i;
d__1 = beta / vnorm;
q__1.r = d__1, q__1.i = (float)0.;
wsp[10].r = q__1.r, wsp[10].i = q__1.i;
return 0;
} /* zgexpv_ */
/* Subroutine */ int zlatm1_(integer *mode, doublereal *cond, integer *irsign,
integer *idist, integer *iseed, doublecomplex *d__, integer *n,
integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1, z__2;
/* Local variables */
integer i__;
doublereal temp, alpha;
doublecomplex ctemp;
extern doublereal dlaran_(integer *);
extern /* Double Complex */ void zlarnd_(doublecomplex *, integer *,
integer *);
extern /* Subroutine */ int zlarnv_(integer *, integer *, integer *,
doublecomplex *);
/* -- LAPACK auxiliary test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLATM1 computes the entries of D(1..N) as specified by */
/* MODE, COND and IRSIGN. IDIST and ISEED determine the generation */
/* of random numbers. ZLATM1 is called by CLATMR to generate */
/* random test matrices for LAPACK programs. */
/* Arguments */
/* ========= */
/* MODE - INTEGER */
/* On entry describes how D is to be computed: */
/* MODE = 0 means do not change D. */
/* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */
/* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */
/* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */
/* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
/* MODE = 5 sets D to random numbers in the range */
/* ( 1/COND , 1 ) such that their logarithms */
/* are uniformly distributed. */
/* MODE = 6 set D to random numbers from same distribution */
/* as the rest of the matrix. */
/* MODE < 0 has the same meaning as ABS(MODE), except that */
/* the order of the elements of D is reversed. */
/* Thus if MODE is positive, D has entries ranging from */
/* 1 to 1/COND, if negative, from 1/COND to 1, */
/* Not modified. */
/* COND - DOUBLE PRECISION */
/* On entry, used as described under MODE above. */
/* If used, it must be >= 1. Not modified. */
/* IRSIGN - INTEGER */
/* On entry, if MODE neither -6, 0 nor 6, determines sign of */
/* entries of D */
/* 0 => leave entries of D unchanged */
/* 1 => multiply each entry of D by random complex number */
/* uniformly distributed with absolute value 1 */
/* IDIST - CHARACTER*1 */
/* 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, dimension ( 4 ) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The random number generator uses a */
/* linear congruential sequence limited to small */
/* integers, and so should produce machine independent */
/* random numbers. The values of ISEED are changed on */
/* exit, and can be used in the next call to ZLATM1 */
/* to continue the same random number sequence. */
/* Changed on exit. */
/* D - COMPLEX*16 array, dimension ( MIN( M , N ) ) */
/* Array to be computed according to MODE, COND and IRSIGN. */
/* May be changed on exit if MODE is nonzero. */
/* N - INTEGER */
/* Number of entries of D. Not modified. */
/* INFO - INTEGER */
/* 0 => normal termination */
/* -1 => if MODE not in range -6 to 6 */
/* -2 => if MODE neither -6, 0 nor 6, and */
/* IRSIGN neither 0 nor 1 */
/* -3 => if MODE neither -6, 0 nor 6 and COND less than 1 */
/* -4 => if MODE equals 6 or -6 and IDIST not in range 1 to 4 */
/* -7 => if N negative */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and Test the input parameters. Initialize flags & seed. */
/* Parameter adjustments */
--d__;
--iseed;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Set INFO if an error */
if (*mode < -6 || *mode > 6) {
*info = -1;
} else if (*mode != -6 && *mode != 0 && *mode != 6 && (*irsign != 0 && *
irsign != 1)) {
*info = -2;
} else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.) {
*info = -3;
} else if ((*mode == 6 || *mode == -6) && (*idist < 1 || *idist > 4)) {
*info = -4;
} else if (*n < 0) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZLATM1", &i__1);
return 0;
}
/* Compute D according to COND and MODE */
if (*mode != 0) {
switch (abs(*mode)) {
case 1: goto L10;
case 2: goto L30;
case 3: goto L50;
case 4: goto L70;
case 5: goto L90;
case 6: goto L110;
}
/* One large D value: */
L10:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
d__1 = 1. / *cond;
d__[i__2].r = d__1, d__[i__2].i = 0.;
/* L20: */
}
d__[1].r = 1., d__[1].i = 0.;
goto L120;
/* One small D value: */
L30:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
d__[i__2].r = 1., d__[i__2].i = 0.;
/* L40: */
}
i__1 = *n;
d__1 = 1. / *cond;
d__[i__1].r = d__1, d__[i__1].i = 0.;
goto L120;
/* Exponentially distributed D values: */
L50:
d__[1].r = 1., d__[1].i = 0.;
if (*n > 1) {
d__1 = -1. / (doublereal) (*n - 1);
alpha = pow_dd(cond, &d__1);
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__ - 1;
d__1 = pow_di(&alpha, &i__3);
d__[i__2].r = d__1, d__[i__2].i = 0.;
/* L60: */
}
}
goto L120;
/* Arithmetically distributed D values: */
L70:
d__[1].r = 1., d__[1].i = 0.;
if (*n > 1) {
temp = 1. / *cond;
alpha = (1. - temp) / (doublereal) (*n - 1);
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
i__2 = i__;
d__1 = (doublereal) (*n - i__) * alpha + temp;
d__[i__2].r = d__1, d__[i__2].i = 0.;
/* L80: */
}
}
goto L120;
/* Randomly distributed D values on ( 1/COND , 1): */
L90:
alpha = log(1. / *cond);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
d__1 = exp(alpha * dlaran_(&iseed[1]));
d__[i__2].r = d__1, d__[i__2].i = 0.;
/* L100: */
}
goto L120;
/* Randomly distributed D values from IDIST */
L110:
zlarnv_(idist, &iseed[1], n, &d__[1]);
L120:
/* If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign */
/* random signs to D */
if (*mode != -6 && *mode != 0 && *mode != 6 && *irsign == 1) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
zlarnd_(&z__1, &c__3, &iseed[1]);
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__2 = i__;
i__3 = i__;
d__1 = z_abs(&ctemp);
z__2.r = ctemp.r / d__1, z__2.i = ctemp.i / d__1;
z__1.r = d__[i__3].r * z__2.r - d__[i__3].i * z__2.i, z__1.i =
d__[i__3].r * z__2.i + d__[i__3].i * z__2.r;
d__[i__2].r = z__1.r, d__[i__2].i = z__1.i;
/* L130: */
}
}
/* Reverse if MODE < 0 */
if (*mode < 0) {
i__1 = *n / 2;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
ctemp.r = d__[i__2].r, ctemp.i = d__[i__2].i;
i__2 = i__;
i__3 = *n + 1 - i__;
d__[i__2].r = d__[i__3].r, d__[i__2].i = d__[i__3].i;
i__2 = *n + 1 - i__;
d__[i__2].r = ctemp.r, d__[i__2].i = ctemp.i;
/* L140: */
}
}
}
return 0;
/* End of ZLATM1 */
} /* zlatm1_ */
/* Subroutine */ int zlattr_(integer *imat, char *uplo, char *trans, char *
diag, integer *iseed, integer *n, doublecomplex *a, integer *lda,
doublecomplex *b, doublecomplex *work, doublereal *rwork, integer *
info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
doublecomplex z__1, z__2;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
double pow_dd(doublereal *, doublereal *), sqrt(doublereal);
void d_cnjg(doublecomplex *, doublecomplex *);
double z_abs(doublecomplex *);
/* Local variables */
doublereal c__;
integer i__, j;
doublecomplex s;
doublereal x, y, z__;
doublecomplex ra, rb;
integer kl, ku, iy;
doublereal ulp, sfac;
integer mode;
char path[3], dist[1];
doublereal unfl, rexp;
char type__[1];
doublereal texp;
extern /* Subroutine */ int zrot_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, doublecomplex *);
doublecomplex star1, plus1, plus2;
doublereal bscal;
extern logical lsame_(char *, char *);
doublereal tscal, anorm, bnorm, tleft;
logical upper;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zrotg_(doublecomplex *,
doublecomplex *, doublereal *, doublecomplex *), zswap_(integer *,
doublecomplex *, integer *, doublecomplex *, integer *), zlatb4_(
char *, integer *, integer *, integer *, char *, integer *,
integer *, doublereal *, integer *, doublereal *, char *), dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *), dlarnd_(integer *, integer *);
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *);
doublereal bignum, cndnum;
extern /* Subroutine */ int dlarnv_(integer *, integer *, integer *,
doublereal *);
extern integer izamax_(integer *, doublecomplex *, integer *);
extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
integer *);
integer jcount;
extern /* Subroutine */ int zlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublecomplex *, integer *,
doublecomplex *, integer *);
doublereal smlnum;
extern /* Subroutine */ int zlarnv_(integer *, integer *, integer *,
doublecomplex *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLATTR generates a triangular test matrix in 2-dimensional storage. */
/* IMAT and UPLO uniquely specify the properties of the test matrix, */
/* which is returned in the array A. */
/* Arguments */
/* ========= */
/* IMAT (input) INTEGER */
/* An integer key describing which matrix to generate for this */
/* path. */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A will be upper or lower */
/* triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* TRANS (input) CHARACTER*1 */
/* Specifies whether the matrix or its transpose will be used. */
/* = 'N': No transpose */
/* = 'T': Transpose */
/* = 'C': Conjugate transpose */
/* DIAG (output) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* The seed vector for the random number generator (used in */
/* ZLATMS). Modified on exit. */
/* N (input) INTEGER */
/* The order of the matrix to be generated. */
/* A (output) COMPLEX*16 array, dimension (LDA,N) */
/* The triangular matrix A. If UPLO = 'U', the leading N x 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 x N lower */
/* triangular part of the array A contains the lower triangular */
/* matrix and the strictly upper triangular part of A is not */
/* referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (output) COMPLEX*16 array, dimension (N) */
/* The right hand side vector, if IMAT > 10. */
/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--iseed;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--b;
--work;
--rwork;
/* Function Body */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "TR", (ftnlen)2, (ftnlen)2);
unfl = dlamch_("Safe minimum");
ulp = dlamch_("Epsilon") * dlamch_("Base");
smlnum = unfl;
bignum = (1. - ulp) / smlnum;
dlabad_(&smlnum, &bignum);
if (*imat >= 7 && *imat <= 10 || *imat == 18) {
*(unsigned char *)diag = 'U';
} else {
*(unsigned char *)diag = 'N';
}
*info = 0;
/* Quick return if N.LE.0. */
if (*n <= 0) {
return 0;
}
/* Call ZLATB4 to set parameters for CLATMS. */
upper = lsame_(uplo, "U");
if (upper) {
zlatb4_(path, imat, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
dist);
} else {
i__1 = -(*imat);
zlatb4_(path, &i__1, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
dist);
}
/* IMAT <= 6: Non-unit triangular matrix */
if (*imat <= 6) {
zlatms_(n, n, dist, &iseed[1], type__, &rwork[1], &mode, &cndnum, &
anorm, &kl, &ku, "No packing", &a[a_offset], lda, &work[1],
info);
/* IMAT > 6: Unit triangular matrix */
/* The diagonal is deliberately set to something other than 1. */
/* IMAT = 7: Matrix is the identity */
} else if (*imat == 7) {
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L10: */
}
i__2 = j + j * a_dim1;
a[i__2].r = (doublereal) j, a[i__2].i = 0.;
/* L20: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j + j * a_dim1;
a[i__2].r = (doublereal) j, a[i__2].i = 0.;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L30: */
}
/* L40: */
}
}
/* IMAT > 7: Non-trivial unit triangular matrix */
/* Generate a unit triangular matrix T with condition CNDNUM by */
/* forming a triangular matrix with known singular values and */
/* filling in the zero entries with Givens rotations. */
} else if (*imat <= 10) {
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L50: */
}
i__2 = j + j * a_dim1;
a[i__2].r = (doublereal) j, a[i__2].i = 0.;
/* L60: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j + j * a_dim1;
a[i__2].r = (doublereal) j, a[i__2].i = 0.;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L70: */
}
/* L80: */
}
}
/* Since the trace of a unit triangular matrix is 1, the product */
/* of its singular values must be 1. Let s = sqrt(CNDNUM), */
/* x = sqrt(s) - 1/sqrt(s), y = sqrt(2/(n-2))*x, and z = x**2. */
/* The following triangular matrix has singular values s, 1, 1, */
/* ..., 1, 1/s: */
/* 1 y y y ... y y z */
/* 1 0 0 ... 0 0 y */
/* 1 0 ... 0 0 y */
/* . ... . . . */
/* . . . . */
/* 1 0 y */
/* 1 y */
/* 1 */
/* To fill in the zeros, we first multiply by a matrix with small */
/* condition number of the form */
/* 1 0 0 0 0 ... */
/* 1 + * 0 0 ... */
/* 1 + 0 0 0 */
/* 1 + * 0 0 */
/* 1 + 0 0 */
/* ... */
/* 1 + 0 */
/* 1 0 */
/* 1 */
/* Each element marked with a '*' is formed by taking the product */
/* of the adjacent elements marked with '+'. The '*'s can be */
/* chosen freely, and the '+'s are chosen so that the inverse of */
/* T will have elements of the same magnitude as T. If the *'s in */
/* both T and inv(T) have small magnitude, T is well conditioned. */
/* The two offdiagonals of T are stored in WORK. */
/* The product of these two matrices has the form */
/* 1 y y y y y . y y z */
/* 1 + * 0 0 . 0 0 y */
/* 1 + 0 0 . 0 0 y */
/* 1 + * . . . . */
/* 1 + . . . . */
/* . . . . . */
/* . . . . */
/* 1 + y */
/* 1 y */
/* 1 */
/* Now we multiply by Givens rotations, using the fact that */
/* [ c s ] [ 1 w ] [ -c -s ] = [ 1 -w ] */
/* [ -s c ] [ 0 1 ] [ s -c ] [ 0 1 ] */
/* and */
/* [ -c -s ] [ 1 0 ] [ c s ] = [ 1 0 ] */
/* [ s -c ] [ w 1 ] [ -s c ] [ -w 1 ] */
/* where c = w / sqrt(w**2+4) and s = 2 / sqrt(w**2+4). */
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = z__2.r * .25, z__1.i = z__2.i * .25;
star1.r = z__1.r, star1.i = z__1.i;
sfac = .5;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = sfac * z__2.r, z__1.i = sfac * z__2.i;
plus1.r = z__1.r, plus1.i = z__1.i;
i__1 = *n;
for (j = 1; j <= i__1; j += 2) {
z_div(&z__1, &star1, &plus1);
plus2.r = z__1.r, plus2.i = z__1.i;
i__2 = j;
work[i__2].r = plus1.r, work[i__2].i = plus1.i;
i__2 = *n + j;
work[i__2].r = star1.r, work[i__2].i = star1.i;
if (j + 1 <= *n) {
i__2 = j + 1;
work[i__2].r = plus2.r, work[i__2].i = plus2.i;
i__2 = *n + j + 1;
work[i__2].r = 0., work[i__2].i = 0.;
z_div(&z__1, &star1, &plus2);
plus1.r = z__1.r, plus1.i = z__1.i;
rexp = dlarnd_(&c__2, &iseed[1]);
if (rexp < 0.) {
d__2 = 1. - rexp;
d__1 = -pow_dd(&sfac, &d__2);
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
star1.r = z__1.r, star1.i = z__1.i;
} else {
d__2 = rexp + 1.;
d__1 = pow_dd(&sfac, &d__2);
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
star1.r = z__1.r, star1.i = z__1.i;
}
}
/* L90: */
}
x = sqrt(cndnum) - 1 / sqrt(cndnum);
if (*n > 2) {
y = sqrt(2. / (*n - 2)) * x;
} else {
y = 0.;
}
z__ = x * x;
if (upper) {
if (*n > 3) {
i__1 = *n - 3;
i__2 = *lda + 1;
zcopy_(&i__1, &work[1], &c__1, &a[a_dim1 * 3 + 2], &i__2);
if (*n > 4) {
i__1 = *n - 4;
i__2 = *lda + 1;
zcopy_(&i__1, &work[*n + 1], &c__1, &a[(a_dim1 << 2) + 2],
&i__2);
}
}
i__1 = *n - 1;
for (j = 2; j <= i__1; ++j) {
i__2 = j * a_dim1 + 1;
a[i__2].r = y, a[i__2].i = 0.;
i__2 = j + *n * a_dim1;
a[i__2].r = y, a[i__2].i = 0.;
/* L100: */
}
i__1 = *n * a_dim1 + 1;
a[i__1].r = z__, a[i__1].i = 0.;
} else {
if (*n > 3) {
i__1 = *n - 3;
i__2 = *lda + 1;
zcopy_(&i__1, &work[1], &c__1, &a[(a_dim1 << 1) + 3], &i__2);
if (*n > 4) {
i__1 = *n - 4;
i__2 = *lda + 1;
zcopy_(&i__1, &work[*n + 1], &c__1, &a[(a_dim1 << 1) + 4],
&i__2);
}
}
i__1 = *n - 1;
for (j = 2; j <= i__1; ++j) {
i__2 = j + a_dim1;
a[i__2].r = y, a[i__2].i = 0.;
i__2 = *n + j * a_dim1;
a[i__2].r = y, a[i__2].i = 0.;
/* L110: */
}
i__1 = *n + a_dim1;
a[i__1].r = z__, a[i__1].i = 0.;
}
/* Fill in the zeros using Givens rotations. */
if (upper) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = j + (j + 1) * a_dim1;
ra.r = a[i__2].r, ra.i = a[i__2].i;
rb.r = 2., rb.i = 0.;
zrotg_(&ra, &rb, &c__, &s);
/* Multiply by [ c s; -conjg(s) c] on the left. */
if (*n > j + 1) {
i__2 = *n - j - 1;
zrot_(&i__2, &a[j + (j + 2) * a_dim1], lda, &a[j + 1 + (j
+ 2) * a_dim1], lda, &c__, &s);
}
/* Multiply by [-c -s; conjg(s) -c] on the right. */
if (j > 1) {
i__2 = j - 1;
d__1 = -c__;
z__1.r = -s.r, z__1.i = -s.i;
zrot_(&i__2, &a[(j + 1) * a_dim1 + 1], &c__1, &a[j *
a_dim1 + 1], &c__1, &d__1, &z__1);
}
/* Negate A(J,J+1). */
i__2 = j + (j + 1) * a_dim1;
i__3 = j + (j + 1) * a_dim1;
z__1.r = -a[i__3].r, z__1.i = -a[i__3].i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L120: */
}
} else {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = j + 1 + j * a_dim1;
ra.r = a[i__2].r, ra.i = a[i__2].i;
rb.r = 2., rb.i = 0.;
zrotg_(&ra, &rb, &c__, &s);
d_cnjg(&z__1, &s);
s.r = z__1.r, s.i = z__1.i;
/* Multiply by [ c -s; conjg(s) c] on the right. */
if (*n > j + 1) {
i__2 = *n - j - 1;
z__1.r = -s.r, z__1.i = -s.i;
zrot_(&i__2, &a[j + 2 + (j + 1) * a_dim1], &c__1, &a[j +
2 + j * a_dim1], &c__1, &c__, &z__1);
}
/* Multiply by [-c s; -conjg(s) -c] on the left. */
if (j > 1) {
i__2 = j - 1;
d__1 = -c__;
zrot_(&i__2, &a[j + a_dim1], lda, &a[j + 1 + a_dim1], lda,
&d__1, &s);
}
/* Negate A(J+1,J). */
i__2 = j + 1 + j * a_dim1;
i__3 = j + 1 + j * a_dim1;
z__1.r = -a[i__3].r, z__1.i = -a[i__3].i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L130: */
}
}
/* IMAT > 10: Pathological test cases. These triangular matrices */
/* are badly scaled or badly conditioned, so when used in solving a */
/* triangular system they may cause overflow in the solution vector. */
} else if (*imat == 11) {
/* Type 11: Generate a triangular matrix with elements between */
/* -1 and 1. Give the diagonal norm 2 to make it well-conditioned. */
/* Make the right hand side large so that it requires scaling. */
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
zlarnv_(&c__4, &iseed[1], &i__2, &a[j * a_dim1 + 1]);
i__2 = j + j * a_dim1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = z__2.r * 2., z__1.i = z__2.i * 2.;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L140: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (j < *n) {
i__2 = *n - j;
zlarnv_(&c__4, &iseed[1], &i__2, &a[j + 1 + j * a_dim1]);
}
i__2 = j + j * a_dim1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = z__2.r * 2., z__1.i = z__2.i * 2.;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L150: */
}
}
/* Set the right hand side so that the largest value is BIGNUM. */
zlarnv_(&c__2, &iseed[1], n, &b[1]);
iy = izamax_(n, &b[1], &c__1);
bnorm = z_abs(&b[iy]);
bscal = bignum / max(1.,bnorm);
zdscal_(n, &bscal, &b[1], &c__1);
} else if (*imat == 12) {
/* Type 12: Make the first diagonal element in the solve small to */
/* cause immediate overflow when dividing by T(j,j). */
/* In type 12, the offdiagonal elements are small (CNORM(j) < 1). */
zlarnv_(&c__2, &iseed[1], n, &b[1]);
/* Computing MAX */
d__1 = 1., d__2 = (doublereal) (*n - 1);
tscal = 1. / max(d__1,d__2);
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
zlarnv_(&c__4, &iseed[1], &i__2, &a[j * a_dim1 + 1]);
i__2 = j - 1;
zdscal_(&i__2, &tscal, &a[j * a_dim1 + 1], &c__1);
i__2 = j + j * a_dim1;
zlarnd_(&z__1, &c__5, &iseed[1]);
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L160: */
}
i__1 = *n + *n * a_dim1;
i__2 = *n + *n * a_dim1;
z__1.r = smlnum * a[i__2].r, z__1.i = smlnum * a[i__2].i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (j < *n) {
i__2 = *n - j;
zlarnv_(&c__4, &iseed[1], &i__2, &a[j + 1 + j * a_dim1]);
i__2 = *n - j;
zdscal_(&i__2, &tscal, &a[j + 1 + j * a_dim1], &c__1);
}
i__2 = j + j * a_dim1;
zlarnd_(&z__1, &c__5, &iseed[1]);
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L170: */
}
i__1 = a_dim1 + 1;
i__2 = a_dim1 + 1;
z__1.r = smlnum * a[i__2].r, z__1.i = smlnum * a[i__2].i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
}
} else if (*imat == 13) {
/* Type 13: Make the first diagonal element in the solve small to */
/* cause immediate overflow when dividing by T(j,j). */
/* In type 13, the offdiagonal elements are O(1) (CNORM(j) > 1). */
zlarnv_(&c__2, &iseed[1], n, &b[1]);
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
zlarnv_(&c__4, &iseed[1], &i__2, &a[j * a_dim1 + 1]);
i__2 = j + j * a_dim1;
zlarnd_(&z__1, &c__5, &iseed[1]);
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L180: */
}
i__1 = *n + *n * a_dim1;
i__2 = *n + *n * a_dim1;
z__1.r = smlnum * a[i__2].r, z__1.i = smlnum * a[i__2].i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (j < *n) {
i__2 = *n - j;
zlarnv_(&c__4, &iseed[1], &i__2, &a[j + 1 + j * a_dim1]);
}
i__2 = j + j * a_dim1;
zlarnd_(&z__1, &c__5, &iseed[1]);
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L190: */
}
i__1 = a_dim1 + 1;
i__2 = a_dim1 + 1;
z__1.r = smlnum * a[i__2].r, z__1.i = smlnum * a[i__2].i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
}
} else if (*imat == 14) {
/* Type 14: T is diagonal with small numbers on the diagonal to */
/* make the growth factor underflow, but a small right hand side */
/* chosen so that the solution does not overflow. */
if (upper) {
jcount = 1;
for (j = *n; j >= 1; --j) {
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + j * a_dim1;
a[i__2].r = 0., a[i__2].i = 0.;
/* L200: */
}
if (jcount <= 2) {
i__1 = j + j * a_dim1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = smlnum * z__2.r, z__1.i = smlnum * z__2.i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
} else {
i__1 = j + j * a_dim1;
zlarnd_(&z__1, &c__5, &iseed[1]);
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
}
++jcount;
if (jcount > 4) {
jcount = 1;
}
/* L210: */
}
} else {
jcount = 1;
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., a[i__3].i = 0.;
/* L220: */
}
if (jcount <= 2) {
i__2 = j + j * a_dim1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = smlnum * z__2.r, z__1.i = smlnum * z__2.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
} else {
i__2 = j + j * a_dim1;
zlarnd_(&z__1, &c__5, &iseed[1]);
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
++jcount;
if (jcount > 4) {
jcount = 1;
}
/* L230: */
}
}
/* Set the right hand side alternately zero and small. */
if (upper) {
b[1].r = 0., b[1].i = 0.;
for (i__ = *n; i__ >= 2; i__ += -2) {
i__1 = i__;
b[i__1].r = 0., b[i__1].i = 0.;
i__1 = i__ - 1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = smlnum * z__2.r, z__1.i = smlnum * z__2.i;
b[i__1].r = z__1.r, b[i__1].i = z__1.i;
/* L240: */
}
} else {
i__1 = *n;
b[i__1].r = 0., b[i__1].i = 0.;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; i__ += 2) {
i__2 = i__;
b[i__2].r = 0., b[i__2].i = 0.;
i__2 = i__ + 1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = smlnum * z__2.r, z__1.i = smlnum * z__2.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
/* L250: */
}
}
} else if (*imat == 15) {
/* Type 15: Make the diagonal elements small to cause gradual */
/* overflow when dividing by T(j,j). To control the amount of */
/* scaling needed, the matrix is bidiagonal. */
/* Computing MAX */
d__1 = 1., d__2 = (doublereal) (*n - 1);
texp = 1. / max(d__1,d__2);
tscal = pow_dd(&smlnum, &texp);
zlarnv_(&c__4, &iseed[1], n, &b[1]);
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 2;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L260: */
}
if (j > 1) {
i__2 = j - 1 + j * a_dim1;
a[i__2].r = -1., a[i__2].i = -1.;
}
i__2 = j + j * a_dim1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L270: */
}
i__1 = *n;
b[i__1].r = 1., b[i__1].i = 1.;
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 2; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L280: */
}
if (j < *n) {
i__2 = j + 1 + j * a_dim1;
a[i__2].r = -1., a[i__2].i = -1.;
}
i__2 = j + j * a_dim1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L290: */
}
b[1].r = 1., b[1].i = 1.;
}
} else if (*imat == 16) {
/* Type 16: One zero diagonal element. */
iy = *n / 2 + 1;
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
zlarnv_(&c__4, &iseed[1], &i__2, &a[j * a_dim1 + 1]);
if (j != iy) {
i__2 = j + j * a_dim1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = z__2.r * 2., z__1.i = z__2.i * 2.;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
} else {
i__2 = j + j * a_dim1;
a[i__2].r = 0., a[i__2].i = 0.;
}
/* L300: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (j < *n) {
i__2 = *n - j;
zlarnv_(&c__4, &iseed[1], &i__2, &a[j + 1 + j * a_dim1]);
}
if (j != iy) {
i__2 = j + j * a_dim1;
zlarnd_(&z__2, &c__5, &iseed[1]);
z__1.r = z__2.r * 2., z__1.i = z__2.i * 2.;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
} else {
i__2 = j + j * a_dim1;
a[i__2].r = 0., a[i__2].i = 0.;
}
/* L310: */
}
}
zlarnv_(&c__2, &iseed[1], n, &b[1]);
zdscal_(n, &c_b92, &b[1], &c__1);
} else if (*imat == 17) {
/* Type 17: Make the offdiagonal elements large to cause overflow */
/* when adding a column of T. In the non-transposed case, the */
/* matrix is constructed to cause overflow when adding a column in */
/* every other step. */
tscal = unfl / ulp;
tscal = (1. - ulp) / tscal;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L320: */
}
/* L330: */
}
texp = 1.;
if (upper) {
for (j = *n; j >= 2; j += -2) {
i__1 = j * a_dim1 + 1;
d__1 = -tscal / (doublereal) (*n + 1);
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = j + j * a_dim1;
a[i__1].r = 1., a[i__1].i = 0.;
i__1 = j;
d__1 = texp * (1. - ulp);
b[i__1].r = d__1, b[i__1].i = 0.;
i__1 = (j - 1) * a_dim1 + 1;
d__1 = -(tscal / (doublereal) (*n + 1)) / (doublereal) (*n +
2);
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = j - 1 + (j - 1) * a_dim1;
a[i__1].r = 1., a[i__1].i = 0.;
i__1 = j - 1;
d__1 = texp * (doublereal) (*n * *n + *n - 1);
b[i__1].r = d__1, b[i__1].i = 0.;
texp *= 2.;
/* L340: */
}
d__1 = (doublereal) (*n + 1) / (doublereal) (*n + 2) * tscal;
b[1].r = d__1, b[1].i = 0.;
} else {
i__1 = *n - 1;
for (j = 1; j <= i__1; j += 2) {
i__2 = *n + j * a_dim1;
d__1 = -tscal / (doublereal) (*n + 1);
a[i__2].r = d__1, a[i__2].i = 0.;
i__2 = j + j * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
i__2 = j;
d__1 = texp * (1. - ulp);
b[i__2].r = d__1, b[i__2].i = 0.;
i__2 = *n + (j + 1) * a_dim1;
d__1 = -(tscal / (doublereal) (*n + 1)) / (doublereal) (*n +
2);
a[i__2].r = d__1, a[i__2].i = 0.;
i__2 = j + 1 + (j + 1) * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
i__2 = j + 1;
d__1 = texp * (doublereal) (*n * *n + *n - 1);
b[i__2].r = d__1, b[i__2].i = 0.;
texp *= 2.;
/* L350: */
}
i__1 = *n;
d__1 = (doublereal) (*n + 1) / (doublereal) (*n + 2) * tscal;
b[i__1].r = d__1, b[i__1].i = 0.;
}
} else if (*imat == 18) {
/* Type 18: Generate a unit triangular matrix with elements */
/* between -1 and 1, and make the right hand side large so that it */
/* requires scaling. */
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
zlarnv_(&c__4, &iseed[1], &i__2, &a[j * a_dim1 + 1]);
i__2 = j + j * a_dim1;
a[i__2].r = 0., a[i__2].i = 0.;
/* L360: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (j < *n) {
i__2 = *n - j;
zlarnv_(&c__4, &iseed[1], &i__2, &a[j + 1 + j * a_dim1]);
}
i__2 = j + j * a_dim1;
a[i__2].r = 0., a[i__2].i = 0.;
/* L370: */
}
}
/* Set the right hand side so that the largest value is BIGNUM. */
zlarnv_(&c__2, &iseed[1], n, &b[1]);
iy = izamax_(n, &b[1], &c__1);
bnorm = z_abs(&b[iy]);
bscal = bignum / max(1.,bnorm);
zdscal_(n, &bscal, &b[1], &c__1);
} else if (*imat == 19) {
/* Type 19: Generate a triangular matrix with elements between */
/* BIGNUM/(n-1) and BIGNUM so that at least one of the column */
/* norms will exceed BIGNUM. */
/* 1/3/91: ZLATRS no longer can handle this case */
/* Computing MAX */
d__1 = 1., d__2 = (doublereal) (*n - 1);
tleft = bignum / max(d__1,d__2);
/* Computing MAX */
d__1 = 1., d__2 = (doublereal) (*n);
tscal = bignum * ((doublereal) (*n - 1) / max(d__1,d__2));
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
zlarnv_(&c__5, &iseed[1], &j, &a[j * a_dim1 + 1]);
dlarnv_(&c__1, &iseed[1], &j, &rwork[1]);
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
d__1 = tleft + rwork[i__] * tscal;
z__1.r = d__1 * a[i__4].r, z__1.i = d__1 * a[i__4].i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L380: */
}
/* L390: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j + 1;
zlarnv_(&c__5, &iseed[1], &i__2, &a[j + j * a_dim1]);
i__2 = *n - j + 1;
dlarnv_(&c__1, &iseed[1], &i__2, &rwork[1]);
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
d__1 = tleft + rwork[i__ - j + 1] * tscal;
z__1.r = d__1 * a[i__4].r, z__1.i = d__1 * a[i__4].i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L400: */
}
/* L410: */
}
}
zlarnv_(&c__2, &iseed[1], n, &b[1]);
zdscal_(n, &c_b92, &b[1], &c__1);
}
/* Flip the matrix if the transpose will be used. */
if (! lsame_(trans, "N")) {
if (upper) {
i__1 = *n / 2;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - (j << 1) + 1;
zswap_(&i__2, &a[j + j * a_dim1], lda, &a[j + 1 + (*n - j + 1)
* a_dim1], &c_n1);
/* L420: */
}
} else {
i__1 = *n / 2;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - (j << 1) + 1;
i__3 = -(*lda);
zswap_(&i__2, &a[j + j * a_dim1], &c__1, &a[*n - j + 1 + (j +
1) * a_dim1], &i__3);
/* L430: */
}
}
}
return 0;
/* End of ZLATTR */
} /* zlattr_ */
/* Subroutine */ int dsaup2_(integer *ido, char *bmat, integer *n, char *
which, integer *nev, integer *np, doublereal *tol, doublereal *resid,
integer *mode, integer *iupd, integer *ishift, integer *mxiter,
doublereal *v, integer *ldv, doublereal *h__, integer *ldh,
doublereal *ritz, doublereal *bounds, doublereal *q, integer *ldq,
doublereal *workl, integer *ipntr, doublereal *workd, integer *info,
ftnlen bmat_len, ftnlen which_len)
{
/* System generated locals */
integer h_dim1, h_offset, q_dim1, q_offset, v_dim1, v_offset, i__1, i__2,
i__3;
doublereal d__1, d__2, d__3;
/* Local variables */
static integer j;
static real t0, t1, t2, t3;
static integer kp[3], np0, nev0;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static doublereal eps23;
static integer ierr, iter;
static doublereal temp;
static integer nevd2;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static logical getv0;
static integer nevm2;
static logical cnorm;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
static integer nconv;
static logical initv;
static doublereal rnorm;
extern /* Subroutine */ int dvout_(integer *, integer *, doublereal *,
integer *, char *, ftnlen), ivout_(integer *, integer *, integer *
, integer *, char *, ftnlen), dgetv0_(integer *, char *, integer *
, logical *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
ftnlen);
extern doublereal dlamch_(char *, ftnlen);
static integer nevbef;
extern /* Subroutine */ int arscnd_(real *);
static logical update;
static char wprime[2];
static logical ushift;
static integer kplusp, msglvl, nptemp;
extern /* Subroutine */ int dsaitr_(integer *, char *, integer *, integer
*, integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, doublereal *,
integer *, ftnlen), dsconv_(integer *, doublereal *, doublereal *,
doublereal *, integer *), dseigt_(doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *), dsgets_(integer *, char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, ftnlen), dsapps_(
integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *), dsortr_(char *, logical *, integer *,
doublereal *, doublereal *, ftnlen);
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %---------------% */
/* | Local Scalars | */
/* %---------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %---------------------% */
/* | Intrinsic Functions | */
/* %---------------------% */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
/* Parameter adjustments */
--workd;
--resid;
--workl;
--bounds;
--ritz;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--ipntr;
/* Function Body */
if (*ido == 0) {
/* %-------------------------------% */
/* | Initialize timing statistics | */
/* | & message level for debugging | */
/* %-------------------------------% */
arscnd_(&t0);
msglvl = debug_1.msaup2;
/* %---------------------------------% */
/* | Set machine dependent constant. | */
/* %---------------------------------% */
eps23 = dlamch_("Epsilon-Machine", (ftnlen)15);
eps23 = pow_dd(&eps23, &c_b3);
/* %-------------------------------------% */
/* | nev0 and np0 are integer variables | */
/* | hold the initial values of NEV & NP | */
/* %-------------------------------------% */
nev0 = *nev;
np0 = *np;
/* %-------------------------------------% */
/* | kplusp is the bound on the largest | */
/* | Lanczos factorization built. | */
/* | nconv is the current number of | */
/* | "converged" eigenvlues. | */
/* | iter is the counter on the current | */
/* | iteration step. | */
/* %-------------------------------------% */
kplusp = nev0 + np0;
nconv = 0;
iter = 0;
/* %--------------------------------------------% */
/* | Set flags for computing the first NEV steps | */
/* | of the Lanczos factorization. | */
/* %--------------------------------------------% */
getv0 = TRUE_;
update = FALSE_;
ushift = FALSE_;
cnorm = FALSE_;
if (*info != 0) {
/* %--------------------------------------------% */
/* | User provides the initial residual vector. | */
/* %--------------------------------------------% */
initv = TRUE_;
*info = 0;
} else {
initv = FALSE_;
}
}
/* %---------------------------------------------% */
/* | Get a possibly random starting vector and | */
/* | force it into the range of the operator OP. | */
/* %---------------------------------------------% */
/* L10: */
if (getv0) {
dgetv0_(ido, bmat, &c__1, &initv, n, &c__1, &v[v_offset], ldv, &resid[
1], &rnorm, &ipntr[1], &workd[1], info, (ftnlen)1);
if (*ido != 99) {
goto L9000;
}
if (rnorm == 0.) {
/* %-----------------------------------------% */
/* | The initial vector is zero. Error exit. | */
/* %-----------------------------------------% */
*info = -9;
goto L1200;
}
getv0 = FALSE_;
*ido = 0;
}
/* %------------------------------------------------------------% */
/* | Back from reverse communication: continue with update step | */
/* %------------------------------------------------------------% */
if (update) {
goto L20;
}
/* %-------------------------------------------% */
/* | Back from computing user specified shifts | */
/* %-------------------------------------------% */
if (ushift) {
goto L50;
}
/* %-------------------------------------% */
/* | Back from computing residual norm | */
/* | at the end of the current iteration | */
/* %-------------------------------------% */
if (cnorm) {
goto L100;
}
/* %----------------------------------------------------------% */
/* | Compute the first NEV steps of the Lanczos factorization | */
/* %----------------------------------------------------------% */
dsaitr_(ido, bmat, n, &c__0, &nev0, mode, &resid[1], &rnorm, &v[v_offset],
ldv, &h__[h_offset], ldh, &ipntr[1], &workd[1], info, (ftnlen)1);
/* %---------------------------------------------------% */
/* | ido .ne. 99 implies use of reverse communication | */
/* | to compute operations involving OP and possibly B | */
/* %---------------------------------------------------% */
if (*ido != 99) {
goto L9000;
}
if (*info > 0) {
/* %-----------------------------------------------------% */
/* | dsaitr was unable to build an Lanczos factorization | */
/* | of length NEV0. INFO is returned with the size of | */
/* | the factorization built. Exit main loop. | */
/* %-----------------------------------------------------% */
*np = *info;
*mxiter = iter;
*info = -9999;
goto L1200;
}
/* %--------------------------------------------------------------% */
/* | | */
/* | M A I N LANCZOS I T E R A T I O N L O O P | */
/* | Each iteration implicitly restarts the Lanczos | */
/* | factorization in place. | */
/* | | */
/* %--------------------------------------------------------------% */
L1000:
++iter;
if (msglvl > 0) {
ivout_(&debug_1.logfil, &c__1, &iter, &debug_1.ndigit, "_saup2: ****"
" Start of major iteration number ****", (ftnlen)49);
}
if (msglvl > 1) {
ivout_(&debug_1.logfil, &c__1, nev, &debug_1.ndigit, "_saup2: The le"
"ngth of the current Lanczos factorization", (ftnlen)55);
ivout_(&debug_1.logfil, &c__1, np, &debug_1.ndigit, "_saup2: Extend "
"the Lanczos factorization by", (ftnlen)43);
}
/* %------------------------------------------------------------% */
/* | Compute NP additional steps of the Lanczos factorization. | */
/* %------------------------------------------------------------% */
*ido = 0;
L20:
update = TRUE_;
dsaitr_(ido, bmat, n, nev, np, mode, &resid[1], &rnorm, &v[v_offset], ldv,
&h__[h_offset], ldh, &ipntr[1], &workd[1], info, (ftnlen)1);
/* %---------------------------------------------------% */
/* | ido .ne. 99 implies use of reverse communication | */
/* | to compute operations involving OP and possibly B | */
/* %---------------------------------------------------% */
if (*ido != 99) {
goto L9000;
}
if (*info > 0) {
/* %-----------------------------------------------------% */
/* | dsaitr was unable to build an Lanczos factorization | */
/* | of length NEV0+NP0. INFO is returned with the size | */
/* | of the factorization built. Exit main loop. | */
/* %-----------------------------------------------------% */
*np = *info;
*mxiter = iter;
*info = -9999;
goto L1200;
}
update = FALSE_;
if (msglvl > 1) {
dvout_(&debug_1.logfil, &c__1, &rnorm, &debug_1.ndigit, "_saup2: Cur"
"rent B-norm of residual for factorization", (ftnlen)52);
}
/* %--------------------------------------------------------% */
/* | Compute the eigenvalues and corresponding error bounds | */
/* | of the current symmetric tridiagonal matrix. | */
/* %--------------------------------------------------------% */
dseigt_(&rnorm, &kplusp, &h__[h_offset], ldh, &ritz[1], &bounds[1], &
workl[1], &ierr);
if (ierr != 0) {
*info = -8;
goto L1200;
}
/* %----------------------------------------------------% */
/* | Make a copy of eigenvalues and corresponding error | */
/* | bounds obtained from _seigt. | */
/* %----------------------------------------------------% */
dcopy_(&kplusp, &ritz[1], &c__1, &workl[kplusp + 1], &c__1);
dcopy_(&kplusp, &bounds[1], &c__1, &workl[(kplusp << 1) + 1], &c__1);
/* %---------------------------------------------------% */
/* | Select the wanted Ritz values and their bounds | */
/* | to be used in the convergence test. | */
/* | The selection is based on the requested number of | */
/* | eigenvalues instead of the current NEV and NP to | */
/* | prevent possible misconvergence. | */
/* | * Wanted Ritz values := RITZ(NP+1:NEV+NP) | */
/* | * Shifts := RITZ(1:NP) := WORKL(1:NP) | */
/* %---------------------------------------------------% */
*nev = nev0;
*np = np0;
dsgets_(ishift, which, nev, np, &ritz[1], &bounds[1], &workl[1], (ftnlen)
2);
/* %-------------------% */
/* | Convergence test. | */
/* %-------------------% */
dcopy_(nev, &bounds[*np + 1], &c__1, &workl[*np + 1], &c__1);
dsconv_(nev, &ritz[*np + 1], &workl[*np + 1], tol, &nconv);
if (msglvl > 2) {
kp[0] = *nev;
kp[1] = *np;
kp[2] = nconv;
ivout_(&debug_1.logfil, &c__3, kp, &debug_1.ndigit, "_saup2: NEV, NP"
", NCONV are", (ftnlen)26);
dvout_(&debug_1.logfil, &kplusp, &ritz[1], &debug_1.ndigit, "_saup2:"
" The eigenvalues of H", (ftnlen)28);
dvout_(&debug_1.logfil, &kplusp, &bounds[1], &debug_1.ndigit, "_saup"
"2: Ritz estimates of the current NCV Ritz values", (ftnlen)53)
;
}
/* %---------------------------------------------------------% */
/* | Count the number of unwanted Ritz values that have zero | */
/* | Ritz estimates. If any Ritz estimates are equal to zero | */
/* | then a leading block of H of order equal to at least | */
/* | the number of Ritz values with zero Ritz estimates has | */
/* | split off. None of these Ritz values may be removed by | */
/* | shifting. Decrease NP the number of shifts to apply. If | */
/* | no shifts may be applied, then prepare to exit | */
/* %---------------------------------------------------------% */
nptemp = *np;
i__1 = nptemp;
for (j = 1; j <= i__1; ++j) {
if (bounds[j] == 0.) {
--(*np);
++(*nev);
}
/* L30: */
}
if (nconv >= nev0 || iter > *mxiter || *np == 0) {
/* %------------------------------------------------% */
/* | Prepare to exit. Put the converged Ritz values | */
/* | and corresponding bounds in RITZ(1:NCONV) and | */
/* | BOUNDS(1:NCONV) respectively. Then sort. Be | */
/* | careful when NCONV > NP since we don't want to | */
/* | swap overlapping locations. | */
/* %------------------------------------------------% */
if (s_cmp(which, "BE", (ftnlen)2, (ftnlen)2) == 0) {
/* %-----------------------------------------------------% */
/* | Both ends of the spectrum are requested. | */
/* | Sort the eigenvalues into algebraically decreasing | */
/* | order first then swap low end of the spectrum next | */
/* | to high end in appropriate locations. | */
/* | NOTE: when np < floor(nev/2) be careful not to swap | */
/* | overlapping locations. | */
/* %-----------------------------------------------------% */
s_copy(wprime, "SA", (ftnlen)2, (ftnlen)2);
dsortr_(wprime, &c_true, &kplusp, &ritz[1], &bounds[1], (ftnlen)2)
;
nevd2 = nev0 / 2;
nevm2 = nev0 - nevd2;
if (*nev > 1) {
i__1 = min(nevd2,*np);
/* Computing MAX */
i__2 = kplusp - nevd2 + 1, i__3 = kplusp - *np + 1;
dswap_(&i__1, &ritz[nevm2 + 1], &c__1, &ritz[max(i__2,i__3)],
&c__1);
i__1 = min(nevd2,*np);
/* Computing MAX */
i__2 = kplusp - nevd2 + 1, i__3 = kplusp - *np + 1;
dswap_(&i__1, &bounds[nevm2 + 1], &c__1, &bounds[max(i__2,
i__3)], &c__1);
}
} else {
/* %--------------------------------------------------% */
/* | LM, SM, LA, SA case. | */
/* | Sort the eigenvalues of H into the an order that | */
/* | is opposite to WHICH, and apply the resulting | */
/* | order to BOUNDS. The eigenvalues are sorted so | */
/* | that the wanted part are always within the first | */
/* | NEV locations. | */
/* %--------------------------------------------------% */
if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "SM", (ftnlen)2, (ftnlen)2);
}
if (s_cmp(which, "SM", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "LM", (ftnlen)2, (ftnlen)2);
}
if (s_cmp(which, "LA", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "SA", (ftnlen)2, (ftnlen)2);
}
if (s_cmp(which, "SA", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "LA", (ftnlen)2, (ftnlen)2);
}
dsortr_(wprime, &c_true, &kplusp, &ritz[1], &bounds[1], (ftnlen)2)
;
}
/* %--------------------------------------------------% */
/* | Scale the Ritz estimate of each Ritz value | */
/* | by 1 / max(eps23,magnitude of the Ritz value). | */
/* %--------------------------------------------------% */
i__1 = nev0;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
d__2 = eps23, d__3 = (d__1 = ritz[j], abs(d__1));
temp = max(d__2,d__3);
bounds[j] /= temp;
/* L35: */
}
/* %----------------------------------------------------% */
/* | Sort the Ritz values according to the scaled Ritz | */
/* | esitmates. This will push all the converged ones | */
/* | towards the front of ritzr, ritzi, bounds | */
/* | (in the case when NCONV < NEV.) | */
/* %----------------------------------------------------% */
s_copy(wprime, "LA", (ftnlen)2, (ftnlen)2);
dsortr_(wprime, &c_true, &nev0, &bounds[1], &ritz[1], (ftnlen)2);
/* %----------------------------------------------% */
/* | Scale the Ritz estimate back to its original | */
/* | value. | */
/* %----------------------------------------------% */
i__1 = nev0;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
d__2 = eps23, d__3 = (d__1 = ritz[j], abs(d__1));
temp = max(d__2,d__3);
bounds[j] *= temp;
/* L40: */
}
/* %--------------------------------------------------% */
/* | Sort the "converged" Ritz values again so that | */
/* | the "threshold" values and their associated Ritz | */
/* | estimates appear at the appropriate position in | */
/* | ritz and bound. | */
/* %--------------------------------------------------% */
if (s_cmp(which, "BE", (ftnlen)2, (ftnlen)2) == 0) {
/* %------------------------------------------------% */
/* | Sort the "converged" Ritz values in increasing | */
/* | order. The "threshold" values are in the | */
/* | middle. | */
/* %------------------------------------------------% */
s_copy(wprime, "LA", (ftnlen)2, (ftnlen)2);
dsortr_(wprime, &c_true, &nconv, &ritz[1], &bounds[1], (ftnlen)2);
} else {
/* %----------------------------------------------% */
/* | In LM, SM, LA, SA case, sort the "converged" | */
/* | Ritz values according to WHICH so that the | */
/* | "threshold" value appears at the front of | */
/* | ritz. | */
/* %----------------------------------------------% */
dsortr_(which, &c_true, &nconv, &ritz[1], &bounds[1], (ftnlen)2);
}
/* %------------------------------------------% */
/* | Use h( 1,1 ) as storage to communicate | */
/* | rnorm to _seupd if needed | */
/* %------------------------------------------% */
h__[h_dim1 + 1] = rnorm;
if (msglvl > 1) {
dvout_(&debug_1.logfil, &kplusp, &ritz[1], &debug_1.ndigit, "_sa"
"up2: Sorted Ritz values.", (ftnlen)27);
dvout_(&debug_1.logfil, &kplusp, &bounds[1], &debug_1.ndigit,
"_saup2: Sorted ritz estimates.", (ftnlen)30);
}
/* %------------------------------------% */
/* | Max iterations have been exceeded. | */
/* %------------------------------------% */
if (iter > *mxiter && nconv < *nev) {
*info = 1;
}
/* %---------------------% */
/* | No shifts to apply. | */
/* %---------------------% */
if (*np == 0 && nconv < nev0) {
*info = 2;
}
*np = nconv;
goto L1100;
} else if (nconv < *nev && *ishift == 1) {
/* %---------------------------------------------------% */
/* | Do not have all the requested eigenvalues yet. | */
/* | To prevent possible stagnation, adjust the number | */
/* | of Ritz values and the shifts. | */
/* %---------------------------------------------------% */
nevbef = *nev;
/* Computing MIN */
i__1 = nconv, i__2 = *np / 2;
*nev += min(i__1,i__2);
if (*nev == 1 && kplusp >= 6) {
*nev = kplusp / 2;
} else if (*nev == 1 && kplusp > 2) {
*nev = 2;
}
*np = kplusp - *nev;
/* %---------------------------------------% */
/* | If the size of NEV was just increased | */
/* | resort the eigenvalues. | */
/* %---------------------------------------% */
if (nevbef < *nev) {
dsgets_(ishift, which, nev, np, &ritz[1], &bounds[1], &workl[1], (
ftnlen)2);
}
}
if (msglvl > 0) {
ivout_(&debug_1.logfil, &c__1, &nconv, &debug_1.ndigit, "_saup2: no."
" of \"converged\" Ritz values at this iter.", (ftnlen)52);
if (msglvl > 1) {
kp[0] = *nev;
kp[1] = *np;
ivout_(&debug_1.logfil, &c__2, kp, &debug_1.ndigit, "_saup2: NEV"
" and NP are", (ftnlen)22);
dvout_(&debug_1.logfil, nev, &ritz[*np + 1], &debug_1.ndigit,
"_saup2: \"wanted\" Ritz values.", (ftnlen)29);
dvout_(&debug_1.logfil, nev, &bounds[*np + 1], &debug_1.ndigit,
"_saup2: Ritz estimates of the \"wanted\" values ", (
ftnlen)46);
}
}
if (*ishift == 0) {
/* %-----------------------------------------------------% */
/* | User specified shifts: reverse communication to | */
/* | compute the shifts. They are returned in the first | */
/* | NP locations of WORKL. | */
/* %-----------------------------------------------------% */
ushift = TRUE_;
*ido = 3;
goto L9000;
}
L50:
/* %------------------------------------% */
/* | Back from reverse communication; | */
/* | User specified shifts are returned | */
/* | in WORKL(1:*NP) | */
/* %------------------------------------% */
ushift = FALSE_;
/* %---------------------------------------------------------% */
/* | Move the NP shifts to the first NP locations of RITZ to | */
/* | free up WORKL. This is for the non-exact shift case; | */
/* | in the exact shift case, dsgets already handles this. | */
/* %---------------------------------------------------------% */
if (*ishift == 0) {
dcopy_(np, &workl[1], &c__1, &ritz[1], &c__1);
}
if (msglvl > 2) {
ivout_(&debug_1.logfil, &c__1, np, &debug_1.ndigit, "_saup2: The num"
"ber of shifts to apply ", (ftnlen)38);
dvout_(&debug_1.logfil, np, &workl[1], &debug_1.ndigit, "_saup2: shi"
"fts selected", (ftnlen)23);
if (*ishift == 1) {
dvout_(&debug_1.logfil, np, &bounds[1], &debug_1.ndigit, "_saup2"
": corresponding Ritz estimates", (ftnlen)36);
}
}
/* %---------------------------------------------------------% */
/* | Apply the NP0 implicit shifts by QR bulge chasing. | */
/* | Each shift is applied to the entire tridiagonal matrix. | */
/* | The first 2*N locations of WORKD are used as workspace. | */
/* | After dsapps is done, we have a Lanczos | */
/* | factorization of length NEV. | */
/* %---------------------------------------------------------% */
dsapps_(n, nev, np, &ritz[1], &v[v_offset], ldv, &h__[h_offset], ldh, &
resid[1], &q[q_offset], ldq, &workd[1]);
/* %---------------------------------------------% */
/* | Compute the B-norm of the updated residual. | */
/* | Keep B*RESID in WORKD(1:N) to be used in | */
/* | the first step of the next call to dsaitr. | */
/* %---------------------------------------------% */
cnorm = TRUE_;
arscnd_(&t2);
if (*(unsigned char *)bmat == 'G') {
++timing_1.nbx;
dcopy_(n, &resid[1], &c__1, &workd[*n + 1], &c__1);
ipntr[1] = *n + 1;
ipntr[2] = 1;
*ido = 2;
/* %----------------------------------% */
/* | Exit in order to compute B*RESID | */
/* %----------------------------------% */
goto L9000;
} else if (*(unsigned char *)bmat == 'I') {
dcopy_(n, &resid[1], &c__1, &workd[1], &c__1);
}
L100:
/* %----------------------------------% */
/* | Back from reverse communication; | */
/* | WORKD(1:N) := B*RESID | */
/* %----------------------------------% */
if (*(unsigned char *)bmat == 'G') {
arscnd_(&t3);
timing_1.tmvbx += t3 - t2;
}
if (*(unsigned char *)bmat == 'G') {
rnorm = ddot_(n, &resid[1], &c__1, &workd[1], &c__1);
rnorm = sqrt((abs(rnorm)));
} else if (*(unsigned char *)bmat == 'I') {
rnorm = dnrm2_(n, &resid[1], &c__1);
}
cnorm = FALSE_;
/* L130: */
if (msglvl > 2) {
dvout_(&debug_1.logfil, &c__1, &rnorm, &debug_1.ndigit, "_saup2: B-n"
"orm of residual for NEV factorization", (ftnlen)48);
dvout_(&debug_1.logfil, nev, &h__[(h_dim1 << 1) + 1], &debug_1.ndigit,
"_saup2: main diagonal of compressed H matrix", (ftnlen)44);
i__1 = *nev - 1;
dvout_(&debug_1.logfil, &i__1, &h__[h_dim1 + 2], &debug_1.ndigit,
"_saup2: subdiagonal of compressed H matrix", (ftnlen)42);
}
goto L1000;
/* %---------------------------------------------------------------% */
/* | | */
/* | E N D O F M A I N I T E R A T I O N L O O P | */
/* | | */
/* %---------------------------------------------------------------% */
L1100:
*mxiter = iter;
*nev = nconv;
L1200:
*ido = 99;
/* %------------% */
/* | Error exit | */
/* %------------% */
arscnd_(&t1);
timing_1.tsaup2 = t1 - t0;
L9000:
return 0;
/* %---------------% */
/* | End of dsaup2 | */
/* %---------------% */
} /* dsaup2_ */
/* Subroutine */ int ok_odex_odxcor_(integer *n, S_fp fcn, doublereal *x, doublereal *
y, doublereal *xend, doublereal *hmax, doublereal *h__, doublereal *
rtol, doublereal *atol, integer *itol, integer *km,
integer *iout, integer *idid, integer *nmax, doublereal *uround,
doublereal *dy, doublereal *yh1, doublereal *yh2, doublereal *dz,
doublereal *scal, doublereal *fsafe, doublereal *ysafe, doublereal *t,
doublereal *hh, doublereal *w, doublereal *a, doublereal *dens,
integer *ncom, integer *icomp, integer *nj, integer *ipoint, integer *
nsequ, integer *mstab, integer *jstab, integer *lfsafe, doublereal *
safe1, doublereal *safe2, doublereal *safe3, doublereal *fac1,
doublereal *fac2, doublereal *fac3, doublereal *fac4, integer *iderr,
doublereal *errfac, integer *mudif, integer *nrd, integer *nfcn, integer *nstep, integer *naccpt,
integer *nrejct, void* params)
{
/* Format strings */
static char fmt_979[] = "(\002 EXIT OF ODEX AT X=\002,d14.7,\002 H="
"\002,d14.7)";
/* System generated locals */
integer t_dim1, t_offset, fsafe_dim1, fsafe_offset, ysafe_dim1,
ysafe_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3;
/* Builtin functions */
double d_sign(doublereal *, doublereal *), d_lg10(doublereal *), sqrt(
doublereal), pow_di(doublereal *, integer *), pow_dd(doublereal *,
doublereal *);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, j, k, l, kc, kk, mu;
doublereal fac;
real hhh;
integer kmi, kln;
doublereal err;
integer krn, ipt, kbeg, lbeg, lend;
logical last;
integer kmit;
doublereal prod;
logical atov;
doublereal xold;
integer kopt;
doublereal errx;
integer njadd;
doublereal facnj;
real xoldd;
integer irtrn;
doublereal dblenj;
logical reject;
doublereal factor, hoptde, errold, posneg;
doublereal errint;
/* Fortran I/O blocks */
static cilist io___91 = { 0, 6, 0, fmt_979, 0 };
/* ---------------------------------------------------------- */
/* CORE INTEGRATOR FOR ODEX */
/* PARAMETERS SAME AS IN ODEX WITH WORKSPACE ADDED */
/* ---------------------------------------------------------- */
/* DECLARATIONS */
/* ---------------------------------------------------------- */
/* --- DEFINE THE STEP SIZE SEQUENCE */
/* Parameter adjustments */
--scal;
--dz;
--yh2;
--yh1;
--dy;
--y;
--rtol;
--atol;
--errfac;
--ipoint;
--nj;
--a;
--w;
--hh;
t_dim1 = *km;
t_offset = 1 + t_dim1;
t -= t_offset;
--dens;
--icomp;
ysafe_dim1 = *km;
ysafe_offset = 1 + ysafe_dim1;
ysafe -= ysafe_offset;
fsafe_dim1 = *lfsafe;
fsafe_offset = 1 + fsafe_dim1;
fsafe -= fsafe_offset;
/* Function Body */
if (*nsequ == 1) {
i__1 = *km;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L1: */
nj[i__] = i__ << 1;
}
}
if (*nsequ == 2) {
nj[1] = 2;
i__1 = *km;
for (i__ = 2; i__ <= i__1; ++i__) {
/* L2: */
nj[i__] = (i__ << 2) - 4;
}
}
if (*nsequ == 3) {
nj[1] = 2;
nj[2] = 4;
nj[3] = 6;
i__1 = *km;
for (i__ = 4; i__ <= i__1; ++i__) {
/* L11: */
nj[i__] = nj[i__ - 2] << 1;
}
}
if (*nsequ == 4) {
i__1 = *km;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L3: */
nj[i__] = (i__ << 2) - 2;
}
}
if (*nsequ == 5) {
i__1 = *km;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L6: */
nj[i__] = i__ << 2;
}
}
/* --- DEFINE THE A(I) FOR ORDER SELECTION */
a[1] = nj[1] + 1.;
i__1 = *km;
for (i__ = 2; i__ <= i__1; ++i__) {
/* L4: */
a[i__] = a[i__ - 1] + nj[i__];
}
/* --- INITIAL SCALING */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (*itol == 0) {
scal[i__] = atol[1] + rtol[1] * (d__1 = y[i__], abs(d__1));
} else {
scal[i__] = atol[i__] + rtol[i__] * (d__1 = y[i__], abs(d__1));
}
/* L8: */
}
/* --- INITIAL PREPARATIONS */
d__1 = *xend - *x;
posneg = d_sign(&c_b67, &d__1);
/* Computing MAX */
/* Computing MIN */
d__1 = rtol[1] + 1e-40;
i__3 = *km - 1, i__4 = (integer) (-d_lg10(&d__1) * .6 + 1.5);
i__1 = 2, i__2 = min(i__3,i__4);
k = max(i__1,i__2);
*hmax = abs(*hmax);
/* Computing MAX */
d__1 = abs(*h__);
*h__ = max(d__1,1e-4);
/* Computing MIN */
d__2 = min(*h__,*hmax), d__3 = (d__1 = *xend - *x, abs(d__1)) / 2.;
*h__ = posneg * min(d__2,d__3);
if (*iout >= 1) {
if (*iout >= 2) {
ipoint[1] = 0;
i__1 = *km;
for (i__ = 1; i__ <= i__1; ++i__) {
njadd = (i__ << 2) - 2;
if (nj[i__] > njadd) {
++njadd;
}
/* L5: */
ipoint[i__ + 1] = ipoint[i__] + njadd;
}
i__1 = *km << 1;
for (mu = 1; mu <= i__1; ++mu) {
errx = sqrt(mu / (mu + 4.)) * .5;
/* Computing 2nd power */
d__1 = mu + 4.;
prod = 1. / (d__1 * d__1);
i__2 = mu;
for (j = 1; j <= i__2; ++j) {
/* L7: */
prod = prod * errx / j;
}
/* L9: */
errfac[mu] = prod;
}
ipt = 0;
}
irtrn = 0;
xold = *x;
i__1 = *naccpt + 1;
if (irtrn < 0) {
goto L120;
}
}
err = 0.;
errold = 1e10;
hoptde = posneg * *hmax;
w[1] = 0.;
reject = FALSE_;
last = FALSE_;
L10:
atov = FALSE_;
/* --- IS XEND REACHED IN THE NEXT STEP? */
if ((d__1 = *xend - *x, abs(d__1)) * .1 <= abs(*x) * *uround) {
goto L110;
}
/* Computing MIN */
d__2 = abs(*h__), d__3 = (d__1 = *xend - *x, abs(d__1)), d__2 = min(d__2,
d__3), d__2 = min(d__2,*hmax), d__3 = abs(hoptde);
*h__ = posneg * min(d__2,d__3);
if ((*x + *h__ * 1.01 - *xend) * posneg > 0.) {
*h__ = *xend - *x;
last = TRUE_;
}
if (*nstep == 0 || *iout != 2) {
(*fcn)(*x, &y[1], &dz[1], params);
}
++(*nfcn);
/* --- THE FIRST AND LAST STEP */
if (*nstep == 0 || last) {
ipt = 0;
++(*nstep);
i__1 = k;
for (j = 1; j <= i__1; ++j) {
kc = j;
ok_odex_midex_(&j, x, &y[1], h__, hmax, n, (S_fp)fcn, &dy[1], &yh1[1], &
yh2[1], &dz[1], &t[t_offset], &nj[1], &hh[1], &w[1], &err,
&fac, &a[1], safe1, uround, fac1, fac2, safe2, &scal[1],
&atov, safe3, &reject, km, &rtol[1], &atol[1], itol,
mstab, jstab, &errold, &fsafe[fsafe_offset], lfsafe, iout,
&ipt, &ysafe[ysafe_offset], &icomp[1], nrd, nfcn, params);
if (atov) {
goto L10;
}
/* L20: */
if (j > 1 && err <= 1.) {
goto L60;
}
}
goto L55;
}
/* --- BASIC INTEGRATION STEP */
L30:
ipt = 0;
++(*nstep);
if (*nstep >= *nmax) {
goto L120;
}
kc = k - 1;
i__1 = kc;
for (j = 1; j <= i__1; ++j) {
ok_odex_midex_(&j, x, &y[1], h__, hmax, n, (S_fp)fcn, &dy[1], &yh1[1], &yh2[1]
, &dz[1], &t[t_offset], &nj[1], &hh[1], &w[1], &err, &fac, &a[
1], safe1, uround, fac1, fac2, safe2, &scal[1], &atov, safe3,
&reject, km, &rtol[1], &atol[1], itol, mstab, jstab, &errold,
&fsafe[fsafe_offset], lfsafe, iout, &ipt, &ysafe[ysafe_offset]
, &icomp[1], nrd, nfcn, params);
if (atov) {
goto L10;
}
/* L40: */
}
/* --- CONVERGENCE MONITOR */
if (k == 2 || reject) {
goto L50;
}
if (err <= 1.) {
goto L60;
}
/* Computing 2nd power */
d__1 = nj[k + 1] * nj[k] / 4.;
if (err > d__1 * d__1) {
goto L100;
}
L50:
ok_odex_midex_(&k, x, &y[1], h__, hmax, n, (S_fp)fcn, &dy[1], &yh1[1], &yh2[1], &
dz[1], &t[t_offset], &nj[1], &hh[1], &w[1], &err, &fac, &a[1],
safe1, uround, fac1, fac2, safe2, &scal[1], &atov, safe3, &reject,
km, &rtol[1], &atol[1], itol, mstab, jstab, &errold, &fsafe[
fsafe_offset], lfsafe, iout, &ipt, &ysafe[ysafe_offset], &icomp[1]
, nrd, nfcn, params);
if (atov) {
goto L10;
}
kc = k;
if (err <= 1.) {
goto L60;
}
/* --- HOPE FOR CONVERGENCE IN LINE K+1 */
L55:
/* Computing 2nd power */
d__1 = nj[k + 1] / 2.;
if (err > d__1 * d__1) {
goto L100;
}
kc = k + 1;
ok_odex_midex_(&kc, x, &y[1], h__, hmax, n, (S_fp)fcn, &dy[1], &yh1[1], &yh2[1], &
dz[1], &t[t_offset], &nj[1], &hh[1], &w[1], &err, &fac, &a[1],
safe1, uround, fac1, fac2, safe2, &scal[1], &atov, safe3, &reject,
km, &rtol[1], &atol[1], itol, mstab, jstab, &errold, &fsafe[
fsafe_offset], lfsafe, iout, &ipt, &ysafe[ysafe_offset], &icomp[1]
, nrd, nfcn, params);
if (atov) {
goto L10;
}
if (err > 1.) {
goto L100;
}
/* --- STEP IS ACCEPTED */
L60:
xold = *x;
*x += *h__;
if (*iout >= 2) {
/* --- KMIT = MU OF THE PAPER */
kmit = (kc << 1) - *mudif + 1;
i__1 = *nrd;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L69: */
dens[i__] = y[icomp[i__]];
}
xoldd = xold;
hhh = *h__;
i__1 = *nrd;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L76: */
dens[*nrd + i__] = *h__ * dz[icomp[i__]];
}
kln = *nrd << 1;
i__1 = *nrd;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L176: */
dens[kln + i__] = t[icomp[i__] * t_dim1 + 1];
}
/* --- COMPUTE SOLUTION AT MID-POINT ---- */
i__1 = kc;
for (j = 2; j <= i__1; ++j) {
dblenj = (doublereal) nj[j];
for (l = j; l >= 2; --l) {
/* Computing 2nd power */
d__1 = dblenj / nj[l - 1];
factor = d__1 * d__1 - 1.;
i__2 = *nrd;
for (i__ = 1; i__ <= i__2; ++i__) {
ysafe[l - 1 + i__ * ysafe_dim1] = ysafe[l + i__ *
ysafe_dim1] + (ysafe[l + i__ * ysafe_dim1] -
ysafe[l - 1 + i__ * ysafe_dim1]) / factor;
/* L473: */
}
}
}
krn = *nrd << 2;
i__2 = *nrd;
for (i__ = 1; i__ <= i__2; ++i__) {
/* L474: */
dens[krn + i__] = ysafe[i__ * ysafe_dim1 + 1];
}
/* --- COMPUTE FIRST DERIVATIVE AT RIGHT END ---- */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* L478: */
yh1[i__] = t[i__ * t_dim1 + 1];
}
(*fcn)(*x, &yh1[1], &yh2[1], params);
krn = *nrd * 3;
i__2 = *nrd;
for (i__ = 1; i__ <= i__2; ++i__) {
/* L274: */
dens[krn + i__] = yh2[icomp[i__]] * *h__;
}
/* --- THE LOOP --- */
i__2 = kmit;
for (kmi = 1; kmi <= i__2; ++kmi) {
/* --- COMPUTE KMI-TH DERIVATIVE AT MID-POINT ---- */
kbeg = (kmi + 1) / 2;
i__1 = kc;
for (kk = kbeg; kk <= i__1; ++kk) {
d__1 = nj[kk] / 2.;
i__3 = kmi - 1;
facnj = pow_di(&d__1, &i__3);
ipt = ipoint[kk + 1] - (kk << 1) + kmi;
i__3 = *nrd;
for (i__ = 1; i__ <= i__3; ++i__) {
/* L371: */
ysafe[kk + i__ * ysafe_dim1] = fsafe[ipt + i__ *
fsafe_dim1] * facnj;
}
/* L375: */
}
i__1 = kc;
for (j = kbeg + 1; j <= i__1; ++j) {
dblenj = (doublereal) nj[j];
i__3 = kbeg + 1;
for (l = j; l >= i__3; --l) {
/* Computing 2nd power */
d__1 = dblenj / nj[l - 1];
factor = d__1 * d__1 - 1.;
i__4 = *nrd;
for (i__ = 1; i__ <= i__4; ++i__) {
ysafe[l - 1 + i__ * ysafe_dim1] = ysafe[l + i__ *
ysafe_dim1] + (ysafe[l + i__ * ysafe_dim1] -
ysafe[l - 1 + i__ * ysafe_dim1]) / factor;
/* L373: */
}
}
}
krn = (kmi + 4) * *nrd;
i__4 = *nrd;
for (i__ = 1; i__ <= i__4; ++i__) {
/* L374: */
dens[krn + i__] = ysafe[kbeg + i__ * ysafe_dim1] * *h__;
}
if (kmi == kmit) {
goto L180;
}
/* --- COMPUTE DIFFERENCES */
i__4 = kc;
for (kk = (kmi + 2) / 2; kk <= i__4; ++kk) {
lbeg = ipoint[kk + 1];
lend = ipoint[kk] + kmi + 1;
if (kmi == 1 && *nsequ == 4) {
lend += 2;
}
i__3 = lend;
for (l = lbeg; l >= i__3; l += -2) {
i__1 = *nrd;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L64: */
fsafe[l + i__ * fsafe_dim1] -= fsafe[l - 2 + i__ *
fsafe_dim1];
}
}
if (kmi == 1 && *nsequ == 4) {
l = lend - 2;
i__1 = *nrd;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L65: */
fsafe[l + i__ * fsafe_dim1] -= dz[icomp[i__]];
}
}
/* L66: */
}
/* --- COMPUTE DIFFERENCES */
i__4 = kc;
for (kk = (kmi + 2) / 2; kk <= i__4; ++kk) {
lbeg = ipoint[kk + 1] - 1;
lend = ipoint[kk] + kmi + 2;
i__1 = lend;
for (l = lbeg; l >= i__1; l += -2) {
i__3 = *nrd;
for (i__ = 1; i__ <= i__3; ++i__) {
/* L164: */
fsafe[l + i__ * fsafe_dim1] -= fsafe[l - 2 + i__ *
fsafe_dim1];
}
}
/* L166: */
}
L180:
;
}
ok_odex_interp_(*nrd, &dens[1], kmit);
/* --- ESTIMATION OF INTERPOLATION ERROR */
if (*iderr == 0 && kmit >= 1) {
errint = 0.;
i__2 = *nrd;
for (i__ = 1; i__ <= i__2; ++i__) {
/* L187: */
/* Computing 2nd power */
d__1 = dens[(kmit + 4) * *nrd + i__] / scal[icomp[i__]];
errint += d__1 * d__1;
}
errint = sqrt(errint / *nrd) * errfac[kmit];
/* Computing MAX */
d__2 = 1. / (kmit + 4);
d__1 = pow_dd(&errint, &d__2);
hoptde = *h__ / max(d__1,.01);
if (errint > 10.) {
*h__ = hoptde;
*x = xold;
++(*nrejct);
reject = TRUE_;
goto L10;
}
}
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* L189: */
dz[i__] = yh2[i__];
}
}
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* L70: */
y[i__] = t[i__ * t_dim1 + 1];
}
++(*naccpt);
if (*iout >= 1) {
i__2 = *naccpt + 1;
if (irtrn < 0) {
goto L120;
}
}
/* --- COMPUTE OPTIMAL ORDER */
if (kc == 2) {
/* Computing MIN */
i__2 = 3, i__4 = *km - 1;
kopt = min(i__2,i__4);
if (reject) {
kopt = 2;
}
goto L80;
}
if (kc <= k) {
kopt = kc;
if (w[kc - 1] < w[kc] * *fac3) {
kopt = kc - 1;
}
if (w[kc] < w[kc - 1] * *fac4) {
/* Computing MIN */
i__2 = kc + 1, i__4 = *km - 1;
kopt = min(i__2,i__4);
}
} else {
kopt = kc - 1;
if (kc > 3 && w[kc - 2] < w[kc - 1] * *fac3) {
kopt = kc - 2;
}
if (w[kc] < w[kopt] * *fac4) {
/* Computing MIN */
i__2 = kc, i__4 = *km - 1;
kopt = min(i__2,i__4);
}
}
/* --- AFTER A REJECTED STEP */
L80:
if (reject) {
k = min(kopt,kc);
/* Computing MIN */
d__2 = abs(*h__), d__3 = (d__1 = hh[k], abs(d__1));
*h__ = posneg * min(d__2,d__3);
reject = FALSE_;
goto L10;
}
/* --- COMPUTE STEPSIZE FOR NEXT STEP */
if (kopt <= kc) {
*h__ = hh[kopt];
} else {
if (kc < k && w[kc] < w[kc - 1] * *fac4) {
*h__ = hh[kc] * a[kopt + 1] / a[kc];
} else {
*h__ = hh[kc] * a[kopt] / a[kc];
}
}
k = kopt;
*h__ = posneg * abs(*h__);
goto L10;
/* --- STEP IS REJECTED */
L100:
/* Computing MIN */
i__2 = min(k,kc), i__4 = *km - 1;
k = min(i__2,i__4);
if (k > 2 && w[k - 1] < w[k] * *fac3) {
--k;
}
++(*nrejct);
*h__ = posneg * hh[k];
reject = TRUE_;
goto L30;
/* --- SOLUTION EXIT */
L110:
*idid = 1;
return 0;
/* --- FAIL EXIT */
L120:
s_wsfe(&io___91);
do_fio(&c__1, (char *)&(*x), (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&(*h__), (ftnlen)sizeof(doublereal));
e_wsfe();
*idid = -1;
return 0;
} /* odxcor_ */
/* DECK CLNGAM */
/* Complex */ void clngam_(complex * ret_val, complex *zin)
{
/* Initialized data */
static real pi = 3.14159265358979324f;
static real sq2pil = .91893853320467274f;
static logical first = TRUE_;
/* System generated locals */
integer i__1;
real r__1, r__2;
doublereal d__1, d__2;
complex q__1, q__2, q__3, q__4, q__5, q__6, q__7, q__8, q__9, q__10,
q__11, q__12, q__13, q__14, q__15, q__16;
/* Local variables */
static integer i__, n;
static real x, y;
static complex z__;
extern doublereal carg_(complex *);
static complex corr;
static real cabsz, bound, dxrel;
extern doublereal r1mach_(integer *);
extern /* Complex */ void c9lgmc_(complex *, complex *), clnrel_(complex *
, complex *);
static real argsum;
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE CLNGAM */
/* ***PURPOSE Compute the logarithm of the absolute value of the Gamma */
/* function. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C7A */
/* ***TYPE COMPLEX (ALNGAM-S, DLNGAM-D, CLNGAM-C) */
/* ***KEYWORDS ABSOLUTE VALUE, COMPLETE GAMMA FUNCTION, FNLIB, LOGARITHM, */
/* SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* CLNGAM computes the natural log of the complex valued gamma function */
/* at ZIN, where ZIN is a complex number. This is a preliminary version, */
/* which is not accurate. */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED C9LGMC, CARG, CLNREL, R1MACH, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 780401 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890531 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* ***END PROLOGUE CLNGAM */
/* ***FIRST EXECUTABLE STATEMENT CLNGAM */
if (first) {
n = log(r1mach_(&c__3)) * -.3f;
/* BOUND = N*(0.1*EPS)**(-1/(2*N-1))/(PI*EXP(1)) */
d__1 = (doublereal) (r1mach_(&c__3) * .1f);
d__2 = (doublereal) (-1.f / ((n << 1) - 1));
bound = n * .1171f * pow_dd(&d__1, &d__2);
dxrel = sqrt(r1mach_(&c__4));
}
first = FALSE_;
z__.r = zin->r, z__.i = zin->i;
x = zin->r;
y = r_imag(zin);
corr.r = 0.f, corr.i = 0.f;
cabsz = c_abs(&z__);
if (x >= 0.f && cabsz > bound) {
goto L50;
}
if (x < 0.f && dabs(y) > bound) {
goto L50;
}
if (cabsz < bound) {
goto L20;
}
/* USE THE REFLECTION FORMULA FOR REAL(Z) NEGATIVE, ABS(Z) LARGE, AND */
/* ABS(AIMAG(Y)) SMALL. */
if (y > 0.f) {
r_cnjg(&q__1, &z__);
z__.r = q__1.r, z__.i = q__1.i;
}
r__1 = pi * 2.f;
q__4.r = 0.f, q__4.i = r__1;
q__3.r = -q__4.r, q__3.i = -q__4.i;
q__2.r = q__3.r * z__.r - q__3.i * z__.i, q__2.i = q__3.r * z__.i +
q__3.i * z__.r;
c_exp(&q__1, &q__2);
corr.r = q__1.r, corr.i = q__1.i;
if (corr.r == 1.f && r_imag(&corr) == 0.f) {
xermsg_("SLATEC", "CLNGAM", "Z IS A NEGATIVE INTEGER", &c__3, &c__2, (
ftnlen)6, (ftnlen)6, (ftnlen)23);
}
r__1 = sq2pil + 1.f;
q__7.r = 0.f, q__7.i = pi;
q__8.r = z__.r - .5f, q__8.i = z__.i;
q__6.r = q__7.r * q__8.r - q__7.i * q__8.i, q__6.i = q__7.r * q__8.i +
q__7.i * q__8.r;
q__5.r = r__1 - q__6.r, q__5.i = -q__6.i;
q__10.r = -corr.r, q__10.i = -corr.i;
clnrel_(&q__9, &q__10);
q__4.r = q__5.r - q__9.r, q__4.i = q__5.i - q__9.i;
q__12.r = z__.r - .5f, q__12.i = z__.i;
q__14.r = 1.f - z__.r, q__14.i = -z__.i;
c_log(&q__13, &q__14);
q__11.r = q__12.r * q__13.r - q__12.i * q__13.i, q__11.i = q__12.r *
q__13.i + q__12.i * q__13.r;
q__3.r = q__4.r + q__11.r, q__3.i = q__4.i + q__11.i;
q__2.r = q__3.r - z__.r, q__2.i = q__3.i - z__.i;
q__16.r = 1.f - z__.r, q__16.i = -z__.i;
c9lgmc_(&q__15, &q__16);
q__1.r = q__2.r - q__15.r, q__1.i = q__2.i - q__15.i;
ret_val->r = q__1.r, ret_val->i = q__1.i;
if (y > 0.f) {
r_cnjg(&q__1, ret_val);
ret_val->r = q__1.r, ret_val->i = q__1.i;
}
return ;
/* USE THE RECURSION RELATION FOR ABS(Z) SMALL. */
L20:
if (x >= -.5f || dabs(y) > dxrel) {
goto L30;
}
r__2 = x - .5f;
r__1 = r_int(&r__2);
q__2.r = z__.r - r__1, q__2.i = z__.i;
q__1.r = q__2.r / x, q__1.i = q__2.i / x;
if (c_abs(&q__1) < dxrel) {
xermsg_("SLATEC", "CLNGAM", "ANSWER LT HALF PRECISION BECAUSE Z TOO "
"NEAR NEGATIVE INTEGER", &c__1, &c__1, (ftnlen)6, (ftnlen)6, (
ftnlen)60);
}
L30:
/* Computing 2nd power */
r__1 = bound;
/* Computing 2nd power */
r__2 = y;
n = sqrt(r__1 * r__1 - r__2 * r__2) - x + 1.f;
argsum = 0.f;
corr.r = 1.f, corr.i = 0.f;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
argsum += carg_(&z__);
q__1.r = z__.r * corr.r - z__.i * corr.i, q__1.i = z__.r * corr.i +
z__.i * corr.r;
corr.r = q__1.r, corr.i = q__1.i;
q__1.r = z__.r + 1.f, q__1.i = z__.i;
z__.r = q__1.r, z__.i = q__1.i;
/* L40: */
}
if (corr.r == 0.f && r_imag(&corr) == 0.f) {
xermsg_("SLATEC", "CLNGAM", "Z IS A NEGATIVE INTEGER", &c__3, &c__2, (
ftnlen)6, (ftnlen)6, (ftnlen)23);
}
r__1 = log(c_abs(&corr));
q__2.r = r__1, q__2.i = argsum;
q__1.r = -q__2.r, q__1.i = -q__2.i;
corr.r = q__1.r, corr.i = q__1.i;
/* USE STIRLING-S APPROXIMATION FOR LARGE Z. */
L50:
q__6.r = z__.r - .5f, q__6.i = z__.i;
c_log(&q__7, &z__);
q__5.r = q__6.r * q__7.r - q__6.i * q__7.i, q__5.i = q__6.r * q__7.i +
q__6.i * q__7.r;
q__4.r = sq2pil + q__5.r, q__4.i = q__5.i;
q__3.r = q__4.r - z__.r, q__3.i = q__4.i - z__.i;
q__2.r = q__3.r + corr.r, q__2.i = q__3.i + corr.i;
c9lgmc_(&q__8, &z__);
q__1.r = q__2.r + q__8.r, q__1.i = q__2.i + q__8.i;
ret_val->r = q__1.r, ret_val->i = q__1.i;
return ;
} /* clngam_ */
/* DECK CPSI */
/* Complex */ void cpsi_(complex * ret_val, complex *zin)
{
/* Initialized data */
static real bern[13] = { .083333333333333333f,-.0083333333333333333f,
.0039682539682539683f,-.0041666666666666667f,
.0075757575757575758f,-.021092796092796093f,.083333333333333333f,
-.44325980392156863f,3.0539543302701197f,-26.456212121212121f,
281.46014492753623f,-3454.8853937728938f,54827.583333333333f };
static real pi = 3.141592653589793f;
static logical first = TRUE_;
/* System generated locals */
integer i__1, i__2;
real r__1, r__2;
doublereal d__1, d__2;
complex q__1, q__2, q__3, q__4, q__5, q__6;
/* Local variables */
static integer i__, n;
static real x, y;
static complex z__;
static integer ndx;
static real rbig;
extern /* Complex */ void ccot_(complex *, complex *);
static complex corr;
static real rmin;
static complex z2inv;
static real cabsz, bound, dxrel;
static integer nterm;
extern doublereal r1mach_(integer *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE CPSI */
/* ***PURPOSE Compute the Psi (or Digamma) function. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C7C */
/* ***TYPE COMPLEX (PSI-S, DPSI-D, CPSI-C) */
/* ***KEYWORDS DIGAMMA FUNCTION, FNLIB, PSI FUNCTION, SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* PSI(X) calculates the psi (or digamma) function of X. PSI(X) */
/* is the logarithmic derivative of the gamma function of X. */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED CCOT, R1MACH, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 780501 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890531 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* 900727 Added EXTERNAL statement. (WRB) */
/* ***END PROLOGUE CPSI */
/* ***FIRST EXECUTABLE STATEMENT CPSI */
if (first) {
nterm = log(r1mach_(&c__3)) * -.3f;
/* MAYBE BOUND = N*(0.1*EPS)**(-1/(2*N-1)) / (PI*EXP(1)) */
d__1 = (doublereal) (r1mach_(&c__3) * .1f);
d__2 = (doublereal) (-1.f / ((nterm << 1) - 1));
bound = nterm * .1171f * pow_dd(&d__1, &d__2);
dxrel = sqrt(r1mach_(&c__4));
/* Computing MAX */
r__1 = log(r1mach_(&c__1)), r__2 = -log(r1mach_(&c__2));
rmin = exp(dmax(r__1,r__2) + .011f);
rbig = 1.f / r1mach_(&c__3);
}
first = FALSE_;
z__.r = zin->r, z__.i = zin->i;
x = z__.r;
y = r_imag(&z__);
if (y < 0.f) {
r_cnjg(&q__1, &z__);
z__.r = q__1.r, z__.i = q__1.i;
}
corr.r = 0.f, corr.i = 0.f;
cabsz = c_abs(&z__);
if (x >= 0.f && cabsz > bound) {
goto L50;
}
if (x < 0.f && dabs(y) > bound) {
goto L50;
}
if (cabsz < bound) {
goto L20;
}
/* USE THE REFLECTION FORMULA FOR REAL(Z) NEGATIVE, ABS(Z) LARGE, AND */
/* ABS(AIMAG(Y)) SMALL. */
r__1 = -pi;
q__3.r = pi * z__.r, q__3.i = pi * z__.i;
ccot_(&q__2, &q__3);
q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
corr.r = q__1.r, corr.i = q__1.i;
q__1.r = 1.f - z__.r, q__1.i = -z__.i;
z__.r = q__1.r, z__.i = q__1.i;
goto L50;
/* USE THE RECURSION RELATION FOR ABS(Z) SMALL. */
L20:
if (cabsz < rmin) {
xermsg_("SLATEC", "CPSI", "CPSI CALLED WITH Z SO NEAR 0 THAT CPSI OV"
"ERFLOWS", &c__2, &c__2, (ftnlen)6, (ftnlen)4, (ftnlen)48);
}
if (x >= -.5f || dabs(y) > dxrel) {
goto L30;
}
r__2 = x - .5f;
r__1 = r_int(&r__2);
q__2.r = z__.r - r__1, q__2.i = z__.i;
q__1.r = q__2.r / x, q__1.i = q__2.i / x;
if (c_abs(&q__1) < dxrel) {
xermsg_("SLATEC", "CPSI", "ANSWER LT HALF PRECISION BECAUSE Z TOO NE"
"AR NEGATIVE INTEGER", &c__1, &c__1, (ftnlen)6, (ftnlen)4, (
ftnlen)60);
}
if (y == 0.f && x == r_int(&x)) {
xermsg_("SLATEC", "CPSI", "Z IS A NEGATIVE INTEGER", &c__3, &c__2, (
ftnlen)6, (ftnlen)4, (ftnlen)23);
}
L30:
/* Computing 2nd power */
r__1 = bound;
/* Computing 2nd power */
r__2 = y;
n = sqrt(r__1 * r__1 - r__2 * r__2) - x + 1.f;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
c_div(&q__2, &c_b28, &z__);
q__1.r = corr.r - q__2.r, q__1.i = corr.i - q__2.i;
corr.r = q__1.r, corr.i = q__1.i;
q__1.r = z__.r + 1.f, q__1.i = z__.i;
z__.r = q__1.r, z__.i = q__1.i;
/* L40: */
}
/* NOW EVALUATE THE ASYMPTOTIC SERIES FOR SUITABLY LARGE Z. */
L50:
if (cabsz > rbig) {
c_log(&q__2, &z__);
q__1.r = q__2.r + corr.r, q__1.i = q__2.i + corr.i;
ret_val->r = q__1.r, ret_val->i = q__1.i;
}
if (cabsz > rbig) {
goto L70;
}
ret_val->r = 0.f, ret_val->i = 0.f;
pow_ci(&q__2, &z__, &c__2);
c_div(&q__1, &c_b28, &q__2);
z2inv.r = q__1.r, z2inv.i = q__1.i;
i__1 = nterm;
for (i__ = 1; i__ <= i__1; ++i__) {
ndx = nterm + 1 - i__;
i__2 = ndx - 1;
q__2.r = z2inv.r * ret_val->r - z2inv.i * ret_val->i, q__2.i =
z2inv.r * ret_val->i + z2inv.i * ret_val->r;
q__1.r = bern[i__2] + q__2.r, q__1.i = q__2.i;
ret_val->r = q__1.r, ret_val->i = q__1.i;
/* L60: */
}
c_log(&q__4, &z__);
c_div(&q__5, &c_b34, &z__);
q__3.r = q__4.r - q__5.r, q__3.i = q__4.i - q__5.i;
q__6.r = ret_val->r * z2inv.r - ret_val->i * z2inv.i, q__6.i =
ret_val->r * z2inv.i + ret_val->i * z2inv.r;
q__2.r = q__3.r - q__6.r, q__2.i = q__3.i - q__6.i;
q__1.r = q__2.r + corr.r, q__1.i = q__2.i + corr.i;
ret_val->r = q__1.r, ret_val->i = q__1.i;
L70:
if (y < 0.f) {
r_cnjg(&q__1, ret_val);
ret_val->r = q__1.r, ret_val->i = q__1.i;
}
return ;
} /* cpsi_ */
/* DECK CUNHJ */
/* Subroutine */ int cunhj_(complex *z__, real *fnu, integer *ipmtr, real *
tol, complex *phi, complex *arg, complex *zeta1, complex *zeta2,
complex *asum, complex *bsum)
{
/* Initialized data */
static real ar[14] = { 1.f,.104166666666666667f,.0835503472222222222f,
.12822657455632716f,.291849026464140464f,.881627267443757652f,
3.32140828186276754f,14.9957629868625547f,78.9230130115865181f,
474.451538868264323f,3207.49009089066193f,24086.5496408740049f,
198923.119169509794f,1791902.00777534383f };
static real pi = 3.14159265358979324f;
static real thpi = 4.71238898038468986f;
static complex czero = {0.f,0.f};
static complex cone = {1.f,0.f};
static real br[14] = { 1.f,-.145833333333333333f,-.0987413194444444444f,
-.143312053915895062f,-.317227202678413548f,-.942429147957120249f,
-3.51120304082635426f,-15.7272636203680451f,-82.2814390971859444f,
-492.355370523670524f,-3316.21856854797251f,-24827.6742452085896f,
-204526.587315129788f,-1838444.9170682099f };
static real c__[105] = { 1.f,-.208333333333333333f,.125f,
.334201388888888889f,-.401041666666666667f,.0703125f,
-1.02581259645061728f,1.84646267361111111f,-.8912109375f,
.0732421875f,4.66958442342624743f,-11.2070026162229938f,
8.78912353515625f,-2.3640869140625f,.112152099609375f,
-28.2120725582002449f,84.6362176746007346f,-91.8182415432400174f,
42.5349987453884549f,-7.3687943594796317f,.227108001708984375f,
212.570130039217123f,-765.252468141181642f,1059.99045252799988f,
-699.579627376132541f,218.19051174421159f,-26.4914304869515555f,
.572501420974731445f,-1919.457662318407f,8061.72218173730938f,
-13586.5500064341374f,11655.3933368645332f,-5305.64697861340311f,
1200.90291321635246f,-108.090919788394656f,1.7277275025844574f,
20204.2913309661486f,-96980.5983886375135f,192547.001232531532f,
-203400.177280415534f,122200.46498301746f,-41192.6549688975513f,
7109.51430248936372f,-493.915304773088012f,6.07404200127348304f,
-242919.187900551333f,1311763.6146629772f,-2998015.91853810675f,
3763271.297656404f,-2813563.22658653411f,1268365.27332162478f,
-331645.172484563578f,45218.7689813627263f,-2499.83048181120962f,
24.3805296995560639f,3284469.85307203782f,-19706819.1184322269f,
50952602.4926646422f,-74105148.2115326577f,66344512.2747290267f,
-37567176.6607633513f,13288767.1664218183f,-2785618.12808645469f,
308186.404612662398f,-13886.0897537170405f,110.017140269246738f,
-49329253.664509962f,325573074.185765749f,-939462359.681578403f,
1553596899.57058006f,-1621080552.10833708f,1106842816.82301447f,
-495889784.275030309f,142062907.797533095f,-24474062.7257387285f,
2243768.17792244943f,-84005.4336030240853f,551.335896122020586f,
814789096.118312115f,-5866481492.05184723f,18688207509.2958249f,
-34632043388.1587779f,41280185579.753974f,-33026599749.8007231f,
17954213731.1556001f,-6563293792.61928433f,1559279864.87925751f,
-225105661.889415278f,17395107.5539781645f,-549842.327572288687f,
3038.09051092238427f,-14679261247.6956167f,114498237732.02581f,
-399096175224.466498f,819218669548.577329f,-1098375156081.22331f,
1008158106865.38209f,-645364869245.376503f,287900649906.150589f,
-87867072178.0232657f,17634730606.8349694f,-2167164983.22379509f,
143157876.718888981f,-3871833.44257261262f,18257.7554742931747f };
static real alfa[180] = { -.00444444444444444444f,
-9.22077922077922078e-4f,-8.84892884892884893e-5f,
1.65927687832449737e-4f,2.4669137274179291e-4f,
2.6599558934625478e-4f,2.61824297061500945e-4f,
2.48730437344655609e-4f,2.32721040083232098e-4f,
2.16362485712365082e-4f,2.00738858762752355e-4f,
1.86267636637545172e-4f,1.73060775917876493e-4f,
1.61091705929015752e-4f,1.50274774160908134e-4f,
1.40503497391269794e-4f,1.31668816545922806e-4f,
1.23667445598253261e-4f,1.16405271474737902e-4f,
1.09798298372713369e-4f,1.03772410422992823e-4f,
9.82626078369363448e-5f,9.32120517249503256e-5f,
8.85710852478711718e-5f,8.42963105715700223e-5f,
8.03497548407791151e-5f,7.66981345359207388e-5f,
7.33122157481777809e-5f,7.01662625163141333e-5f,
6.72375633790160292e-5f,6.93735541354588974e-4f,
2.32241745182921654e-4f,-1.41986273556691197e-5f,
-1.1644493167204864e-4f,-1.50803558053048762e-4f,
-1.55121924918096223e-4f,-1.46809756646465549e-4f,
-1.33815503867491367e-4f,-1.19744975684254051e-4f,
-1.0618431920797402e-4f,-9.37699549891194492e-5f,
-8.26923045588193274e-5f,-7.29374348155221211e-5f,
-6.44042357721016283e-5f,-5.69611566009369048e-5f,
-5.04731044303561628e-5f,-4.48134868008882786e-5f,
-3.98688727717598864e-5f,-3.55400532972042498e-5f,
-3.1741425660902248e-5f,-2.83996793904174811e-5f,
-2.54522720634870566e-5f,-2.28459297164724555e-5f,
-2.05352753106480604e-5f,-1.84816217627666085e-5f,
-1.66519330021393806e-5f,-1.50179412980119482e-5f,
-1.35554031379040526e-5f,-1.22434746473858131e-5f,
-1.10641884811308169e-5f,-3.54211971457743841e-4f,
-1.56161263945159416e-4f,3.0446550359493641e-5f,
1.30198655773242693e-4f,1.67471106699712269e-4f,
1.70222587683592569e-4f,1.56501427608594704e-4f,
1.3633917097744512e-4f,1.14886692029825128e-4f,
9.45869093034688111e-5f,7.64498419250898258e-5f,
6.07570334965197354e-5f,4.74394299290508799e-5f,
3.62757512005344297e-5f,2.69939714979224901e-5f,
1.93210938247939253e-5f,1.30056674793963203e-5f,
7.82620866744496661e-6f,3.59257485819351583e-6f,
1.44040049814251817e-7f,-2.65396769697939116e-6f,
-4.9134686709848591e-6f,-6.72739296091248287e-6f,
-8.17269379678657923e-6f,-9.31304715093561232e-6f,
-1.02011418798016441e-5f,-1.0880596251059288e-5f,
-1.13875481509603555e-5f,-1.17519675674556414e-5f,
-1.19987364870944141e-5f,3.78194199201772914e-4f,
2.02471952761816167e-4f,-6.37938506318862408e-5f,
-2.38598230603005903e-4f,-3.10916256027361568e-4f,
-3.13680115247576316e-4f,-2.78950273791323387e-4f,
-2.28564082619141374e-4f,-1.75245280340846749e-4f,
-1.25544063060690348e-4f,-8.22982872820208365e-5f,
-4.62860730588116458e-5f,-1.72334302366962267e-5f,
5.60690482304602267e-6f,2.313954431482868e-5f,
3.62642745856793957e-5f,4.58006124490188752e-5f,
5.2459529495911405e-5f,5.68396208545815266e-5f,
5.94349820393104052e-5f,6.06478527578421742e-5f,
6.08023907788436497e-5f,6.01577894539460388e-5f,
5.891996573446985e-5f,5.72515823777593053e-5f,
5.52804375585852577e-5f,5.3106377380288017e-5f,
5.08069302012325706e-5f,4.84418647620094842e-5f,
4.6056858160747537e-5f,-6.91141397288294174e-4f,
-4.29976633058871912e-4f,1.83067735980039018e-4f,
6.60088147542014144e-4f,8.75964969951185931e-4f,
8.77335235958235514e-4f,7.49369585378990637e-4f,
5.63832329756980918e-4f,3.68059319971443156e-4f,
1.88464535514455599e-4f,3.70663057664904149e-5f,
-8.28520220232137023e-5f,-1.72751952869172998e-4f,
-2.36314873605872983e-4f,-2.77966150694906658e-4f,
-3.02079514155456919e-4f,-3.12594712643820127e-4f,
-3.12872558758067163e-4f,-3.05678038466324377e-4f,
-2.93226470614557331e-4f,-2.77255655582934777e-4f,
-2.59103928467031709e-4f,-2.39784014396480342e-4f,
-2.20048260045422848e-4f,-2.00443911094971498e-4f,
-1.81358692210970687e-4f,-1.63057674478657464e-4f,
-1.45712672175205844e-4f,-1.29425421983924587e-4f,
-1.14245691942445952e-4f,.00192821964248775885f,
.00135592576302022234f,-7.17858090421302995e-4f,
-.00258084802575270346f,-.00349271130826168475f,
-.00346986299340960628f,-.00282285233351310182f,
-.00188103076404891354f,-8.895317183839476e-4f,
3.87912102631035228e-6f,7.28688540119691412e-4f,
.00126566373053457758f,.00162518158372674427f,
.00183203153216373172f,.00191588388990527909f,
.00190588846755546138f,.00182798982421825727f,
.0017038950642112153f,.00155097127171097686f,
.00138261421852276159f,.00120881424230064774f,
.00103676532638344962f,8.71437918068619115e-4f,
7.16080155297701002e-4f,5.72637002558129372e-4f,
4.42089819465802277e-4f,3.24724948503090564e-4f,
2.20342042730246599e-4f,1.28412898401353882e-4f,
4.82005924552095464e-5f };
static real beta[210] = { .0179988721413553309f,.00559964911064388073f,
.00288501402231132779f,.00180096606761053941f,
.00124753110589199202f,9.22878876572938311e-4f,
7.14430421727287357e-4f,5.71787281789704872e-4f,
4.69431007606481533e-4f,3.93232835462916638e-4f,
3.34818889318297664e-4f,2.88952148495751517e-4f,
2.52211615549573284e-4f,2.22280580798883327e-4f,
1.97541838033062524e-4f,1.76836855019718004e-4f,
1.59316899661821081e-4f,1.44347930197333986e-4f,
1.31448068119965379e-4f,1.20245444949302884e-4f,
1.10449144504599392e-4f,1.01828770740567258e-4f,
9.41998224204237509e-5f,8.74130545753834437e-5f,
8.13466262162801467e-5f,7.59002269646219339e-5f,
7.09906300634153481e-5f,6.65482874842468183e-5f,
6.25146958969275078e-5f,5.88403394426251749e-5f,
-.00149282953213429172f,-8.78204709546389328e-4f,
-5.02916549572034614e-4f,-2.94822138512746025e-4f,
-1.75463996970782828e-4f,-1.04008550460816434e-4f,
-5.96141953046457895e-5f,-3.1203892907609834e-5f,
-1.26089735980230047e-5f,-2.42892608575730389e-7f,
8.05996165414273571e-6f,1.36507009262147391e-5f,
1.73964125472926261e-5f,1.9867297884213378e-5f,
2.14463263790822639e-5f,2.23954659232456514e-5f,
2.28967783814712629e-5f,2.30785389811177817e-5f,
2.30321976080909144e-5f,2.28236073720348722e-5f,
2.25005881105292418e-5f,2.20981015361991429e-5f,
2.16418427448103905e-5f,2.11507649256220843e-5f,
2.06388749782170737e-5f,2.01165241997081666e-5f,
1.95913450141179244e-5f,1.9068936791043674e-5f,
1.85533719641636667e-5f,1.80475722259674218e-5f,
5.5221307672129279e-4f,4.47932581552384646e-4f,
2.79520653992020589e-4f,1.52468156198446602e-4f,
6.93271105657043598e-5f,1.76258683069991397e-5f,
-1.35744996343269136e-5f,-3.17972413350427135e-5f,
-4.18861861696693365e-5f,-4.69004889379141029e-5f,
-4.87665447413787352e-5f,-4.87010031186735069e-5f,
-4.74755620890086638e-5f,-4.55813058138628452e-5f,
-4.33309644511266036e-5f,-4.09230193157750364e-5f,
-3.84822638603221274e-5f,-3.60857167535410501e-5f,
-3.37793306123367417e-5f,-3.15888560772109621e-5f,
-2.95269561750807315e-5f,-2.75978914828335759e-5f,
-2.58006174666883713e-5f,-2.413083567612802e-5f,
-2.25823509518346033e-5f,-2.11479656768912971e-5f,
-1.98200638885294927e-5f,-1.85909870801065077e-5f,
-1.74532699844210224e-5f,-1.63997823854497997e-5f,
-4.74617796559959808e-4f,-4.77864567147321487e-4f,
-3.20390228067037603e-4f,-1.61105016119962282e-4f,
-4.25778101285435204e-5f,3.44571294294967503e-5f,
7.97092684075674924e-5f,1.031382367082722e-4f,
1.12466775262204158e-4f,1.13103642108481389e-4f,
1.08651634848774268e-4f,1.01437951597661973e-4f,
9.29298396593363896e-5f,8.40293133016089978e-5f,
7.52727991349134062e-5f,6.69632521975730872e-5f,
5.92564547323194704e-5f,5.22169308826975567e-5f,
4.58539485165360646e-5f,4.01445513891486808e-5f,
3.50481730031328081e-5f,3.05157995034346659e-5f,
2.64956119950516039e-5f,2.29363633690998152e-5f,
1.97893056664021636e-5f,1.70091984636412623e-5f,
1.45547428261524004e-5f,1.23886640995878413e-5f,
1.04775876076583236e-5f,8.79179954978479373e-6f,
7.36465810572578444e-4f,8.72790805146193976e-4f,
6.22614862573135066e-4f,2.85998154194304147e-4f,
3.84737672879366102e-6f,-1.87906003636971558e-4f,
-2.97603646594554535e-4f,-3.45998126832656348e-4f,
-3.53382470916037712e-4f,-3.35715635775048757e-4f,
-3.04321124789039809e-4f,-2.66722723047612821e-4f,
-2.27654214122819527e-4f,-1.89922611854562356e-4f,
-1.5505891859909387e-4f,-1.2377824076187363e-4f,
-9.62926147717644187e-5f,-7.25178327714425337e-5f,
-5.22070028895633801e-5f,-3.50347750511900522e-5f,
-2.06489761035551757e-5f,-8.70106096849767054e-6f,
1.1369868667510029e-6f,9.16426474122778849e-6f,
1.5647778542887262e-5f,2.08223629482466847e-5f,
2.48923381004595156e-5f,2.80340509574146325e-5f,
3.03987774629861915e-5f,3.21156731406700616e-5f,
-.00180182191963885708f,-.00243402962938042533f,
-.00183422663549856802f,-7.62204596354009765e-4f,
2.39079475256927218e-4f,9.49266117176881141e-4f,
.00134467449701540359f,.00148457495259449178f,
.00144732339830617591f,.00130268261285657186f,
.00110351597375642682f,8.86047440419791759e-4f,
6.73073208165665473e-4f,4.77603872856582378e-4f,
3.05991926358789362e-4f,1.6031569459472163e-4f,
4.00749555270613286e-5f,-5.66607461635251611e-5f,
-1.32506186772982638e-4f,-1.90296187989614057e-4f,
-2.32811450376937408e-4f,-2.62628811464668841e-4f,
-2.82050469867598672e-4f,-2.93081563192861167e-4f,
-2.97435962176316616e-4f,-2.96557334239348078e-4f,
-2.91647363312090861e-4f,-2.83696203837734166e-4f,
-2.73512317095673346e-4f,-2.6175015580676858e-4f,
.00638585891212050914f,.00962374215806377941f,
.00761878061207001043f,.00283219055545628054f,
-.0020984135201272009f,-.00573826764216626498f,
-.0077080424449541462f,-.00821011692264844401f,
-.00765824520346905413f,-.00647209729391045177f,
-.00499132412004966473f,-.0034561228971313328f,
-.00201785580014170775f,-7.59430686781961401e-4f,
2.84173631523859138e-4f,.00110891667586337403f,
.00172901493872728771f,.00216812590802684701f,
.00245357710494539735f,.00261281821058334862f,
.00267141039656276912f,.0026520307339598043f,
.00257411652877287315f,.00245389126236094427f,
.00230460058071795494f,.00213684837686712662f,
.00195896528478870911f,.00177737008679454412f,
.00159690280765839059f,.00142111975664438546f };
static real gama[30] = { .629960524947436582f,.251984209978974633f,
.154790300415655846f,.110713062416159013f,.0857309395527394825f,
.0697161316958684292f,.0586085671893713576f,.0504698873536310685f,
.0442600580689154809f,.0393720661543509966f,.0354283195924455368f,
.0321818857502098231f,.0294646240791157679f,.0271581677112934479f,
.0251768272973861779f,.0234570755306078891f,.0219508390134907203f,
.020621082823564624f,.0194388240897880846f,.0183810633800683158f,
.0174293213231963172f,.0165685837786612353f,.0157865285987918445f,
.0150729501494095594f,.0144193250839954639f,.0138184805735341786f,
.0132643378994276568f,.0127517121970498651f,.0122761545318762767f,
.0118338262398482403f };
static real ex1 = .333333333333333333f;
static real ex2 = .666666666666666667f;
static real hpi = 1.57079632679489662f;
/* System generated locals */
integer i__1, i__2, i__3;
real r__1;
doublereal d__1, d__2;
complex q__1, q__2, q__3, q__4, q__5;
/* Local variables */
static integer j, k, l, m;
static complex p[30], w;
static integer l1, l2;
static complex t2, w2;
static real ac, ap[30];
static complex cr[14], dr[14], za, zb, zc;
static integer is, jr;
static real pp, wi;
static integer ju, ks, lr;
static complex up[14];
static real wr, aw2;
static integer kp1;
static real ang, fn13, fn23;
static integer ias, ibs;
static real zci;
static complex tfn;
static real zcr;
static complex zth;
static integer lrp1;
static complex rfn13, cfnu;
static real atol, btol;
static integer kmax;
static complex zeta, ptfn, suma, sumb;
static real azth, rfnu, zthi, test, tsti;
static complex rzth;
static real zthr, tstr, rfnu2, zetai, asumi, bsumi, zetar, asumr, bsumr;
static complex rtzta, przth;
extern doublereal r1mach_(integer *);
/* ***BEGIN PROLOGUE CUNHJ */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to CBESI and CBESK */
/* ***LIBRARY SLATEC */
/* ***TYPE ALL (CUNHJ-A, ZUNHJ-A) */
/* ***AUTHOR Amos, D. E., (SNL) */
/* ***DESCRIPTION */
/* REFERENCES */
/* HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ AND I.A. */
/* STEGUN, AMS55, NATIONAL BUREAU OF STANDARDS, 1965, CHAPTER 9. */
/* ASYMPTOTICS AND SPECIAL FUNCTIONS BY F.W.J. OLVER, ACADEMIC */
/* PRESS, N.Y., 1974, PAGE 420 */
/* ABSTRACT */
/* CUNHJ COMPUTES PARAMETERS FOR BESSEL FUNCTIONS C(FNU,Z) = */
/* J(FNU,Z), Y(FNU,Z) OR H(I,FNU,Z) I=1,2 FOR LARGE ORDERS FNU */
/* BY MEANS OF THE UNIFORM ASYMPTOTIC EXPANSION */
/* C(FNU,Z)=C1*PHI*( ASUM*AIRY(ARG) + C2*BSUM*DAIRY(ARG) ) */
/* FOR PROPER CHOICES OF C1, C2, AIRY AND DAIRY WHERE AIRY IS */
/* AN AIRY FUNCTION AND DAIRY IS ITS DERIVATIVE. */
/* (2/3)*FNU*ZETA**1.5 = ZETA1-ZETA2, */
/* ZETA1=0.5*FNU*CLOG((1+W)/(1-W)), ZETA2=FNU*W FOR SCALING */
/* PURPOSES IN AIRY FUNCTIONS FROM CAIRY OR CBIRY. */
/* MCONJ=SIGN OF AIMAG(Z), BUT IS AMBIGUOUS WHEN Z IS REAL AND */
/* MUST BE SPECIFIED. IPMTR=0 RETURNS ALL PARAMETERS. IPMTR= */
/* 1 COMPUTES ALL EXCEPT ASUM AND BSUM. */
/* ***SEE ALSO CBESI, CBESK */
/* ***ROUTINES CALLED R1MACH */
/* ***REVISION HISTORY (YYMMDD) */
/* 830501 DATE WRITTEN */
/* 910415 Prologue converted to Version 4.0 format. (BAB) */
/* ***END PROLOGUE CUNHJ */
/* ***FIRST EXECUTABLE STATEMENT CUNHJ */
rfnu = 1.f / *fnu;
/* ZB = Z*CMPLX(RFNU,0.0E0) */
/* ----------------------------------------------------------------------- */
/* OVERFLOW TEST (Z/FNU TOO SMALL) */
/* ----------------------------------------------------------------------- */
tstr = z__->r;
tsti = r_imag(z__);
test = r1mach_(&c__1) * 1e3f;
ac = *fnu * test;
if (dabs(tstr) > ac || dabs(tsti) > ac) {
goto L15;
}
ac = (r__1 = log(test), dabs(r__1)) * 2.f + *fnu;
q__1.r = ac, q__1.i = 0.f;
zeta1->r = q__1.r, zeta1->i = q__1.i;
q__1.r = *fnu, q__1.i = 0.f;
zeta2->r = q__1.r, zeta2->i = q__1.i;
phi->r = cone.r, phi->i = cone.i;
arg->r = cone.r, arg->i = cone.i;
return 0;
L15:
q__2.r = rfnu, q__2.i = 0.f;
q__1.r = z__->r * q__2.r - z__->i * q__2.i, q__1.i = z__->r * q__2.i +
z__->i * q__2.r;
zb.r = q__1.r, zb.i = q__1.i;
rfnu2 = rfnu * rfnu;
/* ----------------------------------------------------------------------- */
/* COMPUTE IN THE FOURTH QUADRANT */
/* ----------------------------------------------------------------------- */
d__1 = (doublereal) (*fnu);
d__2 = (doublereal) ex1;
fn13 = pow_dd(&d__1, &d__2);
fn23 = fn13 * fn13;
r__1 = 1.f / fn13;
q__1.r = r__1, q__1.i = 0.f;
rfn13.r = q__1.r, rfn13.i = q__1.i;
q__2.r = zb.r * zb.r - zb.i * zb.i, q__2.i = zb.r * zb.i + zb.i * zb.r;
q__1.r = cone.r - q__2.r, q__1.i = cone.i - q__2.i;
w2.r = q__1.r, w2.i = q__1.i;
aw2 = c_abs(&w2);
if (aw2 > .25f) {
goto L130;
}
/* ----------------------------------------------------------------------- */
/* POWER SERIES FOR ABS(W2).LE.0.25E0 */
/* ----------------------------------------------------------------------- */
k = 1;
p[0].r = cone.r, p[0].i = cone.i;
q__1.r = gama[0], q__1.i = 0.f;
suma.r = q__1.r, suma.i = q__1.i;
ap[0] = 1.f;
if (aw2 < *tol) {
goto L20;
}
for (k = 2; k <= 30; ++k) {
i__1 = k - 1;
i__2 = k - 2;
q__1.r = p[i__2].r * w2.r - p[i__2].i * w2.i, q__1.i = p[i__2].r *
w2.i + p[i__2].i * w2.r;
p[i__1].r = q__1.r, p[i__1].i = q__1.i;
i__1 = k - 1;
i__2 = k - 1;
q__3.r = gama[i__2], q__3.i = 0.f;
q__2.r = p[i__1].r * q__3.r - p[i__1].i * q__3.i, q__2.i = p[i__1].r *
q__3.i + p[i__1].i * q__3.r;
q__1.r = suma.r + q__2.r, q__1.i = suma.i + q__2.i;
suma.r = q__1.r, suma.i = q__1.i;
ap[k - 1] = ap[k - 2] * aw2;
if (ap[k - 1] < *tol) {
goto L20;
}
/* L10: */
}
k = 30;
L20:
kmax = k;
q__1.r = w2.r * suma.r - w2.i * suma.i, q__1.i = w2.r * suma.i + w2.i *
suma.r;
zeta.r = q__1.r, zeta.i = q__1.i;
q__2.r = fn23, q__2.i = 0.f;
q__1.r = zeta.r * q__2.r - zeta.i * q__2.i, q__1.i = zeta.r * q__2.i +
zeta.i * q__2.r;
arg->r = q__1.r, arg->i = q__1.i;
c_sqrt(&q__1, &suma);
za.r = q__1.r, za.i = q__1.i;
c_sqrt(&q__2, &w2);
q__3.r = *fnu, q__3.i = 0.f;
q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = q__2.r * q__3.i +
q__2.i * q__3.r;
zeta2->r = q__1.r, zeta2->i = q__1.i;
q__4.r = zeta.r * za.r - zeta.i * za.i, q__4.i = zeta.r * za.i + zeta.i *
za.r;
q__5.r = ex2, q__5.i = 0.f;
q__3.r = q__4.r * q__5.r - q__4.i * q__5.i, q__3.i = q__4.r * q__5.i +
q__4.i * q__5.r;
q__2.r = cone.r + q__3.r, q__2.i = cone.i + q__3.i;
q__1.r = zeta2->r * q__2.r - zeta2->i * q__2.i, q__1.i = zeta2->r *
q__2.i + zeta2->i * q__2.r;
zeta1->r = q__1.r, zeta1->i = q__1.i;
q__1.r = za.r + za.r, q__1.i = za.i + za.i;
za.r = q__1.r, za.i = q__1.i;
c_sqrt(&q__2, &za);
q__1.r = q__2.r * rfn13.r - q__2.i * rfn13.i, q__1.i = q__2.r * rfn13.i +
q__2.i * rfn13.r;
phi->r = q__1.r, phi->i = q__1.i;
if (*ipmtr == 1) {
goto L120;
}
/* ----------------------------------------------------------------------- */
/* SUM SERIES FOR ASUM AND BSUM */
/* ----------------------------------------------------------------------- */
sumb.r = czero.r, sumb.i = czero.i;
i__1 = kmax;
for (k = 1; k <= i__1; ++k) {
i__2 = k - 1;
i__3 = k - 1;
q__3.r = beta[i__3], q__3.i = 0.f;
q__2.r = p[i__2].r * q__3.r - p[i__2].i * q__3.i, q__2.i = p[i__2].r *
q__3.i + p[i__2].i * q__3.r;
q__1.r = sumb.r + q__2.r, q__1.i = sumb.i + q__2.i;
sumb.r = q__1.r, sumb.i = q__1.i;
/* L30: */
}
asum->r = czero.r, asum->i = czero.i;
bsum->r = sumb.r, bsum->i = sumb.i;
l1 = 0;
l2 = 30;
btol = *tol * c_abs(bsum);
atol = *tol;
pp = 1.f;
ias = 0;
ibs = 0;
if (rfnu2 < *tol) {
goto L110;
}
for (is = 2; is <= 7; ++is) {
atol /= rfnu2;
pp *= rfnu2;
if (ias == 1) {
goto L60;
}
suma.r = czero.r, suma.i = czero.i;
i__1 = kmax;
for (k = 1; k <= i__1; ++k) {
m = l1 + k;
i__2 = k - 1;
i__3 = m - 1;
q__3.r = alfa[i__3], q__3.i = 0.f;
q__2.r = p[i__2].r * q__3.r - p[i__2].i * q__3.i, q__2.i = p[i__2]
.r * q__3.i + p[i__2].i * q__3.r;
q__1.r = suma.r + q__2.r, q__1.i = suma.i + q__2.i;
suma.r = q__1.r, suma.i = q__1.i;
if (ap[k - 1] < atol) {
goto L50;
}
/* L40: */
}
L50:
q__3.r = pp, q__3.i = 0.f;
q__2.r = suma.r * q__3.r - suma.i * q__3.i, q__2.i = suma.r * q__3.i
+ suma.i * q__3.r;
q__1.r = asum->r + q__2.r, q__1.i = asum->i + q__2.i;
asum->r = q__1.r, asum->i = q__1.i;
if (pp < *tol) {
ias = 1;
}
L60:
if (ibs == 1) {
goto L90;
}
sumb.r = czero.r, sumb.i = czero.i;
i__1 = kmax;
for (k = 1; k <= i__1; ++k) {
m = l2 + k;
i__2 = k - 1;
i__3 = m - 1;
q__3.r = beta[i__3], q__3.i = 0.f;
q__2.r = p[i__2].r * q__3.r - p[i__2].i * q__3.i, q__2.i = p[i__2]
.r * q__3.i + p[i__2].i * q__3.r;
q__1.r = sumb.r + q__2.r, q__1.i = sumb.i + q__2.i;
sumb.r = q__1.r, sumb.i = q__1.i;
if (ap[k - 1] < atol) {
goto L80;
}
/* L70: */
}
L80:
q__3.r = pp, q__3.i = 0.f;
q__2.r = sumb.r * q__3.r - sumb.i * q__3.i, q__2.i = sumb.r * q__3.i
+ sumb.i * q__3.r;
q__1.r = bsum->r + q__2.r, q__1.i = bsum->i + q__2.i;
bsum->r = q__1.r, bsum->i = q__1.i;
if (pp < btol) {
ibs = 1;
}
L90:
if (ias == 1 && ibs == 1) {
goto L110;
}
l1 += 30;
l2 += 30;
/* L100: */
}
L110:
q__1.r = asum->r + cone.r, q__1.i = asum->i + cone.i;
asum->r = q__1.r, asum->i = q__1.i;
pp = rfnu * rfn13.r;
q__2.r = pp, q__2.i = 0.f;
q__1.r = bsum->r * q__2.r - bsum->i * q__2.i, q__1.i = bsum->r * q__2.i +
bsum->i * q__2.r;
bsum->r = q__1.r, bsum->i = q__1.i;
L120:
return 0;
/* ----------------------------------------------------------------------- */
/* ABS(W2).GT.0.25E0 */
/* ----------------------------------------------------------------------- */
L130:
c_sqrt(&q__1, &w2);
w.r = q__1.r, w.i = q__1.i;
wr = w.r;
wi = r_imag(&w);
if (wr < 0.f) {
wr = 0.f;
}
if (wi < 0.f) {
wi = 0.f;
}
q__1.r = wr, q__1.i = wi;
w.r = q__1.r, w.i = q__1.i;
q__2.r = cone.r + w.r, q__2.i = cone.i + w.i;
c_div(&q__1, &q__2, &zb);
za.r = q__1.r, za.i = q__1.i;
c_log(&q__1, &za);
zc.r = q__1.r, zc.i = q__1.i;
zcr = zc.r;
zci = r_imag(&zc);
if (zci < 0.f) {
zci = 0.f;
}
if (zci > hpi) {
zci = hpi;
}
if (zcr < 0.f) {
zcr = 0.f;
}
q__1.r = zcr, q__1.i = zci;
zc.r = q__1.r, zc.i = q__1.i;
q__2.r = zc.r - w.r, q__2.i = zc.i - w.i;
q__1.r = q__2.r * 1.5f - q__2.i * 0.f, q__1.i = q__2.r * 0.f + q__2.i *
1.5f;
zth.r = q__1.r, zth.i = q__1.i;
q__1.r = *fnu, q__1.i = 0.f;
cfnu.r = q__1.r, cfnu.i = q__1.i;
q__1.r = zc.r * cfnu.r - zc.i * cfnu.i, q__1.i = zc.r * cfnu.i + zc.i *
cfnu.r;
zeta1->r = q__1.r, zeta1->i = q__1.i;
q__1.r = w.r * cfnu.r - w.i * cfnu.i, q__1.i = w.r * cfnu.i + w.i *
cfnu.r;
zeta2->r = q__1.r, zeta2->i = q__1.i;
azth = c_abs(&zth);
zthr = zth.r;
zthi = r_imag(&zth);
ang = thpi;
if (zthr >= 0.f && zthi < 0.f) {
goto L140;
}
ang = hpi;
if (zthr == 0.f) {
goto L140;
}
ang = atan(zthi / zthr);
if (zthr < 0.f) {
ang += pi;
}
L140:
d__1 = (doublereal) azth;
d__2 = (doublereal) ex2;
pp = pow_dd(&d__1, &d__2);
ang *= ex2;
zetar = pp * cos(ang);
zetai = pp * sin(ang);
if (zetai < 0.f) {
zetai = 0.f;
}
q__1.r = zetar, q__1.i = zetai;
zeta.r = q__1.r, zeta.i = q__1.i;
q__2.r = fn23, q__2.i = 0.f;
q__1.r = zeta.r * q__2.r - zeta.i * q__2.i, q__1.i = zeta.r * q__2.i +
zeta.i * q__2.r;
arg->r = q__1.r, arg->i = q__1.i;
c_div(&q__1, &zth, &zeta);
rtzta.r = q__1.r, rtzta.i = q__1.i;
c_div(&q__1, &rtzta, &w);
za.r = q__1.r, za.i = q__1.i;
q__3.r = za.r + za.r, q__3.i = za.i + za.i;
c_sqrt(&q__2, &q__3);
q__1.r = q__2.r * rfn13.r - q__2.i * rfn13.i, q__1.i = q__2.r * rfn13.i +
q__2.i * rfn13.r;
phi->r = q__1.r, phi->i = q__1.i;
if (*ipmtr == 1) {
goto L120;
}
q__2.r = rfnu, q__2.i = 0.f;
c_div(&q__1, &q__2, &w);
tfn.r = q__1.r, tfn.i = q__1.i;
q__2.r = rfnu, q__2.i = 0.f;
c_div(&q__1, &q__2, &zth);
rzth.r = q__1.r, rzth.i = q__1.i;
q__2.r = ar[1], q__2.i = 0.f;
q__1.r = rzth.r * q__2.r - rzth.i * q__2.i, q__1.i = rzth.r * q__2.i +
rzth.i * q__2.r;
zc.r = q__1.r, zc.i = q__1.i;
c_div(&q__1, &cone, &w2);
t2.r = q__1.r, t2.i = q__1.i;
q__4.r = c__[1], q__4.i = 0.f;
q__3.r = t2.r * q__4.r - t2.i * q__4.i, q__3.i = t2.r * q__4.i + t2.i *
q__4.r;
q__5.r = c__[2], q__5.i = 0.f;
q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
q__1.r = q__2.r * tfn.r - q__2.i * tfn.i, q__1.i = q__2.r * tfn.i +
q__2.i * tfn.r;
up[1].r = q__1.r, up[1].i = q__1.i;
q__1.r = up[1].r + zc.r, q__1.i = up[1].i + zc.i;
bsum->r = q__1.r, bsum->i = q__1.i;
asum->r = czero.r, asum->i = czero.i;
if (rfnu < *tol) {
goto L220;
}
przth.r = rzth.r, przth.i = rzth.i;
ptfn.r = tfn.r, ptfn.i = tfn.i;
up[0].r = cone.r, up[0].i = cone.i;
pp = 1.f;
bsumr = bsum->r;
bsumi = r_imag(bsum);
btol = *tol * (dabs(bsumr) + dabs(bsumi));
ks = 0;
kp1 = 2;
l = 3;
ias = 0;
ibs = 0;
for (lr = 2; lr <= 12; lr += 2) {
lrp1 = lr + 1;
/* ----------------------------------------------------------------------- */
/* COMPUTE TWO ADDITIONAL CR, DR, AND UP FOR TWO MORE TERMS IN */
/* NEXT SUMA AND SUMB */
/* ----------------------------------------------------------------------- */
i__1 = lrp1;
for (k = lr; k <= i__1; ++k) {
++ks;
++kp1;
++l;
i__2 = l - 1;
q__1.r = c__[i__2], q__1.i = 0.f;
za.r = q__1.r, za.i = q__1.i;
i__2 = kp1;
for (j = 2; j <= i__2; ++j) {
++l;
q__2.r = za.r * t2.r - za.i * t2.i, q__2.i = za.r * t2.i +
za.i * t2.r;
i__3 = l - 1;
q__3.r = c__[i__3], q__3.i = 0.f;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
za.r = q__1.r, za.i = q__1.i;
/* L150: */
}
q__1.r = ptfn.r * tfn.r - ptfn.i * tfn.i, q__1.i = ptfn.r * tfn.i
+ ptfn.i * tfn.r;
ptfn.r = q__1.r, ptfn.i = q__1.i;
i__2 = kp1 - 1;
q__1.r = ptfn.r * za.r - ptfn.i * za.i, q__1.i = ptfn.r * za.i +
ptfn.i * za.r;
up[i__2].r = q__1.r, up[i__2].i = q__1.i;
i__2 = ks - 1;
i__3 = ks;
q__2.r = br[i__3], q__2.i = 0.f;
q__1.r = przth.r * q__2.r - przth.i * q__2.i, q__1.i = przth.r *
q__2.i + przth.i * q__2.r;
cr[i__2].r = q__1.r, cr[i__2].i = q__1.i;
q__1.r = przth.r * rzth.r - przth.i * rzth.i, q__1.i = przth.r *
rzth.i + przth.i * rzth.r;
przth.r = q__1.r, przth.i = q__1.i;
i__2 = ks - 1;
i__3 = ks + 1;
q__2.r = ar[i__3], q__2.i = 0.f;
q__1.r = przth.r * q__2.r - przth.i * q__2.i, q__1.i = przth.r *
q__2.i + przth.i * q__2.r;
dr[i__2].r = q__1.r, dr[i__2].i = q__1.i;
/* L160: */
}
pp *= rfnu2;
if (ias == 1) {
goto L180;
}
i__1 = lrp1 - 1;
suma.r = up[i__1].r, suma.i = up[i__1].i;
ju = lrp1;
i__1 = lr;
for (jr = 1; jr <= i__1; ++jr) {
--ju;
i__2 = jr - 1;
i__3 = ju - 1;
q__2.r = cr[i__2].r * up[i__3].r - cr[i__2].i * up[i__3].i,
q__2.i = cr[i__2].r * up[i__3].i + cr[i__2].i * up[i__3]
.r;
q__1.r = suma.r + q__2.r, q__1.i = suma.i + q__2.i;
suma.r = q__1.r, suma.i = q__1.i;
/* L170: */
}
q__1.r = asum->r + suma.r, q__1.i = asum->i + suma.i;
asum->r = q__1.r, asum->i = q__1.i;
asumr = asum->r;
asumi = r_imag(asum);
test = dabs(asumr) + dabs(asumi);
if (pp < *tol && test < *tol) {
ias = 1;
}
L180:
if (ibs == 1) {
goto L200;
}
i__1 = lr + 1;
i__2 = lrp1 - 1;
q__2.r = up[i__2].r * zc.r - up[i__2].i * zc.i, q__2.i = up[i__2].r *
zc.i + up[i__2].i * zc.r;
q__1.r = up[i__1].r + q__2.r, q__1.i = up[i__1].i + q__2.i;
sumb.r = q__1.r, sumb.i = q__1.i;
ju = lrp1;
i__1 = lr;
for (jr = 1; jr <= i__1; ++jr) {
--ju;
i__2 = jr - 1;
i__3 = ju - 1;
q__2.r = dr[i__2].r * up[i__3].r - dr[i__2].i * up[i__3].i,
q__2.i = dr[i__2].r * up[i__3].i + dr[i__2].i * up[i__3]
.r;
q__1.r = sumb.r + q__2.r, q__1.i = sumb.i + q__2.i;
sumb.r = q__1.r, sumb.i = q__1.i;
/* L190: */
}
q__1.r = bsum->r + sumb.r, q__1.i = bsum->i + sumb.i;
bsum->r = q__1.r, bsum->i = q__1.i;
bsumr = bsum->r;
bsumi = r_imag(bsum);
test = dabs(bsumr) + dabs(bsumi);
if (pp < btol && test < *tol) {
ibs = 1;
}
L200:
if (ias == 1 && ibs == 1) {
goto L220;
}
/* L210: */
}
L220:
q__1.r = asum->r + cone.r, q__1.i = asum->i + cone.i;
asum->r = q__1.r, asum->i = q__1.i;
q__3.r = -bsum->r, q__3.i = -bsum->i;
q__2.r = q__3.r * rfn13.r - q__3.i * rfn13.i, q__2.i = q__3.r * rfn13.i +
q__3.i * rfn13.r;
c_div(&q__1, &q__2, &rtzta);
bsum->r = q__1.r, bsum->i = q__1.i;
goto L120;
} /* cunhj_ */
/* $Procedure DPSPCE ( Propagate a two line element set for deep space ) */
/* Subroutine */ int dpspce_(doublereal *time, doublereal *geophs, doublereal
*elems, doublereal *state)
{
/* Initialized data */
static logical doinit = TRUE_;
static logical first = TRUE_;
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer);
double pow_dd(doublereal *, doublereal *), cos(doublereal), sqrt(
doublereal), sin(doublereal), d_mod(doublereal *, doublereal *),
atan2(doublereal, doublereal);
/* Local variables */
static doublereal coef, eeta, aodp, delo, capu, uang, xmdf, xinc, xmam,
aynl, elsq, temp;
static logical cont;
static doublereal rdot, cosu, sinu, coef1, t2cof, temp1, temp2, temp3,
temp4, temp5, cos2u, temp6;
extern /* Subroutine */ int zzdpinit_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *);
static doublereal sin2u, a, e;
static integer i__;
static doublereal m[3], n[3], s, u[3], v[3], betal, scale, betao;
extern /* Subroutine */ int chkin_(char *, ftnlen);
static doublereal epoch, ecose, aycof, esine, a3ovk2, tempa, tempe, bstar,
cosio, xincl, etasq, rfdot, sinio, a1, rdotk, c1, c2, cosuk, c4,
qoms24, sinuk, templ, x1m5th, x1mth2, x3thm1, x7thm1, psisq,
xinck, xlcof, xmdot, xnode, xnodp;
extern doublereal twopi_(void);
static doublereal s4;
extern /* Subroutine */ int vlcom_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *);
static doublereal betao2, theta2, ae, xhdot1, ao, em, eo, qoms2t, pl,
omgadf, rk, qo, uk, so;
extern doublereal halfpi_(void);
static doublereal xl, xn, omegao;
extern /* Subroutine */ int latrec_(doublereal *, doublereal *,
doublereal *, doublereal *);
static doublereal perige, xnodcf, xnoddf, tsince, xnodek, omgdot, rfdotk,
xnodeo;
extern /* Subroutine */ int chkout_(char *, ftnlen);
static doublereal ck2, lstelm[10], ck4, cosepw, sinepw, xkmper, xnodot,
lstphs[8];
extern logical return_(void);
static doublereal pinvsq, xj2, xj3, xj4, eta, axn, xke, ayn, epw, tsi,
xll, xmo, xno, tsq, xlt, del1;
extern /* Subroutine */ int zzdpsec_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
static doublereal pio2;
extern /* Subroutine */ int zzdpper_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *);
static doublereal pix2;
/* $ Abstract */
/* This routine propagates NORAD two-line element data for */
/* earth orbiting deep space vehicles (a vehicle with an */
/* orbital period more than 225 minutes). */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* EPHEMERIS */
/* TWO LINE ELEMENTS */
/* DEEP SPACE PROPAGATOR */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* TIME I Time for state evaluation in seconds past ephemeris */
/* epoch J2000. */
/* GEOPHS I The array of geophysical constants */
/* ELEMS I Array of orbit elements */
/* STATE O State vector at TIME */
/* $ Detailed_Input */
/* TIME is the epoch in seconds past ephemeris epoch J2000 */
/* to produced a state from the input elements. */
/* GEOPHS is a collection of 8 geophysical constants needed */
/* for computing a state. The order of these */
/* constants must be: */
/* GEOPHS(1) = J2 gravitational harmonic for earth */
/* GEOPHS(2) = J3 gravitational harmonic for earth */
/* GEOPHS(3) = J4 gravitational harmonic for earth */
/* These first three constants are dimensionless. */
/* GEOPHS(4) = KE: Square root of the GM for earth where */
/* GM is expressed in earth radii cubed per */
/* minutes squared. */
/* GEOPHS(5) = QO: Low altitude bound for atmospheric */
/* model in km. */
/* GEOPHS(6) = SO: High altitude bound for atmospheric */
/* model in km. */
/* GEOPHS(7) = RE: Equatorial radius of the earth in km. */
/* GEOPHS(8) = AE: Distance units/earth radius */
/* (normally 1) */
/* Below are currently recommended values for these */
/* items: */
/* J2 = 1.082616D-3 */
/* J3 = -2.53881D-6 */
/* J4 = -1.65597D-6 */
/* The next item is the square root of GM for the */
/* earth given in units of earth-radii**1.5/Minute */
/* KE = 7.43669161D-2 */
/* The next two items define the top and */
/* bottom of the atmospheric drag model */
/* used by the type 10 ephemeris type. */
/* Don't adjust these unless you understand */
/* the full implications of such changes. */
/* QO = 120.0D0 */
/* SO = 78.0D0 */
/* The ER value is the equatorial radius in km */
/* of the earth as used by NORAD. */
/* ER = 6378.135D0 */
/* The value of AE is the number of */
/* distance units per earth radii used by */
/* the NORAD state propagation software. */
/* The value is 1 unless you've got */
/* a very good understanding of the NORAD */
/* routine SGP4 and the affect of changing */
/* this value.. */
/* AE = 1.0D0 */
/* ELEMS is an array containing two-line element data */
/* as prescribed below. The elements XNDD6O and BSTAR */
/* must have been scaled by the proper exponent stored */
/* in the two line elements set. Moreover, the */
/* various items must be converted to the units shown */
/* here. */
/* ELEMS ( 1 ) = XNDT2O in radians/minute**2 */
/* ELEMS ( 2 ) = XNDD6O in radians/minute**3 */
/* ELEMS ( 3 ) = BSTAR */
/* ELEMS ( 4 ) = XINCL in radians */
/* ELEMS ( 5 ) = XNODEO in radians */
/* ELEMS ( 6 ) = EO */
/* ELEMS ( 7 ) = OMEGAO in radians */
/* ELEMS ( 8 ) = XMO in radians */
/* ELEMS ( 9 ) = XNO in radians/minute */
/* ELEMS ( 10 ) = EPOCH of the elements in seconds */
/* past ephemeris epoch J2000. */
/* $ Detailed_Output */
/* STATE A 6 vector containing the X, Y, Z, Vx, Vy, Vz */
/* coordinates in the inertial frame (double */
/* precision). */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Error free. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This subroutine is an extensive rewrite of the SDP4 */
/* routine as described in the Spacetrack 3 report. All common */
/* blocks were removed and all variables are explicitly defined. */
/* The removal of common blocks causes the set of routines to */
/* execute slower than the original version of SDP4. However the */
/* stability improves especially as concerns memory and */
/* expanded internal documentation. */
/* Trivial or redundant variables have been eliminated. */
/* R removed, occurrence replaced with RK */
/* E6A renamed TOL */
/* THETA4 removed, relevant equation recast in Horner's form */
/* i.e. something like x^4 + x^2 -> x^2 ( x^2 + 1 ) */
/* U renamed UANG, U is now a euclidean 3 vector. */
/* Ux,Uy,Uz removed, replaced with 3-vector U */
/* Vx,Vy,Vz removed, replaced with 3-vector V */
/* OMEGAQ removed, usage replaced with OMEGAO */
/* OMGDT removed, same variable as OMGDOT, so all occurrences */
/* replaced with OMGDOT */
/* SSL,SSG replaced with the 5-vector SSX */
/* SSH,SSE */
/* SSI */
/* Three functions present in the original Spacetrack report, ACTAN, */
/* FMOD2P and THETAG, have been either replaced with an intrinsic */
/* FORTRAN function (ACTAN -> DATAN2, FMOD2P -> DMOD) or recoded */
/* using SPICELIB calls (THETAG). */
/* The code at the end of this subroutine which calculates */
/* orientation vectors, was replaced with a set of calls to */
/* SPICELIB vector routines. */
/* A direct comparison of output from the original Spacetrack 3 code */
/* and these NAIF routines for the same elements and time parameters */
/* will produce unacceptably different results. */
/* $ Examples */
/* C--- Load the geophysical constants kernel and the leapsecond */
/* kernel */
/* CALL FURNSH( '/Users/ewright/lib/geophysical.ker' ) */
/* CALL FURNSH( '/kernels/gen/lsk/naif0008.tls' ) */
/* C--- Define a vehicle element array, TDRS 4 Geosynch */
/* LINES( 1 ) = '1 19883U 89021B 97133.05943164 -.00000277 ' */
/* .// '00000-0 10000-3 0 3315' */
/* LINES( 2 ) = '2 19883 0.5548 86.7278 0001786 312.2904 ' */
/* .// '172.2391 1.00269108202415' */
/* C--- Identify the earliest first year for the elements */
/* FRSTYR = 1988 */
/* C--- Parse the elements to something SPICE can use */
/* CALL GETELM ( FRSTYR, LINES, EPOCH, ELEMS ) */
/* C--- Final time past epoch, 1400 mins (in seconds) */
/* TF = 1440.D0 * 60.D0 */
/* C--- Step size for elements output 360 mins (in seconds) */
/* DELT = 360.D0 * 60.D0 */
/* C--- Start time keyed off epoch */
/* TIME = EPOCH - 2.D0 * DELT */
/* DO WHILE ( DABS(TIME - EPOCH) .LE. DABS(TF) ) */
/* CALL DPSPCE ( TIME, GEOPHS, ELEMS, STATE ) */
/* WRITE(*, FMT ='(7F17.8)' ) (TIME-EPOCH)/60.D0, */
/* . (STATE(I),I=1,6) */
/* TIME = TIME + DELT */
/* END DO */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* Hoots, Felix R., Ronald L. Roehrich (31 December 1988). "Models */
/* for Propagation of NORAD Element Sets". United States Department */
/* of Defense Spacetrack Report (3). */
/* $ Author_and_Institution */
/* E.D. Wright (JPL) */
/* $ Version */
/* - SPICELIB Version 2.0.0, 23-JAN-2013 (EDW) */
/* Corrected initialization block error. The ZZDPINIT call */
/* causes a side-effect required for each DPSPCE call. */
/* The ZZDPINIT call now occurs outside the initialization */
/* block. Note from designer, side-effects are bad. */
/* Added proper citation for Hoots paper. */
/* - SPICELIB Version 1.2.2, 22-AUG-2006 (EDW) */
/* Replaced references to LDPOOL with references */
/* to FURNSH. */
/* - SPICELIB Version 1.2.1, DEC-27-2000 (EDW) */
/* Corrected error in header documentation. Horner's Rule */
/* not Butcher's. */
/* - SPICELIB Version 1.2.0, MAR-24-1999 (EDW) */
/* Documentation expanded to include modifications made */
/* to private routines. Some english errors corrected. */
/* Alphabetized variable declaration lists. */
/* Temporary variable TEMP removed. OMGDOT argument added to */
/* ZZDPSEC call. */
/* - SPICELIB Version 1.1.0, OCT-05-1998 (WLT) */
/* Forced initialization section until we can figure out */
/* why it doesn't work on SUNs. */
/* - SPICELIB Version 1.0.1, MAR-11-1998 (EDW) */
/* Corrected error in header describing GEOPHS array. */
/* - SPICELIB Version 1.0.0, NOV-11-1998 (EDW) */
/* -& */
/* $ Index_Entries */
/* NORAD two line elements deep space evaluator */
/* -& */
/* Local variables */
/* Define parameters for convergence tolerance and the value for 2/3, */
/* 0 and 1. */
/* The geophysical Quantities */
/* Elements */
/* Other quantities */
/* SPICELIB routines */
/* Save everything. */
/* Set initialization flags */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("DPSPCE", (ftnlen)6);
}
/* If this is the very first time into this routine, set these */
/* values. */
if (first) {
pix2 = twopi_();
pio2 = halfpi_();
first = FALSE_;
}
/* If initialization flag is FALSE, then this is not the first */
/* call to this routine. Check the stuff. */
if (! doinit) {
/* Check whether the current and last constants and elements */
/* match. If not, we need to reinitialize everything */
/* since the propagation is dependent on the value of these */
/* arrays. */
for (i__ = 1; i__ <= 8; ++i__) {
if (lstphs[(i__1 = i__ - 1) < 8 && 0 <= i__1 ? i__1 : s_rnge(
"lstphs", i__1, "dpspce_", (ftnlen)547)] != geophs[(i__2 =
i__ - 1) < 8 && 0 <= i__2 ? i__2 : s_rnge("geophs", i__2,
"dpspce_", (ftnlen)547)]) {
doinit = TRUE_;
}
}
for (i__ = 1; i__ <= 10; ++i__) {
if (lstelm[(i__1 = i__ - 1) < 10 && 0 <= i__1 ? i__1 : s_rnge(
"lstelm", i__1, "dpspce_", (ftnlen)556)] != elems[(i__2 =
i__ - 1) < 10 && 0 <= i__2 ? i__2 : s_rnge("elems", i__2,
"dpspce_", (ftnlen)556)]) {
doinit = TRUE_;
}
}
}
/* Initialization block. Always called on the initial entry and */
/* anytime the geophysical or elements array changes. */
if (doinit) {
doinit = FALSE_;
/* Retrieve the geophysical constants from the GEOPHS array */
xj2 = geophs[0];
xj3 = geophs[1];
xj4 = geophs[2];
xke = geophs[3];
qo = geophs[4];
so = geophs[5];
xkmper = geophs[6];
ae = geophs[7];
/* Save the geophysical constants for later comparison */
for (i__ = 1; i__ <= 8; ++i__) {
lstphs[(i__1 = i__ - 1) < 8 && 0 <= i__1 ? i__1 : s_rnge("lstphs",
i__1, "dpspce_", (ftnlen)590)] = geophs[(i__2 = i__ - 1)
< 8 && 0 <= i__2 ? i__2 : s_rnge("geophs", i__2, "dpspce_"
, (ftnlen)590)];
}
/* Unpack the elements array. */
bstar = elems[2];
xincl = elems[3];
xnodeo = elems[4];
eo = elems[5];
omegao = elems[6];
xmo = elems[7];
xno = elems[8];
epoch = elems[9];
/* Save the elements for later comparison */
for (i__ = 1; i__ <= 10; ++i__) {
lstelm[(i__1 = i__ - 1) < 10 && 0 <= i__1 ? i__1 : s_rnge("lstelm"
, i__1, "dpspce_", (ftnlen)610)] = elems[(i__2 = i__ - 1)
< 10 && 0 <= i__2 ? i__2 : s_rnge("elems", i__2, "dpspce_"
, (ftnlen)610)];
}
/* Set common variables, the init flag and calculate the */
/* WGS-72 physical and geopotential constants */
/* CK2 = 0.5 * J2 * AE^2 */
/* CK4 = -0.375 * J4 * AE^4 */
/* These are values calculated only once and then saved for */
/* future access. */
/* Computing 2nd power */
d__1 = ae;
ck2 = xj2 * .5 * (d__1 * d__1);
/* Computing 4th power */
d__1 = ae, d__1 *= d__1;
ck4 = xj4 * -.375 * (d__1 * d__1);
/* Computing 4th power */
d__1 = (qo - so) * ae / xkmper, d__1 *= d__1;
qoms2t = d__1 * d__1;
s = ae * (so / xkmper + 1.);
/* Recover original mean motion (XNODP) and semimajor axis (AODP) */
/* from input elements */
d__1 = xke / xno;
a1 = pow_dd(&d__1, &c_b19);
cosio = cos(xincl);
/* Computing 2nd power */
d__1 = cosio;
theta2 = d__1 * d__1;
x3thm1 = theta2 * 3. - 1.;
/* Computing 2nd power */
d__1 = eo;
betao2 = 1. - d__1 * d__1;
betao = sqrt(betao2);
/* Computing 2nd power */
d__1 = a1;
del1 = ck2 * 1.5 * x3thm1 / (d__1 * d__1 * betao * betao2);
ao = a1 * (1. - del1 * (del1 * (del1 * 1.654320987654321 + 1.) +
.33333333333333331));
/* Computing 2nd power */
d__1 = ao;
delo = ck2 * 1.5 * x3thm1 / (d__1 * d__1 * betao * betao2);
xnodp = xno / (delo + 1.);
aodp = ao / (1. - delo);
/* For perigee below 156 km, the values of S and QOMS2T are */
/* altered */
s4 = s;
qoms24 = qoms2t;
perige = (aodp * (1. - eo) - ae) * xkmper;
if (perige < 156.) {
s4 = perige - 78.;
if (perige > 98.) {
/* Computing 4th power */
d__1 = (120. - s4) * ae / xkmper, d__1 *= d__1;
qoms24 = d__1 * d__1;
s4 = s4 / xkmper + ae;
} else {
s4 = 20.;
}
}
/* Computing 2nd power */
d__1 = aodp;
/* Computing 2nd power */
d__2 = betao2;
pinvsq = 1. / (d__1 * d__1 * (d__2 * d__2));
tsi = 1. / (aodp - s4);
eta = aodp * eo * tsi;
/* Computing 2nd power */
d__1 = eta;
etasq = d__1 * d__1;
eeta = eo * eta;
psisq = (d__1 = 1. - etasq, abs(d__1));
/* Computing 4th power */
d__1 = tsi, d__1 *= d__1;
coef = qoms24 * (d__1 * d__1);
coef1 = coef / pow_dd(&psisq, &c_b20);
c2 = coef1 * xnodp * (aodp * (etasq * 1.5 + 1. + eeta * (etasq + 4.))
+ ck2 * .75 * tsi / psisq * x3thm1 * (etasq * 3. * (etasq +
8.) + 8.));
c1 = bstar * c2;
sinio = sin(xincl);
/* Computing 3rd power */
d__1 = ae;
a3ovk2 = -xj3 / ck2 * (d__1 * (d__1 * d__1));
x1mth2 = 1. - theta2;
c4 = xnodp * 2. * coef1 * aodp * betao2 * (eta * (etasq * .5 + 2.) +
eo * (etasq * 2. + .5) - ck2 * 2. * tsi / (aodp * psisq) * (
x3thm1 * -3. * (1. - eeta * 2. + etasq * (1.5 - eeta * .5)) +
x1mth2 * .75 * (etasq * 2. - eeta * (etasq + 1.)) * cos(
omegao * 2.)));
temp1 = ck2 * 3. * pinvsq * xnodp;
temp2 = temp1 * ck2 * pinvsq;
temp3 = ck4 * 1.25 * pinvsq * pinvsq * xnodp;
xmdot = xnodp + temp1 * .5 * betao * x3thm1 + temp2 * .0625 * betao *
(theta2 * (theta2 * 137. - 78.) + 13.);
x1m5th = 1. - theta2 * 5.;
omgdot = temp1 * -.5 * x1m5th + temp2 * .0625 * (theta2 * (theta2 *
395. - 114.) + 7.) + temp3 * (theta2 * (theta2 * 49. - 36.) +
3.);
xhdot1 = -temp1 * cosio;
xnodot = xhdot1 + (temp2 * .5 * (4. - theta2 * 19.) + temp3 * 2. * (
3. - theta2 * 7.)) * cosio;
xnodcf = betao2 * 3.5 * xhdot1 * c1;
t2cof = c1 * 1.5;
xlcof = a3ovk2 * .125 * sinio * (cosio * 5. + 3.) / (cosio + 1.);
aycof = a3ovk2 * .25 * sinio;
x7thm1 = theta2 * 7. - 1.;
}
zzdpinit_(&aodp, &xmdot, &omgdot, &xnodot, &xnodp, elems);
/* Get the time since the EPOCH in minutes. */
tsince = (*time - epoch) / 60.;
/* Update for secular gravity and atmospheric drag */
xmdf = xmo + xmdot * tsince;
omgadf = omegao + omgdot * tsince;
xnoddf = xnodeo + xnodot * tsince;
tsq = tsince * tsince;
xnode = xnoddf + xnodcf * tsq;
tempa = 1. - c1 * tsince;
tempe = bstar * c4 * tsince;
templ = t2cof * tsq;
xn = xnodp;
/* Calculate the secular terms. */
zzdpsec_(&xmdf, &omgadf, &xnode, &em, &xinc, &xn, &tsince, elems, &omgdot)
;
d__1 = xke / xn;
/* Computing 2nd power */
d__2 = tempa;
a = pow_dd(&d__1, &c_b19) * (d__2 * d__2);
e = em - tempe;
xmam = xmdf + xnodp * templ;
/* Calculate the periodic terms. */
zzdpper_(&tsince, &e, &xinc, &omgadf, &xnode, &xmam);
xl = xmam + omgadf + xnode;
xn = xke / pow_dd(&a, &c_b22);
/* Long period periodics */
axn = e * cos(omgadf);
/* Computing 2nd power */
d__1 = e;
temp = 1. / (a * (1. - d__1 * d__1));
xll = temp * xlcof * axn;
aynl = temp * aycof;
xlt = xl + xll;
ayn = e * sin(omgadf) + aynl;
/* Solve Kepler's equation */
/* U = EPW - AXN * SIN(EPW) + AYN * COS(EPW) */
/* Where */
/* AYN = E * SIN(OMEGA) + AYNL */
/* AXN = E * COS(OMEGA) */
/* And */
/* AYNL = -0.50D0 * SINIO * AE * J3 / (J2 * A * (1.0D0 - E^2)) */
/* Get the mod division of CAPU with 2 Pi */
d__1 = xlt - xnode;
capu = d_mod(&d__1, &pix2);
if (capu < 0.) {
capu += pix2;
}
/* Set initial states for the Kepler solution */
epw = capu;
cont = TRUE_;
while(cont) {
temp2 = epw;
sinepw = sin(temp2);
cosepw = cos(temp2);
temp3 = axn * sinepw;
temp4 = ayn * cosepw;
temp5 = axn * cosepw;
temp6 = ayn * sinepw;
epw = (capu - temp4 + temp3 - temp2) / (1. - temp5 - temp6) + temp2;
/* Test for convergence against the defined tolerance */
if ((d__1 = epw - temp2, abs(d__1)) <= 1e-6) {
cont = FALSE_;
}
}
/* Short period preliminary quantities */
ecose = temp5 + temp6;
esine = temp3 - temp4;
elsq = axn * axn + ayn * ayn;
temp = 1. - elsq;
pl = a * temp;
rk = a * (1. - ecose);
temp1 = 1. / rk;
rdot = xke * sqrt(a) * esine * temp1;
rfdot = xke * sqrt(pl) * temp1;
temp2 = a * temp1;
betal = sqrt(temp);
temp3 = 1. / (betal + 1.);
cosu = temp2 * (cosepw - axn + ayn * esine * temp3);
sinu = temp2 * (sinepw - ayn - axn * esine * temp3);
/* Compute the angle from the x-axis of the point ( COSU, SINU ) */
if (sinu != 0. || cosu != 0.) {
uang = atan2(sinu, cosu);
if (uang < 0.) {
uang += pix2;
}
} else {
uang = 0.;
}
sin2u = sinu * 2. * cosu;
cos2u = cosu * 2. * cosu - 1.;
temp1 = ck2 * (1. / pl);
temp2 = temp1 * (1. / pl);
/* Update for short periodics */
rk = rk * (1. - temp2 * 1.5 * betal * x3thm1) + temp1 * .5 * x1mth2 *
cos2u;
uk = uang - temp2 * .25 * x7thm1 * sin2u;
xnodek = xnode + temp2 * 1.5 * cosio * sin2u;
xinck = xinc + temp2 * 1.5 * cosio * sinio * cos2u;
rdotk = rdot - xn * temp1 * x1mth2 * sin2u;
rfdotk = rfdot + xn * temp1 * (x1mth2 * cos2u + x3thm1 * 1.5);
/* Orientation vectors are calculated by */
/* U = M sin(uk) + N cos(uk) */
/* V = M cos(uk) - N sin(uk) */
/* Where M and N are euclidean 3 vectors */
/* M = (-sin(xnodek)cos(xinck), cos(xnodek)cos(xinck), sin(xinck) ) */
/* N = ( cos(xnodek), sin(xnodek) , 0 ) */
sinuk = sin(uk);
cosuk = cos(uk);
/* Use LATREC to generate M and N. M is a latitude to rectangle */
/* conversion of a unit vector where PI/2 + XNODEK is the longitude */
d__1 = pio2 + xnodek;
latrec_(&c_b23, &d__1, &xinck, m);
latrec_(&c_b23, &xnodek, &c_b25, n);
/* Sum the components to obtain U and V */
vlcom_(&sinuk, m, &cosuk, n, u);
d__1 = -sinuk;
vlcom_(&cosuk, m, &d__1, n, v);
/* Determine the position and velocity then pack the STATE vector */
/* with value scaled to KM and KPS. */
/* R = RK U + 0 V */
/* V = RKDOT U + RK RFDOT V */
scale = xkmper / ae;
d__1 = rk * scale;
vlcom_(&d__1, u, &c_b25, v, state);
/* Now scale to KPS for the velocity component */
scale /= 60.;
d__1 = rdotk * scale;
d__2 = rfdotk * scale;
vlcom_(&d__1, u, &d__2, v, &state[3]);
/* All done now.... */
chkout_("DPSPCE", (ftnlen)6);
return 0;
} /* dpspce_ */
/* Subroutine */ int zbdsqr_(char *uplo, integer *n, integer *ncvt, integer *
nru, integer *ncc, doublereal *d__, doublereal *e, doublecomplex *vt,
integer *ldvt, doublecomplex *u, integer *ldu, doublecomplex *c__,
integer *ldc, doublereal *rwork, integer *info)
{
/* System generated locals */
integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1,
i__2;
doublereal d__1, d__2, d__3, d__4;
/* Builtin functions */
double pow_dd(doublereal *, doublereal *), sqrt(doublereal), d_sign(
doublereal *, doublereal *);
/* Local variables */
static doublereal abse;
static integer idir;
static doublereal abss;
static integer oldm;
static doublereal cosl;
static integer isub, iter;
static doublereal unfl, sinl, cosr, smin, smax, sinr;
extern /* Subroutine */ int dlas2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *);
static doublereal f, g, h__;
static integer i__, j, m;
static doublereal r__;
extern logical lsame_(char *, char *);
static doublereal oldcs;
static integer oldll;
static doublereal shift, sigmn, oldsn;
static integer maxit;
static doublereal sminl, sigmx;
static logical lower;
extern /* Subroutine */ int zlasr_(char *, char *, char *, integer *,
integer *, doublereal *, doublereal *, doublecomplex *, integer *), zdrot_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *)
, zswap_(integer *, doublecomplex *, integer *, doublecomplex *,
integer *), dlasq1_(integer *, doublereal *, doublereal *,
doublereal *, integer *), dlasv2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
static doublereal cs;
static integer ll;
extern doublereal dlamch_(char *);
static doublereal sn, mu;
extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *), xerbla_(char *,
integer *), zdscal_(integer *, doublereal *,
doublecomplex *, integer *);
static doublereal sminoa, thresh;
static logical rotate;
static doublereal sminlo;
static integer nm1;
static doublereal tolmul;
static integer nm12, nm13, lll;
static doublereal eps, sll, tol;
#define c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1
#define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)]
#define u_subscr(a_1,a_2) (a_2)*u_dim1 + a_1
#define u_ref(a_1,a_2) u[u_subscr(a_1,a_2)]
#define vt_subscr(a_1,a_2) (a_2)*vt_dim1 + a_1
#define vt_ref(a_1,a_2) vt[vt_subscr(a_1,a_2)]
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1999
Purpose
=======
ZBDSQR computes the singular value decomposition (SVD) of a real
N-by-N (upper or lower) bidiagonal matrix B: B = Q * S * P' (P'
denotes the transpose of P), where S is a diagonal matrix with
non-negative diagonal elements (the singular values of B), and Q
and P are orthogonal matrices.
The routine computes S, and optionally computes U * Q, P' * VT,
or Q' * C, for given complex input matrices U, VT, and C.
See "Computing Small Singular Values of Bidiagonal Matrices With
Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,
no. 5, pp. 873-912, Sept 1990) and
"Accurate singular values and differential qd algorithms," by
B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics
Department, University of California at Berkeley, July 1992
for a detailed description of the algorithm.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': B is upper bidiagonal;
= 'L': B is lower bidiagonal.
N (input) INTEGER
The order of the matrix B. N >= 0.
NCVT (input) INTEGER
The number of columns of the matrix VT. NCVT >= 0.
NRU (input) INTEGER
The number of rows of the matrix U. NRU >= 0.
NCC (input) INTEGER
The number of columns of the matrix C. NCC >= 0.
D (input/output) DOUBLE PRECISION array, dimension (N)
On entry, the n diagonal elements of the bidiagonal matrix B.
On exit, if INFO=0, the singular values of B in decreasing
order.
E (input/output) DOUBLE PRECISION array, dimension (N)
On entry, the elements of E contain the
offdiagonal elements of of the bidiagonal matrix whose SVD
is desired. On normal exit (INFO = 0), E is destroyed.
If the algorithm does not converge (INFO > 0), D and E
will contain the diagonal and superdiagonal elements of a
bidiagonal matrix orthogonally equivalent to the one given
as input. E(N) is used for workspace.
VT (input/output) COMPLEX*16 array, dimension (LDVT, NCVT)
On entry, an N-by-NCVT matrix VT.
On exit, VT is overwritten by P' * VT.
VT is not referenced if NCVT = 0.
LDVT (input) INTEGER
The leading dimension of the array VT.
LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.
U (input/output) COMPLEX*16 array, dimension (LDU, N)
On entry, an NRU-by-N matrix U.
On exit, U is overwritten by U * Q.
U is not referenced if NRU = 0.
LDU (input) INTEGER
The leading dimension of the array U. LDU >= max(1,NRU).
C (input/output) COMPLEX*16 array, dimension (LDC, NCC)
On entry, an N-by-NCC matrix C.
On exit, C is overwritten by Q' * C.
C is not referenced if NCC = 0.
LDC (input) INTEGER
The leading dimension of the array C.
LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.
RWORK (workspace) DOUBLE PRECISION array, dimension (4*N)
INFO (output) INTEGER
= 0: successful exit
< 0: If INFO = -i, the i-th argument had an illegal value
> 0: the algorithm did not converge; D and E contain the
elements of a bidiagonal matrix which is orthogonally
similar to the input matrix B; if INFO = i, i
elements of E have not converged to zero.
Internal Parameters
===================
TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8)))
TOLMUL controls the convergence criterion of the QR loop.
If it is positive, TOLMUL*EPS is the desired relative
precision in the computed singular values.
If it is negative, abs(TOLMUL*EPS*sigma_max) is the
desired absolute accuracy in the computed singular
values (corresponds to relative accuracy
abs(TOLMUL*EPS) in the largest singular value.
abs(TOLMUL) should be between 1 and 1/EPS, and preferably
between 10 (for fast convergence) and .1/EPS
(for there to be some accuracy in the results).
Default is to lose at either one eighth or 2 of the
available decimal digits in each computed singular value
(whichever is smaller).
MAXITR INTEGER, default = 6
MAXITR controls the maximum number of passes of the
algorithm through its inner loop. The algorithms stops
(and so fails to converge) if the number of passes
through the inner loop exceeds MAXITR*N**2.
=====================================================================
Test the input parameters.
Parameter adjustments */
--d__;
--e;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1 * 1;
vt -= vt_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
--rwork;
/* Function Body */
*info = 0;
lower = lsame_(uplo, "L");
if (! lsame_(uplo, "U") && ! lower) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ncvt < 0) {
*info = -3;
} else if (*nru < 0) {
*info = -4;
} else if (*ncc < 0) {
*info = -5;
} else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < max(1,*n)) {
*info = -9;
} else if (*ldu < max(1,*nru)) {
*info = -11;
} else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < max(1,*n)) {
*info = -13;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZBDSQR", &i__1);
return 0;
}
if (*n == 0) {
return 0;
}
if (*n == 1) {
goto L160;
}
/* ROTATE is true if any singular vectors desired, false otherwise */
rotate = *ncvt > 0 || *nru > 0 || *ncc > 0;
/* If no singular vectors desired, use qd algorithm */
if (! rotate) {
dlasq1_(n, &d__[1], &e[1], &rwork[1], info);
return 0;
}
nm1 = *n - 1;
nm12 = nm1 + nm1;
nm13 = nm12 + nm1;
idir = 0;
/* Get machine constants */
eps = dlamch_("Epsilon");
unfl = dlamch_("Safe minimum");
/* If matrix lower bidiagonal, rotate to be upper bidiagonal
by applying Givens rotations on the left */
if (lower) {
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
d__[i__] = r__;
e[i__] = sn * d__[i__ + 1];
d__[i__ + 1] = cs * d__[i__ + 1];
rwork[i__] = cs;
rwork[nm1 + i__] = sn;
/* L10: */
}
/* Update singular vectors if desired */
if (*nru > 0) {
zlasr_("R", "V", "F", nru, n, &rwork[1], &rwork[*n], &u[u_offset],
ldu);
}
if (*ncc > 0) {
zlasr_("L", "V", "F", n, ncc, &rwork[1], &rwork[*n], &c__[
c_offset], ldc);
}
}
/* Compute singular values to relative accuracy TOL
(By setting TOL to be negative, algorithm will compute
singular values to absolute accuracy ABS(TOL)*norm(input matrix))
Computing MAX
Computing MIN */
d__3 = 100., d__4 = pow_dd(&eps, &c_b15);
d__1 = 10., d__2 = min(d__3,d__4);
tolmul = max(d__1,d__2);
tol = tolmul * eps;
/* Compute approximate maximum, minimum singular values */
smax = 0.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = smax, d__3 = (d__1 = d__[i__], abs(d__1));
smax = max(d__2,d__3);
/* L20: */
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = smax, d__3 = (d__1 = e[i__], abs(d__1));
smax = max(d__2,d__3);
/* L30: */
}
sminl = 0.;
if (tol >= 0.) {
/* Relative accuracy desired */
sminoa = abs(d__[1]);
if (sminoa == 0.) {
goto L50;
}
mu = sminoa;
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
mu = (d__2 = d__[i__], abs(d__2)) * (mu / (mu + (d__1 = e[i__ - 1]
, abs(d__1))));
sminoa = min(sminoa,mu);
if (sminoa == 0.) {
goto L50;
}
/* L40: */
}
L50:
sminoa /= sqrt((doublereal) (*n));
/* Computing MAX */
d__1 = tol * sminoa, d__2 = *n * 6 * *n * unfl;
thresh = max(d__1,d__2);
} else {
/* Absolute accuracy desired
Computing MAX */
d__1 = abs(tol) * smax, d__2 = *n * 6 * *n * unfl;
thresh = max(d__1,d__2);
}
/* Prepare for main iteration loop for the singular values
(MAXIT is the maximum number of passes through the inner
loop permitted before nonconvergence signalled.) */
maxit = *n * 6 * *n;
iter = 0;
oldll = -1;
oldm = -1;
/* M points to last element of unconverged part of matrix */
m = *n;
/* Begin main iteration loop */
L60:
/* Check for convergence or exceeding iteration count */
if (m <= 1) {
goto L160;
}
if (iter > maxit) {
goto L200;
}
/* Find diagonal block of matrix to work on */
if (tol < 0. && (d__1 = d__[m], abs(d__1)) <= thresh) {
d__[m] = 0.;
}
smax = (d__1 = d__[m], abs(d__1));
smin = smax;
i__1 = m - 1;
for (lll = 1; lll <= i__1; ++lll) {
ll = m - lll;
abss = (d__1 = d__[ll], abs(d__1));
abse = (d__1 = e[ll], abs(d__1));
if (tol < 0. && abss <= thresh) {
d__[ll] = 0.;
}
if (abse <= thresh) {
goto L80;
}
smin = min(smin,abss);
/* Computing MAX */
d__1 = max(smax,abss);
smax = max(d__1,abse);
/* L70: */
}
ll = 0;
goto L90;
L80:
e[ll] = 0.;
/* Matrix splits since E(LL) = 0 */
if (ll == m - 1) {
/* Convergence of bottom singular value, return to top of loop */
--m;
goto L60;
}
L90:
++ll;
/* E(LL) through E(M-1) are nonzero, E(LL-1) is zero */
if (ll == m - 1) {
/* 2 by 2 block, handle separately */
dlasv2_(&d__[m - 1], &e[m - 1], &d__[m], &sigmn, &sigmx, &sinr, &cosr,
&sinl, &cosl);
d__[m - 1] = sigmx;
e[m - 1] = 0.;
d__[m] = sigmn;
/* Compute singular vectors, if desired */
if (*ncvt > 0) {
zdrot_(ncvt, &vt_ref(m - 1, 1), ldvt, &vt_ref(m, 1), ldvt, &cosr,
&sinr);
}
if (*nru > 0) {
zdrot_(nru, &u_ref(1, m - 1), &c__1, &u_ref(1, m), &c__1, &cosl, &
sinl);
}
if (*ncc > 0) {
zdrot_(ncc, &c___ref(m - 1, 1), ldc, &c___ref(m, 1), ldc, &cosl, &
sinl);
}
m += -2;
goto L60;
}
/* If working on new submatrix, choose shift direction
(from larger end diagonal element towards smaller) */
if (ll > oldm || m < oldll) {
if ((d__1 = d__[ll], abs(d__1)) >= (d__2 = d__[m], abs(d__2))) {
/* Chase bulge from top (big end) to bottom (small end) */
idir = 1;
} else {
/* Chase bulge from bottom (big end) to top (small end) */
idir = 2;
}
}
/* Apply convergence tests */
if (idir == 1) {
/* Run convergence test in forward direction
First apply standard test to bottom of matrix */
if ((d__2 = e[m - 1], abs(d__2)) <= abs(tol) * (d__1 = d__[m], abs(
d__1)) || tol < 0. && (d__3 = e[m - 1], abs(d__3)) <= thresh)
{
e[m - 1] = 0.;
goto L60;
}
if (tol >= 0.) {
/* If relative accuracy desired,
apply convergence criterion forward */
mu = (d__1 = d__[ll], abs(d__1));
sminl = mu;
i__1 = m - 1;
for (lll = ll; lll <= i__1; ++lll) {
if ((d__1 = e[lll], abs(d__1)) <= tol * mu) {
e[lll] = 0.;
goto L60;
}
sminlo = sminl;
mu = (d__2 = d__[lll + 1], abs(d__2)) * (mu / (mu + (d__1 = e[
lll], abs(d__1))));
sminl = min(sminl,mu);
/* L100: */
}
}
} else {
/* Run convergence test in backward direction
First apply standard test to top of matrix */
if ((d__2 = e[ll], abs(d__2)) <= abs(tol) * (d__1 = d__[ll], abs(d__1)
) || tol < 0. && (d__3 = e[ll], abs(d__3)) <= thresh) {
e[ll] = 0.;
goto L60;
}
if (tol >= 0.) {
/* If relative accuracy desired,
apply convergence criterion backward */
mu = (d__1 = d__[m], abs(d__1));
sminl = mu;
i__1 = ll;
for (lll = m - 1; lll >= i__1; --lll) {
if ((d__1 = e[lll], abs(d__1)) <= tol * mu) {
e[lll] = 0.;
goto L60;
}
sminlo = sminl;
mu = (d__2 = d__[lll], abs(d__2)) * (mu / (mu + (d__1 = e[lll]
, abs(d__1))));
sminl = min(sminl,mu);
/* L110: */
}
}
}
oldll = ll;
oldm = m;
/* Compute shift. First, test if shifting would ruin relative
accuracy, and if so set the shift to zero.
Computing MAX */
d__1 = eps, d__2 = tol * .01;
if (tol >= 0. && *n * tol * (sminl / smax) <= max(d__1,d__2)) {
/* Use a zero shift to avoid loss of relative accuracy */
shift = 0.;
} else {
/* Compute the shift from 2-by-2 block at end of matrix */
if (idir == 1) {
sll = (d__1 = d__[ll], abs(d__1));
dlas2_(&d__[m - 1], &e[m - 1], &d__[m], &shift, &r__);
} else {
sll = (d__1 = d__[m], abs(d__1));
dlas2_(&d__[ll], &e[ll], &d__[ll + 1], &shift, &r__);
}
/* Test if shift negligible, and if so set to zero */
if (sll > 0.) {
/* Computing 2nd power */
d__1 = shift / sll;
if (d__1 * d__1 < eps) {
shift = 0.;
}
}
}
/* Increment iteration count */
iter = iter + m - ll;
/* If SHIFT = 0, do simplified QR iteration */
if (shift == 0.) {
if (idir == 1) {
/* Chase bulge from top to bottom
Save cosines and sines for later singular vector updates */
cs = 1.;
oldcs = 1.;
i__1 = m - 1;
for (i__ = ll; i__ <= i__1; ++i__) {
d__1 = d__[i__] * cs;
dlartg_(&d__1, &e[i__], &cs, &sn, &r__);
if (i__ > ll) {
e[i__ - 1] = oldsn * r__;
}
d__1 = oldcs * r__;
d__2 = d__[i__ + 1] * sn;
dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]);
rwork[i__ - ll + 1] = cs;
rwork[i__ - ll + 1 + nm1] = sn;
rwork[i__ - ll + 1 + nm12] = oldcs;
rwork[i__ - ll + 1 + nm13] = oldsn;
/* L120: */
}
h__ = d__[m] * cs;
d__[m] = h__ * oldcs;
e[m - 1] = h__ * oldsn;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
zlasr_("L", "V", "F", &i__1, ncvt, &rwork[1], &rwork[*n], &
vt_ref(ll, 1), ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
zlasr_("R", "V", "F", nru, &i__1, &rwork[nm12 + 1], &rwork[
nm13 + 1], &u_ref(1, ll), ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
zlasr_("L", "V", "F", &i__1, ncc, &rwork[nm12 + 1], &rwork[
nm13 + 1], &c___ref(ll, 1), ldc);
}
/* Test convergence */
if ((d__1 = e[m - 1], abs(d__1)) <= thresh) {
e[m - 1] = 0.;
}
} else {
/* Chase bulge from bottom to top
Save cosines and sines for later singular vector updates */
cs = 1.;
oldcs = 1.;
i__1 = ll + 1;
for (i__ = m; i__ >= i__1; --i__) {
d__1 = d__[i__] * cs;
dlartg_(&d__1, &e[i__ - 1], &cs, &sn, &r__);
if (i__ < m) {
e[i__] = oldsn * r__;
}
d__1 = oldcs * r__;
d__2 = d__[i__ - 1] * sn;
dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]);
rwork[i__ - ll] = cs;
rwork[i__ - ll + nm1] = -sn;
rwork[i__ - ll + nm12] = oldcs;
rwork[i__ - ll + nm13] = -oldsn;
/* L130: */
}
h__ = d__[ll] * cs;
d__[ll] = h__ * oldcs;
e[ll] = h__ * oldsn;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
zlasr_("L", "V", "B", &i__1, ncvt, &rwork[nm12 + 1], &rwork[
nm13 + 1], &vt_ref(ll, 1), ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
zlasr_("R", "V", "B", nru, &i__1, &rwork[1], &rwork[*n], &
u_ref(1, ll), ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
zlasr_("L", "V", "B", &i__1, ncc, &rwork[1], &rwork[*n], &
c___ref(ll, 1), ldc);
}
/* Test convergence */
if ((d__1 = e[ll], abs(d__1)) <= thresh) {
e[ll] = 0.;
}
}
} else {
/* Use nonzero shift */
if (idir == 1) {
/* Chase bulge from top to bottom
Save cosines and sines for later singular vector updates */
f = ((d__1 = d__[ll], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[
ll]) + shift / d__[ll]);
g = e[ll];
i__1 = m - 1;
for (i__ = ll; i__ <= i__1; ++i__) {
dlartg_(&f, &g, &cosr, &sinr, &r__);
if (i__ > ll) {
e[i__ - 1] = r__;
}
f = cosr * d__[i__] + sinr * e[i__];
e[i__] = cosr * e[i__] - sinr * d__[i__];
g = sinr * d__[i__ + 1];
d__[i__ + 1] = cosr * d__[i__ + 1];
dlartg_(&f, &g, &cosl, &sinl, &r__);
d__[i__] = r__;
f = cosl * e[i__] + sinl * d__[i__ + 1];
d__[i__ + 1] = cosl * d__[i__ + 1] - sinl * e[i__];
if (i__ < m - 1) {
g = sinl * e[i__ + 1];
e[i__ + 1] = cosl * e[i__ + 1];
}
rwork[i__ - ll + 1] = cosr;
rwork[i__ - ll + 1 + nm1] = sinr;
rwork[i__ - ll + 1 + nm12] = cosl;
rwork[i__ - ll + 1 + nm13] = sinl;
/* L140: */
}
e[m - 1] = f;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
zlasr_("L", "V", "F", &i__1, ncvt, &rwork[1], &rwork[*n], &
vt_ref(ll, 1), ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
zlasr_("R", "V", "F", nru, &i__1, &rwork[nm12 + 1], &rwork[
nm13 + 1], &u_ref(1, ll), ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
zlasr_("L", "V", "F", &i__1, ncc, &rwork[nm12 + 1], &rwork[
nm13 + 1], &c___ref(ll, 1), ldc);
}
/* Test convergence */
if ((d__1 = e[m - 1], abs(d__1)) <= thresh) {
e[m - 1] = 0.;
}
} else {
/* Chase bulge from bottom to top
Save cosines and sines for later singular vector updates */
f = ((d__1 = d__[m], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[m]
) + shift / d__[m]);
g = e[m - 1];
i__1 = ll + 1;
for (i__ = m; i__ >= i__1; --i__) {
dlartg_(&f, &g, &cosr, &sinr, &r__);
if (i__ < m) {
e[i__] = r__;
}
f = cosr * d__[i__] + sinr * e[i__ - 1];
e[i__ - 1] = cosr * e[i__ - 1] - sinr * d__[i__];
g = sinr * d__[i__ - 1];
d__[i__ - 1] = cosr * d__[i__ - 1];
dlartg_(&f, &g, &cosl, &sinl, &r__);
d__[i__] = r__;
f = cosl * e[i__ - 1] + sinl * d__[i__ - 1];
d__[i__ - 1] = cosl * d__[i__ - 1] - sinl * e[i__ - 1];
if (i__ > ll + 1) {
g = sinl * e[i__ - 2];
e[i__ - 2] = cosl * e[i__ - 2];
}
rwork[i__ - ll] = cosr;
rwork[i__ - ll + nm1] = -sinr;
rwork[i__ - ll + nm12] = cosl;
rwork[i__ - ll + nm13] = -sinl;
/* L150: */
}
e[ll] = f;
/* Test convergence */
if ((d__1 = e[ll], abs(d__1)) <= thresh) {
e[ll] = 0.;
}
/* Update singular vectors if desired */
if (*ncvt > 0) {
i__1 = m - ll + 1;
zlasr_("L", "V", "B", &i__1, ncvt, &rwork[nm12 + 1], &rwork[
nm13 + 1], &vt_ref(ll, 1), ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
zlasr_("R", "V", "B", nru, &i__1, &rwork[1], &rwork[*n], &
u_ref(1, ll), ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
zlasr_("L", "V", "B", &i__1, ncc, &rwork[1], &rwork[*n], &
c___ref(ll, 1), ldc);
}
}
}
/* QR iteration finished, go back and check convergence */
goto L60;
/* All singular values converged, so make them positive */
L160:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (d__[i__] < 0.) {
d__[i__] = -d__[i__];
/* Change sign of singular vectors, if desired */
if (*ncvt > 0) {
zdscal_(ncvt, &c_b72, &vt_ref(i__, 1), ldvt);
}
}
/* L170: */
}
/* Sort the singular values into decreasing order (insertion sort on
singular values, but only one transposition per singular vector) */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Scan for smallest D(I) */
isub = 1;
smin = d__[1];
i__2 = *n + 1 - i__;
for (j = 2; j <= i__2; ++j) {
if (d__[j] <= smin) {
isub = j;
smin = d__[j];
}
/* L180: */
}
if (isub != *n + 1 - i__) {
/* Swap singular values and vectors */
d__[isub] = d__[*n + 1 - i__];
d__[*n + 1 - i__] = smin;
if (*ncvt > 0) {
zswap_(ncvt, &vt_ref(isub, 1), ldvt, &vt_ref(*n + 1 - i__, 1),
ldvt);
}
if (*nru > 0) {
zswap_(nru, &u_ref(1, isub), &c__1, &u_ref(1, *n + 1 - i__), &
c__1);
}
if (*ncc > 0) {
zswap_(ncc, &c___ref(isub, 1), ldc, &c___ref(*n + 1 - i__, 1),
ldc);
}
}
/* L190: */
}
goto L220;
/* Maximum number of iterations exceeded, failure to converge */
L200:
*info = 0;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (e[i__] != 0.) {
++(*info);
}
/* L210: */
}
L220:
return 0;
/* End of ZBDSQR */
} /* zbdsqr_ */
/* DECK CHU */
doublereal chu_(real *a, real *b, real *x)
{
/* Initialized data */
static real pi = 3.14159265358979324f;
static real eps = 0.f;
/* System generated locals */
integer i__1;
real ret_val, r__1, r__2, r__3;
doublereal d__1, d__2;
/* Local variables */
static integer i__, m, n;
static real t, a0, b0, c0, xi, xn, xi1, sum;
extern doublereal gamr_(real *);
static real beps;
extern doublereal poch_(real *, real *);
static real alnx, pch1i;
extern doublereal poch1_(real *, real *), r9chu_(real *, real *, real *);
static real xeps1;
extern doublereal gamma_(real *);
static real aintb;
static integer istrt;
static real pch1ai;
extern doublereal r1mach_(integer *);
static real gamri1, pochai, gamrni, factor;
extern doublereal exprel_(real *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
static real xtoeps;
/* ***BEGIN PROLOGUE CHU */
/* ***PURPOSE Compute the logarithmic confluent hypergeometric function. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C11 */
/* ***TYPE SINGLE PRECISION (CHU-S, DCHU-D) */
/* ***KEYWORDS FNLIB, LOGARITHMIC CONFLUENT HYPERGEOMETRIC FUNCTION, */
/* SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* CHU computes the logarithmic confluent hypergeometric function, */
/* U(A,B,X). */
/* Input Parameters: */
/* A real */
/* B real */
/* X real and positive */
/* This routine is not valid when 1+A-B is close to zero if X is small. */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED EXPREL, GAMMA, GAMR, POCH, POCH1, R1MACH, R9CHU, */
/* XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 770801 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890531 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* 900727 Added EXTERNAL statement. (WRB) */
/* ***END PROLOGUE CHU */
/* ***FIRST EXECUTABLE STATEMENT CHU */
if (eps == 0.f) {
eps = r1mach_(&c__3);
}
if (*x == 0.f) {
xermsg_("SLATEC", "CHU", "X IS ZERO SO CHU IS INFINITE", &c__1, &c__2,
(ftnlen)6, (ftnlen)3, (ftnlen)28);
}
if (*x < 0.f) {
xermsg_("SLATEC", "CHU", "X IS NEGATIVE, USE CCHU", &c__2, &c__2, (
ftnlen)6, (ftnlen)3, (ftnlen)23);
}
/* Computing MAX */
r__2 = dabs(*a);
/* Computing MAX */
r__3 = (r__1 = *a + 1.f - *b, dabs(r__1));
if (dmax(r__2,1.f) * dmax(r__3,1.f) < dabs(*x) * .99f) {
goto L120;
}
/* THE ASCENDING SERIES WILL BE USED, BECAUSE THE DESCENDING RATIONAL */
/* APPROXIMATION (WHICH IS BASED ON THE ASYMPTOTIC SERIES) IS UNSTABLE. */
if ((r__1 = *a + 1.f - *b, dabs(r__1)) < sqrt(eps)) {
xermsg_("SLATEC", "CHU", "ALGORITHM IS BAD WHEN 1+A-B IS NEAR ZERO F"
"OR SMALL X", &c__10, &c__2, (ftnlen)6, (ftnlen)3, (ftnlen)52);
}
r__1 = *b + .5f;
aintb = r_int(&r__1);
if (*b < 0.f) {
r__1 = *b - .5f;
aintb = r_int(&r__1);
}
beps = *b - aintb;
n = aintb;
alnx = log(*x);
xtoeps = exp(-beps * alnx);
/* EVALUATE THE FINITE SUM. ----------------------------------------- */
if (n >= 1) {
goto L40;
}
/* CONSIDER THE CASE B .LT. 1.0 FIRST. */
sum = 1.f;
if (n == 0) {
goto L30;
}
t = 1.f;
m = -n;
i__1 = m;
for (i__ = 1; i__ <= i__1; ++i__) {
xi1 = (real) (i__ - 1);
t = t * (*a + xi1) * *x / ((*b + xi1) * (xi1 + 1.f));
sum += t;
/* L20: */
}
L30:
r__1 = *a + 1.f - *b;
r__2 = -(*a);
sum = poch_(&r__1, &r__2) * sum;
goto L70;
/* NOW CONSIDER THE CASE B .GE. 1.0. */
L40:
sum = 0.f;
m = n - 2;
if (m < 0) {
goto L70;
}
t = 1.f;
sum = 1.f;
if (m == 0) {
goto L60;
}
i__1 = m;
for (i__ = 1; i__ <= i__1; ++i__) {
xi = (real) i__;
t = t * (*a - *b + xi) * *x / ((1.f - *b + xi) * xi);
sum += t;
/* L50: */
}
L60:
r__1 = *b - 1.f;
i__1 = 1 - n;
sum = gamma_(&r__1) * gamr_(a) * pow_ri(x, &i__1) * xtoeps * sum;
/* NOW EVALUATE THE INFINITE SUM. ----------------------------------- */
L70:
istrt = 0;
if (n < 1) {
istrt = 1 - n;
}
xi = (real) istrt;
r__1 = *a + 1.f - *b;
factor = pow_ri(&c_b25, &n) * gamr_(&r__1) * pow_ri(x, &istrt);
if (beps != 0.f) {
factor = factor * beps * pi / sin(beps * pi);
}
pochai = poch_(a, &xi);
r__1 = xi + 1.f;
gamri1 = gamr_(&r__1);
r__1 = aintb + xi;
gamrni = gamr_(&r__1);
r__1 = xi - beps;
r__2 = xi + 1.f - beps;
b0 = factor * poch_(a, &r__1) * gamrni * gamr_(&r__2);
if ((r__1 = xtoeps - 1.f, dabs(r__1)) > .5f) {
goto L90;
}
/* X**(-BEPS) IS CLOSE TO 1.0, SO WE MUST BE CAREFUL IN EVALUATING */
/* THE DIFFERENCES */
r__1 = *a + xi;
r__2 = -beps;
pch1ai = poch1_(&r__1, &r__2);
r__1 = xi + 1.f - beps;
pch1i = poch1_(&r__1, &beps);
r__1 = *b + xi;
r__2 = -beps;
c0 = factor * pochai * gamrni * gamri1 * (-poch1_(&r__1, &r__2) + pch1ai
- pch1i + beps * pch1ai * pch1i);
/* XEPS1 = (1.0 - X**(-BEPS)) / BEPS */
r__1 = -beps * alnx;
xeps1 = alnx * exprel_(&r__1);
ret_val = sum + c0 + xeps1 * b0;
xn = (real) n;
for (i__ = 1; i__ <= 1000; ++i__) {
xi = (real) (istrt + i__);
xi1 = (real) (istrt + i__ - 1);
b0 = (*a + xi1 - beps) * b0 * *x / ((xn + xi1) * (xi - beps));
c0 = (*a + xi1) * c0 * *x / ((*b + xi1) * xi) - ((*a - 1.f) * (xn +
xi * 2.f - 1.f) + xi * (xi - beps)) * b0 / (xi * (*b + xi1) *
(*a + xi1 - beps));
t = c0 + xeps1 * b0;
ret_val += t;
if (dabs(t) < eps * dabs(ret_val)) {
goto L130;
}
/* L80: */
}
xermsg_("SLATEC", "CHU", "NO CONVERGENCE IN 1000 TERMS OF THE ASCENDING "
"SERIES", &c__3, &c__2, (ftnlen)6, (ftnlen)3, (ftnlen)52);
/* X**(-BEPS) IS VERY DIFFERENT FROM 1.0, SO THE STRAIGHTFORWARD */
/* FORMULATION IS STABLE. */
L90:
r__1 = *b + xi;
a0 = factor * pochai * gamr_(&r__1) * gamri1 / beps;
b0 = xtoeps * b0 / beps;
ret_val = sum + a0 - b0;
for (i__ = 1; i__ <= 1000; ++i__) {
xi = (real) (istrt + i__);
xi1 = (real) (istrt + i__ - 1);
a0 = (*a + xi1) * a0 * *x / ((*b + xi1) * xi);
b0 = (*a + xi1 - beps) * b0 * *x / ((aintb + xi1) * (xi - beps));
t = a0 - b0;
ret_val += t;
if (dabs(t) < eps * dabs(ret_val)) {
goto L130;
}
/* L100: */
}
xermsg_("SLATEC", "CHU", "NO CONVERGENCE IN 1000 TERMS OF THE ASCENDING "
"SERIES", &c__3, &c__2, (ftnlen)6, (ftnlen)3, (ftnlen)52);
/* USE LUKE-S RATIONAL APPROX IN THE ASYMPTOTIC REGION. */
L120:
d__1 = (doublereal) (*x);
d__2 = (doublereal) (-(*a));
ret_val = pow_dd(&d__1, &d__2) * r9chu_(a, b, x);
L130:
return ret_val;
} /* chu_ */
/* Subroutine */ int _elfunMANCINO_(doublereal *fuvals, doublereal *xvalue,
doublereal *epvalu, integer *ncalcf, integer *itypee, integer *istaev,
integer *ielvar, integer *intvar, integer *istadh, integer *istepa,
integer *icalcf, integer *ltypee, integer *lstaev, integer *lelvar,
integer *lntvar, integer *lstadh, integer *lstepa, integer *lcalcf,
integer *lfvalu, integer *lxvalu, integer *lepvlu, integer *ifflag,
integer *ifstat)
{
/* System generated locals */
integer i__1;
/* Local variables */
static doublereal b, x, a1, a2, a3, v2, al, ii, jj, cij, lij, sal, sij,
vij, dbdx, dcdx, dsal, scij, dvij, dsdx, dscij, invij, sumal;
static integer jcalcf, ielemn;
static doublereal dsumal;
static integer igstrt, ihstrt, ilstrt, ipstrt;
/* PROBLEM NAME : MANCINO */
/* Parameter adjustments */
--itypee;
--istaev;
--ielvar;
--intvar;
--istadh;
--istepa;
--icalcf;
--fuvals;
--xvalue;
--epvalu;
/* Function Body */
*ifstat = 0;
i__1 = *ncalcf;
for (jcalcf = 1; jcalcf <= i__1; ++jcalcf) {
ielemn = icalcf[jcalcf];
ilstrt = istaev[ielemn] - 1;
igstrt = intvar[ielemn] - 1;
ipstrt = istepa[ielemn] - 1;
if (*ifflag == 3) {
ihstrt = istadh[ielemn] - 1;
}
/* ELEMENT TYPE : MANC */
x = xvalue[ielvar[ilstrt + 1]];
ii = epvalu[ipstrt + 1];
jj = epvalu[ipstrt + 2];
al = epvalu[ipstrt + 3];
a1 = al - 1.f;
a2 = al - 2.f;
a3 = al - 3.f;
invij = x * x + ii / jj;
vij = sqrt(invij);
v2 = vij * vij;
dvij = x / vij;
lij = log(vij);
sij = sin(lij);
dsdx = cij * dvij / vij;
cij = cos(lij);
dcdx = -sij * dvij / vij;
sumal = pow_dd(&sij, &al) + pow_dd(&cij, &al);
dsumal = al * (dsdx * pow_dd(&sij, &a1) + dcdx * pow_dd(&cij, &a1));
scij = sij * cij;
dscij = sij * dcdx + dsdx * cij;
sal = pow_dd(&sij, &a2) - pow_dd(&cij, &a2);
dsal = a2 * (dsdx * pow_dd(&sij, &a3) - dcdx * pow_dd(&cij, &a3));
b = sumal + al * scij * sal;
dbdx = dsumal + al * (dscij * sal + scij * dsal);
if (*ifflag == 1) {
fuvals[ielemn] = vij * sumal;
} else {
fuvals[igstrt + 1] = x * b / vij;
if (*ifflag == 3) {
fuvals[ihstrt + 1] = (b + x * dbdx) / vij - b * x * dvij / v2;
}
}
/* L2: */
}
return 0;
} /* elfun_ */
int sbdsqr_(char *uplo, int *n, int *ncvt, int *
nru, int *ncc, float *d__, float *e, float *vt, int *ldvt, float *
u, int *ldu, float *c__, int *ldc, float *work, int *info)
{
/* System generated locals */
int c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1,
i__2;
float r__1, r__2, r__3, r__4;
double d__1;
/* Builtin functions */
double pow_dd(double *, double *), sqrt(double), r_sign(float *
, float *);
/* Local variables */
float f, g, h__;
int i__, j, m;
float r__, cs;
int ll;
float sn, mu;
int nm1, nm12, nm13, lll;
float eps, sll, tol, abse;
int idir;
float abss;
int oldm;
float cosl;
int isub, iter;
float unfl, sinl, cosr, smin, smax, sinr;
extern int srot_(int *, float *, int *, float *,
int *, float *, float *), slas2_(float *, float *, float *, float *,
float *);
extern int lsame_(char *, char *);
float oldcs;
extern int sscal_(int *, float *, float *, int *);
int oldll;
float shift, sigmn, oldsn;
int maxit;
float sminl;
extern int slasr_(char *, char *, char *, int *,
int *, float *, float *, float *, int *);
float sigmx;
int lower;
extern int sswap_(int *, float *, int *, float *,
int *), slasq1_(int *, float *, float *, float *, int *),
slasv2_(float *, float *, float *, float *, float *, float *, float *,
float *, float *);
extern double slamch_(char *);
extern int xerbla_(char *, int *);
float sminoa;
extern int slartg_(float *, float *, float *, float *, float *
);
float thresh;
int rotate;
float tolmul;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* January 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SBDSQR computes the singular values and, optionally, the right and/or */
/* left singular vectors from the singular value decomposition (SVD) of */
/* a float N-by-N (upper or lower) bidiagonal matrix B using the implicit */
/* zero-shift QR algorithm. The SVD of B has the form */
/* B = Q * S * P**T */
/* where S is the diagonal matrix of singular values, Q is an orthogonal */
/* matrix of left singular vectors, and P is an orthogonal matrix of */
/* right singular vectors. If left singular vectors are requested, this */
/* subroutine actually returns U*Q instead of Q, and, if right singular */
/* vectors are requested, this subroutine returns P**T*VT instead of */
/* P**T, for given float input matrices U and VT. When U and VT are the */
/* orthogonal matrices that reduce a general matrix A to bidiagonal */
/* form: A = U*B*VT, as computed by SGEBRD, then */
/* A = (U*Q) * S * (P**T*VT) */
/* is the SVD of A. Optionally, the subroutine may also compute Q**T*C */
/* for a given float input matrix C. */
/* See "Computing Small Singular Values of Bidiagonal Matrices With */
/* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, */
/* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11, */
/* no. 5, pp. 873-912, Sept 1990) and */
/* "Accurate singular values and differential qd algorithms," by */
/* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics */
/* Department, University of California at Berkeley, July 1992 */
/* for a detailed description of the algorithm. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': B is upper bidiagonal; */
/* = 'L': B is lower bidiagonal. */
/* N (input) INTEGER */
/* The order of the matrix B. N >= 0. */
/* NCVT (input) INTEGER */
/* The number of columns of the matrix VT. NCVT >= 0. */
/* NRU (input) INTEGER */
/* The number of rows of the matrix U. NRU >= 0. */
/* NCC (input) INTEGER */
/* The number of columns of the matrix C. NCC >= 0. */
/* D (input/output) REAL array, dimension (N) */
/* On entry, the n diagonal elements of the bidiagonal matrix B. */
/* On exit, if INFO=0, the singular values of B in decreasing */
/* order. */
/* E (input/output) REAL array, dimension (N-1) */
/* On entry, the N-1 offdiagonal elements of the bidiagonal */
/* matrix B. */
/* On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E */
/* will contain the diagonal and superdiagonal elements of a */
/* bidiagonal matrix orthogonally equivalent to the one given */
/* as input. */
/* VT (input/output) REAL array, dimension (LDVT, NCVT) */
/* On entry, an N-by-NCVT matrix VT. */
/* On exit, VT is overwritten by P**T * VT. */
/* Not referenced if NCVT = 0. */
/* LDVT (input) INTEGER */
/* The leading dimension of the array VT. */
/* LDVT >= MAX(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0. */
/* U (input/output) REAL array, dimension (LDU, N) */
/* On entry, an NRU-by-N matrix U. */
/* On exit, U is overwritten by U * Q. */
/* Not referenced if NRU = 0. */
/* LDU (input) INTEGER */
/* The leading dimension of the array U. LDU >= MAX(1,NRU). */
/* C (input/output) REAL array, dimension (LDC, NCC) */
/* On entry, an N-by-NCC matrix C. */
/* On exit, C is overwritten by Q**T * C. */
/* Not referenced if NCC = 0. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. */
/* LDC >= MAX(1,N) if NCC > 0; LDC >=1 if NCC = 0. */
/* WORK (workspace) REAL array, dimension (4*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: If INFO = -i, the i-th argument had an illegal value */
/* > 0: */
/* if NCVT = NRU = NCC = 0, */
/* = 1, a split was marked by a positive value in E */
/* = 2, current block of Z not diagonalized after 30*N */
/* iterations (in inner while loop) */
/* = 3, termination criterion of outer while loop not met */
/* (program created more than N unreduced blocks) */
/* else NCVT = NRU = NCC = 0, */
/* the algorithm did not converge; D and E contain the */
/* elements of a bidiagonal matrix which is orthogonally */
/* similar to the input matrix B; if INFO = i, i */
/* elements of E have not converged to zero. */
/* Internal Parameters */
/* =================== */
/* TOLMUL REAL, default = MAX(10,MIN(100,EPS**(-1/8))) */
/* TOLMUL controls the convergence criterion of the QR loop. */
/* If it is positive, TOLMUL*EPS is the desired relative */
/* precision in the computed singular values. */
/* If it is negative, ABS(TOLMUL*EPS*sigma_max) is the */
/* desired absolute accuracy in the computed singular */
/* values (corresponds to relative accuracy */
/* ABS(TOLMUL*EPS) in the largest singular value. */
/* ABS(TOLMUL) should be between 1 and 1/EPS, and preferably */
/* between 10 (for fast convergence) and .1/EPS */
/* (for there to be some accuracy in the results). */
/* Default is to lose at either one eighth or 2 of the */
/* available decimal digits in each computed singular value */
/* (whichever is smaller). */
/* MAXITR INTEGER, default = 6 */
/* MAXITR controls the maximum number of passes of the */
/* algorithm through its inner loop. The algorithms stops */
/* (and so fails to converge) if the number of passes */
/* through the inner loop exceeds MAXITR*N**2. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1;
vt -= vt_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
lower = lsame_(uplo, "L");
if (! lsame_(uplo, "U") && ! lower) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ncvt < 0) {
*info = -3;
} else if (*nru < 0) {
*info = -4;
} else if (*ncc < 0) {
*info = -5;
} else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < MAX(1,*n)) {
*info = -9;
} else if (*ldu < MAX(1,*nru)) {
*info = -11;
} else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < MAX(1,*n)) {
*info = -13;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SBDSQR", &i__1);
return 0;
}
if (*n == 0) {
return 0;
}
if (*n == 1) {
goto L160;
}
/* ROTATE is true if any singular vectors desired, false otherwise */
rotate = *ncvt > 0 || *nru > 0 || *ncc > 0;
/* If no singular vectors desired, use qd algorithm */
if (! rotate) {
slasq1_(n, &d__[1], &e[1], &work[1], info);
return 0;
}
nm1 = *n - 1;
nm12 = nm1 + nm1;
nm13 = nm12 + nm1;
idir = 0;
/* Get machine constants */
eps = slamch_("Epsilon");
unfl = slamch_("Safe minimum");
/* If matrix lower bidiagonal, rotate to be upper bidiagonal */
/* by applying Givens rotations on the left */
if (lower) {
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
slartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
d__[i__] = r__;
e[i__] = sn * d__[i__ + 1];
d__[i__ + 1] = cs * d__[i__ + 1];
work[i__] = cs;
work[nm1 + i__] = sn;
/* L10: */
}
/* Update singular vectors if desired */
if (*nru > 0) {
slasr_("R", "V", "F", nru, n, &work[1], &work[*n], &u[u_offset],
ldu);
}
if (*ncc > 0) {
slasr_("L", "V", "F", n, ncc, &work[1], &work[*n], &c__[c_offset],
ldc);
}
}
/* Compute singular values to relative accuracy TOL */
/* (By setting TOL to be negative, algorithm will compute */
/* singular values to absolute accuracy ABS(TOL)*norm(input matrix)) */
/* Computing MAX */
/* Computing MIN */
d__1 = (double) eps;
r__3 = 100.f, r__4 = pow_dd(&d__1, &c_b15);
r__1 = 10.f, r__2 = MIN(r__3,r__4);
tolmul = MAX(r__1,r__2);
tol = tolmul * eps;
/* Compute approximate maximum, minimum singular values */
smax = 0.f;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__2 = smax, r__3 = (r__1 = d__[i__], ABS(r__1));
smax = MAX(r__2,r__3);
/* L20: */
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__2 = smax, r__3 = (r__1 = e[i__], ABS(r__1));
smax = MAX(r__2,r__3);
/* L30: */
}
sminl = 0.f;
if (tol >= 0.f) {
/* Relative accuracy desired */
sminoa = ABS(d__[1]);
if (sminoa == 0.f) {
goto L50;
}
mu = sminoa;
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
mu = (r__2 = d__[i__], ABS(r__2)) * (mu / (mu + (r__1 = e[i__ -
1], ABS(r__1))));
sminoa = MIN(sminoa,mu);
if (sminoa == 0.f) {
goto L50;
}
/* L40: */
}
L50:
sminoa /= sqrt((float) (*n));
/* Computing MAX */
r__1 = tol * sminoa, r__2 = *n * 6 * *n * unfl;
thresh = MAX(r__1,r__2);
} else {
/* Absolute accuracy desired */
/* Computing MAX */
r__1 = ABS(tol) * smax, r__2 = *n * 6 * *n * unfl;
thresh = MAX(r__1,r__2);
}
/* Prepare for main iteration loop for the singular values */
/* (MAXIT is the maximum number of passes through the inner */
/* loop permitted before nonconvergence signalled.) */
maxit = *n * 6 * *n;
iter = 0;
oldll = -1;
oldm = -1;
/* M points to last element of unconverged part of matrix */
m = *n;
/* Begin main iteration loop */
L60:
/* Check for convergence or exceeding iteration count */
if (m <= 1) {
goto L160;
}
if (iter > maxit) {
goto L200;
}
/* Find diagonal block of matrix to work on */
if (tol < 0.f && (r__1 = d__[m], ABS(r__1)) <= thresh) {
d__[m] = 0.f;
}
smax = (r__1 = d__[m], ABS(r__1));
smin = smax;
i__1 = m - 1;
for (lll = 1; lll <= i__1; ++lll) {
ll = m - lll;
abss = (r__1 = d__[ll], ABS(r__1));
abse = (r__1 = e[ll], ABS(r__1));
if (tol < 0.f && abss <= thresh) {
d__[ll] = 0.f;
}
if (abse <= thresh) {
goto L80;
}
smin = MIN(smin,abss);
/* Computing MAX */
r__1 = MAX(smax,abss);
smax = MAX(r__1,abse);
/* L70: */
}
ll = 0;
goto L90;
L80:
e[ll] = 0.f;
/* Matrix splits since E(LL) = 0 */
if (ll == m - 1) {
/* Convergence of bottom singular value, return to top of loop */
--m;
goto L60;
}
L90:
++ll;
/* E(LL) through E(M-1) are nonzero, E(LL-1) is zero */
if (ll == m - 1) {
/* 2 by 2 block, handle separately */
slasv2_(&d__[m - 1], &e[m - 1], &d__[m], &sigmn, &sigmx, &sinr, &cosr,
&sinl, &cosl);
d__[m - 1] = sigmx;
e[m - 1] = 0.f;
d__[m] = sigmn;
/* Compute singular vectors, if desired */
if (*ncvt > 0) {
srot_(ncvt, &vt[m - 1 + vt_dim1], ldvt, &vt[m + vt_dim1], ldvt, &
cosr, &sinr);
}
if (*nru > 0) {
srot_(nru, &u[(m - 1) * u_dim1 + 1], &c__1, &u[m * u_dim1 + 1], &
c__1, &cosl, &sinl);
}
if (*ncc > 0) {
srot_(ncc, &c__[m - 1 + c_dim1], ldc, &c__[m + c_dim1], ldc, &
cosl, &sinl);
}
m += -2;
goto L60;
}
/* If working on new submatrix, choose shift direction */
/* (from larger end diagonal element towards smaller) */
if (ll > oldm || m < oldll) {
if ((r__1 = d__[ll], ABS(r__1)) >= (r__2 = d__[m], ABS(r__2))) {
/* Chase bulge from top (big end) to bottom (small end) */
idir = 1;
} else {
/* Chase bulge from bottom (big end) to top (small end) */
idir = 2;
}
}
/* Apply convergence tests */
if (idir == 1) {
/* Run convergence test in forward direction */
/* First apply standard test to bottom of matrix */
if ((r__2 = e[m - 1], ABS(r__2)) <= ABS(tol) * (r__1 = d__[m], ABS(
r__1)) || tol < 0.f && (r__3 = e[m - 1], ABS(r__3)) <=
thresh) {
e[m - 1] = 0.f;
goto L60;
}
if (tol >= 0.f) {
/* If relative accuracy desired, */
/* apply convergence criterion forward */
mu = (r__1 = d__[ll], ABS(r__1));
sminl = mu;
i__1 = m - 1;
for (lll = ll; lll <= i__1; ++lll) {
if ((r__1 = e[lll], ABS(r__1)) <= tol * mu) {
e[lll] = 0.f;
goto L60;
}
mu = (r__2 = d__[lll + 1], ABS(r__2)) * (mu / (mu + (r__1 =
e[lll], ABS(r__1))));
sminl = MIN(sminl,mu);
/* L100: */
}
}
} else {
/* Run convergence test in backward direction */
/* First apply standard test to top of matrix */
if ((r__2 = e[ll], ABS(r__2)) <= ABS(tol) * (r__1 = d__[ll], ABS(
r__1)) || tol < 0.f && (r__3 = e[ll], ABS(r__3)) <= thresh) {
e[ll] = 0.f;
goto L60;
}
if (tol >= 0.f) {
/* If relative accuracy desired, */
/* apply convergence criterion backward */
mu = (r__1 = d__[m], ABS(r__1));
sminl = mu;
i__1 = ll;
for (lll = m - 1; lll >= i__1; --lll) {
if ((r__1 = e[lll], ABS(r__1)) <= tol * mu) {
e[lll] = 0.f;
goto L60;
}
mu = (r__2 = d__[lll], ABS(r__2)) * (mu / (mu + (r__1 = e[
lll], ABS(r__1))));
sminl = MIN(sminl,mu);
/* L110: */
}
}
}
oldll = ll;
oldm = m;
/* Compute shift. First, test if shifting would ruin relative */
/* accuracy, and if so set the shift to zero. */
/* Computing MAX */
r__1 = eps, r__2 = tol * .01f;
if (tol >= 0.f && *n * tol * (sminl / smax) <= MAX(r__1,r__2)) {
/* Use a zero shift to avoid loss of relative accuracy */
shift = 0.f;
} else {
/* Compute the shift from 2-by-2 block at end of matrix */
if (idir == 1) {
sll = (r__1 = d__[ll], ABS(r__1));
slas2_(&d__[m - 1], &e[m - 1], &d__[m], &shift, &r__);
} else {
sll = (r__1 = d__[m], ABS(r__1));
slas2_(&d__[ll], &e[ll], &d__[ll + 1], &shift, &r__);
}
/* Test if shift negligible, and if so set to zero */
if (sll > 0.f) {
/* Computing 2nd power */
r__1 = shift / sll;
if (r__1 * r__1 < eps) {
shift = 0.f;
}
}
}
/* Increment iteration count */
iter = iter + m - ll;
/* If SHIFT = 0, do simplified QR iteration */
if (shift == 0.f) {
if (idir == 1) {
/* Chase bulge from top to bottom */
/* Save cosines and sines for later singular vector updates */
cs = 1.f;
oldcs = 1.f;
i__1 = m - 1;
for (i__ = ll; i__ <= i__1; ++i__) {
r__1 = d__[i__] * cs;
slartg_(&r__1, &e[i__], &cs, &sn, &r__);
if (i__ > ll) {
e[i__ - 1] = oldsn * r__;
}
r__1 = oldcs * r__;
r__2 = d__[i__ + 1] * sn;
slartg_(&r__1, &r__2, &oldcs, &oldsn, &d__[i__]);
work[i__ - ll + 1] = cs;
work[i__ - ll + 1 + nm1] = sn;
work[i__ - ll + 1 + nm12] = oldcs;
work[i__ - ll + 1 + nm13] = oldsn;
/* L120: */
}
h__ = d__[m] * cs;
d__[m] = h__ * oldcs;
e[m - 1] = h__ * oldsn;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
slasr_("L", "V", "F", &i__1, ncvt, &work[1], &work[*n], &vt[
ll + vt_dim1], ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
slasr_("R", "V", "F", nru, &i__1, &work[nm12 + 1], &work[nm13
+ 1], &u[ll * u_dim1 + 1], ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
slasr_("L", "V", "F", &i__1, ncc, &work[nm12 + 1], &work[nm13
+ 1], &c__[ll + c_dim1], ldc);
}
/* Test convergence */
if ((r__1 = e[m - 1], ABS(r__1)) <= thresh) {
e[m - 1] = 0.f;
}
} else {
/* Chase bulge from bottom to top */
/* Save cosines and sines for later singular vector updates */
cs = 1.f;
oldcs = 1.f;
i__1 = ll + 1;
for (i__ = m; i__ >= i__1; --i__) {
r__1 = d__[i__] * cs;
slartg_(&r__1, &e[i__ - 1], &cs, &sn, &r__);
if (i__ < m) {
e[i__] = oldsn * r__;
}
r__1 = oldcs * r__;
r__2 = d__[i__ - 1] * sn;
slartg_(&r__1, &r__2, &oldcs, &oldsn, &d__[i__]);
work[i__ - ll] = cs;
work[i__ - ll + nm1] = -sn;
work[i__ - ll + nm12] = oldcs;
work[i__ - ll + nm13] = -oldsn;
/* L130: */
}
h__ = d__[ll] * cs;
d__[ll] = h__ * oldcs;
e[ll] = h__ * oldsn;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
slasr_("L", "V", "B", &i__1, ncvt, &work[nm12 + 1], &work[
nm13 + 1], &vt[ll + vt_dim1], ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
slasr_("R", "V", "B", nru, &i__1, &work[1], &work[*n], &u[ll *
u_dim1 + 1], ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
slasr_("L", "V", "B", &i__1, ncc, &work[1], &work[*n], &c__[
ll + c_dim1], ldc);
}
/* Test convergence */
if ((r__1 = e[ll], ABS(r__1)) <= thresh) {
e[ll] = 0.f;
}
}
} else {
/* Use nonzero shift */
if (idir == 1) {
/* Chase bulge from top to bottom */
/* Save cosines and sines for later singular vector updates */
f = ((r__1 = d__[ll], ABS(r__1)) - shift) * (r_sign(&c_b49, &d__[
ll]) + shift / d__[ll]);
g = e[ll];
i__1 = m - 1;
for (i__ = ll; i__ <= i__1; ++i__) {
slartg_(&f, &g, &cosr, &sinr, &r__);
if (i__ > ll) {
e[i__ - 1] = r__;
}
f = cosr * d__[i__] + sinr * e[i__];
e[i__] = cosr * e[i__] - sinr * d__[i__];
g = sinr * d__[i__ + 1];
d__[i__ + 1] = cosr * d__[i__ + 1];
slartg_(&f, &g, &cosl, &sinl, &r__);
d__[i__] = r__;
f = cosl * e[i__] + sinl * d__[i__ + 1];
d__[i__ + 1] = cosl * d__[i__ + 1] - sinl * e[i__];
if (i__ < m - 1) {
g = sinl * e[i__ + 1];
e[i__ + 1] = cosl * e[i__ + 1];
}
work[i__ - ll + 1] = cosr;
work[i__ - ll + 1 + nm1] = sinr;
work[i__ - ll + 1 + nm12] = cosl;
work[i__ - ll + 1 + nm13] = sinl;
/* L140: */
}
e[m - 1] = f;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
slasr_("L", "V", "F", &i__1, ncvt, &work[1], &work[*n], &vt[
ll + vt_dim1], ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
slasr_("R", "V", "F", nru, &i__1, &work[nm12 + 1], &work[nm13
+ 1], &u[ll * u_dim1 + 1], ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
slasr_("L", "V", "F", &i__1, ncc, &work[nm12 + 1], &work[nm13
+ 1], &c__[ll + c_dim1], ldc);
}
/* Test convergence */
if ((r__1 = e[m - 1], ABS(r__1)) <= thresh) {
e[m - 1] = 0.f;
}
} else {
/* Chase bulge from bottom to top */
/* Save cosines and sines for later singular vector updates */
f = ((r__1 = d__[m], ABS(r__1)) - shift) * (r_sign(&c_b49, &d__[
m]) + shift / d__[m]);
g = e[m - 1];
i__1 = ll + 1;
for (i__ = m; i__ >= i__1; --i__) {
slartg_(&f, &g, &cosr, &sinr, &r__);
if (i__ < m) {
e[i__] = r__;
}
f = cosr * d__[i__] + sinr * e[i__ - 1];
e[i__ - 1] = cosr * e[i__ - 1] - sinr * d__[i__];
g = sinr * d__[i__ - 1];
d__[i__ - 1] = cosr * d__[i__ - 1];
slartg_(&f, &g, &cosl, &sinl, &r__);
d__[i__] = r__;
f = cosl * e[i__ - 1] + sinl * d__[i__ - 1];
d__[i__ - 1] = cosl * d__[i__ - 1] - sinl * e[i__ - 1];
if (i__ > ll + 1) {
g = sinl * e[i__ - 2];
e[i__ - 2] = cosl * e[i__ - 2];
}
work[i__ - ll] = cosr;
work[i__ - ll + nm1] = -sinr;
work[i__ - ll + nm12] = cosl;
work[i__ - ll + nm13] = -sinl;
/* L150: */
}
e[ll] = f;
/* Test convergence */
if ((r__1 = e[ll], ABS(r__1)) <= thresh) {
e[ll] = 0.f;
}
/* Update singular vectors if desired */
if (*ncvt > 0) {
i__1 = m - ll + 1;
slasr_("L", "V", "B", &i__1, ncvt, &work[nm12 + 1], &work[
nm13 + 1], &vt[ll + vt_dim1], ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
slasr_("R", "V", "B", nru, &i__1, &work[1], &work[*n], &u[ll *
u_dim1 + 1], ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
slasr_("L", "V", "B", &i__1, ncc, &work[1], &work[*n], &c__[
ll + c_dim1], ldc);
}
}
}
/* QR iteration finished, go back and check convergence */
goto L60;
/* All singular values converged, so make them positive */
L160:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (d__[i__] < 0.f) {
d__[i__] = -d__[i__];
/* Change sign of singular vectors, if desired */
if (*ncvt > 0) {
sscal_(ncvt, &c_b72, &vt[i__ + vt_dim1], ldvt);
}
}
/* L170: */
}
/* Sort the singular values into decreasing order (insertion sort on */
/* singular values, but only one transposition per singular vector) */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Scan for smallest D(I) */
isub = 1;
smin = d__[1];
i__2 = *n + 1 - i__;
for (j = 2; j <= i__2; ++j) {
if (d__[j] <= smin) {
isub = j;
smin = d__[j];
}
/* L180: */
}
if (isub != *n + 1 - i__) {
/* Swap singular values and vectors */
d__[isub] = d__[*n + 1 - i__];
d__[*n + 1 - i__] = smin;
if (*ncvt > 0) {
sswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[*n + 1 - i__ +
vt_dim1], ldvt);
}
if (*nru > 0) {
sswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[(*n + 1 - i__) *
u_dim1 + 1], &c__1);
}
if (*ncc > 0) {
sswap_(ncc, &c__[isub + c_dim1], ldc, &c__[*n + 1 - i__ +
c_dim1], ldc);
}
}
/* L190: */
}
goto L220;
/* Maximum number of iterations exceeded, failure to converge */
L200:
*info = 0;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (e[i__] != 0.f) {
++(*info);
}
/* L210: */
}
L220:
return 0;
/* End of SBDSQR */
} /* sbdsqr_ */
/* Subroutine */ int ssconv_(integer *n, real *ritz, real *bounds, real *tol,
integer *nconv)
{
/* System generated locals */
integer i__1;
real r__1, r__2, r__3;
doublereal d__1;
/* Local variables */
static integer i__;
static real t0, t1, eps23, temp;
extern doublereal slamch_(char *, ftnlen);
extern /* Subroutine */ int arscnd_(real *);
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %---------------% */
/* | Local Scalars | */
/* %---------------% */
/* %-------------------% */
/* | External routines | */
/* %-------------------% */
/* %---------------------% */
/* | Intrinsic Functions | */
/* %---------------------% */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
/* Parameter adjustments */
--bounds;
--ritz;
/* Function Body */
arscnd_(&t0);
eps23 = slamch_("Epsilon-Machine", (ftnlen)15);
d__1 = (doublereal) eps23;
eps23 = pow_dd(&d__1, &c_b3);
*nconv = 0;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* %-----------------------------------------------------% */
/* | The i-th Ritz value is considered "converged" | */
/* | when: bounds(i) .le. TOL*max(eps23, abs(ritz(i))) | */
/* %-----------------------------------------------------% */
/* Computing MAX */
r__2 = eps23, r__3 = (r__1 = ritz[i__], dabs(r__1));
temp = dmax(r__2,r__3);
if (bounds[i__] <= *tol * temp) {
++(*nconv);
}
/* L10: */
}
arscnd_(&t1);
timing_1.tsconv += t1 - t0;
return 0;
/* %---------------% */
/* | End of ssconv | */
/* %---------------% */
} /* ssconv_ */
/* DECK CAIRY */
/* Subroutine */ int cairy_(complex *z__, integer *id, integer *kode, complex
*ai, integer *nz, integer *ierr)
{
/* Initialized data */
static real tth = .666666666666666667f;
static real c1 = .35502805388781724f;
static real c2 = .258819403792806799f;
static real coef = .183776298473930683f;
static complex cone = {1.f,0.f};
/* System generated locals */
integer i__1, i__2;
real r__1, r__2;
doublereal d__1, d__2;
complex q__1, q__2, q__3, q__4, q__5, q__6;
/* Local variables */
static integer k;
static real d1, d2;
static integer k1, k2;
static complex s1, s2, z3;
static real aa, bb, ad, ak, bk, ck, dk, az;
static complex cy[1];
static integer nn;
static real rl;
static integer mr;
static real zi, zr, az3, z3i, z3r, fid, dig, r1m5;
static complex csq;
static real fnu;
static complex zta;
static real tol;
static complex trm1, trm2;
static real sfac, alim, elim, alaz, atrm;
extern /* Subroutine */ int cacai_(complex *, real *, integer *, integer *
, integer *, complex *, integer *, real *, real *, real *, real *)
;
static integer iflag;
extern /* Subroutine */ int cbknu_(complex *, real *, integer *, integer *
, complex *, integer *, real *, real *, real *);
extern integer i1mach_(integer *);
extern doublereal r1mach_(integer *);
/* ***BEGIN PROLOGUE CAIRY */
/* ***PURPOSE Compute the Airy function Ai(z) or its derivative dAi/dz */
/* for complex argument z. A scaling option is available */
/* to help avoid underflow and overflow. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY C10D */
/* ***TYPE COMPLEX (CAIRY-C, ZAIRY-C) */
/* ***KEYWORDS AIRY FUNCTION, BESSEL FUNCTION OF ORDER ONE THIRD, */
/* BESSEL FUNCTION OF ORDER TWO THIRDS */
/* ***AUTHOR Amos, D. E., (SNL) */
/* ***DESCRIPTION */
/* On KODE=1, CAIRY computes the complex Airy function Ai(z) */
/* or its derivative dAi/dz on ID=0 or ID=1 respectively. On */
/* KODE=2, a scaling option exp(zeta)*Ai(z) or exp(zeta)*dAi/dz */
/* is provided to remove the exponential decay in -pi/3<arg(z) */
/* <pi/3 and the exponential growth in pi/3<abs(arg(z))<pi where */
/* zeta=(2/3)*z**(3/2). */
/* While the Airy functions Ai(z) and dAi/dz are analytic in */
/* the whole z-plane, the corresponding scaled functions defined */
/* for KODE=2 have a cut along the negative real axis. */
/* Input */
/* Z - Argument of type COMPLEX */
/* ID - Order of derivative, ID=0 or ID=1 */
/* KODE - A parameter to indicate the scaling option */
/* KODE=1 returns */
/* AI=Ai(z) on ID=0 */
/* AI=dAi/dz on ID=1 */
/* at z=Z */
/* =2 returns */
/* AI=exp(zeta)*Ai(z) on ID=0 */
/* AI=exp(zeta)*dAi/dz on ID=1 */
/* at z=Z where zeta=(2/3)*z**(3/2) */
/* Output */
/* AI - Result of type COMPLEX */
/* NZ - Underflow indicator */
/* NZ=0 Normal return */
/* NZ=1 AI=0 due to underflow in */
/* -pi/3<arg(Z)<pi/3 on KODE=1 */
/* IERR - Error flag */
/* IERR=0 Normal return - COMPUTATION COMPLETED */
/* IERR=1 Input error - NO COMPUTATION */
/* IERR=2 Overflow - NO COMPUTATION */
/* (Re(Z) too large with KODE=1) */
/* IERR=3 Precision warning - COMPUTATION COMPLETED */
/* (Result has less than half precision) */
/* IERR=4 Precision error - NO COMPUTATION */
/* (Result has no precision) */
/* IERR=5 Algorithmic error - NO COMPUTATION */
/* (Termination condition not met) */
/* *Long Description: */
/* Ai(z) and dAi/dz are computed from K Bessel functions by */
/* Ai(z) = c*sqrt(z)*K(1/3,zeta) */
/* dAi/dz = -c* z *K(2/3,zeta) */
/* c = 1/(pi*sqrt(3)) */
/* zeta = (2/3)*z**(3/2) */
/* when abs(z)>1 and from power series when abs(z)<=1. */
/* In most complex variable computation, one must evaluate ele- */
/* mentary functions. When the magnitude of Z is large, losses */
/* of significance by argument reduction occur. Consequently, if */
/* the magnitude of ZETA=(2/3)*Z**(3/2) exceeds U1=SQRT(0.5/UR), */
/* then losses exceeding half precision are likely and an error */
/* flag IERR=3 is triggered where UR=R1MACH(4)=UNIT ROUNDOFF. */
/* Also, if the magnitude of ZETA is larger than U2=0.5/UR, then */
/* all significance is lost and IERR=4. In order to use the INT */
/* function, ZETA must be further restricted not to exceed */
/* U3=I1MACH(9)=LARGEST INTEGER. Thus, the magnitude of ZETA */
/* must be restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, */
/* and U3 are approximately 2.0E+3, 4.2E+6, 2.1E+9 in single */
/* precision and 4.7E+7, 2.3E+15, 2.1E+9 in double precision. */
/* This makes U2 limiting is single precision and U3 limiting */
/* in double precision. This means that the magnitude of Z */
/* cannot exceed approximately 3.4E+4 in single precision and */
/* 2.1E+6 in double precision. This also means that one can */
/* expect to retain, in the worst cases on 32-bit machines, */
/* no digits in single precision and only 6 digits in double */
/* precision. */
/* The approximate relative error in the magnitude of a complex */
/* Bessel function can be expressed as P*10**S where P=MAX(UNIT */
/* ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- */
/* sents the increase in error due to argument reduction in the */
/* elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), */
/* ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF */
/* ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may */
/* have only absolute accuracy. This is most likely to occur */
/* when one component (in magnitude) is larger than the other by */
/* several orders of magnitude. If one component is 10**K larger */
/* than the other, then one can expect only MAX(ABS(LOG10(P))-K, */
/* 0) significant digits; or, stated another way, when K exceeds */
/* the exponent of P, no significant digits remain in the smaller */
/* component. However, the phase angle retains absolute accuracy */
/* because, in complex arithmetic with precision P, the smaller */
/* component will not (as a rule) decrease below P times the */
/* magnitude of the larger component. In these extreme cases, */
/* the principal phase angle is on the order of +P, -P, PI/2-P, */
/* or -PI/2+P. */
/* ***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- */
/* matical Functions, National Bureau of Standards */
/* Applied Mathematics Series 55, U. S. Department */
/* of Commerce, Tenth Printing (1972) or later. */
/* 2. D. E. Amos, Computation of Bessel Functions of */
/* Complex Argument and Large Order, Report SAND83-0643, */
/* Sandia National Laboratories, Albuquerque, NM, May */
/* 1983. */
/* 3. D. E. Amos, A Subroutine Package for Bessel Functions */
/* of a Complex Argument and Nonnegative Order, Report */
/* SAND85-1018, Sandia National Laboratory, Albuquerque, */
/* NM, May 1985. */
/* 4. D. E. Amos, A portable package for Bessel functions */
/* of a complex argument and nonnegative order, ACM */
/* Transactions on Mathematical Software, 12 (September */
/* 1986), pp. 265-273. */
/* ***ROUTINES CALLED CACAI, CBKNU, I1MACH, R1MACH */
/* ***REVISION HISTORY (YYMMDD) */
/* 830501 DATE WRITTEN */
/* 890801 REVISION DATE from Version 3.2 */
/* 910415 Prologue converted to Version 4.0 format. (BAB) */
/* 920128 Category corrected. (WRB) */
/* 920811 Prologue revised. (DWL) */
/* ***END PROLOGUE CAIRY */
/* ***FIRST EXECUTABLE STATEMENT CAIRY */
*ierr = 0;
*nz = 0;
if (*id < 0 || *id > 1) {
*ierr = 1;
}
if (*kode < 1 || *kode > 2) {
*ierr = 1;
}
if (*ierr != 0) {
return 0;
}
az = c_abs(z__);
/* Computing MAX */
r__1 = r1mach_(&c__4);
tol = dmax(r__1,1e-18f);
fid = (real) (*id);
if (az > 1.f) {
goto L60;
}
/* ----------------------------------------------------------------------- */
/* POWER SERIES FOR ABS(Z).LE.1. */
/* ----------------------------------------------------------------------- */
s1.r = cone.r, s1.i = cone.i;
s2.r = cone.r, s2.i = cone.i;
if (az < tol) {
goto L160;
}
aa = az * az;
if (aa < tol / az) {
goto L40;
}
trm1.r = cone.r, trm1.i = cone.i;
trm2.r = cone.r, trm2.i = cone.i;
atrm = 1.f;
q__2.r = z__->r * z__->r - z__->i * z__->i, q__2.i = z__->r * z__->i +
z__->i * z__->r;
q__1.r = q__2.r * z__->r - q__2.i * z__->i, q__1.i = q__2.r * z__->i +
q__2.i * z__->r;
z3.r = q__1.r, z3.i = q__1.i;
az3 = az * aa;
ak = fid + 2.f;
bk = 3.f - fid - fid;
ck = 4.f - fid;
dk = fid + 3.f + fid;
d1 = ak * dk;
d2 = bk * ck;
ad = dmin(d1,d2);
ak = fid * 9.f + 24.f;
bk = 30.f - fid * 9.f;
z3r = z3.r;
z3i = r_imag(&z3);
for (k = 1; k <= 25; ++k) {
r__1 = z3r / d1;
r__2 = z3i / d1;
q__2.r = r__1, q__2.i = r__2;
q__1.r = trm1.r * q__2.r - trm1.i * q__2.i, q__1.i = trm1.r * q__2.i
+ trm1.i * q__2.r;
trm1.r = q__1.r, trm1.i = q__1.i;
q__1.r = s1.r + trm1.r, q__1.i = s1.i + trm1.i;
s1.r = q__1.r, s1.i = q__1.i;
r__1 = z3r / d2;
r__2 = z3i / d2;
q__2.r = r__1, q__2.i = r__2;
q__1.r = trm2.r * q__2.r - trm2.i * q__2.i, q__1.i = trm2.r * q__2.i
+ trm2.i * q__2.r;
trm2.r = q__1.r, trm2.i = q__1.i;
q__1.r = s2.r + trm2.r, q__1.i = s2.i + trm2.i;
s2.r = q__1.r, s2.i = q__1.i;
atrm = atrm * az3 / ad;
d1 += ak;
d2 += bk;
ad = dmin(d1,d2);
if (atrm < tol * ad) {
goto L40;
}
ak += 18.f;
bk += 18.f;
/* L30: */
}
L40:
if (*id == 1) {
goto L50;
}
q__3.r = c1, q__3.i = 0.f;
q__2.r = s1.r * q__3.r - s1.i * q__3.i, q__2.i = s1.r * q__3.i + s1.i *
q__3.r;
q__5.r = z__->r * s2.r - z__->i * s2.i, q__5.i = z__->r * s2.i + z__->i *
s2.r;
q__6.r = c2, q__6.i = 0.f;
q__4.r = q__5.r * q__6.r - q__5.i * q__6.i, q__4.i = q__5.r * q__6.i +
q__5.i * q__6.r;
q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
ai->r = q__1.r, ai->i = q__1.i;
if (*kode == 1) {
return 0;
}
c_sqrt(&q__3, z__);
q__2.r = z__->r * q__3.r - z__->i * q__3.i, q__2.i = z__->r * q__3.i +
z__->i * q__3.r;
q__4.r = tth, q__4.i = 0.f;
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i +
q__2.i * q__4.r;
zta.r = q__1.r, zta.i = q__1.i;
c_exp(&q__2, &zta);
q__1.r = ai->r * q__2.r - ai->i * q__2.i, q__1.i = ai->r * q__2.i + ai->i
* q__2.r;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L50:
q__2.r = -s2.r, q__2.i = -s2.i;
q__3.r = c2, q__3.i = 0.f;
q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = q__2.r * q__3.i +
q__2.i * q__3.r;
ai->r = q__1.r, ai->i = q__1.i;
if (az > tol) {
q__4.r = z__->r * z__->r - z__->i * z__->i, q__4.i = z__->r * z__->i
+ z__->i * z__->r;
q__3.r = q__4.r * s1.r - q__4.i * s1.i, q__3.i = q__4.r * s1.i +
q__4.i * s1.r;
r__1 = c1 / (fid + 1.f);
q__5.r = r__1, q__5.i = 0.f;
q__2.r = q__3.r * q__5.r - q__3.i * q__5.i, q__2.i = q__3.r * q__5.i
+ q__3.i * q__5.r;
q__1.r = ai->r + q__2.r, q__1.i = ai->i + q__2.i;
ai->r = q__1.r, ai->i = q__1.i;
}
if (*kode == 1) {
return 0;
}
c_sqrt(&q__3, z__);
q__2.r = z__->r * q__3.r - z__->i * q__3.i, q__2.i = z__->r * q__3.i +
z__->i * q__3.r;
q__4.r = tth, q__4.i = 0.f;
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i +
q__2.i * q__4.r;
zta.r = q__1.r, zta.i = q__1.i;
c_exp(&q__2, &zta);
q__1.r = ai->r * q__2.r - ai->i * q__2.i, q__1.i = ai->r * q__2.i + ai->i
* q__2.r;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
/* ----------------------------------------------------------------------- */
/* CASE FOR ABS(Z).GT.1.0 */
/* ----------------------------------------------------------------------- */
L60:
fnu = (fid + 1.f) / 3.f;
/* ----------------------------------------------------------------------- */
/* SET PARAMETERS RELATED TO MACHINE CONSTANTS. */
/* TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. */
/* ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. */
/* EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND */
/* EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR */
/* UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. */
/* RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. */
/* DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). */
/* ----------------------------------------------------------------------- */
k1 = i1mach_(&c__12);
k2 = i1mach_(&c__13);
r1m5 = r1mach_(&c__5);
/* Computing MIN */
i__1 = abs(k1), i__2 = abs(k2);
k = min(i__1,i__2);
elim = (k * r1m5 - 3.f) * 2.303f;
k1 = i1mach_(&c__11) - 1;
aa = r1m5 * k1;
dig = dmin(aa,18.f);
aa *= 2.303f;
/* Computing MAX */
r__1 = -aa;
alim = elim + dmax(r__1,-41.45f);
rl = dig * 1.2f + 3.f;
alaz = log(az);
/* ----------------------------------------------------------------------- */
/* TEST FOR RANGE */
/* ----------------------------------------------------------------------- */
aa = .5f / tol;
bb = i1mach_(&c__9) * .5f;
aa = dmin(aa,bb);
d__1 = (doublereal) aa;
d__2 = (doublereal) tth;
aa = pow_dd(&d__1, &d__2);
if (az > aa) {
goto L260;
}
aa = sqrt(aa);
if (az > aa) {
*ierr = 3;
}
c_sqrt(&q__1, z__);
csq.r = q__1.r, csq.i = q__1.i;
q__2.r = z__->r * csq.r - z__->i * csq.i, q__2.i = z__->r * csq.i +
z__->i * csq.r;
q__3.r = tth, q__3.i = 0.f;
q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = q__2.r * q__3.i +
q__2.i * q__3.r;
zta.r = q__1.r, zta.i = q__1.i;
/* ----------------------------------------------------------------------- */
/* RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL */
/* ----------------------------------------------------------------------- */
iflag = 0;
sfac = 1.f;
zi = r_imag(z__);
zr = z__->r;
ak = r_imag(&zta);
if (zr >= 0.f) {
goto L70;
}
bk = zta.r;
ck = -dabs(bk);
q__1.r = ck, q__1.i = ak;
zta.r = q__1.r, zta.i = q__1.i;
L70:
if (zi != 0.f) {
goto L80;
}
if (zr > 0.f) {
goto L80;
}
q__1.r = 0.f, q__1.i = ak;
zta.r = q__1.r, zta.i = q__1.i;
L80:
aa = zta.r;
if (aa >= 0.f && zr > 0.f) {
goto L100;
}
if (*kode == 2) {
goto L90;
}
/* ----------------------------------------------------------------------- */
/* OVERFLOW TEST */
/* ----------------------------------------------------------------------- */
if (aa > -alim) {
goto L90;
}
aa = -aa + alaz * .25f;
iflag = 1;
sfac = tol;
if (aa > elim) {
goto L240;
}
L90:
/* ----------------------------------------------------------------------- */
/* CBKNU AND CACAI RETURN EXP(ZTA)*K(FNU,ZTA) ON KODE=2 */
/* ----------------------------------------------------------------------- */
mr = 1;
if (zi < 0.f) {
mr = -1;
}
cacai_(&zta, &fnu, kode, &mr, &c__1, cy, &nn, &rl, &tol, &elim, &alim);
if (nn < 0) {
goto L250;
}
*nz += nn;
goto L120;
L100:
if (*kode == 2) {
goto L110;
}
/* ----------------------------------------------------------------------- */
/* UNDERFLOW TEST */
/* ----------------------------------------------------------------------- */
if (aa < alim) {
goto L110;
}
aa = -aa - alaz * .25f;
iflag = 2;
sfac = 1.f / tol;
if (aa < -elim) {
goto L180;
}
L110:
cbknu_(&zta, &fnu, kode, &c__1, cy, nz, &tol, &elim, &alim);
L120:
q__2.r = coef, q__2.i = 0.f;
q__1.r = cy[0].r * q__2.r - cy[0].i * q__2.i, q__1.i = cy[0].r * q__2.i +
cy[0].i * q__2.r;
s1.r = q__1.r, s1.i = q__1.i;
if (iflag != 0) {
goto L140;
}
if (*id == 1) {
goto L130;
}
q__1.r = csq.r * s1.r - csq.i * s1.i, q__1.i = csq.r * s1.i + csq.i *
s1.r;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L130:
q__2.r = -z__->r, q__2.i = -z__->i;
q__1.r = q__2.r * s1.r - q__2.i * s1.i, q__1.i = q__2.r * s1.i + q__2.i *
s1.r;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L140:
q__2.r = sfac, q__2.i = 0.f;
q__1.r = s1.r * q__2.r - s1.i * q__2.i, q__1.i = s1.r * q__2.i + s1.i *
q__2.r;
s1.r = q__1.r, s1.i = q__1.i;
if (*id == 1) {
goto L150;
}
q__1.r = s1.r * csq.r - s1.i * csq.i, q__1.i = s1.r * csq.i + s1.i *
csq.r;
s1.r = q__1.r, s1.i = q__1.i;
r__1 = 1.f / sfac;
q__2.r = r__1, q__2.i = 0.f;
q__1.r = s1.r * q__2.r - s1.i * q__2.i, q__1.i = s1.r * q__2.i + s1.i *
q__2.r;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L150:
q__2.r = -s1.r, q__2.i = -s1.i;
q__1.r = q__2.r * z__->r - q__2.i * z__->i, q__1.i = q__2.r * z__->i +
q__2.i * z__->r;
s1.r = q__1.r, s1.i = q__1.i;
r__1 = 1.f / sfac;
q__2.r = r__1, q__2.i = 0.f;
q__1.r = s1.r * q__2.r - s1.i * q__2.i, q__1.i = s1.r * q__2.i + s1.i *
q__2.r;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L160:
aa = r1mach_(&c__1) * 1e3f;
s1.r = 0.f, s1.i = 0.f;
if (*id == 1) {
goto L170;
}
if (az > aa) {
q__2.r = c2, q__2.i = 0.f;
q__1.r = q__2.r * z__->r - q__2.i * z__->i, q__1.i = q__2.r * z__->i
+ q__2.i * z__->r;
s1.r = q__1.r, s1.i = q__1.i;
}
q__2.r = c1, q__2.i = 0.f;
q__1.r = q__2.r - s1.r, q__1.i = q__2.i - s1.i;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L170:
q__2.r = c2, q__2.i = 0.f;
q__1.r = -q__2.r, q__1.i = -q__2.i;
ai->r = q__1.r, ai->i = q__1.i;
aa = sqrt(aa);
if (az > aa) {
q__2.r = z__->r * z__->r - z__->i * z__->i, q__2.i = z__->r * z__->i
+ z__->i * z__->r;
q__1.r = q__2.r * .5f - q__2.i * 0.f, q__1.i = q__2.r * 0.f + q__2.i *
.5f;
s1.r = q__1.r, s1.i = q__1.i;
}
q__3.r = c1, q__3.i = 0.f;
q__2.r = s1.r * q__3.r - s1.i * q__3.i, q__2.i = s1.r * q__3.i + s1.i *
q__3.r;
q__1.r = ai->r + q__2.r, q__1.i = ai->i + q__2.i;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L180:
*nz = 1;
ai->r = 0.f, ai->i = 0.f;
return 0;
L240:
*nz = 0;
*ierr = 2;
return 0;
L250:
if (nn == -1) {
goto L240;
}
*nz = 0;
*ierr = 5;
return 0;
L260:
*ierr = 4;
*nz = 0;
return 0;
} /* cairy_ */
/* Subroutine */ int consts_(doublereal *coord)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4;
/* Builtin functions */
double sqrt(doublereal);
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Subroutine */ int s_stop(char *, ftnlen);
double cos(doublereal), pow_dd(doublereal *, doublereal *);
/* Local variables */
static integer i__, j, k, l;
static doublereal r__, x;
static integer i0, j1, j2, n0[2];
static doublereal x1, x2, x3, y1, y2, y3, aa;
static integer ii;
static doublereal ds, xa[3], ri, rj;
#define iw ((integer *)&chanel_1 + 5)
static doublereal xi[3], xj[3];
static integer ix;
static doublereal sp, xx[3];
static integer nn1, nn2, nn3;
static doublereal aij;
static logical din[1082];
static integer ipm, ips, jps;
static doublereal spm;
#define xsp ((doublereal *)&solv_1 + 161325)
static doublereal c2ds;
static integer nps0, nps3, nara, nari, narj, info, jmax;
static doublereal sdis, dist;
static integer ipiv[400], nset[64920];
static logical isup;
static doublereal sdis0, dist1, dist2, dist3, fdiag;
static integer narea, nsetf[400], inset;
extern /* Subroutine */ int dgetrf_(integer *, integer *, doublereal *,
integer *, integer *, integer *), dgetri_(integer *, doublereal *,
integer *, integer *, doublereal *, integer *, integer *);
static integer nsetfi, nsetfj, maxnps;
static doublereal sininv;
/* Fortran I/O blocks */
static cilist io___6 = { 0, 0, 0, 0, 0 };
static cilist io___43 = { 0, 0, 0, 0, 0 };
static cilist io___65 = { 0, 6, 0, 0, 0 };
static cilist io___66 = { 0, 6, 0, 0, 0 };
/* THIS ROUTINE CONSTRUCTS OR UPDATES THE SOLVENT-ACCESSIBLE */
/* SURFACE (SAS) */
/* COMDECK SIZES */
/* *********************************************************************** */
/* THIS FILE CONTAINS ALL THE ARRAY SIZES FOR USE IN MOPAC. */
/* THERE ARE ONLY 5 PARAMETERS THAT THE PROGRAMMER NEED SET: */
/* MAXHEV = MAXIMUM NUMBER OF HEAVY ATOMS (HEAVY: NON-HYDROGEN ATOMS) */
/* MAXLIT = MAXIMUM NUMBER OF HYDROGEN ATOMS. */
/* MAXTIM = DEFAULT TIME FOR A JOB. (SECONDS) */
/* MAXDMP = DEFAULT TIME FOR AUTOMATIC RESTART FILE GENERATION (SECS) */
/* ISYBYL = 1 IF MOPAC IS TO BE USED IN THE SYBYL PACKAGE, =0 OTHERWISE */
/* SEE ALSO NMECI, NPULAY AND MESP AT THE END OF THIS FILE */
/* *********************************************************************** */
/* THE FOLLOWING CODE DOES NOT NEED TO BE ALTERED BY THE PROGRAMMER */
/* *********************************************************************** */
/* ALL OTHER PARAMETERS ARE DERIVED FUNCTIONS OF THESE TWO PARAMETERS */
/* NAME DEFINITION */
/* NUMATM MAXIMUM NUMBER OF ATOMS ALLOWED. */
/* MAXORB MAXIMUM NUMBER OF ORBITALS ALLOWED. */
/* MAXPAR MAXIMUM NUMBER OF PARAMETERS FOR OPTIMISATION. */
/* N2ELEC MAXIMUM NUMBER OF TWO ELECTRON INTEGRALS ALLOWED. */
/* MPACK AREA OF LOWER HALF TRIANGLE OF DENSITY MATRIX. */
/* MORB2 SQUARE OF THE MAXIMUM NUMBER OF ORBITALS ALLOWED. */
/* MAXHES AREA OF HESSIAN MATRIX */
/* MAXALL LARGER THAN MAXORB OR MAXPAR. */
/* *********************************************************************** */
/* *********************************************************************** */
/* DECK MOPAC */
/* Parameter adjustments */
coord -= 4;
/* Function Body */
solv_1.nps = solvps_1.npsx;
solv_1.nps2 = solvps_1.nps2x;
isup = solv_1.nps > 0;
n0[0] = solv_1.nps2;
n0[1] = -solv_1.nps;
maxnps = sqrt(324000.25099999999f) - solv_1.nden - .5f;
maxnps = min(maxnps,400);
if (maxnps < molkst_1.numat * 3) {
io___6.ciunit = *iw;
s_wsle(&io___6);
do_lio(&c__9, &c__1, " PARAMETER LENABC MUST BE INCREASED FOR THIS S"
"YSTEM", (ftnlen)51);
e_wsle();
s_stop(" PARAMETER LENABC MUST BE INCREASED FOR THIS SYSTEM", (ftnlen)
51);
}
if (isup) {
nps3 = 400 - solv_1.nps;
for (i__ = solv_1.nps; i__ >= 1; --i__) {
solvi_1.iatsp[nps3 + i__ - 1] = solvi_1.iatsp[i__ - 1];
for (ix = 1; ix <= 3; ++ix) {
solv_1.cosurf[ix + (nps3 + i__) * 3 - 4] = solv_1.cosurf[ix +
i__ * 3 - 4];
/* L10: */
}
}
++nps3;
}
sdis = 0.;
fdiag = sqrt(1082.) * 1.05;
inset = 1;
solvi_1.iatsp[400] = 0;
solv_1.nps = 0;
areavd_1.area = 0.;
i__1 = molkst_1.numat;
for (i__ = 1; i__ <= i__1; ++i__) {
ds = sqrt(4. / solv_1.nspa);
if (molkst_1.nat[i__ - 1] == 1) {
ds *= 2;
}
c2ds = cos(ds * 2.);
r__ = solv_1.srad[i__ - 1];
ri = r__ - solv_1.rds;
for (ix = 1; ix <= 3; ++ix) {
/* L20: */
xa[ix - 1] = coord[ix + i__ * 3];
}
nps0 = solv_1.nps + 1;
if (isup) {
if (solv_1.nps >= nps3) {
s_stop("NPS .GT. NPS3", (ftnlen)13);
}
solv_1.nps2 = nps3;
/* IF (IATSP(NPS0) .NE. I) GO TO 340 */
for (ips = solv_1.nps2; ips <= 401; ++ips) {
/* L30: */
if (solvi_1.iatsp[ips - 1] != i__) {
goto L40;
}
}
L40:
nps3 = ips;
/* TRANSFORM COSURF ACCORDING TO TM(INV) */
i__2 = nps3 - 1;
for (j = solv_1.nps2; j <= i__2; ++j) {
xx[0] = solv_1.cosurf[j * 3 - 3];
xx[1] = solv_1.cosurf[j * 3 - 2];
xx[2] = solv_1.cosurf[j * 3 - 1];
solv_1.cosurf[j * 3 - 3] = xx[0] * solv_1.tm[(i__ * 3 + 1) *
3 - 12] + xx[1] * solv_1.tm[(i__ * 3 + 2) * 3 - 12] +
xx[2] * solv_1.tm[(i__ * 3 + 3) * 3 - 12];
solv_1.cosurf[j * 3 - 2] = xx[0] * solv_1.tm[(i__ * 3 + 1) *
3 - 11] + xx[1] * solv_1.tm[(i__ * 3 + 2) * 3 - 11] +
xx[2] * solv_1.tm[(i__ * 3 + 3) * 3 - 11];
solv_1.cosurf[j * 3 - 1] = xx[0] * solv_1.tm[(i__ * 3 + 1) *
3 - 10] + xx[1] * solv_1.tm[(i__ * 3 + 2) * 3 - 10] +
xx[2] * solv_1.tm[(i__ * 3 + 3) * 3 - 10];
/* L50: */
}
nn1 = dirvec_1.nn[i__ * 3 - 3];
nn2 = dirvec_1.nn[i__ * 3 - 2];
nn3 = dirvec_1.nn[i__ * 3 - 1];
} else {
/* SEARCH FOR 3 NEAREST NEIGHBOR ATOMS */
dist1 = 1e20;
dist2 = 1e20;
dist3 = 1e20;
nn1 = 0;
nn2 = 0;
nn3 = 0;
i__2 = molkst_1.numat;
for (j = 1; j <= i__2; ++j) {
if (j == i__) {
goto L70;
}
dist = 0.;
for (ix = 1; ix <= 3; ++ix) {
/* L60: */
/* Computing 2nd power */
d__1 = xa[ix - 1] - coord[ix + j * 3];
dist += d__1 * d__1;
}
if (dist + .05 < dist3) {
dist3 = dist;
nn3 = j;
}
if (dist3 + .05 < dist2) {
dist = dist2;
dist2 = dist3;
dist3 = dist;
nn3 = nn2;
nn2 = j;
}
if (dist2 + .05 < dist1) {
dist = dist1;
dist1 = dist2;
dist2 = dist;
nn2 = nn1;
nn1 = j;
}
L70:
;
}
dirvec_1.nn[i__ * 3 - 3] = nn1;
dirvec_1.nn[i__ * 3 - 2] = nn2;
dirvec_1.nn[i__ * 3 - 1] = nn3;
}
/* BUILD NEW TRANSFORMATION MATRIX */
if (nn1 == 0) {
solv_1.tm[(i__ * 3 + 1) * 3 - 12] = 1.;
solv_1.tm[(i__ * 3 + 2) * 3 - 12] = 0.;
solv_1.tm[(i__ * 3 + 3) * 3 - 12] = 0.;
} else {
dist1 = 0.;
for (ix = 1; ix <= 3; ++ix) {
/* L80: */
/* Computing 2nd power */
d__1 = xa[ix - 1] - coord[ix + nn1 * 3];
dist1 += d__1 * d__1;
}
dist = 1. / sqrt(dist1);
solv_1.tm[(i__ * 3 + 1) * 3 - 12] = (coord[nn1 * 3 + 1] - xa[0]) *
dist;
solv_1.tm[(i__ * 3 + 2) * 3 - 12] = (coord[nn1 * 3 + 2] - xa[1]) *
dist;
solv_1.tm[(i__ * 3 + 3) * 3 - 12] = (coord[nn1 * 3 + 3] - xa[2]) *
dist;
}
L90:
if (nn2 == 0) {
/* Computing 2nd power */
d__1 = solv_1.tm[(i__ * 3 + 3) * 3 - 12];
/* Computing 2nd power */
d__2 = solv_1.tm[(i__ * 3 + 2) * 3 - 12];
/* Computing 2nd power */
d__3 = solv_1.tm[(i__ * 3 + 1) * 3 - 12];
dist = sqrt(d__1 * d__1 + d__2 * d__2 + d__3 * d__3);
solv_1.tm[(i__ * 3 + 1) * 3 - 11] = -solv_1.tm[(i__ * 3 + 2) * 3
- 12] / dist;
solv_1.tm[(i__ * 3 + 2) * 3 - 11] = solv_1.tm[(i__ * 3 + 1) * 3 -
12] / dist;
solv_1.tm[(i__ * 3 + 3) * 3 - 11] = 0.;
} else {
dist2 = 0.;
for (ix = 1; ix <= 3; ++ix) {
/* L100: */
/* Computing 2nd power */
d__1 = xa[ix - 1] - coord[ix + nn2 * 3];
dist2 += d__1 * d__1;
}
dist = 1. / sqrt(dist2);
xx[0] = (coord[nn2 * 3 + 1] - xa[0]) * dist;
xx[1] = (coord[nn2 * 3 + 2] - xa[1]) * dist;
xx[2] = (coord[nn2 * 3 + 3] - xa[2]) * dist;
sp = xx[0] * solv_1.tm[(i__ * 3 + 1) * 3 - 12] + xx[1] *
solv_1.tm[(i__ * 3 + 2) * 3 - 12] + xx[2] * solv_1.tm[(
i__ * 3 + 3) * 3 - 12];
if (sp * sp > .99) {
nn2 = nn3;
nn3 = 0;
dist2 = dist3;
goto L90;
}
sininv = 1. / sqrt(1. - sp * sp);
solv_1.tm[(i__ * 3 + 1) * 3 - 11] = (xx[0] - sp * solv_1.tm[(i__ *
3 + 1) * 3 - 12]) * sininv;
solv_1.tm[(i__ * 3 + 2) * 3 - 11] = (xx[1] - sp * solv_1.tm[(i__ *
3 + 2) * 3 - 12]) * sininv;
solv_1.tm[(i__ * 3 + 3) * 3 - 11] = (xx[2] - sp * solv_1.tm[(i__ *
3 + 3) * 3 - 12]) * sininv;
}
solv_1.tm[(i__ * 3 + 1) * 3 - 10] = solv_1.tm[(i__ * 3 + 2) * 3 - 12]
* solv_1.tm[(i__ * 3 + 3) * 3 - 11] - solv_1.tm[(i__ * 3 + 2)
* 3 - 11] * solv_1.tm[(i__ * 3 + 3) * 3 - 12];
solv_1.tm[(i__ * 3 + 2) * 3 - 10] = solv_1.tm[(i__ * 3 + 3) * 3 - 12]
* solv_1.tm[(i__ * 3 + 1) * 3 - 11] - solv_1.tm[(i__ * 3 + 3)
* 3 - 11] * solv_1.tm[(i__ * 3 + 1) * 3 - 12];
solv_1.tm[(i__ * 3 + 3) * 3 - 10] = solv_1.tm[(i__ * 3 + 1) * 3 - 12]
* solv_1.tm[(i__ * 3 + 2) * 3 - 11] - solv_1.tm[(i__ * 3 + 1)
* 3 - 11] * solv_1.tm[(i__ * 3 + 2) * 3 - 12];
/* TRANSFORM DIRVEC ACCORDING TO TM */
for (j = 1; j <= 1082; ++j) {
xx[0] = dirvec_1.dirvec[j * 3 - 3];
xx[1] = dirvec_1.dirvec[j * 3 - 2];
xx[2] = dirvec_1.dirvec[j * 3 - 1];
for (ix = 1; ix <= 3; ++ix) {
x = xx[0] * solv_1.tm[(ix + i__ * 3) * 3 - 12] + xx[1] *
solv_1.tm[(ix + i__ * 3) * 3 - 11] + xx[2] *
solv_1.tm[(ix + i__ * 3) * 3 - 10];
solv_1.dirtm[ix + j * 3 - 4] = x;
/* L110: */
}
}
/* FIND THE POINTS OF THE BASIC GRID ON THE SAS */
narea = 0;
for (j = 1; j <= 1082; ++j) {
din[j - 1] = FALSE_;
for (ix = 1; ix <= 3; ++ix) {
xx[ix - 1] = xa[ix - 1] + solv_1.dirtm[ix + j * 3 - 4] * r__;
/* L130: */
}
i__2 = molkst_1.numat;
for (k = 1; k <= i__2; ++k) {
if (k == i__) {
goto L150;
}
dist = 0.;
for (ix = 1; ix <= 3; ++ix) {
/* Computing 2nd power */
d__1 = xx[ix - 1] - coord[ix + k * 3];
dist += d__1 * d__1;
/* L140: */
}
dist = sqrt(dist) - solv_1.srad[k - 1];
if (dist < 0.) {
goto L160;
}
L150:
;
}
++narea;
din[j - 1] = TRUE_;
L160:
;
}
if (narea == 0) {
goto L340;
}
areavd_1.area += narea * ri * ri;
if (isup) {
i__2 = nps3 - 1;
for (j = solv_1.nps2; j <= i__2; ++j) {
++solv_1.nps;
solvi_1.iatsp[solv_1.nps - 1] = i__;
xx[0] = solv_1.cosurf[j * 3 - 3];
xx[1] = solv_1.cosurf[j * 3 - 2];
xx[2] = solv_1.cosurf[j * 3 - 1];
solv_1.cosurf[solv_1.nps * 3 - 3] = xx[0] * solv_1.tm[(i__ *
3 + 1) * 3 - 12] + xx[1] * solv_1.tm[(i__ * 3 + 1) *
3 - 11] + xx[2] * solv_1.tm[(i__ * 3 + 1) * 3 - 10];
solv_1.cosurf[solv_1.nps * 3 - 2] = xx[0] * solv_1.tm[(i__ *
3 + 2) * 3 - 12] + xx[1] * solv_1.tm[(i__ * 3 + 2) *
3 - 11] + xx[2] * solv_1.tm[(i__ * 3 + 2) * 3 - 10];
solv_1.cosurf[solv_1.nps * 3 - 1] = xx[0] * solv_1.tm[(i__ *
3 + 3) * 3 - 12] + xx[1] * solv_1.tm[(i__ * 3 + 3) *
3 - 11] + xx[2] * solv_1.tm[(i__ * 3 + 3) * 3 - 10];
/* L120: */
}
} else {
i0 = 2 - 1 / molkst_1.nat[i__ - 1];
jmax = n0[i0 - 1];
i0 = (i0 - 1) * 3246 - 3;
i__2 = jmax;
for (j = 1; j <= i__2; ++j) {
++solv_1.nps;
solvi_1.iatsp[solv_1.nps - 1] = i__;
xx[0] = solv_1.abcmat[i0 + j * 3];
xx[1] = solv_1.abcmat[i0 + j * 3 + 1];
xx[2] = solv_1.abcmat[i0 + j * 3 + 2];
solv_1.cosurf[solv_1.nps * 3 - 3] = xx[0] * solv_1.tm[(i__ *
3 + 1) * 3 - 12] + xx[1] * solv_1.tm[(i__ * 3 + 1) *
3 - 11] + xx[2] * solv_1.tm[(i__ * 3 + 1) * 3 - 10];
solv_1.cosurf[solv_1.nps * 3 - 2] = xx[0] * solv_1.tm[(i__ *
3 + 2) * 3 - 12] + xx[1] * solv_1.tm[(i__ * 3 + 2) *
3 - 11] + xx[2] * solv_1.tm[(i__ * 3 + 2) * 3 - 10];
solv_1.cosurf[solv_1.nps * 3 - 1] = xx[0] * solv_1.tm[(i__ *
3 + 3) * 3 - 12] + xx[1] * solv_1.tm[(i__ * 3 + 3) *
3 - 11] + xx[2] * solv_1.tm[(i__ * 3 + 3) * 3 - 10];
/* L45: */
}
}
L200:
sdis0 = sdis;
i__2 = solv_1.nps;
for (ips = nps0; ips <= i__2; ++ips) {
solvi_1.nar[ips - 1] = 0;
xsp[ips * 3 - 3] = 0.;
xsp[ips * 3 - 2] = 0.;
xsp[ips * 3 - 1] = 0.;
/* L210: */
}
for (j = 1; j <= 1082; ++j) {
if (! din[j - 1]) {
goto L250;
}
spm = -1.;
x1 = solv_1.dirtm[j * 3 - 3];
x2 = solv_1.dirtm[j * 3 - 2];
x3 = solv_1.dirtm[j * 3 - 1];
i__2 = solv_1.nps;
for (ips = nps0; ips <= i__2; ++ips) {
sp = x1 * solv_1.cosurf[ips * 3 - 3] + x2 * solv_1.cosurf[ips
* 3 - 2] + x3 * solv_1.cosurf[ips * 3 - 1];
if (sp < spm) {
goto L220;
}
spm = sp;
ipm = ips;
L220:
;
}
if (spm < c2ds) {
++solv_1.nps;
if (solv_1.nps > maxnps) {
io___43.ciunit = *iw;
s_wsle(&io___43);
do_lio(&c__9, &c__1, "NPS IS GREATER THAN MAXNPS-USE SMA"
"LLER NSPA", (ftnlen)43);
e_wsle();
s_stop("NPS GREATER THAN MAXNPS", (ftnlen)23);
}
for (ix = 1; ix <= 3; ++ix) {
/* L230: */
solv_1.cosurf[ix + solv_1.nps * 3 - 4] = solv_1.dirtm[ix
+ j * 3 - 4];
}
solvi_1.iatsp[solv_1.nps - 1] = i__;
goto L200;
}
++solvi_1.nar[ipm - 1];
for (ix = 1; ix <= 3; ++ix) {
/* L240: */
xsp[ix + ipm * 3 - 4] += solv_1.dirtm[ix + j * 3 - 4];
}
L250:
;
}
sdis = 0.;
ips = nps0 - 1;
if (solv_1.nps < ips) {
goto L200;
}
L260:
++ips;
L352:
if (solvi_1.nar[ips - 1] == 0) {
--solv_1.nps;
if (solv_1.nps < ips) {
goto L200;
}
i__2 = solv_1.nps;
for (jps = ips; jps <= i__2; ++jps) {
solvi_1.nar[jps - 1] = solvi_1.nar[jps];
xsp[jps * 3 - 3] = xsp[(jps + 1) * 3 - 3];
xsp[jps * 3 - 2] = xsp[(jps + 1) * 3 - 2];
/* L369: */
xsp[jps * 3 - 1] = xsp[(jps + 1) * 3 - 1];
}
goto L352;
}
dist = 0.;
for (ix = 1; ix <= 3; ++ix) {
x = xsp[ix + ips * 3 - 4];
dist += x * x;
/* L280: */
}
sdis += dist;
dist = 1. / sqrt(dist);
for (ix = 1; ix <= 3; ++ix) {
/* L290: */
solv_1.cosurf[ix + ips * 3 - 4] = xsp[ix + ips * 3 - 4] * dist;
}
if (ips < solv_1.nps) {
goto L260;
}
if ((d__1 = sdis - sdis0, abs(d__1)) > 1e-5) {
goto L200;
}
i__2 = solv_1.nps;
for (ips = nps0; ips <= i__2; ++ips) {
nsetf[ips - 1] = inset;
inset += solvi_1.nar[ips - 1];
solvi_1.nar[ips - 1] = 0;
for (ix = 1; ix <= 3; ++ix) {
/* L300: */
xsp[ix + ips * 3 - 4] = xa[ix - 1] + solv_1.cosurf[ix + ips *
3 - 4] * ri;
}
/* L310: */
}
for (j = 1; j <= 1082; ++j) {
if (! din[j - 1]) {
goto L330;
}
spm = -1.;
x1 = solv_1.dirtm[j * 3 - 3];
x2 = solv_1.dirtm[j * 3 - 2];
x3 = solv_1.dirtm[j * 3 - 1];
i__2 = solv_1.nps;
for (ips = nps0; ips <= i__2; ++ips) {
sp = x1 * solv_1.cosurf[ips * 3 - 3] + x2 * solv_1.cosurf[ips
* 3 - 2] + x3 * solv_1.cosurf[ips * 3 - 1];
if (sp < spm) {
goto L320;
}
spm = sp;
ipm = ips;
L320:
;
}
if (spm < c2ds) {
goto L330;
}
nara = solvi_1.nar[ipm - 1];
nset[nsetf[ipm - 1] + nara - 1] = j;
solvi_1.nar[ipm - 1] = nara + 1;
L330:
;
}
L340:
;
}
areavd_1.area = areavd_1.area * 4. * 3.14159 / 1082;
/* FILLING AAMAT */
i__1 = solv_1.nps;
for (ips = 1; ips <= i__1; ++ips) {
i__ = solvi_1.iatsp[ips - 1];
ri = solv_1.srad[i__ - 1] - solv_1.rds;
nari = solvi_1.nar[ips - 1];
nsetfi = nsetf[ips - 1];
aa = 0.;
i__2 = nsetfi + nari - 1;
for (k = nsetfi; k <= i__2; ++k) {
j1 = nset[k - 1];
aa += fdiag;
x1 = dirvec_1.dirvec[j1 * 3 - 3];
x2 = dirvec_1.dirvec[j1 * 3 - 2];
x3 = dirvec_1.dirvec[j1 * 3 - 1];
i__3 = k - 1;
for (l = nsetfi; l <= i__3; ++l) {
j2 = nset[l - 1];
/* Computing 2nd power */
d__1 = x1 - dirvec_1.dirvec[j2 * 3 - 3];
/* Computing 2nd power */
d__2 = x2 - dirvec_1.dirvec[j2 * 3 - 2];
/* Computing 2nd power */
d__3 = x3 - dirvec_1.dirvec[j2 * 3 - 1];
aa += 2. / sqrt(d__1 * d__1 + d__2 * d__2 + d__3 * d__3);
/* L350: */
}
}
/* Computing 2nd power */
i__3 = nari;
aa = aa / ri / (i__3 * i__3);
solv_1.abcmat[ips + (ips - 1) * solv_1.nps - 1] = aa;
for (ix = 1; ix <= 3; ++ix) {
xi[ix - 1] = coord[ix + i__ * 3];
/* L360: */
xa[ix - 1] = xsp[ix + ips * 3 - 4];
}
i__3 = solv_1.nps;
for (jps = ips + 1; jps <= i__3; ++jps) {
narj = solvi_1.nar[jps - 1];
nsetfj = nsetf[jps - 1];
j = solvi_1.iatsp[jps - 1];
dist = 0.;
for (ix = 1; ix <= 3; ++ix) {
xj[ix - 1] = coord[ix + j * 3] - xi[ix - 1];
/* L370: */
/* Computing 2nd power */
d__1 = xsp[ix + jps * 3 - 4] - xa[ix - 1];
dist += d__1 * d__1;
}
if (dist < solv_1.disex2) {
rj = solv_1.srad[j - 1] - solv_1.rds;
aij = 0.;
i__2 = nsetfi + nari - 1;
for (k = nsetfi; k <= i__2; ++k) {
j1 = nset[k - 1];
for (ix = 1; ix <= 3; ++ix) {
/* L380: */
xx[ix - 1] = dirvec_1.dirvec[ix + j1 * 3 - 4] * ri;
}
if (i__ != j) {
x1 = xx[0] * solv_1.tm[(i__ * 3 + 1) * 3 - 12] + xx[1]
* solv_1.tm[(i__ * 3 + 1) * 3 - 11] + xx[2] *
solv_1.tm[(i__ * 3 + 1) * 3 - 10] - xj[0];
x2 = xx[0] * solv_1.tm[(i__ * 3 + 2) * 3 - 12] + xx[1]
* solv_1.tm[(i__ * 3 + 2) * 3 - 11] + xx[2] *
solv_1.tm[(i__ * 3 + 2) * 3 - 10] - xj[1];
x3 = xx[0] * solv_1.tm[(i__ * 3 + 3) * 3 - 12] + xx[1]
* solv_1.tm[(i__ * 3 + 3) * 3 - 11] + xx[2] *
solv_1.tm[(i__ * 3 + 3) * 3 - 10] - xj[2];
i__4 = nsetfj + narj - 1;
for (l = nsetfj; l <= i__4; ++l) {
j2 = nset[l - 1];
for (ix = 1; ix <= 3; ++ix) {
/* L390: */
xx[ix - 1] = dirvec_1.dirvec[ix + j2 * 3 - 4]
* rj;
}
y1 = xx[0] * solv_1.tm[(j * 3 + 1) * 3 - 12] + xx[
1] * solv_1.tm[(j * 3 + 1) * 3 - 11] + xx[
2] * solv_1.tm[(j * 3 + 1) * 3 - 10] - x1;
y2 = xx[0] * solv_1.tm[(j * 3 + 2) * 3 - 12] + xx[
1] * solv_1.tm[(j * 3 + 2) * 3 - 11] + xx[
2] * solv_1.tm[(j * 3 + 2) * 3 - 10] - x2;
y3 = xx[0] * solv_1.tm[(j * 3 + 3) * 3 - 12] + xx[
1] * solv_1.tm[(j * 3 + 3) * 3 - 11] + xx[
2] * solv_1.tm[(j * 3 + 3) * 3 - 10] - x3;
aij += 1. / sqrt(y1 * y1 + y2 * y2 + y3 * y3);
/* L400: */
}
} else {
/* L410: */
i__4 = nsetfj + narj - 1;
for (l = nsetfj; l <= i__4; ++l) {
j2 = nset[l - 1];
/* AA=((DIRVEC(1,J2)*RJ-XX(1))**2+(DIRVEC(2,J2)*RJ */
/* & -XX(2))**2+(DIRVEC(3,J2)*RJ-XX(3))**2) */
/* ***** Modified by Jiro Toyoda at 1994-05-25 ***** */
/* AIJ=AIJ+((DIRVEC(1,J2)*RJ-XX(1))**2+(DIRVEC(2,J2 */
/* 1)*RJ -XX(2))**2+(DIRVEC(3,J2)*RJ-XX(3))**2)**-.5 */
/* 2D0 */
/* Computing 2nd power */
d__2 = dirvec_1.dirvec[j2 * 3 - 3] * rj - xx[0];
/* Computing 2nd power */
d__3 = dirvec_1.dirvec[j2 * 3 - 2] * rj - xx[1];
/* Computing 2nd power */
d__4 = dirvec_1.dirvec[j2 * 3 - 1] * rj - xx[2];
d__1 = d__2 * d__2 + d__3 * d__3 + d__4 * d__4;
aij += pow_dd(&d__1, &c_b55);
/* ***************************** at 1994-05-25 ***** */
/* L420: */
}
}
/* L430: */
}
aij = aij / nari / narj;
} else {
aij = 1. / sqrt(dist);
}
solv_1.abcmat[ips + (jps - 1) * solv_1.nps - 1] = aij;
solv_1.abcmat[jps + (ips - 1) * solv_1.nps - 1] = aij;
/* L440: */
}
/* L450: */
}
/* INVERT A-MATRIX */
dgetrf_(&solv_1.nps, &solv_1.nps, solv_1.abcmat, &solv_1.nps, ipiv, &info)
;
if (info != 0) {
s_wsle(&io___65);
do_lio(&c__9, &c__1, " DGETRF FAILED WITH ERROR CODE ", (ftnlen)31);
do_lio(&c__3, &c__1, (char *)&info, (ftnlen)sizeof(integer));
e_wsle();
s_stop("CONSTS", (ftnlen)6);
}
dgetri_(&solv_1.nps, solv_1.abcmat, &solv_1.nps, ipiv, xsp, &c__1200, &
info);
if (info != 0) {
s_wsle(&io___66);
do_lio(&c__9, &c__1, " DGETRI FAILED WITH ERROR CODE ", (ftnlen)31);
do_lio(&c__3, &c__1, (char *)&info, (ftnlen)sizeof(integer));
e_wsle();
s_stop("CONSTS", (ftnlen)6);
}
/* STORE INV. A-MATRIX AS LOWER TRIANGLE */
ii = 0;
i__1 = solv_1.nps;
for (i__ = 1; i__ <= i__1; ++i__) {
i__3 = i__;
for (j = 1; j <= i__3; ++j) {
++ii;
solv_1.abcmat[ii - 1] = solv_1.abcmat[j + (i__ - 1) * solv_1.nps
- 1];
/* L460: */
}
}
solv_1.nps2 = ii;
return 0;
} /* consts_ */
/* 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 sneupd_(logical *rvec, char *howmny, logical *select,
real *dr, real *di, real *z__, integer *ldz, real *sigmar, real *
sigmai, real *workev, char *bmat, integer *n, char *which, integer *
nev, real *tol, real *resid, integer *ncv, real *v, integer *ldv,
integer *iparam, integer *ipntr, real *workd, real *workl, integer *
lworkl, integer *info, ftnlen howmny_len, ftnlen bmat_len, ftnlen
which_len)
{
/* System generated locals */
integer v_dim1, v_offset, z_dim1, z_offset, i__1;
real r__1, r__2;
doublereal d__1;
/* Local variables */
static integer j, k, ih, jj, np;
static real vl[1] /* was [1][1] */;
static integer ibd, ldh, ldq, iri;
static real sep;
static integer irr, wri, wrr, mode;
static real eps23;
extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
integer *, real *, integer *, real *, integer *);
static integer ierr;
static real temp;
static integer iwev;
static char type__[6];
static real temp1;
extern doublereal snrm2_(integer *, real *, integer *);
static integer ihbds, iconj;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static real conds;
static logical reord;
extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *,
ftnlen);
static integer nconv, iwork[1];
static real rnorm;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
static integer ritzi;
extern /* Subroutine */ int strmm_(char *, char *, char *, char *,
integer *, integer *, real *, real *, integer *, real *, integer *
, ftnlen, ftnlen, ftnlen, ftnlen), ivout_(integer *, integer *,
integer *, integer *, char *, ftnlen), smout_(integer *, integer *
, integer *, real *, integer *, integer *, char *, ftnlen);
static integer ritzr;
extern /* Subroutine */ int svout_(integer *, integer *, real *, integer *
, char *, ftnlen), sgeqr2_(integer *, integer *, real *, integer *
, real *, real *, integer *);
static integer nconv2;
extern doublereal slapy2_(real *, real *);
extern /* Subroutine */ int sorm2r_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, real *, integer *, real *,
integer *, ftnlen, ftnlen);
static integer iheigi, iheigr, bounds, invsub, iuptri, msglvl, outncv,
ishift, numcnv;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *, ftnlen), slahqr_(logical *, logical
*, integer *, integer *, integer *, real *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *),
slaset_(char *, integer *, integer *, real *, real *, real *,
integer *, ftnlen), strevc_(char *, char *, logical *, integer *,
real *, integer *, real *, integer *, real *, integer *, integer *
, integer *, real *, integer *, ftnlen, ftnlen), strsen_(char *,
char *, logical *, integer *, real *, integer *, real *, integer *
, real *, real *, integer *, real *, real *, real *, integer *,
integer *, integer *, integer *, ftnlen, ftnlen);
extern doublereal slamch_(char *, ftnlen);
extern /* Subroutine */ int sngets_(integer *, char *, integer *, integer
*, real *, real *, real *, real *, real *, ftnlen);
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %---------------% */
/* | Local Scalars | */
/* %---------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %---------------------% */
/* | Intrinsic Functions | */
/* %---------------------% */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
/* %------------------------% */
/* | Set default parameters | */
/* %------------------------% */
/* Parameter adjustments */
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--workd;
--resid;
--di;
--dr;
--workev;
--select;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--iparam;
--ipntr;
--workl;
/* Function Body */
msglvl = debug_1.mneupd;
mode = iparam[7];
nconv = iparam[5];
*info = 0;
/* %---------------------------------% */
/* | Get machine dependent constant. | */
/* %---------------------------------% */
eps23 = slamch_("Epsilon-Machine", (ftnlen)15);
d__1 = (doublereal) eps23;
eps23 = pow_dd(&d__1, &c_b3);
/* %--------------% */
/* | Quick return | */
/* %--------------% */
ierr = 0;
if (nconv <= 0) {
ierr = -14;
} else if (*n <= 0) {
ierr = -1;
} else if (*nev <= 0) {
ierr = -2;
} else if (*ncv <= *nev + 1 || *ncv > *n) {
ierr = -3;
} else if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which,
"SM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "LR", (ftnlen)2,
(ftnlen)2) != 0 && s_cmp(which, "SR", (ftnlen)2, (ftnlen)2) != 0
&& s_cmp(which, "LI", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which,
"SI", (ftnlen)2, (ftnlen)2) != 0) {
ierr = -5;
} else if (*(unsigned char *)bmat != 'I' && *(unsigned char *)bmat != 'G')
{
ierr = -6;
} else /* if(complicated condition) */ {
/* Computing 2nd power */
i__1 = *ncv;
if (*lworkl < i__1 * i__1 * 3 + *ncv * 6) {
ierr = -7;
} else if (*(unsigned char *)howmny != 'A' && *(unsigned char *)
howmny != 'P' && *(unsigned char *)howmny != 'S' && *rvec) {
ierr = -13;
} else if (*(unsigned char *)howmny == 'S') {
ierr = -12;
}
}
if (mode == 1 || mode == 2) {
s_copy(type__, "REGULR", (ftnlen)6, (ftnlen)6);
} else if (mode == 3 && *sigmai == 0.f) {
s_copy(type__, "SHIFTI", (ftnlen)6, (ftnlen)6);
} else if (mode == 3) {
s_copy(type__, "REALPT", (ftnlen)6, (ftnlen)6);
} else if (mode == 4) {
s_copy(type__, "IMAGPT", (ftnlen)6, (ftnlen)6);
} else {
ierr = -10;
}
if (mode == 1 && *(unsigned char *)bmat == 'G') {
ierr = -11;
}
/* %------------% */
/* | Error Exit | */
/* %------------% */
if (ierr != 0) {
*info = ierr;
goto L9000;
}
/* %--------------------------------------------------------% */
/* | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | */
/* | etc... and the remaining workspace. | */
/* | Also update pointer to be used on output. | */
/* | Memory is laid out as follows: | */
/* | workl(1:ncv*ncv) := generated Hessenberg matrix | */
/* | workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary | */
/* | parts of ritz values | */
/* | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds | */
/* %--------------------------------------------------------% */
/* %-----------------------------------------------------------% */
/* | The following is used and set by SNEUPD. | */
/* | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed | */
/* | real part of the Ritz values. | */
/* | workl(ncv*ncv+4*ncv+1:ncv*ncv+5*ncv) := The untransformed | */
/* | imaginary part of the Ritz values. | */
/* | workl(ncv*ncv+5*ncv+1:ncv*ncv+6*ncv) := The untransformed | */
/* | error bounds of the Ritz values | */
/* | workl(ncv*ncv+6*ncv+1:2*ncv*ncv+6*ncv) := Holds the upper | */
/* | quasi-triangular matrix for H | */
/* | workl(2*ncv*ncv+6*ncv+1: 3*ncv*ncv+6*ncv) := Holds the | */
/* | associated matrix representation of the invariant | */
/* | subspace for H. | */
/* | GRAND total of NCV * ( 3 * NCV + 6 ) locations. | */
/* %-----------------------------------------------------------% */
ih = ipntr[5];
ritzr = ipntr[6];
ritzi = ipntr[7];
bounds = ipntr[8];
ldh = *ncv;
ldq = *ncv;
iheigr = bounds + ldh;
iheigi = iheigr + ldh;
ihbds = iheigi + ldh;
iuptri = ihbds + ldh;
invsub = iuptri + ldh * *ncv;
ipntr[9] = iheigr;
ipntr[10] = iheigi;
ipntr[11] = ihbds;
ipntr[12] = iuptri;
ipntr[13] = invsub;
wrr = 1;
wri = *ncv + 1;
iwev = wri + *ncv;
/* %-----------------------------------------% */
/* | irr points to the REAL part of the Ritz | */
/* | values computed by _neigh before | */
/* | exiting _naup2. | */
/* | iri points to the IMAGINARY part of the | */
/* | Ritz values computed by _neigh | */
/* | before exiting _naup2. | */
/* | ibd points to the Ritz estimates | */
/* | computed by _neigh before exiting | */
/* | _naup2. | */
/* %-----------------------------------------% */
irr = ipntr[14] + *ncv * *ncv;
iri = irr + *ncv;
ibd = iri + *ncv;
/* %------------------------------------% */
/* | RNORM is B-norm of the RESID(1:N). | */
/* %------------------------------------% */
rnorm = workl[ih + 2];
workl[ih + 2] = 0.f;
if (msglvl > 2) {
svout_(&debug_1.logfil, ncv, &workl[irr], &debug_1.ndigit, "_neupd: "
"Real part of Ritz values passed in from _NAUPD.", (ftnlen)55);
svout_(&debug_1.logfil, ncv, &workl[iri], &debug_1.ndigit, "_neupd: "
"Imag part of Ritz values passed in from _NAUPD.", (ftnlen)55);
svout_(&debug_1.logfil, ncv, &workl[ibd], &debug_1.ndigit, "_neupd: "
"Ritz estimates passed in from _NAUPD.", (ftnlen)45);
}
if (*rvec) {
reord = FALSE_;
/* %---------------------------------------------------% */
/* | Use the temporary bounds array to store indices | */
/* | These will be used to mark the select array later | */
/* %---------------------------------------------------% */
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
workl[bounds + j - 1] = (real) j;
select[j] = FALSE_;
/* L10: */
}
/* %-------------------------------------% */
/* | Select the wanted Ritz values. | */
/* | Sort the Ritz values so that the | */
/* | wanted ones appear at the tailing | */
/* | NEV positions of workl(irr) and | */
/* | workl(iri). Move the corresponding | */
/* | error estimates in workl(bound) | */
/* | accordingly. | */
/* %-------------------------------------% */
np = *ncv - *nev;
ishift = 0;
sngets_(&ishift, which, nev, &np, &workl[irr], &workl[iri], &workl[
bounds], &workl[1], &workl[np + 1], (ftnlen)2);
if (msglvl > 2) {
svout_(&debug_1.logfil, ncv, &workl[irr], &debug_1.ndigit, "_neu"
"pd: Real part of Ritz values after calling _NGETS.", (
ftnlen)54);
svout_(&debug_1.logfil, ncv, &workl[iri], &debug_1.ndigit, "_neu"
"pd: Imag part of Ritz values after calling _NGETS.", (
ftnlen)54);
svout_(&debug_1.logfil, ncv, &workl[bounds], &debug_1.ndigit,
"_neupd: Ritz value indices after calling _NGETS.", (
ftnlen)48);
}
/* %-----------------------------------------------------% */
/* | Record indices of the converged wanted Ritz values | */
/* | Mark the select array for possible reordering | */
/* %-----------------------------------------------------% */
numcnv = 0;
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__1 = eps23, r__2 = slapy2_(&workl[irr + *ncv - j], &workl[iri +
*ncv - j]);
temp1 = dmax(r__1,r__2);
jj = workl[bounds + *ncv - j];
if (numcnv < nconv && workl[ibd + jj - 1] <= *tol * temp1) {
select[jj] = TRUE_;
++numcnv;
if (jj > nconv) {
reord = TRUE_;
}
}
/* L11: */
}
/* %-----------------------------------------------------------% */
/* | Check the count (numcnv) of converged Ritz values with | */
/* | the number (nconv) reported by dnaupd. If these two | */
/* | are different then there has probably been an error | */
/* | caused by incorrect passing of the dnaupd data. | */
/* %-----------------------------------------------------------% */
if (msglvl > 2) {
ivout_(&debug_1.logfil, &c__1, &numcnv, &debug_1.ndigit, "_neupd"
": Number of specified eigenvalues", (ftnlen)39);
ivout_(&debug_1.logfil, &c__1, &nconv, &debug_1.ndigit, "_neupd:"
" Number of \"converged\" eigenvalues", (ftnlen)41);
}
if (numcnv != nconv) {
*info = -15;
goto L9000;
}
/* %-----------------------------------------------------------% */
/* | Call LAPACK routine slahqr to compute the real Schur form | */
/* | of the upper Hessenberg matrix returned by SNAUPD. | */
/* | Make a copy of the upper Hessenberg matrix. | */
/* | Initialize the Schur vector matrix Q to the identity. | */
/* %-----------------------------------------------------------% */
i__1 = ldh * *ncv;
scopy_(&i__1, &workl[ih], &c__1, &workl[iuptri], &c__1);
slaset_("All", ncv, ncv, &c_b37, &c_b38, &workl[invsub], &ldq, (
ftnlen)3);
slahqr_(&c_true, &c_true, ncv, &c__1, ncv, &workl[iuptri], &ldh, &
workl[iheigr], &workl[iheigi], &c__1, ncv, &workl[invsub], &
ldq, &ierr);
scopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], &c__1);
if (ierr != 0) {
*info = -8;
goto L9000;
}
if (msglvl > 1) {
svout_(&debug_1.logfil, ncv, &workl[iheigr], &debug_1.ndigit,
"_neupd: Real part of the eigenvalues of H", (ftnlen)41);
svout_(&debug_1.logfil, ncv, &workl[iheigi], &debug_1.ndigit,
"_neupd: Imaginary part of the Eigenvalues of H", (ftnlen)
46);
svout_(&debug_1.logfil, ncv, &workl[ihbds], &debug_1.ndigit,
"_neupd: Last row of the Schur vector matrix", (ftnlen)43)
;
if (msglvl > 3) {
smout_(&debug_1.logfil, ncv, ncv, &workl[iuptri], &ldh, &
debug_1.ndigit, "_neupd: The upper quasi-triangular "
"matrix ", (ftnlen)42);
}
}
if (reord) {
/* %-----------------------------------------------------% */
/* | Reorder the computed upper quasi-triangular matrix. | */
/* %-----------------------------------------------------% */
strsen_("None", "V", &select[1], ncv, &workl[iuptri], &ldh, &
workl[invsub], &ldq, &workl[iheigr], &workl[iheigi], &
nconv2, &conds, &sep, &workl[ihbds], ncv, iwork, &c__1, &
ierr, (ftnlen)4, (ftnlen)1);
if (nconv2 < nconv) {
nconv = nconv2;
}
if (ierr == 1) {
*info = 1;
goto L9000;
}
if (msglvl > 2) {
svout_(&debug_1.logfil, ncv, &workl[iheigr], &debug_1.ndigit,
"_neupd: Real part of the eigenvalues of H--reordered"
, (ftnlen)52);
svout_(&debug_1.logfil, ncv, &workl[iheigi], &debug_1.ndigit,
"_neupd: Imag part of the eigenvalues of H--reordered"
, (ftnlen)52);
if (msglvl > 3) {
smout_(&debug_1.logfil, ncv, ncv, &workl[iuptri], &ldq, &
debug_1.ndigit, "_neupd: Quasi-triangular matrix"
" after re-ordering", (ftnlen)49);
}
}
}
/* %---------------------------------------% */
/* | Copy the last row of the Schur vector | */
/* | into workl(ihbds). This will be used | */
/* | to compute the Ritz estimates of | */
/* | converged Ritz values. | */
/* %---------------------------------------% */
scopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], &c__1);
/* %----------------------------------------------------% */
/* | Place the computed eigenvalues of H into DR and DI | */
/* | if a spectral transformation was not used. | */
/* %----------------------------------------------------% */
if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0) {
scopy_(&nconv, &workl[iheigr], &c__1, &dr[1], &c__1);
scopy_(&nconv, &workl[iheigi], &c__1, &di[1], &c__1);
}
/* %----------------------------------------------------------% */
/* | Compute the QR factorization of the matrix representing | */
/* | the wanted invariant subspace located in the first NCONV | */
/* | columns of workl(invsub,ldq). | */
/* %----------------------------------------------------------% */
sgeqr2_(ncv, &nconv, &workl[invsub], &ldq, &workev[1], &workev[*ncv +
1], &ierr);
/* %---------------------------------------------------------% */
/* | * Postmultiply V by Q using sorm2r. | */
/* | * Copy the first NCONV columns of VQ into Z. | */
/* | * Postmultiply Z by R. | */
/* | The N by NCONV matrix Z is now a matrix representation | */
/* | of the approximate invariant subspace associated with | */
/* | the Ritz values in workl(iheigr) and workl(iheigi) | */
/* | The first NCONV columns of V are now approximate Schur | */
/* | vectors associated with the real upper quasi-triangular | */
/* | matrix of order NCONV in workl(iuptri) | */
/* %---------------------------------------------------------% */
sorm2r_("Right", "Notranspose", n, ncv, &nconv, &workl[invsub], &ldq,
&workev[1], &v[v_offset], ldv, &workd[*n + 1], &ierr, (ftnlen)
5, (ftnlen)11);
slacpy_("All", n, &nconv, &v[v_offset], ldv, &z__[z_offset], ldz, (
ftnlen)3);
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
/* %---------------------------------------------------% */
/* | Perform both a column and row scaling if the | */
/* | diagonal element of workl(invsub,ldq) is negative | */
/* | I'm lazy and don't take advantage of the upper | */
/* | quasi-triangular form of workl(iuptri,ldq) | */
/* | Note that since Q is orthogonal, R is a diagonal | */
/* | matrix consisting of plus or minus ones | */
/* %---------------------------------------------------% */
if (workl[invsub + (j - 1) * ldq + j - 1] < 0.f) {
sscal_(&nconv, &c_b64, &workl[iuptri + j - 1], &ldq);
sscal_(&nconv, &c_b64, &workl[iuptri + (j - 1) * ldq], &c__1);
}
/* L20: */
}
if (*(unsigned char *)howmny == 'A') {
/* %--------------------------------------------% */
/* | Compute the NCONV wanted eigenvectors of T | */
/* | located in workl(iuptri,ldq). | */
/* %--------------------------------------------% */
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
if (j <= nconv) {
select[j] = TRUE_;
} else {
select[j] = FALSE_;
}
/* L30: */
}
strevc_("Right", "Select", &select[1], ncv, &workl[iuptri], &ldq,
vl, &c__1, &workl[invsub], &ldq, ncv, &outncv, &workev[1],
&ierr, (ftnlen)5, (ftnlen)6);
if (ierr != 0) {
*info = -9;
goto L9000;
}
/* %------------------------------------------------% */
/* | Scale the returning eigenvectors so that their | */
/* | Euclidean norms are all one. LAPACK subroutine | */
/* | strevc returns each eigenvector normalized so | */
/* | that the element of largest magnitude has | */
/* | magnitude 1; | */
/* %------------------------------------------------% */
iconj = 0;
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
if (workl[iheigi + j - 1] == 0.f) {
/* %----------------------% */
/* | real eigenvalue case | */
/* %----------------------% */
temp = snrm2_(ncv, &workl[invsub + (j - 1) * ldq], &c__1);
r__1 = 1.f / temp;
sscal_(ncv, &r__1, &workl[invsub + (j - 1) * ldq], &c__1);
} else {
/* %-------------------------------------------% */
/* | Complex conjugate pair case. Note that | */
/* | since the real and imaginary part of | */
/* | the eigenvector are stored in consecutive | */
/* | columns, we further normalize by the | */
/* | square root of two. | */
/* %-------------------------------------------% */
if (iconj == 0) {
r__1 = snrm2_(ncv, &workl[invsub + (j - 1) * ldq], &
c__1);
r__2 = snrm2_(ncv, &workl[invsub + j * ldq], &c__1);
temp = slapy2_(&r__1, &r__2);
r__1 = 1.f / temp;
sscal_(ncv, &r__1, &workl[invsub + (j - 1) * ldq], &
c__1);
r__1 = 1.f / temp;
sscal_(ncv, &r__1, &workl[invsub + j * ldq], &c__1);
iconj = 1;
} else {
iconj = 0;
}
}
/* L40: */
}
sgemv_("T", ncv, &nconv, &c_b38, &workl[invsub], &ldq, &workl[
ihbds], &c__1, &c_b37, &workev[1], &c__1, (ftnlen)1);
iconj = 0;
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
if (workl[iheigi + j - 1] != 0.f) {
/* %-------------------------------------------% */
/* | Complex conjugate pair case. Note that | */
/* | since the real and imaginary part of | */
/* | the eigenvector are stored in consecutive | */
/* %-------------------------------------------% */
if (iconj == 0) {
workev[j] = slapy2_(&workev[j], &workev[j + 1]);
workev[j + 1] = workev[j];
iconj = 1;
} else {
iconj = 0;
}
}
/* L45: */
}
if (msglvl > 2) {
scopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], &
c__1);
svout_(&debug_1.logfil, ncv, &workl[ihbds], &debug_1.ndigit,
"_neupd: Last row of the eigenvector matrix for T", (
ftnlen)48);
if (msglvl > 3) {
smout_(&debug_1.logfil, ncv, ncv, &workl[invsub], &ldq, &
debug_1.ndigit, "_neupd: The eigenvector matrix "
"for T", (ftnlen)36);
}
}
/* %---------------------------------------% */
/* | Copy Ritz estimates into workl(ihbds) | */
/* %---------------------------------------% */
scopy_(&nconv, &workev[1], &c__1, &workl[ihbds], &c__1);
/* %---------------------------------------------------------% */
/* | Compute the QR factorization of the eigenvector matrix | */
/* | associated with leading portion of T in the first NCONV | */
/* | columns of workl(invsub,ldq). | */
/* %---------------------------------------------------------% */
sgeqr2_(ncv, &nconv, &workl[invsub], &ldq, &workev[1], &workev[*
ncv + 1], &ierr);
/* %----------------------------------------------% */
/* | * Postmultiply Z by Q. | */
/* | * Postmultiply Z by R. | */
/* | The N by NCONV matrix Z is now contains the | */
/* | Ritz vectors associated with the Ritz values | */
/* | in workl(iheigr) and workl(iheigi). | */
/* %----------------------------------------------% */
sorm2r_("Right", "Notranspose", n, ncv, &nconv, &workl[invsub], &
ldq, &workev[1], &z__[z_offset], ldz, &workd[*n + 1], &
ierr, (ftnlen)5, (ftnlen)11);
strmm_("Right", "Upper", "No transpose", "Non-unit", n, &nconv, &
c_b38, &workl[invsub], &ldq, &z__[z_offset], ldz, (ftnlen)
5, (ftnlen)5, (ftnlen)12, (ftnlen)8);
}
} else {
/* %------------------------------------------------------% */
/* | An approximate invariant subspace is not needed. | */
/* | Place the Ritz values computed SNAUPD into DR and DI | */
/* %------------------------------------------------------% */
scopy_(&nconv, &workl[ritzr], &c__1, &dr[1], &c__1);
scopy_(&nconv, &workl[ritzi], &c__1, &di[1], &c__1);
scopy_(&nconv, &workl[ritzr], &c__1, &workl[iheigr], &c__1);
scopy_(&nconv, &workl[ritzi], &c__1, &workl[iheigi], &c__1);
scopy_(&nconv, &workl[bounds], &c__1, &workl[ihbds], &c__1);
}
/* %------------------------------------------------% */
/* | Transform the Ritz values and possibly vectors | */
/* | and corresponding error bounds of OP to those | */
/* | of A*x = lambda*B*x. | */
/* %------------------------------------------------% */
if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0) {
if (*rvec) {
sscal_(ncv, &rnorm, &workl[ihbds], &c__1);
}
} else {
/* %---------------------------------------% */
/* | A spectral transformation was used. | */
/* | * Determine the Ritz estimates of the | */
/* | Ritz values in the original system. | */
/* %---------------------------------------% */
if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) {
if (*rvec) {
sscal_(ncv, &rnorm, &workl[ihbds], &c__1);
}
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
temp = slapy2_(&workl[iheigr + k - 1], &workl[iheigi + k - 1])
;
workl[ihbds + k - 1] = (r__1 = workl[ihbds + k - 1], dabs(
r__1)) / temp / temp;
/* L50: */
}
} else if (s_cmp(type__, "REALPT", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
/* L60: */
}
} else if (s_cmp(type__, "IMAGPT", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
/* L70: */
}
}
/* %-----------------------------------------------------------% */
/* | * Transform the Ritz values back to the original system. | */
/* | For TYPE = 'SHIFTI' the transformation is | */
/* | lambda = 1/theta + sigma | */
/* | For TYPE = 'REALPT' or 'IMAGPT' the user must from | */
/* | Rayleigh quotients or a projection. See remark 3 above.| */
/* | NOTES: | */
/* | *The Ritz vectors are not affected by the transformation. | */
/* %-----------------------------------------------------------% */
if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
temp = slapy2_(&workl[iheigr + k - 1], &workl[iheigi + k - 1])
;
workl[iheigr + k - 1] = workl[iheigr + k - 1] / temp / temp +
*sigmar;
workl[iheigi + k - 1] = -workl[iheigi + k - 1] / temp / temp
+ *sigmai;
/* L80: */
}
scopy_(&nconv, &workl[iheigr], &c__1, &dr[1], &c__1);
scopy_(&nconv, &workl[iheigi], &c__1, &di[1], &c__1);
} else if (s_cmp(type__, "REALPT", (ftnlen)6, (ftnlen)6) == 0 ||
s_cmp(type__, "IMAGPT", (ftnlen)6, (ftnlen)6) == 0) {
scopy_(&nconv, &workl[iheigr], &c__1, &dr[1], &c__1);
scopy_(&nconv, &workl[iheigi], &c__1, &di[1], &c__1);
}
}
if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0 && msglvl > 1) {
svout_(&debug_1.logfil, &nconv, &dr[1], &debug_1.ndigit, "_neupd: Un"
"transformed real part of the Ritz valuess.", (ftnlen)52);
svout_(&debug_1.logfil, &nconv, &di[1], &debug_1.ndigit, "_neupd: Un"
"transformed imag part of the Ritz valuess.", (ftnlen)52);
svout_(&debug_1.logfil, &nconv, &workl[ihbds], &debug_1.ndigit, "_ne"
"upd: Ritz estimates of untransformed Ritz values.", (ftnlen)
52);
} else if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0 && msglvl >
1) {
svout_(&debug_1.logfil, &nconv, &dr[1], &debug_1.ndigit, "_neupd: Re"
"al parts of converged Ritz values.", (ftnlen)44);
svout_(&debug_1.logfil, &nconv, &di[1], &debug_1.ndigit, "_neupd: Im"
"ag parts of converged Ritz values.", (ftnlen)44);
svout_(&debug_1.logfil, &nconv, &workl[ihbds], &debug_1.ndigit, "_ne"
"upd: Associated Ritz estimates.", (ftnlen)34);
}
/* %-------------------------------------------------% */
/* | Eigenvector Purification step. Formally perform | */
/* | one of inverse subspace iteration. Only used | */
/* | for MODE = 2. | */
/* %-------------------------------------------------% */
if (*rvec && *(unsigned char *)howmny == 'A' && s_cmp(type__, "SHIFTI", (
ftnlen)6, (ftnlen)6) == 0) {
/* %------------------------------------------------% */
/* | Purify the computed Ritz vectors by adding a | */
/* | little bit of the residual vector: | */
/* | T | */
/* | resid(:)*( e s ) / theta | */
/* | NCV | */
/* | where H s = s theta. Remember that when theta | */
/* | has nonzero imaginary part, the corresponding | */
/* | Ritz vector is stored across two columns of Z. | */
/* %------------------------------------------------% */
iconj = 0;
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
if (workl[iheigi + j - 1] == 0.f) {
workev[j] = workl[invsub + (j - 1) * ldq + *ncv - 1] / workl[
iheigr + j - 1];
} else if (iconj == 0) {
temp = slapy2_(&workl[iheigr + j - 1], &workl[iheigi + j - 1])
;
workev[j] = (workl[invsub + (j - 1) * ldq + *ncv - 1] * workl[
iheigr + j - 1] + workl[invsub + j * ldq + *ncv - 1] *
workl[iheigi + j - 1]) / temp / temp;
workev[j + 1] = (workl[invsub + j * ldq + *ncv - 1] * workl[
iheigr + j - 1] - workl[invsub + (j - 1) * ldq + *ncv
- 1] * workl[iheigi + j - 1]) / temp / temp;
iconj = 1;
} else {
iconj = 0;
}
/* L110: */
}
/* %---------------------------------------% */
/* | Perform a rank one update to Z and | */
/* | purify all the Ritz vectors together. | */
/* %---------------------------------------% */
sger_(n, &nconv, &c_b38, &resid[1], &c__1, &workev[1], &c__1, &z__[
z_offset], ldz);
}
L9000:
return 0;
/* %---------------% */
/* | End of SNEUPD | */
/* %---------------% */
} /* sneupd_ */
/* Subroutine */ int dlatm7_(integer *mode, doublereal *cond, integer *irsign,
integer *idist, integer *iseed, doublereal *d__, integer *n, integer
*rank, integer *info)
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1;
/* Local variables */
integer i__;
doublereal temp, alpha;
extern doublereal dlaran_(integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Craig Lucas, University of Manchester / NAG Ltd. */
/* October, 2008 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLATM7 computes the entries of D as specified by MODE */
/* COND and IRSIGN. IDIST and ISEED determine the generation */
/* of random numbers. DLATM7 is called by DLATMT to generate */
/* random test matrices. */
/* Arguments */
/* ========= */
/* MODE - INTEGER */
/* On entry describes how D is to be computed: */
/* MODE = 0 means do not change D. */
/* MODE = 1 sets D(1)=1 and D(2:RANK)=1.0/COND */
/* MODE = 2 sets D(1:RANK-1)=1 and D(RANK)=1.0/COND */
/* MODE = 3 sets D(I)=COND**(-(I-1)/(RANK-1)) I=1:RANK */
/* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
/* MODE = 5 sets D to random numbers in the range */
/* ( 1/COND , 1 ) such that their logarithms */
/* are uniformly distributed. */
/* MODE = 6 set D to random numbers from same distribution */
/* as the rest of the matrix. */
/* MODE < 0 has the same meaning as ABS(MODE), except that */
/* the order of the elements of D is reversed. */
/* Thus if MODE is positive, D has entries ranging from */
/* 1 to 1/COND, if negative, from 1/COND to 1, */
/* Not modified. */
/* COND - DOUBLE PRECISION */
/* On entry, used as described under MODE above. */
/* If used, it must be >= 1. Not modified. */
/* IRSIGN - INTEGER */
/* On entry, if MODE neither -6, 0 nor 6, determines sign of */
/* entries of D */
/* 0 => leave entries of D unchanged */
/* 1 => multiply each entry of D by 1 or -1 with probability .5 */
/* IDIST - CHARACTER*1 */
/* On entry, IDIST specifies the type of distribution to be */
/* used to generate a random matrix . */
/* 1 => UNIFORM( 0, 1 ) */
/* 2 => UNIFORM( -1, 1 ) */
/* 3 => NORMAL( 0, 1 ) */
/* Not modified. */
/* ISEED - INTEGER array, dimension ( 4 ) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The random number generator uses a */
/* linear congruential sequence limited to small */
/* integers, and so should produce machine independent */
/* random numbers. The values of ISEED are changed on */
/* exit, and can be used in the next call to DLATM7 */
/* to continue the same random number sequence. */
/* Changed on exit. */
/* D - DOUBLE PRECISION array, dimension ( MIN( M , N ) ) */
/* Array to be computed according to MODE, COND and IRSIGN. */
/* May be changed on exit if MODE is nonzero. */
/* N - INTEGER */
/* Number of entries of D. Not modified. */
/* RANK - INTEGER */
/* The rank of matrix to be generated for modes 1,2,3 only. */
/* D( RANK+1:N ) = 0. */
/* Not modified. */
/* INFO - INTEGER */
/* 0 => normal termination */
/* -1 => if MODE not in range -6 to 6 */
/* -2 => if MODE neither -6, 0 nor 6, and */
/* IRSIGN neither 0 nor 1 */
/* -3 => if MODE neither -6, 0 nor 6 and COND less than 1 */
/* -4 => if MODE equals 6 or -6 and IDIST not in range 1 to 3 */
/* -7 => if N negative */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and Test the input parameters. Initialize flags & seed. */
/* Parameter adjustments */
--d__;
--iseed;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Set INFO if an error */
if (*mode < -6 || *mode > 6) {
*info = -1;
} else if (*mode != -6 && *mode != 0 && *mode != 6 && (*irsign != 0 && *
irsign != 1)) {
*info = -2;
} else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.) {
*info = -3;
} else if ((*mode == 6 || *mode == -6) && (*idist < 1 || *idist > 3)) {
*info = -4;
} else if (*n < 0) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLATM7", &i__1);
return 0;
}
/* Compute D according to COND and MODE */
if (*mode != 0) {
switch (abs(*mode)) {
case 1: goto L100;
case 2: goto L130;
case 3: goto L160;
case 4: goto L190;
case 5: goto L210;
case 6: goto L230;
}
/* One large D value: */
L100:
i__1 = *rank;
for (i__ = 2; i__ <= i__1; ++i__) {
d__[i__] = 1. / *cond;
/* L110: */
}
i__1 = *n;
for (i__ = *rank + 1; i__ <= i__1; ++i__) {
d__[i__] = 0.;
/* L120: */
}
d__[1] = 1.;
goto L240;
/* One small D value: */
L130:
i__1 = *rank - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = 1.;
/* L140: */
}
i__1 = *n;
for (i__ = *rank + 1; i__ <= i__1; ++i__) {
d__[i__] = 0.;
/* L150: */
}
d__[*rank] = 1. / *cond;
goto L240;
/* Exponentially distributed D values: */
L160:
d__[1] = 1.;
if (*n > 1) {
d__1 = -1. / (doublereal) (*rank - 1);
alpha = pow_dd(cond, &d__1);
i__1 = *rank;
for (i__ = 2; i__ <= i__1; ++i__) {
i__2 = i__ - 1;
d__[i__] = pow_di(&alpha, &i__2);
/* L170: */
}
i__1 = *n;
for (i__ = *rank + 1; i__ <= i__1; ++i__) {
d__[i__] = 0.;
/* L180: */
}
}
goto L240;
/* Arithmetically distributed D values: */
L190:
d__[1] = 1.;
if (*n > 1) {
temp = 1. / *cond;
alpha = (1. - temp) / (doublereal) (*n - 1);
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
d__[i__] = (doublereal) (*n - i__) * alpha + temp;
/* L200: */
}
}
goto L240;
/* Randomly distributed D values on ( 1/COND , 1): */
L210:
alpha = log(1. / *cond);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = exp(alpha * dlaran_(&iseed[1]));
/* L220: */
}
goto L240;
/* Randomly distributed D values from IDIST */
L230:
dlarnv_(idist, &iseed[1], n, &d__[1]);
L240:
/* If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign */
/* random signs to D */
if (*mode != -6 && *mode != 0 && *mode != 6 && *irsign == 1) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = dlaran_(&iseed[1]);
if (temp > .5) {
d__[i__] = -d__[i__];
}
/* L250: */
}
}
/* Reverse if MODE < 0 */
if (*mode < 0) {
i__1 = *n / 2;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = d__[i__];
d__[i__] = d__[*n + 1 - i__];
d__[*n + 1 - i__] = temp;
/* L260: */
}
}
}
return 0;
/* End of DLATM7 */
} /* dlatm7_ */
/* DECK DDPST */
/* Subroutine */ int ddpst_(doublereal *el, S_fp f, S_fp fa, doublereal *h__,
integer *impl, S_fp jacobn, integer *matdim, integer *miter, integer *
ml, integer *mu, integer *n, integer *nde, integer *nq, doublereal *
save2, doublereal *t, S_fp users, doublereal *y, doublereal *yh,
doublereal *ywt, doublereal *uround, integer *nfe, integer *nje,
doublereal *a, doublereal *dfdy, doublereal *fac, logical *ier,
integer *ipvt, doublereal *save1, integer *iswflg, doublereal *bnd,
integer *jstate)
{
/* 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, i__7, i__8;
doublereal d__1, d__2, d__3, d__4;
/* Local variables */
static integer i__, j, k, j2;
static doublereal bl, bp, br, dy, yj;
static integer mw;
static doublereal ys, diff;
static integer info, imax;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dgbfa_(doublereal *, integer *, integer *,
integer *, integer *, integer *, integer *), dgefa_(doublereal *,
integer *, integer *, integer *, integer *);
static integer iflag;
static doublereal scale, facmin, factor, dfdymx;
/* ***BEGIN PROLOGUE DDPST */
/* ***SUBSIDIARY */
/* ***PURPOSE Subroutine DDPST evaluates the Jacobian matrix of the right */
/* hand side of the differential equations. */
/* ***LIBRARY SLATEC (SDRIVE) */
/* ***TYPE DOUBLE PRECISION (SDPST-S, DDPST-D, CDPST-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 */
/* If MITER is 1, 2, 4, or 5, the matrix */
/* P = I - L(0)*H*Jacobian is stored in DFDY and subjected to LU */
/* decomposition, with the results also stored in DFDY. */
/* ***ROUTINES CALLED DGBFA, DGEFA, DNRM2 */
/* ***REVISION HISTORY (YYMMDD) */
/* 790601 DATE WRITTEN */
/* 900329 Initial submission to SLATEC. */
/* ***END PROLOGUE DDPST */
/* ***FIRST EXECUTABLE STATEMENT DDPST */
/* Parameter adjustments */
el -= 14;
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;
--save2;
--y;
--ywt;
--fac;
--ipvt;
--save1;
/* Function Body */
++(*nje);
*ier = FALSE_;
if (*miter == 1 || *miter == 2) {
if (*miter == 1) {
(*jacobn)(n, t, &y[1], &dfdy[dfdy_offset], matdim, ml, mu);
if (*n == 0) {
*jstate = 8;
return 0;
}
if (*iswflg == 3) {
i__1 = *n * *n;
*bnd = dnrm2_(&i__1, &dfdy[dfdy_offset], &c__1);
}
factor = -el[*nq * 13 + 1] * *h__;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* L110: */
dfdy[i__ + j * dfdy_dim1] = factor * dfdy[i__ + j *
dfdy_dim1];
}
}
} else if (*miter == 2) {
br = pow_dd(uround, &c_b4);
bl = pow_dd(uround, &c_b5);
bp = pow_dd(uround, &c_b6);
facmin = pow_dd(uround, &c_b7);
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
/* Computing MAX */
d__3 = (d__1 = ywt[j], abs(d__1)), d__4 = (d__2 = y[j], abs(
d__2));
ys = max(d__3,d__4);
L120:
dy = fac[j] * ys;
if (dy == 0.) {
if (fac[j] < .5) {
/* Computing MIN */
d__1 = fac[j] * 100.;
fac[j] = min(d__1,.5);
goto L120;
} else {
dy = ys;
}
}
if (*nq == 1) {
dy = d_sign(&dy, &save2[j]);
} else {
dy = d_sign(&dy, &yh[j + yh_dim1 * 3]);
}
dy = y[j] + dy - y[j];
yj = y[j];
y[j] += dy;
(*f)(n, t, &y[1], &save1[1]);
if (*n == 0) {
*jstate = 6;
return 0;
}
y[j] = yj;
factor = -el[*nq * 13 + 1] * *h__ / dy;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L140: */
dfdy[i__ + j * dfdy_dim1] = (save1[i__] - save2[i__]) *
factor;
}
/* Step 1 */
diff = (d__1 = save2[1] - save1[1], abs(d__1));
imax = 1;
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
if ((d__1 = save2[i__] - save1[i__], abs(d__1)) > diff) {
imax = i__;
diff = (d__1 = save2[i__] - save1[i__], abs(d__1));
}
/* L150: */
}
/* Step 2 */
/* Computing MIN */
d__3 = (d__1 = save2[imax], abs(d__1)), d__4 = (d__2 = save1[
imax], abs(d__2));
if (min(d__3,d__4) > 0.) {
/* Computing MAX */
d__3 = (d__1 = save2[imax], abs(d__1)), d__4 = (d__2 =
save1[imax], abs(d__2));
scale = max(d__3,d__4);
/* Step 3 */
if (diff > scale * .5) {
/* Computing MAX */
d__1 = facmin, d__2 = fac[j] * .5;
fac[j] = max(d__1,d__2);
} else if (br * scale <= diff && diff <= bl * scale) {
/* Computing MIN */
d__1 = fac[j] * 2.;
fac[j] = min(d__1,.5);
/* Step 4 */
} else if (diff < br * scale) {
/* Computing MIN */
d__1 = bp * fac[j];
fac[j] = min(d__1,.5);
}
}
/* L170: */
}
if (*iswflg == 3) {
i__2 = *n * *n;
*bnd = dnrm2_(&i__2, &dfdy[dfdy_offset], &c__1) / (-el[*nq *
13 + 1] * *h__);
}
*nfe += *n;
}
if (*impl == 0) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* L190: */
dfdy[i__ + i__ * dfdy_dim1] += 1.;
}
} else if (*impl == 1) {
(*fa)(n, t, &y[1], &a[a_offset], matdim, ml, mu, nde);
if (*n == 0) {
*jstate = 9;
return 0;
}
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L210: */
dfdy[i__ + j * dfdy_dim1] += a[i__ + j * a_dim1];
}
}
} else if (*impl == 2) {
(*fa)(n, t, &y[1], &a[a_offset], matdim, ml, mu, nde);
if (*n == 0) {
*jstate = 9;
return 0;
}
i__1 = *nde;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L230: */
dfdy[i__ + i__ * dfdy_dim1] += a[i__ + a_dim1];
}
} else if (*impl == 3) {
(*fa)(n, t, &y[1], &a[a_offset], matdim, ml, mu, nde);
if (*n == 0) {
*jstate = 9;
return 0;
}
i__1 = *nde;
for (j = 1; j <= i__1; ++j) {
i__2 = *nde;
for (i__ = 1; i__ <= i__2; ++i__) {
/* L220: */
dfdy[i__ + j * dfdy_dim1] += a[i__ + j * a_dim1];
}
}
}
dgefa_(&dfdy[dfdy_offset], matdim, n, &ipvt[1], &info);
if (info != 0) {
*ier = TRUE_;
}
} else if (*miter == 4 || *miter == 5) {
if (*miter == 4) {
(*jacobn)(n, t, &y[1], &dfdy[*ml + 1 + dfdy_dim1], matdim, ml, mu)
;
if (*n == 0) {
*jstate = 8;
return 0;
}
factor = -el[*nq * 13 + 1] * *h__;
mw = *ml + *mu + 1;
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
/* Computing MAX */
i__1 = *ml + 1, i__3 = mw + 1 - j;
/* Computing MIN */
i__5 = mw + *n - j, i__6 = mw + *ml;
i__4 = min(i__5,i__6);
for (i__ = max(i__1,i__3); i__ <= i__4; ++i__) {
/* L260: */
dfdy[i__ + j * dfdy_dim1] = factor * dfdy[i__ + j *
dfdy_dim1];
}
}
} else if (*miter == 5) {
br = pow_dd(uround, &c_b4);
bl = pow_dd(uround, &c_b5);
bp = pow_dd(uround, &c_b6);
facmin = pow_dd(uround, &c_b7);
mw = *ml + *mu + 1;
j2 = min(mw,*n);
i__4 = j2;
for (j = 1; j <= i__4; ++j) {
i__2 = *n;
i__1 = mw;
for (k = j; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
/* Computing MAX */
d__3 = (d__1 = ywt[k], abs(d__1)), d__4 = (d__2 = y[k],
abs(d__2));
ys = max(d__3,d__4);
L280:
dy = fac[k] * ys;
if (dy == 0.) {
if (fac[k] < .5) {
/* Computing MIN */
d__1 = fac[k] * 100.;
fac[k] = min(d__1,.5);
goto L280;
} else {
dy = ys;
}
}
if (*nq == 1) {
dy = d_sign(&dy, &save2[k]);
} else {
dy = d_sign(&dy, &yh[k + yh_dim1 * 3]);
}
dy = y[k] + dy - y[k];
dfdy[mw + k * dfdy_dim1] = y[k];
/* L290: */
y[k] += dy;
}
(*f)(n, t, &y[1], &save1[1]);
if (*n == 0) {
*jstate = 6;
return 0;
}
i__1 = *n;
i__2 = mw;
for (k = j; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
y[k] = dfdy[mw + k * dfdy_dim1];
/* Computing MAX */
d__3 = (d__1 = ywt[k], abs(d__1)), d__4 = (d__2 = y[k],
abs(d__2));
ys = max(d__3,d__4);
dy = fac[k] * ys;
if (dy == 0.) {
dy = ys;
}
if (*nq == 1) {
dy = d_sign(&dy, &save2[k]);
} else {
dy = d_sign(&dy, &yh[k + yh_dim1 * 3]);
}
dy = y[k] + dy - y[k];
factor = -el[*nq * 13 + 1] * *h__ / dy;
/* Computing MAX */
i__3 = *ml + 1, i__5 = mw + 1 - k;
/* Computing MIN */
i__7 = mw + *n - k, i__8 = mw + *ml;
i__6 = min(i__7,i__8);
for (i__ = max(i__3,i__5); i__ <= i__6; ++i__) {
/* L300: */
dfdy[i__ + k * dfdy_dim1] = factor * (save1[i__ + k -
mw] - save2[i__ + k - mw]);
}
/* Step 1 */
/* Computing MAX */
i__6 = 1, i__3 = k - *mu;
imax = max(i__6,i__3);
diff = (d__1 = save2[imax] - save1[imax], abs(d__1));
/* Computing MAX */
i__6 = 1, i__3 = k - *mu;
/* Computing MIN */
i__7 = k + *ml;
i__5 = min(i__7,*n);
for (i__ = max(i__6,i__3) + 1; i__ <= i__5; ++i__) {
if ((d__1 = save2[i__] - save1[i__], abs(d__1)) >
diff) {
imax = i__;
diff = (d__1 = save2[i__] - save1[i__], abs(d__1))
;
}
/* L310: */
}
/* Step 2 */
/* Computing MIN */
d__3 = (d__1 = save2[imax], abs(d__1)), d__4 = (d__2 =
save1[imax], abs(d__2));
if (min(d__3,d__4) > 0.) {
/* Computing MAX */
d__3 = (d__1 = save2[imax], abs(d__1)), d__4 = (d__2 =
save1[imax], abs(d__2));
scale = max(d__3,d__4);
/* Step 3 */
if (diff > scale * .5) {
/* Computing MAX */
d__1 = facmin, d__2 = fac[j] * .5;
fac[j] = max(d__1,d__2);
} else if (br * scale <= diff && diff <= bl * scale) {
/* Computing MIN */
d__1 = fac[j] * 2.;
fac[j] = min(d__1,.5);
/* Step 4 */
} else if (diff < br * scale) {
/* Computing MIN */
d__1 = bp * fac[k];
fac[k] = min(d__1,.5);
}
}
/* L330: */
}
/* L340: */
}
*nfe += j2;
}
if (*iswflg == 3) {
dfdymx = 0.;
i__4 = *n;
for (j = 1; j <= i__4; ++j) {
/* Computing MAX */
i__2 = *ml + 1, i__1 = mw + 1 - j;
/* Computing MIN */
i__6 = mw + *n - j, i__3 = mw + *ml;
i__5 = min(i__6,i__3);
for (i__ = max(i__2,i__1); i__ <= i__5; ++i__) {
/* L345: */
/* Computing MAX */
d__2 = dfdymx, d__3 = (d__1 = dfdy[i__ + j * dfdy_dim1],
abs(d__1));
dfdymx = max(d__2,d__3);
}
}
*bnd = 0.;
if (dfdymx != 0.) {
i__5 = *n;
for (j = 1; j <= i__5; ++j) {
/* Computing MAX */
i__4 = *ml + 1, i__2 = mw + 1 - j;
/* Computing MIN */
i__6 = mw + *n - j, i__3 = mw + *ml;
i__1 = min(i__6,i__3);
for (i__ = max(i__4,i__2); i__ <= i__1; ++i__) {
/* L350: */
/* Computing 2nd power */
d__1 = dfdy[i__ + j * dfdy_dim1] / dfdymx;
*bnd += d__1 * d__1;
}
}
*bnd = dfdymx * sqrt(*bnd) / (-el[*nq * 13 + 1] * *h__);
}
}
if (*impl == 0) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* L360: */
dfdy[mw + j * dfdy_dim1] += 1.;
}
} else if (*impl == 1) {
(*fa)(n, t, &y[1], &a[*ml + 1 + a_dim1], matdim, ml, mu, nde);
if (*n == 0) {
*jstate = 9;
return 0;
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__5 = *ml + 1, i__4 = mw + 1 - j;
/* Computing MIN */
i__6 = mw + *n - j, i__3 = mw + *ml;
i__2 = min(i__6,i__3);
for (i__ = max(i__5,i__4); i__ <= i__2; ++i__) {
/* L380: */
dfdy[i__ + j * dfdy_dim1] += a[i__ + j * a_dim1];
}
}
} else if (*impl == 2) {
(*fa)(n, t, &y[1], &a[a_offset], matdim, ml, mu, nde);
if (*n == 0) {
*jstate = 9;
return 0;
}
i__2 = *nde;
for (j = 1; j <= i__2; ++j) {
/* L400: */
dfdy[mw + j * dfdy_dim1] += a[j + a_dim1];
}
} else if (*impl == 3) {
(*fa)(n, t, &y[1], &a[*ml + 1 + a_dim1], matdim, ml, mu, nde);
if (*n == 0) {
*jstate = 9;
return 0;
}
i__2 = *nde;
for (j = 1; j <= i__2; ++j) {
/* Computing MAX */
i__1 = *ml + 1, i__5 = mw + 1 - j;
/* Computing MIN */
i__6 = mw + *nde - j, i__3 = mw + *ml;
i__4 = min(i__6,i__3);
for (i__ = max(i__1,i__5); i__ <= i__4; ++i__) {
/* L390: */
dfdy[i__ + j * dfdy_dim1] += a[i__ + j * a_dim1];
}
}
}
dgbfa_(&dfdy[dfdy_offset], matdim, n, ml, mu, &ipvt[1], &info);
if (info != 0) {
*ier = TRUE_;
}
} else if (*miter == 3) {
iflag = 1;
(*users)(&y[1], &yh[(yh_dim1 << 1) + 1], &ywt[1], &save1[1], &save2[1]
, t, h__, &el[*nq * 13 + 1], impl, n, nde, &iflag);
if (iflag == -1) {
*ier = TRUE_;
return 0;
}
if (*n == 0) {
*jstate = 10;
return 0;
}
}
return 0;
} /* ddpst_ */
/* DECK DDASTP */
/* Subroutine */ int ddastp_(doublereal *x, doublereal *y, doublereal *yprime,
integer *neq, S_fp res, U_fp jac, doublereal *h__, doublereal *wt,
integer *jstart, integer *idid, doublereal *rpar, integer *ipar,
doublereal *phi, doublereal *delta, doublereal *e, doublereal *wm,
integer *iwm, doublereal *alpha, doublereal *beta, doublereal *gamma,
doublereal *psi, doublereal *sigma, doublereal *cj, doublereal *cjold,
doublereal *hold, doublereal *s, doublereal *hmin, doublereal *
uround, integer *iphase, integer *jcalc, integer *k, integer *kold,
integer *ns, integer *nonneg, integer *ntemp)
{
/* Initialized data */
static integer maxit = 4;
static doublereal xrate = .25;
/* System generated locals */
integer phi_dim1, phi_offset, i__1, i__2;
doublereal d__1, d__2;
/* Local variables */
static integer i__, j, m;
static doublereal r__;
static integer j1;
static doublereal ck;
static integer km1, kp1, kp2, ncf, nef, ier;
static doublereal erk;
static integer nsf;
static doublereal err, est;
static integer nsp1;
static doublereal rate, hnew;
static integer ires, knew;
static doublereal terk, xold, erkm1, erkm2, erkp1, temp1, temp2;
static integer kdiff;
static doublereal enorm, pnorm, alpha0, terkm1, terkm2;
extern /* Subroutine */ int ddajac_(integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *
, doublereal *, doublereal *, doublereal *, integer *, S_fp,
integer *, doublereal *, U_fp, doublereal *, integer *, integer *)
;
static doublereal terkp1;
extern doublereal ddanrm_(integer *, doublereal *, doublereal *,
doublereal *, integer *);
static doublereal alphas;
extern /* Subroutine */ int ddaslv_(integer *, doublereal *, doublereal *,
integer *), ddatrp_(doublereal *, doublereal *, doublereal *,
doublereal *, integer *, integer *, doublereal *, doublereal *);
static doublereal cjlast, delnrm;
static logical convgd;
static doublereal oldnrm;
/* ***BEGIN PROLOGUE DDASTP */
/* ***SUBSIDIARY */
/* ***PURPOSE Perform one step of the DDASSL integration. */
/* ***LIBRARY SLATEC (DASSL) */
/* ***TYPE DOUBLE PRECISION (SDASTP-S, DDASTP-D) */
/* ***AUTHOR Petzold, Linda R., (LLNL) */
/* ***DESCRIPTION */
/* ----------------------------------------------------------------------- */
/* DDASTP SOLVES A SYSTEM OF DIFFERENTIAL/ */
/* ALGEBRAIC EQUATIONS OF THE FORM */
/* G(X,Y,YPRIME) = 0, FOR ONE STEP (NORMALLY */
/* FROM X TO X+H). */
/* THE METHODS USED ARE MODIFIED DIVIDED */
/* DIFFERENCE,FIXED LEADING COEFFICIENT */
/* FORMS OF BACKWARD DIFFERENTIATION */
/* FORMULAS. THE CODE ADJUSTS THE STEPSIZE */
/* AND ORDER TO CONTROL THE LOCAL ERROR PER */
/* STEP. */
/* THE PARAMETERS REPRESENT */
/* X -- INDEPENDENT VARIABLE */
/* Y -- SOLUTION VECTOR AT X */
/* YPRIME -- DERIVATIVE OF SOLUTION VECTOR */
/* AFTER SUCCESSFUL STEP */
/* NEQ -- NUMBER OF EQUATIONS TO BE INTEGRATED */
/* RES -- EXTERNAL USER-SUPPLIED SUBROUTINE */
/* TO EVALUATE THE RESIDUAL. THE CALL IS */
/* CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR) */
/* X,Y,YPRIME ARE INPUT. DELTA IS OUTPUT. */
/* ON INPUT, IRES=0. RES SHOULD ALTER IRES ONLY */
/* IF IT ENCOUNTERS AN ILLEGAL VALUE OF Y OR A */
/* STOP CONDITION. SET IRES=-1 IF AN INPUT VALUE */
/* OF Y IS ILLEGAL, AND DDASTP WILL TRY TO SOLVE */
/* THE PROBLEM WITHOUT GETTING IRES = -1. IF */
/* IRES=-2, DDASTP RETURNS CONTROL TO THE CALLING */
/* PROGRAM WITH IDID = -11. */
/* JAC -- EXTERNAL USER-SUPPLIED ROUTINE TO EVALUATE */
/* THE ITERATION MATRIX (THIS IS OPTIONAL) */
/* THE CALL IS OF THE FORM */
/* CALL JAC(X,Y,YPRIME,PD,CJ,RPAR,IPAR) */
/* PD IS THE MATRIX OF PARTIAL DERIVATIVES, */
/* PD=DG/DY+CJ*DG/DYPRIME */
/* H -- APPROPRIATE STEP SIZE FOR NEXT STEP. */
/* NORMALLY DETERMINED BY THE CODE */
/* WT -- VECTOR OF WEIGHTS FOR ERROR CRITERION. */
/* JSTART -- INTEGER VARIABLE SET 0 FOR */
/* FIRST STEP, 1 OTHERWISE. */
/* IDID -- COMPLETION CODE WITH THE FOLLOWING MEANINGS: */
/* IDID= 1 -- THE STEP WAS COMPLETED SUCCESSFULLY */
/* IDID=-6 -- THE ERROR TEST FAILED REPEATEDLY */
/* IDID=-7 -- THE CORRECTOR COULD NOT CONVERGE */
/* IDID=-8 -- THE ITERATION MATRIX IS SINGULAR */
/* IDID=-9 -- THE CORRECTOR COULD NOT CONVERGE. */
/* THERE WERE REPEATED ERROR TEST */
/* FAILURES ON THIS STEP. */
/* IDID=-10-- THE CORRECTOR COULD NOT CONVERGE */
/* BECAUSE IRES WAS EQUAL TO MINUS ONE */
/* IDID=-11-- IRES EQUAL TO -2 WAS ENCOUNTERED, */
/* AND CONTROL IS BEING RETURNED TO */
/* THE CALLING PROGRAM */
/* RPAR,IPAR -- REAL AND INTEGER PARAMETER ARRAYS THAT */
/* ARE USED FOR COMMUNICATION BETWEEN THE */
/* CALLING PROGRAM AND EXTERNAL USER ROUTINES */
/* THEY ARE NOT ALTERED BY DDASTP */
/* PHI -- ARRAY OF DIVIDED DIFFERENCES USED BY */
/* DDASTP. THE LENGTH IS NEQ*(K+1),WHERE */
/* K IS THE MAXIMUM ORDER */
/* DELTA,E -- WORK VECTORS FOR DDASTP OF LENGTH NEQ */
/* WM,IWM -- REAL AND INTEGER ARRAYS STORING */
/* MATRIX INFORMATION SUCH AS THE MATRIX */
/* OF PARTIAL DERIVATIVES,PERMUTATION */
/* VECTOR, AND VARIOUS OTHER INFORMATION. */
/* THE OTHER PARAMETERS ARE INFORMATION */
/* WHICH IS NEEDED INTERNALLY BY DDASTP TO */
/* CONTINUE FROM STEP TO STEP. */
/* ----------------------------------------------------------------------- */
/* ***ROUTINES CALLED DDAJAC, DDANRM, DDASLV, DDATRP */
/* ***REVISION HISTORY (YYMMDD) */
/* 830315 DATE WRITTEN */
/* 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) */
/* 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. */
/* 901026 Added explicit declarations for all variables and minor */
/* cosmetic changes to prologue. (FNF) */
/* ***END PROLOGUE DDASTP */
/* Parameter adjustments */
--y;
--yprime;
phi_dim1 = *neq;
phi_offset = 1 + phi_dim1;
phi -= phi_offset;
--wt;
--rpar;
--ipar;
--delta;
--e;
--wm;
--iwm;
--alpha;
--beta;
--gamma;
--psi;
--sigma;
/* Function Body */
/* ----------------------------------------------------------------------- */
/* BLOCK 1. */
/* INITIALIZE. ON THE FIRST CALL,SET */
/* THE ORDER TO 1 AND INITIALIZE */
/* OTHER VARIABLES. */
/* ----------------------------------------------------------------------- */
/* INITIALIZATIONS FOR ALL CALLS */
/* ***FIRST EXECUTABLE STATEMENT DDASTP */
*idid = 1;
xold = *x;
ncf = 0;
nsf = 0;
nef = 0;
if (*jstart != 0) {
goto L120;
}
/* IF THIS IS THE FIRST STEP,PERFORM */
/* OTHER INITIALIZATIONS */
iwm[14] = 0;
iwm[15] = 0;
*k = 1;
*kold = 0;
*hold = 0.;
*jstart = 1;
psi[1] = *h__;
*cjold = 1. / *h__;
*cj = *cjold;
*s = 100.;
*jcalc = -1;
delnrm = 1.;
*iphase = 0;
*ns = 0;
L120:
/* ----------------------------------------------------------------------- */
/* BLOCK 2 */
/* COMPUTE COEFFICIENTS OF FORMULAS FOR */
/* THIS STEP. */
/* ----------------------------------------------------------------------- */
L200:
kp1 = *k + 1;
kp2 = *k + 2;
km1 = *k - 1;
xold = *x;
if (*h__ != *hold || *k != *kold) {
*ns = 0;
}
/* Computing MIN */
i__1 = *ns + 1, i__2 = *kold + 2;
*ns = min(i__1,i__2);
nsp1 = *ns + 1;
if (kp1 < *ns) {
goto L230;
}
beta[1] = 1.;
alpha[1] = 1.;
temp1 = *h__;
gamma[1] = 0.;
sigma[1] = 1.;
i__1 = kp1;
for (i__ = 2; i__ <= i__1; ++i__) {
temp2 = psi[i__ - 1];
psi[i__ - 1] = temp1;
beta[i__] = beta[i__ - 1] * psi[i__ - 1] / temp2;
temp1 = temp2 + *h__;
alpha[i__] = *h__ / temp1;
sigma[i__] = (i__ - 1) * sigma[i__ - 1] * alpha[i__];
gamma[i__] = gamma[i__ - 1] + alpha[i__ - 1] / *h__;
/* L210: */
}
psi[kp1] = temp1;
L230:
/* COMPUTE ALPHAS, ALPHA0 */
alphas = 0.;
alpha0 = 0.;
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
alphas -= 1. / i__;
alpha0 -= alpha[i__];
/* L240: */
}
/* COMPUTE LEADING COEFFICIENT CJ */
cjlast = *cj;
*cj = -alphas / *h__;
/* COMPUTE VARIABLE STEPSIZE ERROR COEFFICIENT CK */
ck = (d__1 = alpha[kp1] + alphas - alpha0, abs(d__1));
/* Computing MAX */
d__1 = ck, d__2 = alpha[kp1];
ck = max(d__1,d__2);
/* DECIDE WHETHER NEW JACOBIAN IS NEEDED */
temp1 = (1. - xrate) / (xrate + 1.);
temp2 = 1. / temp1;
if (*cj / *cjold < temp1 || *cj / *cjold > temp2) {
*jcalc = -1;
}
if (*cj != cjlast) {
*s = 100.;
}
/* CHANGE PHI TO PHI STAR */
if (kp1 < nsp1) {
goto L280;
}
i__1 = kp1;
for (j = nsp1; j <= i__1; ++j) {
i__2 = *neq;
for (i__ = 1; i__ <= i__2; ++i__) {
/* L260: */
phi[i__ + j * phi_dim1] = beta[j] * phi[i__ + j * phi_dim1];
}
/* L270: */
}
L280:
/* UPDATE TIME */
*x += *h__;
/* ----------------------------------------------------------------------- */
/* BLOCK 3 */
/* PREDICT THE SOLUTION AND DERIVATIVE, */
/* AND SOLVE THE CORRECTOR EQUATION */
/* ----------------------------------------------------------------------- */
/* FIRST,PREDICT THE SOLUTION AND DERIVATIVE */
L300:
i__1 = *neq;
for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = phi[i__ + phi_dim1];
/* L310: */
yprime[i__] = 0.;
}
i__1 = kp1;
for (j = 2; j <= i__1; ++j) {
i__2 = *neq;
for (i__ = 1; i__ <= i__2; ++i__) {
y[i__] += phi[i__ + j * phi_dim1];
/* L320: */
yprime[i__] += gamma[j] * phi[i__ + j * phi_dim1];
}
/* L330: */
}
pnorm = ddanrm_(neq, &y[1], &wt[1], &rpar[1], &ipar[1]);
/* SOLVE THE CORRECTOR EQUATION USING A */
/* MODIFIED NEWTON SCHEME. */
convgd = TRUE_;
m = 0;
++iwm[12];
ires = 0;
(*res)(x, &y[1], &yprime[1], &delta[1], &ires, &rpar[1], &ipar[1]);
if (ires < 0) {
goto L380;
}
/* IF INDICATED,REEVALUATE THE */
/* ITERATION MATRIX PD = DG/DY + CJ*DG/DYPRIME */
/* (WHERE G(X,Y,YPRIME)=0). SET */
/* JCALC TO 0 AS AN INDICATOR THAT */
/* THIS HAS BEEN DONE. */
if (*jcalc != -1) {
goto L340;
}
++iwm[13];
*jcalc = 0;
ddajac_(neq, x, &y[1], &yprime[1], &delta[1], cj, h__, &ier, &wt[1], &e[1]
, &wm[1], &iwm[1], (S_fp)res, &ires, uround, (U_fp)jac, &rpar[1],
&ipar[1], ntemp);
*cjold = *cj;
*s = 100.;
if (ires < 0) {
goto L380;
}
if (ier != 0) {
goto L380;
}
nsf = 0;
/* INITIALIZE THE ERROR ACCUMULATION VECTOR E. */
L340:
i__1 = *neq;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L345: */
e[i__] = 0.;
}
/* CORRECTOR LOOP. */
L350:
/* MULTIPLY RESIDUAL BY TEMP1 TO ACCELERATE CONVERGENCE */
temp1 = 2. / (*cj / *cjold + 1.);
i__1 = *neq;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L355: */
delta[i__] *= temp1;
}
/* COMPUTE A NEW ITERATE (BACK-SUBSTITUTION). */
/* STORE THE CORRECTION IN DELTA. */
ddaslv_(neq, &delta[1], &wm[1], &iwm[1]);
/* UPDATE Y, E, AND YPRIME */
i__1 = *neq;
for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] -= delta[i__];
e[i__] -= delta[i__];
/* L360: */
yprime[i__] -= *cj * delta[i__];
}
/* TEST FOR CONVERGENCE OF THE ITERATION */
delnrm = ddanrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]);
if (delnrm <= *uround * 100. * pnorm) {
goto L375;
}
if (m > 0) {
goto L365;
}
oldnrm = delnrm;
goto L367;
L365:
d__1 = delnrm / oldnrm;
d__2 = 1. / m;
rate = pow_dd(&d__1, &d__2);
if (rate > .9) {
goto L370;
}
*s = rate / (1. - rate);
L367:
if (*s * delnrm <= .33) {
goto L375;
}
/* THE CORRECTOR HAS NOT YET CONVERGED. */
/* UPDATE M AND TEST WHETHER THE */
/* MAXIMUM NUMBER OF ITERATIONS HAVE */
/* BEEN TRIED. */
++m;
if (m >= maxit) {
goto L370;
}
/* EVALUATE THE RESIDUAL */
/* AND GO BACK TO DO ANOTHER ITERATION */
++iwm[12];
ires = 0;
(*res)(x, &y[1], &yprime[1], &delta[1], &ires, &rpar[1], &ipar[1]);
if (ires < 0) {
goto L380;
}
goto L350;
/* THE CORRECTOR FAILED TO CONVERGE IN MAXIT */
/* ITERATIONS. IF THE ITERATION MATRIX */
/* IS NOT CURRENT,RE-DO THE STEP WITH */
/* A NEW ITERATION MATRIX. */
L370:
if (*jcalc == 0) {
goto L380;
}
*jcalc = -1;
goto L300;
/* THE ITERATION HAS CONVERGED. IF NONNEGATIVITY OF SOLUTION IS */
/* REQUIRED, SET THE SOLUTION NONNEGATIVE, IF THE PERTURBATION */
/* TO DO IT IS SMALL ENOUGH. IF THE CHANGE IS TOO LARGE, THEN */
/* CONSIDER THE CORRECTOR ITERATION TO HAVE FAILED. */
L375:
if (*nonneg == 0) {
goto L390;
}
i__1 = *neq;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L377: */
/* Computing MIN */
d__1 = y[i__];
delta[i__] = min(d__1,0.);
}
delnrm = ddanrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]);
if (delnrm > .33) {
goto L380;
}
i__1 = *neq;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L378: */
e[i__] -= delta[i__];
}
goto L390;
/* EXITS FROM BLOCK 3 */
/* NO CONVERGENCE WITH CURRENT ITERATION */
/* MATRIX,OR SINGULAR ITERATION MATRIX */
L380:
convgd = FALSE_;
L390:
*jcalc = 1;
if (! convgd) {
goto L600;
}
/* ----------------------------------------------------------------------- */
/* BLOCK 4 */
/* ESTIMATE THE ERRORS AT ORDERS K,K-1,K-2 */
/* AS IF CONSTANT STEPSIZE WAS USED. ESTIMATE */
/* THE LOCAL ERROR AT ORDER K AND TEST */
/* WHETHER THE CURRENT STEP IS SUCCESSFUL. */
/* ----------------------------------------------------------------------- */
/* ESTIMATE ERRORS AT ORDERS K,K-1,K-2 */
enorm = ddanrm_(neq, &e[1], &wt[1], &rpar[1], &ipar[1]);
erk = sigma[*k + 1] * enorm;
terk = (*k + 1) * erk;
est = erk;
knew = *k;
if (*k == 1) {
goto L430;
}
i__1 = *neq;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L405: */
delta[i__] = phi[i__ + kp1 * phi_dim1] + e[i__];
}
erkm1 = sigma[*k] * ddanrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]);
terkm1 = *k * erkm1;
if (*k > 2) {
goto L410;
}
if (terkm1 <= terk * .5) {
goto L420;
}
goto L430;
L410:
i__1 = *neq;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L415: */
delta[i__] = phi[i__ + *k * phi_dim1] + delta[i__];
}
erkm2 = sigma[*k - 1] * ddanrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]
);
terkm2 = (*k - 1) * erkm2;
if (max(terkm1,terkm2) > terk) {
goto L430;
}
/* LOWER THE ORDER */
L420:
knew = *k - 1;
est = erkm1;
/* CALCULATE THE LOCAL ERROR FOR THE CURRENT STEP */
/* TO SEE IF THE STEP WAS SUCCESSFUL */
L430:
err = ck * enorm;
if (err > 1.) {
goto L600;
}
/* ----------------------------------------------------------------------- */
/* BLOCK 5 */
/* THE STEP IS SUCCESSFUL. DETERMINE */
/* THE BEST ORDER AND STEPSIZE FOR */
/* THE NEXT STEP. UPDATE THE DIFFERENCES */
/* FOR THE NEXT STEP. */
/* ----------------------------------------------------------------------- */
*idid = 1;
++iwm[11];
kdiff = *k - *kold;
*kold = *k;
*hold = *h__;
/* ESTIMATE THE ERROR AT ORDER K+1 UNLESS: */
/* ALREADY DECIDED TO LOWER ORDER, OR */
/* ALREADY USING MAXIMUM ORDER, OR */
/* STEPSIZE NOT CONSTANT, OR */
/* ORDER RAISED IN PREVIOUS STEP */
if (knew == km1 || *k == iwm[3]) {
*iphase = 1;
}
if (*iphase == 0) {
goto L545;
}
if (knew == km1) {
goto L540;
}
if (*k == iwm[3]) {
goto L550;
}
if (kp1 >= *ns || kdiff == 1) {
goto L550;
}
i__1 = *neq;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L510: */
delta[i__] = e[i__] - phi[i__ + kp2 * phi_dim1];
}
erkp1 = 1. / (*k + 2) * ddanrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]
);
terkp1 = (*k + 2) * erkp1;
if (*k > 1) {
goto L520;
}
if (terkp1 >= terk * .5) {
goto L550;
}
goto L530;
L520:
if (terkm1 <= min(terk,terkp1)) {
goto L540;
}
if (terkp1 >= terk || *k == iwm[3]) {
goto L550;
}
/* RAISE ORDER */
L530:
*k = kp1;
est = erkp1;
goto L550;
/* LOWER ORDER */
L540:
*k = km1;
est = erkm1;
goto L550;
/* IF IPHASE = 0, INCREASE ORDER BY ONE AND MULTIPLY STEPSIZE BY */
/* FACTOR TWO */
L545:
*k = kp1;
hnew = *h__ * 2.;
*h__ = hnew;
goto L575;
/* DETERMINE THE APPROPRIATE STEPSIZE FOR */
/* THE NEXT STEP. */
L550:
hnew = *h__;
temp2 = (doublereal) (*k + 1);
d__1 = est * 2. + 1e-4;
d__2 = -1. / temp2;
r__ = pow_dd(&d__1, &d__2);
if (r__ < 2.) {
goto L555;
}
hnew = *h__ * 2.;
goto L560;
L555:
if (r__ > 1.) {
goto L560;
}
/* Computing MAX */
d__1 = .5, d__2 = min(.9,r__);
r__ = max(d__1,d__2);
hnew = *h__ * r__;
L560:
*h__ = hnew;
/* UPDATE DIFFERENCES FOR NEXT STEP */
L575:
if (*kold == iwm[3]) {
goto L585;
}
i__1 = *neq;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L580: */
phi[i__ + kp2 * phi_dim1] = e[i__];
}
L585:
i__1 = *neq;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L590: */
phi[i__ + kp1 * phi_dim1] += e[i__];
}
i__1 = kp1;
for (j1 = 2; j1 <= i__1; ++j1) {
j = kp1 - j1 + 1;
i__2 = *neq;
for (i__ = 1; i__ <= i__2; ++i__) {
/* L595: */
phi[i__ + j * phi_dim1] += phi[i__ + (j + 1) * phi_dim1];
}
}
return 0;
/* ----------------------------------------------------------------------- */
/* BLOCK 6 */
/* THE STEP IS UNSUCCESSFUL. RESTORE X,PSI,PHI */
/* DETERMINE APPROPRIATE STEPSIZE FOR */
/* CONTINUING THE INTEGRATION, OR EXIT WITH */
/* AN ERROR FLAG IF THERE HAVE BEEN MANY */
/* FAILURES. */
/* ----------------------------------------------------------------------- */
L600:
*iphase = 1;
/* RESTORE X,PHI,PSI */
*x = xold;
if (kp1 < nsp1) {
goto L630;
}
i__2 = kp1;
for (j = nsp1; j <= i__2; ++j) {
temp1 = 1. / beta[j];
i__1 = *neq;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L610: */
phi[i__ + j * phi_dim1] = temp1 * phi[i__ + j * phi_dim1];
}
/* L620: */
}
L630:
i__2 = kp1;
for (i__ = 2; i__ <= i__2; ++i__) {
/* L640: */
psi[i__ - 1] = psi[i__] - *h__;
}
/* TEST WHETHER FAILURE IS DUE TO CORRECTOR ITERATION */
/* OR ERROR TEST */
if (convgd) {
goto L660;
}
++iwm[15];
/* THE NEWTON ITERATION FAILED TO CONVERGE WITH */
/* A CURRENT ITERATION MATRIX. DETERMINE THE CAUSE */
/* OF THE FAILURE AND TAKE APPROPRIATE ACTION. */
if (ier == 0) {
goto L650;
}
/* THE ITERATION MATRIX IS SINGULAR. REDUCE */
/* THE STEPSIZE BY A FACTOR OF 4. IF */
/* THIS HAPPENS THREE TIMES IN A ROW ON */
/* THE SAME STEP, RETURN WITH AN ERROR FLAG */
++nsf;
r__ = .25;
*h__ *= r__;
if (nsf < 3 && abs(*h__) >= *hmin) {
goto L690;
}
*idid = -8;
goto L675;
/* THE NEWTON ITERATION FAILED TO CONVERGE FOR A REASON */
/* OTHER THAN A SINGULAR ITERATION MATRIX. IF IRES = -2, THEN */
/* RETURN. OTHERWISE, REDUCE THE STEPSIZE AND TRY AGAIN, UNLESS */
/* TOO MANY FAILURES HAVE OCCURRED. */
L650:
if (ires > -2) {
goto L655;
}
*idid = -11;
goto L675;
L655:
++ncf;
r__ = .25;
*h__ *= r__;
if (ncf < 10 && abs(*h__) >= *hmin) {
goto L690;
}
*idid = -7;
if (ires < 0) {
*idid = -10;
}
if (nef >= 3) {
*idid = -9;
}
goto L675;
/* THE NEWTON SCHEME CONVERGED, AND THE CAUSE */
/* OF THE FAILURE WAS THE ERROR ESTIMATE */
/* EXCEEDING THE TOLERANCE. */
L660:
++nef;
++iwm[14];
if (nef > 1) {
goto L665;
}
/* ON FIRST ERROR TEST FAILURE, KEEP CURRENT ORDER OR LOWER */
/* ORDER BY ONE. COMPUTE NEW STEPSIZE BASED ON DIFFERENCES */
/* OF THE SOLUTION. */
*k = knew;
temp2 = (doublereal) (*k + 1);
d__1 = est * 2. + 1e-4;
d__2 = -1. / temp2;
r__ = pow_dd(&d__1, &d__2) * .9;
/* Computing MAX */
d__1 = .25, d__2 = min(.9,r__);
r__ = max(d__1,d__2);
*h__ *= r__;
if (abs(*h__) >= *hmin) {
goto L690;
}
*idid = -6;
goto L675;
/* ON SECOND ERROR TEST FAILURE, USE THE CURRENT ORDER OR */
/* DECREASE ORDER BY ONE. REDUCE THE STEPSIZE BY A FACTOR OF */
/* FOUR. */
L665:
if (nef > 2) {
goto L670;
}
*k = knew;
*h__ *= .25;
if (abs(*h__) >= *hmin) {
goto L690;
}
*idid = -6;
goto L675;
/* ON THIRD AND SUBSEQUENT ERROR TEST FAILURES, SET THE ORDER TO */
/* ONE AND REDUCE THE STEPSIZE BY A FACTOR OF FOUR. */
L670:
*k = 1;
*h__ *= .25;
if (abs(*h__) >= *hmin) {
goto L690;
}
*idid = -6;
goto L675;
/* FOR ALL CRASHES, RESTORE Y TO ITS LAST VALUE, */
/* INTERPOLATE TO FIND YPRIME AT LAST X, AND RETURN */
L675:
ddatrp_(x, x, &y[1], &yprime[1], neq, k, &phi[phi_offset], &psi[1]);
return 0;
/* GO BACK AND TRY THIS STEP AGAIN */
L690:
goto L200;
/* ------END OF SUBROUTINE DDASTP------ */
} /* ddastp_ */
/* DECK AI */
doublereal ai_(real *x)
{
/* Initialized data */
static real aifcs[9] = { -.0379713584966699975f,.05919188853726363857f,
9.8629280577279975e-4f,6.84884381907656e-6f,2.594202596219e-8f,
6.176612774e-11f,1.0092454e-13f,1.2014e-16f,1e-19f };
static real aigcs[8] = { .01815236558116127f,.02157256316601076f,
2.5678356987483e-4f,1.42652141197e-6f,4.57211492e-9f,9.52517e-12f,
1.392e-14f,1e-17f };
static logical first = TRUE_;
/* System generated locals */
real ret_val, r__1;
doublereal d__1;
/* Local variables */
static real z__, xm;
extern doublereal aie_(real *);
static integer naif, naig;
static real xmax, x3sml, theta;
extern doublereal csevl_(real *, real *, integer *);
extern integer inits_(real *, integer *, real *);
static real xmaxt;
extern doublereal r1mach_(integer *);
extern /* Subroutine */ int r9aimp_(real *, real *, real *), xermsg_(char
*, char *, char *, integer *, integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE AI */
/* ***PURPOSE Evaluate the Airy function. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C10D */
/* ***TYPE SINGLE PRECISION (AI-S, DAI-D) */
/* ***KEYWORDS AIRY FUNCTION, FNLIB, SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* AI(X) computes the Airy function Ai(X) */
/* Series for AIF on the interval -1.00000D+00 to 1.00000D+00 */
/* with weighted error 1.09E-19 */
/* log weighted error 18.96 */
/* significant figures required 17.76 */
/* decimal places required 19.44 */
/* Series for AIG on the interval -1.00000D+00 to 1.00000D+00 */
/* with weighted error 1.51E-17 */
/* log weighted error 16.82 */
/* significant figures required 15.19 */
/* decimal places required 17.27 */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED AIE, CSEVL, INITS, R1MACH, R9AIMP, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 770701 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890531 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* 900326 Removed duplicate information from DESCRIPTION section. */
/* (WRB) */
/* 920618 Removed space from variable names. (RWC, WRB) */
/* ***END PROLOGUE AI */
/* ***FIRST EXECUTABLE STATEMENT AI */
if (first) {
r__1 = r1mach_(&c__3) * .1f;
naif = inits_(aifcs, &c__9, &r__1);
r__1 = r1mach_(&c__3) * .1f;
naig = inits_(aigcs, &c__8, &r__1);
d__1 = (doublereal) r1mach_(&c__3);
x3sml = pow_dd(&d__1, &c_b7);
d__1 = (doublereal) (log(r1mach_(&c__1)) * -1.5f);
xmaxt = pow_dd(&d__1, &c_b9);
xmax = xmaxt - xmaxt * log(xmaxt) / (sqrt(xmaxt) * 4.f + 1.f) - .01f;
}
first = FALSE_;
if (*x >= -1.f) {
goto L20;
}
r9aimp_(x, &xm, &theta);
ret_val = xm * cos(theta);
return ret_val;
L20:
if (*x > 1.f) {
goto L30;
}
z__ = 0.f;
if (dabs(*x) > x3sml) {
/* Computing 3rd power */
r__1 = *x;
z__ = r__1 * (r__1 * r__1);
}
ret_val = csevl_(&z__, aifcs, &naif) - *x * (csevl_(&z__, aigcs, &naig) +
.25f) + .375f;
return ret_val;
L30:
if (*x > xmax) {
goto L40;
}
ret_val = aie_(x) * exp(*x * -2.f * sqrt(*x) / 3.f);
return ret_val;
L40:
ret_val = 0.f;
xermsg_("SLATEC", "AI", "X SO BIG AI UNDERFLOWS", &c__1, &c__1, (ftnlen)6,
(ftnlen)2, (ftnlen)22);
return ret_val;
} /* ai_ */
