예제 #1
0
파일: psifn.c 프로젝트: Rufflewind/cslatec
/* 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_ */
예제 #2
0
파일: besj.c 프로젝트: Rufflewind/cslatec
/* 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_ */
예제 #3
0
파일: rc6j.c 프로젝트: Rufflewind/cslatec
/* 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_ */
예제 #4
0
파일: besynu.c 프로젝트: Rufflewind/cslatec
/* 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_ */
예제 #5
0
파일: sgeir.c 프로젝트: Rufflewind/cslatec
/* 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_ */
예제 #6
0
파일: ai.c 프로젝트: Rufflewind/cslatec
/* 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_ */
예제 #7
0
파일: cnbir.c 프로젝트: Rufflewind/cslatec
/* 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_ */
예제 #8
0
파일: bi.c 프로젝트: Rufflewind/cslatec
/* 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_ */
예제 #9
0
파일: lsod.c 프로젝트: Rufflewind/cslatec
/* 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_ */
예제 #10
0
파일: qagse.c 프로젝트: Rufflewind/cslatec
/* 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_ */
예제 #11
0
파일: erf.c 프로젝트: Rufflewind/cslatec
/* 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_ */
예제 #12
0
파일: cbrt.c 프로젝트: Rufflewind/cslatec
/* 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_ */
예제 #13
0
파일: qk61.c 프로젝트: Rufflewind/cslatec
/* 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)(&centr);
    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_ */
예제 #14
0
/* 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_ */
예제 #15
0
파일: qawfe.c 프로젝트: pyal/eos_cpp
/* 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_ */
예제 #16
0
파일: qagse.c 프로젝트: pyal/eos_cpp
/* 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_ */
예제 #17
0
파일: besy1.c 프로젝트: Rufflewind/cslatec
/* 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_ */
예제 #18
0
파일: besi1e.c 프로젝트: Rufflewind/cslatec
/* 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_ */
예제 #19
0
파일: cunhj.c 프로젝트: Rufflewind/cslatec
/* 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_ */
예제 #20
0
파일: qelg.c 프로젝트: Rufflewind/cslatec
/* 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_ */
예제 #21
0
파일: chu.c 프로젝트: Rufflewind/cslatec
/* 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_ */
예제 #22
0
파일: cpsi.c 프로젝트: Rufflewind/cslatec
/* 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_ */
예제 #23
0
파일: cunk1.c 프로젝트: Rufflewind/cslatec
/* 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_ */
예제 #24
0
파일: besi1.c 프로젝트: Rufflewind/cslatec
/* 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_ */
예제 #25
0
파일: cairy.c 프로젝트: Rufflewind/cslatec
/* 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_ */
예제 #26
0
파일: clngam.c 프로젝트: Rufflewind/cslatec
/* 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_ */
예제 #27
0
파일: fzero.c 프로젝트: Rufflewind/cslatec
/* 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_ */
예제 #28
0
파일: schkw.c 프로젝트: Rufflewind/cslatec
/* 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_ */