// 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;
}
double bessel(double *dist, int n, int dim, double nugget, double sill,
double range, double smooth, double *rho){
//This function computes the bessel covariance function
//between each pair of locations.
//When ans != 0.0, the powered exponential parameters are ill-defined.
const double irange = 1 / range, cst = sill * R_pow(2, smooth) * gammafn(smooth + 1);
//Some preliminary steps: Valid points?
if (smooth < (0.5 * (dim - 2)))
return (1 + 0.5 * (dim - 2) - smooth) * (1 + 0.5 * (dim - 2) - smooth) * MINF;
/* else if (smooth > 100)
//Require as bessel_j will be numerically undefined
return (smooth - 99) * (smooth - 99) * MINF; */
if (range <= 0)
return (1 - range) * (1 - range) * MINF;
if (sill <= 0)
return (1 - sill) * (1 - sill) * MINF;
if (nugget < 0)
return (1 - nugget) * (1 - nugget) * MINF;
#pragma omp parallel for
for (int i=0;i<n;i++){
double cst2 = dist[i] * irange;
if (cst2 == 0)
rho[i] = nugget + sill;
else if (cst2 <= 1e5)
rho[i] = cst * R_pow(cst2, -smooth) * bessel_j(cst2, smooth);
else
// approximation of the besselJ function for large x
rho[i] = cst * R_pow(cst2, -smooth) * M_SQRT_2dPI *
cos(cst2 - smooth * M_PI_2 - M_PI_4);
/*if (!R_FINITE(rho[i]))
return MINF;*/
}
return 0.0;
}
/*
* Bessel series
* http://dlmf.nist.gov/11.4.19
*/
double struve_bessel_series(double v, double z, int is_h, double *err)
{
int n, sgn;
double term, cterm, sum, maxterm;
if (is_h && v < 0) {
/* Works less reliably in this region */
*err = NPY_INFINITY;
return NPY_NAN;
}
sum = 0;
maxterm = 0;
cterm = sqrt(z / (2*M_PI));
for (n = 0; n < MAXITER; ++n) {
if (is_h) {
term = cterm * bessel_j(n + v + 0.5, z) / (n + 0.5);
cterm *= z/2 / (n + 1);
}
else {
term = cterm * bessel_i(n + v + 0.5, z) / (n + 0.5);
cterm *= -z/2 / (n + 1);
}
sum += term;
if (fabs(term) > maxterm) {
maxterm = fabs(term);
}
if (fabs(term) < SUM_EPS * fabs(sum) || term == 0 || !npy_isfinite(sum)) {
break;
}
}
*err = fabs(term) + fabs(maxterm) * 1e-16;
/* Account for potential underflow of the Bessel functions */
*err += 1e-300 * fabs(cterm);
return sum;
}
static double struve_hl(double v, double z, int is_h)
{
double value[4], err[4], tmp;
int n;
if (z < 0) {
n = v;
if (v == n) {
tmp = (n % 2 == 0) ? -1 : 1;
return tmp * struve_hl(v, -z, is_h);
}
else {
return NPY_NAN;
}
}
else if (z == 0) {
if (v < -1) {
return gammasgn(v + 1.5) * NPY_INFINITY;
}
else if (v == -1) {
return 2 / sqrt(M_PI) / Gamma(0.5);
}
else {
return 0;
}
}
n = -v - 0.5;
if (n == -v - 0.5 && n > 0) {
if (is_h) {
return (n % 2 == 0 ? 1 : -1) * bessel_j(n + 0.5, z);
}
else {
return bessel_i(n + 0.5, z);
}
}
/* Try the asymptotic expansion */
if (z >= 0.7*v + 12) {
value[0] = struve_asymp_large_z(v, z, is_h, &err[0]);
if (err[0] < GOOD_EPS * fabs(value[0])) {
return value[0];
}
}
else {
err[0] = NPY_INFINITY;
}
/* Try power series */
value[1] = struve_power_series(v, z, is_h, &err[1]);
if (err[1] < GOOD_EPS * fabs(value[1])) {
return value[1];
}
/* Try bessel series */
if (fabs(z) < fabs(v) + 20) {
value[2] = struve_bessel_series(v, z, is_h, &err[2]);
if (err[2] < GOOD_EPS * fabs(value[2])) {
return value[2];
}
}
else {
err[2] = NPY_INFINITY;
}
/* Return the best of the three, if it is acceptable */
n = 0;
if (err[1] < err[n]) n = 1;
if (err[2] < err[n]) n = 2;
if (err[n] < ACCEPTABLE_EPS * fabs(value[n]) || err[n] < ACCEPTABLE_ATOL) {
return value[n];
}
/* Maybe it really is an overflow? */
tmp = -lgam(v + 1.5) + (v + 1)*log(z/2);
if (!is_h) {
tmp = fabs(tmp);
}
if (tmp > 700) {
sf_error("struve", SF_ERROR_OVERFLOW, "overflow in series");
return NPY_INFINITY * gammasgn(v + 1.5);
}
/* Failure */
sf_error("struve", SF_ERROR_NO_RESULT, "total loss of precision");
return NPY_NAN;
}
int main()
{
#include "bessel_j_int_data.ipp"
add_data(j0_data);
add_data(j0_tricky);
add_data(j1_data);
add_data(j1_tricky);
add_data(jn_data);
add_data(bessel_j_int_data);
unsigned data_total = data.size();
screen_data([](const std::vector<double>& v){ return boost::math::cyl_bessel_j(static_cast<int>(v[0]), v[1]); }, [](const std::vector<double>& v){ return v[2]; });
#if defined(TEST_C99) && !defined(COMPILER_COMPARISON_TABLES)
screen_data([](const std::vector<double>& v){ return ::jn(static_cast<int>(v[0]), v[1]); }, [](const std::vector<double>& v){ return v[2]; });
#endif
#if defined(TEST_LIBSTDCXX) && !defined(COMPILER_COMPARISON_TABLES)
screen_data([](const std::vector<double>& v){ return std::tr1::cyl_bessel_j(static_cast<int>(v[0]), v[1]); }, [](const std::vector<double>& v){ return v[2]; });
#endif
#if defined(TEST_GSL) && !defined(COMPILER_COMPARISON_TABLES)
screen_data([](const std::vector<double>& v){ return gsl_sf_bessel_Jn(static_cast<int>(v[0]), v[1]); }, [](const std::vector<double>& v){ return v[2]; });
#endif
#if defined(TEST_RMATH) && !defined(COMPILER_COMPARISON_TABLES)
screen_data([](const std::vector<double>& v){ return bessel_j(v[1], static_cast<int>(v[0])); }, [](const std::vector<double>& v){ return v[2]; });
#endif
unsigned data_used = data.size();
std::string function = "cyl_bessel_j (integer order)[br](" + boost::lexical_cast<std::string>(data_used) + "/" + boost::lexical_cast<std::string>(data_total) + " tests selected)";
std::string function_short = "cyl_bessel_j (integer order)";
double time;
time = exec_timed_test([](const std::vector<double>& v){ return boost::math::cyl_bessel_j(static_cast<int>(v[0]), v[1]); });
std::cout << time << std::endl;
#if defined(COMPILER_COMPARISON_TABLES)
report_execution_time(time, std::string("Compiler Option Comparison on ") + platform_name(), "boost::math::cyl_bessel_j (integer orders)", get_compiler_options_name());
#else
#if !defined(COMPILER_COMPARISON_TABLES) && (defined(TEST_GSL) || defined(TEST_RMATH) || defined(TEST_C99) || defined(TEST_LIBSTDCXX))
report_execution_time(time, std::string("Library Comparison with ") + std::string(compiler_name()) + std::string(" on ") + platform_name(), function, boost_name());
#endif
report_execution_time(time, std::string("Compiler Comparison on ") + std::string(platform_name()), function_short, compiler_name() + std::string("[br]") + boost_name());
#endif
//
// Boost again, but with promotion to long double turned off:
//
#if !defined(COMPILER_COMPARISON_TABLES)
if(sizeof(long double) != sizeof(double))
{
time = exec_timed_test([](const std::vector<double>& v){ return boost::math::cyl_bessel_j(static_cast<int>(v[0]), v[1], boost::math::policies::make_policy(boost::math::policies::promote_double<false>())); });
std::cout << time << std::endl;
#if !defined(COMPILER_COMPARISON_TABLES) && (defined(TEST_GSL) || defined(TEST_RMATH) || defined(TEST_C99) || defined(TEST_LIBSTDCXX))
report_execution_time(time, std::string("Library Comparison with ") + std::string(compiler_name()) + std::string(" on ") + platform_name(), function, boost_name() + "[br]promote_double<false>");
#endif
report_execution_time(time, std::string("Compiler Comparison on ") + std::string(platform_name()), function_short, compiler_name() + std::string("[br]") + boost_name() + "[br]promote_double<false>");
}
#endif
#if defined(TEST_C99) && !defined(COMPILER_COMPARISON_TABLES)
time = exec_timed_test([](const std::vector<double>& v){ return ::jn(static_cast<int>(v[0]), v[1]); });
std::cout << time << std::endl;
report_execution_time(time, std::string("Library Comparison with ") + std::string(compiler_name()) + std::string(" on ") + platform_name(), function, "math.h");
#endif
#if defined(TEST_LIBSTDCXX) && !defined(COMPILER_COMPARISON_TABLES)
time = exec_timed_test([](const std::vector<double>& v){ return std::tr1::cyl_bessel_j(static_cast<int>(v[0]), v[1]); });
std::cout << time << std::endl;
report_execution_time(time, std::string("Library Comparison with ") + std::string(compiler_name()) + std::string(" on ") + platform_name(), function, "tr1/cmath");
#endif
#if defined(TEST_GSL) && !defined(COMPILER_COMPARISON_TABLES)
time = exec_timed_test([](const std::vector<double>& v){ return gsl_sf_bessel_Jn(static_cast<int>(v[0]), v[1]); });
std::cout << time << std::endl;
report_execution_time(time, std::string("Library Comparison with ") + std::string(compiler_name()) + std::string(" on ") + platform_name(), function, "GSL " GSL_VERSION);
#endif
#if defined(TEST_RMATH) && !defined(COMPILER_COMPARISON_TABLES)
time = exec_timed_test([](const std::vector<double>& v){ return bessel_j(v[1], static_cast<int>(v[0])); });
std::cout << time << std::endl;
report_execution_time(time, std::string("Library Comparison with ") + std::string(compiler_name()) + std::string(" on ") + platform_name(), function, "Rmath " R_VERSION_STRING);
#endif
return 0;
}
