// unused now from R
double bessel_j(double x, double alpha)
{
int nb, ncalc;
double na, *bj;
#ifndef MATHLIB_STANDALONE
const void *vmax;
#endif
#ifdef IEEE_754
/* NaNs propagated correctly */
if (ISNAN(x) || ISNAN(alpha)) return x + alpha;
#endif
if (x < 0) {
ML_ERROR(ME_RANGE, "bessel_j");
return ML_NAN;
}
na = floor(alpha);
if (alpha < 0) {
/* Using Abramowitz & Stegun 9.1.2
* this may not be quite optimal (CPU and accuracy wise) */
return(((alpha - na == 0.5) ? 0 : bessel_j(x, -alpha) * cospi(alpha)) +
((alpha == na ) ? 0 : bessel_y(x, -alpha) * sinpi(alpha)));
}
else if (alpha > 1e7) {
MATHLIB_WARNING("besselJ(x, nu): nu=%g too large for bessel_j() algorithm", alpha);
return ML_NAN;
}
nb = 1 + (int)na; /* nb-1 <= alpha < nb */
alpha -= (double)(nb-1);
#ifdef MATHLIB_STANDALONE
bj = (double *) calloc(nb, sizeof(double));
#ifndef _RENJIN
if (!bj) MATHLIB_ERROR("%s", _("bessel_j allocation error"));
#endif
#else
vmax = vmaxget();
bj = (double *) R_alloc((size_t) nb, sizeof(double));
#endif
J_bessel(&x, &alpha, &nb, bj, &ncalc);
if(ncalc != nb) {/* error input */
if(ncalc < 0)
MATHLIB_WARNING4(_("bessel_j(%g): ncalc (=%d) != nb (=%d); alpha=%g. Arg. out of range?\n"),
x, ncalc, nb, alpha);
else
MATHLIB_WARNING2(_("bessel_j(%g,nu=%g): precision lost in result\n"),
x, alpha+(double)nb-1);
}
x = bj[nb-1];
#ifdef MATHLIB_STANDALONE
free(bj);
#else
vmaxset(vmax);
#endif
return x;
}
double bessel_y(double x, double alpha)
{
long nb, ncalc;
double na, *by;
#ifndef MATHLIB_STANDALONE
const void *vmax;
#endif
#ifdef IEEE_754
/* NaNs propagated correctly */
if (ISNAN(x) || ISNAN(alpha)) return x + alpha;
#endif
if (x < 0) {
ML_ERROR(ME_RANGE, "bessel_y");
return ML_NAN;
}
na = floor(alpha);
if (alpha < 0) {
/* Using Abramowitz & Stegun 9.1.2
* this may not be quite optimal (CPU and accuracy wise) */
return(bessel_y(x, -alpha) * cos(M_PI * alpha) -
((alpha == na) ? 0 :
bessel_j(x, -alpha) * sin(M_PI * alpha)));
}
nb = 1+ (long)na;/* nb-1 <= alpha < nb */
alpha -= (nb-1);
#ifdef MATHLIB_STANDALONE
by = (double *) calloc(nb, sizeof(double));
if (!by) MATHLIB_ERROR("%s", _("bessel_y allocation error"));
#else
vmax = vmaxget();
by = (double *) R_alloc((size_t) nb, sizeof(double));
#endif
Y_bessel(&x, &alpha, &nb, by, &ncalc);
if(ncalc != nb) {/* error input */
if(ncalc == -1)
return ML_POSINF;
else if(ncalc < -1)
MATHLIB_WARNING4(_("bessel_y(%g): ncalc (=%ld) != nb (=%ld); alpha=%g. Arg. out of range?\n"),
x, ncalc, nb, alpha);
else /* ncalc >= 0 */
MATHLIB_WARNING2(_("bessel_y(%g,nu=%g): precision lost in result\n"),
x, alpha+nb-1);
}
x = by[nb-1];
#ifdef MATHLIB_STANDALONE
free(by);
#else
vmaxset(vmax);
#endif
return x;
}
/*
* Large-z expansion for Struve H and L
* http://dlmf.nist.gov/11.6.1
*/
double struve_asymp_large_z(double v, double z, int is_h, double *err)
{
int n, sgn, maxiter;
double term, sum, maxterm;
double m;
if (is_h) {
sgn = -1;
}
else {
sgn = 1;
}
/* Asymptotic expansion divergenge point */
m = z/2;
if (m <= 0) {
maxiter = 0;
}
else if (m > MAXITER) {
maxiter = MAXITER;
}
else {
maxiter = (int)m;
}
if (maxiter == 0) {
*err = NPY_INFINITY;
return NPY_NAN;
}
if (z < v) {
/* Exclude regions where our error estimation fails */
*err = NPY_INFINITY;
return NPY_NAN;
}
/* Evaluate sum */
term = -sgn / sqrt(M_PI) * exp(-lgam(v + 0.5) + (v - 1) * log(z/2)) * gammasgn(v + 0.5);
sum = term;
maxterm = 0;
for (n = 0; n < maxiter; ++n) {
term *= sgn * (1 + 2*n) * (1 + 2*n - 2*v) / (z*z);
sum += term;
if (fabs(term) > maxterm) {
maxterm = fabs(term);
}
if (fabs(term) < SUM_EPS * fabs(sum) || term == 0 || !npy_isfinite(sum)) {
break;
}
}
if (is_h) {
sum += bessel_y(v, z);
}
else {
sum += bessel_i(v, z);
}
/*
* This error estimate is strictly speaking valid only for
* n > v - 0.5, but numerical results indicate that it works
* reasonably.
*/
*err = fabs(term) + fabs(maxterm) * 1e-16;
return sum;
}
