int
gsl_sf_gamma_inc_e(const double a, const double x, gsl_sf_result * result)
{
if(x < 0.0) {
DOMAIN_ERROR(result);
}
else if(x == 0.0) {
return gsl_sf_gamma_e(a, result);
}
else if(a == 0.0)
{
return GAMMA_INC_A_0(x, result);
}
else if(a > 0.0)
{
return gamma_inc_a_gt_0(a, x, result);
}
else if(x > 0.25)
{
/* continued fraction seems to fail for x too small; otherwise
it is ok, independent of the value of |x/a|, because of the
non-oscillation in the expansion, i.e. the CF is
un-conditionally convergent for a < 0 and x > 0
*/
return gamma_inc_CF(a, x, result);
}
else if(fabs(a) < 0.5)
{
return gamma_inc_series(a, x, result);
}
else
{
/* a = fa + da; da >= 0 */
const double fa = floor(a);
const double da = a - fa;
gsl_sf_result g_da;
const int stat_g_da = ( da > 0.0 ? gamma_inc_a_gt_0(da, x, &g_da)
: GAMMA_INC_A_0(x, &g_da));
double alpha = da;
double gax = g_da.val;
/* Gamma(alpha-1,x) = 1/(alpha-1) (Gamma(a,x) - x^(alpha-1) e^-x) */
do
{
const double shift = exp(-x + (alpha-1.0)*log(x));
gax = (gax - shift) / (alpha - 1.0);
alpha -= 1.0;
} while(alpha > a);
result->val = gax;
result->err = 2.0*(1.0 + fabs(a))*GSL_DBL_EPSILON*fabs(gax);
return stat_g_da;
}
}
/// Lower Pochhammer symbol.
double
pochhammer_l(double a, double x)
{
if (a == x)
return std::numeric_limits<double>::infinity();
if (std::fmod(std::abs(a - x), M_PI) < 1.0e-12)
return std::numeric_limits<double>::infinity();
if (std::fmod(std::abs(a), M_PI) < 1.0e-12)
return std::numeric_limits<double>::infinity();
gsl_sf_result result_num;
int stat_num = gsl_sf_gamma_e(std::abs(a - x), &result_num);
gsl_sf_result result_den;
int stat_den = gsl_sf_gamma_e(std::abs(a), &result_den);
if (stat_num != GSL_SUCCESS && stat_den != GSL_SUCCESS)
{
std::ostringstream msg("Error in lpochhammer_l:");
msg << " a=" << a << " x=" << x;
throw std::runtime_error(msg.str());
}
else
return result_num.val / result_den.val;
}
/* series for small a and x, but not defined for a == 0 */
static int
gamma_inc_series(double a, double x, gsl_sf_result * result)
{
gsl_sf_result Q;
gsl_sf_result G;
const int stat_Q = gamma_inc_Q_series(a, x, &Q);
const int stat_G = gsl_sf_gamma_e(a, &G);
result->val = Q.val * G.val;
result->err = fabs(Q.val * G.err) + fabs(Q.err * G.val);
result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);
return GSL_ERROR_SELECT_2(stat_Q, stat_G);
}
int
gsl_sf_beta_e(const double x, const double y, gsl_sf_result * result)
{
if((x > 0 && y > 0) && x < 50.0 && y < 50.0) {
/* Handle the easy case */
gsl_sf_result gx, gy, gxy;
gsl_sf_gamma_e(x, &gx);
gsl_sf_gamma_e(y, &gy);
gsl_sf_gamma_e(x+y, &gxy);
result->val = (gx.val*gy.val)/gxy.val;
result->err = gx.err * fabs(gy.val/gxy.val);
result->err += gy.err * fabs(gx.val/gxy.val);
result->err += fabs((gx.val*gy.val)/(gxy.val*gxy.val)) * gxy.err;
result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);
return GSL_SUCCESS;
}
else if (isnegint(x) || isnegint(y)) {
DOMAIN_ERROR(result);
} else if (isnegint(x+y)) { /* infinity in the denominator */
result->val = 0.0;
result->err = 0.0;
return GSL_SUCCESS;
} else {
gsl_sf_result lb;
double sgn;
int stat_lb = gsl_sf_lnbeta_sgn_e(x, y, &lb, &sgn);
if(stat_lb == GSL_SUCCESS) {
int status = gsl_sf_exp_err_e(lb.val, lb.err, result);
result->val *= sgn;
return status;
}
else {
result->val = 0.0;
result->err = 0.0;
return stat_lb;
}
}
}
/// Non-normalized lower incomplete gamma functions.
double
gamma_l(double a, double x)
{
gsl_sf_result result;
int stat = gsl_sf_gamma_e(a, &result);
if (stat != GSL_SUCCESS)
{
std::ostringstream msg("Error in gamma_q:");
msg << " a=" << a << " x=" << x;
throw std::runtime_error(msg.str());
}
else
return result.val - gamma_u(a, x);
}
static int
gamma_inc_a_gt_0(double a, double x, gsl_sf_result * result)
{
/* x > 0 and a > 0; use result for Q */
gsl_sf_result Q;
gsl_sf_result G;
const int stat_Q = gsl_sf_gamma_inc_Q_e(a, x, &Q);
const int stat_G = gsl_sf_gamma_e(a, &G);
result->val = G.val * Q.val;
result->err = fabs(G.val * Q.err) + fabs(G.err * Q.val);
result->err += 2.0*GSL_DBL_EPSILON * fabs(result->val);
return GSL_ERROR_SELECT_2(stat_G, stat_Q);
}
APLFLOAT PrimFnMonQuoteDotFisF
(APLFLOAT aplFloatRht,
LPPRIMSPEC lpPrimSpec)
{
int iRet;
gsl_sf_result gsr = {0};
// Check for indeterminates: !N for integer N < 0
if (aplFloatRht < 0)
{
if (aplFloatRht EQ floor (aplFloatRht)
|| aplFloatRht EQ ceil (aplFloatRht))
return TranslateQuadICIndex (0,
ICNDX_QDOTn,
aplFloatRht,
FALSE);
} // End IF
// Check for PosInfinity
if (IsFltPosInfinity (aplFloatRht))
return fltPosInfinity;
// Check for too large for GSL
if ((aplFloatRht + 1) > GSL_SF_GAMMA_XMAX)
RaiseException (EXCEPTION_DOMAIN_ERROR, 0, 0, NULL);
// Use the GNU Scientific Library Gamma function
iRet = gsl_sf_gamma_e (aplFloatRht + 1, &gsr);
// Check the return code
switch (iRet)
{
case GSL_SUCCESS:
break;
case GSL_FAILURE:
case GSL_EDOM:
case GSL_ERANGE:
RaiseException (EXCEPTION_DOMAIN_ERROR, 0, 0, NULL);
defstop
break;
} // End SWITCH
return gsr.val;
} // End PrimFnMonQuoteDotFisF
int gsl_sf_zeta_e(const double s, gsl_sf_result * result)
{
/* CHECK_POINTER(result) */
if(s == 1.0) {
DOMAIN_ERROR(result);
}
else if(s >= 0.0) {
return riemann_zeta_sgt0(s, result);
}
else {
/* reflection formula, [Abramowitz+Stegun, 23.2.5] */
gsl_sf_result zeta_one_minus_s;
const int stat_zoms = riemann_zeta1ms_slt0(s, &zeta_one_minus_s);
const double sin_term = (fmod(s,2.0) == 0.0) ? 0.0 : sin(0.5*M_PI*fmod(s,4.0))/M_PI;
if(sin_term == 0.0) {
result->val = 0.0;
result->err = 0.0;
return GSL_SUCCESS;
}
else if(s > -170) {
/* We have to be careful about losing digits
* in calculating pow(2 Pi, s). The gamma
* function is fine because we were careful
* with that implementation.
* We keep an array of (2 Pi)^(10 n).
*/
const double twopi_pow[18] = { 1.0,
9.589560061550901348e+007,
9.195966217409212684e+015,
8.818527036583869903e+023,
8.456579467173150313e+031,
8.109487671573504384e+039,
7.776641909496069036e+047,
7.457457466828644277e+055,
7.151373628461452286e+063,
6.857852693272229709e+071,
6.576379029540265771e+079,
6.306458169130020789e+087,
6.047615938853066678e+095,
5.799397627482402614e+103,
5.561367186955830005e+111,
5.333106466365131227e+119,
5.114214477385391780e+127,
4.904306689854036836e+135
};
const int n = floor((-s)/10.0);
const double fs = s + 10.0*n;
const double p = pow(2.0*M_PI, fs) / twopi_pow[n];
gsl_sf_result g;
const int stat_g = gsl_sf_gamma_e(1.0-s, &g);
result->val = p * g.val * sin_term * zeta_one_minus_s.val;
result->err = fabs(p * g.val * sin_term) * zeta_one_minus_s.err;
result->err += fabs(p * sin_term * zeta_one_minus_s.val) * g.err;
result->err += GSL_DBL_EPSILON * (fabs(s)+2.0) * fabs(result->val);
return GSL_ERROR_SELECT_2(stat_g, stat_zoms);
}
else {
/* The actual zeta function may or may not
* overflow here. But we have no easy way
* to calculate it when the prefactor(s)
* overflow. Trying to use log's and exp
* is no good because we loose a couple
* digits to the exp error amplification.
* When we gather a little more patience,
* we can implement something here. Until
* then just give up.
*/
OVERFLOW_ERROR(result);
}
}
}
