int
gsl_sf_multiply_e(const double x, const double y, gsl_sf_result * result)
{
const double ax = fabs(x);
const double ay = fabs(y);
if(x == 0.0 || y == 0.0) {
/* It is necessary to eliminate this immediately.
*/
result->val = 0.0;
result->err = 0.0;
return GSL_SUCCESS;
}
else if((ax <= 1.0 && ay >= 1.0) || (ay <= 1.0 && ax >= 1.0)) {
/* Straddling 1.0 is always safe.
*/
result->val = x*y;
result->err = 2.0 * GSL_DBL_EPSILON * fabs(result->val);
return GSL_SUCCESS;
}
else {
const double f = 1.0 - 2.0 * GSL_DBL_EPSILON;
const double min = GSL_MIN_DBL(fabs(x), fabs(y));
const double max = GSL_MAX_DBL(fabs(x), fabs(y));
if(max < 0.9 * GSL_SQRT_DBL_MAX || min < (f * DBL_MAX)/max) {
result->val = GSL_COERCE_DBL(x*y);
result->err = 2.0 * GSL_DBL_EPSILON * fabs(result->val);
CHECK_UNDERFLOW(result);
return GSL_SUCCESS;
}
else {
OVERFLOW_ERROR(result);
}
}
}
static int
qag (const gsl_function * f,
const double a, const double b,
const double epsabs, const double epsrel,
const size_t limit,
gsl_integration_workspace * workspace,
double *result, double *abserr,
gsl_integration_rule * q)
{
double area, errsum;
double result0, abserr0, resabs0, resasc0;
double tolerance;
size_t iteration = 0;
int roundoff_type1 = 0, roundoff_type2 = 0, error_type = 0;
double round_off;
/* Initialize results */
initialise (workspace, a, b);
*result = 0;
*abserr = 0;
if (limit > workspace->limit)
{
GSL_ERROR ("iteration limit exceeds available workspace", GSL_EINVAL) ;
}
if (epsabs <= 0 && (epsrel < 50 * GSL_DBL_EPSILON || epsrel < 0.5e-28))
{
GSL_ERROR ("tolerance cannot be acheived with given epsabs and epsrel",
GSL_EBADTOL);
}
/* perform the first integration */
q (f, a, b, &result0, &abserr0, &resabs0, &resasc0);
set_initial_result (workspace, result0, abserr0);
/* Test on accuracy */
tolerance = GSL_MAX_DBL (epsabs, epsrel * fabs (result0));
/* need IEEE rounding here to match original quadpack behavior */
round_off = GSL_COERCE_DBL (50 * GSL_DBL_EPSILON * resabs0);
if (abserr0 <= round_off && abserr0 > tolerance)
{
*result = result0;
*abserr = abserr0;
GSL_ERROR ("cannot reach tolerance because of roundoff error "
"on first attempt", GSL_EROUND);
}
else if ((abserr0 <= tolerance && abserr0 != resasc0) || abserr0 == 0.0)
{
*result = result0;
*abserr = abserr0;
return GSL_SUCCESS;
}
else if (limit == 1)
{
*result = result0;
*abserr = abserr0;
GSL_ERROR ("a maximum of one iteration was insufficient", GSL_EMAXITER);
}
area = result0;
errsum = abserr0;
iteration = 1;
do
{
double a1, b1, a2, b2;
double a_i, b_i, r_i, e_i;
double area1 = 0, area2 = 0, area12 = 0;
double error1 = 0, error2 = 0, error12 = 0;
double resasc1, resasc2;
double resabs1, resabs2;
/* Bisect the subinterval with the largest error estimate */
retrieve (workspace, &a_i, &b_i, &r_i, &e_i);
a1 = a_i;
b1 = 0.5 * (a_i + b_i);
a2 = b1;
b2 = b_i;
q (f, a1, b1, &area1, &error1, &resabs1, &resasc1);
q (f, a2, b2, &area2, &error2, &resabs2, &resasc2);
area12 = area1 + area2;
error12 = error1 + error2;
errsum += (error12 - e_i);
area += area12 - r_i;
if (resasc1 != error1 && resasc2 != error2)
{
double delta = r_i - area12;
if (fabs (delta) <= 1.0e-5 * fabs (area12) && error12 >= 0.99 * e_i)
{
roundoff_type1++;
}
if (iteration >= 10 && error12 > e_i)
{
roundoff_type2++;
}
}
tolerance = GSL_MAX_DBL (epsabs, epsrel * fabs (area));
if (errsum > tolerance)
{
if (roundoff_type1 >= 6 || roundoff_type2 >= 20)
{
error_type = 2; /* round off error */
}
/* set error flag in the case of bad integrand behaviour at
a point of the integration range */
if (subinterval_too_small (a1, a2, b2))
{
error_type = 3;
}
}
update (workspace, a1, b1, area1, error1, a2, b2, area2, error2);
retrieve (workspace, &a_i, &b_i, &r_i, &e_i);
iteration++;
}
while (iteration < limit && !error_type && errsum > tolerance);
*result = sum_results (workspace);
*abserr = errsum;
if (errsum <= tolerance)
{
return GSL_SUCCESS;
}
else if (error_type == 2)
{
GSL_ERROR ("roundoff error prevents tolerance from being achieved",
GSL_EROUND);
}
else if (error_type == 3)
{
GSL_ERROR ("bad integrand behavior found in the integration interval",
GSL_ESING);
}
else if (iteration == limit)
{
GSL_ERROR ("maximum number of subdivisions reached", GSL_EMAXITER);
}
else
{
GSL_ERROR ("could not integrate function", GSL_EFAILED);
}
}
/* Evolution framework method.
*
* Uses an adaptive step control object
*/
int
gsl_odeiv_evolve_apply (gsl_odeiv_evolve * e,
gsl_odeiv_control * con,
gsl_odeiv_step * step,
const gsl_odeiv_system * dydt,
double *t, double t1, double *h, double y[])
{
const double t0 = *t;
double h0 = *h;
int step_status;
int final_step = 0;
double dt = t1 - t0; /* remaining time, possibly less than h */
if (e->dimension != step->dimension)
{
GSL_ERROR ("step dimension must match evolution size", GSL_EINVAL);
}
if ((dt < 0.0 && h0 > 0.0) || (dt > 0.0 && h0 < 0.0))
{
GSL_ERROR ("step direction must match interval direction", GSL_EINVAL);
}
/* No need to copy if we cannot control the step size. */
if (con != NULL)
{
DBL_MEMCPY (e->y0, y, e->dimension);
}
/* Calculate initial dydt once if the method can benefit. */
if (step->type->can_use_dydt_in)
{
int status = GSL_ODEIV_FN_EVAL (dydt, t0, y, e->dydt_in);
if (status)
{
return status;
}
}
try_step:
if ((dt >= 0.0 && h0 > dt) || (dt < 0.0 && h0 < dt))
{
h0 = dt;
final_step = 1;
}
else
{
final_step = 0;
}
if (step->type->can_use_dydt_in)
{
step_status =
gsl_odeiv_step_apply (step, t0, h0, y, e->yerr, e->dydt_in,
e->dydt_out, dydt);
}
else
{
step_status =
gsl_odeiv_step_apply (step, t0, h0, y, e->yerr, NULL, e->dydt_out,
dydt);
}
/* Check for stepper internal failure */
if (step_status != GSL_SUCCESS)
{
*h = h0; /* notify user of step-size which caused the failure */
return step_status;
}
e->count++;
e->last_step = h0;
if (final_step)
{
*t = t1;
}
else
{
*t = t0 + h0;
}
if (con != NULL)
{
/* Check error and attempt to adjust the step. */
double h_old = h0;
const int hadjust_status
= gsl_odeiv_control_hadjust (con, step, y, e->yerr, e->dydt_out, &h0);
if (hadjust_status == GSL_ODEIV_HADJ_DEC)
{
/* Check that the reported status is correct (i.e. an actual
decrease in h0 occured) and the suggested h0 will change
the time by at least 1 ulp */
double t_curr = GSL_COERCE_DBL(*t);
double t_next = GSL_COERCE_DBL((*t) + h0);
if (fabs(h0) < fabs(h_old) && t_next != t_curr)
{
/* Step was decreased. Undo step, and try again with new h0. */
DBL_MEMCPY (y, e->y0, dydt->dimension);
e->failed_steps++;
goto try_step;
}
else
{
h0 = h_old; /* keep current step size */
}
}
}
*h = h0; /* suggest step size for next time-step */
return step_status;
}
int
gsl_linalg_SV_decomp_jacobi (gsl_matrix * A, gsl_matrix * Q, gsl_vector * S)
{
if (A->size1 < A->size2)
{
/* FIXME: only implemented M>=N case so far */
GSL_ERROR ("svd of MxN matrix, M<N, is not implemented", GSL_EUNIMPL);
}
else if (Q->size1 != A->size2)
{
GSL_ERROR ("square matrix Q must match second dimension of matrix A",
GSL_EBADLEN);
}
else if (Q->size1 != Q->size2)
{
GSL_ERROR ("matrix Q must be square", GSL_ENOTSQR);
}
else if (S->size != A->size2)
{
GSL_ERROR ("length of vector S must match second dimension of matrix A",
GSL_EBADLEN);
}
else
{
const size_t M = A->size1;
const size_t N = A->size2;
size_t i, j, k;
/* Initialize the rotation counter and the sweep counter. */
int count = 1;
int sweep = 0;
int sweepmax = 5*N;
double tolerance = 10 * M * GSL_DBL_EPSILON;
/* Always do at least 12 sweeps. */
sweepmax = GSL_MAX (sweepmax, 12);
/* Set Q to the identity matrix. */
gsl_matrix_set_identity (Q);
/* Store the column error estimates in S, for use during the
orthogonalization */
for (j = 0; j < N; j++)
{
gsl_vector_view cj = gsl_matrix_column (A, j);
double sj = gsl_blas_dnrm2 (&cj.vector);
gsl_vector_set(S, j, GSL_DBL_EPSILON * sj);
}
/* Orthogonalize A by plane rotations. */
while (count > 0 && sweep <= sweepmax)
{
/* Initialize rotation counter. */
count = N * (N - 1) / 2;
for (j = 0; j < N - 1; j++)
{
for (k = j + 1; k < N; k++)
{
double a = 0.0;
double b = 0.0;
double p = 0.0;
double q = 0.0;
double cosine, sine;
double v;
double abserr_a, abserr_b;
int sorted, orthog, noisya, noisyb;
gsl_vector_view cj = gsl_matrix_column (A, j);
gsl_vector_view ck = gsl_matrix_column (A, k);
gsl_blas_ddot (&cj.vector, &ck.vector, &p);
p *= 2.0 ; /* equation 9a: p = 2 x.y */
a = gsl_blas_dnrm2 (&cj.vector);
b = gsl_blas_dnrm2 (&ck.vector);
q = a * a - b * b;
v = hypot(p, q);
/* test for columns j,k orthogonal, or dominant errors */
abserr_a = gsl_vector_get(S,j);
abserr_b = gsl_vector_get(S,k);
sorted = (GSL_COERCE_DBL(a) >= GSL_COERCE_DBL(b));
orthog = (fabs (p) <= tolerance * GSL_COERCE_DBL(a * b));
noisya = (a < abserr_a);
noisyb = (b < abserr_b);
if (sorted && (orthog || noisya || noisyb))
{
count--;
continue;
}
/* calculate rotation angles */
if (v == 0 || !sorted)
{
cosine = 0.0;
sine = 1.0;
}
else
{
cosine = sqrt((v + q) / (2.0 * v));
sine = p / (2.0 * v * cosine);
}
/* apply rotation to A */
for (i = 0; i < M; i++)
{
const double Aik = gsl_matrix_get (A, i, k);
const double Aij = gsl_matrix_get (A, i, j);
gsl_matrix_set (A, i, j, Aij * cosine + Aik * sine);
gsl_matrix_set (A, i, k, -Aij * sine + Aik * cosine);
}
gsl_vector_set(S, j, fabs(cosine) * abserr_a + fabs(sine) * abserr_b);
gsl_vector_set(S, k, fabs(sine) * abserr_a + fabs(cosine) * abserr_b);
/* apply rotation to Q */
for (i = 0; i < N; i++)
{
const double Qij = gsl_matrix_get (Q, i, j);
const double Qik = gsl_matrix_get (Q, i, k);
gsl_matrix_set (Q, i, j, Qij * cosine + Qik * sine);
gsl_matrix_set (Q, i, k, -Qij * sine + Qik * cosine);
}
}
}
/* Sweep completed. */
sweep++;
}
/*
* Orthogonalization complete. Compute singular values.
*/
{
double prev_norm = -1.0;
for (j = 0; j < N; j++)
{
gsl_vector_view column = gsl_matrix_column (A, j);
double norm = gsl_blas_dnrm2 (&column.vector);
/* Determine if singular value is zero, according to the
criteria used in the main loop above (i.e. comparison
with norm of previous column). */
if (norm == 0.0 || prev_norm == 0.0
|| (j > 0 && norm <= tolerance * prev_norm))
{
gsl_vector_set (S, j, 0.0); /* singular */
gsl_vector_set_zero (&column.vector); /* annihilate column */
prev_norm = 0.0;
}
else
{
gsl_vector_set (S, j, norm); /* non-singular */
gsl_vector_scale (&column.vector, 1.0 / norm); /* normalize column */
prev_norm = norm;
}
}
}
if (count > 0)
{
/* reached sweep limit */
GSL_ERROR ("Jacobi iterations did not reach desired tolerance",
GSL_ETOL);
}
return GSL_SUCCESS;
}
}
/* Evolution framework method.
*
* Uses an adaptive step control object
*/
int
gsl_odeiv2_evolve_apply (gsl_odeiv2_evolve * e,
gsl_odeiv2_control * con,
gsl_odeiv2_step * step,
const gsl_odeiv2_system * dydt,
double *t, double t1, double *h, double y[])
{
const double t0 = *t;
double h0 = *h;
int step_status;
int final_step = 0;
double dt = t1 - t0; /* remaining time, possibly less than h */
if (e->dimension != step->dimension)
{
GSL_ERROR ("step dimension must match evolution size", GSL_EINVAL);
}
if ((dt < 0.0 && h0 > 0.0) || (dt > 0.0 && h0 < 0.0))
{
GSL_ERROR ("step direction must match interval direction", GSL_EINVAL);
}
/* Save y in case of failure in a step */
DBL_MEMCPY (e->y0, y, e->dimension);
/* Calculate initial dydt once or reuse previous value if the method
can benefit. */
if (step->type->can_use_dydt_in)
{
if (e->count == 0)
{
int status = GSL_ODEIV_FN_EVAL (dydt, t0, y, e->dydt_in);
if (status)
{
return status;
}
}
else
{
DBL_MEMCPY (e->dydt_in, e->dydt_out, e->dimension);
}
}
try_step:
if ((dt >= 0.0 && h0 > dt) || (dt < 0.0 && h0 < dt))
{
h0 = dt;
final_step = 1;
}
else
{
final_step = 0;
}
if (step->type->can_use_dydt_in)
{
step_status =
gsl_odeiv2_step_apply (step, t0, h0, y, e->yerr, e->dydt_in,
e->dydt_out, dydt);
}
else
{
step_status =
gsl_odeiv2_step_apply (step, t0, h0, y, e->yerr, NULL, e->dydt_out,
dydt);
}
/* Return if stepper indicates a pointer or user function failure */
if (step_status == GSL_EFAULT || step_status == GSL_EBADFUNC)
{
return step_status;
}
/* Check for stepper internal failure */
if (step_status != GSL_SUCCESS)
{
/* Stepper was unable to calculate step. Try decreasing step size. */
double h_old = h0;
h0 *= 0.5;
#ifdef DEBUG
printf ("-- gsl_odeiv2_evolve_apply h0=%.5e\n", h0);
#endif
/* Check that an actual decrease in h0 occured and the
suggested h0 will change the time by at least 1 ulp */
{
double t_curr = GSL_COERCE_DBL (*t);
double t_next = GSL_COERCE_DBL ((*t) + h0);
if (fabs (h0) < fabs (h_old) && t_next != t_curr)
{
/* Step was decreased. Undo step, and try again with new h0. */
DBL_MEMCPY (y, e->y0, dydt->dimension);
e->failed_steps++;
goto try_step;
}
else
{
#ifdef DEBUG
printf
("-- gsl_odeiv2_evolve_apply h0=%.5e, t0=%.5e, step_status=%d\n",
h0, t0, step_status);
#endif
*h = h0; /* notify user of step-size which caused the failure */
*t = t0; /* restore original t value */
return step_status;
}
}
}
e->count++;
e->last_step = h0;
if (final_step)
{
*t = t1;
}
else
{
*t = t0 + h0;
}
if (con != NULL)
{
/* Check error and attempt to adjust the step. */
double h_old = h0;
const int hadjust_status
=
gsl_odeiv2_control_hadjust (con, step, y, e->yerr, e->dydt_out, &h0);
if (hadjust_status == GSL_ODEIV_HADJ_DEC)
{
/* Check that the reported status is correct (i.e. an actual
decrease in h0 occured) and the suggested h0 will change
the time by at least 1 ulp */
double t_curr = GSL_COERCE_DBL (*t);
double t_next = GSL_COERCE_DBL ((*t) + h0);
if (fabs (h0) < fabs (h_old) && t_next != t_curr)
{
/* Step was decreased. Undo step, and try again with new h0. */
DBL_MEMCPY (y, e->y0, dydt->dimension);
e->failed_steps++;
goto try_step;
}
else
{
/* Can not obtain required error tolerance, and can not
decrease step-size any further, so give up and return
GSL_FAILURE.
*/
*h = h0; /* notify user of step-size which caused the failure */
return GSL_FAILURE;
}
}
}
/* Suggest step size for next time-step. Change of step size is not
suggested in the final step, because that step can be very
small compared to previous step, to reach t1.
*/
if (final_step == 0)
{
*h = h0;
}
return step_status;
}
