/* integ(f_monomial,x,a b)=constant*(b^(degree+1)-a^(degree+1))/(degree+1) */
double integ_f_monomial(double a, double b, struct monomial_params * p)
{
const int degreep1 = p->degree + 1;
const double bnp1 = gsl_pow_int(b, degreep1);
const double anp1 = gsl_pow_int(a, degreep1);
return (p->constant / degreep1)*(bnp1 - anp1);
}
// ============================================
void renorm(position *currentpos, double du, double doubleNUMu)
{
long double alpha;
double sum, term, term0;
double endPtCorr;
int i,n;
for(i=0;i<NUMDIM;i++)
{
endPtCorr=gsl_pow_int(currentpos[0].pos[i]-currentpos[NUMBEAD-1].pos[i],2)/doubleNUMu;
sum=0.0l;
for(n=0;n<NUMu;n++)
{
sum+=gsl_pow_int(currentpos[n].pos[i]-currentpos[n+1].pos[i],2);
}
alpha=sqrt((doubleNUMu*du*SIGMA2-endPtCorr)/(sum-endPtCorr));
term=(1.0L-alpha)*(currentpos[NUMBEAD-1].pos[i]-currentpos[0].pos[i])/doubleNUMu;
term0=(1.0L-alpha)*currentpos[0].pos[i];
//term and term0 have a subtraction of roughly equal numbers and thus is not very accurate
// alpha is ~1 with an error of 10^-4 or 5 for sample configs. This makes the routine
//nondeterministic between Fortran and C
for(n=1;n<NUMu;n++)
{
currentpos[n].pos[i]=alpha*currentpos[n].pos[i]+term0+(((double)(n))-1.0l)*term;
}
}
}
/*
* Test the identities:
*
* Sum_{k=0}^n (n choose k) (2 y)^{n - k} H_k(x) = H_n(x + y)
*
* and
*
* Sum_{k=0}^n (n choose k) y^{n-k} He_k(x) = He_n(x + y)
*
* see: http://mathworld.wolfram.com/HermitePolynomial.html (Eq. 55)
*/
void
test_hermite_id1(const int n, const double x, const double y)
{
double *a = malloc((n + 1) * sizeof(double));
double *b = malloc((n + 1) * sizeof(double));
double lhs, rhs;
int k;
a[0] = gsl_pow_int(2.0 * y, n);
b[0] = gsl_pow_int(y, n);
for (k = 1; k <= n; ++k)
{
double fac = (n - k + 1.0) / (k * y);
a[k] = 0.5 * fac * a[k - 1];
b[k] = fac * b[k - 1];
}
lhs = gsl_sf_hermite_phys_series(n, x, a);
rhs = gsl_sf_hermite_phys(n, x + y);
gsl_test_rel(lhs, rhs, TEST_TOL4, "identity1 phys n=%d x=%g y=%g", n, x, y);
lhs = gsl_sf_hermite_prob_series(n, x, b);
rhs = gsl_sf_hermite_prob(n, x + y);
gsl_test_rel(lhs, rhs, TEST_TOL3, "identity1 prob n=%d x=%g y=%g", n, x, y);
free(a);
free(b);
}
// ============================================
void renormBB(double bb[NUMBEAD], double du, double doubleNUMu)
{
int n;
double endPtCorr;
double sum, term, term0;
double alpha;
endPtCorr=gsl_pow_int(bb[0]-bb[NUMBEAD-1],2)/doubleNUMu;
sum=0.0l;
#pragma omp parallel for reduction(+:sum)
for(n=0;n<NUMu;n++)
{
sum+=gsl_pow_int(bb[n]-bb[n+1],2);
}
alpha=sqrt((doubleNUMu*du*SIGMA2-endPtCorr)/(sum-endPtCorr));
term=(1.0l-alpha)*(bb[NUMBEAD-1]-bb[0])/doubleNUMu;
term0=(1.0l-alpha)*bb[0];
//term and term0 have a subtraction of roughly equal numbers and thus is not very accurate
// alpha is ~1 with an error of 10^-4 or 5 for sample configs. This makes the routine
//nondeterministic between Fortran and C
#pragma omp parallel for
for(n=1;n<NUMu;n++)
{
bb[n]=alpha*bb[n]+term0+((double)(n-1))*term;
}
}
int AllSubsetsMetaAnalysis(gsl_vector * esVector, gsl_vector * varVector,
gsl_vector * metaResultsVector, ST_uint4 from, ST_uint4 to ) {
ST_retcode rc;
ST_uint4 i, nStudies;
ST_long j, nSubsets;
char buf[80];
gsl_combination * comb;
nStudies = esVector->size;
nSubsets = gsl_pow_int(2, nStudies)-1 ;
j=1;
//for(i=1; i <= nStudies; i++) {
for(i=from; i <= to; i++) {
comb = gsl_combination_calloc(nStudies, i);
do {
if(j == nSubsets+1) {
snprintf(buf, 80,"combLength %u Obs %u\n",i, j);
SF_error(buf);
SF_error("Exceeded the maximum number of subsets!!!\n");
return(-2);
}
if ((rc = MetaAnalysis(esVector, varVector, metaResultsVector, comb) )) return(rc);
if ((rc = WriteOut(metaResultsVector, j, comb) )) return(rc);
j += 1;
} while (gsl_combination_next(comb) == GSL_SUCCESS);
}
gsl_combination_free(comb);
return(0);
}
// Remove a polynomial from the data
CVector &PolynomialRemoved(CVector &vdX, CVector &vdY, int nOrder) {
CVector *pvdPolyReduced, vdSubtract;
CMatrix mdM, mdTemp;
if(! vdX.Defined() || ! vdY.Defined()) {throw ELENotDefined; }
if(vdX.m_pnDimSize[0] != vdY.m_pnDimSize[0]) {throw ELEDimensionMisMatch; }
pvdPolyReduced = new CVector(vdY.m_pnDimSize[0]); // Make a deep copy of the original
pvdPolyReduced->SetAllocated(true); // We allocated the memory space
// Set the polynomial reduction matrix
mdM.Initialize(vdX.m_pnDimSize[0], nOrder+1);
for(int i=0; i<vdX.m_pnDimSize[0]; i++) {
for(int j=0; j<=nOrder; j++) {
mdM[i][j] = gsl_pow_int(double(vdX[i]), j);
} // for j
} // for i
// Set the projection matrix
mdTemp = mdM[LO_TRANSPOSE] * mdM;
mdTemp.Invert();
// Calculate the reduced vector
vdSubtract = mdM * (mdTemp * (mdM[LO_TRANSPOSE] * vdY));
*pvdPolyReduced = vdY - vdSubtract;
if(vdX.Allocated()) { delete &vdX; } // This should call for the destructor
if(vdY.Allocated()) { delete &vdY; } // This should call for the destructor
return *pvdPolyReduced;
} // PolynomialRemoved
/* Radial integrand. */
static double radial_integrand(double r, void *params)
{
const inner_integrand_params *integrand_params = (const inner_integrand_params *) params;
const double onebyr = 1 / r;
return exp((integrand_params->A * onebyr + integrand_params->B) * onebyr - integrand_params->log_offset)
* gsl_pow_int(r, integrand_params->prior_distance_power);
}
/*assigns a temperature @code beta@ to an MPI rank*/
double /*beta*/ assign_beta(int rank,/*MPI rank*/ int R, /*MPI Comm size*/ int gamma)/*exponent: @code beta=(1-rank/R)^gamma@*/{
double x=(double)(R-rank)/(double) R;
double b=-1;
assert(gamma>=1);
b=gsl_pow_int(x, gamma);
assert(b>=0 && b<=1.0);
return b;
}
void nround (const double *n,int size,unsigned int c,double *ret){
int i;
double m,up;
for (i=0;i<size;i++){
m = gsl_pow_int(10,c);
up = n[i]*m;
ret[i] = round(up)/m;
}
}
double
ho_R (int n, int l, double b, double r)
{
////////////////////////////////////////////////////////////////////
// b= sqrt(h/(wm) ) //
////////////////////////////////////////////////////////////////////
double x=r/b;
return ho_A(n, l, b) * gsl_pow_int(x, (l + 1)) * exp (- x*x/ 2.) * gsl_sf_laguerre_n((n - 1), l + 1./2., x*x);
}
void PSO::Swarm::init_network() {
if (numInform < swarmSize-1) {
double p = 1.-gsl_pow_int(1.-1./swarmSize,numInform);
for (int i(0); i < swarmSize; ++i) {
for (int j(0); j < swarmSize; ++j) {
if (i == j) links.add_link(i,j);
if (rng.uniform() < p) links.add_link(i,j);
}
}
}
}
double I_xyz(int l1, double pax, int l2, double pbx, double gamma, int flags)
{
// 《量子化学》中册 P63 (10.6.8) (10.6.9) (10.6.10)
int i;
double sum = 0;
// BUG 2i
for (i = 0; i < floor((l1 + l2) * 0.5) + 1; i++) {
sum += factorial_2(2*i - 1) / gsl_pow_int(2 * gamma, i) * \
fi_l_ll_pax_pbx(2*i, l1, l2, pax, pbx, flags);
}
return sum;
}
//============================================
void printDistance(config *newConfig, position *savePos)
{
int i,n;
double tempSum;
tempSum=0.0l;
#pragma omp parallel for private(i) reduction(+:tempSum)
for(n=1;n<NUMBEAD-1;n++){
for(i=0;i<NUMDIM;i++){
tempSum+=gsl_pow_int(newConfig[n].pos[i]-savePos[n].pos[i],2);
}
}
printf("%+.10f \n",tempSum/(NUMBEAD-2));
}
int main(int argc, char * argv[]) {
// Define constants
const int nArgs = 6;
// Process arguments
int c, timeCol=0, valueCol=1;
extern char *optarg;
char * dataFile, * basisFile, * priorFile, * idString=NULL;
short readID = 0;
int kSmooth = 8;
int maxIter = 1e3;
double nu=5;
double tol=1e-9;
double missingCode = 99.999;
int minObs = 10;
int basisRows, basisCols, dataRows;
int i;
// Parse options
while ( (c=getopt(argc, argv, "c:d:i:m:n:s:t:h")) != -1 ) {
switch(c) {
case 'h':
puts(kHelpMessage);
return 0;
case 'c':
valueCol = atoi(optarg);
valueCol = (valueCol < 0) ? 0 : valueCol;
break;
case 'd':
nu = atof(optarg);
nu = (nu < 1) ? 1 : nu;
break;
case 'i':
idString = optarg;
readID = 1;
break;
case 'm':
missingCode = atof(optarg);
break;
case 'n':
minObs = atoi(optarg);
break;
case 's':
kSmooth = atoi(optarg);
kSmooth = (trunc(log2(kSmooth))-log2(kSmooth) > 1e-16) ?
(int) gsl_pow_int(2, trunc(log2(kSmooth))) : kSmooth;
break;
case 't':
timeCol = atoi(optarg);
timeCol = (timeCol < 0) ? 1 : timeCol;
break;
case '?':
if ( isprint(optopt) )
fprintf(stderr, "Unknown argument '%c'\n", optopt);
else
fprintf(stderr, "Unknown option character `\\x%x'.\n", optopt);
exit(1);
break;
default:
abort();
}
}
// Parse positional arguments
if (argc-optind < nArgs) {
fprintf(stderr, "Not enough arguments\n");
exit(1);
}
// Get file names and dimensions
basisFile = argv[optind];
basisRows = atoi( argv[optind+1] );
basisCols = atoi( argv[optind+2] );
dataFile = argv[optind+3];
dataRows = atoi( argv[optind+4] );
priorFile = argv[optind + 5];
if (readID == 0)
{
idString = dataFile;
}
// Read basis to allocated matrix
double* basisMat;
basisMat = malloc(basisCols * basisRows * sizeof(double));
checkPtr(basisMat, "out of memory");
readToDoubleMatrix(basisFile, basisRows, basisCols, basisMat);
// Read times to vector
double* timeVec;
timeVec = malloc(dataRows * sizeof(double));
if (timeVec==NULL)
{
fprintf(stderr, "Error -- out of memory\n");
exit(1);
}
int timesRead = readToDoubleVectorDynamic(dataFile, dataRows,
timeCol, &timeVec);
// Check for valid first time
if (isnan(timeVec[0]))
{
fprintf(stderr, "Error -- NaN at first time; aborting\n");
exit(1);
}
// Read y values to vector
double* yVec;
yVec = malloc(dataRows * sizeof(double));
if (yVec==NULL)
{
fprintf(stderr, "Error -- out of memory\n");
exit(1);
}
int obsRead = readToDoubleVectorDynamic(dataFile, dataRows,
valueCol, &yVec);
// Check for valid first obs
if (isnan(yVec[0]))
{
fprintf(stderr, "Error -- NaN at first observation; aborting\n");
exit(1);
}
// Check for agreement between timesRead and obsRead
if (timesRead != obsRead)
{
fprintf(stderr, "Error -- differing number of entries ");
fprintf(stderr, "in time and data columns\n");
exit(1);
}
// Read prior to vector
double * priorVec;
priorVec = malloc( (basisCols-1) * sizeof(double));
if (priorVec==NULL)
{
fprintf(stderr, "Error -- out of memory\n");
exit(1);
}
readToDoubleVector(priorFile, basisCols-1, 0, priorVec);
/*
* Handle coded missing values and restructure times
*/
int nObs = 0;
int * validInd;
validInd = calloc(sizeof(int), obsRead);
// Find valid indices
for (i=0; i<obsRead; i++)
{
if (yVec[i] != missingCode)
{
validInd[nObs]=i;
nObs++;
}
}
// Check for minimum number of observations
if (nObs < minObs)
{
fprintf(stderr, "Error -- read %d obs, minimum to process is %d\n",
nObs, minObs);
exit(1);
}
// Move valid data to head of timeVec and yVec
for (i=0; i<nObs; i++)
{
yVec[i] = yVec[validInd[i]];
timeVec[i] = timeVec[validInd[i]];
}
// Setup variables for estimation
double logPosterior_l, logLikelihood_l, tau_l;
double logPosterior_m, logLikelihood_m, tau_m;
double * coef_l, * coef_m;
coef_l = malloc(kSmooth * sizeof(double));
if (coef_l==NULL)
{
fprintf(stderr, "Error -- out of memory\n");
exit(1);
}
coef_m = malloc(basisCols * sizeof(double));
if (coef_m==NULL)
{
fprintf(stderr, "Error -- out of memory\n");
exit(1);
}
// Run wavelet model with t residuals for full basis
int iter_m;
iter_m = lmT(basisMat, basisRows, basisCols,
yVec, nObs,
timeVec,
priorVec,
nu, basisCols,
maxIter, tol,
&logPosterior_m,
&logLikelihood_m,
coef_m,
&tau_m);
// Run wavelet model with t residuals for restricted (smooth) basis
int iter_l;
iter_l = lmT(basisMat, basisRows, basisCols,
yVec, nObs,
timeVec,
priorVec,
nu, kSmooth,
maxIter, tol,
&logPosterior_l,
&logLikelihood_l,
coef_l,
&tau_l);
// Calculate test statistics (LLR & LPR)
double llr, lpr;
llr = logLikelihood_m - logLikelihood_l;
llr *= 2;
lpr = logPosterior_m - logPosterior_l;
/*
* Print output
*/
// Basic information
fprintf(stdout, "%s %d %d %d %g ", idString, nObs, basisCols, kSmooth, nu);
// Test statistics
fprintf(stdout, "%g %g ", llr, lpr);
// Other statistics
fprintf(stdout, "%g ", sqrt(tau_m));
// Coefficients for k = 1..m
for (i=0; i<basisCols; i++) fprintf(stdout, "%g ", coef_m[i]);
fprintf(stdout, "\n");
/*
* Free allocated memory
*/
// Free basisMat
free(basisMat);
basisMat = NULL;
// Free timeVec & yVec
free(timeVec);
timeVec=NULL;
free(yVec);
yVec=NULL;
// Free coef vecs and prior vec
free(coef_l);
coef_l=NULL;
free(coef_m);
coef_m=NULL;
free(priorVec);
priorVec=NULL;
return 0;
}
int
main (void)
{
double y, y_expected;
int e, e_expected;
gsl_ieee_env_setup ();
/* Test for expm1 */
y = gsl_expm1 (0.0);
y_expected = 0.0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_expm1(0.0)");
y = gsl_expm1 (1e-10);
y_expected = 1.000000000050000000002e-10;
gsl_test_rel (y, y_expected, 1e-15, "gsl_expm1(1e-10)");
y = gsl_expm1 (-1e-10);
y_expected = -9.999999999500000000017e-11;
gsl_test_rel (y, y_expected, 1e-15, "gsl_expm1(-1e-10)");
y = gsl_expm1 (0.1);
y_expected = 0.1051709180756476248117078264902;
gsl_test_rel (y, y_expected, 1e-15, "gsl_expm1(0.1)");
y = gsl_expm1 (-0.1);
y_expected = -0.09516258196404042683575094055356;
gsl_test_rel (y, y_expected, 1e-15, "gsl_expm1(-0.1)");
y = gsl_expm1 (10.0);
y_expected = 22025.465794806716516957900645284;
gsl_test_rel (y, y_expected, 1e-15, "gsl_expm1(10.0)");
y = gsl_expm1 (-10.0);
y_expected = -0.99995460007023751514846440848444;
gsl_test_rel (y, y_expected, 1e-15, "gsl_expm1(-10.0)");
/* Test for log1p */
y = gsl_log1p (0.0);
y_expected = 0.0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_log1p(0.0)");
y = gsl_log1p (1e-10);
y_expected = 9.9999999995000000000333333333308e-11;
gsl_test_rel (y, y_expected, 1e-15, "gsl_log1p(1e-10)");
y = gsl_log1p (0.1);
y_expected = 0.095310179804324860043952123280765;
gsl_test_rel (y, y_expected, 1e-15, "gsl_log1p(0.1)");
y = gsl_log1p (10.0);
y_expected = 2.3978952727983705440619435779651;
gsl_test_rel (y, y_expected, 1e-15, "gsl_log1p(10.0)");
/* Test for gsl_hypot */
y = gsl_hypot (0.0, 0.0);
y_expected = 0.0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(0.0, 0.0)");
y = gsl_hypot (1e-10, 1e-10);
y_expected = 1.414213562373095048801688e-10;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(1e-10, 1e-10)");
y = gsl_hypot (1e-38, 1e-38);
y_expected = 1.414213562373095048801688e-38;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(1e-38, 1e-38)");
y = gsl_hypot (1e-10, -1.0);
y_expected = 1.000000000000000000005;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(1e-10, -1)");
y = gsl_hypot (-1.0, 1e-10);
y_expected = 1.000000000000000000005;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(-1, 1e-10)");
y = gsl_hypot (1e307, 1e301);
y_expected = 1.000000000000499999999999e307;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(1e307, 1e301)");
y = gsl_hypot (1e301, 1e307);
y_expected = 1.000000000000499999999999e307;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(1e301, 1e307)");
y = gsl_hypot (1e307, 1e307);
y_expected = 1.414213562373095048801688e307;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(1e307, 1e307)");
/* Test +-Inf, finite */
y = gsl_hypot (GSL_POSINF, 1.2);
y_expected = GSL_POSINF;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(GSL_POSINF, 1.2)");
y = gsl_hypot (GSL_NEGINF, 1.2);
y_expected = GSL_POSINF;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(GSL_NEGINF, 1.2)");
y = gsl_hypot (1.2, GSL_POSINF);
y_expected = GSL_POSINF;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(1.2, GSL_POSINF)");
y = gsl_hypot (1.2, GSL_NEGINF);
y_expected = GSL_POSINF;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(1.2, GSL_NEGINF)");
/* Test NaN, finite */
y = gsl_hypot (GSL_NAN, 1.2);
y_expected = GSL_NAN;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(GSL_NAN, 1.2)");
y = gsl_hypot (1.2, GSL_NAN);
y_expected = GSL_NAN;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(1.2, GSL_NAN)");
/* Test NaN, NaN */
y = gsl_hypot (GSL_NAN, GSL_NAN);
y_expected = GSL_NAN;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(GSL_NAN, GSL_NAN)");
/* Test +Inf, NaN */
y = gsl_hypot (GSL_POSINF, GSL_NAN);
y_expected = GSL_POSINF;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(GSL_POSINF, GSL_NAN)");
/* Test -Inf, NaN */
y = gsl_hypot (GSL_NEGINF, GSL_NAN);
y_expected = GSL_POSINF;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(GSL_NEGINF, GSL_NAN)");
/* Test NaN, +Inf */
y = gsl_hypot (GSL_NAN, GSL_POSINF);
y_expected = GSL_POSINF;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(GSL_NAN, GSL_POSINF)");
/* Test NaN, -Inf */
y = gsl_hypot (GSL_NAN, GSL_NEGINF);
y_expected = GSL_POSINF;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(GSL_NAN, GSL_NEGINF)");
/* Test for gsl_hypot3 */
y = gsl_hypot3 (0.0, 0.0, 0.0);
y_expected = 0.0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot3(0.0, 0.0, 0.0)");
y = gsl_hypot3 (1e-10, 1e-10, 1e-10);
y_expected = 1.732050807568877293527446e-10;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot3(1e-10, 1e-10, 1e-10)");
y = gsl_hypot3 (1e-38, 1e-38, 1e-38);
y_expected = 1.732050807568877293527446e-38;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot3(1e-38, 1e-38, 1e-38)");
y = gsl_hypot3 (1e-10, 1e-10, -1.0);
y_expected = 1.000000000000000000099;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot3(1e-10, 1e-10, -1)");
y = gsl_hypot3 (1e-10, -1.0, 1e-10);
y_expected = 1.000000000000000000099;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot3(1e-10, -1, 1e-10)");
y = gsl_hypot3 (-1.0, 1e-10, 1e-10);
y_expected = 1.000000000000000000099;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot3(-1, 1e-10, 1e-10)");
y = gsl_hypot3 (1e307, 1e301, 1e301);
y_expected = 1.0000000000009999999999995e307;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot3(1e307, 1e301, 1e301)");
y = gsl_hypot3 (1e307, 1e307, 1e307);
y_expected = 1.732050807568877293527446e307;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot3(1e307, 1e307, 1e307)");
y = gsl_hypot3 (1e307, 1e-307, 1e-307);
y_expected = 1.0e307;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot3(1e307, 1e-307, 1e-307)");
/* Test for acosh */
y = gsl_acosh (1.0);
y_expected = 0.0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_acosh(1.0)");
y = gsl_acosh (1.1);
y_expected = 4.435682543851151891329110663525e-1;
gsl_test_rel (y, y_expected, 1e-15, "gsl_acosh(1.1)");
y = gsl_acosh (10.0);
y_expected = 2.9932228461263808979126677137742e0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_acosh(10.0)");
y = gsl_acosh (1e10);
y_expected = 2.3718998110500402149594646668302e1;
gsl_test_rel (y, y_expected, 1e-15, "gsl_acosh(1e10)");
/* Test for asinh */
y = gsl_asinh (0.0);
y_expected = 0.0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(0.0)");
y = gsl_asinh (1e-10);
y_expected = 9.9999999999999999999833333333346e-11;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(1e-10)");
y = gsl_asinh (-1e-10);
y_expected = -9.9999999999999999999833333333346e-11;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(1e-10)");
y = gsl_asinh (0.1);
y_expected = 9.983407889920756332730312470477e-2;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(0.1)");
y = gsl_asinh (-0.1);
y_expected = -9.983407889920756332730312470477e-2;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(-0.1)");
y = gsl_asinh (1.0);
y_expected = 8.8137358701954302523260932497979e-1;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(1.0)");
y = gsl_asinh (-1.0);
y_expected = -8.8137358701954302523260932497979e-1;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(-1.0)");
y = gsl_asinh (10.0);
y_expected = 2.9982229502979697388465955375965e0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(10)");
y = gsl_asinh (-10.0);
y_expected = -2.9982229502979697388465955375965e0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(-10)");
y = gsl_asinh (1e10);
y_expected = 2.3718998110500402149599646668302e1;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(1e10)");
y = gsl_asinh (-1e10);
y_expected = -2.3718998110500402149599646668302e1;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(-1e10)");
/* Test for atanh */
y = gsl_atanh (0.0);
y_expected = 0.0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_atanh(0.0)");
y = gsl_atanh (1e-20);
y_expected = 1e-20;
gsl_test_rel (y, y_expected, 1e-15, "gsl_atanh(1e-20)");
y = gsl_atanh (-1e-20);
y_expected = -1e-20;
gsl_test_rel (y, y_expected, 1e-15, "gsl_atanh(-1e-20)");
y = gsl_atanh (0.1);
y_expected = 1.0033534773107558063572655206004e-1;
gsl_test_rel (y, y_expected, 1e-15, "gsl_atanh(0.1)");
y = gsl_atanh (-0.1);
y_expected = -1.0033534773107558063572655206004e-1;
gsl_test_rel (y, y_expected, 1e-15, "gsl_atanh(-0.1)");
y = gsl_atanh (0.9);
y_expected = 1.4722194895832202300045137159439e0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_atanh(0.9)");
y = gsl_atanh (-0.9);
y_expected = -1.4722194895832202300045137159439e0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_atanh(0.9)");
/* Test for pow_int */
y = gsl_pow_2 (-3.14);
y_expected = pow (-3.14, 2.0);
gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_2(-3.14)");
y = gsl_pow_3 (-3.14);
y_expected = pow (-3.14, 3.0);
gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_3(-3.14)");
y = gsl_pow_4 (-3.14);
y_expected = pow (-3.14, 4.0);
gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_4(-3.14)");
y = gsl_pow_5 (-3.14);
y_expected = pow (-3.14, 5.0);
gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_5(-3.14)");
y = gsl_pow_6 (-3.14);
y_expected = pow (-3.14, 6.0);
gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_6(-3.14)");
y = gsl_pow_7 (-3.14);
y_expected = pow (-3.14, 7.0);
gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_7(-3.14)");
y = gsl_pow_8 (-3.14);
y_expected = pow (-3.14, 8.0);
gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_8(-3.14)");
y = gsl_pow_9 (-3.14);
y_expected = pow (-3.14, 9.0);
gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_9(-3.14)");
{
int n;
for (n = -9; n < 10; n++)
{
y = gsl_pow_int (-3.14, n);
y_expected = pow (-3.14, n);
gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_int(-3.14,%d)", n);
}
}
{
unsigned int n;
for (n = 0; n < 10; n++)
{
y = gsl_pow_uint (-3.14, n);
y_expected = pow (-3.14, n);
gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_uint(-3.14,%d)", n);
}
}
/* Test case for n at INT_MAX, INT_MIN */
{
double u = 1.0000001;
int n = INT_MAX;
y = gsl_pow_int (u, n);
y_expected = pow (u, n);
gsl_test_rel (y, y_expected, 1e-6, "gsl_pow_int(%.7f,%d)", u, n);
n = INT_MIN;
y = gsl_pow_int (u, n);
y_expected = pow (u, n);
gsl_test_rel (y, y_expected, 1e-6, "gsl_pow_int(%.7f,%d)", u, n);
}
/* Test for ldexp */
y = gsl_ldexp (M_PI, -2);
y_expected = M_PI_4;
gsl_test_rel (y, y_expected, 1e-15, "gsl_ldexp(pi,-2)");
y = gsl_ldexp (1.0, 2);
y_expected = 4.000000;
gsl_test_rel (y, y_expected, 1e-15, "gsl_ldexp(1.0,2)");
y = gsl_ldexp (0.0, 2);
y_expected = 0.0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_ldexp(0.0,2)");
y = gsl_ldexp (9.999999999999998890e-01, 1024);
y_expected = GSL_DBL_MAX;
gsl_test_rel (y, y_expected, 1e-15, "gsl_ldexp DBL_MAX");
y = gsl_ldexp (1e308, -2000);
y_expected = 8.7098098162172166755761e-295;
gsl_test_rel (y, y_expected, 1e-15, "gsl_ldexp(1e308,-2000)");
y = gsl_ldexp (GSL_DBL_MIN, 2000);
y_expected = 2.554675596204441378334779940e294;
gsl_test_rel (y, y_expected, 1e-15, "gsl_ldexp(DBL_MIN,2000)");
/* Test subnormals */
{
int i = 0;
volatile double x = GSL_DBL_MIN;
y_expected = 2.554675596204441378334779940e294;
x /= 2;
while (x > 0)
{
i++ ;
y = gsl_ldexp (x, 2000 + i);
gsl_test_rel (y, y_expected, 1e-15, "gsl_ldexp(DBL_MIN/2**%d,%d)",i,2000+i);
x /= 2;
}
}
/* Test for frexp */
y = gsl_frexp (0.0, &e);
y_expected = 0;
e_expected = 0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_frexp(0) fraction");
gsl_test_int (e, e_expected, "gsl_frexp(0) exponent");
y = gsl_frexp (M_PI, &e);
y_expected = M_PI_4;
e_expected = 2;
gsl_test_rel (y, y_expected, 1e-15, "gsl_frexp(pi) fraction");
gsl_test_int (e, e_expected, "gsl_frexp(pi) exponent");
y = gsl_frexp (2.0, &e);
y_expected = 0.5;
e_expected = 2;
gsl_test_rel (y, y_expected, 1e-15, "gsl_frexp(2.0) fraction");
gsl_test_int (e, e_expected, "gsl_frexp(2.0) exponent");
y = gsl_frexp (1.0 / 4.0, &e);
y_expected = 0.5;
e_expected = -1;
gsl_test_rel (y, y_expected, 1e-15, "gsl_frexp(0.25) fraction");
gsl_test_int (e, e_expected, "gsl_frexp(0.25) exponent");
y = gsl_frexp (1.0 / 4.0 - 4.0 * GSL_DBL_EPSILON, &e);
y_expected = 0.999999999999996447;
e_expected = -2;
gsl_test_rel (y, y_expected, 1e-15, "gsl_frexp(0.25-eps) fraction");
gsl_test_int (e, e_expected, "gsl_frexp(0.25-eps) exponent");
y = gsl_frexp (GSL_DBL_MAX, &e);
y_expected = 9.999999999999998890e-01;
e_expected = 1024;
gsl_test_rel (y, y_expected, 1e-15, "gsl_frexp(DBL_MAX) fraction");
gsl_test_int (e, e_expected, "gsl_frexp(DBL_MAX) exponent");
y = gsl_frexp (-GSL_DBL_MAX, &e);
y_expected = -9.999999999999998890e-01;
e_expected = 1024;
gsl_test_rel (y, y_expected, 1e-15, "gsl_frexp(-DBL_MAX) fraction");
gsl_test_int (e, e_expected, "gsl_frexp(-DBL_MAX) exponent");
y = gsl_frexp (GSL_DBL_MIN, &e);
y_expected = 0.5;
e_expected = -1021;
gsl_test_rel (y, y_expected, 1e-15, "gsl_frexp(DBL_MIN) fraction");
gsl_test_int (e, e_expected, "gsl_frexp(DBL_MIN) exponent");
y = gsl_frexp (-GSL_DBL_MIN, &e);
y_expected = -0.5;
e_expected = -1021;
gsl_test_rel (y, y_expected, 1e-15, "gsl_frexp(-DBL_MIN) fraction");
gsl_test_int (e, e_expected, "gsl_frexp(-DBL_MIN) exponent");
/* Test subnormals */
{
int i = 0;
volatile double x = GSL_DBL_MIN;
y_expected = 0.5;
e_expected = -1021;
x /= 2;
while (x > 0)
{
e_expected--;
i++ ;
y = gsl_frexp (x, &e);
gsl_test_rel (y, y_expected, 1e-15, "gsl_frexp(DBL_MIN/2**%d) fraction",i);
gsl_test_int (e, e_expected, "gsl_frexp(DBL_MIN/2**%d) exponent", i);
x /= 2;
}
}
/* Test for approximate floating point comparison */
{
double x, y;
int i;
x = M_PI;
y = 22.0 / 7.0;
/* test the basic function */
for (i = 0; i < 10; i++)
{
double tol = pow (10, -i);
int res = gsl_fcmp (x, y, tol);
gsl_test_int (res, -(i >= 4), "gsl_fcmp(%.5f,%.5f,%g)", x, y, tol);
}
for (i = 0; i < 10; i++)
{
double tol = pow (10, -i);
int res = gsl_fcmp (y, x, tol);
gsl_test_int (res, (i >= 4), "gsl_fcmp(%.5f,%.5f,%g)", y, x, tol);
}
}
#if HAVE_IEEE_COMPARISONS
/* Test for isinf, isnan, finite */
{
double zero, one, inf, nan;
int s;
zero = 0.0;
one = 1.0;
inf = exp (1.0e10);
nan = inf / inf;
s = gsl_isinf (zero);
gsl_test_int (s, 0, "gsl_isinf(0)");
s = gsl_isinf (one);
gsl_test_int (s, 0, "gsl_isinf(1)");
s = gsl_isinf (inf);
gsl_test_int (s, 1, "gsl_isinf(inf)");
s = gsl_isinf (-inf);
gsl_test_int (s, -1, "gsl_isinf(-inf)");
s = gsl_isinf (nan);
gsl_test_int (s, 0, "gsl_isinf(nan)");
s = gsl_isnan (zero);
gsl_test_int (s, 0, "gsl_isnan(0)");
s = gsl_isnan (one);
gsl_test_int (s, 0, "gsl_isnan(1)");
s = gsl_isnan (inf);
gsl_test_int (s, 0, "gsl_isnan(inf)");
s = gsl_isnan (-inf);
gsl_test_int (s, 0, "gsl_isnan(-inf)");
s = gsl_isnan (nan);
gsl_test_int (s, 1, "gsl_isnan(nan)");
s = gsl_finite (zero);
gsl_test_int (s, 1, "gsl_finite(0)");
s = gsl_finite (one);
gsl_test_int (s, 1, "gsl_finite(1)");
s = gsl_finite (inf);
gsl_test_int (s, 0, "gsl_finite(inf)");
s = gsl_finite (-inf);
gsl_test_int (s, 0, "gsl_finite(-inf)");
s = gsl_finite (nan);
gsl_test_int (s, 0, "gsl_finite(nan)");
}
#endif
{
double x = gsl_fdiv (2.0, 3.0);
gsl_test_rel (x, 2.0 / 3.0, 4 * GSL_DBL_EPSILON, "gsl_fdiv(2,3)");
}
/* Test constants in gsl_math.h */
{
double x = log(M_E);
gsl_test_rel (x, 1.0, 4 * GSL_DBL_EPSILON, "ln(M_E)");
}
{
double x=pow(2.0,M_LOG2E);
gsl_test_rel (x, exp(1.0), 4 * GSL_DBL_EPSILON, "2^M_LOG2E");
}
{
double x=pow(10.0,M_LOG10E);
gsl_test_rel (x, exp(1.0), 4 * GSL_DBL_EPSILON, "10^M_LOG10E");
}
{
double x=pow(M_SQRT2, 2.0);
gsl_test_rel (x, 2.0, 4 * GSL_DBL_EPSILON, "M_SQRT2^2");
}
{
double x=pow(M_SQRT1_2, 2.0);
gsl_test_rel (x, 1.0/2.0, 4 * GSL_DBL_EPSILON, "M_SQRT1_2");
}
{
double x=pow(M_SQRT3, 2.0);
gsl_test_rel (x, 3.0, 4 * GSL_DBL_EPSILON, "M_SQRT3^2");
}
{
double x = M_PI;
gsl_test_rel (x, 3.1415926535897932384626433832795, 4 * GSL_DBL_EPSILON, "M_PI");
}
{
double x = 2 * M_PI_2;
gsl_test_rel (x, M_PI, 4 * GSL_DBL_EPSILON, "2*M_PI_2");
}
{
double x = 4 * M_PI_4;
gsl_test_rel (x, M_PI, 4 * GSL_DBL_EPSILON, "4*M_PI_4");
}
{
double x = pow(M_SQRTPI, 2.0);
gsl_test_rel (x, M_PI, 4 * GSL_DBL_EPSILON, "M_SQRTPI^2");
}
{
double x = pow(M_2_SQRTPI, 2.0);
gsl_test_rel (x, 4/M_PI, 4 * GSL_DBL_EPSILON, "M_SQRTPI^2");
}
{
double x = M_1_PI;
gsl_test_rel (x, 1/M_PI, 4 * GSL_DBL_EPSILON, "M_1_SQRTPI");
}
{
double x = M_2_PI;
gsl_test_rel (x, 2.0/M_PI, 4 * GSL_DBL_EPSILON, "M_2_PI");
}
{
double x = exp(M_LN10);
gsl_test_rel (x, 10, 4 * GSL_DBL_EPSILON, "exp(M_LN10)");
}
{
double x = exp(M_LN2);
gsl_test_rel (x, 2, 4 * GSL_DBL_EPSILON, "exp(M_LN2)");
}
{
double x = exp(M_LNPI);
gsl_test_rel (x, M_PI, 4 * GSL_DBL_EPSILON, "exp(M_LNPI)");
}
{
double x = M_EULER;
gsl_test_rel (x, 0.5772156649015328606065120900824, 4 * GSL_DBL_EPSILON, "M_EULER");
}
exit (gsl_test_summary ());
}
unsigned int
gsl_ran_binomial (const gsl_rng * rng, double p, unsigned int n)
{
int ix; /* return value */
int flipped = 0;
double q, s, np;
if (n == 0)
return 0;
if (p > 0.5)
{
p = 1.0 - p; /* work with small p */
flipped = 1;
}
q = 1 - p;
s = p / q;
np = n * p;
/* Inverse cdf logic for small mean (BINV in K+S) */
if (np < SMALL_MEAN)
{
double f0 = gsl_pow_int (q, n); /* f(x), starting with x=0 */
while (1)
{
/* This while(1) loop will almost certainly only loop once; but
* if u=1 to within a few epsilons of machine precision, then it
* is possible for roundoff to prevent the main loop over ix to
* achieve its proper value. following the ranlib implementation,
* we introduce a check for that situation, and when it occurs,
* we just try again.
*/
double f = f0;
double u = gsl_rng_uniform (rng);
for (ix = 0; ix <= BINV_CUTOFF; ++ix)
{
if (u < f)
goto Finish;
u -= f;
/* Use recursion f(x+1) = f(x)*[(n-x)/(x+1)]*[p/(1-p)] */
f *= s * (n - ix) / (ix + 1);
}
/* It should be the case that the 'goto Finish' was encountered
* before this point was ever reached. But if we have reached
* this point, then roundoff has prevented u from decreasing
* all the way to zero. This can happen only if the initial u
* was very nearly equal to 1, which is a rare situation. In
* that rare situation, we just try again.
*
* Note, following the ranlib implementation, we loop ix only to
* a hardcoded value of SMALL_MEAN_LARGE_N=110; we could have
* looped to n, and 99.99...% of the time it won't matter. This
* choice, I think is a little more robust against the rare
* roundoff error. If n>LARGE_N, then it is technically
* possible for ix>LARGE_N, but it is astronomically rare, and
* if ix is that large, it is more likely due to roundoff than
* probability, so better to nip it at LARGE_N than to take a
* chance that roundoff will somehow conspire to produce an even
* larger (and more improbable) ix. If n<LARGE_N, then once
* ix=n, f=0, and the loop will continue until ix=LARGE_N.
*/
}
}
else
{
/* For n >= SMALL_MEAN, we invoke the BTPE algorithm */
int k;
double ffm = np + p; /* ffm = n*p+p */
int m = (int) ffm; /* m = int floor[n*p+p] */
double fm = m; /* fm = double m; */
double xm = fm + 0.5; /* xm = half integer mean (tip of triangle) */
double npq = np * q; /* npq = n*p*q */
/* Compute cumulative area of tri, para, exp tails */
/* p1: radius of triangle region; since height=1, also: area of region */
/* p2: p1 + area of parallelogram region */
/* p3: p2 + area of left tail */
/* p4: p3 + area of right tail */
/* pi/p4: probability of i'th area (i=1,2,3,4) */
/* Note: magic numbers 2.195, 4.6, 0.134, 20.5, 15.3 */
/* These magic numbers are not adjustable...at least not easily! */
double p1 = floor (2.195 * sqrt (npq) - 4.6 * q) + 0.5;
/* xl, xr: left and right edges of triangle */
double xl = xm - p1;
double xr = xm + p1;
/* Parameter of exponential tails */
/* Left tail: t(x) = c*exp(-lambda_l*[xl - (x+0.5)]) */
/* Right tail: t(x) = c*exp(-lambda_r*[(x+0.5) - xr]) */
double c = 0.134 + 20.5 / (15.3 + fm);
double p2 = p1 * (1.0 + c + c);
double al = (ffm - xl) / (ffm - xl * p);
double lambda_l = al * (1.0 + 0.5 * al);
double ar = (xr - ffm) / (xr * q);
double lambda_r = ar * (1.0 + 0.5 * ar);
double p3 = p2 + c / lambda_l;
double p4 = p3 + c / lambda_r;
double var, accept;
double u, v; /* random variates */
TryAgain:
/* generate random variates, u specifies which region: Tri, Par, Tail */
u = gsl_rng_uniform (rng) * p4;
v = gsl_rng_uniform (rng);
if (u <= p1)
{
/* Triangular region */
ix = (int) (xm - p1 * v + u);
goto Finish;
}
else if (u <= p2)
{
/* Parallelogram region */
double x = xl + (u - p1) / c;
v = v * c + 1.0 - fabs (x - xm) / p1;
if (v > 1.0 || v <= 0.0)
goto TryAgain;
ix = (int) x;
}
else if (u <= p3)
{
/* Left tail */
ix = (int) (xl + log (v) / lambda_l);
if (ix < 0)
goto TryAgain;
v *= ((u - p2) * lambda_l);
}
else
{
/* Right tail */
ix = (int) (xr - log (v) / lambda_r);
if (ix > (double) n)
goto TryAgain;
v *= ((u - p3) * lambda_r);
}
/* At this point, the goal is to test whether v <= f(x)/f(m)
*
* v <= f(x)/f(m) = (m!(n-m)! / (x!(n-x)!)) * (p/q)^{x-m}
*
*/
/* Here is a direct test using logarithms. It is a little
* slower than the various "squeezing" computations below, but
* if things are working, it should give exactly the same answer
* (given the same random number seed). */
#ifdef DIRECT
var = log (v);
accept =
LNFACT (m) + LNFACT (n - m) - LNFACT (ix) - LNFACT (n - ix)
+ (ix - m) * log (p / q);
#else /* SQUEEZE METHOD */
/* More efficient determination of whether v < f(x)/f(M) */
k = abs (ix - m);
if (k <= FAR_FROM_MEAN)
{
/*
* If ix near m (ie, |ix-m|<FAR_FROM_MEAN), then do
* explicit evaluation using recursion relation for f(x)
*/
double g = (n + 1) * s;
double f = 1.0;
var = v;
if (m < ix)
{
int i;
for (i = m + 1; i <= ix; i++)
{
f *= (g / i - s);
}
}
else if (m > ix)
{
int i;
for (i = ix + 1; i <= m; i++)
{
f /= (g / i - s);
}
}
accept = f;
}
else
{
/* If ix is far from the mean m: k=ABS(ix-m) large */
var = log (v);
if (k < npq / 2 - 1)
{
/* "Squeeze" using upper and lower bounds on
* log(f(x)) The squeeze condition was derived
* under the condition k < npq/2-1 */
double amaxp =
k / npq * ((k * (k / 3.0 + 0.625) + (1.0 / 6.0)) / npq + 0.5);
double ynorm = -(k * k / (2.0 * npq));
if (var < ynorm - amaxp)
goto Finish;
if (var > ynorm + amaxp)
goto TryAgain;
}
/* Now, again: do the test log(v) vs. log f(x)/f(M) */
#if USE_EXACT
/* This is equivalent to the above, but is a little (~20%) slower */
/* There are five log's vs three above, maybe that's it? */
accept = LNFACT (m) + LNFACT (n - m)
- LNFACT (ix) - LNFACT (n - ix) + (ix - m) * log (p / q);
#else /* USE STIRLING */
/* The "#define Stirling" above corresponds to the first five
* terms in asymptoic formula for
* log Gamma (y) - (y-0.5)log(y) + y - 0.5 log(2*pi);
* See Abramowitz and Stegun, eq 6.1.40
*/
/* Note below: two Stirling's are added, and two are
* subtracted. In both K+S, and in the ranlib
* implementation, all four are added. I (jt) believe that
* is a mistake -- this has been confirmed by personal
* correspondence w/ Dr. Kachitvichyanukul. Note, however,
* the corrections are so small, that I couldn't find an
* example where it made a difference that could be
* observed, let alone tested. In fact, define'ing Stirling
* to be zero gave identical results!! In practice, alv is
* O(1), ranging 0 to -10 or so, while the Stirling
* correction is typically O(10^{-5}) ...setting the
* correction to zero gives about a 2% performance boost;
* might as well keep it just to be pendantic. */
{
double x1 = ix + 1.0;
double w1 = n - ix + 1.0;
double f1 = fm + 1.0;
double z1 = n + 1.0 - fm;
accept = xm * log (f1 / x1) + (n - m + 0.5) * log (z1 / w1)
+ (ix - m) * log (w1 * p / (x1 * q))
+ Stirling (f1) + Stirling (z1) - Stirling (x1) - Stirling (w1);
}
#endif
#endif
}
if (var <= accept)
{
goto Finish;
}
else
{
goto TryAgain;
}
}
Finish:
return (flipped) ? (n - ix) : (unsigned int)ix;
}
static VALUE rb_gsl_pow_int(VALUE obj, VALUE xx, VALUE nn)
{
VALUE x, ary, argv[2];
size_t i, j, size;
int n;
gsl_vector *v = NULL, *vnew = NULL;
gsl_matrix *m = NULL, *mnew = NULL;
if (CLASS_OF(xx) == rb_cRange) xx = rb_gsl_range2ary(xx);
switch (TYPE(xx)) {
case T_FIXNUM:
case T_BIGNUM:
case T_FLOAT:
return rb_float_new(gsl_pow_int(NUM2DBL(xx), FIX2INT(nn)));
break;
case T_ARRAY:
CHECK_FIXNUM(nn);
n = FIX2INT(nn);
size = RARRAY_LEN(xx);
ary = rb_ary_new2(size);
for (i = 0; i < size; i++) {
x = rb_ary_entry(xx, i);
Need_Float(x);
// rb_ary_store(ary, i, rb_float_new(gsl_pow_int(RFLOAT(x)->value, n)));
rb_ary_store(ary, i, rb_float_new(gsl_pow_int(NUM2DBL(x), n)));
}
return ary;
break;
default:
#ifdef HAVE_NARRAY_H
if (NA_IsNArray(xx)) {
struct NARRAY *na;
double *ptr1, *ptr2;
CHECK_FIXNUM(nn);
n = FIX2INT(nn);
GetNArray(xx, na);
ptr1 = (double*) na->ptr;
size = na->total;
ary = na_make_object(NA_DFLOAT, na->rank, na->shape, CLASS_OF(xx));
ptr2 = NA_PTR_TYPE(ary, double*);
for (i = 0; i < size; i++) ptr2[i] = gsl_pow_int(ptr1[i], n);
return ary;
}
#endif
if (VECTOR_P(xx)) {
CHECK_FIXNUM(nn);
n = FIX2INT(nn);
Data_Get_Struct(xx, gsl_vector, v);
vnew = gsl_vector_alloc(v->size);
for (i = 0; i < v->size; i++) {
gsl_vector_set(vnew, i, gsl_pow_int(gsl_vector_get(v, i), n));
}
return Data_Wrap_Struct(cgsl_vector, 0, gsl_vector_free, vnew);
} else if (MATRIX_P(xx)) {
CHECK_FIXNUM(nn);
n = FIX2INT(nn);
Data_Get_Struct(xx, gsl_matrix, m);
mnew = gsl_matrix_alloc(m->size1, m->size2);
for (i = 0; i < m->size1; i++) {
for (j = 0; j < m->size2; j++) {
gsl_matrix_set(mnew, i, j, gsl_pow_int(gsl_matrix_get(m, i, j), n));
}
}
return Data_Wrap_Struct(cgsl_matrix, 0, gsl_matrix_free, mnew);
} else if (COMPLEX_P(xx) || VECTOR_COMPLEX_P(xx) || MATRIX_COMPLEX_P(xx)) {
argv[0] = xx;
argv[1] = nn;
return rb_gsl_complex_pow_real(2, argv, obj);
} else {
rb_raise(rb_eTypeError, "wrong argument type %s (Array or Vector or Matrix expected)", rb_class2name(CLASS_OF(xx)));
}
break;
}
/* never reach here */
return Qnil;
}
int
main (void)
{
double y, y_expected;
int e, e_expected;
gsl_ieee_env_setup ();
/* Test for expm1 */
y = gsl_expm1 (0.0);
y_expected = 0.0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_expm1(0.0)");
y = gsl_expm1 (1e-10);
y_expected = 1.000000000050000000002e-10;
gsl_test_rel (y, y_expected, 1e-15, "gsl_expm1(1e-10)");
y = gsl_expm1 (-1e-10);
y_expected = -9.999999999500000000017e-11;
gsl_test_rel (y, y_expected, 1e-15, "gsl_expm1(-1e-10)");
y = gsl_expm1 (0.1);
y_expected = 0.1051709180756476248117078264902;
gsl_test_rel (y, y_expected, 1e-15, "gsl_expm1(0.1)");
y = gsl_expm1 (-0.1);
y_expected = -0.09516258196404042683575094055356;
gsl_test_rel (y, y_expected, 1e-15, "gsl_expm1(-0.1)");
y = gsl_expm1 (10.0);
y_expected = 22025.465794806716516957900645284;
gsl_test_rel (y, y_expected, 1e-15, "gsl_expm1(10.0)");
y = gsl_expm1 (-10.0);
y_expected = -0.99995460007023751514846440848444;
gsl_test_rel (y, y_expected, 1e-15, "gsl_expm1(-10.0)");
/* Test for log1p */
y = gsl_log1p (0.0);
y_expected = 0.0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_log1p(0.0)");
y = gsl_log1p (1e-10);
y_expected = 9.9999999995000000000333333333308e-11;
gsl_test_rel (y, y_expected, 1e-15, "gsl_log1p(1e-10)");
y = gsl_log1p (0.1);
y_expected = 0.095310179804324860043952123280765;
gsl_test_rel (y, y_expected, 1e-15, "gsl_log1p(0.1)");
y = gsl_log1p (10.0);
y_expected = 2.3978952727983705440619435779651;
gsl_test_rel (y, y_expected, 1e-15, "gsl_log1p(10.0)");
/* Test for gsl_hypot */
y = gsl_hypot (0.0, 0.0);
y_expected = 0.0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(0.0, 0.0)");
y = gsl_hypot (1e-10, 1e-10);
y_expected = 1.414213562373095048801688e-10;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(1e-10, 1e-10)");
y = gsl_hypot (1e-38, 1e-38);
y_expected = 1.414213562373095048801688e-38;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(1e-38, 1e-38)");
y = gsl_hypot (1e-10, -1.0);
y_expected = 1.000000000000000000005;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(1e-10, -1)");
y = gsl_hypot (-1.0, 1e-10);
y_expected = 1.000000000000000000005;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(-1, 1e-10)");
y = gsl_hypot (1e307, 1e301);
y_expected = 1.000000000000499999999999e307;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(1e307, 1e301)");
y = gsl_hypot (1e301, 1e307);
y_expected = 1.000000000000499999999999e307;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(1e301, 1e307)");
y = gsl_hypot (1e307, 1e307);
y_expected = 1.414213562373095048801688e307;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(1e307, 1e307)");
/* Test for acosh */
y = gsl_acosh (1.0);
y_expected = 0.0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_acosh(1.0)");
y = gsl_acosh (1.1);
y_expected = 4.435682543851151891329110663525e-1;
gsl_test_rel (y, y_expected, 1e-15, "gsl_acosh(1.1)");
y = gsl_acosh (10.0);
y_expected = 2.9932228461263808979126677137742e0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_acosh(10.0)");
y = gsl_acosh (1e10);
y_expected = 2.3718998110500402149594646668302e1;
gsl_test_rel (y, y_expected, 1e-15, "gsl_acosh(1e10)");
/* Test for asinh */
y = gsl_asinh (0.0);
y_expected = 0.0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(0.0)");
y = gsl_asinh (1e-10);
y_expected = 9.9999999999999999999833333333346e-11;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(1e-10)");
y = gsl_asinh (-1e-10);
y_expected = -9.9999999999999999999833333333346e-11;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(1e-10)");
y = gsl_asinh (0.1);
y_expected = 9.983407889920756332730312470477e-2;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(0.1)");
y = gsl_asinh (-0.1);
y_expected = -9.983407889920756332730312470477e-2;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(-0.1)");
y = gsl_asinh (1.0);
y_expected = 8.8137358701954302523260932497979e-1;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(1.0)");
y = gsl_asinh (-1.0);
y_expected = -8.8137358701954302523260932497979e-1;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(-1.0)");
y = gsl_asinh (10.0);
y_expected = 2.9982229502979697388465955375965e0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(10)");
y = gsl_asinh (-10.0);
y_expected = -2.9982229502979697388465955375965e0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(-10)");
y = gsl_asinh (1e10);
y_expected = 2.3718998110500402149599646668302e1;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(1e10)");
y = gsl_asinh (-1e10);
y_expected = -2.3718998110500402149599646668302e1;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(-1e10)");
/* Test for atanh */
y = gsl_atanh (0.0);
y_expected = 0.0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_atanh(0.0)");
y = gsl_atanh (1e-20);
y_expected = 1e-20;
gsl_test_rel (y, y_expected, 1e-15, "gsl_atanh(1e-20)");
y = gsl_atanh (-1e-20);
y_expected = -1e-20;
gsl_test_rel (y, y_expected, 1e-15, "gsl_atanh(-1e-20)");
y = gsl_atanh (0.1);
y_expected = 1.0033534773107558063572655206004e-1;
gsl_test_rel (y, y_expected, 1e-15, "gsl_atanh(0.1)");
y = gsl_atanh (-0.1);
y_expected = -1.0033534773107558063572655206004e-1;
gsl_test_rel (y, y_expected, 1e-15, "gsl_atanh(-0.1)");
y = gsl_atanh (0.9);
y_expected = 1.4722194895832202300045137159439e0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_atanh(0.9)");
y = gsl_atanh (-0.9);
y_expected = -1.4722194895832202300045137159439e0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_atanh(0.9)");
/* Test for pow_int */
y = gsl_pow_2 (-3.14);
y_expected = pow (-3.14, 2.0);
gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_2(-3.14)");
y = gsl_pow_3 (-3.14);
y_expected = pow (-3.14, 3.0);
gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_3(-3.14)");
y = gsl_pow_4 (-3.14);
y_expected = pow (-3.14, 4.0);
gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_4(-3.14)");
y = gsl_pow_5 (-3.14);
y_expected = pow (-3.14, 5.0);
gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_5(-3.14)");
y = gsl_pow_6 (-3.14);
y_expected = pow (-3.14, 6.0);
gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_6(-3.14)");
y = gsl_pow_7 (-3.14);
y_expected = pow (-3.14, 7.0);
gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_7(-3.14)");
y = gsl_pow_8 (-3.14);
y_expected = pow (-3.14, 8.0);
gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_8(-3.14)");
y = gsl_pow_9 (-3.14);
y_expected = pow (-3.14, 9.0);
gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_9(-3.14)");
{
int n;
for (n = -9; n < 10; n++)
{
y = gsl_pow_int (-3.14, n);
y_expected = pow (-3.14, n);
gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_n(-3.14,%d)", n);
}
}
/* Test for ldexp */
y = gsl_ldexp (M_PI, -2);
y_expected = M_PI_4;
gsl_test_rel (y, y_expected, 1e-15, "gsl_ldexp(pi,-2)");
y = gsl_ldexp (1.0, 2);
y_expected = 4.000000;
gsl_test_rel (y, y_expected, 1e-15, "gsl_ldexp(1.0,2)");
y = gsl_ldexp (0.0, 2);
y_expected = 0.0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_ldexp(0.0,2)");
/* Test for frexp */
y = gsl_frexp (M_PI, &e);
y_expected = M_PI_4;
e_expected = 2;
gsl_test_rel (y, y_expected, 1e-15, "gsl_frexp(pi) fraction");
gsl_test_int (e, e_expected, "gsl_frexp(pi) exponent");
y = gsl_frexp (2.0, &e);
y_expected = 0.5;
e_expected = 2;
gsl_test_rel (y, y_expected, 1e-15, "gsl_frexp(2.0) fraction");
gsl_test_int (e, e_expected, "gsl_frexp(2.0) exponent");
y = gsl_frexp (1.0 / 4.0, &e);
y_expected = 0.5;
e_expected = -1;
gsl_test_rel (y, y_expected, 1e-15, "gsl_frexp(0.25) fraction");
gsl_test_int (e, e_expected, "gsl_frexp(0.25) exponent");
y = gsl_frexp (1.0 / 4.0 - 4.0 * GSL_DBL_EPSILON, &e);
y_expected = 0.999999999999996447;
e_expected = -2;
gsl_test_rel (y, y_expected, 1e-15, "gsl_frexp(0.25-eps) fraction");
gsl_test_int (e, e_expected, "gsl_frexp(0.25-eps) exponent");
/* Test for approximate floating point comparison */
{
double x, y;
int i;
x = M_PI;
y = 22.0 / 7.0;
/* test the basic function */
for (i = 0; i < 10; i++)
{
double tol = pow (10, -i);
int res = gsl_fcmp (x, y, tol);
gsl_test_int (res, -(i >= 4), "gsl_fcmp(%.5f,%.5f,%g)", x, y, tol);
}
for (i = 0; i < 10; i++)
{
double tol = pow (10, -i);
int res = gsl_fcmp (y, x, tol);
gsl_test_int (res, (i >= 4), "gsl_fcmp(%.5f,%.5f,%g)", y, x, tol);
}
}
#if HAVE_IEEE_COMPARISONS
/* Test for isinf, isnan, finite */
{
double zero, one, inf, nan;
int s;
zero = 0.0;
one = 1.0;
inf = exp (1.0e10);
nan = inf / inf;
s = gsl_isinf (zero);
gsl_test_int (s, 0, "gsl_isinf(0)");
s = gsl_isinf (one);
gsl_test_int (s, 0, "gsl_isinf(1)");
s = gsl_isinf (inf);
gsl_test_int (s, 1, "gsl_isinf(inf)");
s = gsl_isinf (-inf);
gsl_test_int (s, -1, "gsl_isinf(-inf)");
s = gsl_isinf (nan);
gsl_test_int (s, 0, "gsl_isinf(nan)");
s = gsl_isnan (zero);
gsl_test_int (s, 0, "gsl_isnan(0)");
s = gsl_isnan (one);
gsl_test_int (s, 0, "gsl_isnan(1)");
s = gsl_isnan (inf);
gsl_test_int (s, 0, "gsl_isnan(inf)");
s = gsl_isnan (nan);
gsl_test_int (s, 1, "gsl_isnan(nan)");
s = gsl_finite (zero);
gsl_test_int (s, 1, "gsl_finite(0)");
s = gsl_finite (one);
gsl_test_int (s, 1, "gsl_finite(1)");
s = gsl_finite (inf);
gsl_test_int (s, 0, "gsl_finite(inf)");
s = gsl_finite (nan);
gsl_test_int (s, 0, "gsl_finite(nan)");
}
#endif
{
double x = gsl_fdiv (2.0, 3.0);
gsl_test_rel (x, 2.0 / 3.0, 4 * GSL_DBL_EPSILON, "gsl_fdiv(2,3)");
}
exit (gsl_test_summary ());
}
int
main (void)
{
double y, y_expected;
gsl_ieee_env_setup ();
/* Test for expm1 */
y = gsl_expm1 (0.0); y_expected = 0.0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_expm1(0.0)");
y = gsl_expm1 (1e-10); y_expected = 1.000000000050000000002e-10;
gsl_test_rel (y, y_expected, 1e-15, "gsl_expm1(1e-10)");
y = gsl_expm1 (-1e-10); y_expected = -9.999999999500000000017e-11;
gsl_test_rel (y, y_expected, 1e-15, "gsl_expm1(-1e-10)");
y = gsl_expm1 (0.1); y_expected = 0.1051709180756476248117078264902;
gsl_test_rel (y, y_expected, 1e-15, "gsl_expm1(0.1)");
y = gsl_expm1 (-0.1); y_expected = -0.09516258196404042683575094055356;
gsl_test_rel (y, y_expected, 1e-15, "gsl_expm1(-0.1)");
y = gsl_expm1 (10.0); y_expected = 22025.465794806716516957900645284;
gsl_test_rel (y, y_expected, 1e-15, "gsl_expm1(10.0)");
y = gsl_expm1 (-10.0); y_expected = -0.99995460007023751514846440848444;
gsl_test_rel (y, y_expected, 1e-15, "gsl_expm1(-10.0)");
/* Test for log1p */
y = gsl_log1p (0.0); y_expected = 0.0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_log1p(0.0)");
y = gsl_log1p (1e-10); y_expected = 9.9999999995000000000333333333308e-11;
gsl_test_rel (y, y_expected, 1e-15, "gsl_log1p(1e-10)");
y = gsl_log1p (0.1); y_expected = 0.095310179804324860043952123280765;
gsl_test_rel (y, y_expected, 1e-15, "gsl_log1p(0.1)");
y = gsl_log1p (10.0); y_expected = 2.3978952727983705440619435779651;
gsl_test_rel (y, y_expected, 1e-15, "gsl_log1p(10.0)");
/* Test for gsl_hypot */
y = gsl_hypot (0.0, 0.0) ; y_expected = 0.0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(0.0, 0.0)");
y = gsl_hypot (1e-10, 1e-10) ; y_expected = 1.414213562373095048801688e-10;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(1e-10, 1e-10)");
y = gsl_hypot (1e-38, 1e-38) ; y_expected = 1.414213562373095048801688e-38;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(1e-38, 1e-38)");
y = gsl_hypot (1e-10, -1.0) ; y_expected = 1.000000000000000000005;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(1e-10, -1)");
y = gsl_hypot (-1.0, 1e-10) ; y_expected = 1.000000000000000000005;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(-1, 1e-10)");
y = gsl_hypot (1e307, 1e301) ; y_expected = 1.000000000000499999999999e307;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(1e307, 1e301)");
y = gsl_hypot (1e301, 1e307) ; y_expected = 1.000000000000499999999999e307;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(1e301, 1e307)");
y = gsl_hypot (1e307, 1e307) ; y_expected = 1.414213562373095048801688e307;
gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(1e307, 1e307)");
/* Test for acosh */
y = gsl_acosh (1.0); y_expected = 0.0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_acosh(1.0)");
y = gsl_acosh (1.1); y_expected = 4.435682543851151891329110663525e-1;
gsl_test_rel (y, y_expected, 1e-15, "gsl_acosh(1.1)");
y = gsl_acosh (10.0); y_expected = 2.9932228461263808979126677137742e0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_acosh(10.0)");
y = gsl_acosh (1e10); y_expected = 2.3718998110500402149594646668302e1;
gsl_test_rel (y, y_expected, 1e-15, "gsl_acosh(1e10)");
/* Test for asinh */
y = gsl_asinh (0.0); y_expected = 0.0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(0.0)");
y = gsl_asinh (1e-10); y_expected = 9.9999999999999999999833333333346e-11;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(1e-10)");
y = gsl_asinh (-1e-10); y_expected = -9.9999999999999999999833333333346e-11;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(1e-10)");
y = gsl_asinh (0.1); y_expected = 9.983407889920756332730312470477e-2;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(0.1)");
y = gsl_asinh (-0.1); y_expected = -9.983407889920756332730312470477e-2;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(-0.1)");
y = gsl_asinh (1.0); y_expected = 8.8137358701954302523260932497979e-1;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(1.0)");
y = gsl_asinh (-1.0); y_expected = -8.8137358701954302523260932497979e-1;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(-1.0)");
y = gsl_asinh (10.0); y_expected = 2.9982229502979697388465955375965e0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(10)");
y = gsl_asinh (-10.0); y_expected = -2.9982229502979697388465955375965e0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(-10)");
y = gsl_asinh (1e10); y_expected = 2.3718998110500402149599646668302e1;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(1e10)");
y = gsl_asinh (-1e10); y_expected = -2.3718998110500402149599646668302e1;
gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(-1e10)");
/* Test for atanh */
y = gsl_atanh (0.0); y_expected = 0.0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_atanh(0.0)");
y = gsl_atanh (1e-20); y_expected = 1e-20;
gsl_test_rel (y, y_expected, 1e-15, "gsl_atanh(1e-20)");
y = gsl_atanh (-1e-20); y_expected = -1e-20;
gsl_test_rel (y, y_expected, 1e-15, "gsl_atanh(-1e-20)");
y = gsl_atanh (0.1); y_expected = 1.0033534773107558063572655206004e-1;
gsl_test_rel (y, y_expected, 1e-15, "gsl_atanh(0.1)");
y = gsl_atanh (-0.1); y_expected = -1.0033534773107558063572655206004e-1;
gsl_test_rel (y, y_expected, 1e-15, "gsl_atanh(-0.1)");
y = gsl_atanh (0.9); y_expected = 1.4722194895832202300045137159439e0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_atanh(0.9)");
y = gsl_atanh (-0.9); y_expected = -1.4722194895832202300045137159439e0;
gsl_test_rel (y, y_expected, 1e-15, "gsl_atanh(0.9)");
/* Test for pow_int */
y = gsl_pow_2 (-3.14); y_expected = pow(-3.14, 2.0);
gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_2(-3.14)");
y = gsl_pow_3 (-3.14); y_expected = pow(-3.14, 3.0);
gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_3(-3.14)");
y = gsl_pow_4 (-3.14); y_expected = pow(-3.14, 4.0);
gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_4(-3.14)");
y = gsl_pow_5 (-3.14); y_expected = pow(-3.14, 5.0);
gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_5(-3.14)");
y = gsl_pow_6 (-3.14); y_expected = pow(-3.14, 6.0);
gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_6(-3.14)");
y = gsl_pow_7 (-3.14); y_expected = pow(-3.14, 7.0);
gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_7(-3.14)");
y = gsl_pow_8 (-3.14); y_expected = pow(-3.14, 8.0);
gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_8(-3.14)");
y = gsl_pow_9 (-3.14); y_expected = pow(-3.14, 9.0);
gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_9(-3.14)");
{
int n;
for (n = -9; n < 10; n++) {
y = gsl_pow_int (-3.14, n); y_expected = pow(-3.14, n);
gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_n(-3.14,%d)", n);
}
}
/* Test for isinf, isnan, finite*/
{
double zero, one, inf, nan;
int s;
zero = 0.0;
one = 1.0;
inf = exp(1.0e10);
nan = inf / inf;
s = gsl_isinf(zero);
gsl_test_int (s, 0, "gsl_isinf(0)");
s = gsl_isinf(one);
gsl_test_int (s, 0, "gsl_isinf(1)");
s = gsl_isinf(inf);
gsl_test_int (s, 1, "gsl_isinf(inf)");
s = gsl_isinf(-inf);
gsl_test_int (s, -1, "gsl_isinf(-inf)");
s = gsl_isinf(nan);
gsl_test_int (s, 0, "gsl_isinf(nan)");
s = gsl_isnan(zero);
gsl_test_int (s, 0, "gsl_isnan(0)");
s = gsl_isnan(one);
gsl_test_int (s, 0, "gsl_isnan(1)");
s = gsl_isnan(inf);
gsl_test_int (s, 0, "gsl_isnan(inf)");
s = gsl_isnan(nan);
gsl_test_int (s, 1, "gsl_isnan(nan)");
s = gsl_finite(zero);
gsl_test_int (s, 1, "gsl_finite(0)");
s = gsl_finite(one);
gsl_test_int (s, 1, "gsl_finite(1)");
s = gsl_finite(inf);
gsl_test_int (s, 0, "gsl_finite(inf)");
s = gsl_finite(nan);
gsl_test_int (s, 0, "gsl_finite(nan)");
}
{
double x = gsl_fdiv (2.0, 3.0);
gsl_test_rel (x, 2.0/3.0, 4*GSL_DBL_EPSILON, "gsl_fdiv(2,3)");
}
exit (gsl_test_summary ());
}
int
gsl_monte_vegas_integrate (gsl_monte_function * f,
double xl[], double xu[],
size_t dim, size_t calls,
gsl_rng * r,
gsl_monte_vegas_state * state,
double *result, double *abserr)
{
double cum_int, cum_sig;
size_t i, k, it;
if (dim != state->dim)
{
GSL_ERROR ("number of dimensions must match allocated size", GSL_EINVAL);
}
for (i = 0; i < dim; i++)
{
if (xu[i] <= xl[i])
{
GSL_ERROR ("xu must be greater than xl", GSL_EINVAL);
}
if (xu[i] - xl[i] > GSL_DBL_MAX)
{
GSL_ERROR ("Range of integration is too large, please rescale",
GSL_EINVAL);
}
}
if (state->stage == 0)
{
init_grid (state, xl, xu, dim);
if (state->verbose >= 0)
{
print_lim (state, xl, xu, dim);
}
}
if (state->stage <= 1)
{
state->wtd_int_sum = 0;
state->sum_wgts = 0;
state->chi_sum = 0;
state->it_num = 1;
state->samples = 0;
state->chisq = 0;
}
if (state->stage <= 2)
{
unsigned int bins = state->bins_max;
unsigned int boxes = 1;
if (state->mode != GSL_VEGAS_MODE_IMPORTANCE_ONLY)
{
/* shooting for 2 calls/box */
boxes = floor (pow (calls / 2.0, 1.0 / dim));
state->mode = GSL_VEGAS_MODE_IMPORTANCE;
if (2 * boxes >= state->bins_max)
{
/* if bins/box < 2 */
int box_per_bin = GSL_MAX (boxes / state->bins_max, 1);
bins = GSL_MIN(boxes / box_per_bin, state->bins_max);
boxes = box_per_bin * bins;
state->mode = GSL_VEGAS_MODE_STRATIFIED;
}
}
{
double tot_boxes = gsl_pow_int ((double) boxes, dim);
state->calls_per_box = GSL_MAX (calls / tot_boxes, 2);
calls = state->calls_per_box * tot_boxes;
}
/* total volume of x-space/(avg num of calls/bin) */
state->jac = state->vol * pow ((double) bins, (double) dim) / calls;
state->boxes = boxes;
/* If the number of bins changes from the previous invocation, bins
are expanded or contracted accordingly, while preserving bin
density */
if (bins != state->bins)
{
resize_grid (state, bins);
if (state->verbose > 1)
{
print_grid (state, dim);
}
}
if (state->verbose >= 0)
{
print_head (state,
dim, calls, state->it_num, state->bins, state->boxes);
}
}
state->it_start = state->it_num;
cum_int = 0.0;
cum_sig = 0.0;
for (it = 0; it < state->iterations; it++)
{
double intgrl = 0.0, intgrl_sq = 0.0;
double tss = 0.0;
double wgt, var, sig;
size_t calls_per_box = state->calls_per_box;
double jacbin = state->jac;
double *x = state->x;
coord *bin = state->bin;
state->it_num = state->it_start + it;
reset_grid_values (state);
init_box_coord (state, state->box);
do
{
volatile double m = 0, q = 0;
double f_sq_sum = 0.0;
for (k = 0; k < calls_per_box; k++)
{
volatile double fval;
double bin_vol;
random_point (x, bin, &bin_vol, state->box, xl, xu, state, r);
fval = jacbin * bin_vol * GSL_MONTE_FN_EVAL (f, x);
/* recurrence for mean and variance (sum of squares) */
{
double d = fval - m;
m += d / (k + 1.0);
q += d * d * (k / (k + 1.0));
}
if (state->mode != GSL_VEGAS_MODE_STRATIFIED)
{
double f_sq = fval * fval;
accumulate_distribution (state, bin, f_sq);
}
}
intgrl += m * calls_per_box;
f_sq_sum = q * calls_per_box;
tss += f_sq_sum;
if (state->mode == GSL_VEGAS_MODE_STRATIFIED)
{
accumulate_distribution (state, bin, f_sq_sum);
}
}
while (change_box_coord (state, state->box));
/* Compute final results for this iteration */
var = tss / (calls_per_box - 1.0) ;
if (var > 0)
{
wgt = 1.0 / var;
}
else if (state->sum_wgts > 0)
{
wgt = state->sum_wgts / state->samples;
}
else
{
wgt = 0.0;
}
intgrl_sq = intgrl * intgrl;
sig = sqrt (var);
state->result = intgrl;
state->sigma = sig;
if (wgt > 0.0)
{
double sum_wgts = state->sum_wgts;
double wtd_int_sum = state->wtd_int_sum;
double m = (sum_wgts > 0) ? (wtd_int_sum / sum_wgts) : 0;
double q = intgrl - m;
state->samples++ ;
state->sum_wgts += wgt;
state->wtd_int_sum += intgrl * wgt;
state->chi_sum += intgrl_sq * wgt;
cum_int = state->wtd_int_sum / state->sum_wgts;
cum_sig = sqrt (1 / state->sum_wgts);
#if USE_ORIGINAL_CHISQ_FORMULA
/* This is the chisq formula from the original Lepage paper. It
computes the variance from <x^2> - <x>^2 and can suffer from
catastrophic cancellations, e.g. returning negative chisq. */
if (state->samples > 1)
{
state->chisq = (state->chi_sum - state->wtd_int_sum * cum_int) /
(state->samples - 1.0);
}
#else
/* The new formula below computes exactly the same quantity as above
but using a stable recurrence */
if (state->samples == 1) {
state->chisq = 0;
} else {
state->chisq *= (state->samples - 2.0);
state->chisq += (wgt / (1 + (wgt / sum_wgts))) * q * q;
state->chisq /= (state->samples - 1.0);
}
#endif
}
else
{
cum_int += (intgrl - cum_int) / (it + 1.0);
cum_sig = 0.0;
}
if (state->verbose >= 0)
{
print_res (state,
state->it_num, intgrl, sig, cum_int, cum_sig,
state->chisq);
if (it + 1 == state->iterations && state->verbose > 0)
{
print_grid (state, dim);
}
}
if (state->verbose > 1)
{
print_dist (state, dim);
}
refine_grid (state);
if (state->verbose > 1)
{
print_grid (state, dim);
}
}
/* By setting stage to 1 further calls will generate independent
estimates based on the same grid, although it may be rebinned. */
state->stage = 1;
*result = cum_int;
*abserr = cum_sig;
return GSL_SUCCESS;
}
int main(int argc,char *argv[])
{
//%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
//VARIABLE DEFINITION
//%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
float cp,S,sigma,gamma,pp,Topt;
float q,Ab,Aw,Agf,grad_T,fi,mm,nn,Pmax,EVPmax;
float Ec,Es,deltat,t_integracion,t_modelacion;
float Lini,Lfin,deltaL;
int niter,niterL,nzc;
Vector zc_vector;
int zczc,ii;
float Ac,L,zc;
float aclouds,awhite,ablack,Ts,d;
float t,xx,As;
float k1,k2,k3,k4;
int j;
float Tc,Tlb,Tlw,Tanual,I,a,EVP,E;
float P;
float k1c,k2c,k3c,k4c;
float k1w,k2w,k3w,k4w;
float k1b,k2b,k3b,k4b;
float Bw,Bb;
int it;
Vector time,temperature,white_temperature,
black_temperature,white_area,black_area,clouds_area,evap,prec;
Matrix resultados;
FILE *fl;
char fname[1000];
float k1p1,k1p2,k1p3,k1p4,k1p5;
//%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
//PARAMETERS
//%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
cp = 3.e13; //erg*cm-2*K-1
S = 2.89e13; //erg*cm-2*año-1
sigma = 1789.; //erg*cm-2*año-1*K-4
gamma = 0.3; //año-1
pp = 1.; //adimensional
Topt = 295.5; //K
q = 20.; //K
Ab = 0.25; //adimensinal
Aw = 0.75; //adimensinal
Agf = 0.50; //adimensinal
grad_T = (-0.0065); //K*m-1, Trenberth 95, p.10
fi = 0.1;
mm = 0.35;
nn = 0.1;
Pmax = pow((1./mm),(1/nn)); //=36251 [mm/año], cuando ac=1.0
EVPmax = Pmax;
//EVPmax = 1511.; //[mm/año] corresponde a Ts=26 grados centígrados
//Pmax = EVPmax; //[mm/año]
//ac_crit = mm*Pmax^nn;
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
//experimento otro: cambiando estos parámetros
Ec=1.; //emisividad de las nubes
Es=1.; //emisividad de la superficie
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
deltat = 0.01; //[años] tamaño de paso temporal para dTsdt y dadt
t_integracion = 1; //[año] cada cuanto se guardan valores de las variables
t_modelacion = 10000; //[años] período de modelación por cada L
niter = t_integracion/deltat; //# de iteraciones en los RK4
/*
Lini = 1.992;
Lfin = 4.004;
deltaL = 0.004;
*/
Lini = 1.000;
Lfin = 1.000;
deltaL = 0.004;
niterL = (Lfin-Lini)/deltaL;
////zc_vector = [1000.,2000.,3000.,4000.,5000.,6000.,7000.,8000.]
zc_vector=VecAlloc(1);
VecSet(zc_vector,0,6000.);
nzc=1;
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
//LOOP IN HEIGHTS
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
FILE *ft=fopen("hdw-legacy.dat","w");
for(zczc=0;zczc<=nzc-1;zczc++){
zc=VecGet(zc_vector,zczc);
//Ac=1.-fi*(zc/1000.);
Ac=0.6;
resultados=MatAlloc(niterL+1,19);
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
//LOOP IN SOLAR FORCING
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
for(ii=0;ii<=niterL;ii++){
L = deltaL*ii+Lini;
printf("%d de %d, L = %.4lf\n",ii,niterL,L);
//valores iniciales
aclouds = 0.01 ;//adimensional, 0 para reproducir modelo original, 0.01 para iniciar con area de nubes
awhite = 0.01 ;//adimensional
ablack = 0.01 ;//adimensional
Ts=295.5 ;//temperatura en la superficie, valor inicial para rk4
d = t_modelacion ;//numero de años en el eje de las abscisas - iteraciones de t - dimension de los vectores de resultados
//printf("Tam:%d\n",(int)(d+1)/2);
time=VecAlloc((d+1)/2);
temperature=VecAlloc((d+1)/2);
white_temperature=VecAlloc((d+1)/2);
black_temperature=VecAlloc((d+1)/2);
white_area=VecAlloc((d+1)/2);
black_area=VecAlloc((d+1)/2);
clouds_area=VecAlloc((d+1)/2);
evap=VecAlloc((d+1)/2);
prec=VecAlloc((d+1)/2);
it=0;
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
//LOOP IN MODELLING TIME
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
for(t=0;t<=t_modelacion;t+=t_integracion){
//if(it>5000){
if(it>-1){
fprintf(ft,"%e %e %e %e %e\n",
t,Ts,aclouds,awhite,ablack);
}
xx = pp - awhite - ablack;
As = xx*Agf + ablack*Ab + awhite*Aw;
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
//TIME INTEGRATION
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
for(j=1;j<=niter;j++){
//%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
//TEMPERATURE
//%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
k1=(1/cp)*(S*L*((1-Ac)*aclouds+(1-aclouds))*(1-As)+sigma*Ec*aclouds*gsl_pow_int((Ts+grad_T*zc),4)-sigma*Es*gsl_pow_int(Ts,4));
k2=(1/cp)*(S*L*((1-Ac)*aclouds+(1-aclouds))*(1-As)+sigma*Ec*aclouds*gsl_pow_int(((Ts+k1/2)+grad_T*zc),4)-sigma*Es*gsl_pow_int((Ts+k1/2),4));
k3=(1/cp)*(S*L*((1-Ac)*aclouds+(1-aclouds))*(1-As)+sigma*Ec*aclouds*gsl_pow_int(((Ts+k2/2)+grad_T*zc),4)-sigma*Es*gsl_pow_int((Ts+k2/2),4));
k4=(1/cp)*(S*L*((1-Ac)*aclouds+(1-aclouds))*(1-As)+sigma*Ec*aclouds*gsl_pow_int(((Ts+k3)+grad_T*zc),4)-sigma*Es*gsl_pow_int((Ts+k3),4));
Ts = Ts+deltat*(k1/6+k2/3+k3/3+k4/6);
//CLOUD TEMPERATURE
Tc=Ts+zc*grad_T;
Tlb=q*(As-Ab)+Ts;
Tlw=q*(As-Aw)+Ts;
//EVAPORATION
if(Ts>277){
Tanual = Ts - 273. ;//(°C)
I = 12.*pow((Tanual/5.),1.5);
a = (6.7e-7)*gsl_pow_int(I,3) - (7.7e-5)*PowInt(I,2) + (1.8e-2)*I + 0.49;
EVP = 12.*16*pow((10.*(Ts - 273.)/I),a);
E = Min(1.,EVP/EVPmax);
}else{
E = 0.;
}
//PRECIPITATION
P = (1./Pmax)*pow((aclouds/mm),(1./nn));
//%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
//CLOUD COVERING
//%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
k1c=(1-aclouds)*E-aclouds*P;
k2c=(1-(aclouds+k1c/2))*E-(aclouds+k1c/2)*P;
k3c=(1-(aclouds+k2c/2))*E-(aclouds+k2c/2)*P;
k4c=(1-(aclouds+k3c))*E-(aclouds+k3c)*P;
aclouds=aclouds+deltat*(k1c/6+k2c/3+k3c/3+k4c/6);
//REPRODUCTIVE FITNESS
//WHITE DAISIES
if((Tlw>278)&&(Tlw<313))
Bw=1-0.003265*PowInt((Topt-Tlw),2);
else Bw=0;
//BLACK DAISIES
if((Tlb>278)&&(Tlb<313))
Bb=1-0.003265*PowInt((Topt-Tlb),2);
else Bb=0;
//%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
//WHITE AREA
//%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
k1w=awhite*(xx*Bw-gamma);
k2w=(awhite+k1w/2)*(xx*Bw-gamma);
k3w=(awhite+k2w/2)*(xx*Bw-gamma);
k4w=(awhite+k3w)*(xx*Bw-gamma);
awhite=awhite+deltat*(k1w/6+k2w/3+k3w/3+k4w/6);
//%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
//BLACK AREA
//%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
k1b=ablack*(xx*Bb-gamma);
k2b=(ablack+k1b/2)*(xx*Bb-gamma);
k3b=(ablack+k2b/2)*(xx*Bb-gamma);
k4b=(ablack+k3b)*(xx*Bb-gamma);
ablack=ablack+deltat*(k1b/6+k2b/3+k3b/3+k4b/6);
xx = pp - awhite - ablack;
As = xx*Agf + ablack*Ab + awhite*Aw;
}//end for time integration
if(it>5000){
VecSet(time,it-5001,t);
VecSet(temperature,it-5001,Ts-273);
VecSet(white_temperature,it-5001,Tlw-273);
VecSet(black_temperature,it-5001,Tlb-273);
VecSet(white_area,it-5001,awhite);
VecSet(black_area,it-5001,ablack);
VecSet(clouds_area,it-5001,aclouds);
VecSet(evap,it-5001,E*(1-aclouds));
VecSet(prec,it-5001,P*aclouds);
}
it++;
}//end for modelling time t
if(VERBOSE){
fprintf(stdout,"Valor %s = %.6e\n",VARS[0],L);
fprintf(stdout,"Valor %s = %.6e\n",VARS[1],VecMin(temperature)) ;//Ts
fprintf(stdout,"Valor %s = %.6e\n",VARS[2],VecMean(temperature)) ;//Ts
fprintf(stdout,"Valor %s = %.6e\n",VARS[3],VecMax(temperature)) ;//Ts
fprintf(stdout,"Valor %s = %.6e\n",VARS[4],VecMin(white_area)) ;//aw
fprintf(stdout,"Valor %s = %.6e\n",VARS[5],VecMean(white_area)) ;//aw
fprintf(stdout,"Valor %s = %.6e\n",VARS[6],VecMax(white_area)) ;//aw
fprintf(stdout,"Valor %s = %.6e\n",VARS[7],VecMin(black_area)) ;//ab
fprintf(stdout,"Valor %s = %.6e\n",VARS[8],VecMean(black_area)) ;//ab
fprintf(stdout,"Valor %s = %.6e\n",VARS[9],VecMax(black_area)) ;//ab
fprintf(stdout,"Valor %s = %.6e\n",VARS[10],VecMin(clouds_area)) ;//ac
fprintf(stdout,"Valor %s = %.6e\n",VARS[11],VecMean(clouds_area)) ;//ac
fprintf(stdout,"Valor %s = %.6e\n",VARS[12],VecMax(clouds_area)) ;//ac
fprintf(stdout,"Valor %s = %.6e\n",VARS[13],VecMin(evap)) ;//E
fprintf(stdout,"Valor %s = %.6e\n",VARS[14],VecMean(evap)) ;//E
fprintf(stdout,"Valor %s = %.6e\n",VARS[15],VecMax(evap)) ;//E
fprintf(stdout,"Valor %s = %.6e\n",VARS[16],VecMin(prec)) ;//P
fprintf(stdout,"Valor %s = %.6e\n",VARS[17],VecMean(prec)) ;//P
fprintf(stdout,"Valor %s = %.6e\n",VARS[18],VecMax(prec)) ;//P
}
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
//RESULTADOS
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
MatSet(resultados,ii,0,L);
MatSet(resultados,ii,1,VecMin(temperature)) ;//Ts
MatSet(resultados,ii,2,VecMean(temperature)) ;//Ts
MatSet(resultados,ii,3,VecMax(temperature)) ;//Ts
MatSet(resultados,ii,4,VecMin(white_area)) ;//aw
MatSet(resultados,ii,5,VecMean(white_area)) ;//aw
MatSet(resultados,ii,6,VecMax(white_area)) ;//aw
MatSet(resultados,ii,7,VecMin(black_area)) ;//ab
MatSet(resultados,ii,8,VecMean(black_area)) ;//ab
MatSet(resultados,ii,9,VecMax(black_area)) ;//ab
MatSet(resultados,ii,10,VecMin(clouds_area)) ;//ac
MatSet(resultados,ii,11,VecMean(clouds_area)) ;//ac
MatSet(resultados,ii,12,VecMax(clouds_area)) ;//ac
MatSet(resultados,ii,13,VecMin(evap)) ;//E
MatSet(resultados,ii,14,VecMean(evap)) ;//E
MatSet(resultados,ii,15,VecMax(evap)) ;//E
MatSet(resultados,ii,16,VecMin(prec)) ;//P
MatSet(resultados,ii,17,VecMean(prec)) ;//P
MatSet(resultados,ii,18,VecMax(prec)) ;//P
VecFree(time);
VecFree(temperature);
VecFree(white_temperature);
VecFree(black_temperature);
VecFree(white_area);
VecFree(black_area);
VecFree(clouds_area);
VecFree(evap);
VecFree(prec);
}//end for ii
sprintf(fname,"DAWHYC2_EXP2_L0416_%.2f_%d_activa.txt",Ac,(int)zc/1000);
fl=fopen(fname,"w");
fprintf(fl,"zc= %.0lf\n",zc);
fprintf(fl,"Ac= %.2lf\n",Ac);
for(j=0;j<NVARS;j++)
fprintf(fl,"%10s ",VARS[j]);
MatrixFprintf(fl,resultados,"%10.4f ");
fclose(fl);
MatFree(resultados);
}//end for heights
fclose(ft);
}//end program
/* Initializes MPI,
* loads defaults,
* command line arguments,
* hdf5 data,
* ode model from shared library @code dlopen@
* allocates kernel,
* ode model parameters
* MPI communivcation buffers
* calls MCMC routines
* finalizes and frees (most) structs
*/
int/*always returns success*/
main(int argc,/*count*/ char* argv[])/*array of strings*/ {
int i=0;
int warm_up=0; // sets the number of burn in points at command line
char lib_name[BUFSZ];
ode_model_parameters omp[1];
omp->size=(problem_size*) malloc(sizeof(problem_size));
char global_sample_filename_stem[BUFSZ]="Sample.h5"; // filename basis
char rank_sample_file[BUFSZ]; // filename for sample output
char resume_filename[BUFSZ]="resume.h5";
double seed = 1;
double gamma= 2;
double t0=-1;
int sampling_action=SMPL_FRESH;
int start_from_prior=no;
int sensitivity_approximation=no;
main_options cnf_options=get_default_options(global_sample_filename_stem, lib_name);
MPI_Init(&argc,&argv);
int rank,R;
MPI_Comm_size(MPI_COMM_WORLD,&R);
MPI_Comm_rank(MPI_COMM_WORLD,&rank);
char *h5file=NULL;
gsl_set_error_handler_off();
/* process command line arguments
*/
for (i=0;i<argc;i++){
if (strcmp(argv[i],"-p")==0 || strcmp(argv[i],"--prior-start")==0) {
start_from_prior=1;
} else if (strcmp(argv[i],"-d")==0 || strcmp(argv[i],"--hdf5")==0) {
h5file=argv[i+1];
} else if (strcmp(argv[i],"-t")==0 || strcmp(argv[i],"--init-at-t")==0) {
t0=strtod(argv[i+1],NULL);
//printf("[main] t0=%f\n",t0);
} else if (strcmp(argv[i],"-w")==0 || strcmp(argv[i],"--warm-up")==0) warm_up=strtol(argv[i+1],NULL,10);
else if (strcmp(argv[i],"--resume")==0 || strcmp(argv[i],"-r")==0) sampling_action=SMPL_RESUME;
else if (strcmp(argv[i],"--sens-approx")==0) sensitivity_approximation=1;
else if (strcmp(argv[i],"-l")==0) strcpy(cnf_options.library_file,argv[i+1]);
// else if (strcmp(argv[i],"-n")==0) Tuning=0;
else if (strcmp(argv[i],"-s")==0) cnf_options.sample_size=strtol(argv[i+1],NULL,0);
else if (strcmp(argv[i],"-o")==0) strncpy(cnf_options.output_file,argv[i+1],BUFSZ);
else if (strcmp(argv[i],"-a")==0) cnf_options.target_acceptance=strtod(argv[i+1],NULL);
else if (strcmp(argv[i],"-i")==0 || strcmp(argv[i],"--initial-step-size")==0) cnf_options.initial_stepsize=strtod(argv[i+1],NULL);
else if (strcmp(argv[i],"-m")==0 || strcmp(argv[i],"--initial-step-size-rank-multiplier")==0) cnf_options.initial_stepsize_rank_factor=strtod(argv[i+1],NULL);
else if (strcmp(argv[i],"-g")==0) gamma=strtod(argv[i+1],NULL);
else if (strcmp(argv[i],"--abs-tol")==0) cnf_options.abs_tol=strtod(argv[i+1],NULL);
else if (strcmp(argv[i],"--rel-tol")==0) cnf_options.rel_tol=strtod(argv[i+1],NULL);
else if (strcmp(argv[i],"--seed")==0) seed=strtod(argv[i+1],NULL);
else if (strcmp(argv[i],"-h")==0 || strcmp(argv[i],"--help")==0) {
print_help();
MPI_Abort(MPI_COMM_WORLD,0);
}
}
seed=seed*137+13*rank;
/* load Data from hdf5 file
*/
if (h5file){
printf("# [main] (rank %i) reading hdf5 file, loading data.\n",rank);
fflush(stdout);
read_data(h5file,omp);
fflush(stdout);
} else {
fprintf(stderr,"# [main] (rank %i) no data provided (-d option), exiting.\n",rank);
MPI_Abort(MPI_COMM_WORLD,-1);
}
/* load model from shared library
*/
ode_model *odeModel = ode_model_loadFromFile(lib_name); /* alloc */
if (!odeModel) {
fprintf(stderr, "# [main] (rank %i) Library %s could not be loaded.\n",rank,lib_name);
exit(1);
} else printf( "# [main] (rank %i) Library %s loaded.\n",rank, lib_name);
/* construct an output file from rank, library name, and user
* supplied string.
*/
char *dot;
char *lib_base;
lib_base=basename(lib_name);
dot=strchr(lib_base,'.');
dot[0]='\0';
sprintf(resume_filename,"%s_resume_%02i.h5",lib_base,rank);
sprintf(rank_sample_file,"mcmc_rank_%02i_of_%i_%s_%s",rank,R,lib_base,basename(cnf_options.output_file));
cnf_options.output_file=rank_sample_file;
cnf_options.resume_file=resume_filename;
/* allocate a solver for each experiment for possible parallelization
*/
ode_solver **solver;
int c,C=omp->size->C;
int c_success=0;
solver=malloc(sizeof(ode_solver*)*C);
for (c=0;c<C;c++){
solver[c]=ode_solver_alloc(odeModel);
if (solver[c]) c_success++;
}
if (c_success==C) {
printf("# [main] Solver[0:%i] for «%s» created.\n",C,lib_base);
} else {
fprintf(stderr, "# [main] Solvers for «%s» could not be created.\n",lib_base);
ode_model_free(odeModel);
MPI_Abort(MPI_COMM_WORLD,-1);
}
/* sensitivity analysis is not feasible for large models. So, it can
* be turned off.
*/
if (sensitivity_approximation){
//printf("# [main] experimental: Sensitivity approximation activated.\n");
for (c=0;c<C;c++) ode_solver_disable_sens(solver[c]);
/* also: make sensitivity function unavailable; that way
* ode_model_has_sens(model) will return «FALSE»;
*/
odeModel->vf_sens=NULL;
}
/* init solver
*/
realtype solver_param[3] = {cnf_options.abs_tol, cnf_options.rel_tol, 0};
const char **x_name=ode_model_get_var_names(odeModel);
const char **p_name=ode_model_get_param_names(odeModel);
const char **f_name=ode_model_get_func_names(odeModel);
/* local variables for parameters and inital conditions as presented
in ode model lib: */
int N = ode_model_getN(odeModel);
int P = ode_model_getP(odeModel);
int F = ode_model_getF(odeModel);
/* save in ode model parameter struct: */
set_number_of_state_variables(omp,N);
set_number_of_model_parameters(omp,P);
set_number_of_model_outputs(omp,F);
omp->t0=t0;
/* ode model parameter struct has pointers for sim results that need
memory allocation: */
ode_model_parameters_alloc(omp);
ode_model_parameters_link(omp);
fflush(stdout);
/* get default parameters from the model file
*/
double p[P];
gsl_vector_view p_view=gsl_vector_view_array(p,P);
ode_model_get_default_params(odeModel, p, P);
if (rank==0) gsl_printf("default parameters",&(p_view.vector),GSL_IS_DOUBLE | GSL_IS_VECTOR);
omp->solver=solver;
/* All MCMC meta-parameters (like stepsize) here are positive (to
* make sense). Some command line arguments can override parameters
* read from files; but, input files are processed after the command
* line parameters. So, to check whether default parameters were
* altered by the command line, the variable declaration defaults
* are negative at first. Alterations to some meta-parameter p can
* be checked by: if (cnf_options.p<0)
* cnf_options.p=read_from_file(SOME FILE);
*/
cnf_options.initial_stepsize=fabs(cnf_options.initial_stepsize);
cnf_options.target_acceptance=fabs(cnf_options.target_acceptance);
cnf_options.sample_size=fabs(cnf_options.sample_size);
/* load default initial conditions
*/
double y[N];
gsl_vector_view y_view=gsl_vector_view_array(y,N);
ode_model_get_initial_conditions(odeModel, y, N);
print_experiment_information(rank,R,omp,&(y_view.vector));
/* initialize the ODE solver with initial time t, default ODE
* parameters p and default initial conditions of the state y; In
* addition error tolerances are set and sensitivity initialized.
*/
//printf("# [main] (rank %i) init ivp: t0=%g\n",rank,omp->t0);
for (c=0;c<C;c++){
ode_solver_init(solver[c], omp->t0, omp->E[c]->init_y->data, N, p, P);
//printf("# [main] solver initialised.\n");
ode_solver_setErrTol(solver[c], solver_param[1], &solver_param[0], 1);
if (ode_model_has_sens(odeModel)) {
ode_solver_init_sens(solver[c], omp->E[0]->yS0->data, P, N);
}
}
/* An smmala_model is a struct that contains the posterior
* probablity density function and a pointer to its parameters and
* pre-allocated work-memory.
*/
smmala_model* model = smmala_model_alloc(LogPosterior, NULL, omp);
if (model){
printf("[main] (rank %i) smmala_model allocated.\n",rank);
}else{
fprintf(stderr,"[main] (rank %i) smmala_model could not be allocated.\n",rank);
MPI_Abort(MPI_COMM_WORLD,-1);
}
/* initial parameter values; after allocating an mcmc_kernel of the
* right dimensions we set the initial Markov chain state from
* either the model's default parametrization p, the prior's μ, or the
* state of a previously completed mcmc run (resume).
*/
int D=omp->size->D;
double init_x[D];
double beta=assign_beta(rank,R,round(gamma));
double tgac=cnf_options.target_acceptance;
double m=cnf_options.initial_stepsize_rank_factor;
double step=cnf_options.initial_stepsize;
if (m>1.0 && rank>0) step*=gsl_pow_int(m,rank);
pdf_normalisation_constant(omp);
printf("[main] (rank %i) likelihood log(normalisation constant): %g\n",rank,omp->pdf_lognorm);
mcmc_kernel* kernel = smmala_kernel_alloc(beta,D,step,model,seed,tgac);
int resume_load_status;
if (sampling_action==SMPL_RESUME){
resume_load_status=load_resume_state(resume_filename, rank, R, kernel);
assert(resume_load_status==EXIT_SUCCESS);
for (i=0;i<D;i++) init_x[i]=kernel->x[i];
} else if (start_from_prior){
if (rank==0) printf("# [main] setting initial mcmc vector to prior mean.\n");
for (i=0;i<D;i++) init_x[i]=gsl_vector_get(omp->prior->mu,i);
} else {
if (rank==0) printf("# [main] setting mcmc initial value to log(default parameters)\n");
for (i=0;i<D;i++) init_x[i]=gsl_sf_log(p[i]);
}
fflush(stdout);
//display_prior_information(omp->prior);
/* here we initialize the mcmc_kernel; this makes one test
* evaluation of the log-posterior density function.
*/
/*
if (rank==0){
printf("# [main] initializing MCMC.\n");
printf("# [main] init_x:");
for (i=0;i<D;i++) printf(" %g ",init_x[i]);
printf("\n");
}
*/
mcmc_init(kernel, init_x);
/* display the results of that test evaluation
*
*/
if (rank==0){
printf("# [main] rank %i init complete .\n",rank);
display_test_evaluation_results(kernel);
ode_solver_print_stats(solver[0], stdout);
fflush(stdout);
fflush(stderr);
}
size_t SampleSize = cnf_options.sample_size;
/* in parallel tempering th echains can swap their positions;
* this buffers the communication between chains.
*/
void *buffer=(void *) smmala_comm_buffer_alloc(D);
/* Initialization of burin in length
*/
size_t BurnInSampleSize;
if (warm_up==0){
BurnInSampleSize = 7 * (int) sqrt(cnf_options.sample_size);
} else {
BurnInSampleSize=warm_up;
}
if (rank==0){
printf("# Performing Burn-In with step-size (%g) tuning: %lu iterations\n",get_step_size(kernel),BurnInSampleSize);
fflush(stdout);
}
/* Burn In: these iterations are not recorded, but are used to find
* an acceptable step size for each temperature regime.
*/
int mcmc_error;
mcmc_error=burn_in_foreach(rank,R, BurnInSampleSize, omp, kernel, buffer);
assert(mcmc_error==EXIT_SUCCESS);
if (rank==0){
fprintf(stdout, "\n# Burn-in complete, sampling from the posterior.\n");
}
/* this struct contains all necessary id's and size arrays
* for writing sample data to an hdf5 file in chunks
*/
hdf5block_t *h5block = h5block_init(cnf_options.output_file,
omp,SampleSize,
x_name,p_name,f_name);
/* The main loop of MCMC sampling
* these iterations are recorded and saved to an hdf5 file
* the file is set up and identified via the h5block variable.
*/
mcmc_error=mcmc_foreach(rank, R, SampleSize, omp, kernel, h5block, buffer, &cnf_options);
assert(mcmc_error==EXIT_SUCCESS);
append_meta_properties(h5block,&seed,&BurnInSampleSize, h5file, lib_base);
h5block_close(h5block);
/* clear memory */
smmala_model_free(model);
mcmc_free(kernel);
ode_model_parameters_free(omp);
MPI_Finalize();
return EXIT_SUCCESS;
}
/* f_monomial = constant * x^degree */
double f_monomial(double x, void * params)
{
struct monomial_params * p = (struct monomial_params *) params;
return p->constant * gsl_pow_int(x, p->degree);
}
/* See Remark 2.17 */
double pkd_eval_square( int j, int k, point p) {
double leg = gsl_sf_legendre_Pl( j, p.x);
double pwr = gsl_pow_int( (1.0-p.y)/2.0, j);
double jac = jacobi( k, 2.0*j+1.0, p.y);
return leg*pwr*jac;
}
//============================================
void preconditionSPDE(config* currentConfig, config* newConfig, double du, double dt, double doubleNUMu, double bb[NUMBEAD], double GaussRandArray[NUMu], gsl_rng *RanNumPointer)
//generates a preconditioned step using the Stochastic Partial Differential Equation
//currentConfig is the incoming configuration that has LinvG and GradG calculated
//newConfig is a temp array that is used to make all of the calsulations without touching currentConfig.pos[*][*]
//newConfig.pos is saved to currentConfig.pos before exiting the function
{
double qvvel = 0.0l;
double qvpos = 0.0l;
int i,n;
double h=sqrt(2.0l * dt);
double co=(4.0l-h*h)/(4.0l+h*h);
double si=(4.0l*h)/(4.0l+h*h); //(h/2)*si
double hOverTwoSi=(2.0l*h*h)/(4.0l+h*h); //(h/2)*si
//for grahm shmidt
double alpha, alphaNum, alphaDenom;
for(i=0;i<NUMDIM;i++)
{
generateBB(bb, du, dt, GaussRandArray, RanNumPointer);
//need to make the bb orthogonal to pos without the linear term
//store pos w/o linear term in newconfig.pos temporarily
#pragma omp parallel for
for(n=0;n<NUMBEAD;n++){
newConfig[n].pos[i]=currentConfig[n].pos[i]-currentConfig[0].pos[i]-(((double)(n))*(currentConfig[NUMBEAD-1].pos[i]-currentConfig[0].pos[i]))/((double)(NUMBEAD -1));
}
//Gram Schmidt orthogonalization
alphaNum = 0.0l;
alphaDenom = 0.0l;
#pragma omp parallel for reduction(+:alphaNum,alphaDenom)
for(n=1;n<NUMBEAD;n++)
{
alphaNum+=(bb[n]-bb[n-1])*(newConfig[n].pos[i]-newConfig[n-1].pos[i]);
alphaDenom+=(newConfig[n].pos[i]-newConfig[n-1].pos[i])*(newConfig[n].pos[i]-newConfig[n-1].pos[i]);
}
alpha=alphaNum/alphaDenom;
#pragma omp parallel for
for(n=0;n<NUMBEAD;n++){ bb[n]=bb[n]-alpha*newConfig[n].pos[i];}
renormBB(bb, du, doubleNUMu);
#pragma omp parallel for
for(n=0;n<NUMBEAD;n++){
newConfig[n].pos[i]=hOverTwoSi*currentConfig[n].LinvG[i] + si*bb[n] + co*currentConfig[n].pos[i];
}
//calculate the quadratic variation
#pragma omp parallel for reduction(+:qvpos,qvvel)
for(n=1;n<NUMBEAD;n++){
qvpos+=gsl_pow_int((newConfig[n].pos[i]-newConfig[n-1].pos[i]),2);
qvvel+=gsl_pow_int((bb[n]-bb[n-1]),2);
}
}
//print the quadratic variation
qvvel *= 0.5/(2.0l*du*((double)(NUMBEAD-1)));
qvpos *= 0.5/(2.0l*du*((double)(NUMBEAD-1)));
printf("qvvel=%0.10f qvpos=%0.10f \n",qvvel,qvpos);
}