// R file: lgammacor.c
private static double lgammacor(double x)
{
double tmp;
/* For IEEE double precision DBL_EPSILON = 2^-52 = 2.220446049250313e-16 :
* xbig = 2 ^ 26.5
* xmax = DBL_MAX / 48 = 2^1020 / 3
*/
int nalgm = 5;
double
xbig = 94906265.62425156,
xmax = 3.745194030963158e306;
if (x < 10)
{
// ML_ERR_return_NAN
return(RVaria.R_NaN);
}
else if (x >= xmax)
{
// ML_ERROR(ME_UNDERFLOW, "lgammacor");
/* allow to underflow below */
}
else if (x < xbig)
{
tmp = 10 / x;
return(RVaria.chebyshev_eval(tmp * tmp * 2 - 1, algmcs, nalgm) / x);
}
return(1 / (x * 12));
}
/*
* R rile
* dpois.c
*/
public static double DPoisson(double x, double lambda, bool giveLog)
{
if (double.IsNaN(x) || double.IsNaN(lambda))
{
return(x + lambda);
}
if (lambda < 0)
{
return(double.NaN); // ML_ERR_return_NAN;
}
if ((Math.Abs((x) - Math.Floor(x)) > 1e-7 * RVaria.fmax2(1.0, Math.Abs(x))))
{
//MATHLIB_WARNING("non-integer x = %f", x);
return(giveLog ? double.NegativeInfinity : 0.0);
}
if (x < 0 || !x.IsFinite())
{
return(giveLog ? double.NegativeInfinity : 0.0);
}
x = Math.Round(x);
return(dpois_raw(x, lambda, giveLog));
}
internal static double dpois_raw(double x, double lambda, bool log_p)
{
/* x >= 0 ; integer for dpois(), but not e.g. for pgamma()!
* lambda >= 0
*/
if (lambda == 0)
{
return((x == 0) ? (log_p ? 0.0 : 1.0) : (log_p ? double.NegativeInfinity : 0.0));
}
if (!lambda.IsFinite())
{
return(log_p ? double.NegativeInfinity : 0.0);
}
if (x < 0)
{
return((log_p ? double.NegativeInfinity : 0.0));
}
if (x <= lambda * RVaria.DBL_MIN)
{
return((log_p ? (-lambda) : Math.Exp(-lambda)));
}
if (lambda < x * RVaria.DBL_MIN)
{
return(log_p
? (-lambda + x * Math.Log(lambda) - Functions.LogGamma(x + 1))
: Math.Exp(-lambda + x * Math.Log(lambda) - Functions.LogGamma(x + 1)));
}
return(RVaria.R_D_fexp(RVaria.M_2PI * x, -Functions.StirlingError(x) - RVaria.bd0(x, lambda), log_p));
}
/* Computes the derivative polynomial as the initial
* polynomial and computes l1 no-shift h polynomials. */
void noshft(int l1)
{
int i, j, jj, n = nn - 1, nm1 = n - 1;
double t1, t2, xni;
for (i = 0; i < n; i++)
{
xni = (double)(nn - i - 1);
this.hr[i] = xni * this.pr[i] / n;
this.hi[i] = xni * this.pi[i] / n;
}
for (jj = 1; jj <= l1; jj++)
{
if (RVaria.hypot(this.hr[n - 1], this.hi[n - 1]) <= eta * 10.0 * RVaria.hypot(this.pr[n - 1], this.pi[n - 1]))
{
/* If the constant term is essentially zero, */
/* shift h coefficients. */
for (i = 1; i <= nm1; i++)
{
j = this.nn - i;
this.hr[j - 1] = this.hr[j - 2];
this.hi[j - 1] = this.hi[j - 2];
}
this.hr[0] = 0.0;
this.hi[0] = 0.0;
}
else
{
cdivid(-pr[nn - 1], -pi[nn - 1], hr[n - 1], hi[n - 1], out tr, out ti);
for (i = 1; i <= nm1; i++)
{
j = nn - i;
t1 = hr[j - 2];
t2 = hi[j - 2];
hr[j - 1] = tr * t1 - ti * t2 + pr[j - 1];
hi[j - 1] = tr * t2 + ti * t1 + pi[j - 1];
}
hr[0] = pr[0];
hi[0] = pi[0];
}
}
}
public static double QExp(double p, double scale = 1.0, bool lowerTail = true, bool logP = false)
{
if (double.IsNaN(p) || double.IsNaN(scale))
{
return(p + scale);
}
if (scale < 0)
{
return(double.NaN); //ML_ERR_return_NAN;
}
if ((logP && p > 0) || (!logP && (p < 0 || p > 1)))
//ML_ERR_return_NAN
{
return(RVaria.R_NaN);
}
if (p == (lowerTail ? (logP ? double.NegativeInfinity : 0.0) : (logP ? 0.0 : 1.0)))
{
return(0);
}
return(-scale * (lowerTail ? (logP ? ((p) > -RVaria.M_LN2 ? Math.Log(-RVaria.expm1(p)) : RVaria.log1p(-Math.Exp(p))) : RVaria.log1p(-p)) : (logP ? (p) : Math.Log(p))));
}
public static double[] PExp(double[] xA, double scale = 1.0, bool lowerTail = true, bool logP = false)
{
double[] rep = new double[xA.Length];
for (int i = 0; i < xA.Length; i++)
{
double x = xA[i];
if (double.IsNaN(x) || double.IsNaN(scale))
{
rep[i] = x + scale;
}
if (scale < 0)
{
rep[i] = double.NaN;
}
if (x <= 0.0)
{
rep[i] = (lowerTail ? (logP ? double.NegativeInfinity : 0.0) : (logP ? 0.0 : 1.0));
}
/* same as weibull( shape = 1): */
x = -(x / scale);
if (lowerTail)
{
rep[i] = (logP
? (x > -RVaria.M_LN2 ? Math.Log(-RVaria.expm1(x)) : RVaria.log1p(-Math.Exp(x)))
: -RVaria.expm1(x));
}
/* else: !lower_tail */
else
{
rep[i] = (logP ? (x) : Math.Exp(x));
}
}
return(rep);
}
void calct(out bool bool_)
{
/*
* computes t = -p(s)/h(s).
* bool - logical, set true if h(s) is essentially zero.
*
*/
int n = nn - 1;
double hvi, hvr;
/* evaluate h(s). */
polyev(n, sr, si, hr, hi, qhr, qhi, out hvr, out hvi);
bool_ = RVaria.hypot(hvr, hvi) <= are * 10.0 * RVaria.hypot(hr[n - 1], hi[n - 1]);
if (!bool_)
{
cdivid(-pvr, -pvi, hvr, hvi, out tr, out ti);
}
else
{
tr = 0.0;
ti = 0.0;
}
}
double errev(int n, double[] qr, double[] qi, double ms, double mp, double a_re, double m_re)
{
/*
* bounds the error in evaluating the polynomial by the horner
* recurrence.
*
* qr,qi - the partial sum vectors
* ms - modulus of the point
* mp - modulus of polynomial value
* a_re,m_re - error bounds on complex addition and multiplication
*
*/
double e;
int i;
e = RVaria.hypot(qr[0], qi[0]) * m_re / (a_re + m_re);
for (i = 0; i < n; i++)
{
e = e * ms + RVaria.hypot(qr[i], qi[i]);
}
return(e * (a_re + m_re) - mp * m_re);
}
internal static double poisson_rand(double mu)
{
glblCount++;
/* Local Vars [initialize some for -Wall]: */
//double del;
difmuk = 0.0; E = 0.0; fk = 0.0;
//double fx, fy, g, px, py, t;
u = 0.0;
//double v, x;
pois = -1.0;
//int k, kflag;
//bool big_mu;
bool directToStepF = false;
new_big_mu = false;
big_mu = mu >= 10.0;
if (big_mu)
{
new_big_mu = false;
}
if (!(big_mu && mu == muprev))
{/* maybe compute new persistent par.s */
if (big_mu)
{
new_big_mu = true;
/* Case A. (recalculation of s,d,l because mu has changed):
* The poisson probabilities pk exceed the discrete normal
* probabilities fk whenever k >= m(mu).
*/
muprev = mu;
s = Math.Sqrt(mu);
d = 6.0 * mu * mu;
big_l = Math.Floor(mu - 1.1484);
/* = an upper bound to m(mu) for all mu >= 10.*/
}
else
{ /* Small mu ( < 10) -- not using normal approx. */
/* Case B. (start new table and calculate p0 if necessary) */
/*muprev = 0.;-* such that next time, mu != muprev ..*/
if (mu != muprev)
{
muprev = mu;
m = Math.Max(1, (int)mu);
l = 0; /* pp[] is already ok up to pp[l] */
q = p0 = p = Math.Exp(-mu);
}
for (;;)
{
/* Step U. uniform sample for inversion method */
u = UniformDistribution.RUnif();
if (u <= p0)
{
return(0.0);
}
/* Step T. table comparison until the end pp[l] of the
* pp-table of cumulative poisson probabilities
* (0.458 > ~= pp[9](= 0.45792971447) for mu=10 ) */
if (l != 0)
{
for (k = (u <= 0.458) ? 1 : Math.Min(l, m); k <= l; k++)
{
if (u <= pp[k])
{
return((double)k);
}
}
if (l == 35) /* u > pp[35] */
{
continue;
}
}
/* Step C. creation of new poisson
* probabilities p[l..] and their cumulatives q =: pp[k] */
l++;
for (k = l; k <= 35; k++)
{
p *= mu / k;
q += p;
pp[k] = q;
if (u <= q)
{
l = k;
return((double)k);
}
}
l = 35;
} /* end(repeat) */
} /* mu < 10 */
} /* end {initialize persistent vars} */
/* Only if mu >= 10 : ----------------------- */
/* Step N. normal sample */
g = mu + s * NormalDistribution.RNorm();/* norm_rand() ~ N(0,1), standard normal */
if (g >= 0.0)
{
pois = Math.Floor(g);
/* Step I. immediate acceptance if pois is large enough */
if (pois >= big_l)
{
return(pois);
}
/* Step S. squeeze acceptance */
fk = pois;
difmuk = mu - fk;
u = UniformDistribution.RUnif(); /* ~ U(0,1) - sample */
if (d * u >= difmuk * difmuk * difmuk)
{
return(pois);
}
}
/* Step P. preparations for steps Q and H.
* (recalculations of parameters if necessary) */
if (new_big_mu || mu != muprev2)
{
/* Careful! muprev2 is not always == muprev
* because one might have exited in step I or S
*/
muprev2 = mu;
omega = RVaria.M_1_SQRT_2PI / s;
/* The quantities b1, b2, c3, c2, c1, c0 are for the Hermite
* approximations to the discrete normal probabilities fk. */
b1 = one_24 / mu;
b2 = 0.3 * b1 * b1;
c3 = one_7 * b1 * b2;
c2 = b2 - 15.0 * c3;
c1 = b1 - 6.0 * b2 + 45.0 * c3;
c0 = 1.0 - b1 + 3.0 * b2 - 15.0 * c3;
c = 0.1069 / mu; /* guarantees majorization by the 'hat'-function. */
}
if (g >= 0.0)
{
/* 'Subroutine' F is called (kflag=0 for correct return) */
kflag = 0;
//goto Step_F;
//F(mu);
directToStepF = true;
countDirectToStepF++;
}
for (;;)
{
if (!directToStepF)
{
/* Step E. Exponential Sample */
E = ExponentialDistribution.RExp(); /* ~ Exp(1) (standard exponential) */
/* sample t from the laplace 'hat'
* (if t <= -0.6744 then pk < fk for all mu >= 10.) */
u = 2 * UniformDistribution.RUnif() - 1.0;
t = 1.8 + RVaria.fsign(E, u);
}
if ((t > -0.6744) || directToStepF)
{
if (!directToStepF)
{
pois = Math.Floor(mu + s * t);
fk = pois;
difmuk = mu - fk;
kflag = 1;
}
/* 'subroutine' F is called (kflag=1 for correct return) */
F(mu);
directToStepF = false;
//Step_F: /* 'subroutine' F : calculation of px,py,fx,fy. */
// if (pois < 10)
// { /* use factorials from table fact[] */
// px = -mu;
// py = Math.Pow(mu, pois) / fact[(int)pois];
// }
// else
// {
// /* Case pois >= 10 uses polynomial approximation
// a0-a7 for accuracy when advisable */
// del = one_12 / fk;
// del = del * (1.0 - 4.8 * del * del);
// v = difmuk / fk;
// if (Math.Abs(v) <= 0.25)
// px = fk * v * v * (((((((a7 * v + a6) * v + a5) * v + a4) *
// v + a3) * v + a2) * v + a1) * v + a0)
// - del;
// else /* |v| > 1/4 */
// px = fk * Math.Log(1.0 + v) - difmuk - del;
// py = R.M_1_SQRT_2PI / Math.Sqrt(fk);
// }
// x = (0.5 - difmuk) / s;
// x *= x;/* x^2 */
// fx = -0.5 * x;
// fy = omega * (((c3 * x + c2) * x + c1) * x + c0);
if (kflag > 0)
{
/* Step H. Hat acceptance (E is repeated on rejection) */
if (c * Math.Abs(u) <= py * Math.Exp(px + E) - fy * Math.Exp(fx + E))
{
break;
}
}
else
/* Step Q. Quotient acceptance (rare case) */
if (fy - u * fy <= py * Math.Exp(px - fx))
{
break;
}
}/* t > -.67.. */
}
return(pois);
}
/*
*
* R file
* dnorm.c
*
*/
/*
* Pdf
*/
public static double DNorm(double x, double mu = 0, double sigma = 1, bool give_log = false)
{
// In dnorm.c, the function name is dnorm4!
if (double.IsNaN(x) || double.IsNaN(mu) || double.IsNaN(sigma))
{
return(RVaria.R_NaN); // return x + mu + sigma;
}
if (!sigma.IsFinite())
{
return(give_log ? double.NegativeInfinity : 0.0);
}
if (!x.IsFinite() && mu == x)
{
return(RVaria.R_NaN); /* x-mu is NaN */
}
if (sigma <= 0)
{
if (sigma < 0)
{
// ML_ERR_return_NAN;
return(RVaria.R_NaN);
}
/* sigma == 0 */
return((x == mu) ? double.PositiveInfinity : (give_log ? double.NegativeInfinity : 0.0));
}
x = (x - mu) / sigma;
if (!x.IsFinite())
{
return(give_log ? double.NegativeInfinity : 0.0);
}
x = Math.Abs(x);
if (x >= 2 * Math.Sqrt(RVaria.DBL_MAX))
{
return(give_log ? double.NegativeInfinity : 0.0);
}
if (give_log)
{
return(-(RVaria.M_LN_SQRT_2PI + 0.5 * x * x + Math.Log(sigma)));
}
// M_1_SQRT_2PI = 1 / sqrt(2 * pi)
//#ifdef MATHLIB_FAST_dnorm
// // and for R <= 3.0.x and R-devel upto 2014-01-01:
// return M_1_SQRT_2PI * exp(-0.5 * x * x) / sigma;
//#else
// more accurate, less fast :
if (x < 5)
{
return(RVaria.M_1_SQRT_2PI * Math.Exp(-0.5 * x * x) / sigma);
}
/* ELSE:
*
* x*x may lose upto about two digits accuracy for "large" x
* Morten Welinder's proposal for PR#15620
* https://bugs.r-project.org/bugzilla/show_bug.cgi?id=15620
*
* -- 1 -- No hoop jumping when we underflow to zero anyway:
*
* -x^2/2 < log(2)*.Machine$double.min.exp <==>
* x > sqrt(-2*log(2)*.Machine$double.min.exp) =IEEE= 37.64031
* but "thanks" to denormalized numbers, underflow happens a bit later,
* effective.D.MIN.EXP <- with(.Machine, double.min.exp + double.ulp.digits)
* for IEEE, DBL_MIN_EXP is -1022 but "effective" is -1074
* ==> boundary = sqrt(-2*log(2)*(.Machine$double.min.exp + .Machine$double.ulp.digits))
* =IEEE= 38.58601
* [on one x86_64 platform, effective boundary a bit lower: 38.56804]
*/
if (x > Math.Sqrt(-2 * RVaria.M_LN2 * (RVaria.DBL_MIN_EXP + 1 - RVaria.DBL_MANT_DIG)))
{
return(0.0);
}
/* Now, to get full accurary, split x into two parts,
* x = x1+x2, such that |x2| <= 2^-16.
* Assuming that we are using IEEE doubles, that means that
* x1*x1 is error free for x<1024 (but we have x < 38.6 anyway).
*
* If we do not have IEEE this is still an improvement over the naive formula.
*/
double x1 = // R_forceint(x * 65536) / 65536 =
RVaria.ldexp(Math.Round(RVaria.ldexp(x, 16)), -16);
double x2 = x - x1;
return(RVaria.M_1_SQRT_2PI / sigma *
(Math.Exp(-0.5 * x1 * x1) * Math.Exp((-0.5 * x2 - x1) * x2)));
}
/* R file: gamma.c
* name used in R: gammafn
*/
public static double Gamma(double x)
{
int i, n;
double y;
double sinpiy, value;
const double
xmin = -170.5674972726612,
xmax = 171.61447887182298,
xsml = 2.2474362225598545e-308,
dxrel = 1.490116119384765696e-8;
const int
ngam = 22;
if (double.IsNaN(x))
{
return(x);
}
/* If the argument is exactly zero or a negative integer
* then return NaN. */
if (x == 0 || (x < 0 && x == Math.Round(x)))
{
// ML_ERROR(ME_DOMAIN, "gammafn");
return(double.NaN);
}
y = Math.Abs(x);
if (y <= 10)
{
/* Compute gamma(x) for -10 <= x <= 10
* Reduce the interval and find gamma(1 + y) for 0 <= y < 1
* first of all. */
n = (int)x;
if (x < 0)
{
--n;
}
y = x - n;/* n = floor(x) ==> y in [ 0, 1 ) */
--n;
value = RVaria.chebyshev_eval(y * 2 - 1, gamcs, ngam) + .9375;
if (n == 0)
{
return(value);/* x = 1.dddd = 1+y */
}
if (n < 0)
{
/* compute gamma(x) for -10 <= x < 1 */
/* exact 0 or "-n" checked already above */
/* The answer is less than half precision */
/* because x too near a negative integer. */
if ((x < -0.5) && (Math.Abs(x - (int)(x - 0.5) / x) < dxrel))
{
// ML_ERROR(ME_PRECISION, "gammafn");
}
/* The argument is so close to 0 that the result would overflow. */
if (y < xsml)
{
// ML_ERROR(ME_RANGE, "gammafn");
if (x > 0)
{
return(double.PositiveInfinity);
}
else
{
return(double.NegativeInfinity);
}
}
n = -n;
for (i = 0; i < n; i++)
{
value /= (x + i);
}
return(value);
}
else
{
/* gamma(x) for 2 <= x <= 10 */
for (i = 1; i <= n; i++)
{
value *= (y + i);
}
return(value);
}
}
else
{
/* gamma(x) for y = |x| > 10. */
if (x > xmax)
{ /* Overflow */
// ML_ERROR(ME_RANGE, "gammafn");
return(double.PositiveInfinity);
}
if (x < xmin)
{ /* Underflow */
// ML_ERROR(ME_UNDERFLOW, "gammafn");
return(0.0);
}
if (y <= 50 && y == (int)y)
{ /* compute (n - 1)! */
value = 1.0;
for (i = 2; i < y; i++)
{
value *= i;
}
}
else
{ /* normal case */
value = Math.Exp((y - 0.5) * Math.Log(y) - y + RVaria.M_LN_SQRT_2PI +
((2 * y == (int)2 * y) ? StirlingError(y) : lgammacor(y)));
}
if (x > 0)
{
return(value);
}
if (Math.Abs((x - (int)(x - 0.5)) / x) < dxrel)
{
/* The answer is less than half precision because */
/* the argument is too near a negative integer. */
// ML_ERROR(ME_PRECISION, "gammafn");
}
sinpiy = RVaria.sinpi(y);
if (sinpiy == 0)
{ /* Negative integer arg - overflow */
// ML_ERROR(ME_RANGE, "gammafn");
return(double.PositiveInfinity);
}
return(-RVaria.M_PI / (y * sinpiy * value));
}
}
/* R file: integrate.c
*/
private static void rdqagse(Parameters parameters, Workspace ws, Results results)
{
/* Local variables */
bool noext, extrap;
bool goto140 = false;
int k, ksgn, nres;
int ierro;
int ktmin, nrmax;
int iroff1, iroff2, iroff3;
int id;
int numrl2;
int jupbnd;
int maxerr;
int last;
int ier;
int neval;
int rdqk21_count = 0;
double[] res3la = new double[4];
double[] rlist2 = new double[53];
double
result = 0.0,
abserr = 0.0,
abseps,
area,
area1,
area2,
area12,
dres,
epmach;
double
a1,
a2,
b1,
b2,
defabs,
defab1,
defab2,
oflow,
uflow,
resabs,
reseps;
double
error1,
error2,
erro12,
errbnd,
erlast,
errmax,
errsum;
double
correc = 0.0,
erlarg = 0.0,
ertest = 0.0,
small = 0.0;
//Let's go
epmach = RVaria.DBL_EPSILON;
ier = 0;
neval = 0;
last = 0;
setArray(ws.alist);
setArray(ws.blist);
setArray(ws.rlist);
setArray(ws.elist);
setArray(ws.iord);
ws.alist[1] = parameters.a;
ws.blist[1] = parameters.b;
ws.rlist[1] = 0.0;
ws.elist[1] = 0.0;
//TODO déplacer(?) dans compute
if ((parameters.epsabs <= 0.0) && (parameters.epsrel < RVaria.fmax2(epmach * 50.0, 5e-29)))
{
ier = 6;
return;
}
/* first approximation to the integral */
/* ----------------------------------- */
uflow = RVaria.DBL_MIN;
oflow = RVaria.DBL_MAX;
ierro = 0;
rdqk21(parameters.f, parameters.a, parameters.b, out result, out abserr, out defabs, out resabs, ref rdqk21_count);
/* test on accuracy. */
dres = Math.Abs(result);
errbnd = RVaria.fmax2(parameters.epsabs, parameters.epsrel * dres);
last = 1;
ws.rlist[1] = result;
ws.elist[1] = abserr;
ws.iord[1] = 1;
if ((abserr <= (epmach * 100.0 * defabs)) && (abserr > errbnd))
{
ier = 2;
}
if (ws.limit == 1)
{
ier = 1;
}
if ((ier != 0) || (abserr <= errbnd && abserr != resabs) ||
(abserr == 0.0))
{
goto140 = true;
goto L139;
}
/* 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.0 - epmach * 50.0) * defabs)
{
ksgn = 1;
}
/*------------------------*/
for (last = 2; last <= parameters.limit; ++(last))
{
/* bisect the subinterval with the nrmax-th largest error estimate. */
a1 = ws.alist[maxerr];
b1 = (ws.alist[maxerr] + ws.blist[maxerr]) * .5;
a2 = b1;
b2 = ws.blist[maxerr];
erlast = errmax;
rdqk21(parameters.f, a1, b1, out area1, out error1, out resabs, out defab1, ref rdqk21_count);
rdqk21(parameters.f, a2, b2, out area2, out error2, out resabs, out defab2, ref rdqk21_count);
/* improve previous approximations to integral
* and error and test for accuracy. */
area12 = area1 + area2;
erro12 = error1 + error2;
errsum = errsum + erro12 - errmax;
area = area + area12 - ws.rlist[maxerr];
if (!(defab1 == error1 || defab2 == error2))
{
if (Math.Abs(ws.rlist[maxerr] - area12) <= Math.Abs(area12) * 1e-5 &&
erro12 >= errmax * .99)
{
if (extrap)
{
++iroff2;
}
else /* if(! extrap) */
{
++iroff1;
}
}
if (last > 10 && erro12 > errmax)
{
++iroff3;
}
}
ws.rlist[maxerr] = area1;
ws.rlist[last] = area2;
errbnd = RVaria.fmax2(parameters.epsabs, parameters.epsrel * Math.Abs(area));
/* 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 == ws.limit)
{
ier = 1;
}
/* set error flag in the case of bad integrand behaviour
* at a point of the integration range. */
if (RVaria.fmax2(Math.Abs(a1), Math.Abs(b2)) <=
(epmach * 100.0 + 1.0) * (Math.Abs(a2) + uflow * 1e3))
{
ier = 4;
}
/* append the newly-created intervals to the list. */
if (error2 > error1)
{
ws.alist[maxerr] = a2;
ws.alist[last] = a1;
ws.blist[last] = b1;
ws.rlist[maxerr] = area2;
ws.rlist[last] = area1;
ws.elist[maxerr] = error2;
ws.elist[last] = error1;
}
else
{
ws.alist[last] = a2;
ws.blist[maxerr] = b1;
ws.blist[last] = b2;
ws.elist[maxerr] = error1;
ws.elist[last] = error2;
}
/* call subroutine dqpsrt 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:*/
rdqpsrt(ws.limit, last, ref maxerr, out errmax, ws.elist, ws.iord, ref nrmax);
if (errsum <= errbnd)
{
goto L115;/* ***jump out of do-loop */
}
if (ier != 0)
{
break;
}
if (last == 2)
{ /* L80: */
small = Math.Abs(parameters.b - parameters.a) * .375;
erlarg = errsum;
ertest = errbnd;
rlist2[1] = area; continue;
}
if (noext)
{
continue;
}
erlarg -= erlast;
if (Math.Abs(b1 - a1) > small)
{
erlarg += erro12;
}
if (!extrap)
{
/* test whether the interval to be bisected next is the
* smallest interval. */
if (Math.Abs(ws.blist[maxerr] - ws.alist[maxerr]) > small)
{
continue;
}
extrap = true;
nrmax = 2;
}
if (ierro != 3 && erlarg > ertest)
{
/* 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 > parameters.limit / 2 + 2)
{
jupbnd = parameters.limit + 3 - last;
}
for (k = id; k <= jupbnd; ++k)
{
maxerr = ws.iord[nrmax];
errmax = ws.elist[maxerr];
if (Math.Abs(ws.blist[maxerr] - ws.alist[maxerr]) > small)
{
goto L90;
}
++nrmax;
/* L50: */
}
}
/* perform extrapolation. L60: */
++numrl2;
rlist2[numrl2 - 1] = area;
rdqelg(ref numrl2, rlist2, out reseps, out abseps, res3la, ref nres);
++ktmin;
if (ktmin > 5 && abserr < errsum * .001)
{
ier = 5;
}
if (abseps < abserr)
{
ktmin = 0;
abserr = abseps;
result = reseps;
correc = erlarg;
ertest = RVaria.fmax2(parameters.epsabs, parameters.epsrel * Math.Abs(reseps));
if (abserr <= ertest)
{
break;
}
}
/* prepare bisection of the smallest interval. L70: */
if (numrl2 == 1)
{
noext = true;
}
if (ier == 5)
{
break;
}
maxerr = ws.iord[1];
errmax = ws.elist[maxerr];
nrmax = 1;
extrap = false;
small *= 0.5;
erlarg = errsum;
L90:
;
}
/* L100: set final result and error estimate. */
/* ------------------------------------ */
if (abserr == oflow)
{
goto L115;
}
if (ier + ierro == 0)
{
goto L110;
}
if (ierro == 3)
{
abserr += correc;
}
if (ier == 0)
{
ier = 3;
}
if (result == 0.0 || area == 0.0)
{
if (abserr > errsum)
{
goto L115;
}
if (area == 0.0)
{
goto L130;
}
}
else
{ /* L105:*/
if (abserr / Math.Abs(result) > errsum / Math.Abs(area))
{
goto L115;
}
}
L110: /* test on divergence. */
if (ksgn == -1 && RVaria.fmax2(Math.Abs(result), Math.Abs(area)) <= defabs * .01)
{
goto L130;
}
if (.01 > result / area || result / area > 100.0 || errsum > Math.Abs(area))
{
ier = 5;
}
goto L130;
L115: /* compute global integral sum. */
result = 0.0;
for (k = 1; k <= last; ++k)
{
result += ws.rlist[k];
}
abserr = errsum;
L130:
L139:
if ((ier > 2) || goto140)
{
/*L140:*/
neval = last * 42 - 21;
}
results.AbsErr = abserr;
results.IEr = ier;
results.Last = last;
results.NEval = neval;
results.Value = result;
return;
// ---------------------------*/
}
S4 = 0.0008417508417508417508417508; /* 1/1188 */
#endregion
/* R file: lgamma.c
*/
private static double lgammafn_sign(double x, ref int?sgn)
{
double ans, y, sinpiy;
const double
xmax = 2.5327372760800758e+305,
dxrel = 1.490116119384765625e-8;
if (sgn != null)
{
sgn = 1;
}
if (double.IsNaN(x))
{
return(x);
}
if ((sgn != null) && (x < 0) && ((Math.Floor(-x) % 2.0) == 0)) // fmod était utilisé
{
sgn = -1;
}
if (x <= 0 && x == Math.Truncate(x))
{ /* Negative integer argument */
// ML_ERROR(ME_RANGE, "lgamma");
return(double.PositiveInfinity); /* +Inf, since lgamma(x) = log|gamma(x)| */
}
y = Math.Abs(x);
if (y < 1e-306)
{
return(-Math.Log(y)); // denormalized range, R change
}
if (y <= 10)
{
return(Math.Log(Math.Abs(Gamma(x))));
}
/*
* ELSE y = |x| > 10 ---------------------- */
if (y > xmax)
{
// ML_ERROR(ME_RANGE, "lgamma");
return(double.PositiveInfinity);
}
if (x > 0)
{ /* i.e. y = x > 10 */
if (x > 1e17)
{
return(x * (Math.Log(x) - 1.0));
}
else if (x > 4934720.0)
{
return(RVaria.M_LN_SQRT_2PI + (x - 0.5) * Math.Log(x) - x);
}
else
{
return(RVaria.M_LN_SQRT_2PI + (x - 0.5) * Math.Log(x) - x + lgammacor(x));
}
}
/* else: x < -10; y = -x */
sinpiy = Math.Abs(RVaria.sinpi(y));
if (sinpiy == 0)
{ /* Negative integer argument ===
* Now UNNECESSARY: caught above */
// MATHLIB_WARNING(" ** should NEVER happen! *** [lgamma.c: Neg.int, y=%g]\n",y);
return(RVaria.R_NaN);
// ML_ERR_return_NAN;
}
ans = RVaria.M_LN_SQRT_PId2 + (x - 0.5) * Math.Log(y) - x - Math.Log(sinpiy) - lgammacor(y);
if (Math.Abs((x - Math.Truncate(x - 0.5)) * ans / x) < dxrel)
{
/* The answer is less than half precision because
* the argument is too near a negative integer. */
// ML_ERROR(ME_PRECISION, "lgamma");
}
return(ans);
}
/* R file: integrate.c
*/
private static void rdqk21(Func <double[], double[]> f, double a, double b, out double result, out double abserr, out double resabs, out double resasc, ref int rdqk21_count)
{
//static void rdqk21(integr_fn f, void *ex, double *a, double *b, double *result,
// double *abserr, double *resabs, double *resasc)
double[]
fv1 = new double[10],
fv2 = new double[10],
vec = new double[21];
double absc, resg, resk, fsum, fval1, fval2;
double hlgth, centr, reskh, uflow;
double fc, epmach, dhlgth;
int j, jtw, jtwm1;
rdqk21_count++;
epmach = RVaria.DBL_EPSILON;
uflow = RVaria.DBL_MIN;
centr = (a + b) * 0.5;
hlgth = (b - a) * 0.5;
dhlgth = Math.Abs(hlgth);
/* compute the 21-point kronrod approximation to
* the integral, and estimate the absolute error. */
resg = 0.0;
vec[0] = centr;
for (j = 1; j <= 5; ++j)
{
jtw = j << 1;
absc = hlgth * xgk[jtw - 1];
vec[(j << 1) - 1] = centr - absc;
/*L5:*/
vec[j * 2] = centr + absc;
}
for (j = 1; j <= 5; ++j)
{
jtwm1 = (j << 1) - 1;
absc = hlgth * xgk[jtwm1 - 1];
vec[(j << 1) + 9] = centr - absc;
vec[(j << 1) + 10] = centr + absc;
}
double[] vec_y = f(vec);//, 21);
fc = vec_y[0];
resk = wgk[10] * fc;
resabs = Math.Abs(resk);
for (j = 1; j <= 5; ++j)
{
jtw = j << 1;
absc = hlgth * xgk[jtw - 1];
fval1 = vec_y[(j << 1) - 1];
fval2 = vec_y[j * 2];
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] * (Math.Abs(fval1) + Math.Abs(fval2));
//L10:
}
for (j = 1; j <= 5; ++j)
{
jtwm1 = (j << 1) - 1;
absc = hlgth * xgk[jtwm1 - 1];
fval1 = vec_y[(j << 1) + 9];
fval2 = vec_y[(j << 1) + 10];
fv1[jtwm1 - 1] = fval1;
fv2[jtwm1 - 1] = fval2;
fsum = fval1 + fval2;
resk += wgk[jtwm1 - 1] * fsum;
resabs += wgk[jtwm1 - 1] * (Math.Abs(fval1) + Math.Abs(fval2));
// L15:
}
reskh = resk * .5;
resasc = wgk[10] * Math.Abs(fc - reskh);
for (j = 1; j <= 10; ++j)
{
resasc += wgk[j - 1] * (Math.Abs(fv1[j - 1] - reskh) +
Math.Abs(fv2[j - 1] - reskh));
/* L20: */
}
//vec[0] = 0;
result = resk * hlgth;
resabs *= dhlgth;
resasc *= dhlgth;
abserr = Math.Abs((resk - resg) * hlgth);
if ((resasc != 0.0) && (abserr != 0.0))
{
abserr = resasc * RVaria.fmin2(1.0, Math.Pow(abserr * 200.0 / resasc, 1.5));
}
if (resabs > uflow / (epmach * 50.0))
{
abserr = RVaria.fmax2(epmach * 50.0 * resabs, abserr);
}
return;
// throw new System.NotImplementedException();
}
/* R file: integrate.c
*/
private static void rdqelg(ref int n, double[] epstab, out double result, out double abserr, double[] res3la, ref int nres)
{
/* Local variables */
int i__, indx, ib, ib2, ie, k1, k2, k3, num, newelm, limexp;
double delta1, delta2, delta3, e0, e1, e1abs, e2, e3, epmach, epsinf;
double oflow, ss, res;
double errA, err1, err2, err3, tol1, tol2, tol3;
#region prologue
/* ***begin prologue dqelg
***refer to dqagie,dqagoe,dqagpe,dqagse
***revision date 830518 (yymmdd)
***keywords epsilon algorithm, convergence acceleration,
* extrapolation
***author piessens,robert,appl. math. & progr. div. - k.u.leuven
* de doncker,elise,appl. math & progr. div. - k.u.leuven
***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.
***description
*
* epsilon algorithm
* standard fortran subroutine
* double precision version
*
* parameters
* n - int
* epstab(n) contains the new element in the
* first column of the epsilon table.
*
* epstab - double precision
* 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 - double precision
* resulting approximation to the integral
*
* abserr - double precision
* estimate of the absolute error computed from
* result and the 3 previous results
*
* res3la - double precision
* vector of dimension 3 containing the last 3
* results
*
* nres - int
* number of calls to the routine
* (should be zero at first call)
*
***end prologue dqelg
*
*
* list of major variables
* -----------------------
*
* e0 - the 4 elements on which the computation of a new
* e1 element in the epsilon table is based
* e2
* e3 e0
* e3 e1 new
* e2
*
* newelm - number of elements to be computed in the new diagonal
* errA - errA = abs(e1-e0)+abs(e2-e1)+abs(new-e2)
* result - the element in the new diagonal with least value of errA
*
* 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. */
#endregion
// -res3la;
//--epstab;
/* Function Body */
epmach = RVaria.DBL_EPSILON;
oflow = RVaria.DBL_MAX;
++nres;
abserr = oflow;
result = epstab[n - 1]; // modifié
if (n < 3)
{
goto L100;
}
limexp = 50;
epstab[n + 2 - 1] = epstab[n - 1]; // modifiés
newelm = (n - 1) / 2;
epstab[n - 1] = oflow; // modifié
num = n;
k1 = n;
for (i__ = 1; i__ <= newelm; ++i__)
{
k2 = k1 - 1;
k3 = k1 - 2;
res = epstab[k1 + 2 - 1]; // modifié
e0 = epstab[k3 - 1]; // modifié
e1 = epstab[k2 - 1]; // modifié
e2 = res;
e1abs = Math.Abs(e1);
delta2 = e2 - e1;
err2 = Math.Abs(delta2);
tol2 = RVaria.fmax2(Math.Abs(e2), e1abs) * epmach;
delta3 = e1 - e0;
err3 = Math.Abs(delta3);
tol3 = RVaria.fmax2(e1abs, Math.Abs(e0)) * epmach;
if (err2 <= tol2 && err3 <= tol3)
{
/* if e0, e1 and e2 are equal to within machine
* accuracy, convergence is assumed. */
result = res; /* result = e2 */
abserr = err2 + err3; /* abserr = fabs(e1-e0)+fabs(e2-e1) */
goto L100; /* ***jump out of do-loop */
}
e3 = epstab[k1 - 1]; // modifié
epstab[k1 - 1] = e1; // modifié
delta1 = e1 - e3;
err1 = Math.Abs(delta1);
tol1 = RVaria.fmax2(e1abs, Math.Abs(e3)) * 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)
{
ss = 1.0 / delta1 + 1.0 / delta2 - 1.0 / delta3;
epsinf = Math.Abs(ss * e1);
/*
* test to detect irregular behaviour in the table, and
* eventually omit a part of the table adjusting the value of n.
*/
if (epsinf > 1e-4)
{
goto L30;
}
}
n = i__ + i__ - 1;
goto L50;
/* ***jump out of do-loop */
L30: /* compute a new element and eventually adjust the value of result. */
res = e1 + 1.0 / ss;
epstab[k1 - 1] = res; // modifié
k1 += -2;
errA = err2 + Math.Abs(res - e2) + err3;
if (errA <= abserr)
{
abserr = errA;
result = res;
}
}
/* shift the table. */
L50:
if (n == limexp)
{
n = (limexp / 2 << 1) - 1;
}
if (num / 2 << 1 == num)
{
ib = 2;
}
else
{
ib = 1;
}
ie = newelm + 1;
for (i__ = 1; i__ <= ie; ++i__)
{
ib2 = ib + 2;
epstab[ib - 1] = epstab[ib2 - 1];// modifiés
ib = ib2;
}
if (num != n)
{
indx = num - n + 1;
for (i__ = 1; i__ <= n; ++i__)
{
epstab[i__ - 1] = epstab[indx - 1]; // modifiés
++indx;
}
}
/*L80:*/
if (nres >= 4)
{
/* L90: */
abserr = Math.Abs(result - res3la[3 - 1]) +
Math.Abs(result - res3la[2 - 1]) +
Math.Abs(result - res3la[1 - 1]); //modifiés 3x
res3la[1 - 1] = res3la[2 - 1];
res3la[2 - 1] = res3la[3 - 1];
res3la[3 - 1] = result;//modifiés 3x
}
else
{
res3la[nres - 1] = result;
abserr = oflow;
}
L100: /* compute error estimate */
abserr = RVaria.fmax2(abserr, epmach * 5.0 * Math.Abs(result));
return;
}
private static void pnorm_both(double x, ref double cum, ref double ccum, bool i_tail, bool log_p)
{
/* i_tail in {0,1,2} means: "lower", "upper", or "both" :
* if(lower) return *cum := P[X <= x]
* if(upper) return *ccum := P[X > x] = 1 - P[X <= x]
*/
double xden, xnum, temp, del, eps, xsq, y;
double min = RVaria.DBL_MIN;
int i;
bool lower, upper;
if (double.IsNaN(x))
{
cum = ccum = x; return;
}
/* Consider changing these : */
eps = RVaria.DBL_EPSILON * 0.5;
/* i_tail in {0,1,2} =^= {lower, upper, both} */
lower = !i_tail; // = i_tail != 1;
upper = i_tail; // = i_tail != 0
y = Math.Abs(x);
if (y <= 0.67448975)
{ /* qnorm(3/4) = .6744.... -- earlier had 0.66291 */
if (y > eps)
{
xsq = x * x;
xnum = a[4] * xsq;
xden = xsq;
for (i = 0; i < 3; ++i)
{
xnum = (xnum + a[i]) * xsq;
xden = (xden + b[i]) * xsq;
}
}
else
{
xnum = xden = 0.0;
}
temp = x * (xnum + a[3]) / (xden + b[3]);
if (lower)
{
cum = 0.5 + temp;
}
if (upper)
{
ccum = 0.5 - temp;
}
if (log_p)
{
if (lower)
{
cum = Math.Log(cum);
}
if (upper)
{
ccum = Math.Log(ccum);
}
}
}
else if (y <= RVaria.M_SQRT_32)
{
/* Evaluate pnorm for 0.674.. = qnorm(3/4) < |x| <= sqrt(32) ~= 5.657 */
xnum = c[8] * y;
xden = y;
for (i = 0; i < 7; ++i)
{
xnum = (xnum + c[i]) * y;
xden = (xden + d[i]) * y;
}
temp = (xnum + c[7]) / (xden + d[7]);
xsq = Math.Truncate(y * SIXTEN) / SIXTEN;
del = (y - xsq) * (y + xsq);
if (log_p)
{
cum = (-xsq * xsq * 0.5) + (-del * 0.5) + Math.Log(temp);
if ((lower && x > 0.0) || (upper && x <= 0.0))
{
ccum = RVaria.log1p(-Math.Exp(-xsq * xsq * 0.5) *
Math.Exp(-del * 0.5) * temp);
}
}
else
{
cum = Math.Exp(-xsq * xsq * 0.5) * Math.Exp(-del * 0.5) * temp;
ccum = 1.0 - cum;
}
if (x > 0.0)
{/* swap ccum <--> cum */
temp = cum;
if (lower)
{
cum = ccum;
}
ccum = temp;
}
}
else if ((log_p && y < 1e170) /* avoid underflow below */
/* ^^^^^ MM FIXME: can speedup for log_p and much larger |x| !
* Then, make use of Abramowitz & Stegun, 26.2.13, something like
*
* xsq = x*x;
*
* if(xsq * DBL_EPSILON < 1.)
* del = (1. - (1. - 5./(xsq+6.)) / (xsq+4.)) / (xsq+2.);
* else
* del = 0.;
* cum = -.5*xsq - M_LN_SQRT_2PI - log(x) + log1p(-del);
* ccum = log1p(-exp(*cum)); /.* ~ log(1) = 0 *./
*
* swap_tail;
*
* [Yes, but xsq might be infinite.]
*
*/
|| (lower && -37.5193 < x && x < 8.2924) ||
(upper && -8.2924 < x && x < 37.5193)
)
{
/* Evaluate pnorm for x in (-37.5, -5.657) union (5.657, 37.5) */
xsq = 1.0 / (x * x); /* (1./x)*(1./x) might be better */
xnum = p[5] * xsq;
xden = xsq;
for (i = 0; i < 4; ++i)
{
xnum = (xnum + p[i]) * xsq;
xden = (xden + q[i]) * xsq;
}
temp = xsq * (xnum + p[4]) / (xden + q[4]);
temp = (RVaria.M_1_SQRT_2PI - temp) / y;
// do_del(x);
xsq = Math.Truncate(x * SIXTEN) / SIXTEN;
del = (x - xsq) * (x + xsq);
if (log_p)
{
cum = (-xsq * xsq * 0.5) + (-del * 0.5) + Math.Log(temp);
if ((lower && x > 0.0) || (upper && x <= 0.0))
{
ccum = RVaria.log1p(-Math.Exp(-xsq * xsq * 0.5) *
Math.Exp(-del * 0.5) * temp);
}
}
else
{
cum = Math.Exp(-xsq * xsq * 0.5) * Math.Exp(-del * 0.5) * temp;
ccum = 1.0 - cum;
}
if (x > 0.0)
{/* swap ccum <--> cum */
temp = cum;
if (lower)
{
cum = ccum;
}
ccum = temp;
}
}
else
{ /* large x such that probs are 0 or 1 */
if (x > 0)
{
cum = (log_p ? 0.0 : 1.0); ccum = (log_p ? double.NegativeInfinity : 0.0);
}
else
{
cum = (log_p ? double.NegativeInfinity : 0.0); ccum = (log_p ? 0.0 : 1.0);
}
}
//#ifdef NO_DENORMS
/* do not return "denormalized" -- we do in R */
if (log_p)
{
if (cum > -min)
{
cum = -0.0;
}
if (ccum > -min)
{
ccum = -0.0;
}
}
else
{
if (cum < min)
{
cum = 0.0;
}
if (ccum < min)
{
ccum = 0.0;
}
}
//#endif
return;
}
private void R_cpolyroot(double[] opr, double[] opi, int degree, double[] zeror, double[] zeroi, out bool fail)
{
const double smalno = RVaria.DBL_MIN;
const double base_ = (double)RVaria.FLT_RADIX;
// R_cpolyroot variables ...
int d_n, i, i1, i2;
double zr = 0, zi = 0, xx, yy;
double bnd, xxx;
bool conv;
int d1;
const double cosr = /* cos 94 */ -0.06975647374412529990;
const double sinr = /* sin 94 */ 0.99756405025982424767;
xx = RVaria.M_SQRT1_2;/* 1/Math.Sqrt(2) = 0.707.... */
yy = -xx;
fail = false;
nn = degree;
d1 = nn - 1;
/* algorithm fails if the leading coefficient is zero. */
if ((opr[0] == 0) && (opi[0] == 0))
{
fail = true;
return;
}
/* remove the zeros at the origin if any. */
while ((opr[nn] == 0.0) && (opi[nn] == 0.0))
{
d_n = d1 - nn + 1;
zeror[d_n] = 0.0;
zeroi[d_n] = 0.0;
nn--;
}
nn++;
/*-- Now, global var. nn := #{coefficients} = (relevant degree)+1 */
if (nn == 1)
{
return;
}
/* Use a single allocation as these as small */
//const void* vmax = vmaxget();
//tmp = new double[nn];
pr = new double[nn];
pi = new double[nn];
hr = new double[nn];
hi = new double[nn];
qpr = new double[nn];
qpi = new double[nn];
qhr = new double[nn];
qhi = new double[nn];
shr = new double[nn];
shi = new double[nn];
/* make a copy of the coefficients and shr[] = | p[] | */
for (i = 0; i < nn; i++)
{
pr[i] = opr[i];
pi[i] = opi[i];
shr[i] = RVaria.hypot(pr[i], pi[i]);
}
/* scale the polynomial with factor 'bnd'. */
bnd = cpoly_scale(nn, shr, eta, infin, smalno, base_);
if (bnd != 1.0)
{
for (i = 0; i < nn; i++)
{
pr[i] *= bnd;
pi[i] *= bnd;
}
}
/* start the algorithm for one zero */
while (nn > 2)
{
/* calculate bnd, a lower bound on the modulus of the zeros. */
for (i = 0; i < nn; i++)
{
shr[i] = RVaria.hypot(pr[i], pi[i]);
}
bnd = cpoly_cauchy(nn, shr, shi);
/* outer loop to control 2 major passes */
/* with different sequences of shifts */
for (i1 = 1; i1 <= 2; i1++)
{
/* first stage calculation, no shift */
noshft(5);
/* inner loop to select a shift */
for (i2 = 1; i2 <= 9; i2++)
{
/* shift is chosen with modulus bnd */
/* and amplitude rotated by 94 degrees */
/* from the previous shift */
xxx = cosr * xx - sinr * yy;
yy = sinr * xx + cosr * yy;
xx = xxx;
this.sr = bnd * xx;
this.si = bnd * yy;
/* second stage calculation, fixed shift */
conv = fxshft(i2 * 10, ref zr, ref zi);
if (conv)
{
goto L10;
}
}
}
/* the zerofinder has failed on two major passes */
/* return empty handed */
fail = true;
return;
/* the second stage jumps directly to the third stage iteration.
* if successful, the zero is stored and the polynomial deflated.
*/
L10:
d_n = d1 + 2 - nn;
zeror[d_n] = zr;
zeroi[d_n] = zi;
--nn;
for (i = 0; i < nn; i++)
{
pr[i] = qpr[i];
pi[i] = qpi[i];
}
}/*while*/
/* calculate the final zero and return */
cdivid(-pr[1], -pi[1], pr[0], pi[0], out zeror[d1], out zeroi[d1]);
return;
}
public static double QNorm(double p, double mu = 0.0, double sigma = 1.0, bool lower_tail = true, bool log_p = false)
{
double p_, q, r, val;
if (double.IsNaN(p) || double.IsNaN(mu) || double.IsNaN(sigma))
{
return(double.NaN);
}
//R_Q_P01_boundaries(p, ML_NEGINF, ML_POSINF);
if (log_p)
{
if (p > 0)
{
return(double.NaN); //ML_ERR_return_NAN
}
if (p == 0) /* upper bound*/
{
return(lower_tail ? double.PositiveInfinity : double.NegativeInfinity);
}
if (p == double.NegativeInfinity)
{
return(lower_tail ? double.NegativeInfinity : double.PositiveInfinity);
}
}
else
{ /* !log_p */
if (p < 0 || p > 1)
{
return(double.NaN); //ML_ERR_return_NAN
}
if (p == 0)
{
return(lower_tail ? double.NegativeInfinity : double.PositiveInfinity);
}
if (p == 1)
{
return(lower_tail ? double.PositiveInfinity : double.NegativeInfinity);
}
}
if (sigma < 0)
{
return(double.NaN); //ML_ERR_return_NAN;
}
if (sigma == 0)
{
return(mu);
}
p_ = RVaria.R_DT_qIv(p, lower_tail, log_p);/* real lower_tail prob. p */
q = p_ - 0.5;
/*-- use AS 241 --- */
/* double ppnd16_(double *p, long *ifault)*/
/* ALGORITHM AS241 APPL. STATIST. (1988) VOL. 37, NO. 3
*
* Produces the normal deviate Z corresponding to a given lower
* tail area of P; Z is accurate to about 1 part in 10**16.
*
* (original fortran code used PARAMETER(..) for the coefficients
* and provided hash codes for checking them...)
*/
if (Math.Abs(q) <= .425)
{/* 0.075 <= p <= 0.925 */
r = .180625 - q * q;
val =
q * (((((((r * 2509.0809287301226727 +
33430.575583588128105) * r + 67265.770927008700853) * r +
45921.953931549871457) * r + 13731.693765509461125) * r +
1971.5909503065514427) * r + 133.14166789178437745) * r +
3.387132872796366608)
/ (((((((r * 5226.495278852854561 +
28729.085735721942674) * r + 39307.89580009271061) * r +
21213.794301586595867) * r + 5394.1960214247511077) * r +
687.1870074920579083) * r + 42.313330701600911252) * r + 1.0);
}
else
{ /* closer than 0.075 from {0,1} boundary */
/* r = min(p, 1-p) < 0.075 */
if (q > 0)
{
r = RVaria.R_DT_CIv(p, lower_tail, log_p);/* 1-p */
}
else
{
r = p_;/* = R_DT_Iv(p) ^= p */
}
r = Math.Sqrt(-((log_p &&
((lower_tail && q <= 0) || (!lower_tail && q > 0))) ?
p : /* else */ Math.Log(r)));
/* r = sqrt(-log(r)) <==> min(p, 1-p) = exp( - r^2 ) */
if (r <= 5.0)
{ /* <==> min(p,1-p) >= exp(-25) ~= 1.3888e-11 */
r += -1.6;
val = (((((((r * 7.7454501427834140764e-4 +
.0227238449892691845833) * r + .24178072517745061177) *
r + 1.27045825245236838258) * r +
3.64784832476320460504) * r + 5.7694972214606914055) *
r + 4.6303378461565452959) * r +
1.42343711074968357734)
/ (((((((r *
1.05075007164441684324e-9 + 5.475938084995344946e-4) *
r + .0151986665636164571966) * r +
.14810397642748007459) * r + .68976733498510000455) *
r + 1.6763848301838038494) * r +
2.05319162663775882187) * r + 1.0);
}
else
{ /* very close to 0 or 1 */
r += -5.0;
val = (((((((r * 2.01033439929228813265e-7 +
2.71155556874348757815e-5) * r +
.0012426609473880784386) * r + .026532189526576123093) *
r + .29656057182850489123) * r +
1.7848265399172913358) * r + 5.4637849111641143699) *
r + 6.6579046435011037772)
/ (((((((r *
2.04426310338993978564e-15 + 1.4215117583164458887e-7) *
r + 1.8463183175100546818e-5) * r +
7.868691311456132591e-4) * r + .0148753612908506148525)
* r + .13692988092273580531) * r +
.59983220655588793769) * r + 1.0);
}
if (q < 0.0)
{
val = -val;
}
/* return (q >= 0.)? r : -r ;*/
}
return(mu + sigma * val);
}
/*
* Computes l2 fixed-shift h polynomials and tests for convergence.
* initiates a variable-shift iteration and returns with the
* approximate zero if successful.
*
*/
bool fxshft(int l2, ref double zr, ref double zi)
{
/*
* l2 - limit of fixed shift steps
* zr,zi - approximate zero if convergence (result TRUE)
*
* Return value indicates convergence of stage 3 iteration
*
* Uses global (sr,si), nn, pr[], pi[], .. (all args of polyev() !)
*
*/
bool pasd, bool_, test;
double svsi, svsr;
int i, j, n;
double oti, otr;
n = nn - 1;
/* evaluate p at s. */
polyev(nn, sr, si, pr, pi, qpr, qpi, out pvr, out pvi);
test = true;
pasd = false;
/* calculate first t = -p(s)/h(s). */
calct(out bool_);
/* main loop for one second stage step. */
for (j = 1; j <= l2; j++)
{
otr = tr;
oti = ti;
/* compute next h polynomial and new t. */
nexth(bool_);
calct(out bool_);
zr = sr + tr;
zi = si + ti;
/* test for convergence unless stage 3 has */
/* failed once or this is the last h polynomial. */
if (!bool_ && test && (j != l2))
{
if (RVaria.hypot(tr - otr, ti - oti) >= RVaria.hypot(zr, zi) * 0.5)
{
pasd = false;
}
else if (!pasd)
{
pasd = true;
}
else
{
/* the weak convergence test has been */
/* passed twice, start the third stage */
/* iteration, after saving the current */
/* h polynomial and shift. */
for (i = 0; i < n; i++)
{
shr[i] = hr[i];
shi[i] = hi[i];
}
svsr = sr;
svsi = si;
if (vrshft(10, ref zr, ref zi))
{
return(true);
}
/* the iteration failed to converge. */
/* turn off testing and restore */
/* h, s, pv and t. */
test = false;
for (i = 1; i <= n; i++)
{
hr[i - 1] = shr[i - 1];
hi[i - 1] = shi[i - 1];
}
sr = svsr;
si = svsi;
polyev(nn, sr, si, pr, pi, qpr, qpi, out pvr, out pvi);
calct(out bool_);
}
}
}
/* attempt an iteration with final h polynomial */
/* from second stage. */
return(vrshft(10, ref zr, ref zi));
}
/*
* carries out the third stage iteration.
*
*/
bool vrshft(int l3, ref double zr, ref double zi)
{
/* l3 - limit of steps in stage 3.
* zr,zi - on entry contains the initial iterate;
* if the iteration converges it contains
* the final iterate on exit.
* Returns TRUE if iteration converges
*
* Assign and uses GLOBAL sr, si
*/
bool bool_, b;
int i, j;
double r1, r2, mp, ms, tp, relstp = 0.0;
double omp = 0.0;
b = false;
sr = zr;
si = zi;
/* main loop for stage three */
for (i = 1; i <= l3; i++)
{
/* evaluate p at s and test for convergence. */
polyev(nn, sr, si, pr, pi, qpr, qpi, out pvr, out pvi);
mp = RVaria.hypot(pvr, pvi);
ms = RVaria.hypot(sr, si);
if (mp <= 20.0 * errev(nn, qpr, qpi, ms, mp, /*are=*/ eta, mre))
{
goto L_conv;
}
/*
* polynomial value is smaller in value than
* a bound on the error in evaluating p,
* terminate the iteration.
*
*/
if (i != 1)
{
if (!b && (mp >= omp) && (relstp < .05))
{
/*
* iteration has stalled. probably a
* cluster of zeros. do 5 fixed shift
* steps into the cluster to force
* one zero to dominate.
*
*/
tp = relstp;
b = true;
if (relstp < eta)
{
tp = eta;
}
r1 = Math.Sqrt(tp);
r2 = sr * (r1 + 1.0) - si * r1;
si = sr * r1 + si * (r1 + 1.0);
sr = r2;
polyev(nn, sr, si, pr, pi, qpr, qpi, out pvr, out pvi);
for (j = 1; j <= 5; ++j)
{
calct(out bool_);
nexth(bool_);
}
omp = infin;
goto L10;
}
else
{
/* exit if polynomial value */
/* increases significantly. */
if (mp * .1 > omp)
{
return(false);
}
}
}
omp = mp;
/* calculate next iterate. */
L10:
calct(out bool_);
nexth(bool_);
calct(out bool_);
if (!bool_)
{
relstp = RVaria.hypot(tr, ti) / RVaria.hypot(sr, si);
sr += tr;
si += ti;
}
}
return(false);
L_conv:
zr = sr;
zi = si;
return(true);
}
