double loghyperg1F1(double a, double b, double x, int laplace)
{
double y;
if (laplace == 0) {
if (x <0) {
/* Since Linux system tends to report error for negative x, we
use the following fomular to convert it to positive value
1F1(a, b, x) = 1F1(b - a, b, -x) * exp(x) */
y = log(hyperg(b-a, b, -x)) + x;
}
else {
y = log( hyperg(a, b, x));
}
}
else {
/* Laplace approximation assumes -x for x positive
if ( x <= 0.0 ){y = loghyperg1F1_laplace(a, b, -x); }
else { y = loghyperg1F1_laplace(b - a, b, x) + x;} */
y = loghyperg1F1_laplace(a, b, x);
}
// Rprintf("LOG Cephes 1F1(%lf, %lf, %lf) = %lf (%lf)\n", a,b,x,log(y), y);
// ly = hyperg1F1_laplace(a,b,x);
// Rprintf("called from hyperg1F1: LOG Pos 1F1(%lf, %lf, %lf) = %lf (%lf)\n", a,b,x,ly, exp(ly));
if (!R_FINITE(y) && laplace == 0) {
warning("Cephes 1F1 function returned NA, using Laplace approximation");
y = loghyperg1F1_laplace(a, b, x); // try Laplace approximation
}
return(y);
}
double hyperg(double a, double b, double x)
{
double asum, psum, acanc, pcanc = 0, temp;
/* See if a Kummer transformation will help */
temp = b - a;
if (fabs(temp) < 0.001 * fabs(a))
return(exp(x) * hyperg(temp, b, -x));
psum = hy1f1p(a, b, x, &pcanc);
if (pcanc < 1.0e-15)
goto done;
/* try asymptotic series */
asum = hy1f1a(a, b, x, &acanc);
/* Pick the result with less estimated error */
if (acanc < pcanc) {
pcanc = acanc;
psum = asum;
}
done:
if (pcanc > 1.0e-12) {
it_warning("hyperg(): partial loss of precision");
}
return(psum);
}
double hyperg (double a, double b, double x)
{
double asum, psum, acanc, temp, pcanc = 0;
/* See if a Kummer transformation will help */
temp = b - a;
if (fabs(temp) < 0.001 * fabs(a))
return exp(x) * hyperg(temp, b, -x);
psum = hy1f1p(a, b, x, &pcanc);
if (pcanc < 1.0e-15)
goto done;
/* try asymptotic series */
asum = hy1f1a(a, b, x, &acanc);
/* Pick the result with less estimated error */
if (acanc < pcanc) {
pcanc = acanc;
psum = asum;
}
done:
if (pcanc > 1.0e-12)
mtherr("hyperg", CEPHES_PLOSS);
return psum;
}
double cephes_bessel_Iv (double v, double x)
{
double ax, t = floor(v);
int sign;
/* If v is a negative integer, invoke symmetry */
if (v < 0.0 && t == v) {
t = v = -v;
}
/* If x is negative, require v to be an integer */
sign = 1;
if (x < 0.0) {
if (t != v) {
mtherr("iv", DOMAIN);
return 0.0;
}
if (v != 2.0 * floor(v/2.0))
sign = -1;
}
/* Avoid logarithm singularity */
if (x == 0.0) {
if (v == 0.0)
return 1.0;
if (v < 0.0) {
mtherr("iv", CEPHES_OVERFLOW);
return MAXNUM;
} else
return 0.0;
}
ax = fabs(x);
t = v * log(0.5 * ax) - x;
t = sign * exp(t) / cephes_gamma(v + 1.0);
ax = v + 0.5;
return t * hyperg(ax, 2*ax, 2*x);
}
