/* DECK PSIFN */
/* Subroutine */ int psifn_(real *x, integer *n, integer *kode, integer *m,
real *ans, integer *nz, integer *ierr)
{
/* Initialized data */
static integer nmax = 100;
static real b[22] = { 1.f,-.5f,.166666666666666667f,
-.0333333333333333333f,.0238095238095238095f,
-.0333333333333333333f,.0757575757575757576f,
-.253113553113553114f,1.16666666666666667f,-7.09215686274509804f,
54.9711779448621554f,-529.124242424242424f,6192.1231884057971f,
-86580.2531135531136f,1425517.16666666667f,-27298231.067816092f,
601580873.900642368f,-15116315767.0921569f,429614643061.166667f,
-13711655205088.3328f,488332318973593.167f,-19296579341940068.1f }
;
/* System generated locals */
integer i__1, i__2;
real r__1, r__2;
/* Local variables */
static integer i__, j, k;
static real s, t, t1, t2, fn, ta;
static integer mm, nn, np;
static real fx, tk;
static integer mx, nx;
static real xm, tt, xq, den, arg, fln, fnp, r1m4, r1m5, fns, eps, rln,
tol, xln, trm[22], tss, tst, elim, xinc, xmin, tols, xdmy, yint,
trmr[100], rxsq, slope, xdmln, wdtol;
extern integer i1mach_(integer *);
extern doublereal r1mach_(integer *);
/* ***BEGIN PROLOGUE PSIFN */
/* ***PURPOSE Compute derivatives of the Psi function. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY C7C */
/* ***TYPE SINGLE PRECISION (PSIFN-S, DPSIFN-D) */
/* ***KEYWORDS DERIVATIVES OF THE GAMMA FUNCTION, POLYGAMMA FUNCTION, */
/* PSI FUNCTION */
/* ***AUTHOR Amos, D. E., (SNLA) */
/* ***DESCRIPTION */
/* The following definitions are used in PSIFN: */
/* Definition 1 */
/* PSI(X) = d/dx (ln(GAMMA(X)), the first derivative of */
/* the LOG GAMMA function. */
/* Definition 2 */
/* K K */
/* PSI(K,X) = d /dx (PSI(X)), the K-th derivative of PSI(X). */
/* ___________________________________________________________________ */
/* PSIFN computes a sequence of SCALED derivatives of */
/* the PSI function; i.e. for fixed X and M it computes */
/* the M-member sequence */
/* ((-1)**(K+1)/GAMMA(K+1))*PSI(K,X) */
/* for K = N,...,N+M-1 */
/* where PSI(K,X) is as defined above. For KODE=1, PSIFN returns */
/* the scaled derivatives as described. KODE=2 is operative only */
/* when K=0 and in that case PSIFN returns -PSI(X) + LN(X). That */
/* is, the logarithmic behavior for large X is removed when KODE=1 */
/* and K=0. When sums or differences of PSI functions are computed */
/* the logarithmic terms can be combined analytically and computed */
/* separately to help retain significant digits. */
/* Note that CALL PSIFN(X,0,1,1,ANS) results in */
/* ANS = -PSI(X) */
/* Input */
/* X - Argument, X .gt. 0.0E0 */
/* N - First member of the sequence, 0 .le. N .le. 100 */
/* N=0 gives ANS(1) = -PSI(X) for KODE=1 */
/* -PSI(X)+LN(X) for KODE=2 */
/* KODE - Selection parameter */
/* KODE=1 returns scaled derivatives of the PSI */
/* function. */
/* KODE=2 returns scaled derivatives of the PSI */
/* function EXCEPT when N=0. In this case, */
/* ANS(1) = -PSI(X) + LN(X) is returned. */
/* M - Number of members of the sequence, M .ge. 1 */
/* Output */
/* ANS - A vector of length at least M whose first M */
/* components contain the sequence of derivatives */
/* scaled according to KODE. */
/* NZ - Underflow flag */
/* NZ.eq.0, A normal return */
/* NZ.ne.0, Underflow, last NZ components of ANS are */
/* set to zero, ANS(M-K+1)=0.0, K=1,...,NZ */
/* IERR - Error flag */
/* IERR=0, A normal return, computation completed */
/* IERR=1, Input error, no computation */
/* IERR=2, Overflow, X too small or N+M-1 too */
/* large or both */
/* IERR=3, Error, N too large. Dimensioned */
/* array TRMR(NMAX) is not large enough for N */
/* The nominal computational accuracy is the maximum of unit */
/* roundoff (=R1MACH(4)) and 1.0E-18 since critical constants */
/* are given to only 18 digits. */
/* DPSIFN is the Double Precision version of PSIFN. */
/* *Long Description: */
/* The basic method of evaluation is the asymptotic expansion */
/* for large X.ge.XMIN followed by backward recursion on a two */
/* term recursion relation */
/* W(X+1) + X**(-N-1) = W(X). */
/* This is supplemented by a series */
/* SUM( (X+K)**(-N-1) , K=0,1,2,... ) */
/* which converges rapidly for large N. Both XMIN and the */
/* number of terms of the series are calculated from the unit */
/* roundoff of the machine environment. */
/* ***REFERENCES Handbook of Mathematical Functions, National Bureau */
/* of Standards Applied Mathematics Series 55, edited */
/* by M. Abramowitz and I. A. Stegun, equations 6.3.5, */
/* 6.3.18, 6.4.6, 6.4.9 and 6.4.10, pp.258-260, 1964. */
/* D. E. Amos, A portable Fortran subroutine for */
/* derivatives of the Psi function, Algorithm 610, ACM */
/* Transactions on Mathematical Software 9, 4 (1983), */
/* pp. 494-502. */
/* ***ROUTINES CALLED I1MACH, R1MACH */
/* ***REVISION HISTORY (YYMMDD) */
/* 820601 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) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE PSIFN */
/* Parameter adjustments */
--ans;
/* Function Body */
/* ----------------------------------------------------------------------- */
/* BERNOULLI NUMBERS */
/* ----------------------------------------------------------------------- */
/* ***FIRST EXECUTABLE STATEMENT PSIFN */
*ierr = 0;
*nz = 0;
if (*x <= 0.f) {
*ierr = 1;
}
if (*n < 0) {
*ierr = 1;
}
if (*kode < 1 || *kode > 2) {
*ierr = 1;
}
if (*m < 1) {
*ierr = 1;
}
if (*ierr != 0) {
return 0;
}
mm = *m;
/* Computing MIN */
i__1 = -i1mach_(&c__12), i__2 = i1mach_(&c__13);
nx = min(i__1,i__2);
r1m5 = r1mach_(&c__5);
r1m4 = r1mach_(&c__4) * .5f;
wdtol = dmax(r1m4,5e-19f);
/* ----------------------------------------------------------------------- */
/* ELIM = APPROXIMATE EXPONENTIAL OVER AND UNDERFLOW LIMIT */
/* ----------------------------------------------------------------------- */
elim = (nx * r1m5 - 3.f) * 2.302f;
xln = log(*x);
L41:
nn = *n + mm - 1;
fn = (real) nn;
fnp = fn + 1.f;
t = fnp * xln;
/* ----------------------------------------------------------------------- */
/* OVERFLOW AND UNDERFLOW TEST FOR SMALL AND LARGE X */
/* ----------------------------------------------------------------------- */
if (dabs(t) > elim) {
goto L290;
}
if (*x < wdtol) {
goto L260;
}
/* ----------------------------------------------------------------------- */
/* COMPUTE XMIN AND THE NUMBER OF TERMS OF THE SERIES, FLN+1 */
/* ----------------------------------------------------------------------- */
rln = r1m5 * i1mach_(&c__11);
rln = dmin(rln,18.06f);
fln = dmax(rln,3.f) - 3.f;
yint = fln * .4f + 3.5f;
slope = fln * (fln * 6.038e-4f + .008677f) + .21f;
xm = yint + slope * fn;
mx = (integer) xm + 1;
xmin = (real) mx;
if (*n == 0) {
goto L50;
}
xm = rln * -2.302f - dmin(0.f,xln);
fns = (real) (*n);
arg = xm / fns;
arg = dmin(0.f,arg);
eps = exp(arg);
xm = 1.f - eps;
if (dabs(arg) < .001f) {
xm = -arg;
}
fln = *x * xm / eps;
xm = xmin - *x;
if (xm > 7.f && fln < 15.f) {
goto L200;
}
L50:
xdmy = *x;
xdmln = xln;
xinc = 0.f;
if (*x >= xmin) {
goto L60;
}
nx = (integer) (*x);
xinc = xmin - nx;
xdmy = *x + xinc;
xdmln = log(xdmy);
L60:
/* ----------------------------------------------------------------------- */
/* GENERATE W(N+MM-1,X) BY THE ASYMPTOTIC EXPANSION */
/* ----------------------------------------------------------------------- */
t = fn * xdmln;
t1 = xdmln + xdmln;
t2 = t + xdmln;
/* Computing MAX */
r__1 = dabs(t), r__2 = dabs(t1), r__1 = max(r__1,r__2), r__2 = dabs(t2);
tk = dmax(r__1,r__2);
if (tk > elim) {
goto L380;
}
tss = exp(-t);
tt = .5f / xdmy;
t1 = tt;
tst = wdtol * tt;
if (nn != 0) {
t1 = tt + 1.f / fn;
}
rxsq = 1.f / (xdmy * xdmy);
ta = rxsq * .5f;
t = fnp * ta;
s = t * b[2];
if (dabs(s) < tst) {
goto L80;
}
tk = 2.f;
for (k = 4; k <= 22; ++k) {
t = t * ((tk + fn + 1.f) / (tk + 1.f)) * ((tk + fn) / (tk + 2.f)) *
rxsq;
trm[k - 1] = t * b[k - 1];
if ((r__1 = trm[k - 1], dabs(r__1)) < tst) {
goto L80;
}
s += trm[k - 1];
tk += 2.f;
/* L70: */
}
L80:
s = (s + t1) * tss;
if (xinc == 0.f) {
goto L100;
}
/* ----------------------------------------------------------------------- */
/* BACKWARD RECUR FROM XDMY TO X */
/* ----------------------------------------------------------------------- */
nx = (integer) xinc;
np = nn + 1;
if (nx > nmax) {
goto L390;
}
if (nn == 0) {
goto L160;
}
xm = xinc - 1.f;
fx = *x + xm;
/* ----------------------------------------------------------------------- */
/* THIS LOOP SHOULD NOT BE CHANGED. FX IS ACCURATE WHEN X IS SMALL */
/* ----------------------------------------------------------------------- */
i__1 = nx;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = -np;
trmr[i__ - 1] = pow_ri(&fx, &i__2);
s += trmr[i__ - 1];
xm += -1.f;
fx = *x + xm;
/* L90: */
}
L100:
ans[mm] = s;
if (fn == 0.f) {
goto L180;
}
/* ----------------------------------------------------------------------- */
/* GENERATE LOWER DERIVATIVES, J.LT.N+MM-1 */
/* ----------------------------------------------------------------------- */
if (mm == 1) {
return 0;
}
i__1 = mm;
for (j = 2; j <= i__1; ++j) {
fnp = fn;
fn += -1.f;
tss *= xdmy;
t1 = tt;
if (fn != 0.f) {
t1 = tt + 1.f / fn;
}
t = fnp * ta;
s = t * b[2];
if (dabs(s) < tst) {
goto L120;
}
tk = fnp + 3.f;
for (k = 4; k <= 22; ++k) {
trm[k - 1] = trm[k - 1] * fnp / tk;
if ((r__1 = trm[k - 1], dabs(r__1)) < tst) {
goto L120;
}
s += trm[k - 1];
tk += 2.f;
/* L110: */
}
L120:
s = (s + t1) * tss;
if (xinc == 0.f) {
goto L140;
}
if (fn == 0.f) {
goto L160;
}
xm = xinc - 1.f;
fx = *x + xm;
i__2 = nx;
for (i__ = 1; i__ <= i__2; ++i__) {
trmr[i__ - 1] *= fx;
s += trmr[i__ - 1];
xm += -1.f;
fx = *x + xm;
/* L130: */
}
L140:
mx = mm - j + 1;
ans[mx] = s;
if (fn == 0.f) {
goto L180;
}
/* L150: */
}
return 0;
/* ----------------------------------------------------------------------- */
/* RECURSION FOR N = 0 */
/* ----------------------------------------------------------------------- */
L160:
i__1 = nx;
for (i__ = 1; i__ <= i__1; ++i__) {
s += 1.f / (*x + nx - i__);
/* L170: */
}
L180:
if (*kode == 2) {
goto L190;
}
ans[1] = s - xdmln;
return 0;
L190:
if (xdmy == *x) {
return 0;
}
xq = xdmy / *x;
ans[1] = s - log(xq);
return 0;
/* ----------------------------------------------------------------------- */
/* COMPUTE BY SERIES (X+K)**(-(N+1)) , K=0,1,2,... */
/* ----------------------------------------------------------------------- */
L200:
nn = (integer) fln + 1;
np = *n + 1;
t1 = (fns + 1.f) * xln;
t = exp(-t1);
s = t;
den = *x;
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
den += 1.f;
i__2 = -np;
trm[i__ - 1] = pow_ri(&den, &i__2);
s += trm[i__ - 1];
/* L210: */
}
ans[1] = s;
if (*n != 0) {
goto L220;
}
if (*kode == 2) {
ans[1] = s + xln;
}
L220:
if (mm == 1) {
return 0;
}
/* ----------------------------------------------------------------------- */
/* GENERATE HIGHER DERIVATIVES, J.GT.N */
/* ----------------------------------------------------------------------- */
tol = wdtol / 5.f;
i__1 = mm;
for (j = 2; j <= i__1; ++j) {
t /= *x;
s = t;
tols = t * tol;
den = *x;
i__2 = nn;
for (i__ = 1; i__ <= i__2; ++i__) {
den += 1.f;
trm[i__ - 1] /= den;
s += trm[i__ - 1];
if (trm[i__ - 1] < tols) {
goto L240;
}
/* L230: */
}
L240:
ans[j] = s;
/* L250: */
}
return 0;
/* ----------------------------------------------------------------------- */
/* SMALL X.LT.UNIT ROUND OFF */
/* ----------------------------------------------------------------------- */
L260:
i__1 = -(*n) - 1;
ans[1] = pow_ri(x, &i__1);
if (mm == 1) {
goto L280;
}
k = 1;
i__1 = mm;
for (i__ = 2; i__ <= i__1; ++i__) {
ans[k + 1] = ans[k] / *x;
++k;
/* L270: */
}
L280:
if (*n != 0) {
return 0;
}
if (*kode == 2) {
ans[1] += xln;
}
return 0;
L290:
if (t > 0.f) {
goto L380;
}
*nz = 0;
*ierr = 2;
return 0;
L380:
++(*nz);
ans[mm] = 0.f;
--mm;
if (mm == 0) {
return 0;
}
goto L41;
L390:
*ierr = 3;
*nz = 0;
return 0;
} /* psifn_ */
/* DECK BESJ */
/* Subroutine */ int besj_(real *x, real *alpha, integer *n, real *y, integer
*nz)
{
/* Initialized data */
static real rtwo = 1.34839972492648f;
static real pdf = .785398163397448f;
static real rttp = .797884560802865f;
static real pidt = 1.5707963267949f;
static real pp[4] = { 8.72909153935547f,.26569393226503f,
.124578576865586f,7.70133747430388e-4f };
static integer inlim = 150;
static real fnulim[2] = { 100.f,60.f };
/* System generated locals */
integer i__1;
real r__1;
/* Local variables */
static integer i__, k;
static real s, t;
static integer i1, i2;
static real s1, s2, t1, t2, ak, ap, fn, sa;
static integer kk, in, km;
static real sb, ta, tb;
static integer is, nn, kt, ns;
static real tm, wk[7], tx, xo2, dfn, akm, arg, fnf, fni, gln, ans, dtm,
tfn, fnu, tau, tol, etx, rtx, trx, fnp1, xo2l, sxo2, coef, earg,
relb;
static integer ialp;
static real rden;
static integer iflw;
static real slim, temp[3], rtol, elim1, fidal;
static integer idalp;
static real flgjy;
extern /* Subroutine */ int jairy_();
static real rzden, tolln;
extern /* Subroutine */ int asyjy_(U_fp, real *, real *, real *, integer *
, real *, real *, integer *);
extern integer i1mach_(integer *);
extern doublereal r1mach_(integer *);
static real dalpha;
extern doublereal alngam_(real *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE BESJ */
/* ***PURPOSE Compute an N member sequence of J Bessel functions */
/* J/SUB(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA */
/* and X. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY C10A3 */
/* ***TYPE SINGLE PRECISION (BESJ-S, DBESJ-D) */
/* ***KEYWORDS J BESSEL FUNCTION, SPECIAL FUNCTIONS */
/* ***AUTHOR Amos, D. E., (SNLA) */
/* Daniel, S. L., (SNLA) */
/* Weston, M. K., (SNLA) */
/* ***DESCRIPTION */
/* Abstract */
/* BESJ computes an N member sequence of J Bessel functions */
/* J/sub(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA and X. */
/* A combination of the power series, the asymptotic expansion */
/* for X to infinity and the uniform asymptotic expansion for */
/* NU to infinity are applied over subdivisions of the (NU,X) */
/* plane. For values of (NU,X) not covered by one of these */
/* formulae, the order is incremented or decremented by integer */
/* values into a region where one of the formulae apply. Backward */
/* recursion is applied to reduce orders by integer values except */
/* where the entire sequence lies in the oscillatory region. In */
/* this case forward recursion is stable and values from the */
/* asymptotic expansion for X to infinity start the recursion */
/* when it is efficient to do so. Leading terms of the series */
/* and uniform expansion are tested for underflow. If a sequence */
/* is requested and the last member would underflow, the result */
/* is set to zero and the next lower order tried, etc., until a */
/* member comes on scale or all members are set to zero. */
/* Overflow cannot occur. */
/* Description of Arguments */
/* Input */
/* X - X .GE. 0.0E0 */
/* ALPHA - order of first member of the sequence, */
/* ALPHA .GE. 0.0E0 */
/* N - number of members in the sequence, N .GE. 1 */
/* Output */
/* Y - a vector whose first N components contain */
/* values for J/sub(ALPHA+K-1)/(X), K=1,...,N */
/* NZ - number of components of Y set to zero due to */
/* underflow, */
/* NZ=0 , normal return, computation completed */
/* NZ .NE. 0, last NZ components of Y set to zero, */
/* Y(K)=0.0E0, K=N-NZ+1,...,N. */
/* Error Conditions */
/* Improper input arguments - a fatal error */
/* Underflow - a non-fatal error (NZ .NE. 0) */
/* ***REFERENCES D. E. Amos, S. L. Daniel and M. K. Weston, CDC 6600 */
/* subroutines IBESS and JBESS for Bessel functions */
/* I(NU,X) and J(NU,X), X .GE. 0, NU .GE. 0, ACM */
/* Transactions on Mathematical Software 3, (1977), */
/* pp. 76-92. */
/* F. W. J. Olver, Tables of Bessel Functions of Moderate */
/* or Large Orders, NPL Mathematical Tables 6, Her */
/* Majesty's Stationery Office, London, 1962. */
/* ***ROUTINES CALLED ALNGAM, ASYJY, I1MACH, JAIRY, R1MACH, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 750101 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) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE BESJ */
/* Parameter adjustments */
--y;
/* Function Body */
/* ***FIRST EXECUTABLE STATEMENT BESJ */
*nz = 0;
kt = 1;
ns = 0;
/* I1MACH(14) REPLACES I1MACH(11) IN A DOUBLE PRECISION CODE */
/* I1MACH(15) REPLACES I1MACH(12) IN A DOUBLE PRECISION CODE */
ta = r1mach_(&c__3);
tol = dmax(ta,1e-15f);
i1 = i1mach_(&c__11) + 1;
i2 = i1mach_(&c__12);
tb = r1mach_(&c__5);
elim1 = (i2 * tb + 3.f) * -2.303f;
rtol = 1.f / tol;
slim = r1mach_(&c__1) * 1e3f * rtol;
/* TOLLN = -LN(TOL) */
tolln = tb * 2.303f * i1;
tolln = dmin(tolln,34.5388f);
if ((i__1 = *n - 1) < 0) {
goto L720;
} else if (i__1 == 0) {
goto L10;
} else {
goto L20;
}
L10:
kt = 2;
L20:
nn = *n;
if (*x < 0.f) {
goto L730;
} else if (*x == 0) {
goto L30;
} else {
goto L80;
}
L30:
if (*alpha < 0.f) {
goto L710;
} else if (*alpha == 0) {
goto L40;
} else {
goto L50;
}
L40:
y[1] = 1.f;
if (*n == 1) {
return 0;
}
i1 = 2;
goto L60;
L50:
i1 = 1;
L60:
i__1 = *n;
for (i__ = i1; i__ <= i__1; ++i__) {
y[i__] = 0.f;
/* L70: */
}
return 0;
L80:
if (*alpha < 0.f) {
goto L710;
}
ialp = (integer) (*alpha);
fni = (real) (ialp + *n - 1);
fnf = *alpha - ialp;
dfn = fni + fnf;
fnu = dfn;
xo2 = *x * .5f;
sxo2 = xo2 * xo2;
/* DECISION TREE FOR REGION WHERE SERIES, ASYMPTOTIC EXPANSION FOR X */
/* TO INFINITY AND ASYMPTOTIC EXPANSION FOR NU TO INFINITY ARE */
/* APPLIED. */
if (sxo2 <= fnu + 1.f) {
goto L90;
}
ta = dmax(20.f,fnu);
if (*x > ta) {
goto L120;
}
if (*x > 12.f) {
goto L110;
}
xo2l = log(xo2);
ns = (integer) (sxo2 - fnu) + 1;
goto L100;
L90:
fn = fnu;
fnp1 = fn + 1.f;
xo2l = log(xo2);
is = kt;
if (*x <= .5f) {
goto L330;
}
ns = 0;
L100:
fni += ns;
dfn = fni + fnf;
fn = dfn;
fnp1 = fn + 1.f;
is = kt;
if (*n - 1 + ns > 0) {
is = 3;
}
goto L330;
L110:
/* Computing MAX */
r__1 = 36.f - fnu;
ans = dmax(r__1,0.f);
ns = (integer) ans;
fni += ns;
dfn = fni + fnf;
fn = dfn;
is = kt;
if (*n - 1 + ns > 0) {
is = 3;
}
goto L130;
L120:
rtx = sqrt(*x);
tau = rtwo * rtx;
ta = tau + fnulim[kt - 1];
if (fnu <= ta) {
goto L480;
}
fn = fnu;
is = kt;
/* UNIFORM ASYMPTOTIC EXPANSION FOR NU TO INFINITY */
L130:
i1 = (i__1 = 3 - is, abs(i__1));
i1 = max(i1,1);
flgjy = 1.f;
asyjy_((U_fp)jairy_, x, &fn, &flgjy, &i1, &temp[is - 1], wk, &iflw);
if (iflw != 0) {
goto L380;
}
switch (is) {
case 1: goto L320;
case 2: goto L450;
case 3: goto L620;
}
L310:
temp[0] = temp[2];
kt = 1;
L320:
is = 2;
fni += -1.f;
dfn = fni + fnf;
fn = dfn;
if (i1 == 2) {
goto L450;
}
goto L130;
/* SERIES FOR (X/2)**2.LE.NU+1 */
L330:
gln = alngam_(&fnp1);
arg = fn * xo2l - gln;
if (arg < -elim1) {
goto L400;
}
earg = exp(arg);
L340:
s = 1.f;
if (*x < tol) {
goto L360;
}
ak = 3.f;
t2 = 1.f;
t = 1.f;
s1 = fn;
for (k = 1; k <= 17; ++k) {
s2 = t2 + s1;
t = -t * sxo2 / s2;
s += t;
if (dabs(t) < tol) {
goto L360;
}
t2 += ak;
ak += 2.f;
s1 += fn;
/* L350: */
}
L360:
temp[is - 1] = s * earg;
switch (is) {
case 1: goto L370;
case 2: goto L450;
case 3: goto L610;
}
L370:
earg = earg * fn / xo2;
fni += -1.f;
dfn = fni + fnf;
fn = dfn;
is = 2;
goto L340;
/* SET UNDERFLOW VALUE AND UPDATE PARAMETERS */
/* UNDERFLOW CAN ONLY OCCUR FOR NS=0 SINCE THE ORDER MUST BE */
/* LARGER THAN 36. THEREFORE, NS NEED NOT BE CONSIDERED. */
L380:
y[nn] = 0.f;
--nn;
fni += -1.f;
dfn = fni + fnf;
fn = dfn;
if ((i__1 = nn - 1) < 0) {
goto L440;
} else if (i__1 == 0) {
goto L390;
} else {
goto L130;
}
L390:
kt = 2;
is = 2;
goto L130;
L400:
y[nn] = 0.f;
--nn;
fnp1 = fn;
fni += -1.f;
dfn = fni + fnf;
fn = dfn;
if ((i__1 = nn - 1) < 0) {
goto L440;
} else if (i__1 == 0) {
goto L410;
} else {
goto L420;
}
L410:
kt = 2;
is = 2;
L420:
if (sxo2 <= fnp1) {
goto L430;
}
goto L130;
L430:
arg = arg - xo2l + log(fnp1);
if (arg < -elim1) {
goto L400;
}
goto L330;
L440:
*nz = *n - nn;
return 0;
/* BACKWARD RECURSION SECTION */
L450:
if (ns != 0) {
goto L451;
}
*nz = *n - nn;
if (kt == 2) {
goto L470;
}
/* BACKWARD RECUR FROM INDEX ALPHA+NN-1 TO ALPHA */
y[nn] = temp[0];
y[nn - 1] = temp[1];
if (nn == 2) {
return 0;
}
L451:
trx = 2.f / *x;
dtm = fni;
tm = (dtm + fnf) * trx;
ak = 1.f;
ta = temp[0];
tb = temp[1];
if (dabs(ta) > slim) {
goto L455;
}
ta *= rtol;
tb *= rtol;
ak = tol;
L455:
kk = 2;
in = ns - 1;
if (in == 0) {
goto L690;
}
if (ns != 0) {
goto L670;
}
k = nn - 2;
i__1 = nn;
for (i__ = 3; i__ <= i__1; ++i__) {
s = tb;
tb = tm * tb - ta;
ta = s;
y[k] = tb * ak;
--k;
dtm += -1.f;
tm = (dtm + fnf) * trx;
/* L460: */
}
return 0;
L470:
y[1] = temp[1];
return 0;
/* ASYMPTOTIC EXPANSION FOR X TO INFINITY WITH FORWARD RECURSION IN */
/* OSCILLATORY REGION X.GT.MAX(20, NU), PROVIDED THE LAST MEMBER */
/* OF THE SEQUENCE IS ALSO IN THE REGION. */
L480:
in = (integer) (*alpha - tau + 2.f);
if (in <= 0) {
goto L490;
}
idalp = ialp - in - 1;
kt = 1;
goto L500;
L490:
idalp = ialp;
in = 0;
L500:
is = kt;
fidal = (real) idalp;
dalpha = fidal + fnf;
arg = *x - pidt * dalpha - pdf;
sa = sin(arg);
sb = cos(arg);
coef = rttp / rtx;
etx = *x * 8.f;
L510:
dtm = fidal + fidal;
dtm *= dtm;
tm = 0.f;
if (fidal == 0.f && dabs(fnf) < tol) {
goto L520;
}
tm = fnf * 4.f * (fidal + fidal + fnf);
L520:
trx = dtm - 1.f;
t2 = (trx + tm) / etx;
s2 = t2;
relb = tol * dabs(t2);
t1 = etx;
s1 = 1.f;
fn = 1.f;
ak = 8.f;
for (k = 1; k <= 13; ++k) {
t1 += etx;
fn += ak;
trx = dtm - fn;
ap = trx + tm;
t2 = -t2 * ap / t1;
s1 += t2;
t1 += etx;
ak += 8.f;
fn += ak;
trx = dtm - fn;
ap = trx + tm;
t2 = t2 * ap / t1;
s2 += t2;
if (dabs(t2) <= relb) {
goto L540;
}
ak += 8.f;
/* L530: */
}
L540:
temp[is - 1] = coef * (s1 * sb - s2 * sa);
if (is == 2) {
goto L560;
}
fidal += 1.f;
dalpha = fidal + fnf;
is = 2;
tb = sa;
sa = -sb;
sb = tb;
goto L510;
/* FORWARD RECURSION SECTION */
L560:
if (kt == 2) {
goto L470;
}
s1 = temp[0];
s2 = temp[1];
tx = 2.f / *x;
tm = dalpha * tx;
if (in == 0) {
goto L580;
}
/* FORWARD RECUR TO INDEX ALPHA */
i__1 = in;
for (i__ = 1; i__ <= i__1; ++i__) {
s = s2;
s2 = tm * s2 - s1;
tm += tx;
s1 = s;
/* L570: */
}
if (nn == 1) {
goto L600;
}
s = s2;
s2 = tm * s2 - s1;
tm += tx;
s1 = s;
L580:
/* FORWARD RECUR FROM INDEX ALPHA TO ALPHA+N-1 */
y[1] = s1;
y[2] = s2;
if (nn == 2) {
return 0;
}
i__1 = nn;
for (i__ = 3; i__ <= i__1; ++i__) {
y[i__] = tm * y[i__ - 1] - y[i__ - 2];
tm += tx;
/* L590: */
}
return 0;
L600:
y[1] = s2;
return 0;
/* BACKWARD RECURSION WITH NORMALIZATION BY */
/* ASYMPTOTIC EXPANSION FOR NU TO INFINITY OR POWER SERIES. */
L610:
/* COMPUTATION OF LAST ORDER FOR SERIES NORMALIZATION */
/* Computing MAX */
r__1 = 3.f - fn;
akm = dmax(r__1,0.f);
km = (integer) akm;
tfn = fn + km;
ta = (gln + tfn - .9189385332f - .0833333333f / tfn) / (tfn + .5f);
ta = xo2l - ta;
tb = -(1.f - 1.5f / tfn) / tfn;
akm = tolln / (-ta + sqrt(ta * ta - tolln * tb)) + 1.5f;
in = km + (integer) akm;
goto L660;
L620:
/* COMPUTATION OF LAST ORDER FOR ASYMPTOTIC EXPANSION NORMALIZATION */
gln = wk[2] + wk[1];
if (wk[5] > 30.f) {
goto L640;
}
rden = (pp[3] * wk[5] + pp[2]) * wk[5] + 1.f;
rzden = pp[0] + pp[1] * wk[5];
ta = rzden / rden;
if (wk[0] < .1f) {
goto L630;
}
tb = gln / wk[4];
goto L650;
L630:
tb = ((wk[0] * .0887944358f + .167989473f) * wk[0] + 1.259921049f) / wk[6]
;
goto L650;
L640:
ta = tolln * .5f / wk[3];
ta = ((ta * .049382716f - .1111111111f) * ta + .6666666667f) * ta * wk[5];
if (wk[0] < .1f) {
goto L630;
}
tb = gln / wk[4];
L650:
in = (integer) (ta / tb + 1.5f);
if (in > inlim) {
goto L310;
}
L660:
dtm = fni + in;
trx = 2.f / *x;
tm = (dtm + fnf) * trx;
ta = 0.f;
tb = tol;
kk = 1;
ak = 1.f;
L670:
/* BACKWARD RECUR UNINDEXED AND SCALE WHEN MAGNITUDES ARE CLOSE TO */
/* UNDERFLOW LIMITS (LESS THAN SLIM=R1MACH(1)*1.0E+3/TOL) */
i__1 = in;
for (i__ = 1; i__ <= i__1; ++i__) {
s = tb;
tb = tm * tb - ta;
ta = s;
dtm += -1.f;
tm = (dtm + fnf) * trx;
/* L680: */
}
/* NORMALIZATION */
if (kk != 1) {
goto L690;
}
s = temp[2];
sa = ta / tb;
ta = s;
tb = s;
if (dabs(s) > slim) {
goto L685;
}
ta *= rtol;
tb *= rtol;
ak = tol;
L685:
ta *= sa;
kk = 2;
in = ns;
if (ns != 0) {
goto L670;
}
L690:
y[nn] = tb * ak;
*nz = *n - nn;
if (nn == 1) {
return 0;
}
k = nn - 1;
s = tb;
tb = tm * tb - ta;
ta = s;
y[k] = tb * ak;
if (nn == 2) {
return 0;
}
dtm += -1.f;
tm = (dtm + fnf) * trx;
k = nn - 2;
/* BACKWARD RECUR INDEXED */
i__1 = nn;
for (i__ = 3; i__ <= i__1; ++i__) {
s = tb;
tb = tm * tb - ta;
ta = s;
y[k] = tb * ak;
dtm += -1.f;
tm = (dtm + fnf) * trx;
--k;
/* L700: */
}
return 0;
L710:
xermsg_("SLATEC", "BESJ", "ORDER, ALPHA, LESS THAN ZERO.", &c__2, &c__1, (
ftnlen)6, (ftnlen)4, (ftnlen)29);
return 0;
L720:
xermsg_("SLATEC", "BESJ", "N LESS THAN ONE.", &c__2, &c__1, (ftnlen)6, (
ftnlen)4, (ftnlen)16);
return 0;
L730:
xermsg_("SLATEC", "BESJ", "X LESS THAN ZERO.", &c__2, &c__1, (ftnlen)6, (
ftnlen)4, (ftnlen)17);
return 0;
} /* besj_ */
/* DECK RC6J */
/* Subroutine */ int rc6j_(real *l2, real *l3, real *l4, real *l5, real *l6,
real *l1min, real *l1max, real *sixcof, integer *ndim, integer *ier)
{
/* Initialized data */
static real zero = 0.f;
static real eps = .01f;
static real one = 1.f;
static real two = 2.f;
static real three = 3.f;
/* System generated locals */
integer i__1;
real r__1, r__2, r__3, r__4;
/* Local variables */
static integer i__, n;
static real x, y, a1, a2, c1, c2, l1, x1, x2, x3, y1, y2, y3, dv, a1s,
a2s, sum1, sum2, huge__;
static integer nfin, nlim;
static real tiny, c1old, sign1, sign2, denom;
static integer index;
static real cnorm, ratio;
static integer lstep;
extern doublereal r1mach_(integer *);
static integer nfinp1, nfinp2, nfinp3, nstep2;
static real oldfac, newfac, sumbac, srhuge, thresh;
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
static real sumfor, sumuni, srtiny;
/* ***BEGIN PROLOGUE RC6J */
/* ***PURPOSE Evaluate the 6j symbol h(L1) = {L1 L2 L3} */
/* {L4 L5 L6} */
/* for all allowed values of L1, the other parameters */
/* being held fixed. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY C19 */
/* ***TYPE SINGLE PRECISION (RC6J-S, DRC6J-D) */
/* ***KEYWORDS 6J COEFFICIENTS, 6J SYMBOLS, CLEBSCH-GORDAN COEFFICIENTS, */
/* RACAH COEFFICIENTS, VECTOR ADDITION COEFFICIENTS, */
/* WIGNER COEFFICIENTS */
/* ***AUTHOR Gordon, R. G., Harvard University */
/* Schulten, K., Max Planck Institute */
/* ***DESCRIPTION */
/* *Usage: */
/* REAL L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF(NDIM) */
/* INTEGER NDIM, IER */
/* CALL RC6J(L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF, NDIM, IER) */
/* *Arguments: */
/* L2 :IN Parameter in 6j symbol. */
/* L3 :IN Parameter in 6j symbol. */
/* L4 :IN Parameter in 6j symbol. */
/* L5 :IN Parameter in 6j symbol. */
/* L6 :IN Parameter in 6j symbol. */
/* L1MIN :OUT Smallest allowable L1 in 6j symbol. */
/* L1MAX :OUT Largest allowable L1 in 6j symbol. */
/* SIXCOF :OUT Set of 6j coefficients generated by evaluating the */
/* 6j symbol for all allowed values of L1. SIXCOF(I) */
/* will contain h(L1MIN+I-1), I=1,2,...,L1MAX-L1MIN+1. */
/* NDIM :IN Declared length of SIXCOF in calling program. */
/* IER :OUT Error flag. */
/* IER=0 No errors. */
/* IER=1 L2+L3+L5+L6 or L4+L2+L6 not an integer. */
/* IER=2 L4, L2, L6 triangular condition not satisfied. */
/* IER=3 L4, L5, L3 triangular condition not satisfied. */
/* IER=4 L1MAX-L1MIN not an integer. */
/* IER=5 L1MAX less than L1MIN. */
/* IER=6 NDIM less than L1MAX-L1MIN+1. */
/* *Description: */
/* The definition and properties of 6j symbols can be found, for */
/* example, in Appendix C of Volume II of A. Messiah. Although the */
/* parameters of the vector addition coefficients satisfy certain */
/* conventional restrictions, the restriction that they be non-negative */
/* integers or non-negative integers plus 1/2 is not imposed on input */
/* to this subroutine. The restrictions imposed are */
/* 1. L2+L3+L5+L6 and L2+L4+L6 must be integers; */
/* 2. ABS(L2-L4).LE.L6.LE.L2+L4 must be satisfied; */
/* 3. ABS(L4-L5).LE.L3.LE.L4+L5 must be satisfied; */
/* 4. L1MAX-L1MIN must be a non-negative integer, where */
/* L1MAX=MIN(L2+L3,L5+L6) and L1MIN=MAX(ABS(L2-L3),ABS(L5-L6)). */
/* If all the conventional restrictions are satisfied, then these */
/* restrictions are met. Conversely, if input to this subroutine meets */
/* all of these restrictions and the conventional restriction stated */
/* above, then all the conventional restrictions are satisfied. */
/* The user should be cautious in using input parameters that do */
/* not satisfy the conventional restrictions. For example, the */
/* the subroutine produces values of */
/* h(L1) = { L1 2/3 1 } */
/* {2/3 2/3 2/3} */
/* for L1=1/3 and 4/3 but none of the symmetry properties of the 6j */
/* symbol, set forth on pages 1063 and 1064 of Messiah, is satisfied. */
/* The subroutine generates h(L1MIN), h(L1MIN+1), ..., h(L1MAX) */
/* where L1MIN and L1MAX are defined above. The sequence h(L1) is */
/* generated by a three-term recurrence algorithm with scaling to */
/* control overflow. Both backward and forward recurrence are used to */
/* maintain numerical stability. The two recurrence sequences are */
/* matched at an interior point and are normalized from the unitary */
/* property of 6j coefficients and Wigner's phase convention. */
/* The algorithm is suited to applications in which large quantum */
/* numbers arise, such as in molecular dynamics. */
/* ***REFERENCES 1. Messiah, Albert., Quantum Mechanics, Volume II, */
/* North-Holland Publishing Company, 1963. */
/* 2. Schulten, Klaus and Gordon, Roy G., Exact recursive */
/* evaluation of 3j and 6j coefficients for quantum- */
/* mechanical coupling of angular momenta, J Math */
/* Phys, v 16, no. 10, October 1975, pp. 1961-1970. */
/* 3. Schulten, Klaus and Gordon, Roy G., Semiclassical */
/* approximations to 3j and 6j coefficients for */
/* quantum-mechanical coupling of angular momenta, */
/* J Math Phys, v 16, no. 10, October 1975, */
/* pp. 1971-1988. */
/* 4. Schulten, Klaus and Gordon, Roy G., Recursive */
/* evaluation of 3j and 6j coefficients, Computer */
/* Phys Comm, v 11, 1976, pp. 269-278. */
/* ***ROUTINES CALLED R1MACH, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 750101 DATE WRITTEN */
/* 880515 SLATEC prologue added by G. C. Nielson, NBS; parameters */
/* HUGE and TINY revised to depend on R1MACH. */
/* 891229 Prologue description rewritten; other prologue sections */
/* revised; LMATCH (location of match point for recurrences) */
/* removed from argument list; argument IER changed to serve */
/* only as an error flag (previously, in cases without error, */
/* it returned the number of scalings); number of error codes */
/* increased to provide more precise error information; */
/* program comments revised; SLATEC error handler calls */
/* introduced to enable printing of error messages to meet */
/* SLATEC standards. These changes were done by D. W. Lozier, */
/* M. A. McClain and J. M. Smith of the National Institute */
/* of Standards and Technology, formerly NBS. */
/* 910415 Mixed type expressions eliminated; variable C1 initialized; */
/* description of SIXCOF expanded. These changes were done by */
/* D. W. Lozier. */
/* ***END PROLOGUE RC6J */
/* Parameter adjustments */
--sixcof;
/* Function Body */
/* ***FIRST EXECUTABLE STATEMENT RC6J */
*ier = 0;
/* HUGE is the square root of one twentieth of the largest floating */
/* point number, approximately. */
huge__ = sqrt(r1mach_(&c__2) / 20.f);
srhuge = sqrt(huge__);
tiny = 1.f / huge__;
srtiny = 1.f / srhuge;
/* LMATCH = ZERO */
/* Check error conditions 1, 2, and 3. */
r__1 = *l2 + *l3 + *l5 + *l6 + eps;
r__2 = *l4 + *l2 + *l6 + eps;
if (r_mod(&r__1, &one) >= eps + eps || r_mod(&r__2, &one) >= eps + eps) {
*ier = 1;
xermsg_("SLATEC", "RC6J", "L2+L3+L5+L6 or L4+L2+L6 not integer.", ier,
&c__1, (ftnlen)6, (ftnlen)4, (ftnlen)36);
return 0;
} else if (*l4 + *l2 - *l6 < zero || *l4 - *l2 + *l6 < zero || -(*l4) + *
l2 + *l6 < zero) {
*ier = 2;
xermsg_("SLATEC", "RC6J", "L4, L2, L6 triangular condition not satis"
"fied.", ier, &c__1, (ftnlen)6, (ftnlen)4, (ftnlen)46);
return 0;
} else if (*l4 - *l5 + *l3 < zero || *l4 + *l5 - *l3 < zero || -(*l4) + *
l5 + *l3 < zero) {
*ier = 3;
xermsg_("SLATEC", "RC6J", "L4, L5, L3 triangular condition not satis"
"fied.", ier, &c__1, (ftnlen)6, (ftnlen)4, (ftnlen)46);
return 0;
}
/* Limits for L1 */
/* Computing MAX */
r__3 = (r__1 = *l2 - *l3, dabs(r__1)), r__4 = (r__2 = *l5 - *l6, dabs(
r__2));
*l1min = dmax(r__3,r__4);
/* Computing MIN */
r__1 = *l2 + *l3, r__2 = *l5 + *l6;
*l1max = dmin(r__1,r__2);
/* Check error condition 4. */
r__1 = *l1max - *l1min + eps;
if (r_mod(&r__1, &one) >= eps + eps) {
*ier = 4;
xermsg_("SLATEC", "RC6J", "L1MAX-L1MIN not integer.", ier, &c__1, (
ftnlen)6, (ftnlen)4, (ftnlen)24);
return 0;
}
if (*l1min < *l1max - eps) {
goto L20;
}
if (*l1min < *l1max + eps) {
goto L10;
}
/* Check error condition 5. */
*ier = 5;
xermsg_("SLATEC", "RC6J", "L1MIN greater than L1MAX.", ier, &c__1, (
ftnlen)6, (ftnlen)4, (ftnlen)25);
return 0;
/* This is reached in case that L1 can take only one value */
L10:
/* LSCALE = 0 */
r__1 = -one;
i__1 = (integer) (*l2 + *l3 + *l5 + *l6 + eps);
sixcof[1] = pow_ri(&r__1, &i__1) / sqrt((*l1min + *l1min + one) * (*l4 + *
l4 + one));
return 0;
/* This is reached in case that L1 can take more than one value. */
L20:
/* LSCALE = 0 */
nfin = (integer) (*l1max - *l1min + one + eps);
if (*ndim - nfin >= 0) {
goto L23;
} else {
goto L21;
}
/* Check error condition 6. */
L21:
*ier = 6;
xermsg_("SLATEC", "RC6J", "Dimension of result array for 6j coefficients"
" too small.", ier, &c__1, (ftnlen)6, (ftnlen)4, (ftnlen)56);
return 0;
/* Start of forward recursion */
L23:
l1 = *l1min;
newfac = 0.f;
c1 = 0.f;
sixcof[1] = srtiny;
sum1 = (l1 + l1 + one) * tiny;
lstep = 1;
L30:
++lstep;
l1 += one;
oldfac = newfac;
a1 = (l1 + *l2 + *l3 + one) * (l1 - *l2 + *l3) * (l1 + *l2 - *l3) * (-l1
+ *l2 + *l3 + one);
a2 = (l1 + *l5 + *l6 + one) * (l1 - *l5 + *l6) * (l1 + *l5 - *l6) * (-l1
+ *l5 + *l6 + one);
newfac = sqrt(a1 * a2);
if (l1 < one + eps) {
goto L40;
}
dv = two * (*l2 * (*l2 + one) * *l5 * (*l5 + one) + *l3 * (*l3 + one) * *
l6 * (*l6 + one) - l1 * (l1 - one) * *l4 * (*l4 + one)) - (*l2 * (
*l2 + one) + *l3 * (*l3 + one) - l1 * (l1 - one)) * (*l5 * (*l5 +
one) + *l6 * (*l6 + one) - l1 * (l1 - one));
denom = (l1 - one) * newfac;
if (lstep - 2 <= 0) {
goto L32;
} else {
goto L31;
}
L31:
c1old = dabs(c1);
L32:
c1 = -(l1 + l1 - one) * dv / denom;
goto L50;
/* If L1 = 1, (L1 - 1) has to be factored out of DV, hence */
L40:
c1 = -two * (*l2 * (*l2 + one) + *l5 * (*l5 + one) - *l4 * (*l4 + one)) /
newfac;
L50:
if (lstep > 2) {
goto L60;
}
/* If L1 = L1MIN + 1, the third term in recursion equation vanishes */
x = srtiny * c1;
sixcof[2] = x;
sum1 += tiny * (l1 + l1 + one) * c1 * c1;
if (lstep == nfin) {
goto L220;
}
goto L30;
L60:
c2 = -l1 * oldfac / denom;
/* Recursion to the next 6j coefficient X */
x = c1 * sixcof[lstep - 1] + c2 * sixcof[lstep - 2];
sixcof[lstep] = x;
sumfor = sum1;
sum1 += (l1 + l1 + one) * x * x;
if (lstep == nfin) {
goto L100;
}
/* See if last unnormalized 6j coefficient exceeds SRHUGE */
if (dabs(x) < srhuge) {
goto L80;
}
/* This is reached if last 6j coefficient larger than SRHUGE, */
/* so that the recursion series SIXCOF(1), ... ,SIXCOF(LSTEP) */
/* has to be rescaled to prevent overflow */
/* LSCALE = LSCALE + 1 */
i__1 = lstep;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((r__1 = sixcof[i__], dabs(r__1)) < srtiny) {
sixcof[i__] = zero;
}
/* L70: */
sixcof[i__] /= srhuge;
}
sum1 /= huge__;
sumfor /= huge__;
x /= srhuge;
/* As long as the coefficient ABS(C1) is decreasing, the recursion */
/* proceeds towards increasing 6j values and, hence, is numerically */
/* stable. Once an increase of ABS(C1) is detected, the recursion */
/* direction is reversed. */
L80:
if (c1old - dabs(c1) <= 0.f) {
goto L100;
} else {
goto L30;
}
/* Keep three 6j coefficients around LMATCH for comparison later */
/* with backward recursion. */
L100:
/* LMATCH = L1 - 1 */
x1 = x;
x2 = sixcof[lstep - 1];
x3 = sixcof[lstep - 2];
/* Starting backward recursion from L1MAX taking NSTEP2 steps, so */
/* that forward and backward recursion overlap at the three points */
/* L1 = LMATCH+1, LMATCH, LMATCH-1. */
nfinp1 = nfin + 1;
nfinp2 = nfin + 2;
nfinp3 = nfin + 3;
nstep2 = nfin - lstep + 3;
l1 = *l1max;
sixcof[nfin] = srtiny;
sum2 = (l1 + l1 + one) * tiny;
l1 += two;
lstep = 1;
L110:
++lstep;
l1 -= one;
oldfac = newfac;
a1s = (l1 + *l2 + *l3) * (l1 - *l2 + *l3 - one) * (l1 + *l2 - *l3 - one) *
(-l1 + *l2 + *l3 + two);
a2s = (l1 + *l5 + *l6) * (l1 - *l5 + *l6 - one) * (l1 + *l5 - *l6 - one) *
(-l1 + *l5 + *l6 + two);
newfac = sqrt(a1s * a2s);
dv = two * (*l2 * (*l2 + one) * *l5 * (*l5 + one) + *l3 * (*l3 + one) * *
l6 * (*l6 + one) - l1 * (l1 - one) * *l4 * (*l4 + one)) - (*l2 * (
*l2 + one) + *l3 * (*l3 + one) - l1 * (l1 - one)) * (*l5 * (*l5 +
one) + *l6 * (*l6 + one) - l1 * (l1 - one));
denom = l1 * newfac;
c1 = -(l1 + l1 - one) * dv / denom;
if (lstep > 2) {
goto L120;
}
/* If L1 = L1MAX + 1 the third term in the recursion equation vanishes */
y = srtiny * c1;
sixcof[nfin - 1] = y;
if (lstep == nstep2) {
goto L200;
}
sumbac = sum2;
sum2 += (l1 + l1 - three) * c1 * c1 * tiny;
goto L110;
L120:
c2 = -(l1 - one) * oldfac / denom;
/* Recursion to the next 6j coefficient Y */
y = c1 * sixcof[nfinp2 - lstep] + c2 * sixcof[nfinp3 - lstep];
if (lstep == nstep2) {
goto L200;
}
sixcof[nfinp1 - lstep] = y;
sumbac = sum2;
sum2 += (l1 + l1 - three) * y * y;
/* See if last unnormalized 6j coefficient exceeds SRHUGE */
if (dabs(y) < srhuge) {
goto L110;
}
/* This is reached if last 6j coefficient larger than SRHUGE, */
/* so that the recursion series SIXCOF(NFIN), ... ,SIXCOF(NFIN-LSTEP+1) */
/* has to be rescaled to prevent overflow */
/* LSCALE = LSCALE + 1 */
i__1 = lstep;
for (i__ = 1; i__ <= i__1; ++i__) {
index = nfin - i__ + 1;
if ((r__1 = sixcof[index], dabs(r__1)) < srtiny) {
sixcof[index] = zero;
}
/* L130: */
sixcof[index] /= srhuge;
}
sumbac /= huge__;
sum2 /= huge__;
goto L110;
/* The forward recursion 6j coefficients X1, X2, X3 are to be matched */
/* with the corresponding backward recursion values Y1, Y2, Y3. */
L200:
y3 = y;
y2 = sixcof[nfinp2 - lstep];
y1 = sixcof[nfinp3 - lstep];
/* Determine now RATIO such that YI = RATIO * XI (I=1,2,3) holds */
/* with minimal error. */
ratio = (x1 * y1 + x2 * y2 + x3 * y3) / (x1 * x1 + x2 * x2 + x3 * x3);
nlim = nfin - nstep2 + 1;
if (dabs(ratio) < one) {
goto L211;
}
i__1 = nlim;
for (n = 1; n <= i__1; ++n) {
/* L210: */
sixcof[n] = ratio * sixcof[n];
}
sumuni = ratio * ratio * sumfor + sumbac;
goto L230;
L211:
++nlim;
ratio = one / ratio;
i__1 = nfin;
for (n = nlim; n <= i__1; ++n) {
/* L212: */
sixcof[n] = ratio * sixcof[n];
}
sumuni = sumfor + ratio * ratio * sumbac;
goto L230;
L220:
sumuni = sum1;
/* Normalize 6j coefficients */
L230:
cnorm = one / sqrt((*l4 + *l4 + one) * sumuni);
/* Sign convention for last 6j coefficient determines overall phase */
sign1 = r_sign(&one, &sixcof[nfin]);
r__1 = -one;
i__1 = (integer) (*l2 + *l3 + *l5 + *l6 + eps);
sign2 = pow_ri(&r__1, &i__1);
if (sign1 * sign2 <= 0.f) {
goto L235;
} else {
goto L236;
}
L235:
cnorm = -cnorm;
L236:
if (dabs(cnorm) < one) {
goto L250;
}
i__1 = nfin;
for (n = 1; n <= i__1; ++n) {
/* L240: */
sixcof[n] = cnorm * sixcof[n];
}
return 0;
L250:
thresh = tiny / dabs(cnorm);
i__1 = nfin;
for (n = 1; n <= i__1; ++n) {
if ((r__1 = sixcof[n], dabs(r__1)) < thresh) {
sixcof[n] = zero;
}
/* L251: */
sixcof[n] = cnorm * sixcof[n];
}
return 0;
} /* rc6j_ */
/* DECK BESYNU */
/* Subroutine */ int besynu_(real *x, real *fnu, integer *n, real *y)
{
/* Initialized data */
static real x1 = 3.f;
static real x2 = 20.f;
static real pi = 3.14159265358979f;
static real rthpi = .797884560802865f;
static real hpi = 1.5707963267949f;
static real cc[8] = { .577215664901533f,-.0420026350340952f,
-.0421977345555443f,.007218943246663f,-2.152416741149e-4f,
-2.01348547807e-5f,1.133027232e-6f,6.116095e-9f };
/* System generated locals */
integer i__1;
real r__1, r__2;
/* Local variables */
static real a[120], f, g;
static integer i__, j, k;
static real p, q, s, a1, a2, g1, g2, s1, s2, t1, t2, cb[120], fc, ak, bk,
ck, fk, fn, rb[120];
static integer kk;
static real cs, sa, sb, cx;
static integer nn;
static real tb, fx, tm, pt, rs, ss, st, rx, cp1, cp2, cs1, cs2, rp1, rp2,
rs1, rs2, cbk, cck, arg, rbk, rck, fhs, fks, cpt, dnu, fmu;
static integer inu;
static real tol, etx, smu, rpt, dnu2, coef, relb, flrx;
extern doublereal gamma_(real *);
static real etest;
extern doublereal r1mach_(integer *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE BESYNU */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to BESY */
/* ***LIBRARY SLATEC */
/* ***TYPE SINGLE PRECISION (BESYNU-S, DBSYNU-D) */
/* ***AUTHOR Amos, D. E., (SNLA) */
/* ***DESCRIPTION */
/* Abstract */
/* BESYNU computes N member sequences of Y Bessel functions */
/* Y/SUB(FNU+I-1)/(X), I=1,N for non-negative orders FNU and */
/* positive X. Equations of the references are implemented on */
/* small orders DNU for Y/SUB(DNU)/(X) and Y/SUB(DNU+1)/(X). */
/* Forward recursion with the three term recursion relation */
/* generates higher orders FNU+I-1, I=1,...,N. */
/* To start the recursion FNU is normalized to the interval */
/* -0.5.LE.DNU.LT.0.5. A special form of the power series is */
/* implemented on 0.LT.X.LE.X1 while the Miller algorithm for the */
/* K Bessel function in terms of the confluent hypergeometric */
/* function U(FNU+0.5,2*FNU+1,I*X) is implemented on X1.LT.X.LE.X */
/* Here I is the complex number SQRT(-1.). */
/* For X.GT.X2, the asymptotic expansion for large X is used. */
/* When FNU is a half odd integer, a special formula for */
/* DNU=-0.5 and DNU+1.0=0.5 is used to start the recursion. */
/* BESYNU assumes that a significant digit SINH(X) function is */
/* available. */
/* Description of Arguments */
/* Input */
/* X - X.GT.0.0E0 */
/* FNU - Order of initial Y function, FNU.GE.0.0E0 */
/* N - Number of members of the sequence, N.GE.1 */
/* Output */
/* Y - A vector whose first N components contain values */
/* for the sequence Y(I)=Y/SUB(FNU+I-1), I=1,N. */
/* Error Conditions */
/* Improper input arguments - a fatal error */
/* Overflow - a fatal error */
/* ***SEE ALSO BESY */
/* ***REFERENCES N. M. Temme, On the numerical evaluation of the ordinary */
/* Bessel function of the second kind, Journal of */
/* Computational Physics 21, (1976), pp. 343-350. */
/* N. M. Temme, On the numerical evaluation of the modified */
/* Bessel function of the third kind, Journal of */
/* Computational Physics 19, (1975), pp. 324-337. */
/* ***ROUTINES CALLED GAMMA, R1MACH, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 800501 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 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) */
/* 900328 Added TYPE section. (WRB) */
/* 900727 Added EXTERNAL statement. (WRB) */
/* 910408 Updated the AUTHOR and REFERENCES sections. (WRB) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE BESYNU */
/* Parameter adjustments */
--y;
/* Function Body */
/* ***FIRST EXECUTABLE STATEMENT BESYNU */
ak = r1mach_(&c__3);
tol = dmax(ak,1e-15f);
if (*x <= 0.f) {
goto L270;
}
if (*fnu < 0.f) {
goto L280;
}
if (*n < 1) {
goto L290;
}
rx = 2.f / *x;
inu = (integer) (*fnu + .5f);
dnu = *fnu - inu;
if (dabs(dnu) == .5f) {
goto L260;
}
dnu2 = 0.f;
if (dabs(dnu) < tol) {
goto L10;
}
dnu2 = dnu * dnu;
L10:
if (*x > x1) {
goto L120;
}
/* SERIES FOR X.LE.X1 */
a1 = 1.f - dnu;
a2 = dnu + 1.f;
t1 = 1.f / gamma_(&a1);
t2 = 1.f / gamma_(&a2);
if (dabs(dnu) > .1f) {
goto L40;
}
/* SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU) */
s = cc[0];
ak = 1.f;
for (k = 2; k <= 8; ++k) {
ak *= dnu2;
tm = cc[k - 1] * ak;
s += tm;
if (dabs(tm) < tol) {
goto L30;
}
/* L20: */
}
L30:
g1 = -(s + s);
goto L50;
L40:
g1 = (t1 - t2) / dnu;
L50:
g2 = t1 + t2;
smu = 1.f;
fc = 1.f / pi;
flrx = log(rx);
fmu = dnu * flrx;
tm = 0.f;
if (dnu == 0.f) {
goto L60;
}
tm = sin(dnu * hpi) / dnu;
tm = (dnu + dnu) * tm * tm;
fc = dnu / sin(dnu * pi);
if (fmu != 0.f) {
smu = sinh(fmu) / fmu;
}
L60:
f = fc * (g1 * cosh(fmu) + g2 * flrx * smu);
fx = exp(fmu);
p = fc * t1 * fx;
q = fc * t2 / fx;
g = f + tm * q;
ak = 1.f;
ck = 1.f;
bk = 1.f;
s1 = g;
s2 = p;
if (inu > 0 || *n > 1) {
goto L90;
}
if (*x < tol) {
goto L80;
}
cx = *x * *x * .25f;
L70:
f = (ak * f + p + q) / (bk - dnu2);
p /= ak - dnu;
q /= ak + dnu;
g = f + tm * q;
ck = -ck * cx / ak;
t1 = ck * g;
s1 += t1;
bk = bk + ak + ak + 1.f;
ak += 1.f;
s = dabs(t1) / (dabs(s1) + 1.f);
if (s > tol) {
goto L70;
}
L80:
y[1] = -s1;
return 0;
L90:
if (*x < tol) {
goto L110;
}
cx = *x * *x * .25f;
L100:
f = (ak * f + p + q) / (bk - dnu2);
p /= ak - dnu;
q /= ak + dnu;
g = f + tm * q;
ck = -ck * cx / ak;
t1 = ck * g;
s1 += t1;
t2 = ck * (p - ak * g);
s2 += t2;
bk = bk + ak + ak + 1.f;
ak += 1.f;
s = dabs(t1) / (dabs(s1) + 1.f) + dabs(t2) / (dabs(s2) + 1.f);
if (s > tol) {
goto L100;
}
L110:
s2 = -s2 * rx;
s1 = -s1;
goto L160;
L120:
coef = rthpi / sqrt(*x);
if (*x > x2) {
goto L210;
}
/* MILLER ALGORITHM FOR X1.LT.X.LE.X2 */
etest = cos(pi * dnu) / (pi * *x * tol);
fks = 1.f;
fhs = .25f;
fk = 0.f;
rck = 2.f;
cck = *x + *x;
rp1 = 0.f;
cp1 = 0.f;
rp2 = 1.f;
cp2 = 0.f;
k = 0;
L130:
++k;
fk += 1.f;
ak = (fhs - dnu2) / (fks + fk);
pt = fk + 1.f;
rbk = rck / pt;
cbk = cck / pt;
rpt = rp2;
cpt = cp2;
rp2 = rbk * rpt - cbk * cpt - ak * rp1;
cp2 = cbk * rpt + rbk * cpt - ak * cp1;
rp1 = rpt;
cp1 = cpt;
rb[k - 1] = rbk;
cb[k - 1] = cbk;
a[k - 1] = ak;
rck += 2.f;
fks = fks + fk + fk + 1.f;
fhs = fhs + fk + fk;
/* Computing MAX */
r__1 = dabs(rp1), r__2 = dabs(cp1);
pt = dmax(r__1,r__2);
/* Computing 2nd power */
r__1 = rp1 / pt;
/* Computing 2nd power */
r__2 = cp1 / pt;
fc = r__1 * r__1 + r__2 * r__2;
pt = pt * sqrt(fc) * fk;
if (etest > pt) {
goto L130;
}
kk = k;
rs = 1.f;
cs = 0.f;
rp1 = 0.f;
cp1 = 0.f;
rp2 = 1.f;
cp2 = 0.f;
i__1 = k;
for (i__ = 1; i__ <= i__1; ++i__) {
rpt = rp2;
cpt = cp2;
rp2 = (rb[kk - 1] * rpt - cb[kk - 1] * cpt - rp1) / a[kk - 1];
cp2 = (cb[kk - 1] * rpt + rb[kk - 1] * cpt - cp1) / a[kk - 1];
rp1 = rpt;
cp1 = cpt;
rs += rp2;
cs += cp2;
--kk;
/* L140: */
}
/* Computing MAX */
r__1 = dabs(rs), r__2 = dabs(cs);
pt = dmax(r__1,r__2);
/* Computing 2nd power */
r__1 = rs / pt;
/* Computing 2nd power */
r__2 = cs / pt;
fc = r__1 * r__1 + r__2 * r__2;
pt *= sqrt(fc);
rs1 = (rp2 * (rs / pt) + cp2 * (cs / pt)) / pt;
cs1 = (cp2 * (rs / pt) - rp2 * (cs / pt)) / pt;
fc = hpi * (dnu - .5f) - *x;
p = cos(fc);
q = sin(fc);
s1 = (cs1 * q - rs1 * p) * coef;
if (inu > 0 || *n > 1) {
goto L150;
}
y[1] = s1;
return 0;
L150:
/* Computing MAX */
r__1 = dabs(rp2), r__2 = dabs(cp2);
pt = dmax(r__1,r__2);
/* Computing 2nd power */
r__1 = rp2 / pt;
/* Computing 2nd power */
r__2 = cp2 / pt;
fc = r__1 * r__1 + r__2 * r__2;
pt *= sqrt(fc);
rpt = dnu + .5f - (rp1 * (rp2 / pt) + cp1 * (cp2 / pt)) / pt;
cpt = *x - (cp1 * (rp2 / pt) - rp1 * (cp2 / pt)) / pt;
cs2 = cs1 * cpt - rs1 * rpt;
rs2 = rpt * cs1 + rs1 * cpt;
s2 = (rs2 * q + cs2 * p) * coef / *x;
/* FORWARD RECURSION ON THE THREE TERM RECURSION RELATION */
L160:
ck = (dnu + dnu + 2.f) / *x;
if (*n == 1) {
--inu;
}
if (inu > 0) {
goto L170;
}
if (*n > 1) {
goto L190;
}
s1 = s2;
goto L190;
L170:
i__1 = inu;
for (i__ = 1; i__ <= i__1; ++i__) {
st = s2;
s2 = ck * s2 - s1;
s1 = st;
ck += rx;
/* L180: */
}
if (*n == 1) {
s1 = s2;
}
L190:
y[1] = s1;
if (*n == 1) {
return 0;
}
y[2] = s2;
if (*n == 2) {
return 0;
}
i__1 = *n;
for (i__ = 3; i__ <= i__1; ++i__) {
y[i__] = ck * y[i__ - 1] - y[i__ - 2];
ck += rx;
/* L200: */
}
return 0;
/* ASYMPTOTIC EXPANSION FOR LARGE X, X.GT.X2 */
L210:
nn = 2;
if (inu == 0 && *n == 1) {
nn = 1;
}
dnu2 = dnu + dnu;
fmu = 0.f;
if (dabs(dnu2) < tol) {
goto L220;
}
fmu = dnu2 * dnu2;
L220:
arg = *x - hpi * (dnu + .5f);
sa = sin(arg);
sb = cos(arg);
etx = *x * 8.f;
i__1 = nn;
for (k = 1; k <= i__1; ++k) {
s1 = s2;
t2 = (fmu - 1.f) / etx;
ss = t2;
relb = tol * dabs(t2);
t1 = etx;
s = 1.f;
fn = 1.f;
ak = 0.f;
for (j = 1; j <= 13; ++j) {
t1 += etx;
ak += 8.f;
fn += ak;
t2 = -t2 * (fmu - fn) / t1;
s += t2;
t1 += etx;
ak += 8.f;
fn += ak;
t2 = t2 * (fmu - fn) / t1;
ss += t2;
if (dabs(t2) <= relb) {
goto L240;
}
/* L230: */
}
L240:
s2 = coef * (s * sa + ss * sb);
fmu = fmu + dnu * 8.f + 4.f;
tb = sa;
sa = -sb;
sb = tb;
/* L250: */
}
if (nn > 1) {
goto L160;
}
s1 = s2;
goto L190;
/* FNU=HALF ODD INTEGER CASE */
L260:
coef = rthpi / sqrt(*x);
s1 = coef * sin(*x);
s2 = -coef * cos(*x);
goto L160;
L270:
xermsg_("SLATEC", "BESYNU", "X NOT GREATER THAN ZERO", &c__2, &c__1, (
ftnlen)6, (ftnlen)6, (ftnlen)23);
return 0;
L280:
xermsg_("SLATEC", "BESYNU", "FNU NOT ZERO OR POSITIVE", &c__2, &c__1, (
ftnlen)6, (ftnlen)6, (ftnlen)24);
return 0;
L290:
xermsg_("SLATEC", "BESYNU", "N NOT GREATER THAN 0", &c__2, &c__1, (ftnlen)
6, (ftnlen)6, (ftnlen)20);
return 0;
} /* besynu_ */
/* DECK SGEIR */
/* Subroutine */ int sgeir_(real *a, integer *lda, integer *n, real *v,
integer *itask, integer *ind, real *work, integer *iwork)
{
/* System generated locals */
address a__1[4], a__2[3];
integer a_dim1, a_offset, work_dim1, work_offset, i__1[4], i__2[3], i__3;
real r__1, r__2, r__3;
char ch__1[40], ch__2[27], ch__3[31];
/* Local variables */
static integer j, info;
static char xern1[8], xern2[8];
extern /* Subroutine */ int sgefa_(real *, integer *, integer *, integer *
, integer *), sgesl_(real *, integer *, integer *, integer *,
real *, integer *);
static real dnorm;
extern doublereal sasum_(integer *, real *, integer *);
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
static real xnorm;
extern doublereal r1mach_(integer *), sdsdot_(integer *, real *, real *,
integer *, real *, integer *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* Fortran I/O blocks */
static icilist io___2 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___4 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___5 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___6 = { 0, xern1, 0, "(I8)", 8, 1 };
/* ***BEGIN PROLOGUE SGEIR */
/* ***PURPOSE Solve a general system of linear equations. Iterative */
/* refinement is used to obtain an error estimate. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY D2A1 */
/* ***TYPE SINGLE PRECISION (SGEIR-S, CGEIR-C) */
/* ***KEYWORDS COMPLEX LINEAR EQUATIONS, GENERAL MATRIX, */
/* GENERAL SYSTEM OF LINEAR EQUATIONS */
/* ***AUTHOR Voorhees, E. A., (LANL) */
/* ***DESCRIPTION */
/* Subroutine SGEIR solves a general NxN system of single */
/* precision linear equations using LINPACK subroutines SGEFA and */
/* SGESL. One pass of iterative refinement is used only to obtain */
/* an estimate of the accuracy. That is, if A is an NxN real */
/* matrix and if X and B are real N-vectors, then SGEIR solves */
/* the equation */
/* A*X=B. */
/* The matrix A is first factored into upper and lower tri- */
/* angular matrices U and L using partial pivoting. These */
/* factors and the pivoting information are used to calculate */
/* the solution, X. Then the residual vector is found and */
/* used to calculate an estimate of the relative error, IND. */
/* IND estimates the accuracy of the solution only when the */
/* input matrix and the right hand side are represented */
/* exactly in the computer and does not take into account */
/* any errors in the input data. */
/* If the equation A*X=B is to be solved for more than one vector */
/* B, the factoring of A does not need to be performed again and */
/* the option to solve only (ITASK .GT. 1) will be faster for */
/* the succeeding solutions. In this case, the contents of A, */
/* LDA, N, WORK, and IWORK must not have been altered by the */
/* user following factorization (ITASK=1). IND will not be */
/* changed by SGEIR in this case. */
/* Argument Description *** */
/* A REAL(LDA,N) */
/* the doubly subscripted array with dimension (LDA,N) */
/* which contains the coefficient matrix. A is not */
/* altered by the routine. */
/* LDA INTEGER */
/* the leading dimension of the array A. LDA must be great- */
/* er than or equal to N. (terminal error message IND=-1) */
/* N INTEGER */
/* the order of the matrix A. The first N elements of */
/* the array A are the elements of the first column of */
/* matrix A. N must be greater than or equal to 1. */
/* (terminal error message IND=-2) */
/* V REAL(N) */
/* on entry, the singly subscripted array(vector) of di- */
/* mension N which contains the right hand side B of a */
/* system of simultaneous linear equations A*X=B. */
/* on return, V contains the solution vector, X . */
/* ITASK INTEGER */
/* If ITASK=1, the matrix A is factored and then the */
/* linear equation is solved. */
/* If ITASK .GT. 1, the equation is solved using the existing */
/* factored matrix A (stored in WORK). */
/* If ITASK .LT. 1, then terminal error message IND=-3 is */
/* printed. */
/* IND INTEGER */
/* GT. 0 IND is a rough estimate of the number of digits */
/* of accuracy in the solution, X. IND=75 means */
/* that the solution vector X is zero. */
/* LT. 0 see error message corresponding to IND below. */
/* WORK REAL(N*(N+1)) */
/* a singly subscripted array of dimension at least N*(N+1). */
/* IWORK INTEGER(N) */
/* a singly subscripted array of dimension at least N. */
/* Error Messages Printed *** */
/* IND=-1 terminal N is greater than LDA. */
/* IND=-2 terminal N is less than one. */
/* IND=-3 terminal ITASK is less than one. */
/* IND=-4 terminal The matrix A is computationally singular. */
/* A solution has not been computed. */
/* IND=-10 warning The solution has no apparent significance. */
/* The solution may be inaccurate or the matrix */
/* A may be poorly scaled. */
/* Note- The above terminal(*fatal*) error messages are */
/* designed to be handled by XERMSG in which */
/* LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 */
/* for warning error messages from XERMSG. Unless */
/* the user provides otherwise, an error message */
/* will be printed followed by an abort. */
/* ***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. */
/* Stewart, LINPACK Users' Guide, SIAM, 1979. */
/* ***ROUTINES CALLED R1MACH, SASUM, SCOPY, SDSDOT, SGEFA, SGESL, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 800430 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890831 Modified array declarations. (WRB) */
/* 890831 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* 900510 Convert XERRWV calls to XERMSG calls. (RWC) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE SGEIR */
/* ***FIRST EXECUTABLE STATEMENT SGEIR */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
work_dim1 = *n;
work_offset = 1 + work_dim1;
work -= work_offset;
--v;
--iwork;
/* Function Body */
if (*lda < *n) {
*ind = -1;
s_wsfi(&io___2);
do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___4);
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 6, a__1[0] = "LDA = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 18, a__1[2] = " IS LESS THAN N = ";
i__1[3] = 8, a__1[3] = xern2;
s_cat(ch__1, a__1, i__1, &c__4, (ftnlen)40);
xermsg_("SLATEC", "SGEIR", ch__1, &c_n1, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)40);
return 0;
}
if (*n <= 0) {
*ind = -2;
s_wsfi(&io___5);
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 4, a__2[0] = "N = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 15, a__2[2] = " IS LESS THAN 1";
s_cat(ch__2, a__2, i__2, &c__3, (ftnlen)27);
xermsg_("SLATEC", "SGEIR", ch__2, &c_n2, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)27);
return 0;
}
if (*itask < 1) {
*ind = -3;
s_wsfi(&io___6);
do_fio(&c__1, (char *)&(*itask), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 8, a__2[0] = "ITASK = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 15, a__2[2] = " IS LESS THAN 1";
s_cat(ch__3, a__2, i__2, &c__3, (ftnlen)31);
xermsg_("SLATEC", "SGEIR", ch__3, &c_n3, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)31);
return 0;
}
if (*itask == 1) {
/* MOVE MATRIX A TO WORK */
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
scopy_(n, &a[j * a_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &
c__1);
/* L10: */
}
/* FACTOR MATRIX A INTO LU */
sgefa_(&work[work_offset], n, n, &iwork[1], &info);
/* CHECK FOR COMPUTATIONALLY SINGULAR MATRIX */
if (info != 0) {
*ind = -4;
xermsg_("SLATEC", "SGEIR", "SINGULAR MATRIX A - NO SOLUTION", &
c_n4, &c__1, (ftnlen)6, (ftnlen)5, (ftnlen)31);
return 0;
}
}
/* SOLVE WHEN FACTORING COMPLETE */
/* MOVE VECTOR B TO WORK */
scopy_(n, &v[1], &c__1, &work[(*n + 1) * work_dim1 + 1], &c__1);
sgesl_(&work[work_offset], n, n, &iwork[1], &v[1], &c__0);
/* FORM NORM OF X0 */
xnorm = sasum_(n, &v[1], &c__1);
if (xnorm == 0.f) {
*ind = 75;
return 0;
}
/* COMPUTE RESIDUAL */
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
r__1 = -work[j + (*n + 1) * work_dim1];
work[j + (*n + 1) * work_dim1] = sdsdot_(n, &r__1, &a[j + a_dim1],
lda, &v[1], &c__1);
/* L40: */
}
/* SOLVE A*DELTA=R */
sgesl_(&work[work_offset], n, n, &iwork[1], &work[(*n + 1) * work_dim1 +
1], &c__0);
/* FORM NORM OF DELTA */
dnorm = sasum_(n, &work[(*n + 1) * work_dim1 + 1], &c__1);
/* COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) */
/* AND CHECK FOR IND GREATER THAN ZERO */
/* Computing MAX */
r__2 = r1mach_(&c__4), r__3 = dnorm / xnorm;
r__1 = dmax(r__2,r__3);
*ind = -r_lg10(&r__1);
if (*ind <= 0) {
*ind = -10;
xermsg_("SLATEC", "SGEIR", "SOLUTION MAY HAVE NO SIGNIFICANCE", &
c_n10, &c__0, (ftnlen)6, (ftnlen)5, (ftnlen)33);
}
return 0;
} /* sgeir_ */
/* 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_ */
/* DECK CNBIR */
/* Subroutine */ int cnbir_(complex *abe, integer *lda, integer *n, integer *
ml, integer *mu, complex *v, integer *itask, integer *ind, complex *
work, integer *iwork)
{
/* System generated locals */
address a__1[4], a__2[3];
integer abe_dim1, abe_offset, work_dim1, work_offset, i__1[4], i__2[3],
i__3, i__4, i__5;
real r__1, r__2, r__3;
complex q__1, q__2;
char ch__1[40], ch__2[27], ch__3[31], ch__4[29];
/* Local variables */
static integer j, k, l, m, nc, kk, info;
static char xern1[8], xern2[8];
extern /* Subroutine */ int cnbfa_(complex *, integer *, integer *,
integer *, integer *, integer *, integer *), cnbsl_(complex *,
integer *, integer *, integer *, integer *, integer *, complex *,
integer *), ccopy_(integer *, complex *, integer *, complex *,
integer *);
static real dnorm, xnorm;
extern doublereal r1mach_(integer *);
extern /* Complex */ void cdcdot_(complex *, integer *, complex *,
complex *, integer *, complex *, integer *);
extern doublereal scasum_(integer *, complex *, integer *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* Fortran I/O blocks */
static icilist io___2 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___4 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___5 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___6 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___7 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___8 = { 0, xern1, 0, "(I8)", 8, 1 };
/* ***BEGIN PROLOGUE CNBIR */
/* ***PURPOSE Solve a general nonsymmetric banded system of linear */
/* equations. Iterative refinement is used to obtain an error */
/* estimate. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY D2C2 */
/* ***TYPE COMPLEX (SNBIR-S, CNBIR-C) */
/* ***KEYWORDS BANDED, LINEAR EQUATIONS, NONSYMMETRIC */
/* ***AUTHOR Voorhees, E. A., (LANL) */
/* ***DESCRIPTION */
/* Subroutine CNBIR solves a general nonsymmetric banded NxN */
/* system of single precision complex linear equations using */
/* SLATEC subroutines CNBFA and CNBSL. These are adaptations */
/* of the LINPACK subroutines CGBFA and CGBSL which require */
/* a different format for storing the matrix elements. */
/* One pass of iterative refinement is used only to obtain an */
/* estimate of the accuracy. If A is an NxN complex banded */
/* matrix and if X and B are complex N-vectors, then CNBIR */
/* solves the equation */
/* A*X=B. */
/* A band matrix is a matrix whose nonzero elements are all */
/* fairly near the main diagonal, specifically A(I,J) = 0 */
/* if I-J is greater than ML or J-I is greater than */
/* MU . The integers ML and MU are called the lower and upper */
/* band widths and M = ML+MU+1 is the total band width. */
/* CNBIR uses less time and storage than the corresponding */
/* program for general matrices (CGEIR) if 2*ML+MU .LT. N . */
/* The matrix A is first factored into upper and lower tri- */
/* angular matrices U and L using partial pivoting. These */
/* factors and the pivoting information are used to find the */
/* solution vector X . Then the residual vector is found and used */
/* to calculate an estimate of the relative error, IND . IND esti- */
/* mates the accuracy of the solution only when the input matrix */
/* and the right hand side are represented exactly in the computer */
/* and does not take into account any errors in the input data. */
/* If the equation A*X=B is to be solved for more than one vector */
/* B, the factoring of A does not need to be performed again and */
/* the option to only solve (ITASK .GT. 1) will be faster for */
/* the succeeding solutions. In this case, the contents of A, LDA, */
/* N, WORK and IWORK must not have been altered by the user follow- */
/* ing factorization (ITASK=1). IND will not be changed by CNBIR */
/* in this case. */
/* Band Storage */
/* If A is a band matrix, the following program segment */
/* will set up the input. */
/* ML = (band width below the diagonal) */
/* MU = (band width above the diagonal) */
/* DO 20 I = 1, N */
/* J1 = MAX(1, I-ML) */
/* J2 = MIN(N, I+MU) */
/* DO 10 J = J1, J2 */
/* K = J - I + ML + 1 */
/* ABE(I,K) = A(I,J) */
/* 10 CONTINUE */
/* 20 CONTINUE */
/* This uses columns 1 through ML+MU+1 of ABE . */
/* Example: If the original matrix is */
/* 11 12 13 0 0 0 */
/* 21 22 23 24 0 0 */
/* 0 32 33 34 35 0 */
/* 0 0 43 44 45 46 */
/* 0 0 0 54 55 56 */
/* 0 0 0 0 65 66 */
/* then N = 6, ML = 1, MU = 2, LDA .GE. 5 and ABE should contain */
/* * 11 12 13 , * = not used */
/* 21 22 23 24 */
/* 32 33 34 35 */
/* 43 44 45 46 */
/* 54 55 56 * */
/* 65 66 * * */
/* Argument Description *** */
/* ABE COMPLEX(LDA,MM) */
/* on entry, contains the matrix in band storage as */
/* described above. MM must not be less than M = */
/* ML+MU+1 . The user is cautioned to dimension ABE */
/* with care since MM is not an argument and cannot */
/* be checked by CNBIR. The rows of the original */
/* matrix are stored in the rows of ABE and the */
/* diagonals of the original matrix are stored in */
/* columns 1 through ML+MU+1 of ABE . ABE is */
/* not altered by the program. */
/* LDA INTEGER */
/* the leading dimension of array ABE. LDA must be great- */
/* er than or equal to N. (terminal error message IND=-1) */
/* N INTEGER */
/* the order of the matrix A. N must be greater */
/* than or equal to 1 . (terminal error message IND=-2) */
/* ML INTEGER */
/* the number of diagonals below the main diagonal. */
/* ML must not be less than zero nor greater than or */
/* equal to N . (terminal error message IND=-5) */
/* MU INTEGER */
/* the number of diagonals above the main diagonal. */
/* MU must not be less than zero nor greater than or */
/* equal to N . (terminal error message IND=-6) */
/* V COMPLEX(N) */
/* on entry, the singly subscripted array(vector) of di- */
/* mension N which contains the right hand side B of a */
/* system of simultaneous linear equations A*X=B. */
/* on return, V contains the solution vector, X . */
/* ITASK INTEGER */
/* if ITASK=1, the matrix A is factored and then the */
/* linear equation is solved. */
/* if ITASK .GT. 1, the equation is solved using the existing */
/* factored matrix A and IWORK. */
/* if ITASK .LT. 1, then terminal error message IND=-3 is */
/* printed. */
/* IND INTEGER */
/* GT. 0 IND is a rough estimate of the number of digits */
/* of accuracy in the solution, X . IND=75 means */
/* that the solution vector X is zero. */
/* LT. 0 see error message corresponding to IND below. */
/* WORK COMPLEX(N*(NC+1)) */
/* a singly subscripted array of dimension at least */
/* N*(NC+1) where NC = 2*ML+MU+1 . */
/* IWORK INTEGER(N) */
/* a singly subscripted array of dimension at least N. */
/* Error Messages Printed *** */
/* IND=-1 terminal N is greater than LDA. */
/* IND=-2 terminal N is less than 1. */
/* IND=-3 terminal ITASK is less than 1. */
/* IND=-4 terminal The matrix A is computationally singular. */
/* A solution has not been computed. */
/* IND=-5 terminal ML is less than zero or is greater than */
/* or equal to N . */
/* IND=-6 terminal MU is less than zero or is greater than */
/* or equal to N . */
/* IND=-10 warning The solution has no apparent significance. */
/* The solution may be inaccurate or the matrix */
/* A may be poorly scaled. */
/* NOTE- The above terminal(*fatal*) error messages are */
/* designed to be handled by XERMSG in which */
/* LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 */
/* for warning error messages from XERMSG. Unless */
/* the user provides otherwise, an error message */
/* will be printed followed by an abort. */
/* ***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. */
/* Stewart, LINPACK Users' Guide, SIAM, 1979. */
/* ***ROUTINES CALLED CCOPY, CDCDOT, CNBFA, CNBSL, R1MACH, SCASUM, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 800819 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890831 Modified array declarations. (WRB) */
/* 890831 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* 900510 Convert XERRWV calls to XERMSG calls, cvt GOTO's to */
/* IF-THEN-ELSE. (RWC) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE CNBIR */
/* ***FIRST EXECUTABLE STATEMENT CNBIR */
/* Parameter adjustments */
abe_dim1 = *lda;
abe_offset = 1 + abe_dim1;
abe -= abe_offset;
work_dim1 = *n;
work_offset = 1 + work_dim1;
work -= work_offset;
--v;
--iwork;
/* Function Body */
if (*lda < *n) {
*ind = -1;
s_wsfi(&io___2);
do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___4);
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 6, a__1[0] = "LDA = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 18, a__1[2] = " IS LESS THAN N = ";
i__1[3] = 8, a__1[3] = xern2;
s_cat(ch__1, a__1, i__1, &c__4, (ftnlen)40);
xermsg_("SLATEC", "CNBIR", ch__1, &c_n1, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)40);
return 0;
}
if (*n <= 0) {
*ind = -2;
s_wsfi(&io___5);
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 4, a__2[0] = "N = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 15, a__2[2] = " IS LESS THAN 1";
s_cat(ch__2, a__2, i__2, &c__3, (ftnlen)27);
xermsg_("SLATEC", "CNBIR", ch__2, &c_n2, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)27);
return 0;
}
if (*itask < 1) {
*ind = -3;
s_wsfi(&io___6);
do_fio(&c__1, (char *)&(*itask), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 8, a__2[0] = "ITASK = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 15, a__2[2] = " IS LESS THAN 1";
s_cat(ch__3, a__2, i__2, &c__3, (ftnlen)31);
xermsg_("SLATEC", "CNBIR", ch__3, &c_n3, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)31);
return 0;
}
if (*ml < 0 || *ml >= *n) {
*ind = -5;
s_wsfi(&io___7);
do_fio(&c__1, (char *)&(*ml), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 5, a__2[0] = "ML = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 16, a__2[2] = " IS OUT OF RANGE";
s_cat(ch__4, a__2, i__2, &c__3, (ftnlen)29);
xermsg_("SLATEC", "CNBIR", ch__4, &c_n5, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)29);
return 0;
}
if (*mu < 0 || *mu >= *n) {
*ind = -6;
s_wsfi(&io___8);
do_fio(&c__1, (char *)&(*mu), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 5, a__2[0] = "MU = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 16, a__2[2] = " IS OUT OF RANGE";
s_cat(ch__4, a__2, i__2, &c__3, (ftnlen)29);
xermsg_("SLATEC", "CNBIR", ch__4, &c_n6, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)29);
return 0;
}
nc = (*ml << 1) + *mu + 1;
if (*itask == 1) {
/* MOVE MATRIX ABE TO WORK */
m = *ml + *mu + 1;
i__3 = m;
for (j = 1; j <= i__3; ++j) {
ccopy_(n, &abe[j * abe_dim1 + 1], &c__1, &work[j * work_dim1 + 1],
&c__1);
/* L10: */
}
/* FACTOR MATRIX A INTO LU */
cnbfa_(&work[work_offset], n, n, ml, mu, &iwork[1], &info);
/* CHECK FOR COMPUTATIONALLY SINGULAR MATRIX */
if (info != 0) {
*ind = -4;
xermsg_("SLATEC", "CNBIR", "SINGULAR MATRIX A - NO SOLUTION", &
c_n4, &c__1, (ftnlen)6, (ftnlen)5, (ftnlen)31);
return 0;
}
}
/* SOLVE WHEN FACTORING COMPLETE */
/* MOVE VECTOR B TO WORK */
ccopy_(n, &v[1], &c__1, &work[(nc + 1) * work_dim1 + 1], &c__1);
cnbsl_(&work[work_offset], n, n, ml, mu, &iwork[1], &v[1], &c__0);
/* FORM NORM OF X0 */
xnorm = scasum_(n, &v[1], &c__1);
if (xnorm == 0.f) {
*ind = 75;
return 0;
}
/* COMPUTE RESIDUAL */
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
/* Computing MAX */
i__4 = 1, i__5 = *ml + 2 - j;
k = max(i__4,i__5);
/* Computing MAX */
i__4 = 1, i__5 = j - *ml;
kk = max(i__4,i__5);
/* Computing MIN */
i__4 = j - 1;
/* Computing MIN */
i__5 = *n - j;
l = min(i__4,*ml) + min(i__5,*mu) + 1;
i__4 = j + (nc + 1) * work_dim1;
i__5 = j + (nc + 1) * work_dim1;
q__2.r = -work[i__5].r, q__2.i = -work[i__5].i;
cdcdot_(&q__1, &l, &q__2, &abe[j + k * abe_dim1], lda, &v[kk], &c__1);
work[i__4].r = q__1.r, work[i__4].i = q__1.i;
/* L40: */
}
/* SOLVE A*DELTA=R */
cnbsl_(&work[work_offset], n, n, ml, mu, &iwork[1], &work[(nc + 1) *
work_dim1 + 1], &c__0);
/* FORM NORM OF DELTA */
dnorm = scasum_(n, &work[(nc + 1) * work_dim1 + 1], &c__1);
/* COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) */
/* AND CHECK FOR IND GREATER THAN ZERO */
/* Computing MAX */
r__2 = r1mach_(&c__4), r__3 = dnorm / xnorm;
r__1 = dmax(r__2,r__3);
*ind = -r_lg10(&r__1);
if (*ind <= 0) {
*ind = -10;
xermsg_("SLATEC", "CNBIR", "SOLUTION MAY HAVE NO SIGNIFICANCE", &
c_n10, &c__0, (ftnlen)6, (ftnlen)5, (ftnlen)33);
}
return 0;
} /* cnbir_ */
/* DECK BI */
doublereal bi_(real *x)
{
/* Initialized data */
static real bifcs[9] = { -.01673021647198664948f,.1025233583424944561f,
.00170830925073815165f,1.186254546774468e-5f,4.493290701779e-8f,
1.0698207143e-10f,1.7480643e-13f,2.081e-16f,1.8e-19f };
static real bigcs[8] = { .02246622324857452f,.03736477545301955f,
4.4476218957212e-4f,2.47080756363e-6f,7.91913533e-9f,
1.649807e-11f,2.411e-14f,2e-17f };
static real bif2cs[10] = { .09984572693816041f,.478624977863005538f,
.0251552119604330118f,5.820693885232645e-4f,7.4997659644377e-6f,
6.13460287034e-8f,3.462753885e-10f,1.428891e-12f,4.4962e-15f,
1.11e-17f };
static real big2cs[10] = { .03330566214551434f,.161309215123197068f,
.0063190073096134286f,1.187904568162517e-4f,1.30453458862e-6f,
9.3741259955e-9f,4.74580188e-11f,1.783107e-13f,5.167e-16f,
1.1e-18f };
static logical first = TRUE_;
/* System generated locals */
real ret_val, r__1;
doublereal d__1;
/* Local variables */
static real z__, xm;
extern doublereal bie_(real *);
static real eta;
static integer nbif, nbig;
static real xmax;
static integer nbif2, nbig2;
static real x3sml, theta;
extern doublereal csevl_(real *, real *, integer *);
extern integer inits_(real *, integer *, real *);
extern doublereal r1mach_(integer *);
extern /* Subroutine */ int r9aimp_(real *, real *, real *), xermsg_(char
*, char *, char *, integer *, integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE BI */
/* ***PURPOSE Evaluate the Bairy function (the Airy function of the */
/* second kind). */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C10D */
/* ***TYPE SINGLE PRECISION (BI-S, DBI-D) */
/* ***KEYWORDS BAIRY FUNCTION, FNLIB, SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* BI(X) calculates the Airy function of the second kind for real */
/* argument X. */
/* Series for BIF on the interval -1.00000D+00 to 1.00000D+00 */
/* with weighted error 1.88E-19 */
/* log weighted error 18.72 */
/* significant figures required 17.74 */
/* decimal places required 19.20 */
/* Series for BIG on the interval -1.00000D+00 to 1.00000D+00 */
/* with weighted error 2.61E-17 */
/* log weighted error 16.58 */
/* significant figures required 15.17 */
/* decimal places required 17.03 */
/* Series for BIF2 on the interval 1.00000D+00 to 8.00000D+00 */
/* with weighted error 1.11E-17 */
/* log weighted error 16.95 */
/* approx significant figures required 16.5 */
/* decimal places required 17.45 */
/* Series for BIG2 on the interval 1.00000D+00 to 8.00000D+00 */
/* with weighted error 1.19E-18 */
/* log weighted error 17.92 */
/* approx significant figures required 17.2 */
/* decimal places required 18.42 */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED BIE, 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) */
/* ***END PROLOGUE BI */
/* ***FIRST EXECUTABLE STATEMENT BI */
if (first) {
eta = r1mach_(&c__3) * .1f;
nbif = inits_(bifcs, &c__9, &eta);
nbig = inits_(bigcs, &c__8, &eta);
nbif2 = inits_(bif2cs, &c__10, &eta);
nbig2 = inits_(big2cs, &c__10, &eta);
d__1 = (doublereal) eta;
x3sml = pow_dd(&d__1, &c_b7);
d__1 = (doublereal) (log(r1mach_(&c__2)) * 1.5f);
xmax = pow_dd(&d__1, &c_b9);
}
first = FALSE_;
if (*x >= -1.f) {
goto L20;
}
r9aimp_(x, &xm, &theta);
ret_val = xm * sin(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__, bifcs, &nbif) + .625f + *x * (csevl_(&z__, bigcs, &
nbig) + .4375f);
return ret_val;
L30:
if (*x > 2.f) {
goto L40;
}
/* Computing 3rd power */
r__1 = *x;
z__ = (r__1 * (r__1 * r__1) * 2.f - 9.f) / 7.f;
ret_val = csevl_(&z__, bif2cs, &nbif2) + 1.125f + *x * (csevl_(&z__,
big2cs, &nbig2) + .625f);
return ret_val;
L40:
if (*x > xmax) {
xermsg_("SLATEC", "BI", "X SO BIG THAT BI OVERFLOWS", &c__1, &c__2, (
ftnlen)6, (ftnlen)2, (ftnlen)26);
}
ret_val = bie_(x) * exp(*x * 2.f * sqrt(*x) / 3.f);
return ret_val;
} /* bi_ */
/* DECK LSOD */
/* Subroutine */ int lsod_(S_fp f, integer *neq, real *t, real *y, real *tout,
real *rtol, real *atol, integer *idid, real *ypout, real *yh, real *
yh1, real *ewt, real *savf, real *acor, real *wm, integer *iwm, U_fp
jac, logical *intout, real *tstop, real *tolfac, real *delsgn, real *
rpar, integer *ipar)
{
/* Initialized data */
static integer maxnum = 500;
/* System generated locals */
address a__1[2], a__2[7], a__3[6], a__4[8], a__5[3], a__6[5];
integer yh_dim1, yh_offset, i__1[2], i__2, i__3[7], i__4[6], i__5[8],
i__6[3], i__7[5];
real r__1, r__2, r__3, r__4;
char ch__1[107], ch__2[215], ch__3[207], ch__4[111], ch__5[127], ch__6[
158];
/* Local variables */
static integer k, l;
static real ha, dt, big, del, tol;
extern /* Subroutine */ int stod_(integer *, real *, real *, integer *,
real *, real *, real *, real *, real *, integer *, S_fp, U_fp,
real *, integer *);
static integer ltol;
static char xern1[8], xern3[16], xern4[16];
extern /* Subroutine */ int intyd_(real *, integer *, real *, integer *,
real *, integer *);
extern doublereal r1mach_(integer *);
static real absdel;
static integer intflg, natolp;
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen), hstart_(S_fp, integer *, real
*, real *, real *, real *, real *, integer *, real *, real *,
real *, real *, real *, real *, real *, integer *, real *);
static integer nrtolp;
extern doublereal vnwrms_(integer *, real *, real *);
/* Fortran I/O blocks */
static icilist io___3 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___7 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___9 = { 0, xern3, 0, "(1PE15.6)", 16, 1 };
static icilist io___10 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___11 = { 0, xern3, 0, "(1PE15.6)", 16, 1 };
static icilist io___12 = { 0, xern3, 0, "(1PE15.6)", 16, 1 };
static icilist io___14 = { 0, xern4, 0, "(1PE15.6)", 16, 1 };
static icilist io___15 = { 0, xern3, 0, "(1PE15.6)", 16, 1 };
static icilist io___16 = { 0, xern3, 0, "(1PE15.6)", 16, 1 };
static icilist io___17 = { 0, xern4, 0, "(1PE15.6)", 16, 1 };
static icilist io___18 = { 0, xern3, 0, "(1PE15.6)", 16, 1 };
/* ***BEGIN PROLOGUE LSOD */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to DEBDF */
/* ***LIBRARY SLATEC */
/* ***TYPE SINGLE PRECISION (LSOD-S, DLSOD-D) */
/* ***AUTHOR (UNKNOWN) */
/* ***DESCRIPTION */
/* DEBDF merely allocates storage for LSOD to relieve the user of */
/* the inconvenience of a long call list. Consequently LSOD is used */
/* as described in the comments for DEBDF . */
/* ***SEE ALSO DEBDF */
/* ***ROUTINES CALLED HSTART, INTYD, R1MACH, STOD, VNWRMS, XERMSG */
/* ***COMMON BLOCKS DEBDF1 */
/* ***REVISION HISTORY (YYMMDD) */
/* 800901 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890831 Modified array declarations. (WRB) */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900328 Added TYPE section. (WRB) */
/* 900510 Convert XERRWV calls to XERMSG calls. (RWC) */
/* ***END PROLOGUE LSOD */
/* ....................................................................... */
/* THE EXPENSE OF SOLVING THE PROBLEM IS MONITORED BY COUNTING THE */
/* NUMBER OF STEPS ATTEMPTED. WHEN THIS EXCEEDS MAXNUM, THE COUNTER */
/* IS RESET TO ZERO AND THE USER IS INFORMED ABOUT POSSIBLE EXCESSIVE */
/* WORK. */
/* Parameter adjustments */
yh_dim1 = *neq;
yh_offset = 1 + yh_dim1;
yh -= yh_offset;
--y;
--rtol;
--atol;
--ypout;
--yh1;
--ewt;
--savf;
--acor;
--wm;
--iwm;
--rpar;
--ipar;
/* Function Body */
/* ....................................................................... */
/* ***FIRST EXECUTABLE STATEMENT LSOD */
if (debdf1_1.ibegin == 0) {
/* ON THE FIRST CALL , PERFORM INITIALIZATION -- */
/* DEFINE THE MACHINE UNIT ROUNDOFF QUANTITY U BY CALLING THE */
/* FUNCTION ROUTINE R1MACH. THE USER MUST MAKE SURE THAT THE */
/* VALUES SET IN R1MACH ARE RELEVANT TO THE COMPUTER BEING USED. */
debdf1_1.u = r1mach_(&c__4);
/* -- SET ASSOCIATED MACHINE DEPENDENT PARAMETER */
wm[1] = sqrt(debdf1_1.u);
/* -- SET TERMINATION FLAG */
debdf1_1.iquit = 0;
/* -- SET INITIALIZATION INDICATOR */
debdf1_1.init = 0;
/* -- SET COUNTER FOR ATTEMPTED STEPS */
debdf1_1.ksteps = 0;
/* -- SET INDICATOR FOR INTERMEDIATE-OUTPUT */
*intout = FALSE_;
/* -- SET START INDICATOR FOR STOD CODE */
debdf1_1.jstart = 0;
/* -- SET BDF METHOD INDICATOR */
debdf1_1.meth = 2;
/* -- SET MAXIMUM ORDER FOR BDF METHOD */
debdf1_1.maxord = 5;
/* -- SET ITERATION MATRIX INDICATOR */
if (debdf1_1.ijac == 0 && debdf1_1.iband == 0) {
debdf1_1.miter = 2;
}
if (debdf1_1.ijac == 1 && debdf1_1.iband == 0) {
debdf1_1.miter = 1;
}
if (debdf1_1.ijac == 0 && debdf1_1.iband == 1) {
debdf1_1.miter = 5;
}
if (debdf1_1.ijac == 1 && debdf1_1.iband == 1) {
debdf1_1.miter = 4;
}
/* -- SET OTHER NECESSARY ITEMS IN COMMON BLOCK */
debdf1_1.n = *neq;
debdf1_1.nst = 0;
debdf1_1.nje = 0;
debdf1_1.hmxi = 0.f;
debdf1_1.nq = 1;
debdf1_1.h__ = 1.f;
/* -- RESET IBEGIN FOR SUBSEQUENT CALLS */
debdf1_1.ibegin = 1;
}
/* ....................................................................... */
/* CHECK VALIDITY OF INPUT PARAMETERS ON EACH ENTRY */
if (*neq < 1) {
s_wsfi(&io___3);
do_fio(&c__1, (char *)&(*neq), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 99, a__1[0] = "IN DEBDF, THE NUMBER OF EQUATIONS MUST BE A"
" POSITIVE INTEGER.$$YOU HAVE CALLED THE CODE WITH NEQ = ";
i__1[1] = 8, a__1[1] = xern1;
s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)107);
xermsg_("SLATEC", "LSOD", ch__1, &c__6, &c__1, (ftnlen)6, (ftnlen)4, (
ftnlen)107);
*idid = -33;
}
nrtolp = 0;
natolp = 0;
i__2 = *neq;
for (k = 1; k <= i__2; ++k) {
if (nrtolp <= 0) {
if (rtol[k] < 0.f) {
s_wsfi(&io___7);
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___9);
do_fio(&c__1, (char *)&rtol[k], (ftnlen)sizeof(real));
e_wsfi();
/* Writing concatenation */
i__3[0] = 98, a__2[0] = "IN DEBDF, THE RELATIVE ERROR TOLERA"
"NCES MUST BE NON-NEGATIVE.$$YOU HAVE CALLED THE CODE"
" WITH RTOL(";
i__3[1] = 8, a__2[1] = xern1;
i__3[2] = 4, a__2[2] = ") = ";
i__3[3] = 16, a__2[3] = xern3;
i__3[4] = 9, a__2[4] = "$$IN THE ";
i__3[5] = 44, a__2[5] = "CASE OF VECTOR ERROR TOLERANCES, NO"
" FURTHER ";
i__3[6] = 36, a__2[6] = "CHECKING OF RTOL COMPONENTS IS DONE."
;
s_cat(ch__2, a__2, i__3, &c__7, (ftnlen)215);
xermsg_("SLATEC", "LSOD", ch__2, &c__7, &c__1, (ftnlen)6, (
ftnlen)4, (ftnlen)215);
*idid = -33;
if (natolp > 0) {
goto L70;
}
nrtolp = 1;
} else if (natolp > 0) {
goto L50;
}
}
if (atol[k] < 0.f) {
s_wsfi(&io___10);
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___11);
do_fio(&c__1, (char *)&atol[k], (ftnlen)sizeof(real));
e_wsfi();
/* Writing concatenation */
i__4[0] = 98, a__3[0] = "IN DEBDF, THE ABSOLUTE ERROR TOLERANCES"
" MUST BE NON-NEGATIVE.$$YOU HAVE CALLED THE CODE WITH AT"
"OL(";
i__4[1] = 8, a__3[1] = xern1;
i__4[2] = 4, a__3[2] = ") = ";
i__4[3] = 16, a__3[3] = xern3;
i__4[4] = 53, a__3[4] = "$$IN THE CASE OF VECTOR ERROR TOLERANCE"
"S, NO FURTHER ";
i__4[5] = 36, a__3[5] = "CHECKING OF ATOL COMPONENTS IS DONE.";
s_cat(ch__2, a__3, i__4, &c__6, (ftnlen)215);
xermsg_("SLATEC", "LSOD", ch__2, &c__8, &c__1, (ftnlen)6, (ftnlen)
4, (ftnlen)215);
*idid = -33;
if (nrtolp > 0) {
goto L70;
}
natolp = 1;
}
L50:
if (debdf1_1.itol == 0) {
goto L70;
}
/* L60: */
}
L70:
if (debdf1_1.itstop == 1) {
r__3 = *tout - *t;
r__4 = *tstop - *t;
if (r_sign(&c_b41, &r__3) != r_sign(&c_b41, &r__4) || (r__1 = *tout -
*t, dabs(r__1)) > (r__2 = *tstop - *t, dabs(r__2))) {
s_wsfi(&io___12);
do_fio(&c__1, (char *)&(*tout), (ftnlen)sizeof(real));
e_wsfi();
s_wsfi(&io___14);
do_fio(&c__1, (char *)&(*tstop), (ftnlen)sizeof(real));
e_wsfi();
/* Writing concatenation */
i__5[0] = 47, a__4[0] = "IN DEBDF, YOU HAVE CALLED THE CODE WITH"
" TOUT = ";
i__5[1] = 16, a__4[1] = xern3;
i__5[2] = 15, a__4[2] = "$$BUT YOU HAVE ";
i__5[3] = 51, a__4[3] = "ALSO TOLD THE CODE NOT TO INTEGRATE PAS"
"T THE POINT ";
i__5[4] = 8, a__4[4] = "TSTOP = ";
i__5[5] = 16, a__4[5] = xern4;
i__5[6] = 26, a__4[6] = " BY SETTING INFO(4) = 1. ";
i__5[7] = 28, a__4[7] = "THESE INSTRUCTIONS CONFLICT.";
s_cat(ch__3, a__4, i__5, &c__8, (ftnlen)207);
xermsg_("SLATEC", "LSOD", ch__3, &c__14, &c__1, (ftnlen)6, (
ftnlen)4, (ftnlen)207);
*idid = -33;
}
}
/* CHECK SOME CONTINUATION POSSIBILITIES */
if (debdf1_1.init != 0) {
if (*t == *tout) {
s_wsfi(&io___15);
do_fio(&c__1, (char *)&(*t), (ftnlen)sizeof(real));
e_wsfi();
/* Writing concatenation */
i__6[0] = 51, a__5[0] = "IN DEBDF, YOU HAVE CALLED THE CODE WITH"
" T = TOUT = ";
i__6[1] = 16, a__5[1] = xern3;
i__6[2] = 44, a__5[2] = " THIS IS NOT ALLOWED ON CONTINUATION C"
"ALLS.";
s_cat(ch__4, a__5, i__6, &c__3, (ftnlen)111);
xermsg_("SLATEC", "LSOD", ch__4, &c__9, &c__1, (ftnlen)6, (ftnlen)
4, (ftnlen)111);
*idid = -33;
}
if (*t != debdf1_1.told) {
s_wsfi(&io___16);
do_fio(&c__1, (char *)&debdf1_1.told, (ftnlen)sizeof(real));
e_wsfi();
s_wsfi(&io___17);
do_fio(&c__1, (char *)&(*t), (ftnlen)sizeof(real));
e_wsfi();
/* Writing concatenation */
i__7[0] = 47, a__6[0] = "IN DEBDF, YOU HAVE CHANGED THE VALUE OF"
" T FROM ";
i__7[1] = 16, a__6[1] = xern3;
i__7[2] = 4, a__6[2] = " TO ";
i__7[3] = 16, a__6[3] = xern4;
i__7[4] = 44, a__6[4] = " THIS IS NOT ALLOWED ON CONTINUATION C"
"ALLS.";
s_cat(ch__5, a__6, i__7, &c__5, (ftnlen)127);
xermsg_("SLATEC", "LSOD", ch__5, &c__10, &c__1, (ftnlen)6, (
ftnlen)4, (ftnlen)127);
*idid = -33;
}
if (debdf1_1.init != 1) {
if (*delsgn * (*tout - *t) < 0.f) {
s_wsfi(&io___18);
do_fio(&c__1, (char *)&(*tout), (ftnlen)sizeof(real));
e_wsfi();
/* Writing concatenation */
i__7[0] = 42, a__6[0] = "IN DEBDF, BY CALLING THE CODE WITH "
"TOUT = ";
i__7[1] = 16, a__6[1] = xern3;
i__7[2] = 34, a__6[2] = " YOU ARE ATTEMPTING TO CHANGE THE ";
i__7[3] = 27, a__6[3] = "DIRECTION OF INTEGRATION.$$";
i__7[4] = 39, a__6[4] = "THIS IS NOT ALLOWED WITHOUT RESTART"
"ING.";
s_cat(ch__6, a__6, i__7, &c__5, (ftnlen)158);
xermsg_("SLATEC", "LSOD", ch__6, &c__11, &c__1, (ftnlen)6, (
ftnlen)4, (ftnlen)158);
*idid = -33;
}
}
}
if (*idid == -33) {
if (debdf1_1.iquit != -33) {
/* INVALID INPUT DETECTED */
debdf1_1.iquit = -33;
debdf1_1.ibegin = -1;
} else {
xermsg_("SLATEC", "LSOD", "IN DEBDF, INVALID INPUT WAS DETECTED "
"ON SUCCESSIVE ENTRIES. IT IS IMPOSSIBLE TO PROCEED BECA"
"USE YOU HAVE NOT CORRECTED THE PROBLEM, SO EXECUTION IS "
"BEING TERMINATED.", &c__12, &c__2, (ftnlen)6, (ftnlen)4, (
ftnlen)166);
}
return 0;
}
/* ....................................................................... */
/* RTOL = ATOL = 0. IS ALLOWED AS VALID INPUT AND INTERPRETED AS */
/* ASKING FOR THE MOST ACCURATE SOLUTION POSSIBLE. IN THIS CASE, */
/* THE RELATIVE ERROR TOLERANCE RTOL IS RESET TO THE SMALLEST VALUE */
/* 100*U WHICH IS LIKELY TO BE REASONABLE FOR THIS METHOD AND MACHINE */
i__2 = *neq;
for (k = 1; k <= i__2; ++k) {
if (rtol[k] + atol[k] > 0.f) {
goto L160;
}
rtol[k] = debdf1_1.u * 100.f;
*idid = -2;
L160:
if (debdf1_1.itol == 0) {
goto L180;
}
/* L170: */
}
L180:
if (*idid != -2) {
goto L190;
}
/* RTOL=ATOL=0 ON INPUT, SO RTOL IS CHANGED TO A */
/* SMALL POSITIVE VALUE */
debdf1_1.ibegin = -1;
return 0;
/* BRANCH ON STATUS OF INITIALIZATION INDICATOR */
/* INIT=0 MEANS INITIAL DERIVATIVES AND NOMINAL STEP SIZE */
/* AND DIRECTION NOT YET SET */
/* INIT=1 MEANS NOMINAL STEP SIZE AND DIRECTION NOT YET SET */
/* INIT=2 MEANS NO FURTHER INITIALIZATION REQUIRED */
L190:
if (debdf1_1.init == 0) {
goto L200;
}
if (debdf1_1.init == 1) {
goto L220;
}
goto L240;
/* ....................................................................... */
/* MORE INITIALIZATION -- */
/* -- EVALUATE INITIAL DERIVATIVES */
L200:
debdf1_1.init = 1;
(*f)(t, &y[1], &yh[(yh_dim1 << 1) + 1], &rpar[1], &ipar[1]);
debdf1_1.nfe = 1;
if (*t != *tout) {
goto L220;
}
*idid = 2;
i__2 = *neq;
for (l = 1; l <= i__2; ++l) {
/* L210: */
ypout[l] = yh[l + (yh_dim1 << 1)];
}
debdf1_1.told = *t;
return 0;
/* -- COMPUTE INITIAL STEP SIZE */
/* -- SAVE SIGN OF INTEGRATION DIRECTION */
/* -- SET INDEPENDENT AND DEPENDENT VARIABLES */
/* X AND YH(*) FOR STOD */
L220:
ltol = 1;
i__2 = *neq;
for (l = 1; l <= i__2; ++l) {
if (debdf1_1.itol == 1) {
ltol = l;
}
tol = rtol[ltol] * (r__1 = y[l], dabs(r__1)) + atol[ltol];
if (tol == 0.f) {
goto L380;
}
/* L225: */
ewt[l] = tol;
}
big = sqrt(r1mach_(&c__2));
hstart_((S_fp)f, neq, t, tout, &y[1], &yh[(yh_dim1 << 1) + 1], &ewt[1], &
c__1, &debdf1_1.u, &big, &yh[yh_dim1 * 3 + 1], &yh[(yh_dim1 << 2)
+ 1], &yh[yh_dim1 * 5 + 1], &yh[yh_dim1 * 6 + 1], &rpar[1], &ipar[
1], &debdf1_1.h__);
r__1 = *tout - *t;
*delsgn = r_sign(&c_b41, &r__1);
debdf1_1.x = *t;
i__2 = *neq;
for (l = 1; l <= i__2; ++l) {
yh[l + yh_dim1] = y[l];
/* L230: */
yh[l + (yh_dim1 << 1)] = debdf1_1.h__ * yh[l + (yh_dim1 << 1)];
}
debdf1_1.init = 2;
/* ....................................................................... */
/* ON EACH CALL SET INFORMATION WHICH DETERMINES THE ALLOWED INTERVAL */
/* OF INTEGRATION BEFORE RETURNING WITH AN ANSWER AT TOUT */
L240:
del = *tout - *t;
absdel = dabs(del);
/* ....................................................................... */
/* IF ALREADY PAST OUTPUT POINT, INTERPOLATE AND RETURN */
L250:
if ((r__1 = debdf1_1.x - *t, dabs(r__1)) < absdel) {
goto L270;
}
intyd_(tout, &c__0, &yh[yh_offset], neq, &y[1], &intflg);
intyd_(tout, &c__1, &yh[yh_offset], neq, &ypout[1], &intflg);
*idid = 3;
if (debdf1_1.x != *tout) {
goto L260;
}
*idid = 2;
*intout = FALSE_;
L260:
*t = *tout;
debdf1_1.told = *t;
return 0;
/* IF CANNOT GO PAST TSTOP AND SUFFICIENTLY CLOSE, */
/* EXTRAPOLATE AND RETURN */
L270:
if (debdf1_1.itstop != 1) {
goto L290;
}
if ((r__1 = *tstop - debdf1_1.x, dabs(r__1)) >= debdf1_1.u * 100.f * dabs(
debdf1_1.x)) {
goto L290;
}
dt = *tout - debdf1_1.x;
i__2 = *neq;
for (l = 1; l <= i__2; ++l) {
/* L280: */
y[l] = yh[l + yh_dim1] + dt / debdf1_1.h__ * yh[l + (yh_dim1 << 1)];
}
(*f)(tout, &y[1], &ypout[1], &rpar[1], &ipar[1]);
++debdf1_1.nfe;
*idid = 3;
*t = *tout;
debdf1_1.told = *t;
return 0;
L290:
if (debdf1_1.iinteg == 0 || ! (*intout)) {
goto L300;
}
/* INTERMEDIATE-OUTPUT MODE */
*idid = 1;
goto L500;
/* ....................................................................... */
/* MONITOR NUMBER OF STEPS ATTEMPTED */
L300:
if (debdf1_1.ksteps <= maxnum) {
goto L330;
}
/* A SIGNIFICANT AMOUNT OF WORK HAS BEEN EXPENDED */
*idid = -1;
debdf1_1.ksteps = 0;
debdf1_1.ibegin = -1;
goto L500;
/* ....................................................................... */
/* LIMIT STEP SIZE AND SET WEIGHT VECTOR */
L330:
debdf1_1.hmin = debdf1_1.u * 100.f * dabs(debdf1_1.x);
/* Computing MAX */
r__1 = dabs(debdf1_1.h__);
ha = dmax(r__1,debdf1_1.hmin);
if (debdf1_1.itstop != 1) {
goto L340;
}
/* Computing MIN */
r__2 = ha, r__3 = (r__1 = *tstop - debdf1_1.x, dabs(r__1));
ha = dmin(r__2,r__3);
L340:
debdf1_1.h__ = r_sign(&ha, &debdf1_1.h__);
ltol = 1;
i__2 = *neq;
for (l = 1; l <= i__2; ++l) {
if (debdf1_1.itol == 1) {
ltol = l;
}
ewt[l] = rtol[ltol] * (r__1 = yh[l + yh_dim1], dabs(r__1)) + atol[
ltol];
if (ewt[l] <= 0.f) {
goto L380;
}
/* L350: */
}
*tolfac = debdf1_1.u * vnwrms_(neq, &yh[yh_offset], &ewt[1]);
if (*tolfac <= 1.f) {
goto L400;
}
/* TOLERANCES TOO SMALL */
*idid = -2;
*tolfac *= 2.f;
rtol[1] = *tolfac * rtol[1];
atol[1] = *tolfac * atol[1];
if (debdf1_1.itol == 0) {
goto L370;
}
i__2 = *neq;
for (l = 2; l <= i__2; ++l) {
rtol[l] = *tolfac * rtol[l];
/* L360: */
atol[l] = *tolfac * atol[l];
}
L370:
debdf1_1.ibegin = -1;
goto L500;
/* RELATIVE ERROR CRITERION INAPPROPRIATE */
L380:
*idid = -3;
debdf1_1.ibegin = -1;
goto L500;
/* ....................................................................... */
/* TAKE A STEP */
L400:
stod_(neq, &y[1], &yh[yh_offset], neq, &yh1[1], &ewt[1], &savf[1], &acor[
1], &wm[1], &iwm[1], (S_fp)f, (U_fp)jac, &rpar[1], &ipar[1]);
debdf1_1.jstart = -2;
*intout = TRUE_;
if (debdf1_1.kflag == 0) {
goto L250;
}
/* ....................................................................... */
if (debdf1_1.kflag == -1) {
goto L450;
}
/* REPEATED CORRECTOR CONVERGENCE FAILURES */
*idid = -6;
debdf1_1.ibegin = -1;
goto L500;
/* REPEATED ERROR TEST FAILURES */
L450:
*idid = -7;
debdf1_1.ibegin = -1;
/* ....................................................................... */
/* STORE VALUES BEFORE RETURNING TO DEBDF */
L500:
i__2 = *neq;
for (l = 1; l <= i__2; ++l) {
y[l] = yh[l + yh_dim1];
/* L555: */
ypout[l] = yh[l + (yh_dim1 << 1)] / debdf1_1.h__;
}
*t = debdf1_1.x;
debdf1_1.told = *t;
*intout = FALSE_;
return 0;
} /* lsod_ */
/* DECK QAGSE */
/* Subroutine */ int qagse_(E_fp f, real *a, real *b, real *epsabs, real *
epsrel, integer *limit, real *result, real *abserr, integer *neval,
integer *ier, real *alist__, real *blist, real *rlist, real *elist,
integer *iord, integer *last)
{
/* System generated locals */
integer i__1, i__2;
real r__1, r__2;
/* Local variables */
static integer k;
static real a1, a2, b1, b2;
static integer id;
extern /* Subroutine */ int qk21_(E_fp, real *, real *, real *, real *,
real *, real *);
static real area;
extern /* Subroutine */ int qelg_(integer *, real *, real *, real *, real
*, integer *);
static real dres;
static integer ksgn, nres;
static real area1, area2, area12, small, erro12;
static integer ierro;
static real defab1, defab2;
static integer ktmin, nrmax;
static real oflow, uflow;
static logical noext;
extern /* Subroutine */ int qpsrt_(integer *, integer *, integer *, real *
, real *, integer *, integer *);
extern doublereal r1mach_(integer *);
static integer iroff1, iroff2, iroff3;
static real res3la[3], error1, error2, rlist2[52];
static integer numrl2;
static real defabs, epmach, erlarg, abseps, correc, errbnd, resabs;
static integer jupbnd;
static real erlast, errmax;
static integer maxerr;
static real reseps;
static logical extrap;
static real ertest, errsum;
/* ***BEGIN PROLOGUE QAGSE */
/* ***PURPOSE The routine calculates an approximation result to a given */
/* definite integral I = Integral of F over (A,B), */
/* hopefully satisfying following claim for accuracy */
/* ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). */
/* ***LIBRARY SLATEC (QUADPACK) */
/* ***CATEGORY H2A1A1 */
/* ***TYPE SINGLE PRECISION (QAGSE-S, DQAGSE-D) */
/* ***KEYWORDS AUTOMATIC INTEGRATOR, END POINT SINGULARITIES, */
/* EXTRAPOLATION, GENERAL-PURPOSE, GLOBALLY ADAPTIVE, */
/* QUADPACK, QUADRATURE */
/* ***AUTHOR Piessens, Robert */
/* Applied Mathematics and Programming Division */
/* K. U. Leuven */
/* de Doncker, Elise */
/* Applied Mathematics and Programming Division */
/* K. U. Leuven */
/* ***DESCRIPTION */
/* Computation of a definite integral */
/* Standard fortran subroutine */
/* Real version */
/* PARAMETERS */
/* ON ENTRY */
/* F - Real */
/* Function subprogram defining the integrand */
/* function F(X). The actual name for F needs to be */
/* declared E X T E R N A L in the driver program. */
/* A - Real */
/* Lower limit of integration */
/* B - Real */
/* Upper limit of integration */
/* EPSABS - Real */
/* Absolute accuracy requested */
/* EPSREL - Real */
/* Relative accuracy requested */
/* If EPSABS.LE.0 */
/* and EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), */
/* the routine will end with IER = 6. */
/* LIMIT - Integer */
/* Gives an upper bound on the number of subintervals */
/* in the partition of (A,B) */
/* ON RETURN */
/* RESULT - Real */
/* Approximation to the integral */
/* ABSERR - Real */
/* Estimate of the modulus of the absolute error, */
/* which should equal or exceed ABS(I-RESULT) */
/* NEVAL - Integer */
/* Number of integrand evaluations */
/* IER - Integer */
/* IER = 0 Normal and reliable termination of the */
/* routine. It is assumed that the requested */
/* accuracy has been achieved. */
/* IER.GT.0 Abnormal termination of the routine */
/* the estimates for integral and error are */
/* less reliable. It is assumed that the */
/* requested accuracy has not been achieved. */
/* ERROR MESSAGES */
/* = 1 Maximum number of subdivisions allowed */
/* has been achieved. One can allow more sub- */
/* divisions by increasing the value of LIMIT */
/* (and taking the according dimension */
/* adjustments into account). However, if */
/* this yields no improvement it is advised */
/* to analyze the integrand in order to */
/* determine the integration difficulties. If */
/* the position of a local difficulty can be */
/* determined (e.g. singularity, */
/* discontinuity within the interval) one */
/* will probably gain from splitting up the */
/* interval at this point and calling the */
/* integrator on the subranges. If possible, */
/* an appropriate special-purpose integrator */
/* should be used, which is designed for */
/* handling the type of difficulty involved. */
/* = 2 The occurrence of roundoff error is detec- */
/* ted, which prevents the requested */
/* tolerance from being achieved. */
/* The error may be under-estimated. */
/* = 3 Extremely bad integrand behaviour */
/* occurs at some points of the integration */
/* interval. */
/* = 4 The algorithm does not converge. */
/* Roundoff error is detected in the */
/* extrapolation table. */
/* It is presumed that the requested */
/* tolerance cannot be achieved, and that the */
/* returned result is the best which can be */
/* obtained. */
/* = 5 The integral is probably divergent, or */
/* slowly convergent. It must be noted that */
/* divergence can occur with any other value */
/* of IER. */
/* = 6 The input is invalid, because */
/* EPSABS.LE.0 and */
/* EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28). */
/* RESULT, ABSERR, NEVAL, LAST, RLIST(1), */
/* IORD(1) and ELIST(1) are set to zero. */
/* ALIST(1) and BLIST(1) are set to A and B */
/* respectively. */
/* ALIST - Real */
/* Vector of dimension at least LIMIT, the first */
/* LAST elements of which are the left end points */
/* of the subintervals in the partition of the */
/* given integration range (A,B) */
/* BLIST - Real */
/* Vector of dimension at least LIMIT, the first */
/* LAST elements of which are the right end points */
/* of the subintervals in the partition of the given */
/* integration range (A,B) */
/* RLIST - Real */
/* Vector of dimension at least LIMIT, the first */
/* LAST elements of which are the integral */
/* approximations on the subintervals */
/* ELIST - Real */
/* Vector of dimension at least LIMIT, the first */
/* LAST elements of which are the moduli of the */
/* absolute error estimates on the subintervals */
/* IORD - Integer */
/* Vector of dimension at least LIMIT, the first K */
/* elements of which are pointers to the */
/* error estimates over the subintervals, */
/* such that ELIST(IORD(1)), ..., ELIST(IORD(K)) */
/* form a decreasing sequence, with K = LAST */
/* If LAST.LE.(LIMIT/2+2), and K = LIMIT+1-LAST */
/* otherwise */
/* LAST - Integer */
/* Number of subintervals actually produced in the */
/* subdivision process */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED QELG, QK21, QPSRT, R1MACH */
/* ***REVISION HISTORY (YYMMDD) */
/* 800101 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890831 Modified array declarations. (WRB) */
/* 890831 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* ***END PROLOGUE QAGSE */
/* THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF */
/* LIMEXP IN SUBROUTINE QELG (RLIST2 SHOULD BE OF DIMENSION */
/* (LIMEXP+2) AT LEAST). */
/* LIST OF MAJOR VARIABLES */
/* ----------------------- */
/* ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS */
/* CONSIDERED UP TO NOW */
/* BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS */
/* CONSIDERED UP TO NOW */
/* RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER */
/* (ALIST(I),BLIST(I)) */
/* RLIST2 - ARRAY OF DIMENSION AT LEAST LIMEXP+2 */
/* CONTAINING THE PART OF THE EPSILON TABLE */
/* WHICH IS STILL NEEDED FOR FURTHER COMPUTATIONS */
/* ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) */
/* MAXERR - POINTER TO THE INTERVAL WITH LARGEST ERROR */
/* ESTIMATE */
/* ERRMAX - ELIST(MAXERR) */
/* ERLAST - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED */
/* (BEFORE THAT SUBDIVISION HAS TAKEN PLACE) */
/* AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS */
/* ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS */
/* ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* */
/* ABS(RESULT)) */
/* *****1 - VARIABLE FOR THE LEFT INTERVAL */
/* *****2 - VARIABLE FOR THE RIGHT INTERVAL */
/* LAST - INDEX FOR SUBDIVISION */
/* NRES - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE */
/* NUMRL2 - NUMBER OF ELEMENTS CURRENTLY IN RLIST2. IF AN */
/* APPROPRIATE APPROXIMATION TO THE COMPOUNDED */
/* INTEGRAL HAS BEEN OBTAINED IT IS PUT IN */
/* RLIST2(NUMRL2) AFTER NUMRL2 HAS BEEN INCREASED */
/* BY ONE. */
/* SMALL - LENGTH OF THE SMALLEST INTERVAL CONSIDERED */
/* UP TO NOW, MULTIPLIED BY 1.5 */
/* ERLARG - SUM OF THE ERRORS OVER THE INTERVALS LARGER */
/* THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW */
/* EXTRAP - LOGICAL VARIABLE DENOTING THAT THE ROUTINE */
/* IS ATTEMPTING TO PERFORM EXTRAPOLATION */
/* I.E. BEFORE SUBDIVIDING THE SMALLEST INTERVAL */
/* WE TRY TO DECREASE THE VALUE OF ERLARG. */
/* NOEXT - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION */
/* IS NO LONGER ALLOWED (TRUE VALUE) */
/* MACHINE DEPENDENT CONSTANTS */
/* --------------------------- */
/* EPMACH IS THE LARGEST RELATIVE SPACING. */
/* UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. */
/* OFLOW IS THE LARGEST POSITIVE MAGNITUDE. */
/* ***FIRST EXECUTABLE STATEMENT QAGSE */
/* Parameter adjustments */
--iord;
--elist;
--rlist;
--blist;
--alist__;
/* Function Body */
epmach = r1mach_(&c__4);
/* TEST ON VALIDITY OF PARAMETERS */
/* ------------------------------ */
*ier = 0;
*neval = 0;
*last = 0;
*result = 0.f;
*abserr = 0.f;
alist__[1] = *a;
blist[1] = *b;
rlist[1] = 0.f;
elist[1] = 0.f;
/* Computing MAX */
r__1 = epmach * 50.f;
if (*epsabs <= 0.f && *epsrel < dmax(r__1,5e-15f)) {
*ier = 6;
}
if (*ier == 6) {
goto L999;
}
/* FIRST APPROXIMATION TO THE INTEGRAL */
/* ----------------------------------- */
uflow = r1mach_(&c__1);
oflow = r1mach_(&c__2);
ierro = 0;
qk21_((E_fp)f, a, b, result, abserr, &defabs, &resabs);
/* TEST ON ACCURACY. */
dres = dabs(*result);
/* Computing MAX */
r__1 = *epsabs, r__2 = *epsrel * dres;
errbnd = dmax(r__1,r__2);
*last = 1;
rlist[1] = *result;
elist[1] = *abserr;
iord[1] = 1;
if (*abserr <= epmach * 100.f * defabs && *abserr > errbnd) {
*ier = 2;
}
if (*limit == 1) {
*ier = 1;
}
if (*ier != 0 || *abserr <= errbnd && *abserr != resabs || *abserr == 0.f)
{
goto L140;
}
/* INITIALIZATION */
/* -------------- */
rlist2[0] = *result;
errmax = *abserr;
maxerr = 1;
area = *result;
errsum = *abserr;
*abserr = oflow;
nrmax = 1;
nres = 0;
numrl2 = 2;
ktmin = 0;
extrap = FALSE_;
noext = FALSE_;
iroff1 = 0;
iroff2 = 0;
iroff3 = 0;
ksgn = -1;
if (dres >= (1.f - epmach * 50.f) * defabs) {
ksgn = 1;
}
/* MAIN DO-LOOP */
/* ------------ */
i__1 = *limit;
for (*last = 2; *last <= i__1; ++(*last)) {
/* BISECT THE SUBINTERVAL WITH THE NRMAX-TH LARGEST */
/* ERROR ESTIMATE. */
a1 = alist__[maxerr];
b1 = (alist__[maxerr] + blist[maxerr]) * .5f;
a2 = b1;
b2 = blist[maxerr];
erlast = errmax;
qk21_((E_fp)f, &a1, &b1, &area1, &error1, &resabs, &defab1);
qk21_((E_fp)f, &a2, &b2, &area2, &error2, &resabs, &defab2);
/* IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL */
/* AND ERROR AND TEST FOR ACCURACY. */
area12 = area1 + area2;
erro12 = error1 + error2;
errsum = errsum + erro12 - errmax;
area = area + area12 - rlist[maxerr];
if (defab1 == error1 || defab2 == error2) {
goto L15;
}
if ((r__1 = rlist[maxerr] - area12, dabs(r__1)) > dabs(area12) *
1e-5f || erro12 < errmax * .99f) {
goto L10;
}
if (extrap) {
++iroff2;
}
if (! extrap) {
++iroff1;
}
L10:
if (*last > 10 && erro12 > errmax) {
++iroff3;
}
L15:
rlist[maxerr] = area1;
rlist[*last] = area2;
/* Computing MAX */
r__1 = *epsabs, r__2 = *epsrel * dabs(area);
errbnd = dmax(r__1,r__2);
/* TEST FOR ROUNDOFF ERROR AND EVENTUALLY */
/* SET ERROR FLAG. */
if (iroff1 + iroff2 >= 10 || iroff3 >= 20) {
*ier = 2;
}
if (iroff2 >= 5) {
ierro = 3;
}
/* SET ERROR FLAG IN THE CASE THAT THE NUMBER OF */
/* SUBINTERVALS EQUALS LIMIT. */
if (*last == *limit) {
*ier = 1;
}
/* SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR */
/* AT A POINT OF THE INTEGRATION RANGE. */
/* Computing MAX */
r__1 = dabs(a1), r__2 = dabs(b2);
if (dmax(r__1,r__2) <= (epmach * 100.f + 1.f) * (dabs(a2) + uflow *
1e3f)) {
*ier = 4;
}
/* APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. */
if (error2 > error1) {
goto L20;
}
alist__[*last] = a2;
blist[maxerr] = b1;
blist[*last] = b2;
elist[maxerr] = error1;
elist[*last] = error2;
goto L30;
L20:
alist__[maxerr] = a2;
alist__[*last] = a1;
blist[*last] = b1;
rlist[maxerr] = area2;
rlist[*last] = area1;
elist[maxerr] = error2;
elist[*last] = error1;
/* CALL SUBROUTINE QPSRT TO MAINTAIN THE DESCENDING ORDERING */
/* IN THE LIST OF ERROR ESTIMATES AND SELECT THE */
/* SUBINTERVAL WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE */
/* BISECTED NEXT). */
L30:
qpsrt_(limit, last, &maxerr, &errmax, &elist[1], &iord[1], &nrmax);
/* ***JUMP OUT OF DO-LOOP */
if (errsum <= errbnd) {
goto L115;
}
/* ***JUMP OUT OF DO-LOOP */
if (*ier != 0) {
goto L100;
}
if (*last == 2) {
goto L80;
}
if (noext) {
goto L90;
}
erlarg -= erlast;
if ((r__1 = b1 - a1, dabs(r__1)) > small) {
erlarg += erro12;
}
if (extrap) {
goto L40;
}
/* TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE */
/* SMALLEST INTERVAL. */
if ((r__1 = blist[maxerr] - alist__[maxerr], dabs(r__1)) > small) {
goto L90;
}
extrap = TRUE_;
nrmax = 2;
L40:
if (ierro == 3 || erlarg <= ertest) {
goto L60;
}
/* THE SMALLEST INTERVAL HAS THE LARGEST ERROR. */
/* BEFORE BISECTING DECREASE THE SUM OF THE ERRORS */
/* OVER THE LARGER INTERVALS (ERLARG) AND PERFORM */
/* EXTRAPOLATION. */
id = nrmax;
jupbnd = *last;
if (*last > *limit / 2 + 2) {
jupbnd = *limit + 3 - *last;
}
i__2 = jupbnd;
for (k = id; k <= i__2; ++k) {
maxerr = iord[nrmax];
errmax = elist[maxerr];
/* ***JUMP OUT OF DO-LOOP */
if ((r__1 = blist[maxerr] - alist__[maxerr], dabs(r__1)) > small)
{
goto L90;
}
++nrmax;
/* L50: */
}
/* PERFORM EXTRAPOLATION. */
L60:
++numrl2;
rlist2[numrl2 - 1] = area;
qelg_(&numrl2, rlist2, &reseps, &abseps, res3la, &nres);
++ktmin;
if (ktmin > 5 && *abserr < errsum * .001f) {
*ier = 5;
}
if (abseps >= *abserr) {
goto L70;
}
ktmin = 0;
*abserr = abseps;
*result = reseps;
correc = erlarg;
/* Computing MAX */
r__1 = *epsabs, r__2 = *epsrel * dabs(reseps);
ertest = dmax(r__1,r__2);
/* ***JUMP OUT OF DO-LOOP */
if (*abserr <= ertest) {
goto L100;
}
/* PREPARE BISECTION OF THE SMALLEST INTERVAL. */
L70:
if (numrl2 == 1) {
noext = TRUE_;
}
if (*ier == 5) {
goto L100;
}
maxerr = iord[1];
errmax = elist[maxerr];
nrmax = 1;
extrap = FALSE_;
small *= .5f;
erlarg = errsum;
goto L90;
L80:
small = (r__1 = *b - *a, dabs(r__1)) * .375f;
erlarg = errsum;
ertest = errbnd;
rlist2[1] = area;
L90:
;
}
/* SET FINAL RESULT AND ERROR ESTIMATE. */
/* ------------------------------------ */
L100:
if (*abserr == oflow) {
goto L115;
}
if (*ier + ierro == 0) {
goto L110;
}
if (ierro == 3) {
*abserr += correc;
}
if (*ier == 0) {
*ier = 3;
}
if (*result != 0.f && area != 0.f) {
goto L105;
}
if (*abserr > errsum) {
goto L115;
}
if (area == 0.f) {
goto L130;
}
goto L110;
L105:
if (*abserr / dabs(*result) > errsum / dabs(area)) {
goto L115;
}
/* TEST ON DIVERGENCE. */
L110:
/* Computing MAX */
r__1 = dabs(*result), r__2 = dabs(area);
if (ksgn == -1 && dmax(r__1,r__2) <= defabs * .01f) {
goto L130;
}
if (.01f > *result / area || *result / area > 100.f || errsum > dabs(area)
) {
*ier = 6;
}
goto L130;
/* COMPUTE GLOBAL INTEGRAL SUM. */
L115:
*result = 0.f;
i__1 = *last;
for (k = 1; k <= i__1; ++k) {
*result += rlist[k];
/* L120: */
}
*abserr = errsum;
L130:
if (*ier > 2) {
--(*ier);
}
L140:
*neval = *last * 42 - 21;
L999:
return 0;
} /* qagse_ */
/* DECK ERF */
doublereal erf_(real *x)
{
/* Initialized data */
static real erfcs[13] = { -.049046121234691808f,-.14226120510371364f,
.010035582187599796f,-5.76876469976748e-4f,2.7419931252196e-5f,
-1.104317550734e-6f,3.848875542e-8f,-1.180858253e-9f,
3.2334215e-11f,-7.99101e-13f,1.799e-14f,-3.71e-16f,7e-18f };
static real sqrtpi = 1.772453850905516f;
static logical first = TRUE_;
/* System generated locals */
real ret_val, r__1, r__2;
/* Local variables */
static real y;
extern doublereal erfc_(real *);
static real xbig;
extern doublereal csevl_(real *, real *, integer *);
static integer nterf;
extern integer inits_(real *, integer *, real *);
static real sqeps;
extern doublereal r1mach_(integer *);
/* ***BEGIN PROLOGUE ERF */
/* ***PURPOSE Compute the error function. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C8A, L5A1E */
/* ***TYPE SINGLE PRECISION (ERF-S, DERF-D) */
/* ***KEYWORDS ERF, ERROR FUNCTION, FNLIB, SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* ERF(X) calculates the single precision error function for */
/* single precision argument X. */
/* Series for ERF on the interval 0. to 1.00000D+00 */
/* with weighted error 7.10E-18 */
/* log weighted error 17.15 */
/* significant figures required 16.31 */
/* decimal places required 17.71 */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED CSEVL, ERFC, INITS, R1MACH */
/* ***REVISION HISTORY (YYMMDD) */
/* 770401 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) */
/* 900727 Added EXTERNAL statement. (WRB) */
/* 920618 Removed space from variable name. (RWC, WRB) */
/* ***END PROLOGUE ERF */
/* ***FIRST EXECUTABLE STATEMENT ERF */
if (first) {
r__1 = r1mach_(&c__3) * .1f;
nterf = inits_(erfcs, &c__13, &r__1);
xbig = sqrt(-log(sqrtpi * r1mach_(&c__3)));
sqeps = sqrt(r1mach_(&c__3) * 2.f);
}
first = FALSE_;
y = dabs(*x);
if (y > 1.f) {
goto L20;
}
/* ERF(X) = 1. - ERFC(X) FOR -1. .LE. X .LE. 1. */
if (y <= sqeps) {
ret_val = *x * 2.f / sqrtpi;
}
if (y > sqeps) {
/* Computing 2nd power */
r__2 = *x;
r__1 = r__2 * r__2 * 2.f - 1.f;
ret_val = *x * (csevl_(&r__1, erfcs, &nterf) + 1.f);
}
return ret_val;
/* ERF(X) = 1. - ERFC(X) FOR ABS(X) .GT. 1. */
L20:
if (y <= xbig) {
r__1 = 1.f - erfc_(&y);
ret_val = r_sign(&r__1, x);
}
if (y > xbig) {
ret_val = r_sign(&c_b7, x);
}
return ret_val;
} /* erf_ */
/* DECK CBRT */
doublereal cbrt_(real *x)
{
/* Initialized data */
static real cbrt2[5] = { .62996052494743658f,.79370052598409974f,1.f,
1.25992104989487316f,1.58740105196819947f };
static integer niter = 0;
/* System generated locals */
integer i__1;
real ret_val, r__1;
/* Local variables */
static integer n;
static real y;
static integer irem, iter;
extern doublereal r9pak_(real *, integer *);
static integer ixpnt;
extern doublereal r1mach_(integer *);
extern /* Subroutine */ int r9upak_(real *, real *, integer *);
static real cbrtsq;
/* ***BEGIN PROLOGUE CBRT */
/* ***PURPOSE Compute the cube root. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C2 */
/* ***TYPE SINGLE PRECISION (CBRT-S, DCBRT-D, CCBRT-C) */
/* ***KEYWORDS CUBE ROOT, ELEMENTARY FUNCTIONS, FNLIB, ROOTS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* CBRT(X) calculates the cube root of X. */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED R1MACH, R9PAK, R9UPAK */
/* ***REVISION HISTORY (YYMMDD) */
/* 770601 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) */
/* ***END PROLOGUE CBRT */
/* ***FIRST EXECUTABLE STATEMENT CBRT */
if (niter == 0) {
niter = 1.443f * log(-.106f * log(.1f * r1mach_(&c__3))) + 1.f;
}
ret_val = 0.f;
if (*x == 0.f) {
return ret_val;
}
r__1 = dabs(*x);
r9upak_(&r__1, &y, &n);
ixpnt = n / 3;
irem = n - ixpnt * 3 + 3;
/* THE APPROXIMATION BELOW IS A GENERALIZED CHEBYSHEV SERIES CONVERTED */
/* TO POLYNOMIAL FORM. THE APPROX IS NEARLY BEST IN THE SENSE OF */
/* RELATIVE ERROR WITH 4.085 DIGITS ACCURACY. */
ret_val = y * (y * (y * .144586f - .512653f) + .928549f) + .439581f;
i__1 = niter;
for (iter = 1; iter <= i__1; ++iter) {
cbrtsq = ret_val * ret_val;
ret_val += (y - ret_val * cbrtsq) / (cbrtsq * 3.f);
/* L10: */
}
r__1 = cbrt2[irem - 1] * r_sign(&ret_val, x);
ret_val = r9pak_(&r__1, &ixpnt);
return ret_val;
} /* cbrt_ */
/* DECK QK61 */
/* Subroutine */ int qk61_(E_fp f, real *a, real *b, real *result, real *
abserr, real *resabs, real *resasc)
{
/* Initialized data */
static real xgk[31] = { .9994844100504906f,.9968934840746495f,
.9916309968704046f,.9836681232797472f,.9731163225011263f,
.9600218649683075f,.94437444474856f,.9262000474292743f,
.9055733076999078f,.8825605357920527f,.8572052335460611f,
.8295657623827684f,.7997278358218391f,.7677774321048262f,
.7337900624532268f,.6978504947933158f,.660061064126627f,
.6205261829892429f,.5793452358263617f,.5366241481420199f,
.4924804678617786f,.4470337695380892f,.4004012548303944f,
.3527047255308781f,.3040732022736251f,.2546369261678898f,
.2045251166823099f,.1538699136085835f,.102806937966737f,
.0514718425553177f,0.f };
static real wgk[31] = { .001389013698677008f,.003890461127099884f,
.006630703915931292f,.009273279659517763f,.01182301525349634f,
.0143697295070458f,.01692088918905327f,.01941414119394238f,
.02182803582160919f,.0241911620780806f,.0265099548823331f,
.02875404876504129f,.03090725756238776f,.03298144705748373f,
.03497933802806002f,.03688236465182123f,.03867894562472759f,
.04037453895153596f,.04196981021516425f,.04345253970135607f,
.04481480013316266f,.04605923827100699f,.04718554656929915f,
.04818586175708713f,.04905543455502978f,.04979568342707421f,
.05040592140278235f,.05088179589874961f,.05122154784925877f,
.05142612853745903f,.05149472942945157f };
static real wg[15] = { .007968192496166606f,.01846646831109096f,
.02878470788332337f,.03879919256962705f,.04840267283059405f,
.05749315621761907f,.0659742298821805f,.07375597473770521f,
.08075589522942022f,.08689978720108298f,.09212252223778613f,
.09636873717464426f,.09959342058679527f,.1017623897484055f,
.1028526528935588f };
/* System generated locals */
real r__1, r__2;
doublereal d__1;
/* Local variables */
static integer j;
static real fc, fv1[30], fv2[30];
static integer jtw;
static real absc, resg, resk, fsum, fval1, fval2;
static integer jtwm1;
static real hlgth, centr, reskh, uflow;
extern doublereal r1mach_(integer *);
static real epmach, dhlgth;
/* ***BEGIN PROLOGUE QK61 */
/* ***PURPOSE To compute I = Integral of F over (A,B) with error */
/* estimate */
/* J = Integral of ABS(F) over (A,B) */
/* ***LIBRARY SLATEC (QUADPACK) */
/* ***CATEGORY H2A1A2 */
/* ***TYPE SINGLE PRECISION (QK61-S, DQK61-D) */
/* ***KEYWORDS 61-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE */
/* ***AUTHOR Piessens, Robert */
/* Applied Mathematics and Programming Division */
/* K. U. Leuven */
/* de Doncker, Elise */
/* Applied Mathematics and Programming Division */
/* K. U. Leuven */
/* ***DESCRIPTION */
/* Integration rule */
/* Standard fortran subroutine */
/* Real version */
/* PARAMETERS */
/* ON ENTRY */
/* F - Real */
/* Function subprogram defining the integrand */
/* function F(X). The actual name for F needs to be */
/* declared E X T E R N A L in the calling program. */
/* A - Real */
/* Lower limit of integration */
/* B - Real */
/* Upper limit of integration */
/* ON RETURN */
/* RESULT - Real */
/* Approximation to the integral I */
/* RESULT is computed by applying the 61-point */
/* Kronrod rule (RESK) obtained by optimal addition of */
/* abscissae to the 30-point Gauss rule (RESG). */
/* ABSERR - Real */
/* Estimate of the modulus of the absolute error, */
/* which should equal or exceed ABS(I-RESULT) */
/* RESABS - Real */
/* Approximation to the integral J */
/* RESASC - Real */
/* Approximation to the integral of ABS(F-I/(B-A)) */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED R1MACH */
/* ***REVISION HISTORY (YYMMDD) */
/* 800101 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) */
/* ***END PROLOGUE QK61 */
/* THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE */
/* INTERVAL (-1,1). BECAUSE OF SYMMETRY ONLY THE POSITIVE */
/* ABSCISSAE AND THEIR CORRESPONDING WEIGHTS ARE GIVEN. */
/* XGK - ABSCISSAE OF THE 61-POINT KRONROD RULE */
/* XGK(2), XGK(4) ... ABSCISSAE OF THE 30-POINT */
/* GAUSS RULE */
/* XGK(1), XGK(3) ... OPTIMALLY ADDED ABSCISSAE */
/* TO THE 30-POINT GAUSS RULE */
/* WGK - WEIGHTS OF THE 61-POINT KRONROD RULE */
/* WG - WEIGHTS OF THE 30-POINT GAUSS RULE */
/* LIST OF MAJOR VARIABLES */
/* ----------------------- */
/* CENTR - MID POINT OF THE INTERVAL */
/* HLGTH - HALF-LENGTH OF THE INTERVAL */
/* ABSC - ABSCISSA */
/* FVAL* - FUNCTION VALUE */
/* RESG - RESULT OF THE 30-POINT GAUSS RULE */
/* RESK - RESULT OF THE 61-POINT KRONROD RULE */
/* RESKH - APPROXIMATION TO THE MEAN VALUE OF F */
/* OVER (A,B), I.E. TO I/(B-A) */
/* MACHINE DEPENDENT CONSTANTS */
/* --------------------------- */
/* EPMACH IS THE LARGEST RELATIVE SPACING. */
/* UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. */
/* ***FIRST EXECUTABLE STATEMENT QK61 */
epmach = r1mach_(&c__4);
uflow = r1mach_(&c__1);
centr = (*b + *a) * .5f;
hlgth = (*b - *a) * .5f;
dhlgth = dabs(hlgth);
/* COMPUTE THE 61-POINT KRONROD APPROXIMATION TO THE */
/* INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR. */
resg = 0.f;
fc = (*f)(¢r);
resk = wgk[30] * fc;
*resabs = dabs(resk);
for (j = 1; j <= 15; ++j) {
jtw = j << 1;
absc = hlgth * xgk[jtw - 1];
r__1 = centr - absc;
fval1 = (*f)(&r__1);
r__1 = centr + absc;
fval2 = (*f)(&r__1);
fv1[jtw - 1] = fval1;
fv2[jtw - 1] = fval2;
fsum = fval1 + fval2;
resg += wg[j - 1] * fsum;
resk += wgk[jtw - 1] * fsum;
*resabs += wgk[jtw - 1] * (dabs(fval1) + dabs(fval2));
/* L10: */
}
for (j = 1; j <= 15; ++j) {
jtwm1 = (j << 1) - 1;
absc = hlgth * xgk[jtwm1 - 1];
r__1 = centr - absc;
fval1 = (*f)(&r__1);
r__1 = centr + absc;
fval2 = (*f)(&r__1);
fv1[jtwm1 - 1] = fval1;
fv2[jtwm1 - 1] = fval2;
fsum = fval1 + fval2;
resk += wgk[jtwm1 - 1] * fsum;
*resabs += wgk[jtwm1 - 1] * (dabs(fval1) + dabs(fval2));
/* L15: */
}
reskh = resk * .5f;
*resasc = wgk[30] * (r__1 = fc - reskh, dabs(r__1));
for (j = 1; j <= 30; ++j) {
*resasc += wgk[j - 1] * ((r__1 = fv1[j - 1] - reskh, dabs(r__1)) + (
r__2 = fv2[j - 1] - reskh, dabs(r__2)));
/* L20: */
}
*result = resk * hlgth;
*resabs *= dhlgth;
*resasc *= dhlgth;
*abserr = (r__1 = (resk - resg) * hlgth, dabs(r__1));
if (*resasc != 0.f && *abserr != 0.f) {
/* Computing MIN */
d__1 = (doublereal) (*abserr * 200.f / *resasc);
r__1 = 1.f, r__2 = pow_dd(&d__1, &c_b7);
*abserr = *resasc * dmin(r__1,r__2);
}
if (*resabs > uflow / (epmach * 50.f)) {
/* Computing MAX */
r__1 = epmach * 50.f * *resabs;
*abserr = dmax(r__1,*abserr);
}
return 0;
} /* qk61_ */
/* Subroutine */ int spcgnr_(S_fp matvec, S_fp pcondl, real *a, integer *ia,
real *x, real *b, integer *n, real *q, integer *iq, integer *iparam,
real *rparam, integer *iwork, real *r__, real *h__, real *ap, real *
d__, real *e, real *cndwk, integer *ierror)
{
/* Format strings */
static char fmt_6[] = "(\002 THE METHOD IS CG ON CT*AT*A*C (PCGNR)\002,/)"
;
static char fmt_8[] = "(4x,\002CNDPNS = \002,e12.5,/)";
static char fmt_10[] = "(\002 RESID = 2-NORM OF C*CT*AT*R\002,/,\002 RE"
"LRSD = RESID / INITIAL RESID\002,/,\002 COND(C*CT*AT*A) USED IN "
"STOPPING CRITERION\002,/)";
static char fmt_25[] = "(\002 INITIAL RESID = \002,e12.5,/)";
static char fmt_35[] = "(\002 ITERS = \002,i5,4x,\002RESID = \002,e12.5,"
"4x,\002RELRSD = \002,e12.5)";
static char fmt_70[] = "(/,\002 NEW ESTIMATES FOR C*CT*AT*A:\002)";
/* System generated locals */
integer i__1;
real r__1;
/* Builtin functions */
integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
double sqrt(doublereal);
/* Local variables */
static integer i__, nce, ido, isp1;
static real beta;
static integer kmax;
extern doublereal snrm2_(integer *, real *, integer *);
static real alpha, denom;
static integer itmax;
static real hnorm, sdumm;
static integer iters;
static real wdumm, zdumm;
static integer istop, jstop;
static real snorm;
extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
real *, integer *);
extern doublereal r1mach_(integer *);
static real s0norm;
extern /* Subroutine */ int scgchk_(integer *, real *, integer *);
static real ralpha;
static integer icycle;
static real eigmin, eigmax, oldhnm, cndpns, rndumm;
static integer iounit;
static real errtol;
extern /* Subroutine */ int sonest_(integer *, real *, real *, real *,
real *, integer *, integer *, real *, real *, real *);
static real wdummy;
extern integer msstop_(integer *, integer *, integer *, real *, real *,
integer *, real *, real *, real *, integer *, real *, real *,
real *, real *, real *, integer *);
static real stptst;
/* Fortran I/O blocks */
static cilist io___9 = { 0, 0, 0, fmt_6, 0 };
static cilist io___10 = { 0, 0, 0, fmt_8, 0 };
static cilist io___11 = { 0, 0, 0, fmt_10, 0 };
static cilist io___21 = { 0, 0, 0, fmt_25, 0 };
static cilist io___30 = { 0, 0, 0, fmt_35, 0 };
static cilist io___35 = { 0, 0, 0, fmt_70, 0 };
/* ***BEGIN PROLOGUE SPCGNR */
/* ***DATE WRITTEN 860115 (YYMMDD) */
/* ***REVISION DATE 900210 (YYMMDD) */
/* ***CATEGORY NO. D2A4 */
/* ***KEYWORDS LINEAR SYSTEM,SPARSE,NONSYMMETRIC,NORMAL EQUATIONS, */
/* PRECONDITION,ITERATIVE,CONJUGATE GRADIENTS */
/* ***AUTHOR ASHBY,STEVEN F., (UIUC) */
/* UNIV. OF ILLINOIS */
/* DEPT. OF COMPUTER SCIENCE */
/* URBANA, IL 61801 */
/* ***AUTHOR HOLST,MICHAEL J., (UIUC) */
/* UNIV. OF ILLINOIS */
/* DEPT. OF COMPUTER SCIENCE */
/* URBANA, IL 61801 */
/* MANTEUFFEL,THOMAS A., (LANL) */
/* LOS ALAMOS NATIONAL LABORATORY */
/* MAIL STOP B265 */
/* LOS ALAMOS, NM 87545 */
/* ***PURPOSE THIS ROUTINE SOLVES THE ARBITRARY LINEAR SYSTEM AX=P BY */
/* THE METHOD OF CONJUGATE GRADIENTS ON THE PRECONDITIONED */
/* NORMAL EQUATIONS. SEE THE LONG DESCRIPTION FOR DETAILS. */
/* ***DESCRIPTION */
/* --- ON ENTRY --- */
/* MATVEC EXTERNAL SUBROUTINE MATVEC(JOB,A,IA,W,X,Y,N) */
/* THE USER MUST PROVIDE A SUBROUTINE HAVING THE SPECIFED */
/* PARAMETER LIST. THE SUBROUTINE MUST RETURN THE PRODUCT */
/* (OR A RELATED COMPUTATION; SEE BELOW) Y=A*X, WHERE A IS */
/* THE COEFFICIENT MATRIX OF THE LINEAR SYSTEM. THE MATRIX */
/* A IS REPRESENTED BY THE WORK ARRAYS A AND IA, DESCRIBED */
/* BELOW. THE INTEGER PARAMETER JOB SPECIFIES THE PRODUCT */
/* TO BE COMPUTED: */
/* JOB=0 Y=A*X */
/* JOB=1 Y=AT*X */
/* JOB=2 Y=W - A*X */
/* JOB=3 Y=W - AT*X. */
/* IN THE ABOVE, AT DENOTES A-TRANSPOSE. NOTE THAT */
/* ONLY THE VALUES OF JOB=0,1 ARE REQUIRED FOR CGCODE. */
/* ALL OF THE ROUTINES IN CGCODE REQUIRE JOB=0; THE */
/* ROUTINES SCGNR, SCGNE, SPCGNR, AND SPCGNE ALSO REQUIRE */
/* THE VALUE OF JOB=1. (THE VALUES OF JOB=2,3 ARE NOT */
/* REQUIRED BY ANY OF THE ROUTINES IN CGCODE, BUT MAY BE */
/* REQUIRED BY OTHER ITERATIVE PACKAGES CONFORMING TO THE */
/* PROPOSED ITERATIVE STANDARD.) THE PARAMETERS W,X,Y ARE */
/* ALL VECTORS OF LENGTH N. THE ONLY PARAMETER THAT MAY BE */
/* CHANGED INSIDE THE ROUTINE IS Y. MATVEC WILL USUALLY */
/* SERVE AS AN INTERFACE TO THE USER'S OWN MATRIX-VECTOR */
/* MULTIPLY SUBROUTINE. */
/* NOTE: MATVEC MUST BE DECLARED IN AN EXTERNAL STATEMENT */
/* IN THE CALLING PROGRAM. */
/* PCONDL EXTERNAL SUBROUTINE PCONDL(JOB,Q,IQ,W,X,Y,N) */
/* PCONDL IMPLEMENTS A USER SUPPLIED LEFT-PRECONDITIONER. */
/* IF PRECONDITIONING IS SPECIFIED BY THE USER, THEN THE */
/* USER MUST PROVIDE A SUBROUTINE HAVING THE SPECIFED */
/* PARAMETER LIST. THE SUBROUTINE MUST RETURN THE PRODUCT */
/* (OR A RELATED COMPUTATION; SEE BELOW) Y=C*X, WHERE C */
/* IS A PRECONDITIONING MATRIX. THE MATRIX C IS */
/* REPRESENTED BY THE WORK ARRAYS Q AND IQ, DESCRIBED */
/* BELOW. THE INTEGER PARAMETER JOB SPECIFIES THE PRODUCT */
/* TO BE COMPUTED: */
/* JOB=0 Y=C*X */
/* JOB=1 Y=CT*X */
/* JOB=2 Y=W - C*X */
/* JOB=3 Y=W - CT*X. */
/* IN THE ABOVE, CT DENOTES C-TRANSPOSE. NOTE THAT */
/* ONLY THE VALUES OF JOB=0,1 ARE REQUIRED FOR CGCODE. */
/* THE ROUTINES SPCG, SPCGNR, SPCGNE, SPPCG, AND SPCGCA IN */
/* CGCODE REQUIRE JOB=0; THE ROUTINES SPCGNR AND SPCGNE ALSO */
/* REQUIRE THE VALUE OF JOB=1. (THE VALUES OF JOB=2,3 ARE */
/* NOT REQUIRED BY ANY OF THE ROUTINES IN CGCODE, BUT MAY BE */
/* REQUIRED BY OTHER ITERATIVE PACKAGES CONFORMING TO THE */
/* PROPOSED ITERATIVE STANDARD.) THE PARAMETERS W,X,Y ARE */
/* ALL VECTORS OF LENGTH N. THE ONLY PARAMETER THAT MAY BE */
/* CHANGED INSIDE THE ROUTINE IS Y. PCONDL WILL USUALLY */
/* SERVE AS AN INTERFACE TO THE USER'S OWN PRECONDITIONING */
/* NOTE: PCONDL MUST BE DECLARED IN AN EXTERNAL STATEMENT */
/* IN THE CALLING PROGRAM. IF NO PRE-CONDITIONING IS BEING */
/* DONE, PCONDL IS A DUMMY ARGUMENT. */
/* A REAL ARRAY ADDRESS. */
/* THE BASE ADDRESS OF THE USER'S REAL WORK ARRAY, USUALLY */
/* THE MATRIX A. SINCE A IS ONLY ACCESSED BY CALLS TO SUBR */
/* MATVEC, IT MAY BE A DUMMY ADDRESS. */
/* IA INTEGER ARRAY ADDRESS. */
/* THE BASE ADDRESS OF THE USER'S INTEGER WORK ARRAY. THIS */
/* USUALLY CONTAINS ADDITIONAL INFORMATION ABOUT A NEEDED BY */
/* MATVEC. SINCE IA IS ONLY ACCESSED BY CALLS TO MATVEC, IT */
/* MAY BE A DUMMY ADDRESS. */
/* X REAL(N). */
/* THE INITIAL GUESS VECTOR, X0. */
/* (ON EXIT, X IS OVERWRITTEN WITH THE APPROXIMATE SOLUTION */
/* OF A*X=B.) */
/* B REAL(N). */
/* THE RIGHT-HAND SIDE VECTOR OF THE LINEAR SYSTEM AX=B. */
/* NOTE: B IS CHANGED BY THE SOLVER. */
/* N INTEGER. */
/* THE ORDER OF THE MATRIX A IN THE LINEAR SYSTEM AX=B. */
/* Q REAL ARRAY ADDRESS. */
/* THE BASE ADDRESS OF THE USER'S LEFT-PRECONDITIONING ARRAY, */
/* Q. SINCE Q IS ONLY ACCESSED BY CALLS TO PCONDL, IT MAY BE */
/* A DUMMY ADDRESS. IF NO LEFT-PRECONDITIONING IS BEING */
/* DONE, THIS IS A DUMMY ARGUMENT. */
/* IQ INTEGER ARRAY ADDRESS. */
/* THE BASE ADDRESS OF AN INTEGER WORK ARRAY ASSOCIATED WITH */
/* Q. THIS PROVIDES THE USER WITH A WAY OF PASSING INTEGER */
/* INFORMATION ABOUT Q TO PCONDL. SINCE IQ IS ONLY ACCESSED */
/* BY CALLS TO PCONDL, IT MAY BE A DUMMY ADDRESS. IF NO */
/* LEFT-PRECONDITIONING IS BEING DONE, THIS IS A DUMMY */
/* ARGUMENT. */
/* IPARAM INTEGER(40). */
/* AN ARRAY OF INTEGER INPUT PARAMETERS: */
/* NOTE: IPARAM(1) THROUGH IPARAM(10) ARE MANDATED BY THE */
/* PROPOSED STANDARD; IPARAM(11) THROUGH IPARAM(30) ARE */
/* RESERVED FOR EXPANSION OF THE PROPOSED STANDARD; */
/* IPARAM(31) THROUGH IPARAM(34) ARE ADDITIONAL */
/* PARAMETERS, SPECIFIC TO CGCODE. */
/* IPARAM(1) = NIPAR */
/* LENGTH OF THE IPARAM ARRAY. */
/* IPARAM(2) = NRPAR */
/* LENGTH OF THE RPARAM ARRAY. */
/* IPARAM(3) = NIWK */
/* LENGTH OF THE IWORK ARRAY. */
/* IPARAM(4) = NRWK */
/* LENGTH OF THE RWORK ARRAY. */
/* IPARAM(5) = IOUNIT */
/* IF (IOUNIT > 0) THEN ITERATION INFORMATION (AS */
/* SPECIFIED BY IOLEVL; SEE BELOW) IS SENT TO UNIT=IOUNIT, */
/* WHICH MUST BE OPENED IN THE CALLING PROGRAM. */
/* IF (IOUNIT <= 0) THEN THERE IS NO OUTPUT. */
/* IPARAM(6) = IOLEVL */
/* SPECIFIES THE AMOUNT AND TYPE OF INFORMATION TO BE */
/* OUTPUT IF (IOUNIT > 0): */
/* IOLEVL = 0 OUTPUT ERROR MESSAGES ONLY */
/* IOLEVL = 1 OUTPUT INPUT PARAMETERS AND LEVEL 0 INFO */
/* IOLEVL = 2 OUTPUT STPTST (SEE BELOW) AND LEVEL 1 INFO */
/* IOLEVL = 3 OUTPUT LEVEL 2 INFO AND MORE DETAILS */
/* IPARAM(8) = ISTOP */
/* STOPPING CRITERION FLAG, INTERPRETED AS: */
/* ISTOP = 0 ||E||/||E0|| <= ERRTOL (DEFAULT) */
/* ISTOP = 1 ||R|| <= ERRTOL */
/* ISTOP = 2 ||R||/||B|| <= ERRTOL */
/* ISTOP = 3 ||C*R|| <= ERRTOL */
/* ISTOP = 4 ||C*R||/||C*B|| <= ERRTOL */
/* WHERE E=ERROR, R=RESIDUAL, B=RIGHT HAND SIDE OF A*X=B, */
/* AND C IS THE PRECONDITIONING MATRIX OR PRECONDITIONING */
/* POLYNOMIAL (OR BOTH.) */
/* NOTE: IF ISTOP=0 IS SELECTED BY THE USER, THEN ERRTOL */
/* IS THE AMOUNT BY WHICH THE INITIAL ERROR IS TO BE */
/* REDUCED. BY ESTIMATING THE CONDITION NUMBER OF THE */
/* ITERATION MATRIX, THE CODE ATTEMPTS TO GUARANTEE THAT */
/* THE FINAL RELATIVE ERROR IS .LE. ERRTOL. SEE THE LONG */
/* DESCRIPTION BELOW FOR DETAILS. */
/* IPARAM(9) = ITMAX */
/* THE MAXIMUM NUMBER OF ITERATIVE STEPS TO BE TAKEN. */
/* IF SOLVER IS UNABLE TO SATISFY THE STOPPING CRITERION */
/* WITHIN ITMAX ITERATIONS, IT RETURNS TO THE CALLING */
/* PROGRAM WITH IERROR=-1000. */
/* IPARAM(31) = ICYCLE */
/* THE FREQUENCY WITH WHICH A CONDITION NUMBER ESTIMATE IS */
/* COMPUTED; SEE THE LONG DESCRIPTION BELOW. */
/* IPARAM(32) = NCE */
/* THE MAXIMUM NUMBER OF CONDITION NUMBER ESTIMATES TO BE */
/* COMPUTED. IF NCE = 0 NO ESTIMATES ARE COMPUTED. SEE */
/* THE LONG DESCRIPTION BELOW. */
/* NOTE: KMAX = ICYCLE*NCE IS THE ORDER OF THE LARGEST */
/* ORTHOGONAL SECTION OF C*A USED TO COMPUTE A CONDITION */
/* NUMBER ESTIMATE. THIS ESTIMATE IS ONLY USED IN THE */
/* STOPPING CRITERION. AS SUCH, KMAX SHOULD BE MUCH LESS */
/* THAN N. OTHERWISE THE CODE WILL HAVE EXCESSIVE STORAGE */
/* AND WORK REQUIREMENTS. */
/* RPARAM REAL(40). */
/* AN ARRAY OF REAL INPUT PARAMETERS: */
/* NOTE: RPARAM(1) AND RPARAM(2) ARE MANDATED BY THE */
/* PROPOSED STANDARD; RPARAM(3) THROUGH RPARAM(30) ARE */
/* RESERVED FOR EXPANSION OF THE PROPOSED STANDARD; */
/* RPARAM(31) THROUGH RPARAM(34) ARE ADDITIONAL */
/* PARAMETERS, SPECIFIC TO CGCODE. */
/* RPARAM(1) = ERRTOL */
/* USER PROVIDED ERROR TOLERANCE; SEE ISTOP ABOVE, AND THE */
/* LONG DESCRIPTION BELOW. */
/* RPARAM(31) = CONDES */
/* AN INITIAL ESTIMATE FOR THE COND NUMBER OF THE ITERATION */
/* MATRIX; SEE THE INDIVIDUAL SUBROUTINE'S PROLOGUE. AN */
/* ACCEPTABLE INITIAL VALUE IS 1.0. */
/* R REAL(N). */
/* WORK ARRAY OF LENGTH .GE. N. */
/* H REAL(N). */
/* WORK ARRAY OF LENGTH .GE. N. */
/* AP REAL(N). */
/* WORK ARRAY OF LENGTH .GE. N. */
/* D,E REAL(ICYCLE*NCE + 1), REAL(ICYCLE*NCE + 1). */
/* CNDWK REAL(2*ICYCLE*NCE). */
/* IWORK INTEGER(ICYCLE*NCE). */
/* WORK ARRAYS FOR COMPUTING CONDITION NUMBER ESTIMATES. */
/* IF NCE = 0 THESE MAY BE DUMMY ADDRESSES. */
/* --- ON RETURN --- */
/* IPARAM THE FOLLOWING ITERATION INFO IS RETURNED VIA THIS ARRAY: */
/* IPARAM(10) = ITERS */
/* THE NUMBER OF ITERATIONS TAKEN. IF IERROR=0, THEN X_ITERS */
/* SATISFIES THE SPECIFIED STOPPING CRITERION. IF */
/* IERROR=-1000, CGCODE WAS UNABLE TO CONVERGE WITHIN ITMAX */
/* ITERATIONS, AND X_ITERS IS CGCODE'S BEST APPROXIMATION TO */
/* THE SOLUTION OF A*X=B. */
/* RPARAM THE FOLLOWING ITERATION INFO IS RETURNED VIA THIS ARRAY: */
/* RPARAM(2) = STPTST */
/* FINAL QUANTITY USED IN THE STOPPING CRITERION; SEE ISTOP */
/* ABOVE, AND THE LONG DESCRIPTION BELOW. */
/* RPARAM(31) = CONDES */
/* CONDITION NUMBER ESTIMATE; FINAL ESTIMATE USED IN THE */
/* STOPPING CRITERION; SEE ISTOP ABOVE, AND THE LONG */
/* DESCRIPTION BELOW. */
/* RPARAM(34) = SCRLRS */
/* THE SCALED RELATIVE RESIDUAL USING THE LAST COMPUTED */
/* RESIDUAL. */
/* X THE COMPUTED SOLUTION OF THE LINEAR SYSTEM AX=B. */
/* IERROR INTEGER. */
/* ERROR FLAG (NEGATIVE ERRORS ARE FATAL): */
/* (BELOW, A=SYSTEM MATRIX, Q=LEFT PRECONDITIONING MATRIX.) */
/* IERROR = 0 NORMAL RETURN: ITERATION CONVERGED */
/* IERROR = -1000 METHOD FAILED TO CONVERGE IN ITMAX STEPS */
/* IERROR = +-2000 ERROR IN USER INPUT */
/* IERROR = +-3000 METHOD BREAKDOWN */
/* IERROR = -6000 A DOES NOT SATISTY ASSUMPTIONS OF METHOD */
/* IERROR = -7000 Q DOES NOT SATISTY ASSUMPTIONS OF METHOD */
/* ***LONG DESCRIPTION */
/* SPCGNR IMPLEMENTS SCGNR ON THE PRECONDITIONED NORMAL EQUATIONS, */
/* CT*AT*A*C, USING THE OMIN ALGORITHM GIVEN BY: */
/* H0 = CT*AT*R0 */
/* P0 = C*H0 */
/* ALPHA = <H,H>/<A*P,A*P> */
/* XNEW = X + ALPHA*P */
/* RNEW = R - ALPHA*(A*P) */
/* HNEW = CT*AT*RNEW */
/* BETA = <HNEW,HNEW>/<H,H> */
/* PNEW = C*HNEW + BETA*P */
/* THIS ALGORITHM IS GUARANTEED TO CONVERGE FOR ANY NONSINGULAR A. */
/* MATHEMATICALLY, IF CT*AT*A*C HAS M DISTINCT EIGENVALUES, THEN */
/* THE ALGORITHM WILL CONVERGE IN AT MOST M STEPS. AT EACH STEP THE */
/* ALGORITHM MINIMIZES THE 2-NORM OF THE RESIDUAL. */
/* WHEN THE USER SELECTS THE STOPPING CRITERION OPTION ISTOP=0, THE */
/* CODE STOPS WHEN COND(C*CT*AT*A)*(SNORM/S0NORM) .LE. ERRTOL, */
/* ATTEMPTING TO GUARANTEE THAT (FINAL RELATIVE ERROR) .LE. ERRTOL. */
/* A NEW ESTIMATE FOR COND(C*CT*AT*A) IS COMPUTED EVERY ICYCLE */
/* STEPS, DONE BY COMPUTING THE MIN AND MAX EGVALS OF AN ORTHOGONAL */
/* SECTION OF A. THE LARGEST ORTHOG SECTION HAS ORDER ICYCLE*NCE, */
/* WHERE NCE IS THE MAXIMUM NUMBER OF CONDITION ESTIMATES. IF NCE=0, */
/* NO CONDITION ESTIMATES ARE COMPUTED. IN THIS CASE, THE CODE STOPS */
/* WHEN SNORM/S0NORM .LE. ERRTOL. (ALSO SEE THE PROLOGUE TO SCGDRV.) */
/* THIS STOPPING CRITERION WAS IMPLEMENTED BY A.J. ROBERTSON, III */
/* (DEPT. OF MATHEMATICS, UNIV. OF COLORADO AT DENVER). QUESTIONS */
/* MAY BE DIRECTED TO HIM OR TO ONE OF THE AUTHORS. */
/* SPCGNR IS ONE ROUTINE IN A PACKAGE OF CG CODES; THE OTHERS ARE: */
/* SCGDRV: AN INTERFACE TO ANY ROUTINE IN THE PACKAGE. */
/* SCG: METHOD OF CONJUGATE GRADIENTS, A SPD. */
/* SCR: METHOD OF CONJUGATE RESIDUALS, A SYMMETRIC. */
/* SCRIND: METHOD OF CONJUGATE RESIDUALS, A SYMMETRIC INDEFINITE. */
/* SPCG: PRECONDITIONED CG, BOTH A AND C SPD. */
/* SCGNR: CG APPLIED TO AT*A, A ARBITRARY. */
/* SCGNE: CG APPLIED TO A*AT, A ARBITRARY. */
/* SPCGNR: CG APPLIED TO CT*AT*A*C, A AND C ARBITRARY. */
/* SPCGNE: CG APPLIED TO C*A*AT*CT, A AND C ARBITRARY. */
/* SPPCG: POLYNOMIAL PRECONDITIONED CG, BOTH A AND C SPD. */
/* SPCGCA: CG APPLIED TO C(A)*C*A, BOTH A AND C SPD. */
/* ***REFERENCES HOWARD C. ELMAN, "ITERATIVE METHODS FOR LARGE, SPARSE, */
/* NONSYMMETRIC SYSTEMS OF LINEAR EQUATIONS", YALE UNIV. */
/* DCS RESEARCH REPORT NO. 229 (APRIL 1982). */
/* VANCE FABER AND THOMAS MANTEUFFEL, "NECESSARY AND */
/* SUFFICIENT CONDITIONS FOR THE EXISTENCE OF A */
/* CONJUGATE GRADIENT METHODS", SIAM J. NUM ANAL 21(2), */
/* PP. 352-362, 1984. */
/* S. ASHBY, T. MANTEUFFEL, AND P. SAYLOR, "A TAXONOMY FOR */
/* CONJUGATE GRADIENT METHODS", SIAM J. NUM ANAL 27(6), */
/* PP. 1542-1568, 1990. */
/* S. ASHBY, M. HOLST, T. MANTEUFFEL, AND P. SAYLOR, */
/* THE ROLE OF THE INNER PRODUCT IN STOPPING CRITERIA */
/* FOR CONJUGATE GRADIENT ITERATIONS", BIT 41(1), */
/* PP. 26-53, 2001. */
/* M. HOLST, "CGCODE: SOFTWARE FOR SOLVING LINEAR SYSTEMS */
/* WITH CONJUGATE GRADIENT METHODS", M.S. THESIS, UNIV. */
/* OF ILLINOIS DCS RESEARCH REPORT (MAY 1990). */
/* S. ASHBY, "POLYNOMIAL PRECONDITIONG FOR CONJUGATE */
/* GRADIENT METHODS", PH.D. THESIS, UNIV. OF ILLINOIS */
/* DCS RESEARCH REPORT NO. R-87-1355 (DECEMBER 1987). */
/* S. ASHBY, M. SEAGER, "A PROPOSED STANDARD FOR ITERATIVE */
/* LINEAR SOLVERS", LAWRENCE LIVERMORE NATIONAL */
/* LABORATORY REPORT (TO APPEAR). */
/* ***ROUTINES CALLED SONEST,R1MACH,SCGCHK,SAXPY,SNRM2 */
/* ***END PROLOGUE SPCGNR */
/* *** DECLARATIONS *** */
/* CCCCCIMPLICIT DOUBLE PRECISION(A-H,O-Z) */
/* ***FIRST EXECUTABLE STATEMENT SPCGNR */
/* Parameter adjustments */
--ap;
--h__;
--r__;
--b;
--x;
--iparam;
--rparam;
--iwork;
--d__;
--e;
--cndwk;
/* Function Body */
/* L1: */
/* *** INITIALIZE INPUT PARAMETERS *** */
iounit = iparam[5];
istop = iparam[8];
itmax = iparam[9];
icycle = iparam[31];
nce = iparam[32];
kmax = icycle * nce;
errtol = rparam[1];
cndpns = dmax(1.f,rparam[31]);
/* *** CHECK THE INPUT PARAMETERS *** */
if (iounit > 0) {
io___9.ciunit = iounit;
s_wsfe(&io___9);
e_wsfe();
}
scgchk_(&iparam[1], &rparam[1], n);
if (iounit > 0) {
io___10.ciunit = iounit;
s_wsfe(&io___10);
do_fio(&c__1, (char *)&cndpns, (ftnlen)sizeof(real));
e_wsfe();
}
if (iounit > 0) {
io___11.ciunit = iounit;
s_wsfe(&io___11);
e_wsfe();
}
/* *** INITIALIZE D(1), EIGMIN, EIGMAX, ITERS *** */
d__[1] = 0.f;
eigmin = r1mach_(&c__2);
eigmax = r1mach_(&c__1);
iters = 0;
/* *** COMPUTE STOPPING CRITERION DENOMINATOR *** */
denom = 1.f;
if (istop == 2) {
denom = snrm2_(n, &b[1], &c__1);
}
if (istop == 0 || istop == 4) {
(*matvec)(&c__1, a, ia, &wdumm, &b[1], &r__[1], n);
(*pcondl)(&c__1, q, iq, &wdumm, &r__[1], &ap[1], n);
(*pcondl)(&c__0, q, iq, &wdumm, &ap[1], &r__[1], n);
denom = snrm2_(n, &r__[1], &c__1);
}
/* *** TELL MSSTOP WHETHER OR NOT I AM SUPPLYING THE STOPPING QUANTITY *** */
if (istop == 1 || istop == 2) {
ido = 0;
} else {
ido = 1;
}
/* *** COMPUTE THE INITIAL S = C*CT*AT*R *** */
(*matvec)(&c__0, a, ia, &wdummy, &x[1], &r__[1], n);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
r__[i__] = b[i__] - r__[i__];
/* L20: */
}
(*matvec)(&c__1, a, ia, &wdummy, &r__[1], &ap[1], n);
(*pcondl)(&c__1, q, iq, &wdummy, &ap[1], &h__[1], n);
(*pcondl)(&c__0, q, iq, &wdummy, &h__[1], &b[1], n);
s0norm = snrm2_(n, &b[1], &c__1);
if (iounit > 0) {
io___21.ciunit = iounit;
s_wsfe(&io___21);
do_fio(&c__1, (char *)&s0norm, (ftnlen)sizeof(real));
e_wsfe();
}
/* *** CHECK THE INITIAL RESIDUAL *** */
jstop = msstop_(&istop, &iters, &itmax, &errtol, &stptst, ierror, &ap[1],
&sdumm, &zdumm, n, &rndumm, &s0norm, &s0norm, &denom, &cndpns, &
ido);
if (jstop == 1) {
goto L90;
}
/* *** INITIALIZE HNORM *** */
hnorm = snrm2_(n, &h__[1], &c__1);
/* *** UPDATE ITERS AND COMPUTE A*P *** */
L30:
++iters;
(*matvec)(&c__0, a, ia, &wdummy, &b[1], &ap[1], n);
/* *** COMPUTE NEW X *** */
/* Computing 2nd power */
r__1 = hnorm / snrm2_(n, &ap[1], &c__1);
alpha = r__1 * r__1;
saxpy_(n, &alpha, &b[1], &c__1, &x[1], &c__1);
/* *** COMPUTE AND CHECK NEW S *** */
r__1 = -alpha;
saxpy_(n, &r__1, &ap[1], &c__1, &r__[1], &c__1);
(*matvec)(&c__1, a, ia, &wdummy, &r__[1], &ap[1], n);
(*pcondl)(&c__1, q, iq, &wdummy, &ap[1], &h__[1], n);
(*pcondl)(&c__0, q, iq, &wdummy, &h__[1], &ap[1], n);
snorm = snrm2_(n, &ap[1], &c__1);
if (iounit > 0) {
io___30.ciunit = iounit;
s_wsfe(&io___30);
do_fio(&c__1, (char *)&iters, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&snorm, (ftnlen)sizeof(real));
r__1 = snorm / s0norm;
do_fio(&c__1, (char *)&r__1, (ftnlen)sizeof(real));
e_wsfe();
}
/* *** TEST TO HALT *** */
jstop = msstop_(&istop, &iters, &itmax, &errtol, &stptst, ierror, &ap[1],
&sdumm, &zdumm, n, &rndumm, &snorm, &snorm, &denom, &cndpns, &ido)
;
if (jstop == 1) {
goto L90;
}
/* *** COMPUTE NEW P *** */
oldhnm = hnorm;
hnorm = snrm2_(n, &h__[1], &c__1);
/* Computing 2nd power */
r__1 = hnorm / oldhnm;
beta = r__1 * r__1;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
b[i__] = ap[i__] + beta * b[i__];
/* L40: */
}
/* *** UPDATE CONDITION NUMBER *** */
if (iters <= kmax && istop == 0) {
/* *** UPDATE PARAMETERS *** */
isp1 = iters + 1;
ralpha = 1.f / alpha;
d__[iters] += ralpha;
d__[isp1] = beta * ralpha;
e[isp1] = -sqrt(beta) * ralpha;
if (iters % icycle == 0) {
if (iounit > 0) {
io___35.ciunit = iounit;
s_wsfe(&io___35);
e_wsfe();
}
sonest_(&iounit, &d__[1], &e[1], &cndwk[1], &cndwk[kmax + 1], &
iwork[1], &iters, &eigmin, &eigmax, &cndpns);
}
}
/* *** RESUME PCGNR ITERATION *** */
goto L30;
/* *** FINISHED: PASS BACK ITERATION INFO *** */
L90:
iparam[10] = iters;
rparam[2] = stptst;
rparam[31] = cndpns;
rparam[34] = snorm / s0norm;
return 0;
} /* spcgnr_ */
/* Subroutine */ int qawfe_(U_fp f, real *a, real *omega, integer *integr,
real *epsabs, integer *limlst, integer *limit, integer *maxp1, real *
result, real *abserr, integer *neval, integer *ier, real *rslst, real
*erlst, integer *ierlst, integer *lst, real *alist__, real *blist,
real *rlist, real *elist, integer *iord, integer *nnlog, real *chebmo)
{
/* Initialized data */
static real p = (float).9;
static real pi = (float)3.1415926535897932;
/* System generated locals */
integer chebmo_dim1, chebmo_offset, i__1;
real r__1, r__2;
/* Local variables */
real fact, epsa;
extern /* Subroutine */ int qelg_(integer *, real *, real *, real *, real
*, integer *);
integer last, nres;
real psum[52];
integer l;
extern /* Subroutine */ int qagie_(U_fp, real *, integer *, real *, real *
, integer *, real *, real *, integer *, integer *, real *, real *,
real *, real *, integer *, integer *);
real cycle;
extern /* Subroutine */ int qawoe_(U_fp, real *, real *, real *, integer *
, real *, real *, integer *, integer *, integer *, real *, real *,
integer *, integer *, integer *, real *, real *, real *, real *,
integer *, integer *, integer *, real *);
integer ktmin;
real c1, c2, uflow, p1;
extern doublereal r1mach_(integer *);
real res3la[3];
integer numrl2;
real dl, ep;
integer ll;
real abseps, correc;
integer momcom;
real reseps, errsum, dla, drl, eps;
integer nev;
/* ***begin prologue qawfe */
/* ***date written 800101 (yymmdd) */
/* ***revision date 830518 (yymmdd) */
/* ***category no. h2a3a1 */
/* ***keywords automatic integrator, special-purpose, */
/* fourier integrals, */
/* integration between zeros with dqawoe, */
/* convergence acceleration with dqelg */
/* ***author piessens,robert,appl. math. & progr. div. - k.u.leuven */
/* dedoncker,elise,appl. math. & progr. div. - k.u.leuven */
/* ***purpose the routine calculates an approximation result to a */
/* given fourier integal */
/* i = integral of f(x)*w(x) over (a,infinity) */
/* where w(x) = cos(omega*x) or w(x) = sin(omega*x), */
/* hopefully satisfying following claim for accuracy */
/* abs(i-result).le.epsabs. */
/* ***description */
/* computation of fourier integrals */
/* standard fortran subroutine */
/* real version */
/* parameters */
/* on entry */
/* f - real */
/* function subprogram defining the integrand */
/* function f(x). the actual name for f needs to */
/* be declared e x t e r n a l in the driver program. */
/* a - real */
/* lower limit of integration */
/* omega - real */
/* parameter in the weight function */
/* integr - integer */
/* indicates which weight function is used */
/* integr = 1 w(x) = cos(omega*x) */
/* integr = 2 w(x) = sin(omega*x) */
/* if integr.ne.1.and.integr.ne.2, the routine will */
/* end with ier = 6. */
/* epsabs - real */
/* absolute accuracy requested, epsabs.gt.0 */
/* if epsabs.le.0, the routine will end with ier = 6. */
/* limlst - integer */
/* limlst gives an upper bound on the number of */
/* cycles, limlst.ge.1. */
/* if limlst.lt.3, the routine will end with ier = 6. */
/* limit - integer */
/* gives an upper bound on the number of subintervals */
/* allowed in the partition of each cycle, limit.ge.1 */
/* each cycle, limit.ge.1. */
/* maxp1 - integer */
/* gives an upper bound on the number of */
/* chebyshev moments which can be stored, i.e. */
/* for the intervals of lengths abs(b-a)*2**(-l), */
/* l=0,1, ..., maxp1-2, maxp1.ge.1 */
/* on return */
/* result - real */
/* approximation to the integral x */
/* abserr - real */
/* estimate of the modulus of the absolute error, */
/* which should equal or exceed abs(i-result) */
/* neval - integer */
/* number of integrand evaluations */
/* ier - ier = 0 normal and reliable termination of */
/* the routine. it is assumed that the */
/* requested accuracy has been achieved. */
/* ier.gt.0 abnormal termination of the routine. the */
/* estimates for integral and error are less */
/* reliable. it is assumed that the requested */
/* accuracy has not been achieved. */
/* error messages */
/* if omega.ne.0 */
/* ier = 1 maximum number of cycles allowed */
/* has been achieved., i.e. of subintervals */
/* (a+(k-1)c,a+kc) where */
/* c = (2*int(abs(omega))+1)*pi/abs(omega), */
/* for k = 1, 2, ..., lst. */
/* one can allow more cycles by increasing */
/* the value of limlst (and taking the */
/* according dimension adjustments into */
/* account). */
/* examine the array iwork which contains */
/* the error flags on the cycles, in order to */
/* look for eventual local integration */
/* difficulties. if the position of a local */
/* difficulty can be determined (e.g. */
/* singularity, discontinuity within the */
/* interval) one will probably gain from */
/* splitting up the interval at this point */
/* and calling appropriate integrators on */
/* the subranges. */
/* = 4 the extrapolation table constructed for */
/* convergence acceleration of the series */
/* formed by the integral contributions over */
/* the cycles, does not converge to within */
/* the requested accuracy. as in the case of */
/* ier = 1, it is advised to examine the */
/* array iwork which contains the error */
/* flags on the cycles. */
/* = 6 the input is invalid because */
/* (integr.ne.1 and integr.ne.2) or */
/* epsabs.le.0 or limlst.lt.3. */
/* result, abserr, neval, lst are set */
/* to zero. */
/* = 7 bad integrand behaviour occurs within one */
/* or more of the cycles. location and type */
/* of the difficulty involved can be */
/* determined from the vector ierlst. here */
/* lst is the number of cycles actually */
/* needed (see below). */
/* ierlst(k) = 1 the maximum number of */
/* subdivisions (= limit) has */
/* been achieved on the k th */
/* cycle. */
/* = 2 occurrence of roundoff error */
/* is detected and prevents the */
/* tolerance imposed on the */
/* k th cycle, from being */
/* achieved. */
/* = 3 extremely bad integrand */
/* behaviour occurs at some */
/* points of the k th cycle. */
/* = 4 the integration procedure */
/* over the k th cycle does */
/* not converge (to within the */
/* required accuracy) due to */
/* roundoff in the */
/* extrapolation procedure */
/* invoked on this cycle. it */
/* is assumed that the result */
/* on this interval is the */
/* best which can be obtained. */
/* = 5 the integral over the k th */
/* cycle is probably divergent */
/* or slowly convergent. it */
/* must be noted that */
/* divergence can occur with */
/* any other value of */
/* ierlst(k). */
/* if omega = 0 and integr = 1, */
/* the integral is calculated by means of dqagie */
/* and ier = ierlst(1) (with meaning as described */
/* for ierlst(k), k = 1). */
/* rslst - real */
/* vector of dimension at least limlst */
/* rslst(k) contains the integral contribution */
/* over the interval (a+(k-1)c,a+kc) where */
/* c = (2*int(abs(omega))+1)*pi/abs(omega), */
/* k = 1, 2, ..., lst. */
/* note that, if omega = 0, rslst(1) contains */
/* the value of the integral over (a,infinity). */
/* erlst - real */
/* vector of dimension at least limlst */
/* erlst(k) contains the error estimate corresponding */
/* with rslst(k). */
/* ierlst - integer */
/* vector of dimension at least limlst */
/* ierlst(k) contains the error flag corresponding */
/* with rslst(k). for the meaning of the local error */
/* flags see description of output parameter ier. */
/* lst - integer */
/* number of subintervals needed for the integration */
/* if omega = 0 then lst is set to 1. */
/* alist, blist, rlist, elist - real */
/* vector of dimension at least limit, */
/* iord, nnlog - integer */
/* vector of dimension at least limit, providing */
/* space for the quantities needed in the subdivision */
/* process of each cycle */
/* chebmo - real */
/* array of dimension at least (maxp1,25), providing */
/* space for the chebyshev moments needed within the */
/* cycles */
/* ***references (none) */
/* ***routines called qagie,qawoe,qelg,r1mach */
/* ***end prologue qawfe */
/* the dimension of psum is determined by the value of */
/* limexp in subroutine qelg (psum must be */
/* of dimension (limexp+2) at least). */
/* list of major variables */
/* ----------------------- */
/* c1, c2 - end points of subinterval (of length */
/* cycle) */
/* cycle - (2*int(abs(omega))+1)*pi/abs(omega) */
/* psum - vector of dimension at least (limexp+2) */
/* (see routine qelg) */
/* psum contains the part of the epsilon */
/* table which is still needed for further */
/* computations. */
/* each element of psum is a partial sum of */
/* the series which should sum to the value of */
/* the integral. */
/* errsum - sum of error estimates over the */
/* subintervals, calculated cumulatively */
/* epsa - absolute tolerance requested over current */
/* subinterval */
/* chebmo - array containing the modified chebyshev */
/* moments (see also routine qc25f) */
/* Parameter adjustments */
--ierlst;
--erlst;
--rslst;
--nnlog;
--iord;
--elist;
--rlist;
--blist;
--alist__;
chebmo_dim1 = *maxp1;
chebmo_offset = 1 + chebmo_dim1 * 1;
chebmo -= chebmo_offset;
/* Function Body */
/* test on validity of parameters */
/* ------------------------------ */
/* ***first executable statement qawfe */
*result = (float)0.;
*abserr = (float)0.;
*neval = 0;
*lst = 0;
*ier = 0;
if (*integr != 1 && *integr != 2 || *epsabs <= (float)0. || *limlst < 3) {
*ier = 6;
}
if (*ier == 6) {
goto L999;
}
if (*omega != (float)0.) {
goto L10;
}
/* integration by qagie if omega is zero */
/* -------------------------------------- */
if (*integr == 1) {
qagie_((U_fp)f, &c_b4, &c__1, epsabs, &c_b4, limit, result, abserr,
neval, ier, &alist__[1], &blist[1], &rlist[1], &elist[1], &
iord[1], &last);
}
rslst[1] = *result;
erlst[1] = *abserr;
ierlst[1] = *ier;
*lst = 1;
goto L999;
/* initializations */
/* --------------- */
L10:
l = dabs(*omega);
dl = (real) ((l << 1) + 1);
cycle = dl * pi / dabs(*omega);
*ier = 0;
ktmin = 0;
*neval = 0;
numrl2 = 0;
nres = 0;
c1 = *a;
c2 = cycle + *a;
p1 = (float)1. - p;
eps = *epsabs;
uflow = r1mach_(&c__1);
if (*epsabs > uflow / p1) {
eps = *epsabs * p1;
}
ep = eps;
fact = (float)1.;
correc = (float)0.;
*abserr = (float)0.;
errsum = (float)0.;
/* main do-loop */
/* ------------ */
i__1 = *limlst;
for (*lst = 1; *lst <= i__1; ++(*lst)) {
/* integrate over current subinterval. */
dla = (real) (*lst);
epsa = eps * fact;
qawoe_((U_fp)f, &c1, &c2, omega, integr, &epsa, &c_b4, limit, lst,
maxp1, &rslst[*lst], &erlst[*lst], &nev, &ierlst[*lst], &last,
&alist__[1], &blist[1], &rlist[1], &elist[1], &iord[1], &
nnlog[1], &momcom, &chebmo[chebmo_offset]);
*neval += nev;
fact *= p;
errsum += erlst[*lst];
drl = (r__1 = rslst[*lst], dabs(r__1)) * (float)50.;
/* test on accuracy with partial sum */
if (errsum + drl <= *epsabs && *lst >= 6) {
goto L80;
}
/* Computing MAX */
r__1 = correc, r__2 = erlst[*lst];
correc = dmax(r__1,r__2);
if (ierlst[*lst] != 0) {
/* Computing MAX */
r__1 = ep, r__2 = correc * p1;
eps = dmax(r__1,r__2);
}
if (ierlst[*lst] != 0) {
*ier = 7;
}
if (*ier == 7 && errsum + drl <= correc * (float)10. && *lst > 5) {
goto L80;
}
++numrl2;
if (*lst > 1) {
goto L20;
}
psum[0] = rslst[1];
goto L40;
L20:
psum[numrl2 - 1] = psum[ll - 1] + rslst[*lst];
if (*lst == 2) {
goto L40;
}
/* test on maximum number of subintervals */
if (*lst == *limlst) {
*ier = 1;
}
/* perform new extrapolation */
qelg_(&numrl2, psum, &reseps, &abseps, res3la, &nres);
/* test whether extrapolated result is influenced by */
/* roundoff */
++ktmin;
if (ktmin >= 15 && *abserr <= (errsum + drl) * (float).001) {
*ier = 4;
}
if (abseps > *abserr && *lst != 3) {
goto L30;
}
*abserr = abseps;
*result = reseps;
ktmin = 0;
/* if ier is not 0, check whether direct result (partial */
/* sum) or extrapolated result yields the best integral */
/* approximation */
if (*abserr + correc * (float)10. <= *epsabs || *abserr <= *epsabs &&
correc * (float)10. >= *epsabs) {
goto L60;
}
L30:
if (*ier != 0 && *ier != 7) {
goto L60;
}
L40:
ll = numrl2;
c1 = c2;
c2 += cycle;
/* L50: */
}
/* set final result and error estimate */
/* ----------------------------------- */
L60:
*abserr += correc * (float)10.;
if (*ier == 0) {
goto L999;
}
if (*result != (float)0. && psum[numrl2 - 1] != (float)0.) {
goto L70;
}
if (*abserr > errsum) {
goto L80;
}
if (psum[numrl2 - 1] == (float)0.) {
goto L999;
}
L70:
if (*abserr / dabs(*result) > (errsum + drl) / (r__1 = psum[numrl2 - 1],
dabs(r__1))) {
goto L80;
}
if (*ier >= 1 && *ier != 7) {
*abserr += drl;
}
goto L999;
L80:
*result = psum[numrl2 - 1];
*abserr = errsum + drl;
L999:
return 0;
} /* qawfe_ */
/* Subroutine */ int qagse_(E_fp f, real *a, real *b, real *epsabs, real *
epsrel, integer *limit, real *result, real *abserr, integer *neval,
integer *ier, real *alist__, real *blist, real *rlist, real *elist,
integer *iord, integer *last)
{
/* System generated locals */
integer i__1, i__2;
real r__1, r__2;
/* Local variables */
real area;
extern /* Subroutine */ int qelg_(integer *, real *, real *, real *, real
*, integer *);
real dres;
integer ksgn, nres;
real area1, area2, area12;
integer k;
real small, erro12;
integer ierro;
real a1, a2, b1, b2, defab1, defab2, oflow;
integer ktmin, nrmax;
real uflow;
logical noext;
extern /* Subroutine */ int qpsrt_(integer *, integer *, integer *, real *
, real *, integer *, integer *);
extern doublereal r1mach_(integer *);
integer iroff1, iroff2, iroff3;
real res3la[3], error1, error2;
integer id;
real rlist2[52];
integer numrl2;
real defabs, epmach, erlarg, abseps, correc, errbnd, resabs;
integer jupbnd;
real erlast, errmax;
integer maxerr;
real reseps;
logical extrap;
real ertest, errsum;
extern /* Subroutine */ int qk21_(E_fp, real *, real *, real *, real *,
real *, real *);
/* ***begin prologue qagse */
/* ***date written 800101 (yymmdd) */
/* ***revision date 830518 (yymmdd) */
/* ***category no. h2a1a1 */
/* ***keywords automatic integrator, general-purpose, */
/* (end point) singularities, extrapolation, */
/* globally adaptive */
/* ***author piessens,robert,appl. math. & progr. div. - k.u.leuven */
/* de doncker,elise,appl. math. & progr. div. - k.u.leuven */
/* ***purpose the routine calculates an approximation result to a given */
/* definite integral i = integral of f over (a,b), */
/* hopefully satisfying following claim for accuracy */
/* abs(i-result).le.max(epsabs,epsrel*abs(i)). */
/* ***description */
/* computation of a definite integral */
/* standard fortran subroutine */
/* real version */
/* parameters */
/* on entry */
/* f - real */
/* function subprogram defining the integrand */
/* function f(x). the actual name for f needs to be */
/* declared e x t e r n a l in the driver program. */
/* a - real */
/* lower limit of integration */
/* b - real */
/* upper limit of integration */
/* epsabs - real */
/* absolute accuracy requested */
/* epsrel - real */
/* relative accuracy requested */
/* if epsabs.le.0 */
/* and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), */
/* the routine will end with ier = 6. */
/* limit - integer */
/* gives an upperbound on the number of subintervals */
/* in the partition of (a,b) */
/* on return */
/* result - real */
/* approximation to the integral */
/* abserr - real */
/* estimate of the modulus of the absolute error, */
/* which should equal or exceed abs(i-result) */
/* neval - integer */
/* number of integrand evaluations */
/* ier - integer */
/* ier = 0 normal and reliable termination of the */
/* routine. it is assumed that the requested */
/* accuracy has been achieved. */
/* ier.gt.0 abnormal termination of the routine */
/* the estimates for integral and error are */
/* less reliable. it is assumed that the */
/* requested accuracy has not been achieved. */
/* error messages */
/* = 1 maximum number of subdivisions allowed */
/* has been achieved. one can allow more sub- */
/* divisions by increasing the value of limit */
/* (and taking the according dimension */
/* adjustments into account). however, if */
/* this yields no improvement it is advised */
/* to analyze the integrand in order to */
/* determine the integration difficulties. if */
/* the position of a local difficulty can be */
/* determined (e.g. singularity, */
/* discontinuity within the interval) one */
/* will probably gain from splitting up the */
/* interval at this point and calling the */
/* integrator on the subranges. if possible, */
/* an appropriate special-purpose integrator */
/* should be used, which is designed for */
/* handling the type of difficulty involved. */
/* = 2 the occurrence of roundoff error is detec- */
/* ted, which prevents the requested */
/* tolerance from being achieved. */
/* the error may be under-estimated. */
/* = 3 extremely bad integrand behaviour */
/* occurs at some points of the integration */
/* interval. */
/* = 4 the algorithm does not converge. */
/* roundoff error is detected in the */
/* extrapolation table. */
/* it is presumed that the requested */
/* tolerance cannot be achieved, and that the */
/* returned result is the best which can be */
/* obtained. */
/* = 5 the integral is probably divergent, or */
/* slowly convergent. it must be noted that */
/* divergence can occur with any other value */
/* of ier. */
/* = 6 the input is invalid, because */
/* epsabs.le.0 and */
/* epsrel.lt.max(50*rel.mach.acc.,0.5d-28). */
/* result, abserr, neval, last, rlist(1), */
/* iord(1) and elist(1) are set to zero. */
/* alist(1) and blist(1) are set to a and b */
/* respectively. */
/* alist - real */
/* vector of dimension at least limit, the first */
/* last elements of which are the left end points */
/* of the subintervals in the partition of the */
/* given integration range (a,b) */
/* blist - real */
/* vector of dimension at least limit, the first */
/* last elements of which are the right end points */
/* of the subintervals in the partition of the given */
/* integration range (a,b) */
/* rlist - real */
/* vector of dimension at least limit, the first */
/* last elements of which are the integral */
/* approximations on the subintervals */
/* elist - real */
/* vector of dimension at least limit, the first */
/* last elements of which are the moduli of the */
/* absolute error estimates on the subintervals */
/* iord - integer */
/* vector of dimension at least limit, the first k */
/* elements of which are pointers to the */
/* error estimates over the subintervals, */
/* such that elist(iord(1)), ..., elist(iord(k)) */
/* form a decreasing sequence, with k = last */
/* if last.le.(limit/2+2), and k = limit+1-last */
/* otherwise */
/* last - integer */
/* number of subintervals actually produced in the */
/* subdivision process */
/* ***references (none) */
/* ***routines called qelg,qk21,qpsrt,r1mach */
/* ***end prologue qagse */
/* the dimension of rlist2 is determined by the value of */
/* limexp in subroutine qelg (rlist2 should be of dimension */
/* (limexp+2) at least). */
/* list of major variables */
/* ----------------------- */
/* alist - list of left end points of all subintervals */
/* considered up to now */
/* blist - list of right end points of all subintervals */
/* considered up to now */
/* rlist(i) - approximation to the integral over */
/* (alist(i),blist(i)) */
/* rlist2 - array of dimension at least limexp+2 */
/* containing the part of the epsilon table */
/* which is still needed for further computations */
/* elist(i) - error estimate applying to rlist(i) */
/* maxerr - pointer to the interval with largest error */
/* estimate */
/* errmax - elist(maxerr) */
/* erlast - error on the interval currently subdivided */
/* (before that subdivision has taken place) */
/* area - sum of the integrals over the subintervals */
/* errsum - sum of the errors over the subintervals */
/* errbnd - requested accuracy max(epsabs,epsrel* */
/* abs(result)) */
/* *****1 - variable for the left interval */
/* *****2 - variable for the right interval */
/* last - index for subdivision */
/* nres - number of calls to the extrapolation routine */
/* numrl2 - number of elements currently in rlist2. if an */
/* appropriate approximation to the compounded */
/* integral has been obtained it is put in */
/* rlist2(numrl2) after numrl2 has been increased */
/* by one. */
/* small - length of the smallest interval considered */
/* up to now, multiplied by 1.5 */
/* erlarg - sum of the errors over the intervals larger */
/* than the smallest interval considered up to now */
/* extrap - logical variable denoting that the routine */
/* is attempting to perform extrapolation */
/* i.e. before subdividing the smallest interval */
/* we try to decrease the value of erlarg. */
/* noext - logical variable denoting that extrapolation */
/* is no longer allowed (true value) */
/* machine dependent constants */
/* --------------------------- */
/* epmach is the largest relative spacing. */
/* uflow is the smallest positive magnitude. */
/* oflow is the largest positive magnitude. */
/* ***first executable statement qagse */
/* Parameter adjustments */
--iord;
--elist;
--rlist;
--blist;
--alist__;
/* Function Body */
epmach = r1mach_(&c__4);
/* test on validity of parameters */
/* ------------------------------ */
*ier = 0;
*neval = 0;
*last = 0;
*result = (float)0.;
*abserr = (float)0.;
alist__[1] = *a;
blist[1] = *b;
rlist[1] = (float)0.;
elist[1] = (float)0.;
/* Computing MAX */
r__1 = epmach * (float)50.;
if (*epsabs <= (float)0. && *epsrel < dmax(r__1,(float)5e-15)) {
*ier = 6;
}
if (*ier == 6) {
goto L999;
}
/* first approximation to the integral */
/* ----------------------------------- */
uflow = r1mach_(&c__1);
oflow = r1mach_(&c__2);
ierro = 0;
qk21_((E_fp)f, a, b, result, abserr, &defabs, &resabs);
/* test on accuracy. */
dres = dabs(*result);
/* Computing MAX */
r__1 = *epsabs, r__2 = *epsrel * dres;
errbnd = dmax(r__1,r__2);
*last = 1;
rlist[1] = *result;
elist[1] = *abserr;
iord[1] = 1;
if (*abserr <= epmach * (float)100. * defabs && *abserr > errbnd) {
*ier = 2;
}
if (*limit == 1) {
*ier = 1;
}
if (*ier != 0 || *abserr <= errbnd && *abserr != resabs || *abserr == (
float)0.) {
goto L140;
}
/* initialization */
/* -------------- */
rlist2[0] = *result;
errmax = *abserr;
maxerr = 1;
area = *result;
errsum = *abserr;
*abserr = oflow;
nrmax = 1;
nres = 0;
numrl2 = 2;
ktmin = 0;
extrap = FALSE_;
noext = FALSE_;
iroff1 = 0;
iroff2 = 0;
iroff3 = 0;
ksgn = -1;
if (dres >= ((float)1. - epmach * (float)50.) * defabs) {
ksgn = 1;
}
/* main do-loop */
/* ------------ */
i__1 = *limit;
for (*last = 2; *last <= i__1; ++(*last)) {
/* bisect the subinterval with the nrmax-th largest */
/* error estimate. */
a1 = alist__[maxerr];
b1 = (alist__[maxerr] + blist[maxerr]) * (float).5;
a2 = b1;
b2 = blist[maxerr];
erlast = errmax;
qk21_((E_fp)f, &a1, &b1, &area1, &error1, &resabs, &defab1);
qk21_((E_fp)f, &a2, &b2, &area2, &error2, &resabs, &defab2);
/* improve previous approximations to integral */
/* and error and test for accuracy. */
area12 = area1 + area2;
erro12 = error1 + error2;
errsum = errsum + erro12 - errmax;
area = area + area12 - rlist[maxerr];
if (defab1 == error1 || defab2 == error2) {
goto L15;
}
if ((r__1 = rlist[maxerr] - area12, dabs(r__1)) > dabs(area12) * (
float)1e-5 || erro12 < errmax * (float).99) {
goto L10;
}
if (extrap) {
++iroff2;
}
if (! extrap) {
++iroff1;
}
L10:
if (*last > 10 && erro12 > errmax) {
++iroff3;
}
L15:
rlist[maxerr] = area1;
rlist[*last] = area2;
/* Computing MAX */
r__1 = *epsabs, r__2 = *epsrel * dabs(area);
errbnd = dmax(r__1,r__2);
/* test for roundoff error and eventually */
/* set error flag. */
if (iroff1 + iroff2 >= 10 || iroff3 >= 20) {
*ier = 2;
}
if (iroff2 >= 5) {
ierro = 3;
}
/* set error flag in the case that the number of */
/* subintervals equals limit. */
if (*last == *limit) {
*ier = 1;
}
/* set error flag in the case of bad integrand behaviour */
/* at a point of the integration range. */
/* Computing MAX */
r__1 = dabs(a1), r__2 = dabs(b2);
if (dmax(r__1,r__2) <= (epmach * (float)100. + (float)1.) * (dabs(a2)
+ uflow * (float)1e3)) {
*ier = 4;
}
/* append the newly-created intervals to the list. */
if (error2 > error1) {
goto L20;
}
alist__[*last] = a2;
blist[maxerr] = b1;
blist[*last] = b2;
elist[maxerr] = error1;
elist[*last] = error2;
goto L30;
L20:
alist__[maxerr] = a2;
alist__[*last] = a1;
blist[*last] = b1;
rlist[maxerr] = area2;
rlist[*last] = area1;
elist[maxerr] = error2;
elist[*last] = error1;
/* call subroutine qpsrt to maintain the descending ordering */
/* in the list of error estimates and select the */
/* subinterval with nrmax-th largest error estimate (to be */
/* bisected next). */
L30:
qpsrt_(limit, last, &maxerr, &errmax, &elist[1], &iord[1], &nrmax);
/* ***jump out of do-loop */
if (errsum <= errbnd) {
goto L115;
}
/* ***jump out of do-loop */
if (*ier != 0) {
goto L100;
}
if (*last == 2) {
goto L80;
}
if (noext) {
goto L90;
}
erlarg -= erlast;
if ((r__1 = b1 - a1, dabs(r__1)) > small) {
erlarg += erro12;
}
if (extrap) {
goto L40;
}
/* test whether the interval to be bisected next is the */
/* smallest interval. */
if ((r__1 = blist[maxerr] - alist__[maxerr], dabs(r__1)) > small) {
goto L90;
}
extrap = TRUE_;
nrmax = 2;
L40:
if (ierro == 3 || erlarg <= ertest) {
goto L60;
}
/* the smallest interval has the largest error. */
/* before bisecting decrease the sum of the errors */
/* over the larger intervals (erlarg) and perform */
/* extrapolation. */
id = nrmax;
jupbnd = *last;
if (*last > *limit / 2 + 2) {
jupbnd = *limit + 3 - *last;
}
i__2 = jupbnd;
for (k = id; k <= i__2; ++k) {
maxerr = iord[nrmax];
errmax = elist[maxerr];
/* ***jump out of do-loop */
if ((r__1 = blist[maxerr] - alist__[maxerr], dabs(r__1)) > small)
{
goto L90;
}
++nrmax;
/* L50: */
}
/* perform extrapolation. */
L60:
++numrl2;
rlist2[numrl2 - 1] = area;
qelg_(&numrl2, rlist2, &reseps, &abseps, res3la, &nres);
++ktmin;
if (ktmin > 5 && *abserr < errsum * (float).001) {
*ier = 5;
}
if (abseps >= *abserr) {
goto L70;
}
ktmin = 0;
*abserr = abseps;
*result = reseps;
correc = erlarg;
/* Computing MAX */
r__1 = *epsabs, r__2 = *epsrel * dabs(reseps);
ertest = dmax(r__1,r__2);
/* ***jump out of do-loop */
if (*abserr <= ertest) {
goto L100;
}
/* prepare bisection of the smallest interval. */
L70:
if (numrl2 == 1) {
noext = TRUE_;
}
if (*ier == 5) {
goto L100;
}
maxerr = iord[1];
errmax = elist[maxerr];
nrmax = 1;
extrap = FALSE_;
small *= (float).5;
erlarg = errsum;
goto L90;
L80:
small = (r__1 = *b - *a, dabs(r__1)) * (float).375;
erlarg = errsum;
ertest = errbnd;
rlist2[1] = area;
L90:
;
}
/* set final result and error estimate. */
/* ------------------------------------ */
L100:
if (*abserr == oflow) {
goto L115;
}
if (*ier + ierro == 0) {
goto L110;
}
if (ierro == 3) {
*abserr += correc;
}
if (*ier == 0) {
*ier = 3;
}
if (*result != (float)0. && area != (float)0.) {
goto L105;
}
if (*abserr > errsum) {
goto L115;
}
if (area == (float)0.) {
goto L130;
}
goto L110;
L105:
if (*abserr / dabs(*result) > errsum / dabs(area)) {
goto L115;
}
/* test on divergence. */
L110:
/* Computing MAX */
r__1 = dabs(*result), r__2 = dabs(area);
if (ksgn == -1 && dmax(r__1,r__2) <= defabs * (float).01) {
goto L130;
}
if ((float).01 > *result / area || *result / area > (float)100. || errsum
> dabs(area)) {
*ier = 6;
}
goto L130;
/* compute global integral sum. */
L115:
*result = (float)0.;
i__1 = *last;
for (k = 1; k <= i__1; ++k) {
*result += rlist[k];
/* L120: */
}
*abserr = errsum;
L130:
if (*ier > 2) {
--(*ier);
}
L140:
*neval = *last * 42 - 21;
L999:
return 0;
} /* qagse_ */
/* DECK BESY1 */
doublereal besy1_(real *x)
{
/* Initialized data */
static real by1cs[14] = { .03208047100611908629f,1.26270789743350045f,
.006499961899923175f,-.08936164528860504117f,
.01325088122175709545f,-8.9790591196483523e-4f,
3.647361487958306e-5f,-1.001374381666e-6f,1.99453965739e-8f,
-3.0230656018e-10f,3.60987815e-12f,-3.487488e-14f,2.7838e-16f,
-1.86e-18f };
static real bm1cs[21] = { .1047362510931285f,.00442443893702345f,
-5.661639504035e-5f,2.31349417339e-6f,-1.7377182007e-7f,
1.89320993e-8f,-2.65416023e-9f,4.4740209e-10f,-8.691795e-11f,
1.891492e-11f,-4.51884e-12f,1.16765e-12f,-3.2265e-13f,9.45e-14f,
-2.913e-14f,9.39e-15f,-3.15e-15f,1.09e-15f,-3.9e-16f,1.4e-16f,
-5e-17f };
static real bth1cs[24] = { .7406014102631385f,-.00457175565963769f,
1.19818510964326e-4f,-6.964561891648e-6f,6.55495621447e-7f,
-8.4066228945e-8f,1.3376886564e-8f,-2.499565654e-9f,5.294951e-10f,
-1.24135944e-10f,3.1656485e-11f,-8.66864e-12f,2.523758e-12f,
-7.75085e-13f,2.49527e-13f,-8.3773e-14f,2.9205e-14f,-1.0534e-14f,
3.919e-15f,-1.5e-15f,5.89e-16f,-2.37e-16f,9.7e-17f,-4e-17f };
static real twodpi = .63661977236758134f;
static real pi4 = .78539816339744831f;
static logical first = TRUE_;
/* System generated locals */
real ret_val, r__1, r__2;
/* Local variables */
static real y, z__;
static integer ntm1, nty1;
static real ampl, xmin, xmax, xsml;
extern doublereal besj1_(real *);
static integer ntth1;
static real theta;
extern doublereal csevl_(real *, real *, integer *);
extern integer inits_(real *, integer *, real *);
extern doublereal r1mach_(integer *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE BESY1 */
/* ***PURPOSE Compute the Bessel function of the second kind of order */
/* one. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C10A1 */
/* ***TYPE SINGLE PRECISION (BESY1-S, DBESY1-D) */
/* ***KEYWORDS BESSEL FUNCTION, FNLIB, ORDER ONE, SECOND KIND, */
/* SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* BESY1(X) calculates the Bessel function of the second kind of */
/* order one for real argument X. */
/* Series for BY1 on the interval 0. to 1.60000D+01 */
/* with weighted error 1.87E-18 */
/* log weighted error 17.73 */
/* significant figures required 17.83 */
/* decimal places required 18.30 */
/* Series for BM1 on the interval 0. to 6.25000D-02 */
/* with weighted error 5.61E-17 */
/* log weighted error 16.25 */
/* significant figures required 14.97 */
/* decimal places required 16.91 */
/* Series for BTH1 on the interval 0. to 6.25000D-02 */
/* with weighted error 4.10E-17 */
/* log weighted error 16.39 */
/* significant figures required 15.96 */
/* decimal places required 17.08 */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED BESJ1, CSEVL, INITS, R1MACH, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 770401 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) */
/* ***END PROLOGUE BESY1 */
/* ***FIRST EXECUTABLE STATEMENT BESY1 */
if (first) {
r__1 = r1mach_(&c__3) * .1f;
nty1 = inits_(by1cs, &c__14, &r__1);
r__1 = r1mach_(&c__3) * .1f;
ntm1 = inits_(bm1cs, &c__21, &r__1);
r__1 = r1mach_(&c__3) * .1f;
ntth1 = inits_(bth1cs, &c__24, &r__1);
/* Computing MAX */
r__1 = log(r1mach_(&c__1)), r__2 = -log(r1mach_(&c__2));
xmin = exp(dmax(r__1,r__2) + .01f) * 1.571f;
xsml = sqrt(r1mach_(&c__3) * 4.f);
xmax = 1.f / r1mach_(&c__4);
}
first = FALSE_;
if (*x <= 0.f) {
xermsg_("SLATEC", "BESY1", "X IS ZERO OR NEGATIVE", &c__1, &c__2, (
ftnlen)6, (ftnlen)5, (ftnlen)21);
}
if (*x > 4.f) {
goto L20;
}
if (*x < xmin) {
xermsg_("SLATEC", "BESY1", "X SO SMALL Y1 OVERFLOWS", &c__3, &c__2, (
ftnlen)6, (ftnlen)5, (ftnlen)23);
}
y = 0.f;
if (*x > xsml) {
y = *x * *x;
}
r__1 = y * .125f - 1.f;
ret_val = twodpi * log(*x * .5f) * besj1_(x) + (csevl_(&r__1, by1cs, &
nty1) + .5f) / *x;
return ret_val;
L20:
if (*x > xmax) {
xermsg_("SLATEC", "BESY1", "NO PRECISION BECAUSE X IS BIG", &c__2, &
c__2, (ftnlen)6, (ftnlen)5, (ftnlen)29);
}
/* Computing 2nd power */
r__1 = *x;
z__ = 32.f / (r__1 * r__1) - 1.f;
ampl = (csevl_(&z__, bm1cs, &ntm1) + .75f) / sqrt(*x);
theta = *x - pi4 * 3.f + csevl_(&z__, bth1cs, &ntth1) / *x;
ret_val = ampl * sin(theta);
return ret_val;
} /* besy1_ */
/* DECK BESI1E */
doublereal besi1e_(real *x)
{
/* Initialized data */
static real bi1cs[11] = { -.001971713261099859f,.40734887667546481f,
.034838994299959456f,.001545394556300123f,4.1888521098377e-5f,
7.64902676483e-7f,1.0042493924e-8f,9.9322077e-11f,7.6638e-13f,
4.741e-15f,2.4e-17f };
static real ai1cs[21] = { -.02846744181881479f,-.01922953231443221f,
-6.1151858579437e-4f,-2.06997125335e-5f,8.58561914581e-6f,
1.04949824671e-6f,-2.9183389184e-7f,-1.559378146e-8f,
1.318012367e-8f,-1.44842341e-9f,-2.9085122e-10f,1.2663889e-10f,
-1.664947e-11f,-1.66665e-12f,1.2426e-12f,-2.7315e-13f,2.023e-14f,
7.3e-15f,-3.33e-15f,7.1e-16f,-6e-17f };
static real ai12cs[22] = { .02857623501828014f,-.00976109749136147f,
-1.1058893876263e-4f,-3.88256480887e-6f,-2.5122362377e-7f,
-2.631468847e-8f,-3.83538039e-9f,-5.5897433e-10f,-1.897495e-11f,
3.252602e-11f,1.41258e-11f,2.03564e-12f,-7.1985e-13f,-4.0836e-13f,
-2.101e-14f,4.273e-14f,1.041e-14f,-3.82e-15f,-1.86e-15f,3.3e-16f,
2.8e-16f,-3e-17f };
static logical first = TRUE_;
/* System generated locals */
real ret_val, r__1;
/* Local variables */
static real y;
static integer nti1;
static real xmin, xsml;
static integer ntai1, ntai12;
extern doublereal csevl_(real *, real *, integer *);
extern integer inits_(real *, integer *, real *);
extern doublereal r1mach_(integer *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE BESI1E */
/* ***PURPOSE Compute the exponentially scaled modified (hyperbolic) */
/* Bessel function of the first kind of order one. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C10B1 */
/* ***TYPE SINGLE PRECISION (BESI1E-S, DBSI1E-D) */
/* ***KEYWORDS EXPONENTIALLY SCALED, FIRST KIND, FNLIB, */
/* HYPERBOLIC BESSEL FUNCTION, MODIFIED BESSEL FUNCTION, */
/* ORDER ONE, SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* BESI1E(X) calculates the exponentially scaled modified (hyperbolic) */
/* Bessel function of the first kind of order one for real argument X; */
/* i.e., EXP(-ABS(X))*I1(X). */
/* Series for BI1 on the interval 0. to 9.00000D+00 */
/* with weighted error 2.40E-17 */
/* log weighted error 16.62 */
/* significant figures required 16.23 */
/* decimal places required 17.14 */
/* Series for AI1 on the interval 1.25000D-01 to 3.33333D-01 */
/* with weighted error 6.98E-17 */
/* log weighted error 16.16 */
/* significant figures required 14.53 */
/* decimal places required 16.82 */
/* Series for AI12 on the interval 0. to 1.25000D-01 */
/* with weighted error 3.55E-17 */
/* log weighted error 16.45 */
/* significant figures required 14.69 */
/* decimal places required 17.12 */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 770401 DATE WRITTEN */
/* 890210 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 BESI1E */
/* ***FIRST EXECUTABLE STATEMENT BESI1E */
if (first) {
r__1 = r1mach_(&c__3) * .1f;
nti1 = inits_(bi1cs, &c__11, &r__1);
r__1 = r1mach_(&c__3) * .1f;
ntai1 = inits_(ai1cs, &c__21, &r__1);
r__1 = r1mach_(&c__3) * .1f;
ntai12 = inits_(ai12cs, &c__22, &r__1);
xmin = r1mach_(&c__1) * 2.f;
xsml = sqrt(r1mach_(&c__3) * 4.5f);
}
first = FALSE_;
y = dabs(*x);
if (y > 3.f) {
goto L20;
}
ret_val = 0.f;
if (y == 0.f) {
return ret_val;
}
if (y <= xmin) {
xermsg_("SLATEC", "BESI1E", "ABS(X) SO SMALL I1 UNDERFLOWS", &c__1, &
c__1, (ftnlen)6, (ftnlen)6, (ftnlen)29);
}
if (y > xmin) {
ret_val = *x * .5f;
}
if (y > xsml) {
r__1 = y * y / 4.5f - 1.f;
ret_val = *x * (csevl_(&r__1, bi1cs, &nti1) + .875f);
}
ret_val = exp(-y) * ret_val;
return ret_val;
L20:
if (y <= 8.f) {
r__1 = (48.f / y - 11.f) / 5.f;
ret_val = (csevl_(&r__1, ai1cs, &ntai1) + .375f) / sqrt(y);
}
if (y > 8.f) {
r__1 = 16.f / y - 1.f;
ret_val = (csevl_(&r__1, ai12cs, &ntai12) + .375f) / sqrt(y);
}
ret_val = r_sign(&ret_val, x);
return ret_val;
} /* besi1e_ */
/* 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_ */
/* DECK QELG */
/* Subroutine */ int qelg_(integer *n, real *epstab, real *result, real *
abserr, real *res3la, integer *nres)
{
/* System generated locals */
integer i__1;
real r__1, r__2, r__3;
/* Local variables */
static integer i__;
static real e0, e1, e2, e3;
static integer k1, k2, k3, ib, ie;
static real ss;
static integer ib2;
static real res;
static integer num;
static real err1, err2, err3, tol1, tol2, tol3;
static integer indx;
static real e1abs, oflow, error, delta1, delta2, delta3;
extern doublereal r1mach_(integer *);
static real epmach, epsinf;
static integer newelm, limexp;
/* ***BEGIN PROLOGUE QELG */
/* ***SUBSIDIARY */
/* ***PURPOSE The routine determines the limit of a given sequence of */
/* approximations, by means of the Epsilon algorithm of */
/* P. Wynn. An estimate of the absolute error is also given. */
/* The condensed Epsilon table is computed. Only those */
/* elements needed for the computation of the next diagonal */
/* are preserved. */
/* ***LIBRARY SLATEC */
/* ***TYPE SINGLE PRECISION (QELG-S, DQELG-D) */
/* ***KEYWORDS CONVERGENCE ACCELERATION, EPSILON ALGORITHM, EXTRAPOLATION */
/* ***AUTHOR Piessens, Robert */
/* Applied Mathematics and Programming Division */
/* K. U. Leuven */
/* de Doncker, Elise */
/* Applied Mathematics and Programming Division */
/* K. U. Leuven */
/* ***DESCRIPTION */
/* Epsilon algorithm */
/* Standard fortran subroutine */
/* Real version */
/* PARAMETERS */
/* N - Integer */
/* EPSTAB(N) contains the new element in the */
/* first column of the epsilon table. */
/* EPSTAB - Real */
/* Vector of dimension 52 containing the elements */
/* of the two lower diagonals of the triangular */
/* epsilon table. The elements are numbered */
/* starting at the right-hand corner of the */
/* triangle. */
/* RESULT - Real */
/* Resulting approximation to the integral */
/* ABSERR - Real */
/* Estimate of the absolute error computed from */
/* RESULT and the 3 previous results */
/* RES3LA - Real */
/* Vector of dimension 3 containing the last 3 */
/* results */
/* NRES - Integer */
/* Number of calls to the routine */
/* (should be zero at first call) */
/* ***SEE ALSO QAGIE, QAGOE, QAGPE, QAGSE */
/* ***ROUTINES CALLED R1MACH */
/* ***REVISION HISTORY (YYMMDD) */
/* 800101 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) */
/* 900328 Added TYPE section. (WRB) */
/* ***END PROLOGUE QELG */
/* LIST OF MAJOR VARIABLES */
/* ----------------------- */
/* E0 - THE 4 ELEMENTS ON WHICH THE */
/* E1 COMPUTATION OF A NEW ELEMENT IN */
/* E2 THE EPSILON TABLE IS BASED */
/* E3 E0 */
/* E3 E1 NEW */
/* E2 */
/* NEWELM - NUMBER OF ELEMENTS TO BE COMPUTED IN THE NEW */
/* DIAGONAL */
/* ERROR - ERROR = ABS(E1-E0)+ABS(E2-E1)+ABS(NEW-E2) */
/* RESULT - THE ELEMENT IN THE NEW DIAGONAL WITH LEAST VALUE */
/* OF ERROR */
/* MACHINE DEPENDENT CONSTANTS */
/* --------------------------- */
/* EPMACH IS THE LARGEST RELATIVE SPACING. */
/* OFLOW IS THE LARGEST POSITIVE MAGNITUDE. */
/* LIMEXP IS THE MAXIMUM NUMBER OF ELEMENTS THE EPSILON */
/* TABLE CAN CONTAIN. IF THIS NUMBER IS REACHED, THE UPPER */
/* DIAGONAL OF THE EPSILON TABLE IS DELETED. */
/* ***FIRST EXECUTABLE STATEMENT QELG */
/* Parameter adjustments */
--res3la;
--epstab;
/* Function Body */
epmach = r1mach_(&c__4);
oflow = r1mach_(&c__2);
++(*nres);
*abserr = oflow;
*result = epstab[*n];
if (*n < 3) {
goto L100;
}
limexp = 50;
epstab[*n + 2] = epstab[*n];
newelm = (*n - 1) / 2;
epstab[*n] = oflow;
num = *n;
k1 = *n;
i__1 = newelm;
for (i__ = 1; i__ <= i__1; ++i__) {
k2 = k1 - 1;
k3 = k1 - 2;
res = epstab[k1 + 2];
e0 = epstab[k3];
e1 = epstab[k2];
e2 = res;
e1abs = dabs(e1);
delta2 = e2 - e1;
err2 = dabs(delta2);
/* Computing MAX */
r__1 = dabs(e2);
tol2 = dmax(r__1,e1abs) * epmach;
delta3 = e1 - e0;
err3 = dabs(delta3);
/* Computing MAX */
r__1 = e1abs, r__2 = dabs(e0);
tol3 = dmax(r__1,r__2) * epmach;
if (err2 > tol2 || err3 > tol3) {
goto L10;
}
/* IF E0, E1 AND E2 ARE EQUAL TO WITHIN MACHINE */
/* ACCURACY, CONVERGENCE IS ASSUMED. */
/* RESULT = E2 */
/* ABSERR = ABS(E1-E0)+ABS(E2-E1) */
*result = res;
*abserr = err2 + err3;
/* ***JUMP OUT OF DO-LOOP */
goto L100;
L10:
e3 = epstab[k1];
epstab[k1] = e1;
delta1 = e1 - e3;
err1 = dabs(delta1);
/* Computing MAX */
r__1 = e1abs, r__2 = dabs(e3);
tol1 = dmax(r__1,r__2) * epmach;
/* IF TWO ELEMENTS ARE VERY CLOSE TO EACH OTHER, OMIT */
/* A PART OF THE TABLE BY ADJUSTING THE VALUE OF N */
if (err1 <= tol1 || err2 <= tol2 || err3 <= tol3) {
goto L20;
}
ss = 1.f / delta1 + 1.f / delta2 - 1.f / delta3;
epsinf = (r__1 = ss * e1, dabs(r__1));
/* TEST TO DETECT IRREGULAR BEHAVIOUR IN THE TABLE, AND */
/* EVENTUALLY OMIT A PART OF THE TABLE ADJUSTING THE VALUE */
/* OF N. */
if (epsinf > 1e-4f) {
goto L30;
}
L20:
*n = i__ + i__ - 1;
/* ***JUMP OUT OF DO-LOOP */
goto L50;
/* COMPUTE A NEW ELEMENT AND EVENTUALLY ADJUST */
/* THE VALUE OF RESULT. */
L30:
res = e1 + 1.f / ss;
epstab[k1] = res;
k1 += -2;
error = err2 + (r__1 = res - e2, dabs(r__1)) + err3;
if (error > *abserr) {
goto L40;
}
*abserr = error;
*result = res;
L40:
;
}
/* SHIFT THE TABLE. */
L50:
if (*n == limexp) {
*n = (limexp / 2 << 1) - 1;
}
ib = 1;
if (num / 2 << 1 == num) {
ib = 2;
}
ie = newelm + 1;
i__1 = ie;
for (i__ = 1; i__ <= i__1; ++i__) {
ib2 = ib + 2;
epstab[ib] = epstab[ib2];
ib = ib2;
/* L60: */
}
if (num == *n) {
goto L80;
}
indx = num - *n + 1;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
epstab[i__] = epstab[indx];
++indx;
/* L70: */
}
L80:
if (*nres >= 4) {
goto L90;
}
res3la[*nres] = *result;
*abserr = oflow;
goto L100;
/* COMPUTE ERROR ESTIMATE */
L90:
*abserr = (r__1 = *result - res3la[3], dabs(r__1)) + (r__2 = *result -
res3la[2], dabs(r__2)) + (r__3 = *result - res3la[1], dabs(r__3));
res3la[1] = res3la[2];
res3la[2] = res3la[3];
res3la[3] = *result;
L100:
/* Computing MAX */
r__1 = *abserr, r__2 = epmach * 5.f * dabs(*result);
*abserr = dmax(r__1,r__2);
return 0;
} /* qelg_ */
/* 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_ */
/* 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 CUNK1 */
/* Subroutine */ int cunk1_(complex *z__, real *fnu, integer *kode, integer *
mr, integer *n, complex *y, integer *nz, real *tol, real *elim, real *
alim)
{
/* Initialized data */
static complex czero = {0.f,0.f};
static complex cone = {1.f,0.f};
static real pi = 3.14159265358979324f;
/* System generated locals */
integer i__1, i__2, i__3;
real r__1, r__2;
complex q__1, q__2, q__3, q__4, q__5;
/* Local variables */
static integer i__, j, k, m;
static real x;
static complex c1, c2, s1, s2;
static integer ib, ic;
static complex ck;
static real fn;
static integer il;
static complex cs;
static integer kk;
static complex cy[2];
static integer nw;
static complex rz, zr;
static real c2i, c2m, c2r, rs1, ang;
static complex cfn;
static real asc, fnf;
static integer ifn;
static complex phi[2];
static real cpn;
static integer iuf;
static real fmr;
static complex csr[3], css[3];
static real sgn;
static integer inu;
static real bry[3], spn;
static complex sum[2];
static real aphi;
static complex cscl, phid, crsc, csgn;
extern /* Subroutine */ int cs1s2_(complex *, complex *, complex *,
integer *, real *, real *, integer *);
static complex cspn;
static integer init[2];
static complex cwrk[48] /* was [16][3] */, sumd, zeta1[2], zeta2[2];
static integer iflag, kflag;
static real ascle;
static integer kdflg;
extern /* Subroutine */ int cuchk_(complex *, integer *, real *, real *);
static integer ipard, initd;
extern /* Subroutine */ int cunik_(complex *, real *, integer *, integer *
, real *, integer *, complex *, complex *, complex *, complex *,
complex *);
extern doublereal r1mach_(integer *);
static complex zeta1d, zeta2d;
/* ***BEGIN PROLOGUE CUNK1 */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to CBESK */
/* ***LIBRARY SLATEC */
/* ***TYPE ALL (CUNK1-A, ZUNK1-A) */
/* ***AUTHOR Amos, D. E., (SNL) */
/* ***DESCRIPTION */
/* CUNK1 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE */
/* RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE */
/* UNIFORM ASYMPTOTIC EXPANSION. */
/* MR INDICATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION. */
/* NZ=-1 MEANS AN OVERFLOW WILL OCCUR */
/* ***SEE ALSO CBESK */
/* ***ROUTINES CALLED CS1S2, CUCHK, CUNIK, R1MACH */
/* ***REVISION HISTORY (YYMMDD) */
/* 830501 DATE WRITTEN */
/* 910415 Prologue converted to Version 4.0 format. (BAB) */
/* ***END PROLOGUE CUNK1 */
/* Parameter adjustments */
--y;
/* Function Body */
/* ***FIRST EXECUTABLE STATEMENT CUNK1 */
kdflg = 1;
*nz = 0;
/* ----------------------------------------------------------------------- */
/* EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN */
/* THE UNDERFLOW LIMIT */
/* ----------------------------------------------------------------------- */
r__1 = 1.f / *tol;
q__1.r = r__1, q__1.i = 0.f;
cscl.r = q__1.r, cscl.i = q__1.i;
q__1.r = *tol, q__1.i = 0.f;
crsc.r = q__1.r, crsc.i = q__1.i;
css[0].r = cscl.r, css[0].i = cscl.i;
css[1].r = cone.r, css[1].i = cone.i;
css[2].r = crsc.r, css[2].i = crsc.i;
csr[0].r = crsc.r, csr[0].i = crsc.i;
csr[1].r = cone.r, csr[1].i = cone.i;
csr[2].r = cscl.r, csr[2].i = cscl.i;
bry[0] = r1mach_(&c__1) * 1e3f / *tol;
bry[1] = 1.f / bry[0];
bry[2] = r1mach_(&c__2);
x = z__->r;
zr.r = z__->r, zr.i = z__->i;
if (x < 0.f) {
q__1.r = -z__->r, q__1.i = -z__->i;
zr.r = q__1.r, zr.i = q__1.i;
}
j = 2;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* ----------------------------------------------------------------------- */
/* J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J */
/* ----------------------------------------------------------------------- */
j = 3 - j;
fn = *fnu + (i__ - 1);
init[j - 1] = 0;
cunik_(&zr, &fn, &c__2, &c__0, tol, &init[j - 1], &phi[j - 1], &zeta1[
j - 1], &zeta2[j - 1], &sum[j - 1], &cwrk[(j << 4) - 16]);
if (*kode == 1) {
goto L20;
}
q__1.r = fn, q__1.i = 0.f;
cfn.r = q__1.r, cfn.i = q__1.i;
i__2 = j - 1;
i__3 = j - 1;
q__4.r = zr.r + zeta2[i__3].r, q__4.i = zr.i + zeta2[i__3].i;
c_div(&q__3, &cfn, &q__4);
q__2.r = cfn.r * q__3.r - cfn.i * q__3.i, q__2.i = cfn.r * q__3.i +
cfn.i * q__3.r;
q__1.r = zeta1[i__2].r - q__2.r, q__1.i = zeta1[i__2].i - q__2.i;
s1.r = q__1.r, s1.i = q__1.i;
goto L30;
L20:
i__2 = j - 1;
i__3 = j - 1;
q__1.r = zeta1[i__2].r - zeta2[i__3].r, q__1.i = zeta1[i__2].i -
zeta2[i__3].i;
s1.r = q__1.r, s1.i = q__1.i;
L30:
/* ----------------------------------------------------------------------- */
/* TEST FOR UNDERFLOW AND OVERFLOW */
/* ----------------------------------------------------------------------- */
rs1 = s1.r;
if (dabs(rs1) > *elim) {
goto L60;
}
if (kdflg == 1) {
kflag = 2;
}
if (dabs(rs1) < *alim) {
goto L40;
}
/* ----------------------------------------------------------------------- */
/* REFINE TEST AND SCALE */
/* ----------------------------------------------------------------------- */
aphi = c_abs(&phi[j - 1]);
rs1 += log(aphi);
if (dabs(rs1) > *elim) {
goto L60;
}
if (kdflg == 1) {
kflag = 1;
}
if (rs1 < 0.f) {
goto L40;
}
if (kdflg == 1) {
kflag = 3;
}
L40:
/* ----------------------------------------------------------------------- */
/* SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR */
/* EXPONENT EXTREMES */
/* ----------------------------------------------------------------------- */
i__2 = j - 1;
i__3 = j - 1;
q__1.r = phi[i__2].r * sum[i__3].r - phi[i__2].i * sum[i__3].i,
q__1.i = phi[i__2].r * sum[i__3].i + phi[i__2].i * sum[i__3]
.r;
s2.r = q__1.r, s2.i = q__1.i;
c2r = s1.r;
c2i = r_imag(&s1);
i__2 = kflag - 1;
c2m = exp(c2r) * css[i__2].r;
q__2.r = c2m, q__2.i = 0.f;
r__1 = cos(c2i);
r__2 = sin(c2i);
q__3.r = r__1, q__3.i = r__2;
q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = q__2.r * q__3.i
+ q__2.i * q__3.r;
s1.r = q__1.r, s1.i = q__1.i;
q__1.r = s2.r * s1.r - s2.i * s1.i, q__1.i = s2.r * s1.i + s2.i *
s1.r;
s2.r = q__1.r, s2.i = q__1.i;
if (kflag != 1) {
goto L50;
}
cuchk_(&s2, &nw, bry, tol);
if (nw != 0) {
goto L60;
}
L50:
i__2 = kdflg - 1;
cy[i__2].r = s2.r, cy[i__2].i = s2.i;
i__2 = i__;
i__3 = kflag - 1;
q__1.r = s2.r * csr[i__3].r - s2.i * csr[i__3].i, q__1.i = s2.r * csr[
i__3].i + s2.i * csr[i__3].r;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
if (kdflg == 2) {
goto L75;
}
kdflg = 2;
goto L70;
L60:
if (rs1 > 0.f) {
goto L290;
}
/* ----------------------------------------------------------------------- */
/* FOR X.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW */
/* ----------------------------------------------------------------------- */
if (x < 0.f) {
goto L290;
}
kdflg = 1;
i__2 = i__;
y[i__2].r = czero.r, y[i__2].i = czero.i;
++(*nz);
if (i__ == 1) {
goto L70;
}
i__2 = i__ - 1;
if (y[i__2].r == czero.r && y[i__2].i == czero.i) {
goto L70;
}
i__2 = i__ - 1;
y[i__2].r = czero.r, y[i__2].i = czero.i;
++(*nz);
L70:
;
}
i__ = *n;
L75:
c_div(&q__1, &c_b14, &zr);
rz.r = q__1.r, rz.i = q__1.i;
q__2.r = fn, q__2.i = 0.f;
q__1.r = q__2.r * rz.r - q__2.i * rz.i, q__1.i = q__2.r * rz.i + q__2.i *
rz.r;
ck.r = q__1.r, ck.i = q__1.i;
ib = i__ + 1;
if (*n < ib) {
goto L160;
}
/* ----------------------------------------------------------------------- */
/* TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW, SET SEQUENCE TO ZERO */
/* ON UNDERFLOW */
/* ----------------------------------------------------------------------- */
fn = *fnu + (*n - 1);
ipard = 1;
if (*mr != 0) {
ipard = 0;
}
initd = 0;
cunik_(&zr, &fn, &c__2, &ipard, tol, &initd, &phid, &zeta1d, &zeta2d, &
sumd, &cwrk[32]);
if (*kode == 1) {
goto L80;
}
q__1.r = fn, q__1.i = 0.f;
cfn.r = q__1.r, cfn.i = q__1.i;
q__4.r = zr.r + zeta2d.r, q__4.i = zr.i + zeta2d.i;
c_div(&q__3, &cfn, &q__4);
q__2.r = cfn.r * q__3.r - cfn.i * q__3.i, q__2.i = cfn.r * q__3.i + cfn.i
* q__3.r;
q__1.r = zeta1d.r - q__2.r, q__1.i = zeta1d.i - q__2.i;
s1.r = q__1.r, s1.i = q__1.i;
goto L90;
L80:
q__1.r = zeta1d.r - zeta2d.r, q__1.i = zeta1d.i - zeta2d.i;
s1.r = q__1.r, s1.i = q__1.i;
L90:
rs1 = s1.r;
if (dabs(rs1) > *elim) {
goto L95;
}
if (dabs(rs1) < *alim) {
goto L100;
}
/* ----------------------------------------------------------------------- */
/* REFINE ESTIMATE AND TEST */
/* ----------------------------------------------------------------------- */
aphi = c_abs(&phid);
rs1 += log(aphi);
if (dabs(rs1) < *elim) {
goto L100;
}
L95:
if (rs1 > 0.f) {
goto L290;
}
/* ----------------------------------------------------------------------- */
/* FOR X.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW */
/* ----------------------------------------------------------------------- */
if (x < 0.f) {
goto L290;
}
*nz = *n;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
y[i__2].r = czero.r, y[i__2].i = czero.i;
/* L96: */
}
return 0;
L100:
/* ----------------------------------------------------------------------- */
/* RECUR FORWARD FOR REMAINDER OF THE SEQUENCE */
/* ----------------------------------------------------------------------- */
s1.r = cy[0].r, s1.i = cy[0].i;
s2.r = cy[1].r, s2.i = cy[1].i;
i__1 = kflag - 1;
c1.r = csr[i__1].r, c1.i = csr[i__1].i;
ascle = bry[kflag - 1];
i__1 = *n;
for (i__ = ib; i__ <= i__1; ++i__) {
c2.r = s2.r, c2.i = s2.i;
q__2.r = ck.r * s2.r - ck.i * s2.i, q__2.i = ck.r * s2.i + ck.i *
s2.r;
q__1.r = q__2.r + s1.r, q__1.i = q__2.i + s1.i;
s2.r = q__1.r, s2.i = q__1.i;
s1.r = c2.r, s1.i = c2.i;
q__1.r = ck.r + rz.r, q__1.i = ck.i + rz.i;
ck.r = q__1.r, ck.i = q__1.i;
q__1.r = s2.r * c1.r - s2.i * c1.i, q__1.i = s2.r * c1.i + s2.i *
c1.r;
c2.r = q__1.r, c2.i = q__1.i;
i__2 = i__;
y[i__2].r = c2.r, y[i__2].i = c2.i;
if (kflag >= 3) {
goto L120;
}
c2r = c2.r;
c2i = r_imag(&c2);
c2r = dabs(c2r);
c2i = dabs(c2i);
c2m = dmax(c2r,c2i);
if (c2m <= ascle) {
goto L120;
}
++kflag;
ascle = bry[kflag - 1];
q__1.r = s1.r * c1.r - s1.i * c1.i, q__1.i = s1.r * c1.i + s1.i *
c1.r;
s1.r = q__1.r, s1.i = q__1.i;
s2.r = c2.r, s2.i = c2.i;
i__2 = kflag - 1;
q__1.r = s1.r * css[i__2].r - s1.i * css[i__2].i, q__1.i = s1.r * css[
i__2].i + s1.i * css[i__2].r;
s1.r = q__1.r, s1.i = q__1.i;
i__2 = kflag - 1;
q__1.r = s2.r * css[i__2].r - s2.i * css[i__2].i, q__1.i = s2.r * css[
i__2].i + s2.i * css[i__2].r;
s2.r = q__1.r, s2.i = q__1.i;
i__2 = kflag - 1;
c1.r = csr[i__2].r, c1.i = csr[i__2].i;
L120:
;
}
L160:
if (*mr == 0) {
return 0;
}
/* ----------------------------------------------------------------------- */
/* ANALYTIC CONTINUATION FOR RE(Z).LT.0.0E0 */
/* ----------------------------------------------------------------------- */
*nz = 0;
fmr = (real) (*mr);
sgn = -r_sign(&pi, &fmr);
/* ----------------------------------------------------------------------- */
/* CSPN AND CSGN ARE COEFF OF K AND I FUNCTIONS RESP. */
/* ----------------------------------------------------------------------- */
q__1.r = 0.f, q__1.i = sgn;
csgn.r = q__1.r, csgn.i = q__1.i;
inu = *fnu;
fnf = *fnu - inu;
ifn = inu + *n - 1;
ang = fnf * sgn;
cpn = cos(ang);
spn = sin(ang);
q__1.r = cpn, q__1.i = spn;
cspn.r = q__1.r, cspn.i = q__1.i;
if (ifn % 2 == 1) {
q__1.r = -cspn.r, q__1.i = -cspn.i;
cspn.r = q__1.r, cspn.i = q__1.i;
}
asc = bry[0];
kk = *n;
iuf = 0;
kdflg = 1;
--ib;
ic = ib - 1;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
fn = *fnu + (kk - 1);
/* ----------------------------------------------------------------------- */
/* LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K */
/* FUNCTION ABOVE */
/* ----------------------------------------------------------------------- */
m = 3;
if (*n > 2) {
goto L175;
}
L170:
initd = init[j - 1];
i__2 = j - 1;
phid.r = phi[i__2].r, phid.i = phi[i__2].i;
i__2 = j - 1;
zeta1d.r = zeta1[i__2].r, zeta1d.i = zeta1[i__2].i;
i__2 = j - 1;
zeta2d.r = zeta2[i__2].r, zeta2d.i = zeta2[i__2].i;
i__2 = j - 1;
sumd.r = sum[i__2].r, sumd.i = sum[i__2].i;
m = j;
j = 3 - j;
goto L180;
L175:
if (kk == *n && ib < *n) {
goto L180;
}
if (kk == ib || kk == ic) {
goto L170;
}
initd = 0;
L180:
cunik_(&zr, &fn, &c__1, &c__0, tol, &initd, &phid, &zeta1d, &zeta2d, &
sumd, &cwrk[(m << 4) - 16]);
if (*kode == 1) {
goto L190;
}
q__1.r = fn, q__1.i = 0.f;
cfn.r = q__1.r, cfn.i = q__1.i;
q__2.r = -zeta1d.r, q__2.i = -zeta1d.i;
q__5.r = zr.r + zeta2d.r, q__5.i = zr.i + zeta2d.i;
c_div(&q__4, &cfn, &q__5);
q__3.r = cfn.r * q__4.r - cfn.i * q__4.i, q__3.i = cfn.r * q__4.i +
cfn.i * q__4.r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
s1.r = q__1.r, s1.i = q__1.i;
goto L200;
L190:
q__2.r = -zeta1d.r, q__2.i = -zeta1d.i;
q__1.r = q__2.r + zeta2d.r, q__1.i = q__2.i + zeta2d.i;
s1.r = q__1.r, s1.i = q__1.i;
L200:
/* ----------------------------------------------------------------------- */
/* TEST FOR UNDERFLOW AND OVERFLOW */
/* ----------------------------------------------------------------------- */
rs1 = s1.r;
if (dabs(rs1) > *elim) {
goto L250;
}
if (kdflg == 1) {
iflag = 2;
}
if (dabs(rs1) < *alim) {
goto L210;
}
/* ----------------------------------------------------------------------- */
/* REFINE TEST AND SCALE */
/* ----------------------------------------------------------------------- */
aphi = c_abs(&phid);
rs1 += log(aphi);
if (dabs(rs1) > *elim) {
goto L250;
}
if (kdflg == 1) {
iflag = 1;
}
if (rs1 < 0.f) {
goto L210;
}
if (kdflg == 1) {
iflag = 3;
}
L210:
q__2.r = csgn.r * phid.r - csgn.i * phid.i, q__2.i = csgn.r * phid.i
+ csgn.i * phid.r;
q__1.r = q__2.r * sumd.r - q__2.i * sumd.i, q__1.i = q__2.r * sumd.i
+ q__2.i * sumd.r;
s2.r = q__1.r, s2.i = q__1.i;
c2r = s1.r;
c2i = r_imag(&s1);
i__2 = iflag - 1;
c2m = exp(c2r) * css[i__2].r;
q__2.r = c2m, q__2.i = 0.f;
r__1 = cos(c2i);
r__2 = sin(c2i);
q__3.r = r__1, q__3.i = r__2;
q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = q__2.r * q__3.i
+ q__2.i * q__3.r;
s1.r = q__1.r, s1.i = q__1.i;
q__1.r = s2.r * s1.r - s2.i * s1.i, q__1.i = s2.r * s1.i + s2.i *
s1.r;
s2.r = q__1.r, s2.i = q__1.i;
if (iflag != 1) {
goto L220;
}
cuchk_(&s2, &nw, bry, tol);
if (nw != 0) {
s2.r = 0.f, s2.i = 0.f;
}
L220:
i__2 = kdflg - 1;
cy[i__2].r = s2.r, cy[i__2].i = s2.i;
c2.r = s2.r, c2.i = s2.i;
i__2 = iflag - 1;
q__1.r = s2.r * csr[i__2].r - s2.i * csr[i__2].i, q__1.i = s2.r * csr[
i__2].i + s2.i * csr[i__2].r;
s2.r = q__1.r, s2.i = q__1.i;
/* ----------------------------------------------------------------------- */
/* ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N */
/* ----------------------------------------------------------------------- */
i__2 = kk;
s1.r = y[i__2].r, s1.i = y[i__2].i;
if (*kode == 1) {
goto L240;
}
cs1s2_(&zr, &s1, &s2, &nw, &asc, alim, &iuf);
*nz += nw;
L240:
i__2 = kk;
q__2.r = s1.r * cspn.r - s1.i * cspn.i, q__2.i = s1.r * cspn.i + s1.i
* cspn.r;
q__1.r = q__2.r + s2.r, q__1.i = q__2.i + s2.i;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
--kk;
q__1.r = -cspn.r, q__1.i = -cspn.i;
cspn.r = q__1.r, cspn.i = q__1.i;
if (c2.r != czero.r || c2.i != czero.i) {
goto L245;
}
kdflg = 1;
goto L260;
L245:
if (kdflg == 2) {
goto L265;
}
kdflg = 2;
goto L260;
L250:
if (rs1 > 0.f) {
goto L290;
}
s2.r = czero.r, s2.i = czero.i;
goto L220;
L260:
;
}
k = *n;
L265:
il = *n - k;
if (il == 0) {
return 0;
}
/* ----------------------------------------------------------------------- */
/* RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE */
/* K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP */
/* INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES. */
/* ----------------------------------------------------------------------- */
s1.r = cy[0].r, s1.i = cy[0].i;
s2.r = cy[1].r, s2.i = cy[1].i;
i__1 = iflag - 1;
cs.r = csr[i__1].r, cs.i = csr[i__1].i;
ascle = bry[iflag - 1];
fn = (real) (inu + il);
i__1 = il;
for (i__ = 1; i__ <= i__1; ++i__) {
c2.r = s2.r, c2.i = s2.i;
r__1 = fn + fnf;
q__4.r = r__1, q__4.i = 0.f;
q__3.r = q__4.r * rz.r - q__4.i * rz.i, q__3.i = q__4.r * rz.i +
q__4.i * rz.r;
q__2.r = q__3.r * s2.r - q__3.i * s2.i, q__2.i = q__3.r * s2.i +
q__3.i * s2.r;
q__1.r = s1.r + q__2.r, q__1.i = s1.i + q__2.i;
s2.r = q__1.r, s2.i = q__1.i;
s1.r = c2.r, s1.i = c2.i;
fn += -1.f;
q__1.r = s2.r * cs.r - s2.i * cs.i, q__1.i = s2.r * cs.i + s2.i *
cs.r;
c2.r = q__1.r, c2.i = q__1.i;
ck.r = c2.r, ck.i = c2.i;
i__2 = kk;
c1.r = y[i__2].r, c1.i = y[i__2].i;
if (*kode == 1) {
goto L270;
}
cs1s2_(&zr, &c1, &c2, &nw, &asc, alim, &iuf);
*nz += nw;
L270:
i__2 = kk;
q__2.r = c1.r * cspn.r - c1.i * cspn.i, q__2.i = c1.r * cspn.i + c1.i
* cspn.r;
q__1.r = q__2.r + c2.r, q__1.i = q__2.i + c2.i;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
--kk;
q__1.r = -cspn.r, q__1.i = -cspn.i;
cspn.r = q__1.r, cspn.i = q__1.i;
if (iflag >= 3) {
goto L280;
}
c2r = ck.r;
c2i = r_imag(&ck);
c2r = dabs(c2r);
c2i = dabs(c2i);
c2m = dmax(c2r,c2i);
if (c2m <= ascle) {
goto L280;
}
++iflag;
ascle = bry[iflag - 1];
q__1.r = s1.r * cs.r - s1.i * cs.i, q__1.i = s1.r * cs.i + s1.i *
cs.r;
s1.r = q__1.r, s1.i = q__1.i;
s2.r = ck.r, s2.i = ck.i;
i__2 = iflag - 1;
q__1.r = s1.r * css[i__2].r - s1.i * css[i__2].i, q__1.i = s1.r * css[
i__2].i + s1.i * css[i__2].r;
s1.r = q__1.r, s1.i = q__1.i;
i__2 = iflag - 1;
q__1.r = s2.r * css[i__2].r - s2.i * css[i__2].i, q__1.i = s2.r * css[
i__2].i + s2.i * css[i__2].r;
s2.r = q__1.r, s2.i = q__1.i;
i__2 = iflag - 1;
cs.r = csr[i__2].r, cs.i = csr[i__2].i;
L280:
;
}
return 0;
L290:
*nz = -1;
return 0;
} /* cunk1_ */
/* DECK BESI1 */
doublereal besi1_(real *x)
{
/* Initialized data */
static real bi1cs[11] = { -.001971713261099859f,.40734887667546481f,
.034838994299959456f,.001545394556300123f,4.1888521098377e-5f,
7.64902676483e-7f,1.0042493924e-8f,9.9322077e-11f,7.6638e-13f,
4.741e-15f,2.4e-17f };
static logical first = TRUE_;
/* System generated locals */
real ret_val, r__1;
/* Local variables */
static real y;
static integer nti1;
static real xmin, xmax, xsml;
extern doublereal csevl_(real *, real *, integer *);
extern integer inits_(real *, integer *, real *);
extern doublereal besi1e_(real *), r1mach_(integer *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE BESI1 */
/* ***PURPOSE Compute the modified (hyperbolic) Bessel function of the */
/* first kind of order one. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C10B1 */
/* ***TYPE SINGLE PRECISION (BESI1-S, DBESI1-D) */
/* ***KEYWORDS FIRST KIND, FNLIB, HYPERBOLIC BESSEL FUNCTION, */
/* MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* BESI1(X) calculates the modified (hyperbolic) Bessel function */
/* of the first kind of order one for real argument X. */
/* Series for BI1 on the interval 0. to 9.00000D+00 */
/* with weighted error 2.40E-17 */
/* log weighted error 16.62 */
/* significant figures required 16.23 */
/* decimal places required 17.14 */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED BESI1E, CSEVL, INITS, R1MACH, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 770401 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) */
/* ***END PROLOGUE BESI1 */
/* ***FIRST EXECUTABLE STATEMENT BESI1 */
if (first) {
r__1 = r1mach_(&c__3) * .1f;
nti1 = inits_(bi1cs, &c__11, &r__1);
xmin = r1mach_(&c__1) * 2.f;
xsml = sqrt(r1mach_(&c__3) * 4.5f);
xmax = log(r1mach_(&c__2));
}
first = FALSE_;
y = dabs(*x);
if (y > 3.f) {
goto L20;
}
ret_val = 0.f;
if (y == 0.f) {
return ret_val;
}
if (y <= xmin) {
xermsg_("SLATEC", "BESI1", "ABS(X) SO SMALL I1 UNDERFLOWS", &c__1, &
c__1, (ftnlen)6, (ftnlen)5, (ftnlen)29);
}
if (y > xmin) {
ret_val = *x * .5f;
}
if (y > xsml) {
r__1 = y * y / 4.5f - 1.f;
ret_val = *x * (csevl_(&r__1, bi1cs, &nti1) + .875f);
}
return ret_val;
L20:
if (y > xmax) {
xermsg_("SLATEC", "BESI1", "ABS(X) SO BIG I1 OVERFLOWS", &c__2, &c__2,
(ftnlen)6, (ftnlen)5, (ftnlen)26);
}
ret_val = exp(y) * besi1e_(x);
return ret_val;
} /* besi1_ */
/* 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_ */
/* 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 FZERO */
/* Subroutine */ int fzero_(E_fp f, real *b, real *c__, real *r__, real *re,
real *ae, integer *iflag)
{
/* System generated locals */
real r__1, r__2;
/* Local variables */
static real a, p, q, t, z__, fa, fb, fc;
static integer ic;
static real aw, er, fx, fz, rw, cmb, tol, acmb, acbs;
static integer kount;
extern doublereal r1mach_(integer *);
/* ***BEGIN PROLOGUE FZERO */
/* ***PURPOSE Search for a zero of a function F(X) in a given interval */
/* (B,C). It is designed primarily for problems where F(B) */
/* and F(C) have opposite signs. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY F1B */
/* ***TYPE SINGLE PRECISION (FZERO-S, DFZERO-D) */
/* ***KEYWORDS BISECTION, NONLINEAR EQUATIONS, ROOTS, ZEROS */
/* ***AUTHOR Shampine, L. F., (SNLA) */
/* Watts, H. A., (SNLA) */
/* ***DESCRIPTION */
/* FZERO searches for a zero of a REAL function F(X) between the */
/* given REAL values B and C until the width of the interval (B,C) */
/* has collapsed to within a tolerance specified by the stopping */
/* criterion, */
/* ABS(B-C) .LE. 2.*(RW*ABS(B)+AE). */
/* The method used is an efficient combination of bisection and the */
/* secant rule and is due to T. J. Dekker. */
/* Description Of Arguments */
/* F :EXT - Name of the REAL external function. This name must */
/* be in an EXTERNAL statement in the calling program. */
/* F must be a function of one REAL argument. */
/* B :INOUT - One end of the REAL interval (B,C). The value */
/* returned for B usually is the better approximation */
/* to a zero of F. */
/* C :INOUT - The other end of the REAL interval (B,C) */
/* R :OUT - A (better) REAL guess of a zero of F which could help */
/* in speeding up convergence. If F(B) and F(R) have */
/* opposite signs, a root will be found in the interval */
/* (B,R); if not, but F(R) and F(C) have opposite signs, */
/* a root will be found in the interval (R,C); */
/* otherwise, the interval (B,C) will be searched for a */
/* possible root. When no better guess is known, it is */
/* recommended that r be set to B or C, since if R is */
/* not interior to the interval (B,C), it will be */
/* ignored. */
/* RE :IN - Relative error used for RW in the stopping criterion. */
/* If the requested RE is less than machine precision, */
/* then RW is set to approximately machine precision. */
/* AE :IN - Absolute error used in the stopping criterion. If */
/* the given interval (B,C) contains the origin, then a */
/* nonzero value should be chosen for AE. */
/* IFLAG :OUT - A status code. User must check IFLAG after each */
/* call. Control returns to the user from FZERO in all */
/* cases. */
/* 1 B is within the requested tolerance of a zero. */
/* The interval (B,C) collapsed to the requested */
/* tolerance, the function changes sign in (B,C), and */
/* F(X) decreased in magnitude as (B,C) collapsed. */
/* 2 F(B) = 0. However, the interval (B,C) may not have */
/* collapsed to the requested tolerance. */
/* 3 B may be near a singular point of F(X). */
/* The interval (B,C) collapsed to the requested tol- */
/* erance and the function changes sign in (B,C), but */
/* F(X) increased in magnitude as (B,C) collapsed, i.e. */
/* ABS(F(B out)) .GT. MAX(ABS(F(B in)),ABS(F(C in))) */
/* 4 No change in sign of F(X) was found although the */
/* interval (B,C) collapsed to the requested tolerance. */
/* The user must examine this case and decide whether */
/* B is near a local minimum of F(X), or B is near a */
/* zero of even multiplicity, or neither of these. */
/* 5 Too many (.GT. 500) function evaluations used. */
/* ***REFERENCES L. F. Shampine and H. A. Watts, FZERO, a root-solving */
/* code, Report SC-TM-70-631, Sandia Laboratories, */
/* September 1970. */
/* T. J. Dekker, Finding a zero by means of successive */
/* linear interpolation, Constructive Aspects of the */
/* Fundamental Theorem of Algebra, edited by B. Dejon */
/* and P. Henrici, Wiley-Interscience, 1969. */
/* ***ROUTINES CALLED R1MACH */
/* ***REVISION HISTORY (YYMMDD) */
/* 700901 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) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE FZERO */
/* ***FIRST EXECUTABLE STATEMENT FZERO */
/* ER is two times the computer unit roundoff value which is defined */
/* here by the function R1MACH. */
er = r1mach_(&c__4) * 2.f;
/* Initialize. */
z__ = *r__;
if (*r__ <= dmin(*b,*c__) || *r__ >= dmax(*b,*c__)) {
z__ = *c__;
}
rw = dmax(*re,er);
aw = dmax(*ae,0.f);
ic = 0;
t = z__;
fz = (*f)(&t);
fc = fz;
t = *b;
fb = (*f)(&t);
kount = 2;
if (r_sign(&c_b3, &fz) == r_sign(&c_b3, &fb)) {
goto L1;
}
*c__ = z__;
goto L2;
L1:
if (z__ == *c__) {
goto L2;
}
t = *c__;
fc = (*f)(&t);
kount = 3;
if (r_sign(&c_b3, &fz) == r_sign(&c_b3, &fc)) {
goto L2;
}
*b = z__;
fb = fz;
L2:
a = *c__;
fa = fc;
acbs = (r__1 = *b - *c__, dabs(r__1));
/* Computing MAX */
r__1 = dabs(fb), r__2 = dabs(fc);
fx = dmax(r__1,r__2);
L3:
if (dabs(fc) >= dabs(fb)) {
goto L4;
}
/* Perform interchange. */
a = *b;
fa = fb;
*b = *c__;
fb = fc;
*c__ = a;
fc = fa;
L4:
cmb = (*c__ - *b) * .5f;
acmb = dabs(cmb);
tol = rw * dabs(*b) + aw;
/* Test stopping criterion and function count. */
if (acmb <= tol) {
goto L10;
}
if (fb == 0.f) {
goto L11;
}
if (kount >= 500) {
goto L14;
}
/* Calculate new iterate implicitly as B+P/Q, where we arrange */
/* P .GE. 0. The implicit form is used to prevent overflow. */
p = (*b - a) * fb;
q = fa - fb;
if (p >= 0.f) {
goto L5;
}
p = -p;
q = -q;
/* Update A and check for satisfactory reduction in the size of the */
/* bracketing interval. If not, perform bisection. */
L5:
a = *b;
fa = fb;
++ic;
if (ic < 4) {
goto L6;
}
if (acmb * 8.f >= acbs) {
goto L8;
}
ic = 0;
acbs = acmb;
/* Test for too small a change. */
L6:
if (p > dabs(q) * tol) {
goto L7;
}
/* Increment by TOLerance. */
*b += r_sign(&tol, &cmb);
goto L9;
/* Root ought to be between B and (C+B)/2. */
L7:
if (p >= cmb * q) {
goto L8;
}
/* Use secant rule. */
*b += p / q;
goto L9;
/* Use bisection (C+B)/2. */
L8:
*b += cmb;
/* Have completed computation for new iterate B. */
L9:
t = *b;
fb = (*f)(&t);
++kount;
/* Decide whether next step is interpolation or extrapolation. */
if (r_sign(&c_b3, &fb) != r_sign(&c_b3, &fc)) {
goto L3;
}
*c__ = a;
fc = fa;
goto L3;
/* Finished. Process results for proper setting of IFLAG. */
L10:
if (r_sign(&c_b3, &fb) == r_sign(&c_b3, &fc)) {
goto L13;
}
if (dabs(fb) > fx) {
goto L12;
}
*iflag = 1;
return 0;
L11:
*iflag = 2;
return 0;
L12:
*iflag = 3;
return 0;
L13:
*iflag = 4;
return 0;
L14:
*iflag = 5;
return 0;
} /* fzero_ */
/* DECK SCHKW */
/* Subroutine */ int schkw_(char *name__, integer *lociw, integer *leniw,
integer *locw, integer *lenw, integer *ierr, integer *iter, real *err,
ftnlen name_len)
{
/* System generated locals */
address a__1[7];
integer i__1[7];
char ch__1[89], ch__2[86];
/* Local variables */
static char xern1[8], xern2[8];
extern doublereal r1mach_(integer *);
static char xernam[8];
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* Fortran I/O blocks */
static icilist io___3 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___5 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___6 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___7 = { 0, xern2, 0, "(I8)", 8, 1 };
/* ***BEGIN PROLOGUE SCHKW */
/* ***SUBSIDIARY */
/* ***PURPOSE SLAP WORK/IWORK Array Bounds Checker. */
/* This routine checks the work array lengths and interfaces */
/* to the SLATEC error handler if a problem is found. */
/* ***LIBRARY SLATEC (SLAP) */
/* ***CATEGORY R2 */
/* ***TYPE SINGLE PRECISION (SCHKW-S, DCHKW-D) */
/* ***KEYWORDS ERROR CHECKING, SLAP, WORKSPACE CHECKING */
/* ***AUTHOR Seager, Mark K., (LLNL) */
/* Lawrence Livermore National Laboratory */
/* PO BOX 808, L-60 */
/* Livermore, CA 94550 (510) 423-3141 */
/* [email protected] */
/* ***DESCRIPTION */
/* *Usage: */
/* CHARACTER*(*) NAME */
/* INTEGER LOCIW, LENIW, LOCW, LENW, IERR, ITER */
/* REAL ERR */
/* CALL SCHKW( NAME, LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) */
/* *Arguments: */
/* NAME :IN Character*(*). */
/* Name of the calling routine. This is used in the output */
/* message, if an error is detected. */
/* LOCIW :IN Integer. */
/* Location of the first free element in the integer workspace */
/* array. */
/* LENIW :IN Integer. */
/* Length of the integer workspace array. */
/* LOCW :IN Integer. */
/* Location of the first free element in the real workspace */
/* array. */
/* LENRW :IN Integer. */
/* Length of the real workspace array. */
/* IERR :OUT Integer. */
/* Return error flag. */
/* IERR = 0 => All went well. */
/* IERR = 1 => Insufficient storage allocated for */
/* WORK or IWORK. */
/* ITER :OUT Integer. */
/* Set to zero on return. */
/* ERR :OUT Real. */
/* Set to the smallest positive magnitude if all went well. */
/* Set to a very large number if an error is detected. */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED R1MACH, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 880225 DATE WRITTEN */
/* 881213 Previous REVISION DATE */
/* 890915 Made changes requested at July 1989 CML Meeting. (MKS) */
/* 890922 Numerous changes to prologue to make closer to SLATEC */
/* standard. (FNF) */
/* 890929 Numerous changes to reduce SP/DP differences. (FNF) */
/* 900805 Changed XERRWV calls to calls to XERMSG. (RWC) */
/* 910411 Prologue converted to Version 4.0 format. (BAB) */
/* 910502 Corrected XERMSG calls to satisfy Section 6.2.2 of ANSI */
/* X3.9-1978. (FNF) */
/* 910506 Made subsidiary. (FNF) */
/* 920511 Added complete declaration section. (WRB) */
/* 921015 Added code to initialize ITER and ERR when IERR=0. (FNF) */
/* ***END PROLOGUE SCHKW */
/* .. Scalar Arguments .. */
/* .. Local Scalars .. */
/* .. External Functions .. */
/* .. External Subroutines .. */
/* ***FIRST EXECUTABLE STATEMENT SCHKW */
/* Check the Integer workspace situation. */
*ierr = 0;
*iter = 0;
*err = r1mach_(&c__1);
if (*lociw > *leniw) {
*ierr = 1;
*err = r1mach_(&c__2);
s_copy(xernam, name__, (ftnlen)8, name_len);
s_wsfi(&io___3);
do_fio(&c__1, (char *)&(*lociw), (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___5);
do_fio(&c__1, (char *)&(*leniw), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 3, a__1[0] = "In ";
i__1[1] = 8, a__1[1] = xernam;
i__1[2] = 33, a__1[2] = ", INTEGER work array too short. ";
i__1[3] = 12, a__1[3] = "IWORK needs ";
i__1[4] = 8, a__1[4] = xern1;
i__1[5] = 17, a__1[5] = "; have allocated ";
i__1[6] = 8, a__1[6] = xern2;
s_cat(ch__1, a__1, i__1, &c__7, (ftnlen)89);
xermsg_("SLATEC", "SCHKW", ch__1, &c__1, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)89);
}
/* Check the Real workspace situation. */
if (*locw > *lenw) {
*ierr = 1;
*err = r1mach_(&c__2);
s_copy(xernam, name__, (ftnlen)8, name_len);
s_wsfi(&io___6);
do_fio(&c__1, (char *)&(*locw), (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___7);
do_fio(&c__1, (char *)&(*lenw), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 3, a__1[0] = "In ";
i__1[1] = 8, a__1[1] = xernam;
i__1[2] = 30, a__1[2] = ", REAL work array too short. ";
i__1[3] = 12, a__1[3] = "RWORK needs ";
i__1[4] = 8, a__1[4] = xern1;
i__1[5] = 17, a__1[5] = "; have allocated ";
i__1[6] = 8, a__1[6] = xern2;
s_cat(ch__2, a__1, i__1, &c__7, (ftnlen)86);
xermsg_("SLATEC", "SCHKW", ch__2, &c__1, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)86);
}
return 0;
/* ------------- LAST LINE OF SCHKW FOLLOWS ---------------------------- */
} /* schkw_ */