/**
* Tests a single evaluator function from the high-level interface.
*
* See test_interp2d in this file for usage examples.
*/
static inline int test_single_high_level(
double (*evaluator)(const interp2d_spline*, const double, const double, gsl_interp_accel*, gsl_interp_accel*),
int (*evaluator_e)(const interp2d_spline*, const double, const double, gsl_interp_accel*, gsl_interp_accel*, double*),
const interp2d_spline* interp, const double x, const double y, gsl_interp_accel* xa, gsl_interp_accel* ya, const double expected_results[], size_t i
) {
if (expected_results != NULL) {
int failures = 0;
int status;
double result = evaluator(interp, x, y, xa, ya);
gsl_test_abs(result, expected_results[i], 1e-10, "high level %s %d", interp2d_spline_name(interp), i);
if (fabs(result - expected_results[i]) > 1e-10) {
// test failed
failures++;
}
status = evaluator_e(interp, x, y, xa, ya, &result);
if (status != GSL_SUCCESS) {
// something went wrong
failures++;
}
else {
gsl_test_abs(result, expected_results[i], 1e-10, "high level POSIX %s %d", interp2d_spline_name(interp), i);
if (fabs(result - expected_results[i]) > 1e-10) {
// test failed - wrong result
failures++;
}
}
}
else {
return 0;
}
}
/* test if A Z = Q S */
void
test_eigen_schur(const gsl_matrix * A, const gsl_matrix * S,
const gsl_matrix * Q, const gsl_matrix * Z,
size_t count, const char * desc,
const char * desc2)
{
const size_t N = A->size1;
size_t i, j;
gsl_matrix * T1 = gsl_matrix_alloc(N, N);
gsl_matrix * T2 = gsl_matrix_alloc(N, N);
/* compute T1 = A Z */
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, A, Z, 0.0, T1);
/* compute T2 = Q S */
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, Q, S, 0.0, T2);
for (i = 0; i < N; ++i)
{
for (j = 0; j < N; ++j)
{
double x = gsl_matrix_get(T1, i, j);
double y = gsl_matrix_get(T2, i, j);
gsl_test_abs(x, y, 1.0e8 * GSL_DBL_EPSILON,
"%s(N=%u,cnt=%u), %s, schur(%d,%d)", desc, N, count, desc2, i, j);
}
}
gsl_matrix_free (T1);
gsl_matrix_free (T2);
} /* test_eigen_schur() */
/* test if A is orthogonal */
int
test_eigen_orthog(gsl_matrix *A, size_t count, const char *desc,
const char *desc2)
{
size_t N = A->size1;
gsl_matrix *M = gsl_matrix_alloc(A->size1, A->size2);
size_t i, j;
gsl_blas_dgemm(CblasNoTrans, CblasTrans, 1.0, A, A, 0.0, M);
for (i = 0; i < A->size1; ++i)
{
for (j = 0; j < A->size2; ++j)
{
double val;
double mij = gsl_matrix_get(M, i, j);
if (i == j)
val = 1.0;
else
val = 0.0;
gsl_test_abs(mij, val, 1.0e8 * GSL_DBL_EPSILON,
"%s(N=%u,cnt=%u), %s, orthog(%d,%d)", desc, N, count, desc2, i, j);
}
}
gsl_matrix_free(M);
return 1;
} /* test_eigen_orthog() */
void
test_eigenvalues_real (const gsl_vector *eval, const gsl_vector * eval2,
const char * desc, const char * desc2)
{
const size_t N = eval->size;
size_t i;
double emax = 0;
/* check eigenvalues */
for (i = 0; i < N; i++)
{
double ei = gsl_vector_get (eval, i);
if (fabs(ei) > emax) emax = fabs(ei);
}
for (i = 0; i < N; i++)
{
double ei = gsl_vector_get (eval, i);
double e2i = gsl_vector_get (eval2, i);
e2i = chop_subnormals(e2i);
gsl_test_abs(ei, e2i, emax * 1e8 * GSL_DBL_EPSILON,
"%s, direct eigenvalue(%d), %s",
desc, i, desc2);
}
}
void
test_bspline(gsl_bspline_workspace * bw, gsl_bspline_deriv_workspace * dbw)
{
gsl_vector *B;
gsl_matrix *dB;
size_t i, j;
size_t n = 100;
size_t ncoeffs = gsl_bspline_ncoeffs(bw);
size_t order = gsl_bspline_order(bw);
size_t nbreak = gsl_bspline_nbreak(bw);
double a = gsl_bspline_breakpoint(0, bw);
double b = gsl_bspline_breakpoint(nbreak - 1, bw);
B = gsl_vector_alloc(ncoeffs);
dB = gsl_matrix_alloc(ncoeffs, 1);
/* Ensure B-splines form a partition of unity */
for (i = 0; i < n; i++)
{
double xi = a + (b - a) * (i / (n - 1.0));
double sum = 0;
gsl_bspline_eval(xi, B, bw);
for (j = 0; j < ncoeffs; j++)
{
double Bj = gsl_vector_get(B, j);
int s = (Bj < 0 || Bj > 1);
gsl_test(s,
"basis-spline coefficient %u is in range [0,1] for x=%g",
j, xi);
sum += Bj;
}
gsl_test_rel(sum, 1.0, order * GSL_DBL_EPSILON,
"basis-spline order %u is normalized for x=%g", order,
xi);
}
/* Ensure B-splines 0th derivatives agree with regular evaluation */
for (i = 0; i < n; i++)
{
double xi = a + (b - a) * (i / (n - 1.0));
gsl_bspline_eval(xi, B, bw);
gsl_bspline_deriv_eval(xi, 0, dB, bw, dbw);
for (j = 0; j < ncoeffs; j++)
{
gsl_test_abs(gsl_matrix_get(dB, j, 0), gsl_vector_get(B, j),
GSL_DBL_EPSILON,
"b-spline order %d basis #%d evaluation and 0th derivative consistent for x=%g",
order, j, xi);
}
}
gsl_vector_free(B);
gsl_matrix_free(dB);
}
void
test (diff_fn * diff, gsl_function * f, gsl_function * df, double x,
const char * desc)
{
double result, abserr;
double expected = GSL_FN_EVAL (df, x);
(*diff) (f, x, &result, &abserr);
gsl_test_abs (result, expected, abserr, desc);
gsl_test (fabs(result-expected) > abserr, "%s, valid error estimate", desc);
}
void
test_eigen_genherm_results (const gsl_matrix_complex * A,
const gsl_matrix_complex * B,
const gsl_vector * eval,
const gsl_matrix_complex * evec,
size_t count,
const char * desc,
const char * desc2)
{
const size_t N = A->size1;
size_t i, j;
gsl_vector_complex * x = gsl_vector_complex_alloc(N);
gsl_vector_complex * y = gsl_vector_complex_alloc(N);
/* check A v = lambda B v */
for (i = 0; i < N; i++)
{
double ei = gsl_vector_get (eval, i);
gsl_vector_complex_const_view vi =
gsl_matrix_complex_const_column(evec, i);
double norm = gsl_blas_dznrm2(&vi.vector);
/* check that eigenvector is normalized */
gsl_test_rel(norm, 1.0, N * GSL_DBL_EPSILON,
"genherm(N=%u,cnt=%u), %s, normalized(%d), %s", N, count,
desc, i, desc2);
/* compute y = A z */
gsl_blas_zgemv (CblasNoTrans, GSL_COMPLEX_ONE, A, &vi.vector, GSL_COMPLEX_ZERO, y);
/* compute x = B z */
gsl_blas_zgemv (CblasNoTrans, GSL_COMPLEX_ONE, B, &vi.vector, GSL_COMPLEX_ZERO, x);
/* compute x = lambda B z */
gsl_blas_zdscal(ei, x);
/* now test if y = x */
for (j = 0; j < N; j++)
{
gsl_complex xj = gsl_vector_complex_get (x, j);
gsl_complex yj = gsl_vector_complex_get (y, j);
gsl_test_rel(GSL_REAL(yj), GSL_REAL(xj), 1e9 * GSL_DBL_EPSILON,
"genherm(N=%u,cnt=%u), %s, eigenvalue(%d,%d), real, %s", N, count, desc, i, j, desc2);
gsl_test_abs(GSL_IMAG(yj), GSL_IMAG(xj), 1e9 * GSL_DBL_EPSILON,
"genherm(N=%u,cnt=%u), %s, eigenvalue(%d,%d), imag, %s", N, count, desc, i, j, desc2);
}
}
gsl_vector_complex_free(x);
gsl_vector_complex_free(y);
}
void
test_dim (const size_t n, const double a, const double b,
gsl_function * F, gsl_function * DF, gsl_function *IF)
{
double tol = 100.0 * GSL_DBL_EPSILON;
double x;
gsl_cheb_series * cs = gsl_cheb_alloc(n);
gsl_cheb_series * csd = gsl_cheb_alloc(n);
gsl_cheb_series * csi = gsl_cheb_alloc(n);
gsl_cheb_init(cs, F, a, b);
for(x=a; x<b; x += (b-a)/100.0) {
double r = gsl_cheb_eval(cs, x);
gsl_test_abs(r, GSL_FN_EVAL(F, x), tol, "gsl_cheb_eval, F(%.3g)", x);
}
/* Test derivative */
gsl_cheb_calc_deriv(csd, cs);
for(x=a; x<b; x += (b-a)/100.0) {
double r = gsl_cheb_eval(csd, x);
gsl_test_abs(r, GSL_FN_EVAL(DF, x), tol, "gsl_cheb_eval, deriv F(%.3g)", x);
}
/* Test integral */
gsl_cheb_calc_integ(csi, cs);
for(x=a; x<b; x += (b-a)/100.0) {
double r = gsl_cheb_eval(csi, x);
gsl_test_abs(r, GSL_FN_EVAL(IF, x), tol, "gsl_cheb_eval, integ F(%.3g)", x);
}
gsl_cheb_free(csi);
gsl_cheb_free(csd);
gsl_cheb_free(cs);
}
void
test (deriv_fn * deriv, gsl_function * f, gsl_function * df, double x,
const char * desc)
{
double result, abserr;
double expected = GSL_FN_EVAL (df, x);
(*deriv) (f, x, 1e-4, &result, &abserr);
gsl_test_abs (result, expected, GSL_MIN(1e-4,fabs(expected)) + GSL_DBL_EPSILON, desc);
if (abserr < fabs(result-expected))
{
gsl_test_factor (abserr, fabs(result-expected), 2, "%s error estimate", desc);
}
else if (result == expected || expected == 0.0)
{
gsl_test_abs (abserr, 0.0, 1e-6, "%s abserr", desc);
}
else
{
double d = fabs(result - expected);
gsl_test_abs (abserr, fabs(result-expected), 1e6*d, "%s abserr", desc);
}
}
void
test_quantile(const double p, const double data[], const size_t n,
const double expected, const double tol, const char *desc)
{
gsl_rstat_quantile_workspace *w = gsl_rstat_quantile_alloc(p);
double result;
size_t i;
for (i = 0; i < n; ++i)
gsl_rstat_quantile_add(data[i], w);
result = gsl_rstat_quantile_get(w);
if (fabs(expected) < 1.0e-4)
gsl_test_abs(result, expected, tol, "%s p=%g", desc, p);
else
gsl_test_rel(result, expected, tol, "%s p=%g", desc, p);
gsl_rstat_quantile_free(w);
}
void
FUNCTION (test, func) (const size_t M, const size_t N)
{
TYPE (gsl_vector) * v;
size_t i, j;
size_t k = 0;
TYPE (gsl_matrix) * m = FUNCTION (gsl_matrix, alloc) (M, N);
gsl_test (m->data == 0, NAME (gsl_matrix) "_alloc returns valid pointer");
gsl_test (m->size1 != M, NAME (gsl_matrix) "_alloc returns valid size1");
gsl_test (m->size2 != N, NAME (gsl_matrix) "_alloc returns valid size2");
gsl_test (m->tda != N, NAME (gsl_matrix) "_alloc returns valid tda");
for (i = 0; i < M; i++)
{
for (j = 0; j < N; j++)
{
k++;
FUNCTION (gsl_matrix, set) (m, i, j, (BASE) k);
}
}
{
status = 0;
k = 0;
for (i = 0; i < M; i++)
{
for (j = 0; j < N; j++)
{
k++;
if (m->data[i * N + j] != (BASE) k)
status = 1;
};
};
gsl_test (status, NAME (gsl_matrix) "_set writes into array");
}
{
status = 0;
k = 0;
for (i = 0; i < M; i++)
{
for (j = 0; j < N; j++)
{
k++;
if (FUNCTION (gsl_matrix, get) (m, i, j) != (BASE) k)
status = 1;
};
};
gsl_test (status, NAME (gsl_matrix) "_get reads from array");
}
FUNCTION (gsl_matrix, free) (m); /* free whatever is in m */
m = FUNCTION (gsl_matrix, calloc) (M, N);
v = FUNCTION (gsl_vector, calloc) (N);
{
int status = (FUNCTION(gsl_matrix,isnull)(m) != 1);
TEST (status, "_isnull" DESC " on calloc matrix");
status = (FUNCTION(gsl_matrix,ispos)(m) != 0);
TEST (status, "_ispos" DESC " on calloc matrix");
status = (FUNCTION(gsl_matrix,isneg)(m) != 0);
TEST (status, "_isneg" DESC " on calloc matrix");
status = (FUNCTION(gsl_matrix,isnonneg)(m) != 1);
TEST (status, "_isnonneg" DESC " on calloc matrix");
}
k = 0;
for (i = 0; i < M; i++)
{
for (j = 0; j < N; j++)
{
k++;
FUNCTION (gsl_matrix, set) (m, i, j, (BASE) k);
}
}
{
status = 0;
k = 0;
for (i = 0; i < M; i++)
{
FUNCTION (gsl_matrix, get_row) (v, m, i);
for (j = 0; j < N; j++)
{
k++;
if (v->data[j] != (BASE) k)
status = 1;
}
}
gsl_test (status, NAME (gsl_matrix) "_get_row extracts row");
}
{
BASE exp_max = FUNCTION(gsl_matrix, get) (m, 0, 0);
BASE exp_min = FUNCTION(gsl_matrix, get) (m, 0, 0);
size_t exp_imax = 0, exp_jmax = 0, exp_imin = 0, exp_jmin = 0;
for (i = 0; i < M; i++)
{
for (j = 0; j < N; j++)
{
BASE k = FUNCTION(gsl_matrix, get) (m, i, j);
if (k > exp_max) {
exp_max = FUNCTION(gsl_matrix, get) (m, i, j);
exp_imax = i;
exp_jmax = j;
}
if (k < exp_min) {
exp_min = FUNCTION(gsl_matrix, get) (m, i, j);
exp_imin = i;
exp_jmin = j;
}
}
}
{
BASE max = FUNCTION(gsl_matrix, max) (m) ;
gsl_test (max != exp_max, NAME(gsl_matrix) "_max returns correct maximum value");
}
{
BASE min = FUNCTION(gsl_matrix, min) (m) ;
gsl_test (min != exp_min, NAME(gsl_matrix) "_min returns correct minimum value");
}
{
BASE min, max;
FUNCTION(gsl_matrix, minmax) (m, &min, &max);
gsl_test (max != exp_max, NAME(gsl_matrix) "_minmax returns correct maximum value");
gsl_test (min != exp_min, NAME(gsl_matrix) "_minmax returns correct minimum value");
}
{
size_t imax, jmax;
FUNCTION(gsl_matrix, max_index) (m, &imax, &jmax) ;
gsl_test (imax != exp_imax, NAME(gsl_matrix) "_max_index returns correct maximum i");
gsl_test (jmax != exp_jmax, NAME(gsl_matrix) "_max_index returns correct maximum j");
}
{
size_t imin, jmin;
FUNCTION(gsl_matrix, min_index) (m, &imin, &jmin) ;
gsl_test (imin != exp_imin, NAME(gsl_matrix) "_min_index returns correct minimum i");
gsl_test (jmin != exp_jmin, NAME(gsl_matrix) "_min_index returns correct minimum j");
}
{
size_t imin, jmin, imax, jmax;
FUNCTION(gsl_matrix, minmax_index) (m, &imin, &jmin, &imax, &jmax);
gsl_test (imax != exp_imax, NAME(gsl_matrix) "_minmax_index returns correct maximum i");
gsl_test (jmax != exp_jmax, NAME(gsl_matrix) "_minmax_index returns correct maximum j");
gsl_test (imin != exp_imin, NAME(gsl_matrix) "_minmax_index returns correct minimum i");
gsl_test (jmin != exp_jmin, NAME(gsl_matrix) "_minmax_index returns correct minimum j");
}
#if FP
FUNCTION(gsl_matrix,set)(m, 2, 3, GSL_NAN);
exp_min = GSL_NAN; exp_max = GSL_NAN;
exp_imin = 2; exp_jmin = 3;
exp_imax = 2; exp_jmax = 3;
{
BASE max = FUNCTION(gsl_matrix, max) (m) ;
gsl_test_abs (max,exp_max, 0, NAME(gsl_matrix) "_max returns correct maximum value for NaN");
}
{
BASE min = FUNCTION(gsl_matrix, min) (m) ;
gsl_test_abs (min, exp_min, 0, NAME(gsl_matrix) "_min returns correct minimum value for NaN");
}
{
BASE min, max;
FUNCTION(gsl_matrix, minmax) (m, &min, &max);
gsl_test_abs (max, exp_max, 0, NAME(gsl_matrix) "_minmax returns correct maximum value for NaN");
gsl_test_abs (min, exp_min, 0, NAME(gsl_matrix) "_minmax returns correct minimum value for NaN");
}
{
size_t imax, jmax;
FUNCTION(gsl_matrix, max_index) (m, &imax, &jmax) ;
gsl_test (imax != exp_imax, NAME(gsl_matrix) "_max_index returns correct maximum i for NaN");
gsl_test (jmax != exp_jmax, NAME(gsl_matrix) "_max_index returns correct maximum j for NaN");
}
{
size_t imin, jmin;
FUNCTION(gsl_matrix, min_index) (m, &imin, &jmin) ;
gsl_test (imin != exp_imin, NAME(gsl_matrix) "_min_index returns correct minimum i for NaN");
gsl_test (jmin != exp_jmin, NAME(gsl_matrix) "_min_index returns correct minimum j for NaN");
}
{
size_t imin, jmin, imax, jmax;
FUNCTION(gsl_matrix, minmax_index) (m, &imin, &jmin, &imax, &jmax);
gsl_test (imax != exp_imax, NAME(gsl_matrix) "_minmax_index returns correct maximum i for NaN");
gsl_test (jmax != exp_jmax, NAME(gsl_matrix) "_minmax_index returns correct maximum j for NaN");
gsl_test (imin != exp_imin, NAME(gsl_matrix) "_minmax_index returns correct minimum i for NaN");
gsl_test (jmin != exp_jmin, NAME(gsl_matrix) "_minmax_index returns correct minimum j for NaN");
}
#endif
}
for (i = 0; i < M; i++)
{
for (j = 0; j < N; j++)
{
FUNCTION (gsl_matrix, set) (m, i, j, (ATOMIC) 0);
}
}
{
status = (FUNCTION(gsl_matrix,isnull)(m) != 1);
TEST (status, "_isnull" DESC " on null matrix") ;
status = (FUNCTION(gsl_matrix,ispos)(m) != 0);
TEST (status, "_ispos" DESC " on null matrix") ;
status = (FUNCTION(gsl_matrix,isneg)(m) != 0);
TEST (status, "_isneg" DESC " on null matrix") ;
status = (FUNCTION(gsl_matrix,isnonneg)(m) != 1);
TEST (status, "_isnonneg" DESC " on null matrix") ;
}
k = 0;
for (i = 0; i < M; i++)
{
for (j = 0; j < N; j++)
{
k++;
FUNCTION (gsl_matrix, set) (m, i, j, (ATOMIC) (k % 10));
}
}
{
status = (FUNCTION(gsl_matrix,isnull)(m) != 0);
TEST (status, "_isnull" DESC " on non-negative matrix") ;
status = (FUNCTION(gsl_matrix,ispos)(m) != 0);
TEST (status, "_ispos" DESC " on non-negative matrix") ;
status = (FUNCTION(gsl_matrix,isneg)(m) != 0);
TEST (status, "_isneg" DESC " on non-negative matrix") ;
status = (FUNCTION(gsl_matrix,isnonneg)(m) != 1);
TEST (status, "_isnonneg" DESC " on non-negative matrix") ;
}
#ifndef UNSIGNED
k = 0;
for (i = 0; i < M; i++)
{
for (j = 0; j < N; j++)
{
ATOMIC mij = ((++k) % 10) - (ATOMIC) 5;
FUNCTION (gsl_matrix, set) (m, i, j, mij);
}
}
{
status = (FUNCTION(gsl_matrix,isnull)(m) != 0);
TEST (status, "_isnull" DESC " on mixed matrix") ;
status = (FUNCTION(gsl_matrix,ispos)(m) != 0);
TEST (status, "_ispos" DESC " on mixed matrix") ;
status = (FUNCTION(gsl_matrix,isneg)(m) != 0);
TEST (status, "_isneg" DESC " on mixed matrix") ;
status = (FUNCTION(gsl_matrix,isnonneg)(m) != 0);
TEST (status, "_isnonneg" DESC " on mixed matrix") ;
}
k = 0;
for (i = 0; i < M; i++)
{
for (j = 0; j < N; j++)
{
k++;
FUNCTION (gsl_matrix, set) (m, i, j, -(ATOMIC) (k % 10));
}
}
{
status = (FUNCTION(gsl_matrix,isnull)(m) != 0);
TEST (status, "_isnull" DESC " on non-positive matrix") ;
status = (FUNCTION(gsl_matrix,ispos)(m) != 0);
TEST (status, "_ispos" DESC " on non-positive matrix") ;
status = (FUNCTION(gsl_matrix,isneg)(m) != 0);
TEST (status, "_isneg" DESC " on non-positive matrix") ;
status = (FUNCTION(gsl_matrix,isnonneg)(m) != 0);
TEST (status, "_isnonneg" DESC " on non-positive matrix") ;
}
#endif
k = 0;
for (i = 0; i < M; i++)
{
for (j = 0; j < N; j++)
{
k++;
FUNCTION (gsl_matrix, set) (m, i, j, (ATOMIC) (k % 10 + 1));
}
}
{
status = (FUNCTION(gsl_matrix,isnull)(m) != 0);
TEST (status, "_isnull" DESC " on positive matrix") ;
status = (FUNCTION(gsl_matrix,ispos)(m) != 1);
TEST (status, "_ispos" DESC " on positive matrix") ;
status = (FUNCTION(gsl_matrix,isneg)(m) != 0);
TEST (status, "_isneg" DESC " on positive matrix") ;
status = (FUNCTION(gsl_matrix,isnonneg)(m) != 1);
TEST (status, "_isnonneg" DESC " on positive matrix") ;
}
#if (!defined(UNSIGNED) && !defined(BASE_CHAR))
k = 0;
for (i = 0; i < M; i++)
{
for (j = 0; j < N; j++)
{
k++;
FUNCTION (gsl_matrix, set) (m, i, j, -(ATOMIC) (k % 10 + 1));
}
}
{
status = (FUNCTION(gsl_matrix,isnull)(m) != 0);
TEST (status, "_isnull" DESC " on negative matrix") ;
status = (FUNCTION(gsl_matrix,ispos)(m) != 0);
TEST (status, "_ispos" DESC " on negative matrix") ;
status = (FUNCTION(gsl_matrix,isneg)(m) != 1);
TEST (status, "_isneg" DESC " on negative matrix") ;
status = (FUNCTION(gsl_matrix,isnonneg)(m) != 0);
TEST (status, "_isnonneg" DESC " on negative matrix") ;
}
#endif
FUNCTION (gsl_matrix, free) (m);
FUNCTION (gsl_vector, free) (v);
}
static void
test_fdfridge(const gsl_multifit_fdfsolver_type * T, const double xtol,
const double gtol, const double ftol,
const double epsrel, const double x0_scale,
test_fdf_problem *problem, const double *wts)
{
gsl_multifit_function_fdf *fdf = problem->fdf;
const size_t n = fdf->n;
const size_t p = fdf->p;
const size_t max_iter = 1500;
gsl_vector *x0 = gsl_vector_alloc(p);
gsl_vector_view x0v = gsl_vector_view_array(problem->x0, p);
gsl_multifit_fdfridge *w = gsl_multifit_fdfridge_alloc (T, n, p);
const char *pname = problem->name;
char sname[2048];
int status, info;
double lambda = 0.0;
sprintf(sname, "ridge/%s", gsl_multifit_fdfridge_name(w));
/* scale starting point x0 */
gsl_vector_memcpy(x0, &x0v.vector);
test_scale_x0(x0, x0_scale);
/* test undamped case with lambda = 0 */
if (wts)
{
gsl_vector_const_view wv = gsl_vector_const_view_array(wts, n);
gsl_multifit_fdfridge_wset(w, fdf, x0, lambda, &wv.vector);
}
else
gsl_multifit_fdfridge_set(w, fdf, x0, lambda);
status = gsl_multifit_fdfridge_driver(w, max_iter, xtol, gtol,
ftol, &info);
gsl_test(status, "%s/%s did not converge, status=%s",
sname, pname, gsl_strerror(status));
/* check solution */
test_fdf_checksol(sname, pname, epsrel, w->s, problem);
/* test for self consisent solution with L = \lambda I */
{
const double eps = 1.0e-10;
gsl_matrix *L = gsl_matrix_calloc(p, p);
gsl_vector_view diag = gsl_matrix_diagonal(L);
gsl_multifit_fdfridge *w2 = gsl_multifit_fdfridge_alloc (T, n, p);
gsl_vector *y0 = gsl_vector_alloc(p);
size_t i;
/* pick some value for lambda and set L = \lambda I */
lambda = 5.0;
gsl_vector_set_all(&diag.vector, lambda);
/* scale initial vector */
gsl_vector_memcpy(x0, &x0v.vector);
test_scale_x0(x0, x0_scale);
gsl_vector_memcpy(y0, x0);
if (wts)
{
gsl_vector_const_view wv = gsl_vector_const_view_array(wts, n);
gsl_multifit_fdfridge_wset(w, fdf, x0, lambda, &wv.vector);
gsl_multifit_fdfridge_wset3(w2, fdf, y0, L, &wv.vector);
}
else
{
gsl_multifit_fdfridge_set(w, fdf, x0, lambda);
gsl_multifit_fdfridge_set3(w2, fdf, y0, L);
}
/* solve with scalar lambda routine */
status = gsl_multifit_fdfridge_driver(w, max_iter, xtol, gtol,
ftol, &info);
gsl_test(status, "%s/lambda/%s did not converge, status=%s",
sname, pname, gsl_strerror(status));
/* solve with general matrix routine */
status = gsl_multifit_fdfridge_driver(w2, max_iter, xtol, gtol,
ftol, &info);
gsl_test(status, "%s/L/%s did not converge, status=%s",
sname, pname, gsl_strerror(status));
/* test x = y */
for (i = 0; i < p; ++i)
{
double xi = gsl_vector_get(w->s->x, i);
double yi = gsl_vector_get(w2->s->x, i);
if (fabs(xi) < eps)
{
gsl_test_abs(yi, xi, eps, "%s/%s ridge lambda=%g i="F_ZU,
sname, pname, lambda, i);
}
else
{
gsl_test_rel(yi, xi, eps, "%s/%s ridge lambda=%g i="F_ZU,
sname, pname, lambda, i);
}
}
gsl_matrix_free(L);
gsl_vector_free(y0);
gsl_multifit_fdfridge_free(w2);
}
gsl_multifit_fdfridge_free(w);
gsl_vector_free(x0);
}
int
main(int argc, char **argv)
{
size_t order, breakpoints, i;
gsl_ieee_env_setup();
argc = 0; /* prevent warnings about unused parameters */
argv = 0;
for (order = 1; order < 10; order++)
{
for (breakpoints = 2; breakpoints < 100; breakpoints++)
{
double a = -1.23 * order, b = 45.6 * order;
gsl_bspline_workspace *bw = gsl_bspline_alloc(order, breakpoints);
gsl_bspline_deriv_workspace *dbw = gsl_bspline_deriv_alloc(order);
gsl_bspline_knots_uniform(a, b, bw);
test_bspline(bw, dbw);
gsl_bspline_deriv_free(dbw);
gsl_bspline_free(bw);
}
}
for (order = 1; order < 10; order++)
{
for (breakpoints = 2; breakpoints < 100; breakpoints++)
{
double a = -1.23 * order, b = 45.6 * order;
gsl_bspline_workspace *bw = gsl_bspline_alloc(order, breakpoints);
gsl_bspline_deriv_workspace *dbw = gsl_bspline_deriv_alloc(order);
gsl_vector *k = gsl_vector_alloc(breakpoints);
for (i = 0; i < breakpoints; i++)
{
double f, x;
f = sqrt(i / (breakpoints - 1.0));
x = (1 - f) * a + f * b;
gsl_vector_set(k, i, x);
};
gsl_bspline_knots(k, bw);
test_bspline(bw, dbw);
gsl_vector_free(k);
gsl_bspline_deriv_free(dbw);
gsl_bspline_free(bw);
}
}
/* Spot check known 0th, 1st, 2nd derivative
evaluations for a particular k = 2 case. */
{
size_t i, j; /* looping */
const double xloc[4] = { 0.0, 1.0, 6.0, 7.0};
const double deriv[4][3] =
{
{ -1.0/2.0, 1.0/2.0, 0.0 },
{ -1.0/2.0, 1.0/2.0, 0.0 },
{ 0.0, -1.0/5.0, 1.0/5.0 },
{ 0.0, -1.0/5.0, 1.0/5.0 }
};
gsl_bspline_workspace *bw = gsl_bspline_alloc(2, 3);
gsl_bspline_deriv_workspace *dbw = gsl_bspline_deriv_alloc(2);
gsl_matrix *dB = gsl_matrix_alloc(gsl_bspline_ncoeffs(bw),
gsl_bspline_order(bw) + 1);
gsl_vector *breakpts = gsl_vector_alloc(3);
gsl_vector_set(breakpts, 0, 0.0);
gsl_vector_set(breakpts, 1, 2.0);
gsl_vector_set(breakpts, 2, 7.0);
gsl_bspline_knots(breakpts, bw);
for (i = 0; i < 4; ++i) /* at each location */
{
/* Initialize dB with poison to ensure we overwrite it */
gsl_matrix_set_all(dB, GSL_NAN);
gsl_bspline_deriv_eval(xloc[i], gsl_bspline_order(bw), dB, bw, dbw);
for (j = 0; j < gsl_bspline_ncoeffs(bw) ; ++j)
{
/* check basis function 1st deriv */
gsl_test_abs(gsl_matrix_get(dB, j, 1), deriv[i][j], GSL_DBL_EPSILON,
"b-spline k=%d basis #%d derivative %d at x = %f",
gsl_bspline_order(bw), j, 1, xloc[i]);
}
for (j = 0; j < gsl_bspline_ncoeffs(bw); ++j)
{
/* check k order basis function has k-th deriv equal to 0 */
gsl_test_abs(gsl_matrix_get(dB, j, gsl_bspline_order(bw)), 0.0,
GSL_DBL_EPSILON,
"b-spline k=%d basis #%d derivative %d at x = %f",
gsl_bspline_order(bw), j, gsl_bspline_order(bw),
xloc[i]);
}
}
gsl_matrix_free(dB);
gsl_bspline_deriv_free(dbw);
gsl_bspline_free(bw);
gsl_vector_free(breakpts);
}
/* Spot check known 0th, 1st, 2nd derivative
evaluations for a particular k = 3 case. */
{
size_t i, j; /* looping */
const double xloc[5] = { 0.0, 5.0, 9.0, 12.0, 15.0 };
const double eval[5][6] =
{
{ 4./25., 69./100., 3./ 20. , 0. , 0. , 0. },
{ 0. , 4./21. , 143./210. , 9./70., 0. , 0. },
{ 0. , 0. , 3./ 10. , 7./10., 0. , 0. },
{ 0. , 0. , 0. , 3./4. , 1./4., 0. },
{ 0. , 0. , 0. , 1./3. , 5./9., 1./9. }
};
const double deriv[5][6] =
{
{ -4./25., 3./50., 1./ 10., 0. , 0. , 0. },
{ 0. , -2./21., 1./105., 3./35., 0. , 0. },
{ 0. , 0. , -1./5. , 1./ 5., 0. , 0. },
{ 0. , 0. , 0. , -1./ 6., 1./6. , 0. },
{ 0. , 0. , 0. , -1./ 9., 1./27., 2./27. }
};
const double deriv2[5][6] =
{
{ 2./25., -17./150., 1.0/30.0 , 0.0 , 0. , 0. },
{ 0. , 1./ 42., -11.0/210.0, 1.0/35.0, 0. , 0. },
{ 0. , 0. , 1.0/15.0 ,-11.0/90.0, 1./18. , 0. },
{ 0. , 0. , 0.0 , 1.0/54.0, -7./162., 2./81. },
{ 0. , 0. , 0.0 , 1.0/54.0, -7./162., 2./81. }
};
gsl_bspline_workspace *bw = gsl_bspline_alloc(3, 5);
gsl_bspline_deriv_workspace *dbw = gsl_bspline_deriv_alloc(3);
gsl_matrix *dB = gsl_matrix_alloc(gsl_bspline_ncoeffs(bw),
gsl_bspline_order(bw) + 1);
gsl_vector *breakpts = gsl_vector_alloc(5);
gsl_vector_set(breakpts, 0, -3.0);
gsl_vector_set(breakpts, 1, 2.0);
gsl_vector_set(breakpts, 2, 9.0);
gsl_vector_set(breakpts, 3, 12.0);
gsl_vector_set(breakpts, 4, 21.0);
gsl_bspline_knots(breakpts, bw);
for (i = 0; i < 5; ++i) /* at each location */
{
/* Initialize dB with poison to ensure we overwrite it */
gsl_matrix_set_all(dB, GSL_NAN);
gsl_bspline_deriv_eval(xloc[i], gsl_bspline_order(bw), dB, bw, dbw);
/* check basis function evaluation */
for (j = 0; j < gsl_bspline_ncoeffs(bw); ++j)
{
gsl_test_abs(gsl_matrix_get(dB, j, 0), eval[i][j], GSL_DBL_EPSILON,
"b-spline k=%d basis #%d derivative %d at x = %f",
gsl_bspline_order(bw), j, 0, xloc[i]);
}
/* check 1st derivative evaluation */
for (j = 0; j < gsl_bspline_ncoeffs(bw); ++j)
{
gsl_test_abs(gsl_matrix_get(dB, j, 1), deriv[i][j], GSL_DBL_EPSILON,
"b-spline k=%d basis #%d derivative %d at x = %f",
gsl_bspline_order(bw), j, 1, xloc[i]);
}
/* check 2nd derivative evaluation */
for (j = 0; j < gsl_bspline_ncoeffs(bw); ++j)
{
gsl_test_abs(gsl_matrix_get(dB, j, 2), deriv2[i][j], GSL_DBL_EPSILON,
"b-spline k=%d basis #%d derivative %d at x = %f",
gsl_bspline_order(bw), j, 2, xloc[i]);
}
}
gsl_matrix_free(dB);
gsl_bspline_deriv_free(dbw);
gsl_bspline_free(bw);
gsl_vector_free(breakpts);
}
/* Check Greville abscissae functionality on a non-uniform k=1 */
{
size_t i; /* looping */
/* Test parameters */
const size_t k = 1;
const double bpoint_data[] = { 0.0, 0.2, 0.5, 0.75, 1.0 };
const size_t nbreak = sizeof(bpoint_data)/sizeof(bpoint_data[0]);
/* Expected results */
const double abscissae_data[] = { 0.1, 0.35, 0.625, 0.875 };
const size_t nabscissae = sizeof(abscissae_data)/sizeof(abscissae_data[0]);
gsl_vector_const_view bpoints = gsl_vector_const_view_array(bpoint_data, nbreak);
gsl_bspline_workspace *w = gsl_bspline_alloc(k, nbreak);
gsl_bspline_knots((const gsl_vector *) &bpoints, w);
gsl_test_int(nabscissae, gsl_bspline_ncoeffs(w),
"b-spline k=%d number of abscissae", k);
for (i = 0; i < nabscissae; ++i)
{
gsl_test_abs(gsl_bspline_greville_abscissa(i, w), abscissae_data[i], 2*k*GSL_DBL_EPSILON,
"b-spline k=%d Greville abscissa #%d at x = %f", k, i, abscissae_data[i]);
}
gsl_bspline_free(w);
}
/* Check Greville abscissae functionality on a non-uniform k=2 */
{
size_t i; /* looping */
/* Test parameters */
const size_t k = 2;
const double bpoint_data[] = { 0.0, 0.2, 0.5, 0.75, 1.0 };
const size_t nbreak = sizeof(bpoint_data)/sizeof(bpoint_data[0]);
/* Expected results */
const double abscissae_data[] = { 0.0, 0.2, 0.5, 0.75, 1.0 };
const size_t nabscissae = sizeof(abscissae_data)/sizeof(abscissae_data[0]);
gsl_vector_const_view bpoints = gsl_vector_const_view_array(bpoint_data, nbreak);
gsl_bspline_workspace *w = gsl_bspline_alloc(k, nbreak);
gsl_bspline_knots((const gsl_vector *) &bpoints, w);
gsl_test_int(nabscissae, gsl_bspline_ncoeffs(w),
"b-spline k=%d number of abscissae", k);
for (i = 0; i < nabscissae; ++i)
{
gsl_test_abs(gsl_bspline_greville_abscissa(i, w), abscissae_data[i], 2*k*GSL_DBL_EPSILON,
"b-spline k=%d Greville abscissa #%d at x = %f", k, i, abscissae_data[i]);
}
gsl_bspline_free(w);
}
/* Check Greville abscissae functionality on non-uniform k=3 */
{
size_t i; /* looping */
/* Test parameters */
const size_t k = 3;
const double bpoint_data[] = { 0.0, 0.2, 0.5, 0.75, 1.0 };
const size_t nbreak = sizeof(bpoint_data)/sizeof(bpoint_data[0]);
/* Expected results */
const double abscissae_data[] = { 0.0, 1.0/10.0, 7.0/20.0,
5.0/ 8.0, 7.0/ 8.0, 1.0 };
const size_t nabscissae = sizeof(abscissae_data)/sizeof(abscissae_data[0]);
gsl_vector_const_view bpoints = gsl_vector_const_view_array(bpoint_data, nbreak);
gsl_bspline_workspace *w = gsl_bspline_alloc(k, nbreak);
gsl_bspline_knots((const gsl_vector *) &bpoints, w);
gsl_test_int(nabscissae, gsl_bspline_ncoeffs(w),
"b-spline k=%d number of abscissae", k);
for (i = 0; i < nabscissae; ++i)
{
gsl_test_abs(gsl_bspline_greville_abscissa(i, w), abscissae_data[i], 2*k*GSL_DBL_EPSILON,
"b-spline k=%d Greville abscissa #%d at x = %f", k, i, abscissae_data[i]);
}
gsl_bspline_free(w);
}
/* Check Greville abscissae functionality on non-uniform k=4 */
{
size_t i; /* looping */
/* Test parameters */
const size_t k = 4;
const double bpoint_data[] = { 0.0, 0.2, 0.5, 0.75, 1.0 };
const size_t nbreak = sizeof(bpoint_data)/sizeof(bpoint_data[0]);
/* Expected results */
const double abscissae_data[] = { 0.0, 1.0/15.0, 7.0/30.0, 29.0/60.0,
3.0/ 4.0, 11.0/12.0, 1.0 };
const size_t nabscissae = sizeof(abscissae_data)/sizeof(abscissae_data[0]);
gsl_vector_const_view bpoints = gsl_vector_const_view_array(bpoint_data, nbreak);
gsl_bspline_workspace *w = gsl_bspline_alloc(k, nbreak);
gsl_bspline_knots((const gsl_vector *) &bpoints, w);
gsl_test_int(nabscissae, gsl_bspline_ncoeffs(w),
"b-spline k=%d number of abscissae", k);
for (i = 0; i < nabscissae; ++i)
{
gsl_test_abs(gsl_bspline_greville_abscissa(i, w), abscissae_data[i], 2*k*GSL_DBL_EPSILON,
"b-spline k=%d Greville abscissa #%d at x = %f", k, i, abscissae_data[i]);
}
gsl_bspline_free(w);
}
exit(gsl_test_summary());
}
void
test_eigen_herm_results (const gsl_matrix_complex * A,
const gsl_vector * eval,
const gsl_matrix_complex * evec,
size_t count,
const char * desc,
const char * desc2)
{
const size_t N = A->size1;
size_t i, j;
gsl_vector_complex * x = gsl_vector_complex_alloc(N);
gsl_vector_complex * y = gsl_vector_complex_alloc(N);
/* check eigenvalues */
for (i = 0; i < N; i++)
{
double ei = gsl_vector_get (eval, i);
gsl_vector_complex_const_view vi =
gsl_matrix_complex_const_column(evec, i);
gsl_vector_complex_memcpy(x, &vi.vector);
/* compute y = m x (should = lambda v) */
gsl_blas_zgemv (CblasNoTrans, GSL_COMPLEX_ONE, A, x,
GSL_COMPLEX_ZERO, y);
for (j = 0; j < N; j++)
{
gsl_complex xj = gsl_vector_complex_get (x, j);
gsl_complex yj = gsl_vector_complex_get (y, j);
gsl_test_rel(GSL_REAL(yj), ei * GSL_REAL(xj), 1e8*GSL_DBL_EPSILON,
"%s, eigenvalue(%d,%d), real, %s", desc, i, j, desc2);
gsl_test_rel(GSL_IMAG(yj), ei * GSL_IMAG(xj), 1e8*GSL_DBL_EPSILON,
"%s, eigenvalue(%d,%d), imag, %s", desc, i, j, desc2);
}
}
/* check eigenvectors are orthonormal */
for (i = 0; i < N; i++)
{
gsl_vector_complex_const_view vi = gsl_matrix_complex_const_column(evec, i);
double nrm_v = gsl_blas_dznrm2(&vi.vector);
gsl_test_rel (nrm_v, 1.0, N * GSL_DBL_EPSILON, "%s, normalized(%d), %s",
desc, i, desc2);
}
for (i = 0; i < N; i++)
{
gsl_vector_complex_const_view vi = gsl_matrix_complex_const_column(evec, i);
for (j = i + 1; j < N; j++)
{
gsl_vector_complex_const_view vj
= gsl_matrix_complex_const_column(evec, j);
gsl_complex vivj;
gsl_blas_zdotc (&vi.vector, &vj.vector, &vivj);
gsl_test_abs (gsl_complex_abs(vivj), 0.0, 10.0 * N * GSL_DBL_EPSILON,
"%s, orthogonal(%d,%d), %s", desc, i, j, desc2);
}
}
gsl_vector_complex_free(x);
gsl_vector_complex_free(y);
} /* test_eigen_herm_results() */
void
test_eigen_nonsymm_results (const gsl_matrix * m,
const gsl_vector_complex * eval,
const gsl_matrix_complex * evec,
size_t count,
const char * desc,
const char * desc2)
{
size_t i,j;
size_t N = m->size1;
gsl_vector_complex * x = gsl_vector_complex_alloc(N);
gsl_vector_complex * y = gsl_vector_complex_alloc(N);
gsl_matrix_complex * A = gsl_matrix_complex_alloc(N, N);
/* we need a complex matrix for the blas routines, so copy m into A */
for (i = 0; i < N; ++i)
{
for (j = 0; j < N; ++j)
{
gsl_complex z;
GSL_SET_COMPLEX(&z, gsl_matrix_get(m, i, j), 0.0);
gsl_matrix_complex_set(A, i, j, z);
}
}
for (i = 0; i < N; i++)
{
gsl_complex ei = gsl_vector_complex_get (eval, i);
gsl_vector_complex_const_view vi = gsl_matrix_complex_const_column(evec, i);
double norm = gsl_blas_dznrm2(&vi.vector);
/* check that eigenvector is normalized */
gsl_test_rel(norm, 1.0, N * GSL_DBL_EPSILON,
"nonsymm(N=%u,cnt=%u), %s, normalized(%d), %s", N, count, desc, i, desc2);
gsl_vector_complex_memcpy(x, &vi.vector);
/* compute y = m x (should = lambda v) */
gsl_blas_zgemv (CblasNoTrans, GSL_COMPLEX_ONE, A, x,
GSL_COMPLEX_ZERO, y);
/* compute x = lambda v */
gsl_blas_zscal(ei, x);
/* now test if y = x */
for (j = 0; j < N; j++)
{
gsl_complex xj = gsl_vector_complex_get (x, j);
gsl_complex yj = gsl_vector_complex_get (y, j);
/* use abs here in case the values are close to 0 */
gsl_test_abs(GSL_REAL(yj), GSL_REAL(xj), 1e8*GSL_DBL_EPSILON,
"nonsymm(N=%u,cnt=%u), %s, eigenvalue(%d,%d), real, %s", N, count, desc, i, j, desc2);
gsl_test_abs(GSL_IMAG(yj), GSL_IMAG(xj), 1e8*GSL_DBL_EPSILON,
"nonsymm(N=%u,cnt=%u), %s, eigenvalue(%d,%d), imag, %s", N, count, desc, i, j, desc2);
}
}
gsl_matrix_complex_free(A);
gsl_vector_complex_free(x);
gsl_vector_complex_free(y);
}
void
test_evolve_system (const gsl_odeiv_step_type * T,
const gsl_odeiv_system * sys,
double t0, double t1, double hstart,
double y[], double yfin[],
double err_target, const char *desc)
{
/* Tests system sys with stepper T. Step length is controlled by
error estimation from the stepper.
*/
int steps = 0;
size_t i;
double t = t0;
double h = hstart;
/* Tolerance factor in testing errors */
const double factor = 10;
gsl_odeiv_step * step = gsl_odeiv_step_alloc (T, sys->dimension);
gsl_odeiv_control *c =
gsl_odeiv_control_standard_new (err_target, err_target, 1.0, 0.0);
gsl_odeiv_evolve *e = gsl_odeiv_evolve_alloc (sys->dimension);
while (t < t1)
{
int s = gsl_odeiv_evolve_apply (e, c, step, sys, &t, t1, &h, y);
if (s != GSL_SUCCESS && sys != &rhs_func_xsin)
{
gsl_test(s, "%s evolve_apply returned %d",
gsl_odeiv_step_name (step), s);
break;
}
if (steps > 100000)
{
gsl_test(GSL_EFAILED,
"%s evolve_apply reached maxiter",
gsl_odeiv_step_name (step));
break;
}
steps++;
}
/* err_target is target error of one step. Test if stepper has made
larger error than (tolerance factor times) the number of steps
times the err_target */
for (i = 0; i < sys->dimension; i++)
{
gsl_test_abs (y[i], yfin[i], factor * e->count * err_target,
"%s %s evolve(%d)",
gsl_odeiv_step_name (step), desc, i);
}
gsl_odeiv_evolve_free (e);
gsl_odeiv_control_free (c);
gsl_odeiv_step_free (step);
}
void
test_eigen_symm_results (const gsl_matrix * A,
const gsl_vector * eval,
const gsl_matrix * evec,
size_t count,
const char * desc,
const char * desc2)
{
const size_t N = A->size1;
size_t i, j;
double emax = 0;
gsl_vector * x = gsl_vector_alloc(N);
gsl_vector * y = gsl_vector_alloc(N);
/* check eigenvalues */
for (i = 0; i < N; i++)
{
double ei = gsl_vector_get (eval, i);
if (fabs(ei) > emax) emax = fabs(ei);
}
for (i = 0; i < N; i++)
{
double ei = gsl_vector_get (eval, i);
gsl_vector_const_view vi = gsl_matrix_const_column(evec, i);
gsl_vector_memcpy(x, &vi.vector);
/* compute y = A x (should = lambda v) */
gsl_blas_dgemv (CblasNoTrans, 1.0, A, x, 0.0, y);
for (j = 0; j < N; j++)
{
double xj = gsl_vector_get (x, j);
double yj = gsl_vector_get (y, j);
double eixj = chop_subnormals(ei * xj);
gsl_test_abs(yj, eixj, emax * 1e8 * GSL_DBL_EPSILON,
"%s, eigenvalue(%d,%d), %s", desc, i, j, desc2);
}
}
/* check eigenvectors are orthonormal */
for (i = 0; i < N; i++)
{
gsl_vector_const_view vi = gsl_matrix_const_column(evec, i);
double nrm_v = gsl_blas_dnrm2(&vi.vector);
gsl_test_rel (nrm_v, 1.0, N * GSL_DBL_EPSILON, "%s, normalized(%d), %s",
desc, i, desc2);
}
for (i = 0; i < N; i++)
{
gsl_vector_const_view vi = gsl_matrix_const_column(evec, i);
for (j = i + 1; j < N; j++)
{
gsl_vector_const_view vj = gsl_matrix_const_column(evec, j);
double vivj;
gsl_blas_ddot (&vi.vector, &vj.vector, &vivj);
gsl_test_abs (vivj, 0.0, N * GSL_DBL_EPSILON,
"%s, orthogonal(%d,%d), %s", desc, i, j, desc2);
}
}
gsl_vector_free(x);
gsl_vector_free(y);
}
void
test_compare_vanderpol (void)
{
/* Compares output of van Der Pol oscillator with several steppers */
/* system dimension */
const size_t sd = 2;
const gsl_odeiv_step_type *steppers[20];
const gsl_odeiv_step_type **T;
/* Required error tolerance for each stepper. */
double err_target[20];
/* number of ODE solvers */
const size_t ns = 11;
/* initial values for each ode-solver */
double y[11][2];
double *yp = &y[0][0];
size_t i, j, k;
int status = 0;
/* Parameters for the problem and stepper */
const double start = 0.0;
const double end = 100.0;
const double epsabs = 1e-8;
const double epsrel = 1e-8;
const double initstepsize = 1e-5;
/* Initialize */
steppers[0] = gsl_odeiv_step_rk2;
err_target[0] = 1e-6;
steppers[1] = gsl_odeiv_step_rk4;
err_target[1] = 1e-6;
steppers[2] = gsl_odeiv_step_rkf45;
err_target[2] = 1e-6;
steppers[3] = gsl_odeiv_step_rkck;
err_target[3] = 1e-6;
steppers[4] = gsl_odeiv_step_rk8pd;
err_target[4] = 1e-6;
steppers[5] = gsl_odeiv_step_rk2imp;
err_target[5] = 1e-5;
steppers[6] = gsl_odeiv_step_rk2simp;
err_target[6] = 1e-5;
steppers[7] = gsl_odeiv_step_rk4imp;
err_target[7] = 1e-6;
steppers[8] = gsl_odeiv_step_bsimp;
err_target[8] = 1e-7;
steppers[9] = gsl_odeiv_step_gear1;
err_target[9] = 1e-2;
steppers[10] = gsl_odeiv_step_gear2;
err_target[10] = 1e-6;
steppers[11] = 0;
T = steppers;
for (i = 0; i < ns; i++)
{
y[i][0] = 1.0;
y[i][1] = 0.0;
}
/* Call each solver for the problem */
i = 0;
while (*T != 0)
{
{
int s = sys_driver (*T, &rhs_func_vanderpol,
start, end, initstepsize, &yp[i],
epsabs, epsrel, "vanderpol");
if (s != GSL_SUCCESS)
{
status++;
}
}
T++;
i += sd;
}
if (status != GSL_SUCCESS)
{
return;
}
/* Compare results */
T = steppers;
for (i = 0; i < ns; i++)
for (j = i+1; j < ns; j++)
for (k = 0; k < sd; k++)
{
const double val1 = yp[sd * i + k];
const double val2 = yp[sd * j + k];
gsl_test_abs (val1, val2,
( GSL_MAX(err_target[i], err_target[j]) ),
"%s/%s vanderpol",
T[i]->name, T[j]->name);
}
}
int
main(void)
{
double tol = 100.0 * GSL_DBL_EPSILON;
double ftol = 20.0;
double x;
size_t i;
gsl_cheb_series * cs = gsl_cheb_alloc(40);
gsl_cheb_series * csd = gsl_cheb_alloc(40);
gsl_cheb_series * csi = gsl_cheb_alloc(40);
gsl_function F_sin, F_T0, F_T1, F_T2, F_DP, F_P, F_IP1, F_IP2;
F_sin.function = f_sin;
F_sin.params = 0;
F_T0.function = f_T0;
F_T0.params = 0;
F_T1.function = f_T1;
F_T1.params = 0;
F_T2.function = f_T2;
F_T2.params = 0;
F_P.function = f_P;
F_P.params = 0;
F_DP.function = f_DP;
F_DP.params = 0;
F_IP1.function = f_IP1;
F_IP1.params = 0;
F_IP2.function = f_IP2;
F_IP2.params = 0;
gsl_ieee_env_setup();
gsl_cheb_init(cs, &F_T0, -1.0, 1.0);
{
size_t expected = 40;
size_t order = gsl_cheb_order (cs);
size_t size = gsl_cheb_size (cs);
double * p = gsl_cheb_coeffs (cs);
gsl_test(order != expected, "gsl_cheb_order");
gsl_test(size != expected + 1, "gsl_cheb_size");
gsl_test(p != cs->c, "gsl_cheb_coeffs");
}
for (i = 0; i<cs->order; i++)
{
double c_exp = (i == 0) ? 2.0 : 0.0;
gsl_test_abs (cs->c[i], c_exp, tol, "c[%d] for T_0(x)", i);
}
gsl_cheb_init(cs, &F_T1, -1.0, 1.0);
for (i = 0; i<cs->order; i++)
{
double c_exp = (i == 1) ? 1.0 : 0.0;
gsl_test_abs (cs->c[i], c_exp, tol, "c[%d] for T_1(x)", i);
}
gsl_cheb_init(cs, &F_T2, -1.0, 1.0);
for (i = 0; i<cs->order; i++)
{
double c_exp = (i == 2) ? 1.0 : 0.0;
gsl_test_abs (cs->c[i], c_exp, tol, "c[%d] for T_2(x)", i);
}
gsl_cheb_init(cs, &F_sin, -M_PI, M_PI);
gsl_test_abs (cs->c[0], 0.0, tol, "c[0] for F_sin(x)");
gsl_test_abs (cs->c[1], 5.69230686359506e-01, tol, "c[1] for F_sin(x)");
gsl_test_abs (cs->c[2], 0.0, tol, "c[2] for F_sin(x)");
gsl_test_abs (cs->c[3], -6.66916672405979e-01, tol, "c[3] for F_sin(x)");
gsl_test_abs (cs->c[4], 0.0, tol, "c[4] for F_sin(x)");
gsl_test_abs (cs->c[5], 1.04282368734237e-01, tol, "c[5] for F_sin(x)");
for(x=-M_PI; x<M_PI; x += M_PI/100.0) {
double r = gsl_cheb_eval(cs, x);
gsl_test_abs(r, sin(x), tol, "gsl_cheb_eval, sin(%.3g)", x);
}
for(x=-M_PI; x<M_PI; x += M_PI/100.0) {
double r, e;
gsl_cheb_eval_err(cs, x, &r, &e);
gsl_test_abs(r, sin(x), tol, "gsl_cheb_eval_err, sin(%.3g)", x);
gsl_test_factor(fabs(r-sin(x)) + GSL_DBL_EPSILON, e, ftol,
"gsl_cheb_eval_err, error sin(%.3g)", x);
}
for(x=-M_PI; x<M_PI; x += M_PI/100.0) {
double r = gsl_cheb_eval_n(cs, 25, x);
gsl_test_abs(r, sin(x), tol, "gsl_cheb_eval_n, sin(%.3g)", x);
}
for(x=-M_PI; x<M_PI; x += M_PI/100.0) {
double r, e;
gsl_cheb_eval_n_err(cs, 25, x, &r, &e);
gsl_test_abs(r, sin(x), 100.0 * tol, "gsl_cheb_eval_n_err, deriv sin(%.3g)", x);
gsl_test_factor(fabs(r-sin(x)) + GSL_DBL_EPSILON, e, ftol,
"gsl_cheb_eval_n_err, error sin(%.3g)", x);
}
/* Test derivative */
gsl_cheb_calc_deriv(csd, cs);
for(x=-M_PI; x<M_PI; x += M_PI/100.0) {
double r = gsl_cheb_eval(csd, x);
gsl_test_abs(r, cos(x), 1600 * tol, "gsl_cheb_eval, deriv sin(%.3g)", x);
}
#ifdef TEST_DERIVATIVE_ERR
for(x=-M_PI; x<M_PI; x += M_PI/100.0) {
double r, e;
gsl_cheb_eval_err(csd, x, &r, &e);
gsl_test_abs(r, cos(x), tol, "gsl_cheb_eval_err, deriv sin(%.3g)", x);
gsl_test_factor(fabs(r-cos(x)) + GSL_DBL_EPSILON, e, ftol,
"gsl_cheb_eval_err, deriv error sin(%.3g)", x);
}
#endif
for(x=-M_PI; x<M_PI; x += M_PI/100.0) {
double r = gsl_cheb_eval_n(csd, 25, x);
gsl_test_abs(r, cos(x), 1600 * tol, "gsl_cheb_eval_n, deriv sin(%.3g)", x);
}
#ifdef TEST_DERIVATIVE_ERR
for(x=-M_PI; x<M_PI; x += M_PI/100.0) {
double r, e;
gsl_cheb_eval_n_err(csd, 25, x, &r, &e);
gsl_test_abs(r, cos(x), 100.0 * tol, "gsl_cheb_eval_n_err, deriv sin(%.3g)", x);
gsl_test_factor(fabs(r-cos(x)) + GSL_DBL_EPSILON, e, ftol,
"gsl_cheb_eval_n_err, deriv error sin(%.3g)", x);
}
#endif
/* Test integral */
gsl_cheb_calc_integ(csi, cs);
for(x=-M_PI; x<M_PI; x += M_PI/100.0) {
double r = gsl_cheb_eval(csi, x);
gsl_test_abs(r, -(1+cos(x)), tol, "gsl_cheb_eval, integ sin(%.3g)", x);
}
#ifdef TEST_INTEGRAL_ERR
for(x=-M_PI; x<M_PI; x += M_PI/100.0) {
double r, e;
gsl_cheb_eval_err(csi, x, &r, &e);
gsl_test_abs(r, -(1+cos(x)), tol, "gsl_cheb_eval_err, integ sin(%.3g)", x);
gsl_test_factor(fabs(r-(-1-cos(x))) + GSL_DBL_EPSILON, e, ftol,
"gsl_cheb_eval_err, integ error sin(%.3g)", x);
}
#endif
for(x=-M_PI; x<M_PI; x += M_PI/100.0) {
double r = gsl_cheb_eval_n(csi, 25, x);
gsl_test_abs(r, -(1+cos(x)), tol, "gsl_cheb_eval_n, integ sin(%.3g)", x);
}
#ifdef TEST_INTEGRAL_ERR
for(x=-M_PI; x<M_PI; x += M_PI/100.0) {
double r, e;
gsl_cheb_eval_n_err(csi, 25, x, &r, &e);
gsl_test_abs(r, -(1+cos(x)), 100.0 * tol, "gsl_cheb_eval_n_err, integ sin(%.3g)", x);
gsl_test_factor(fabs(r-(-1-cos(x))) + GSL_DBL_EPSILON, e, ftol,
"gsl_cheb_eval_n_err, integ error sin(%.3g)", x);
}
#endif
gsl_cheb_free(csi);
gsl_cheb_free(csd);
gsl_cheb_free(cs);
/* Test low order cases */
test_dim (2, -5.0, 5.0, &F_P, &F_DP, &F_IP2);
test_dim (1, -5.0, 5.0, &F_P, &F_DP, &F_IP1);
exit (gsl_test_summary());
}
static int
test_COD_lssolve_eps(const gsl_matrix * m, const double * actual, const double eps, const char *desc)
{
int s = 0;
size_t i, M = m->size1, N = m->size2;
gsl_vector * lhs = gsl_vector_alloc(M);
gsl_vector * rhs = gsl_vector_alloc(M);
gsl_matrix * QRZT = gsl_matrix_alloc(M, N);
gsl_vector * tau_Q = gsl_vector_alloc(GSL_MIN(M, N));
gsl_vector * tau_Z = gsl_vector_alloc(GSL_MIN(M, N));
gsl_vector * work = gsl_vector_alloc(N);
gsl_vector * x = gsl_vector_alloc(N);
gsl_vector * r = gsl_vector_alloc(M);
gsl_vector * res = gsl_vector_alloc(M);
gsl_permutation * perm = gsl_permutation_alloc(N);
size_t rank;
gsl_matrix_memcpy(QRZT, m);
for (i = 0; i < M; i++)
gsl_vector_set(rhs, i, i + 1.0);
s += gsl_linalg_COD_decomp(QRZT, tau_Q, tau_Z, perm, &rank, work);
s += gsl_linalg_COD_lssolve(QRZT, tau_Q, tau_Z, perm, rank, rhs, x, res);
for (i = 0; i < N; i++)
{
double xi = gsl_vector_get(x, i);
gsl_test_rel(xi, actual[i], eps,
"%s (%3lu,%3lu)[%lu]: %22.18g %22.18g\n",
desc, M, N, i, xi, actual[i]);
}
/* compute residual r = b - m x */
if (M == N)
{
gsl_vector_set_zero(r);
}
else
{
gsl_vector_memcpy(r, rhs);
gsl_blas_dgemv(CblasNoTrans, -1.0, m, x, 1.0, r);
}
for (i = 0; i < N; i++)
{
double r1 = gsl_vector_get(res, i);
double r2 = gsl_vector_get(r, i);
if (fabs(r2) < 1.0e3 * GSL_DBL_EPSILON)
{
gsl_test_abs(r1, r2, 10.0 * eps,
"%s res (%3lu,%3lu)[%lu]: %22.18g %22.18g\n",
desc, M, N, i, r1, r2);
}
else
{
gsl_test_rel(r1, r2, eps,
"%s res (%3lu,%3lu)[%lu]: %22.18g %22.18g\n",
desc, M, N, i, r1, r2);
}
}
gsl_vector_free(r);
gsl_vector_free(res);
gsl_vector_free(x);
gsl_vector_free(tau_Q);
gsl_vector_free(tau_Z);
gsl_matrix_free(QRZT);
gsl_vector_free(rhs);
gsl_vector_free(lhs);
gsl_vector_free(work);
gsl_permutation_free(perm);
return s;
}
int
main()
{
gsl_rng *r = gsl_rng_alloc(gsl_rng_default);
const double tol1 = 1.0e-8;
const double tol2 = 1.0e-3;
gsl_ieee_env_setup();
{
const size_t N = 2000000;
double *data = random_data(N, r);
double data2[] = { 4.0, 7.0, 13.0, 16.0 };
size_t i;
test_basic(2, data, tol1);
test_basic(100, data, tol1);
test_basic(1000, data, tol1);
test_basic(10000, data, tol1);
test_basic(50000, data, tol1);
test_basic(80000, data, tol1);
test_basic(1500000, data, tol1);
test_basic(2000000, data, tol1);
for (i = 0; i < 4; ++i)
data2[i] += 1.0e9;
test_basic(4, data2, tol1);
free(data);
}
{
/* dataset from Jain and Chlamtac paper */
const size_t n_jain = 20;
const double data_jain[] = { 0.02, 0.15, 0.74, 3.39, 0.83,
22.37, 10.15, 15.43, 38.62, 15.92,
34.60, 10.28, 1.47, 0.40, 0.05,
11.39, 0.27, 0.42, 0.09, 11.37 };
double expected_jain = 4.44063435326;
test_quantile(0.5, data_jain, n_jain, expected_jain, tol1, "jain");
}
{
size_t n = 1000000;
double *data = malloc(n * sizeof(double));
double *sorted_data = malloc(n * sizeof(double));
gsl_rstat_workspace *rstat_workspace_p = gsl_rstat_alloc();
double p;
size_t i;
for (i = 0; i < n; ++i)
{
data[i] = gsl_ran_gaussian_tail(r, 1.3, 1.0);
gsl_rstat_add(data[i], rstat_workspace_p);
}
memcpy(sorted_data, data, n * sizeof(double));
gsl_sort(sorted_data, 1, n);
/* test quantile calculation */
for (p = 0.1; p <= 0.9; p += 0.1)
{
double expected = gsl_stats_quantile_from_sorted_data(sorted_data, 1, n, p);
test_quantile(p, data, n, expected, tol2, "gauss");
}
/* test mean, variance */
{
const double expected_mean = gsl_stats_mean(data, 1, n);
const double expected_var = gsl_stats_variance(data, 1, n);
const double expected_sd = gsl_stats_sd(data, 1, n);
const double expected_skew = gsl_stats_skew(data, 1, n);
const double expected_kurtosis = gsl_stats_kurtosis(data, 1, n);
const double expected_median = gsl_stats_quantile_from_sorted_data(sorted_data, 1, n, 0.5);
const double mean = gsl_rstat_mean(rstat_workspace_p);
const double var = gsl_rstat_variance(rstat_workspace_p);
const double sd = gsl_rstat_sd(rstat_workspace_p);
const double skew = gsl_rstat_skew(rstat_workspace_p);
const double kurtosis = gsl_rstat_kurtosis(rstat_workspace_p);
const double median = gsl_rstat_median(rstat_workspace_p);
gsl_test_rel(mean, expected_mean, tol1, "mean");
gsl_test_rel(var, expected_var, tol1, "variance");
gsl_test_rel(sd, expected_sd, tol1, "stddev");
gsl_test_rel(skew, expected_skew, tol1, "skew");
gsl_test_rel(kurtosis, expected_kurtosis, tol1, "kurtosis");
gsl_test_abs(median, expected_median, tol2, "median");
}
free(data);
free(sorted_data);
gsl_rstat_free(rstat_workspace_p);
}
gsl_rng_free(r);
exit (gsl_test_summary());
}
void
FUNCTION (test, func) (size_t stride, size_t N)
{
TYPE (gsl_vector) * v0;
TYPE (gsl_vector) * v;
QUALIFIED_VIEW(gsl_vector,view) view;
size_t i, j;
if (stride == 1)
{
v = FUNCTION (gsl_vector, calloc) (N);
TEST(v->data == 0, "_calloc pointer");
TEST(v->size != N, "_calloc size");
TEST(v->stride != 1, "_calloc stride");
{
int status = (FUNCTION(gsl_vector,isnull)(v) != 1);
TEST (status, "_isnull" DESC " on calloc vector");
status = (FUNCTION(gsl_vector,ispos)(v) != 0);
TEST (status, "_ispos" DESC " on calloc vector");
status = (FUNCTION(gsl_vector,isneg)(v) != 0);
TEST (status, "_isneg" DESC " on calloc vector");
status = (FUNCTION(gsl_vector,isnonneg)(v) != 1);
TEST (status, "_isnonneg" DESC " on calloc vector");
}
FUNCTION (gsl_vector, free) (v); /* free whatever is in v */
}
if (stride == 1)
{
v = FUNCTION (gsl_vector, alloc) (N);
TEST(v->data == 0, "_alloc pointer");
TEST(v->size != N, "_alloc size");
TEST(v->stride != 1, "_alloc stride");
FUNCTION (gsl_vector, free) (v); /* free whatever is in v */
}
if (stride == 1)
{
v0 = FUNCTION (gsl_vector, alloc) (N);
view = FUNCTION (gsl_vector, subvector) (v0, 0, N);
v = &view.vector;
}
else
{
v0 = FUNCTION (gsl_vector, alloc) (N * stride);
for (i = 0; i < N*stride; i++)
{
v0->data[i] = i;
}
view = FUNCTION (gsl_vector, subvector_with_stride) (v0, 0, stride, N);
v = &view.vector;
}
{
int status = 0;
for (i = 0; i < N; i++)
{
FUNCTION (gsl_vector, set) (v, i, (ATOMIC) i);
}
for (i = 0; i < N; i++)
{
if (v->data[i*stride] != (ATOMIC) (i))
status = 1;
};
TEST(status,"_set" DESC " writes into array");
}
{
int status = 0;
for (i = 0; i < N; i++)
{
if (FUNCTION (gsl_vector, get) (v, i) != (ATOMIC) (i))
status = 1;
};
TEST (status, "_get" DESC " reads from array");
}
{
int status = 0;
for (i = 0; i < N; i++)
{
if (FUNCTION (gsl_vector, ptr) (v, i) != v->data + i*stride)
status = 1;
};
TEST (status, "_ptr" DESC " access to array");
}
{
int status = 0;
for (i = 0; i < N; i++)
{
if (FUNCTION (gsl_vector, const_ptr) (v, i) != v->data + i*stride)
status = 1;
};
TEST (status, "_const_ptr" DESC " access to array");
}
{
int status = 0;
for (i = 0; i < N; i++)
{
FUNCTION (gsl_vector, set) (v, i, (ATOMIC) 0);
}
status = (FUNCTION(gsl_vector,isnull)(v) != 1);
TEST (status, "_isnull" DESC " on null vector") ;
status = (FUNCTION(gsl_vector,ispos)(v) != 0);
TEST (status, "_ispos" DESC " on null vector") ;
status = (FUNCTION(gsl_vector,isneg)(v) != 0);
TEST (status, "_isneg" DESC " on null vector") ;
status = (FUNCTION(gsl_vector,isnonneg)(v) != 1);
TEST (status, "_isnonneg" DESC " on null vector") ;
}
{
int status = 0;
for (i = 0; i < N; i++)
{
FUNCTION (gsl_vector, set) (v, i, (ATOMIC) (i % 10));
}
status = (FUNCTION(gsl_vector,isnull)(v) != 0);
TEST (status, "_isnull" DESC " on non-negative vector") ;
status = (FUNCTION(gsl_vector,ispos)(v) != 0);
TEST (status, "_ispos" DESC " on non-negative vector") ;
status = (FUNCTION(gsl_vector,isneg)(v) != 0);
TEST (status, "_isneg" DESC " on non-negative vector") ;
status = (FUNCTION(gsl_vector,isnonneg)(v) != 1);
TEST (status, "_isnonneg" DESC " on non-negative vector") ;
}
#ifndef UNSIGNED
{
int status = 0;
for (i = 0; i < N; i++)
{
ATOMIC vi = (i % 10) - (ATOMIC) 5;
FUNCTION (gsl_vector, set) (v, i, vi);
}
status = (FUNCTION(gsl_vector,isnull)(v) != 0);
TEST (status, "_isnull" DESC " on mixed vector") ;
status = (FUNCTION(gsl_vector,ispos)(v) != 0);
TEST (status, "_ispos" DESC " on mixed vector") ;
status = (FUNCTION(gsl_vector,isneg)(v) != 0);
TEST (status, "_isneg" DESC " on mixed vector") ;
status = (FUNCTION(gsl_vector,isnonneg)(v) != 0);
TEST (status, "_isnonneg" DESC " on mixed vector") ;
}
{
int status = 0;
for (i = 0; i < N; i++)
{
FUNCTION (gsl_vector, set) (v, i, -(ATOMIC) (i % 10));
}
status = (FUNCTION(gsl_vector,isnull)(v) != 0);
TEST (status, "_isnull" DESC " on non-positive vector") ;
status = (FUNCTION(gsl_vector,ispos)(v) != 0);
TEST (status, "_ispos" DESC " on non-positive vector") ;
status = (FUNCTION(gsl_vector,isneg)(v) != 0);
TEST (status, "_isneg" DESC " on non-positive non-null vector") ;
status = (FUNCTION(gsl_vector,isnonneg)(v) != 0);
TEST (status, "_isnonneg" DESC " on non-positive non-null vector") ;
}
#endif
{
int status = 0;
for (i = 0; i < N; i++)
{
FUNCTION (gsl_vector, set) (v, i, (ATOMIC) (i % 10 + 1));
}
status = (FUNCTION(gsl_vector,isnull)(v) != 0);
TEST (status, "_isnull" DESC " on positive vector") ;
status = (FUNCTION(gsl_vector,ispos)(v) != 1);
TEST (status, "_ispos" DESC " on positive vector") ;
status = (FUNCTION(gsl_vector,isneg)(v) != 0);
TEST (status, "_isneg" DESC " on positive vector") ;
status = (FUNCTION(gsl_vector,isnonneg)(v) != 1);
TEST (status, "_isnonneg" DESC " on positive vector") ;
}
#if (!defined(UNSIGNED) && !defined(BASE_CHAR))
{
int status = 0;
for (i = 0; i < N; i++)
{
FUNCTION (gsl_vector, set) (v, i, -(ATOMIC) (i % 10 + 1));
}
status = (FUNCTION(gsl_vector,isnull)(v) != 0);
TEST (status, "_isnull" DESC " on negative vector") ;
status = (FUNCTION(gsl_vector,ispos)(v) != 0);
TEST (status, "_ispos" DESC " on negative vector") ;
status = (FUNCTION(gsl_vector,isneg)(v) != 1);
TEST (status, "_isneg" DESC " on negative vector") ;
status = (FUNCTION(gsl_vector,isnonneg)(v) != 0);
TEST (status, "_isnonneg" DESC " on negative vector") ;
}
#endif
{
int status = 0;
FUNCTION (gsl_vector, set_zero) (v);
for (i = 0; i < N; i++)
{
if (FUNCTION (gsl_vector, get) (v, i) != (ATOMIC)0)
status = 1;
};
TEST (status, "_setzero" DESC " on non-null vector") ;
}
{
int status = 0;
FUNCTION (gsl_vector, set_all) (v, (ATOMIC)27);
for (i = 0; i < N; i++)
{
if (FUNCTION (gsl_vector, get) (v, i) != (ATOMIC) (27))
status = 1;
};
TEST (status, "_setall" DESC " to non-zero value") ;
}
{
int status = 0;
for (i = 0; i < N; i++)
{
FUNCTION (gsl_vector, set_basis) (v, i);
for (j = 0; j < N; j++)
{
if (i == j)
{
if (FUNCTION (gsl_vector, get) (v, j) != (ATOMIC)1)
status = 1 ;
}
else
{
if (FUNCTION (gsl_vector, get) (v, j) != (ATOMIC)(0))
status = 1;
}
};
}
TEST (status, "_setbasis" DESC " over range") ;
}
{
int status = 0;
for (i = 0; i < N; i++)
{
FUNCTION (gsl_vector, set) (v, i, (ATOMIC) i);
}
FUNCTION (gsl_vector, scale) (v, 2.0);
for (i = 0; i < N; i++)
{
if (FUNCTION (gsl_vector, get) (v, i) != (ATOMIC) ((ATOMIC)i*(ATOMIC)2.0))
status = 1;
};
TEST (status, "_scale" DESC " by 2") ;
}
{
int status = 0;
FUNCTION (gsl_vector, add_constant) (v, (ATOMIC)7);
for (i = 0; i < N; i++)
{
if (FUNCTION (gsl_vector, get) (v, i) != (ATOMIC) ((ATOMIC)i*(ATOMIC)2.0 + (ATOMIC)7))
status = 1;
};
TEST (status, "_add_constant" DESC) ;
}
{
int status = 0;
for (i = 0; i < N; i++)
{
FUNCTION (gsl_vector, set) (v, i, (ATOMIC) i);
}
FUNCTION (gsl_vector,swap_elements) (v, 2, 5) ;
status = (FUNCTION(gsl_vector,get)(v,2) != 5) ;
status |= (FUNCTION(gsl_vector,get)(v,5) != 2) ;
FUNCTION (gsl_vector,swap_elements) (v, 2, 5) ;
status |= (FUNCTION(gsl_vector,get)(v,2) != 2) ;
status |= (FUNCTION(gsl_vector,get)(v,5) != 5) ;
TEST (status, "_swap_elements" DESC " (2,5)") ;
}
{
int status = 0;
FUNCTION (gsl_vector,reverse) (v) ;
for (i = 0; i < N; i++)
{
status |= (FUNCTION (gsl_vector, get) (v, i) != (ATOMIC) (N - i - 1));
}
TEST (status, "_reverse" DESC " reverses elements") ;
}
{
int status = 0;
QUALIFIED_VIEW(gsl_vector,view) v1 = FUNCTION(gsl_vector, view_array) (v->data, N*stride);
for (i = 0; i < N; i++)
{
if (FUNCTION (gsl_vector, get) (&v1.vector, i*stride) != FUNCTION (gsl_vector, get) (v, i))
status = 1;
};
TEST (status, "_view_array" DESC);
}
{
int status = 0;
QUALIFIED_VIEW(gsl_vector,view) v1 = FUNCTION(gsl_vector, view_array_with_stride) (v->data, stride, N*stride);
for (i = 0; i < N; i++)
{
if (FUNCTION (gsl_vector, get) (&v1.vector, i) != FUNCTION (gsl_vector, get) (v, i))
status = 1;
};
TEST (status, "_view_array_with_stride" DESC);
}
{
int status = 0;
QUALIFIED_VIEW(gsl_vector,view) v1 = FUNCTION(gsl_vector, subvector) (v, N/3, N/2);
for (i = 0; i < N/2; i++)
{
if (FUNCTION (gsl_vector, get) (&v1.vector, i) != FUNCTION (gsl_vector, get) (v, (N/3) + i))
status = 1;
};
TEST (status, "_view_subvector" DESC);
}
{
int status = 0;
QUALIFIED_VIEW(gsl_vector,view) v1 = FUNCTION(gsl_vector, subvector_with_stride) (v, N/5, 3, N/4);
for (i = 0; i < N/4; i++)
{
if (FUNCTION (gsl_vector, get) (&v1.vector, i) != FUNCTION (gsl_vector, get) (v, (N/5) + 3*i))
status = 1;
};
TEST (status, "_view_subvector_with_stride" DESC);
}
{
BASE exp_max = FUNCTION(gsl_vector,get)(v, 0);
BASE exp_min = FUNCTION(gsl_vector,get)(v, 0);
size_t exp_imax = 0, exp_imin = 0;
for (i = 0; i < N; i++)
{
BASE k = FUNCTION(gsl_vector, get) (v, i) ;
if (k < exp_min) {
exp_min = FUNCTION(gsl_vector, get) (v, i);
exp_imin = i;
}
}
for (i = 0; i < N; i++)
{
BASE k = FUNCTION(gsl_vector, get) (v, i) ;
if (k > exp_max) {
exp_max = FUNCTION(gsl_vector, get) (v, i) ;
exp_imax = i;
}
}
{
BASE max = FUNCTION(gsl_vector, max) (v) ;
TEST (max != exp_max, "_max returns correct maximum value");
}
{
BASE min = FUNCTION(gsl_vector, min) (v) ;
TEST (min != exp_min, "_min returns correct minimum value");
}
{
BASE min, max;
FUNCTION(gsl_vector, minmax) (v, &min, &max);
TEST (max != exp_max, "_minmax returns correct maximum value");
TEST (min != exp_min, "_minmax returns correct minimum value");
}
{
size_t imax = FUNCTION(gsl_vector, max_index) (v) ;
TEST (imax != exp_imax, "_max_index returns correct maximum i");
}
{
size_t imin = FUNCTION(gsl_vector, min_index) (v) ;
TEST (imin != exp_imin, "_min_index returns correct minimum i");
}
{
size_t imin, imax;
FUNCTION(gsl_vector, minmax_index) (v, &imin, &imax);
TEST (imax != exp_imax, "_minmax_index returns correct maximum i");
TEST (imin != exp_imin, "_minmax_index returns correct minimum i");
}
#if FP
i = N/2;
FUNCTION(gsl_vector, set) (v, i, GSL_NAN);
exp_max = GSL_NAN; exp_min = GSL_NAN;
exp_imax = i; exp_imin = i;
{
BASE max = FUNCTION(gsl_vector, max) (v) ;
gsl_test_abs (max, exp_max, 0, "_max returns correct maximum value for NaN");
}
{
BASE min = FUNCTION(gsl_vector, min) (v) ;
gsl_test_abs (min, exp_min, 0, "_min returns correct minimum value for NaN");
}
{
BASE min, max;
FUNCTION(gsl_vector, minmax) (v, &min, &max);
gsl_test_abs (max, exp_max, 0, "_minmax returns correct maximum value for NaN");
gsl_test_abs (min, exp_min, 0, "_minmax returns correct minimum value for NaN");
}
{
size_t imax = FUNCTION(gsl_vector, max_index) (v) ;
TEST (imax != exp_imax, "_max_index returns correct maximum i for NaN");
}
{
size_t imin = FUNCTION(gsl_vector, min_index) (v) ;
TEST (imin != exp_imin, "_min_index returns correct minimum i for NaN");
}
{
size_t imin, imax;
FUNCTION(gsl_vector, minmax_index) (v, &imin, &imax);
TEST (imax != exp_imax, "_minmax_index returns correct maximum i for NaN");
TEST (imin != exp_imin, "_minmax_index returns correct minimum i for NaN");
}
#endif
}
FUNCTION (gsl_vector, free) (v0); /* free whatever is in v */
}
void
test_eigen_gen_results (const gsl_matrix * A, const gsl_matrix * B,
const gsl_vector_complex * alpha,
const gsl_vector * beta,
const gsl_matrix_complex * evec,
size_t count, const char * desc,
const char * desc2)
{
const size_t N = A->size1;
size_t i, j;
gsl_matrix_complex *ma, *mb;
gsl_vector_complex *x, *y;
gsl_complex z_one, z_zero;
ma = gsl_matrix_complex_alloc(N, N);
mb = gsl_matrix_complex_alloc(N, N);
y = gsl_vector_complex_alloc(N);
x = gsl_vector_complex_alloc(N);
/* ma <- A, mb <- B */
for (i = 0; i < N; ++i)
{
for (j = 0; j < N; ++j)
{
gsl_complex z;
GSL_SET_COMPLEX(&z, gsl_matrix_get(A, i, j), 0.0);
gsl_matrix_complex_set(ma, i, j, z);
GSL_SET_COMPLEX(&z, gsl_matrix_get(B, i, j), 0.0);
gsl_matrix_complex_set(mb, i, j, z);
}
}
GSL_SET_COMPLEX(&z_one, 1.0, 0.0);
GSL_SET_COMPLEX(&z_zero, 0.0, 0.0);
/* check eigenvalues */
for (i = 0; i < N; ++i)
{
gsl_vector_complex_const_view vi =
gsl_matrix_complex_const_column(evec, i);
gsl_complex ai = gsl_vector_complex_get(alpha, i);
double bi = gsl_vector_get(beta, i);
/* compute x = alpha * B * v */
gsl_blas_zgemv(CblasNoTrans, z_one, mb, &vi.vector, z_zero, x);
gsl_blas_zscal(ai, x);
/* compute y = beta * A v */
gsl_blas_zgemv(CblasNoTrans, z_one, ma, &vi.vector, z_zero, y);
gsl_blas_zdscal(bi, y);
/* now test if y = x */
for (j = 0; j < N; ++j)
{
gsl_complex xj = gsl_vector_complex_get(x, j);
gsl_complex yj = gsl_vector_complex_get(y, j);
gsl_test_abs(GSL_REAL(yj), GSL_REAL(xj), 1e8*GSL_DBL_EPSILON,
"gen(N=%u,cnt=%u), %s, eigenvalue(%d,%d), real, %s",
N, count, desc, i, j, desc2);
gsl_test_abs(GSL_IMAG(yj), GSL_IMAG(xj), 1e8*GSL_DBL_EPSILON,
"gen(N=%u,cnt=%u), %s, eigenvalue(%d,%d), real, %s",
N, count, desc, i, j, desc2);
}
}
gsl_matrix_complex_free(ma);
gsl_matrix_complex_free(mb);
gsl_vector_complex_free(y);
gsl_vector_complex_free(x);
} /* test_eigen_gen_results() */
void
test2d (void)
{
double xr[MR + 1] =
{ 0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0, 8.0, 9.0, 10.0 };
double yr[NR + 1] = { 90.0, 91.0, 92.0, 93.0, 94.0, 95.0 };
gsl_histogram2d *h, *h1, *g, *hr;
size_t i, j, k;
gsl_ieee_env_setup ();
h = gsl_histogram2d_calloc (M, N);
h1 = gsl_histogram2d_calloc (M, N);
g = gsl_histogram2d_calloc (M, N);
gsl_test (h->xrange == 0,
"gsl_histogram2d_calloc returns valid xrange pointer");
gsl_test (h->yrange == 0,
"gsl_histogram2d_calloc returns valid yrange pointer");
gsl_test (h->bin == 0, "gsl_histogram2d_calloc returns valid bin pointer");
gsl_test (h->nx != M, "gsl_histogram2d_calloc returns valid nx");
gsl_test (h->ny != N, "gsl_histogram2d_calloc returns valid ny");
hr = gsl_histogram2d_calloc_range (MR, NR, xr, yr);
gsl_test (hr->xrange == 0,
"gsl_histogram2d_calloc_range returns valid xrange pointer");
gsl_test (hr->yrange == 0,
"gsl_histogram2d_calloc_range returns valid yrange pointer");
gsl_test (hr->bin == 0,
"gsl_histogram2d_calloc_range returns valid bin pointer");
gsl_test (hr->nx != MR, "gsl_histogram2d_calloc_range returns valid nx");
gsl_test (hr->ny != NR, "gsl_histogram2d_calloc_range returns valid ny");
{
int status = 0;
for (i = 0; i <= MR; i++)
{
if (hr->xrange[i] != xr[i])
{
status = 1;
}
};
gsl_test (status,
"gsl_histogram2d_calloc_range creates xrange");
}
{
int status = 0;
for (i = 0; i <= NR; i++)
{
if (hr->yrange[i] != yr[i])
{
status = 1;
}
};
gsl_test (status,
"gsl_histogram2d_calloc_range creates yrange");
}
for (i = 0; i <= MR; i++)
{
hr->xrange[i] = 0.0;
}
for (i = 0; i <= NR; i++)
{
hr->yrange[i] = 0.0;
}
{
int status = gsl_histogram2d_set_ranges (hr, xr, MR + 1, yr, NR + 1);
for (i = 0; i <= MR; i++)
{
if (hr->xrange[i] != xr[i])
{
status = 1;
}
};
gsl_test (status, "gsl_histogram2d_set_ranges sets xrange");
}
{
int status = 0;
for (i = 0; i <= NR; i++)
{
if (hr->yrange[i] != yr[i])
{
status = 1;
}
};
gsl_test (status, "gsl_histogram2d_set_ranges sets yrange");
}
k = 0;
for (i = 0; i < M; i++)
{
for (j = 0; j < N; j++)
{
k++;
gsl_histogram2d_accumulate (h, (double) i, (double) j, (double) k);
};
}
{
int status = 0;
k = 0;
for (i = 0; i < M; i++)
{
for (j = 0; j < N; j++)
{
k++;
if (h->bin[i * N + j] != (double) k)
{
status = 1;
}
}
}
gsl_test (status,
"gsl_histogram2d_accumulate writes into array");
}
{
int status = 0;
k = 0;
for (i = 0; i < M; i++)
{
for (j = 0; j < N; j++)
{
k++;
if (gsl_histogram2d_get (h, i, j) != (double) k)
status = 1;
};
}
gsl_test (status, "gsl_histogram2d_get reads from array");
}
for (i = 0; i <= M; i++)
{
h1->xrange[i] = 100.0 + i;
}
for (i = 0; i <= N; i++)
{
h1->yrange[i] = 900.0 + i * i;
}
gsl_histogram2d_memcpy (h1, h);
{
int status = 0;
for (i = 0; i <= M; i++)
{
if (h1->xrange[i] != h->xrange[i])
status = 1;
};
gsl_test (status, "gsl_histogram2d_memcpy copies bin xranges");
}
{
int status = 0;
for (i = 0; i <= N; i++)
{
if (h1->yrange[i] != h->yrange[i])
status = 1;
};
gsl_test (status, "gsl_histogram2d_memcpy copies bin yranges");
}
{
int status = 0;
for (i = 0; i < M; i++)
{
for (j = 0; j < N; j++)
{
if (gsl_histogram2d_get (h1, i, j) !=
gsl_histogram2d_get (h, i, j))
status = 1;
}
}
gsl_test (status, "gsl_histogram2d_memcpy copies bin values");
}
gsl_histogram2d_free (h1);
h1 = gsl_histogram2d_clone (h);
{
int status = 0;
for (i = 0; i <= M; i++)
{
if (h1->xrange[i] != h->xrange[i])
status = 1;
};
gsl_test (status, "gsl_histogram2d_clone copies bin xranges");
}
{
int status = 0;
for (i = 0; i <= N; i++)
{
if (h1->yrange[i] != h->yrange[i])
status = 1;
};
gsl_test (status, "gsl_histogram2d_clone copies bin yranges");
}
{
int status = 0;
for (i = 0; i < M; i++)
{
for (j = 0; j < N; j++)
{
if (gsl_histogram2d_get (h1, i, j) !=
gsl_histogram2d_get (h, i, j))
status = 1;
}
}
gsl_test (status, "gsl_histogram2d_clone copies bin values");
}
gsl_histogram2d_reset (h);
{
int status = 0;
for (i = 0; i < M * N; i++)
{
if (h->bin[i] != 0)
status = 1;
}
gsl_test (status, "gsl_histogram2d_reset zeros array");
}
gsl_histogram2d_free (h);
h = gsl_histogram2d_calloc (M1, N1);
{
int status = 0;
for (i = 0; i < M1; i++)
{
for (j = 0; j < N1; j++)
{
gsl_histogram2d_increment (h, (double) i, (double) j);
for (k = 0; k <= i * N1 + j; k++)
{
if (h->bin[k] != 1)
{
status = 1;
}
}
for (k = i * N1 + j + 1; k < M1 * N1; k++)
{
if (h->bin[k] != 0)
{
status = 1;
}
}
}
}
gsl_test (status, "gsl_histogram2d_increment increases bin value");
}
gsl_histogram2d_free (h);
h = gsl_histogram2d_calloc (M, N);
{
int status = 0;
for (i = 0; i < M; i++)
{
double x0 = 0, x1 = 0;
gsl_histogram2d_get_xrange (h, i, &x0, &x1);
if (x0 != i || x1 != i + 1)
{
status = 1;
}
}
gsl_test (status,
"gsl_histogram2d_get_xlowerlimit and xupperlimit");
}
{
int status = 0;
for (i = 0; i < N; i++)
{
double y0 = 0, y1 = 0;
gsl_histogram2d_get_yrange (h, i, &y0, &y1);
if (y0 != i || y1 != i + 1)
{
status = 1;
}
}
gsl_test (status,
"gsl_histogram2d_get_ylowerlimit and yupperlimit");
}
{
int status = 0;
if (gsl_histogram2d_xmax (h) != M)
status = 1;
gsl_test (status, "gsl_histogram2d_xmax");
}
{
int status = 0;
if (gsl_histogram2d_xmin (h) != 0)
status = 1;
gsl_test (status, "gsl_histogram2d_xmin");
}
{
int status = 0;
if (gsl_histogram2d_nx (h) != M)
status = 1;
gsl_test (status, "gsl_histogram2d_nx");
}
{
int status = 0;
if (gsl_histogram2d_ymax (h) != N)
status = 1;
gsl_test (status, "gsl_histogram2d_ymax");
}
{
int status = 0;
if (gsl_histogram2d_ymin (h) != 0)
status = 1;
gsl_test (status, "gsl_histogram2d_ymin");
}
{
int status = 0;
if (gsl_histogram2d_ny (h) != N)
status = 1;
gsl_test (status, "gsl_histogram2d_ny");
}
h->bin[3 * N + 2] = 123456.0;
h->bin[4 * N + 3] = -654321;
{
double max = gsl_histogram2d_max_val (h);
gsl_test (max != 123456.0, "gsl_histogram2d_max_val finds maximum value");
}
{
double min = gsl_histogram2d_min_val (h);
gsl_test (min != -654321.0,
"gsl_histogram2d_min_val finds minimum value");
}
{
size_t imax, jmax;
gsl_histogram2d_max_bin (h, &imax, &jmax);
gsl_test (imax != 3
|| jmax != 2,
"gsl_histogram2d_max_bin finds maximum value bin");
}
{
size_t imin, jmin;
gsl_histogram2d_min_bin (h, &imin, &jmin);
gsl_test (imin != 4
|| jmin != 3, "gsl_histogram2d_min_bin find minimum value bin");
}
for (i = 0; i < M * N; i++)
{
h->bin[i] = i + 27;
g->bin[i] = (i + 27) * (i + 1);
}
{
double sum = gsl_histogram2d_sum (h);
gsl_test (sum != N * M * 27 + ((N * M - 1) * N * M) / 2,
"gsl_histogram2d_sum sums all bin values");
}
{
/* first test... */
const double xpos = 0.6;
const double ypos = 0.85;
double xmean;
double ymean;
size_t xbin;
size_t ybin;
gsl_histogram2d *h3 = gsl_histogram2d_alloc (M, N);
gsl_histogram2d_set_ranges_uniform (h3, 0, 1, 0, 1);
gsl_histogram2d_increment (h3, xpos, ypos);
gsl_histogram2d_find (h3, xpos, ypos, &xbin, &ybin);
xmean = gsl_histogram2d_xmean (h3);
ymean = gsl_histogram2d_ymean (h3);
{
double expected_xmean = (h3->xrange[xbin] + h3->xrange[xbin + 1]) / 2.0;
double expected_ymean = (h3->yrange[ybin] + h3->yrange[ybin + 1]) / 2.0;
gsl_test_abs (xmean, expected_xmean, 100.0 * GSL_DBL_EPSILON,
"gsl_histogram2d_xmean");
gsl_test_abs (ymean, expected_ymean, 100.0 * GSL_DBL_EPSILON,
"gsl_histogram2d_ymean");
};
gsl_histogram2d_free (h3);
}
{
/* test it with bivariate normal distribution */
const double xmean = 0.7;
const double ymean = 0.7;
const double xsigma = 0.1;
const double ysigma = 0.1;
const double correl = 0.5;
const double norm =
10.0 / M_PI / xsigma / ysigma / sqrt (1.0 - correl * correl);
size_t xbin;
size_t ybin;
gsl_histogram2d *h3 = gsl_histogram2d_alloc (M, N);
gsl_histogram2d_set_ranges_uniform (h3, 0, 1, 0, 1);
/* initialize with 2d gauss pdf in two directions */
for (xbin = 0; xbin < M; xbin++)
{
double xi =
((h3->xrange[xbin] + h3->xrange[xbin + 1]) / 2.0 - xmean) / xsigma;
for (ybin = 0; ybin < N; ybin++)
{
double yi =
((h3->yrange[ybin] + h3->yrange[ybin + 1]) / 2.0 -
ymean) / ysigma;
double prob =
norm * exp (-(xi * xi - 2.0 * correl * xi * yi + yi * yi) /
2.0 / (1 - correl * correl));
h3->bin[xbin * N + ybin] = prob;
}
}
{
double xs = gsl_histogram2d_xsigma (h3);
double ys = gsl_histogram2d_ysigma (h3);
/* evaluate results and compare with parameters */
gsl_test_abs (gsl_histogram2d_xmean (h3), xmean, 2.0/M,
"gsl_histogram2d_xmean histogram mean(x)");
gsl_test_abs (gsl_histogram2d_ymean (h3), ymean, 2.0/N,
"gsl_histogram2d_ymean histogram mean(y)");
gsl_test_abs (xs, xsigma, 2.0/M,
"gsl_histogram2d_xsigma histogram stdev(x)");
gsl_test_abs (ys, ysigma, 2.0/N,
"gsl_histogram2d_ysigma histogram stdev(y)");
gsl_test_abs (gsl_histogram2d_cov (h3) / xs / ys, correl,
2.0/((M < N) ? M : N),
"gsl_histogram2d_cov histogram covariance");
}
gsl_histogram2d_free (h3);
}
gsl_histogram2d_memcpy (h1, g);
gsl_histogram2d_add (h1, h);
{
int status = 0;
for (i = 0; i < M * N; i++)
{
if (h1->bin[i] != g->bin[i] + h->bin[i])
status = 1;
}
gsl_test (status, "gsl_histogram2d_add histogram addition");
}
gsl_histogram2d_memcpy (h1, g);
gsl_histogram2d_sub (h1, h);
{
int status = 0;
for (i = 0; i < M * N; i++)
{
if (h1->bin[i] != g->bin[i] - h->bin[i])
status = 1;
}
gsl_test (status, "gsl_histogram2d_sub histogram subtraction");
}
gsl_histogram2d_memcpy (h1, g);
gsl_histogram2d_mul (h1, h);
{
int status = 0;
for (i = 0; i < M * N; i++)
{
if (h1->bin[i] != g->bin[i] * h->bin[i])
status = 1;
}
gsl_test (status, "gsl_histogram2d_mul histogram multiplication");
}
gsl_histogram2d_memcpy (h1, g);
gsl_histogram2d_div (h1, h);
{
int status = 0;
for (i = 0; i < M * N; i++)
{
if (h1->bin[i] != g->bin[i] / h->bin[i])
status = 1;
}
gsl_test (status, "gsl_histogram2d_div histogram division");
}
gsl_histogram2d_memcpy (h1, g);
gsl_histogram2d_scale (h1, 0.5);
{
int status = 0;
for (i = 0; i < M * N; i++)
{
if (h1->bin[i] != 0.5 * g->bin[i])
status = 1;
}
gsl_test (status, "gsl_histogram2d_scale histogram scaling");
}
gsl_histogram2d_memcpy (h1, g);
gsl_histogram2d_shift (h1, 0.25);
{
int status = 0;
for (i = 0; i < M * N; i++)
{
if (h1->bin[i] != 0.25 + g->bin[i])
status = 1;
}
gsl_test (status, "gsl_histogram2d_shift histogram shift");
}
gsl_histogram2d_free (h); /* free whatever is in h */
h = gsl_histogram2d_calloc_uniform (M1, N1, 0.0, 5.0, 0.0, 5.0);
gsl_test (h->xrange == 0,
"gsl_histogram2d_calloc_uniform returns valid range pointer");
gsl_test (h->yrange == 0,
"gsl_histogram2d_calloc_uniform returns valid range pointer");
gsl_test (h->bin == 0,
"gsl_histogram2d_calloc_uniform returns valid bin pointer");
gsl_test (h->nx != M1, "gsl_histogram2d_calloc_uniform returns valid nx");
gsl_test (h->ny != N1, "gsl_histogram2d_calloc_uniform returns valid ny");
gsl_histogram2d_accumulate (h, 0.0, 3.01, 1.0);
gsl_histogram2d_accumulate (h, 0.1, 2.01, 2.0);
gsl_histogram2d_accumulate (h, 0.2, 1.01, 3.0);
gsl_histogram2d_accumulate (h, 0.3, 0.01, 4.0);
{
size_t i1, i2, i3, i4;
size_t j1, j2, j3, j4;
double expected;
int status;
status = gsl_histogram2d_find (h, 0.0, 3.01, &i1, &j1);
status = gsl_histogram2d_find (h, 0.1, 2.01, &i2, &j2);
status = gsl_histogram2d_find (h, 0.2, 1.01, &i3, &j3);
status = gsl_histogram2d_find (h, 0.3, 0.01, &i4, &j4);
for (i = 0; i < M1; i++)
{
for (j = 0; j < N1; j++)
{
if (i == i1 && j == j1)
{
expected = 1.0;
}
else if (i == i2 && j == j2)
{
expected = 2.0;
}
else if (i == i3 && j == j3)
{
expected = 3.0;
}
else if (i == i4 && j == j4)
{
expected = 4.0;
}
else
{
expected = 0.0;
}
if (h->bin[i * N1 + j] != expected)
{
status = 1;
}
}
}
gsl_test (status, "gsl_histogram2d_find returns index");
}
{
FILE *f = fopen ("test.txt", "w");
gsl_histogram2d_fprintf (f, h, "%.19e", "%.19e");
fclose (f);
}
{
FILE *f = fopen ("test.txt", "r");
gsl_histogram2d *hh = gsl_histogram2d_calloc (M1, N1);
int status = 0;
gsl_histogram2d_fscanf (f, hh);
for (i = 0; i <= M1; i++)
{
if (h->xrange[i] != hh->xrange[i])
{
printf ("xrange[%d] : %g orig vs %g\n",
(int) i, h->xrange[i], hh->xrange[i]);
status = 1;
}
}
for (j = 0; j <= N1; j++)
{
if (h->yrange[j] != hh->yrange[j])
{
printf ("yrange[%d] : %g orig vs %g\n",
(int) j, h->yrange[j], hh->yrange[j]);
status = 1;
}
}
for (i = 0; i < M1 * N1; i++)
{
if (h->bin[i] != hh->bin[i])
{
printf ("bin[%d] : %g orig vs %g\n",
(int) i, h->bin[i], hh->bin[i]);
status = 1;
}
}
gsl_test (status, "gsl_histogram2d_fprintf and fscanf");
gsl_histogram2d_free (hh);
fclose (f);
}
{
FILE *f = fopen ("test.dat", "wb");
gsl_histogram2d_fwrite (f, h);
fclose (f);
}
{
FILE *f = fopen ("test.dat", "rb");
gsl_histogram2d *hh = gsl_histogram2d_calloc (M1, N1);
int status = 0;
gsl_histogram2d_fread (f, hh);
for (i = 0; i <= M1; i++)
{
if (h->xrange[i] != hh->xrange[i])
{
printf ("xrange[%d] : %g orig vs %g\n",
(int) i, h->xrange[i], hh->xrange[i]);
status = 1;
}
}
for (j = 0; j <= N1; j++)
{
if (h->yrange[j] != hh->yrange[j])
{
printf ("yrange[%d] : %g orig vs %g\n",
(int) j, h->yrange[j], hh->yrange[j]);
status = 1;
}
}
for (i = 0; i < M1 * N1; i++)
{
if (h->bin[i] != hh->bin[i])
{
printf ("bin[%d] : %g orig vs %g\n",
(int) i, h->bin[i], hh->bin[i]);
status = 1;
}
}
gsl_test (status, "gsl_histogram2d_fwrite and fread");
gsl_histogram2d_free (hh);
fclose (f);
}
gsl_histogram2d_free (h);
gsl_histogram2d_free (h1);
gsl_histogram2d_free (g);
gsl_histogram2d_free (hr);
}
