void simpleabs_df (const gsl_vector * x, void *params, gsl_vector * df)
{
double u = gsl_vector_get(x,0);
double v = gsl_vector_get(x,1);
gcount++;
gsl_vector_set(df,0, GSL_SIGN(u-1));
gsl_vector_set(df,1, GSL_SIGN(v-2));
}
void simpleabs_fdf (const gsl_vector * x, void *params, double * f,
gsl_vector * df)
{
double u = gsl_vector_get(x,0);
double v = gsl_vector_get(x,1);
double a = u - 1;
double b = v - 2;
gcount++;
*f = fabs(a) + fabs(b);
gsl_vector_set(df,0, GSL_SIGN(u-1));
gsl_vector_set(df,1, GSL_SIGN(v-2));
}
int UnidimensionalRootFinder(gsl_function *F,
double lower_bound,
double upper_bound,
double abs_error,
double rel_error,
int max_iterations,
double *return_result)
{
const gsl_root_fsolver_type * T = gsl_root_fsolver_bisection;
gsl_root_fsolver * s = gsl_root_fsolver_alloc(T);
// Test if the limits straddle the root,
// if they don't, we will return -1.
if (GSL_SIGN(GSL_FN_EVAL(F, lower_bound)) == GSL_SIGN(GSL_FN_EVAL(F, upper_bound)))
return -1;
gsl_root_fsolver_set(s, F, lower_bound, upper_bound);
int i = 0;
double x_lower;
double x_upper;
do{
i++;
int status = gsl_root_fsolver_iterate(s);
if (status != GSL_SUCCESS){
printf("ERROR: No solution to the gap equation was found!\n");
exit(EXIT_FAILURE);
}
x_lower = gsl_root_fsolver_x_lower(s);
x_upper = gsl_root_fsolver_x_upper(s);
} while(GSL_CONTINUE == gsl_root_test_interval(x_lower,
x_upper,
abs_error,
rel_error)
&& i <= max_iterations);
double result = gsl_root_fsolver_root(s);
void gsl_root_fsolver_free(gsl_root_fsolver * S);
*return_result = result;
return 0;
}
int gsl_sf_angle_restrict_symm_err_e(const double theta, gsl_sf_result * result)
{
/* synthetic extended precision constants */
const double P1 = 4 * 7.8539812564849853515625e-01;
const double P2 = 4 * 3.7748947079307981766760e-08;
const double P3 = 4 * 2.6951514290790594840552e-15;
const double TwoPi = 2*(P1 + P2 + P3);
const double y = GSL_SIGN(theta) * 2 * floor(fabs(theta)/TwoPi);
double r = ((theta - y*P1) - y*P2) - y*P3;
if(r > M_PI) { r = (((r-2*P1)-2*P2)-2*P3); } /* r-TwoPi */
else if (r < -M_PI) r = (((r+2*P1)+2*P2)+2*P3); /* r+TwoPi */
result->val = r;
if(fabs(theta) > 0.0625/GSL_DBL_EPSILON) {
result->val = GSL_NAN;
result->err = GSL_NAN;
GSL_ERROR ("error", GSL_ELOSS);
}
else if(fabs(theta) > 0.0625/GSL_SQRT_DBL_EPSILON) {
result->err = 2.0 * GSL_DBL_EPSILON * fabs(result->val - theta);
return GSL_SUCCESS;
}
else {
double delta = fabs(result->val - theta);
result->err = 2.0 * GSL_DBL_EPSILON * ((delta < M_PI) ? delta : M_PI);
return GSL_SUCCESS;
}
}
void BasicVelocityClamping::clamp( PsoParticle& particle ) {
for (int i = 0; i < particle.getSize(); ++i) {
if (Math::abs(particle.getVelocity(i) > particle.getMaxVelocity(i))) {
particle.setVelocity(i,
GSL_SIGN(particle.getVelocity(i)) * particle.getMaxVelocity(i));
}
}
}
double CKDE::MeanShift_Forward(bool bFindMax, double x, double& h, double alpha, double eplison, int maxIter, bool bNeighbor)
// use Epanechnikov Kernel
{
int iter ;
double diffX, oldX;
double lowerBound;
int oldSgn, sgn, oscillation;
iter = 0;
oscillation = oldSgn = sgn = 0;
do{
oldSgn = sgn ;
oldX = x;
lowerBound = -(1-1.*exp(-1.*iter/alpha));
x = WeightedMean(x, h, lowerBound, bFindMax);
diffX = x - oldX;
sgn = GSL_SIGN(diffX);
oscillation += abs(sgn - oldSgn)/2;
// TRACE("[%2d] diff X %.3f, new X = %.3f, h=%.3f, low=%.3f, FindMax %d\n", iter, diffX, x, h, lowerBound, bFindMax);
if(fabs(diffX) < eplison || oscillation >20) {
oscillation = 0;
// break;
h *= 0.85;
if(h < 2) break;
}
iter++;
}while(iter <maxIter);
// gpMsgbar->ShowMessage("max_min %d, find (%.3f, %.3f) ==>", bFindMax, x, m_pdf[(int)(x+0.5)]);
// neighborhood search
if(bNeighbor) {
int i, start, end;
start = (int)(x-h - 1);
if(start < 0) start = 0;
end = (int)(x+h+1);
if(end >= m_nBin) end = m_nBin -1;
for(i=start; i<=end; i++) {
if(bFindMax)
if(m_pdf[i] > m_pdf[(int)(x+0.5)]) x = i;
if(! bFindMax)
if(m_pdf[i] < m_pdf[(int)(x+0.5)]) x = i;
}
}
// gpMsgbar->ShowMessage(" (%.3f, %.3f) \n", x, m_pdf[(int)(x+0.5)]);
// gpMainDlg->ShowMessage("best position %d\n", bestPos);
return x;
}
double NBinGlm::getfAfAdash(double k0, unsigned int id, unsigned int limit)
{
unsigned int i, it=0;
double sum=1, num=0, k;
double y, m, dl, ddl, tol;
double phi, dl_dphi, d2l_dphi2, del_phi;
if (k0==0) {
for (i=0; i<nRows; i++) {
y = gsl_matrix_get(Yref, i, id);
m = gsl_matrix_get(Mu, i, id);
if (m>0) {
sum = sum+(y/m-1)*(y/m-1);
num = num+1;
}
}
k = num/sum;
if (num==0) printf("num=0\n");
}
else k=k0;
k = MAX(k, mintol);
phi = 1/k;
while ( it<limit ) {
it++;
dl=nRows*(1+log(k)-gsl_sf_psi(k));
ddl=nRows*(gsl_sf_psi_1(k)-1/k);
for ( i=0; i<nRows; i++ ) {
y = gsl_matrix_get(Yref, i, id);
m = gsl_matrix_get(Mu, i, id);
dl = dl + gsl_sf_psi(y+k)-log(m+k)-(y+k)/(m+k);
ddl = ddl - gsl_sf_psi_1(y+k)+2/(m+k)-(y+k)/((m+k)*(m+k));
}
dl_dphi = - exp(2*log(k))*dl;
d2l_dphi2 = 2*exp(3*log(k))*dl + exp(4*log(k))*ddl;
if (ABS(ddl) < mintol) ddl = GSL_SIGN(ddl)*mintol;
del_phi = dl_dphi/ABS(d2l_dphi2);
tol = ABS(del_phi*dl_dphi);
if (tol<eps) break;
phi = phi + del_phi;
if (phi<0) {k=0; break;}
k = 1/MAX(ABS(phi),mintol);
if (k>maxth) break;
}
return k;
}
static double
inv_cornish_fisher (double z, double nu)
{
double a = 1 / (nu - 0.5);
double b = 48.0 / (a * a);
double cf1 = z * (3 + z * z);
double cf2 = z * (945 + z * z * (360 + z * z * (63 + z * z * 4)));
double y = z - cf1 / b + cf2 / (10 * b * b);
double t = GSL_SIGN (z) * sqrt (nu * expm1 (a * y * y));
return t;
}
/**
* ncm_mpsf_sbessel_recur_goto: (skip)
* @jlrec: a #NcmMpsfSBesselRecur
* @l: FIXME
* @rnd: FIXME
*
* FIXME
*
*/
void
ncm_mpsf_sbessel_recur_goto (NcmMpsfSBesselRecur *jlrec, glong l, mp_rnd_t rnd)
{
glong sign = GSL_SIGN (l - jlrec->l);
glong sub = labs(l - jlrec->l);
glong i;
if (sub == 0)
return;
if (sign == 1)
for (i = 0; i < sub; i++)
ncm_mpsf_sbessel_recur_next (jlrec, rnd);
else
for (i = 0; i < sub; i++)
ncm_mpsf_sbessel_recur_previous (jlrec, rnd);
}
int gsl_sf_exp_mult_err_e10_e(const double x, const double dx,
const double y, const double dy,
gsl_sf_result_e10 * result)
{
const double ay = fabs(y);
if(y == 0.0) {
result->val = 0.0;
result->err = fabs(dy * exp(x));
result->e10 = 0;
return GSL_SUCCESS;
}
else if( ( x < 0.5*GSL_LOG_DBL_MAX && x > 0.5*GSL_LOG_DBL_MIN)
&& (ay < 0.8*GSL_SQRT_DBL_MAX && ay > 1.2*GSL_SQRT_DBL_MIN)
) {
const double ex = exp(x);
result->val = y * ex;
result->err = ex * (fabs(dy) + fabs(y*dx));
result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);
result->e10 = 0;
return GSL_SUCCESS;
}
else {
const double ly = log(ay);
const double l10_val = (x + ly)/M_LN10;
if(l10_val > INT_MAX-1) {
OVERFLOW_ERROR_E10(result);
}
else if(l10_val < INT_MIN+1) {
UNDERFLOW_ERROR_E10(result);
}
else {
const double sy = GSL_SIGN(y);
const int N = (int) floor(l10_val);
const double arg_val = (l10_val - N) * M_LN10;
const double arg_err = dy/fabs(y) + dx + 2.0*GSL_DBL_EPSILON*fabs(arg_val);
result->val = sy * exp(arg_val);
result->err = arg_err * fabs(result->val);
result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);
result->e10 = N;
return GSL_SUCCESS;
}
}
}
int gsl_sf_exp_mult_err_e(const double x, const double dx,
const double y, const double dy,
gsl_sf_result * result)
{
const double ay = fabs(y);
if(y == 0.0) {
result->val = 0.0;
result->err = fabs(dy * exp(x));
return GSL_SUCCESS;
}
else if( ( x < 0.5*GSL_LOG_DBL_MAX && x > 0.5*GSL_LOG_DBL_MIN)
&& (ay < 0.8*GSL_SQRT_DBL_MAX && ay > 1.2*GSL_SQRT_DBL_MIN)
) {
double ex = exp(x);
result->val = y * ex;
result->err = ex * (fabs(dy) + fabs(y*dx));
result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);
return GSL_SUCCESS;
}
else {
const double ly = log(ay);
const double lnr = x + ly;
if(lnr > GSL_LOG_DBL_MAX - 0.01) {
OVERFLOW_ERROR(result);
}
else if(lnr < GSL_LOG_DBL_MIN + 0.01) {
UNDERFLOW_ERROR(result);
}
else {
const double sy = GSL_SIGN(y);
const double M = floor(x);
const double N = floor(ly);
const double a = x - M;
const double b = ly - N;
const double eMN = exp(M+N);
const double eab = exp(a+b);
result->val = sy * eMN * eab;
result->err = eMN * eab * 2.0*GSL_DBL_EPSILON;
result->err += eMN * eab * fabs(dy/y);
result->err += eMN * eab * fabs(dx);
return GSL_SUCCESS;
}
}
}
double NBinGlm::thetaML(double k0, unsigned int id, unsigned int limit)
{
// equivalent to theta.ml() in MASS
// Note that theta here is the dispersion parameter
// So phi = 1/theta;
unsigned int i, it=0;
double del=1, sum=1, num=0, k;
double y, m, dl, ddl, tol;
if (k0==0) {
for (i=0; i<nRows; i++) {
y = gsl_matrix_get(Yref, i, id);
m = gsl_matrix_get(Mu, i, id);
if (m>0) {
sum = sum+(y/m-1)*(y/m-1);
num = num+1;
}
}
k = num/sum;
}
else k=k0;
k = MAX(k, mintol);
while ( it<=limit ) {
it++;
k = ABS(k);
dl=nRows*(1+log(k)-gsl_sf_psi(k));
ddl=nRows*(gsl_sf_psi_1(k)-1/k);
for ( i=0; i<nRows; i++ ) {
y = gsl_matrix_get(Yref, i, id);
m = gsl_matrix_get(Mu, i, id);
dl = dl + gsl_sf_psi(y+k)-log(m+k)-(y+k)/(m+k);
ddl = ddl - gsl_sf_psi_1(y+k)+2/(m+k)-(y+k)/((m+k)*(m+k));
}
if (ABS(ddl) < mintol) ddl = GSL_SIGN(ddl)*mintol;
del = dl/ABS(ddl);
tol = ABS(del*dl);
if (tol<eps) break;
k = k+del; // Normal Newton use - instead of + for -ddl
if (k>maxth) break;
if (k<0) { k = 0; break; }
}
// if (k<0) k=0;
return k;
}
/**
* nc_cluster_abundance_prepare_inv_dNdlnM_z:
* @cad: a #NcClusterAbundance
* @cosmo: a #NcHICosmo
* @lnMi: logarithm base e of the minimum mass $\ln(M_i)$
* @z: redshift $z$
*
* This function prepares a spline where the x array corresponds to the value
* of $\int_{\ln M_0} ^{\ln M_1} d^2N/dzd\ln M dM/ \int_lnMi^lnMf dN/dz dM$ given a redshift $z$
* and the y array contains the values of logarithms base e of the mass.
* It is used to generate a sample of $\ln M$ values.
*
*/
void
nc_cluster_abundance_prepare_inv_dNdlnM_z (NcClusterAbundance *cad, NcHICosmo *cosmo, const gdouble lnMi, gdouble z)
{
gboolean use_spline = FALSE;
gdouble dNdz = nc_halo_mass_function_dn_dz (cad->mfp, cosmo, lnMi, cad->lnMf, z, use_spline);
gdouble lnM0 = lnMi;
gdouble ntot = 0.0;
gdouble f = _nc_cad_inv_dNdz_convergence_f (0.0, cad->lnM_epsilon);
const gdouble dlnM = (cad->lnMf - lnMi) / (cad->inv_lnM->len - 1.0);
guint i;
g_assert (z > 0.0);
ncm_vector_set (cad->inv_lnM->xv, 0, f);
ncm_vector_set (cad->inv_lnM->yv, 0, lnM0);
for (i = 1; i < cad->inv_lnM->len; i++)
{
const gdouble lnM1 = lnMi + dlnM * i;
if (ntot < 0.99)
{
const gdouble Delta = nc_halo_mass_function_dn_dz (cad->mfp, cosmo, lnM0, lnM1, z, use_spline) / dNdz;
ntot += fabs (Delta);
f = _nc_cad_inv_dNdz_convergence_f (ntot, cad->lnM_epsilon);
}
else
{
const gdouble onemn = nc_halo_mass_function_dn_dz (cad->mfp, cosmo, lnM1, cad->lnMf, z, use_spline) / dNdz;
const gdouble f_try = _nc_cad_inv_dNdz_convergence_f_onemn (fabs (onemn), cad->lnM_epsilon);
if (f_try < f)
f = f * (1.0 + GSL_SIGN (f) * 0.01);
else
f = f_try;
}
ncm_vector_set (cad->inv_lnM->xv, i, f);
ncm_vector_set (cad->inv_lnM->yv, i, lnM1);
lnM0 = lnM1;
}
ncm_spline_prepare (cad->inv_lnM);
}
int
gsl_sf_atanint_e(const double x, gsl_sf_result * result)
{
const double ax = fabs(x);
const double sgn = GSL_SIGN(x);
/* CHECK_POINTER(result) */
if(ax == 0.0) {
result->val = 0.0;
result->err = 0.0;
return GSL_SUCCESS;
}
else if(ax < 0.5*GSL_SQRT_DBL_EPSILON) {
result->val = x;
result->err = 0.0;
return GSL_SUCCESS;
}
else if(ax <= 1.0) {
const double t = 2.0 * (x*x - 0.5);
gsl_sf_result result_c;
cheb_eval_e(&atanint_cs, t, &result_c);
result->val = x * result_c.val;
result->err = x * result_c.err;
result->err += GSL_DBL_EPSILON * fabs(result->val);
return GSL_SUCCESS;
}
else if(ax < 1.0/GSL_SQRT_DBL_EPSILON) {
const double t = 2.0 * (1.0/(x*x) - 0.5);
gsl_sf_result result_c;
cheb_eval_e(&atanint_cs, t, &result_c);
result->val = sgn * (0.5*M_PI*log(ax) + result_c.val/ax);
result->err = result_c.err/ax + fabs(result->val*GSL_DBL_EPSILON);
result->err += GSL_DBL_EPSILON * fabs(result->val);
return GSL_SUCCESS;
}
else {
result->val = sgn * 0.5*M_PI*log(ax);
result->err = 2.0 * fabs(result->val * GSL_DBL_EPSILON);
return GSL_SUCCESS;
}
}
/* Uniform asymptotic for x near a, a and x large.
* See [Temme, p. 285]
*/
static
int
gamma_inc_Q_asymp_unif(const double a, const double x, gsl_sf_result * result)
{
const double rta = sqrt(a);
const double eps = (x-a)/a;
gsl_sf_result ln_term;
const int stat_ln = gsl_sf_log_1plusx_mx_e(eps, &ln_term); /* log(1+eps) - eps */
const double eta = GSL_SIGN(eps) * sqrt(-2.0*ln_term.val);
gsl_sf_result erfc;
double R;
double c0, c1;
/* This used to say erfc(eta*M_SQRT2*rta), which is wrong.
* The sqrt(2) is in the denominator. Oops.
* Fixed: [GJ] Mon Nov 15 13:25:32 MST 2004
*/
gsl_sf_erfc_e(eta*rta/M_SQRT2, &erfc);
if(fabs(eps) < GSL_ROOT5_DBL_EPSILON) {
c0 = -1.0/3.0 + eps*(1.0/12.0 - eps*(23.0/540.0 - eps*(353.0/12960.0 - eps*589.0/30240.0)));
c1 = -1.0/540.0 - eps/288.0;
}
else {
const double rt_term = sqrt(-2.0 * ln_term.val/(eps*eps));
const double lam = x/a;
c0 = (1.0 - 1.0/rt_term)/eps;
c1 = -(eta*eta*eta * (lam*lam + 10.0*lam + 1.0) - 12.0 * eps*eps*eps) / (12.0 * eta*eta*eta*eps*eps*eps);
}
R = exp(-0.5*a*eta*eta)/(M_SQRT2*M_SQRTPI*rta) * (c0 + c1/a);
result->val = 0.5 * erfc.val + R;
result->err = GSL_DBL_EPSILON * fabs(R * 0.5 * a*eta*eta) + 0.5 * erfc.err;
result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);
return stat_ln;
}
/**
* nc_cluster_abundance_prepare_inv_dNdz:
* @cad: a #NcClusterAbundance
* @cosmo: a #NcHICosmo
* @lnMi: logarithm base e of the minimum mass $\ln(M_i)$
*
* This function prepares a bidimensional spline...
*
*/
void
nc_cluster_abundance_prepare_inv_dNdz (NcClusterAbundance *cad, NcHICosmo *cosmo, const gdouble lnMi)
{
NcHaloMassFunctionSplineOptimize sp_optimize = NC_HALO_MASS_FUNCTION_SPLINE_Z;
const gdouble delta_z = (cad->zf - cad->zi) / (cad->inv_z->len - 1.0);
const gdouble delta_lnM = (cad->lnMf - lnMi) / (cad->inv_lnM->len - 1.0);
const gdouble norma = nc_halo_mass_function_n (cad->mfp, cosmo, lnMi, cad->lnMf, cad->zi, cad->zf, NC_HALO_MASS_FUNCTION_SPLINE_LNM);
gboolean use_spline = FALSE;
guint middle = cad->inv_z->len / 2;
gdouble z0 = cad->zi;
guint i, j;
g_assert (cad->zi != 0);
{
const gdouble zfm1 = cad->zf - delta_z;
const gdouble lnMfm1 = cad->lnMf - delta_lnM;
cad->z_epsilon = fabs (nc_halo_mass_function_n (cad->mfp, cosmo, lnMi, cad->lnMf, zfm1, cad->zf, sp_optimize) / norma);
cad->lnM_epsilon = fabs (nc_halo_mass_function_dn_dz (cad->mfp, cosmo, lnMfm1, cad->lnMf, cad->zf, use_spline) /
nc_halo_mass_function_dn_dz (cad->mfp, cosmo, lnMi, cad->lnMf, cad->zf, use_spline));
}
{
gdouble zm = cad->zi + delta_z * middle;
nc_cluster_abundance_prepare_inv_dNdlnM_z (cad, cosmo, lnMi, zm);
ncm_vector_set (cad->inv_lnM_z->xv, 0, _nc_cad_inv_dNdz_convergence_f (0.0, cad->lnM_epsilon));
ncm_matrix_set (cad->inv_lnM_z->zm, middle, 0, lnMi);
for (j = 1; j < ncm_vector_len (cad->inv_lnM_z->xv) - 1; j++)
{
gdouble u2 = ncm_vector_get (cad->inv_lnM->xv, j);
ncm_vector_set (cad->inv_lnM_z->xv, j, u2);
ncm_matrix_set (cad->inv_lnM_z->zm, middle, j, ncm_spline_eval (cad->inv_lnM, u2));
}
ncm_vector_set (cad->inv_lnM_z->xv, j, _nc_cad_inv_dNdz_convergence_f_onemn (0.0, cad->lnM_epsilon));
ncm_matrix_set (cad->inv_lnM_z->zm, middle, j, cad->lnMf);
}
nc_cluster_abundance_prepare_inv_dNdlnM_z (cad, cosmo, lnMi, z0);
ncm_matrix_set (cad->inv_lnM_z->zm, 0, 0, lnMi);
for (j = 1; j < ncm_vector_len(cad->inv_lnM_z->xv) - 1; j++)
{
gdouble u2 = ncm_vector_get (cad->inv_lnM_z->xv, j);
ncm_matrix_set (cad->inv_lnM_z->zm, 0, j, ncm_spline_eval (cad->inv_lnM, u2));
}
ncm_matrix_set (cad->inv_lnM_z->zm, 0, j, cad->lnMf);
{
gdouble nztot = 0.0;
gdouble f = _nc_cad_inv_dNdz_convergence_f (0.0, cad->z_epsilon);
ncm_vector_set (cad->inv_z->xv, 0, f);
ncm_vector_set (cad->inv_z->yv, 0, z0);
for (i = 1; i < cad->inv_z->len; i++)
{
gdouble z1 = cad->zi + delta_z * i;
if (nztot < 0.99)
{
gdouble delta = nc_halo_mass_function_n (cad->mfp, cosmo, lnMi, cad->lnMf, z0, z1, sp_optimize) / norma;
nztot += fabs (delta);
f = _nc_cad_inv_dNdz_convergence_f (nztot, cad->z_epsilon);
}
else
{
gdouble onemn = nc_halo_mass_function_n (cad->mfp, cosmo, lnMi, cad->lnMf, z1, cad->zf, sp_optimize) / norma;
gdouble f_try = _nc_cad_inv_dNdz_convergence_f_onemn (onemn, cad->z_epsilon);
if (f_try < f)
f = f * (1.0 + GSL_SIGN (f) * 0.01);
else
f = f_try;
}
ncm_vector_set (cad->inv_z->xv, i, f);
ncm_vector_set (cad->inv_z->yv, i, z1);
z0 = z1;
if (i == middle)
continue;
nc_cluster_abundance_prepare_inv_dNdlnM_z (cad, cosmo, lnMi, z1);
ncm_matrix_set (cad->inv_lnM_z->zm, i, 0, lnMi);
for (j = 1; j < ncm_vector_len(cad->inv_lnM_z->xv) - 1; j++)
{
gdouble u2 = ncm_vector_get (cad->inv_lnM_z->xv, j);
ncm_matrix_set (cad->inv_lnM_z->zm, i, j, ncm_spline_eval (cad->inv_lnM, u2));
}
ncm_matrix_set (cad->inv_lnM_z->zm, i, j, cad->lnMf);
}
}
ncm_spline2d_prepare (cad->inv_lnM_z);
ncm_spline_prepare (cad->inv_z);
}
int
gsl_sf_bessel_Jnu_e(const double nu, const double x, gsl_sf_result * result)
{
/* CHECK_POINTER(result) */
if(x < 0.0 || nu < 0.0) {
DOMAIN_ERROR(result);
}
else if(x == 0.0) {
if(nu == 0.0) {
result->val = 1.0;
result->err = 0.0;
}
else {
result->val = 0.0;
result->err = 0.0;
}
return GSL_SUCCESS;
}
else if(x*x < 10.0*(nu+1.0)) {
return gsl_sf_bessel_IJ_taylor_e(nu, x, -1, 100, GSL_DBL_EPSILON, result);
}
else if(nu > 50.0) {
return gsl_sf_bessel_Jnu_asymp_Olver_e(nu, x, result);
}
else {
/* -1/2 <= mu <= 1/2 */
int N = (int)(nu + 0.5);
double mu = nu - N;
/* Determine the J ratio at nu.
*/
double Jnup1_Jnu;
double sgn_Jnu;
const int stat_CF1 = gsl_sf_bessel_J_CF1(nu, x, &Jnup1_Jnu, &sgn_Jnu);
if(x < 2.0) {
/* Determine Y_mu, Y_mup1 directly and recurse forward to nu.
* Then use the CF1 information to solve for J_nu and J_nup1.
*/
gsl_sf_result Y_mu, Y_mup1;
const int stat_mu = gsl_sf_bessel_Y_temme(mu, x, &Y_mu, &Y_mup1);
double Ynm1 = Y_mu.val;
double Yn = Y_mup1.val;
double Ynp1 = 0.0;
int n;
for(n=1; n<N; n++) {
Ynp1 = 2.0*(mu+n)/x * Yn - Ynm1;
Ynm1 = Yn;
Yn = Ynp1;
}
result->val = 2.0/(M_PI*x) / (Jnup1_Jnu*Yn - Ynp1);
result->err = GSL_DBL_EPSILON * (N + 2.0) * fabs(result->val);
return GSL_ERROR_SELECT_2(stat_mu, stat_CF1);
}
else {
/* Recurse backward from nu to mu, determining the J ratio
* at mu. Use this together with a Steed method CF2 to
* determine the actual J_mu, and thus obtain the normalization.
*/
double Jmu;
double Jmup1_Jmu;
double sgn_Jmu;
double Jmuprime_Jmu;
double P, Q;
const int stat_CF2 = gsl_sf_bessel_JY_steed_CF2(mu, x, &P, &Q);
double gamma;
double Jnp1 = sgn_Jnu * GSL_SQRT_DBL_MIN * Jnup1_Jnu;
double Jn = sgn_Jnu * GSL_SQRT_DBL_MIN;
double Jnm1;
int n;
for(n=N; n>0; n--) {
Jnm1 = 2.0*(mu+n)/x * Jn - Jnp1;
Jnp1 = Jn;
Jn = Jnm1;
}
Jmup1_Jmu = Jnp1/Jn;
sgn_Jmu = GSL_SIGN(Jn);
Jmuprime_Jmu = mu/x - Jmup1_Jmu;
gamma = (P - Jmuprime_Jmu)/Q;
Jmu = sgn_Jmu * sqrt(2.0/(M_PI*x) / (Q + gamma*(P-Jmuprime_Jmu)));
result->val = Jmu * (sgn_Jnu * GSL_SQRT_DBL_MIN) / Jn;
result->err = 2.0 * GSL_DBL_EPSILON * (N + 2.0) * fabs(result->val);
return GSL_ERROR_SELECT_2(stat_CF2, stat_CF1);
}
}
}
int
gsl_eigen_genv_sort (gsl_vector_complex * alpha, gsl_vector * beta,
gsl_matrix_complex * evec, gsl_eigen_sort_t sort_type)
{
if (evec->size1 != evec->size2)
{
GSL_ERROR ("eigenvector matrix must be square", GSL_ENOTSQR);
}
else if (alpha->size != evec->size1 || beta->size != evec->size1)
{
GSL_ERROR ("eigenvalues must match eigenvector matrix", GSL_EBADLEN);
}
else
{
const size_t N = alpha->size;
size_t i;
for (i = 0; i < N - 1; i++)
{
size_t j;
size_t k = i;
gsl_complex ak = gsl_vector_complex_get (alpha, i);
double bk = gsl_vector_get(beta, i);
gsl_complex ek;
if (bk < GSL_DBL_EPSILON)
{
GSL_SET_COMPLEX(&ek,
GSL_SIGN(GSL_REAL(ak)) ? GSL_POSINF : GSL_NEGINF,
GSL_SIGN(GSL_IMAG(ak)) ? GSL_POSINF : GSL_NEGINF);
}
else
ek = gsl_complex_div_real(ak, bk);
/* search for something to swap */
for (j = i + 1; j < N; j++)
{
int test;
const gsl_complex aj = gsl_vector_complex_get (alpha, j);
double bj = gsl_vector_get(beta, j);
gsl_complex ej;
if (bj < GSL_DBL_EPSILON)
{
GSL_SET_COMPLEX(&ej,
GSL_SIGN(GSL_REAL(aj)) ? GSL_POSINF : GSL_NEGINF,
GSL_SIGN(GSL_IMAG(aj)) ? GSL_POSINF : GSL_NEGINF);
}
else
ej = gsl_complex_div_real(aj, bj);
switch (sort_type)
{
case GSL_EIGEN_SORT_ABS_ASC:
test = (gsl_complex_abs (ej) < gsl_complex_abs (ek));
break;
case GSL_EIGEN_SORT_ABS_DESC:
test = (gsl_complex_abs (ej) > gsl_complex_abs (ek));
break;
case GSL_EIGEN_SORT_VAL_ASC:
case GSL_EIGEN_SORT_VAL_DESC:
default:
GSL_ERROR ("invalid sort type", GSL_EINVAL);
}
if (test)
{
k = j;
ek = ej;
}
}
if (k != i)
{
/* swap eigenvalues */
gsl_vector_complex_swap_elements (alpha, i, k);
gsl_vector_swap_elements (beta, i, k);
/* swap eigenvectors */
gsl_matrix_complex_swap_columns (evec, i, k);
}
}
return GSL_SUCCESS;
}
}
int
gsl_linalg_HH_svx (gsl_matrix * A, gsl_vector * x)
{
if (A->size1 > A->size2)
{
/* System is underdetermined. */
GSL_ERROR ("System is underdetermined", GSL_EINVAL);
}
else if (A->size2 != x->size)
{
GSL_ERROR ("matrix and vector sizes must be equal", GSL_EBADLEN);
}
else
{
const size_t N = A->size1;
const size_t M = A->size2;
size_t i, j, k;
REAL *d = (REAL *) malloc (N * sizeof (REAL));
if (d == 0)
{
GSL_ERROR ("could not allocate memory for workspace", GSL_ENOMEM);
}
/* Perform Householder transformation. */
for (i = 0; i < N; i++)
{
const REAL aii = gsl_matrix_get (A, i, i);
REAL alpha;
REAL f;
REAL ak;
REAL max_norm = 0.0;
REAL r = 0.0;
for (k = i; k < M; k++)
{
REAL aki = gsl_matrix_get (A, k, i);
r += aki * aki;
}
if (r == 0.0)
{
/* Rank of matrix is less than size1. */
free (d);
GSL_ERROR ("matrix is rank deficient", GSL_ESING);
}
alpha = sqrt (r) * GSL_SIGN (aii);
ak = 1.0 / (r + alpha * aii);
gsl_matrix_set (A, i, i, aii + alpha);
d[i] = -alpha;
for (k = i + 1; k < N; k++)
{
REAL norm = 0.0;
f = 0.0;
for (j = i; j < M; j++)
{
REAL ajk = gsl_matrix_get (A, j, k);
REAL aji = gsl_matrix_get (A, j, i);
norm += ajk * ajk;
f += ajk * aji;
}
max_norm = GSL_MAX (max_norm, norm);
f *= ak;
for (j = i; j < M; j++)
{
REAL ajk = gsl_matrix_get (A, j, k);
REAL aji = gsl_matrix_get (A, j, i);
gsl_matrix_set (A, j, k, ajk - f * aji);
}
}
if (fabs (alpha) < 2.0 * GSL_DBL_EPSILON * sqrt (max_norm))
{
/* Apparent singularity. */
free (d);
GSL_ERROR("apparent singularity detected", GSL_ESING);
}
/* Perform update of RHS. */
f = 0.0;
for (j = i; j < M; j++)
{
f += gsl_vector_get (x, j) * gsl_matrix_get (A, j, i);
}
f *= ak;
for (j = i; j < M; j++)
{
REAL xj = gsl_vector_get (x, j);
REAL aji = gsl_matrix_get (A, j, i);
gsl_vector_set (x, j, xj - f * aji);
}
}
/* Perform back-substitution. */
for (i = N; i > 0 && i--;)
{
REAL xi = gsl_vector_get (x, i);
REAL sum = 0.0;
for (k = i + 1; k < N; k++)
{
sum += gsl_matrix_get (A, i, k) * gsl_vector_get (x, k);
}
gsl_vector_set (x, i, (xi - sum) / d[i]);
}
free (d);
return GSL_SUCCESS;
}
}
/* I would have prefered just using the library sin() function.
* But after some experimentation I decided that there was
* no good way to understand the error; library sin() is just a black box.
* So we have to roll our own.
*/
int
gsl_sf_sin_e(double x, gsl_sf_result * result)
{
/* CHECK_POINTER(result) */
{
const double P1 = 7.85398125648498535156e-1;
const double P2 = 3.77489470793079817668e-8;
const double P3 = 2.69515142907905952645e-15;
const double sgn_x = GSL_SIGN(x);
const double abs_x = fabs(x);
if(abs_x < GSL_ROOT4_DBL_EPSILON) {
const double x2 = x*x;
result->val = x * (1.0 - x2/6.0);
result->err = fabs(x*x2*x2 / 100.0);
return GSL_SUCCESS;
}
else {
double sgn_result = sgn_x;
double y = floor(abs_x/(0.25*M_PI));
int octant = y - ldexp(floor(ldexp(y,-3)),3);
int stat_cs;
double z;
if(GSL_IS_ODD(octant)) {
octant += 1;
octant &= 07;
y += 1.0;
}
if(octant > 3) {
octant -= 4;
sgn_result = -sgn_result;
}
z = ((abs_x - y * P1) - y * P2) - y * P3;
if(octant == 0) {
gsl_sf_result sin_cs_result;
const double t = 8.0*fabs(z)/M_PI - 1.0;
stat_cs = cheb_eval_e(&sin_cs, t, &sin_cs_result);
result->val = z * (1.0 + z*z * sin_cs_result.val);
}
else { /* octant == 2 */
gsl_sf_result cos_cs_result;
const double t = 8.0*fabs(z)/M_PI - 1.0;
stat_cs = cheb_eval_e(&cos_cs, t, &cos_cs_result);
result->val = 1.0 - 0.5*z*z * (1.0 - z*z * cos_cs_result.val);
}
result->val *= sgn_result;
if(abs_x > 1.0/GSL_DBL_EPSILON) {
result->err = fabs(result->val);
}
else if(abs_x > 100.0/GSL_SQRT_DBL_EPSILON) {
result->err = 2.0 * abs_x * GSL_DBL_EPSILON * fabs(result->val);
}
else if(abs_x > 0.1/GSL_SQRT_DBL_EPSILON) {
result->err = 2.0 * GSL_SQRT_DBL_EPSILON * fabs(result->val);
}
else {
result->err = 2.0 * GSL_DBL_EPSILON * fabs(result->val);
}
return stat_cs;
}
}
}
static VALUE rb_GSL_SIGN(VALUE obj, VALUE x)
{
return INT2FIX(GSL_SIGN(NUM2DBL(x)));
}
int
gsl_sf_lnpoch_sgn_e(const double a, const double x,
gsl_sf_result * result, double * sgn)
{
if(a == 0.0 || a+x == 0.0) {
*sgn = 0.0;
DOMAIN_ERROR(result);
}
else if(x == 0.0) {
*sgn = 1.0;
result->val = 0.0;
result->err = 0.0;
return GSL_SUCCESS;
}
else if(a > 0.0 && a+x > 0.0) {
*sgn = 1.0;
return lnpoch_pos(a, x, result);
}
else if(a < 0.0 && a+x < 0.0) {
/* Reduce to positive case using reflection.
*/
double sin_1 = sin(M_PI * (1.0 - a));
double sin_2 = sin(M_PI * (1.0 - a - x));
if(sin_1 == 0.0 || sin_2 == 0.0) {
*sgn = 0.0;
DOMAIN_ERROR(result);
}
else {
gsl_sf_result lnp_pos;
int stat_pp = lnpoch_pos(1.0-a, -x, &lnp_pos);
double lnterm = log(fabs(sin_1/sin_2));
result->val = lnterm - lnp_pos.val;
result->err = lnp_pos.err;
result->err += 2.0 * GSL_DBL_EPSILON * (fabs(1.0-a) + fabs(1.0-a-x)) * fabs(lnterm);
result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);
*sgn = GSL_SIGN(sin_1*sin_2);
return stat_pp;
}
}
else {
/* Evaluate gamma ratio directly.
*/
gsl_sf_result lg_apn;
gsl_sf_result lg_a;
double s_apn, s_a;
int stat_apn = gsl_sf_lngamma_sgn_e(a+x, &lg_apn, &s_apn);
int stat_a = gsl_sf_lngamma_sgn_e(a, &lg_a, &s_a);
if(stat_apn == GSL_SUCCESS && stat_a == GSL_SUCCESS) {
result->val = lg_apn.val - lg_a.val;
result->err = lg_apn.err + lg_a.err;
result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);
*sgn = s_a * s_apn;
return GSL_SUCCESS;
}
else if(stat_apn == GSL_EDOM || stat_a == GSL_EDOM){
*sgn = 0.0;
DOMAIN_ERROR(result);
}
else {
result->val = 0.0;
result->err = 0.0;
*sgn = 0.0;
return GSL_FAILURE;
}
}
}
