int
gsl_ieee_set_mode (int precision, int rounding, int exception_mask)
{
int mode;
switch (precision)
{
case GSL_IEEE_SINGLE_PRECISION:
GSL_ERROR ("single precision rounding is not supported by <fenv.h>",
GSL_EUNSUP) ;
break ;
case GSL_IEEE_DOUBLE_PRECISION:
GSL_ERROR ("double precision rounding is not supported by <fenv.h>",
GSL_EUNSUP) ;
break ;
case GSL_IEEE_EXTENDED_PRECISION:
GSL_ERROR ("extended precision rounding is not supported by <fenv.h>",
GSL_EUNSUP) ;
break ;
}
switch (rounding)
{
case GSL_IEEE_ROUND_TO_NEAREST:
#ifdef FE_TONEAREST
fesetround (FE_TONEAREST) ;
#else
GSL_ERROR ("round-to-nearest is not supported by <fenv.h>", GSL_EUNSUP) ;
#endif
break ;
case GSL_IEEE_ROUND_DOWN:
#ifdef FE_DOWNWARD
fesetround (FE_DOWNWARD) ;
#else
GSL_ERROR ("round-down is not supported by <fenv.h>", GSL_EUNSUP) ;
#endif
break ;
case GSL_IEEE_ROUND_UP:
#ifdef FE_UPWARD
fesetround (FE_UPWARD) ;
#else
GSL_ERROR ("round-up is not supported by <fenv.h>", GSL_EUNSUP) ;
#endif
break ;
case GSL_IEEE_ROUND_TO_ZERO:
#ifdef FE_TOWARDZERO
fesetround (FE_TOWARDZERO) ;
#else
GSL_ERROR ("round-toward-zero is not supported by <fenv.h>", GSL_EUNSUP) ;
#endif
break ;
default:
#ifdef FE_TONEAREST
fesetround (FE_TONEAREST) ;
#else
GSL_ERROR ("default round-to-nearest mode is not supported by <fenv.h>", GSL_EUNSUP) ;
#endif
}
/* Turn on all the exceptions apart from 'inexact' */
mode = 0;
#ifdef FE_INVALID
mode |= FE_INVALID;
#endif
#ifdef FE_DIVBYZERO
mode |= FE_DIVBYZERO;
#endif
#ifdef FE_OVERFLOW
mode |= FE_OVERFLOW ;
#endif
#ifdef FE_UNDERFLOW
mode |= FE_UNDERFLOW ;
#endif
if (exception_mask & GSL_IEEE_MASK_INVALID)
{
#ifdef FE_INVALID
mode &= ~ FE_INVALID ;
#else
GSL_ERROR ("invalid operation exception not supported by <fenv.h>",
GSL_EUNSUP);
#endif
}
if (exception_mask & GSL_IEEE_MASK_DENORMALIZED)
{
/* do nothing */
}
else
{
GSL_ERROR ("denormalized operand exception not supported by <fenv.h>. "
"Use 'mask-denormalized' to work around this.", GSL_EUNSUP) ;
}
if (exception_mask & GSL_IEEE_MASK_DIVISION_BY_ZERO)
{
#ifdef FE_DIVBYZERO
mode &= ~ FE_DIVBYZERO ;
#else
GSL_ERROR ("division by zero exception not supported by <fenv.h>",
GSL_EUNSUP);
#endif
}
if (exception_mask & GSL_IEEE_MASK_OVERFLOW)
{
#ifdef FE_OVERFLOW
mode &= ~ FE_OVERFLOW ;
#else
GSL_ERROR ("overflow exception not supported by <fenv.h>", GSL_EUNSUP);
#endif
}
if (exception_mask & GSL_IEEE_MASK_UNDERFLOW)
{
#ifdef FE_UNDERFLOW
mode &= ~ FE_UNDERFLOW ;
#else
GSL_ERROR ("underflow exception not supported by <fenv.h>", GSL_EUNSUP);
#endif
}
if (exception_mask & GSL_IEEE_TRAP_INEXACT)
{
#ifdef FE_INEXACT
mode |= FE_INEXACT ;
#else
GSL_ERROR ("inexact exception not supported by <fenv.h>", GSL_EUNSUP);
#endif
}
else
{
#ifdef FE_INEXACT
mode &= ~ FE_INEXACT ;
#else
/* do nothing */
#endif
}
#if HAVE_DECL_FEENABLEEXCEPT
feenableexcept (mode) ;
#elif HAVE_DECL_FESETTRAPENABLE
fesettrapenable (mode);
#else
GSL_ERROR ("unknown exception trap method", GSL_EUNSUP)
#endif
return GSL_SUCCESS ;
}
int
gsl_sf_bessel_sequence_Jnu_e(double nu, gsl_mode_t mode, size_t size, double * v)
{
/* CHECK_POINTER(v) */
if(nu < 0.0) {
GSL_ERROR ("domain error", GSL_EDOM);
}
else if(size == 0) {
GSL_ERROR ("error", GSL_EINVAL);
}
else {
const gsl_prec_t goal = GSL_MODE_PREC(mode);
const double dx_array[] = { 0.001, 0.03, 0.1 }; /* double, single, approx */
const double dx_nominal = dx_array[goal];
const int cnu = (int) ceil(nu);
const double nu13 = pow(nu,1.0/3.0);
const double smalls[] = { 0.01, 0.02, 0.4, 0.7, 1.3, 2.0, 2.5, 3.2, 3.5, 4.5, 6.0 };
const double x_small = ( nu >= 10.0 ? nu - nu13 : smalls[cnu] );
gsl_sf_result J0, J1;
double Jp, J;
double x;
size_t i = 0;
/* Calculate the first point. */
x = v[0];
gsl_sf_bessel_Jnu_e(nu, x, &J0);
v[0] = J0.val;
++i;
/* Step over the idiot case where the
* first point was actually zero.
*/
if(x == 0.0) {
if(v[1] <= x) {
/* Strict ordering failure. */
GSL_ERROR ("error", GSL_EFAILED);
}
x = v[1];
gsl_sf_bessel_Jnu_e(nu, x, &J0);
v[1] = J0.val;
++i;
}
/* Calculate directly as long as the argument
* is small. This is necessary because the
* integration is not very good there.
*/
while(v[i] < x_small && i < size) {
if(v[i] <= x) {
/* Strict ordering failure. */
GSL_ERROR ("error", GSL_EFAILED);
}
x = v[i];
gsl_sf_bessel_Jnu_e(nu, x, &J0);
v[i] = J0.val;
++i;
}
/* At this point we are ready to integrate.
* The value of x is the last calculated
* point, which has the value J0; v[i] is
* the next point we need to calculate. We
* calculate nu+1 at x as well to get
* the derivative, then we go forward.
*/
gsl_sf_bessel_Jnu_e(nu+1.0, x, &J1);
J = J0.val;
Jp = -J1.val + nu/x * J0.val;
while(i < size) {
const double dv = v[i] - x;
const int Nd = (int) ceil(dv/dx_nominal);
const double dx = dv / Nd;
double xj;
int j;
if(v[i] <= x) {
/* Strict ordering failure. */
GSL_ERROR ("error", GSL_EFAILED);
}
/* Integrate over interval up to next sample point.
*/
for(j=0, xj=x; j<Nd; j++, xj += dx) {
rk_step(nu, xj, dx, &Jp, &J);
}
/* Go to next interval. */
x = v[i];
v[i] = J;
++i;
}
return GSL_SUCCESS;
}
}
int
gsl_filter_gaussian_kernel(const double alpha, const size_t order, const int normalize, gsl_vector * kernel)
{
const size_t N = kernel->size;
if (alpha <= 0.0)
{
GSL_ERROR("alpha must be positive", GSL_EDOM);
}
else if (order > GSL_FILTER_GAUSSIAN_MAX_ORDER)
{
GSL_ERROR("derivative order is too large", GSL_EDOM);
}
else
{
const double half = 0.5 * (N - 1.0); /* (N - 1) / 2 */
double sum = 0.0;
size_t i;
/* check for quick return */
if (N == 1)
{
if (order == 0)
gsl_vector_set(kernel, 0, 1.0);
else
gsl_vector_set(kernel, 0, 0.0);
return GSL_SUCCESS;
}
for (i = 0; i < N; ++i)
{
double xi = ((double)i - half) / half;
double yi = alpha * xi;
double gi = exp(-0.5 * yi * yi);
gsl_vector_set(kernel, i, gi);
sum += gi;
}
/* normalize so sum(kernel) = 1 */
if (normalize)
gsl_vector_scale(kernel, 1.0 / sum);
if (order > 0)
{
const double beta = -0.5 * alpha * alpha;
double q[GSL_FILTER_GAUSSIAN_MAX_ORDER + 1];
size_t k;
/*
* Need to calculate derivatives of the Gaussian window; define
*
* w(n) = C * exp [ p(n) ]
*
* p(n) = beta * n^2
* beta = -1/2 * ( alpha / ((N-1)/2) )^2
*
* Then:
*
* d^k/dn^k w(n) = q_k(n) * w(n)
*
* where q_k(n) is a degree-k polynomial in n, which satisfies:
*
* q_k(n) = d/dn q_{k-1}(n) + q_{k-1}(n) * dp(n)/dn
* q_0(n) = 1 / half^{order}
*/
/* initialize q_0(n) = 1 / half^{order} */
q[0] = 1.0 / gsl_pow_uint(half, order);
for (i = 1; i <= GSL_FILTER_GAUSSIAN_MAX_ORDER; ++i)
q[i] = 0.0;
/* loop through derivative orders and calculate q_k(n) for k = 1,...,order */
for (k = 1; k <= order; ++k)
{
double qm1 = q[0];
q[0] = q[1];
for (i = 1; i <= k; ++i)
{
double tmp = q[i];
q[i] = (i + 1.0) * q[i + 1] + /* d/dn q_{k-1} */
2.0 * beta * qm1; /* q_{k-1}(n) p'(n) */
qm1 = tmp;
}
}
/* now set w(n) := q(n) * w(n) */
for (i = 0; i < N; ++i)
{
double xi = ((double)i - half) / half;
double qn = gsl_poly_eval(q, order + 1, xi);
double *wn = gsl_vector_ptr(kernel, i);
*wn *= qn;
}
}
return GSL_SUCCESS;
}
}
/* for description of method see [Engeln-Mullges + Uhlig, p. 92]
*
* diag[0] offdiag[0] 0 .....
* offdiag[0] diag[1] offdiag[1] .....
* 0 offdiag[1] diag[2]
* 0 0 offdiag[2] .....
*/
static
int
solve_tridiag(
const double diag[], size_t d_stride,
const double offdiag[], size_t o_stride,
const double b[], size_t b_stride,
double x[], size_t x_stride,
size_t N)
{
int status = GSL_SUCCESS;
double *gamma = (double *) malloc (N * sizeof (double));
double *alpha = (double *) malloc (N * sizeof (double));
double *c = (double *) malloc (N * sizeof (double));
double *z = (double *) malloc (N * sizeof (double));
if (gamma == 0 || alpha == 0 || c == 0 || z == 0)
{
GSL_ERROR("failed to allocate working space", GSL_ENOMEM);
}
else
{
size_t i, j;
/* Cholesky decomposition
A = L.D.L^t
lower_diag(L) = gamma
diag(D) = alpha
*/
alpha[0] = diag[0];
gamma[0] = offdiag[0] / alpha[0];
if (alpha[0] == 0) {
status = GSL_EZERODIV;
}
for (i = 1; i < N - 1; i++)
{
alpha[i] = diag[d_stride * i] - offdiag[o_stride*(i - 1)] * gamma[i - 1];
gamma[i] = offdiag[o_stride * i] / alpha[i];
if (alpha[i] == 0) {
status = GSL_EZERODIV;
}
}
if (N > 1)
{
alpha[N - 1] = diag[d_stride * (N - 1)] - offdiag[o_stride*(N - 2)] * gamma[N - 2];
}
/* update RHS */
z[0] = b[0];
for (i = 1; i < N; i++)
{
z[i] = b[b_stride * i] - gamma[i - 1] * z[i - 1];
}
for (i = 0; i < N; i++)
{
c[i] = z[i] / alpha[i];
}
/* backsubstitution */
x[x_stride * (N - 1)] = c[N - 1];
if (N >= 2)
{
for (i = N - 2, j = 0; j <= N - 2; j++, i--)
{
x[x_stride * i] = c[i] - gamma[i] * x[x_stride * (i + 1)];
}
}
}
if (z != 0)
free (z);
if (c != 0)
free (c);
if (alpha != 0)
free (alpha);
if (gamma != 0)
free (gamma);
if (status == GSL_EZERODIV) {
GSL_ERROR ("matrix must be positive definite", status);
}
return status;
}
int
gsl_integration_qawc (gsl_function * f,
const double a, const double b, const double c,
const double epsabs, const double epsrel,
const size_t limit,
gsl_integration_workspace * workspace,
double *result, double *abserr)
{
double area, errsum;
double result0, abserr0;
double tolerance;
size_t iteration = 0;
int roundoff_type1 = 0, roundoff_type2 = 0, error_type = 0;
int err_reliable;
int sign = 1;
double lower, higher;
/* Initialize results */
*result = 0;
*abserr = 0;
if (limit > workspace->limit)
{
GSL_ERROR ("iteration limit exceeds available workspace", GSL_EINVAL) ;
}
if (b < a)
{
lower = b ;
higher = a ;
sign = -1 ;
}
else
{
lower = a;
higher = b;
}
initialise (workspace, lower, higher);
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);
}
if (c == a || c == b)
{
GSL_ERROR ("cannot integrate with singularity on endpoint", GSL_EINVAL);
}
/* perform the first integration */
qc25c (f, lower, higher, c, &result0, &abserr0, &err_reliable);
set_initial_result (workspace, result0, abserr0);
/* Test on accuracy, use 0.01 relative error as an extra safety
margin on the first iteration (ignored for subsequent iterations) */
tolerance = GSL_MAX_DBL (epsabs, epsrel * fabs (result0));
if (abserr0 < tolerance && abserr0 < 0.01 * fabs(result0))
{
*result = sign * result0;
*abserr = abserr0;
return GSL_SUCCESS;
}
else if (limit == 1)
{
*result = sign * 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;
int err_reliable1, err_reliable2;
/* 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;
if (c > a1 && c <= b1)
{
b1 = 0.5 * (c + b2) ;
a2 = b1;
}
else if (c > b1 && c < b2)
{
b1 = 0.5 * (a1 + c) ;
a2 = b1;
}
qc25c (f, a1, b1, c, &area1, &error1, &err_reliable1);
qc25c (f, a2, b2, c, &area2, &error2, &err_reliable2);
area12 = area1 + area2;
error12 = error1 + error2;
errsum += (error12 - e_i);
area += area12 - r_i;
if (err_reliable1 && err_reliable2)
{
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 = sign * 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);
}
}
int
gsl_odeiv2_evolve_apply_fixed_step (gsl_odeiv2_evolve * e,
gsl_odeiv2_control * con,
gsl_odeiv2_step * step,
const gsl_odeiv2_system * dydt,
double *t, const double h, double y[])
{
const double t0 = *t;
int step_status;
if (e->dimension != step->dimension)
{
GSL_ERROR ("step dimension must match evolution size", GSL_EINVAL);
}
/* Save y in case of failure in a step */
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;
}
}
if (step->type->can_use_dydt_in)
{
step_status =
gsl_odeiv2_step_apply (step, t0, h, y, e->yerr, e->dydt_in,
e->dydt_out, dydt);
}
else
{
step_status =
gsl_odeiv2_step_apply (step, t0, h, y, e->yerr, NULL, e->dydt_out,
dydt);
}
/* Return the stepper return value in case of an error */
if (step_status != GSL_SUCCESS)
{
return step_status;
}
if (con != NULL)
{
/* Calculate error level. Fail if error level exceeds desired
error level. */
double htemp = h;
const int hadjust_status
= gsl_odeiv2_control_hadjust (con, step, y, e->yerr,
e->dydt_out, &htemp);
if (hadjust_status == GSL_ODEIV_HADJ_DEC)
{
DBL_MEMCPY (y, e->y0, dydt->dimension);
e->failed_steps++;
return GSL_FAILURE;
}
}
/* Step is accepted, update status */
e->count++;
e->last_step = h;
*t = t0 + h;
return GSL_SUCCESS;
}
/* for description of method see [Engeln-Mullges + Uhlig, p. 96]
*
* diag[0] offdiag[0] 0 ..... offdiag[N-1]
* offdiag[0] diag[1] offdiag[1] .....
* 0 offdiag[1] diag[2]
* 0 0 offdiag[2] .....
* ... ...
* offdiag[N-1] ...
*
*/
static
int
solve_cyc_tridiag(
const double diag[], size_t d_stride,
const double offdiag[], size_t o_stride,
const double b[], size_t b_stride,
double x[], size_t x_stride,
size_t N)
{
int status = GSL_SUCCESS;
double * delta = (double *) malloc (N * sizeof (double));
double * gamma = (double *) malloc (N * sizeof (double));
double * alpha = (double *) malloc (N * sizeof (double));
double * c = (double *) malloc (N * sizeof (double));
double * z = (double *) malloc (N * sizeof (double));
if (delta == 0 || gamma == 0 || alpha == 0 || c == 0 || z == 0)
{
GSL_ERROR("failed to allocate working space", GSL_ENOMEM);
}
else
{
size_t i, j;
double sum = 0.0;
/* factor */
if (N == 1)
{
x[0] = b[0] / diag[0];
return GSL_SUCCESS;
}
alpha[0] = diag[0];
gamma[0] = offdiag[0] / alpha[0];
delta[0] = offdiag[o_stride * (N-1)] / alpha[0];
if (alpha[0] == 0) {
status = GSL_EZERODIV;
}
for (i = 1; i < N - 2; i++)
{
alpha[i] = diag[d_stride * i] - offdiag[o_stride * (i-1)] * gamma[i - 1];
gamma[i] = offdiag[o_stride * i] / alpha[i];
delta[i] = -delta[i - 1] * offdiag[o_stride * (i-1)] / alpha[i];
if (alpha[i] == 0) {
status = GSL_EZERODIV;
}
}
for (i = 0; i < N - 2; i++)
{
sum += alpha[i] * delta[i] * delta[i];
}
alpha[N - 2] = diag[d_stride * (N - 2)] - offdiag[o_stride * (N - 3)] * gamma[N - 3];
gamma[N - 2] = (offdiag[o_stride * (N - 2)] - offdiag[o_stride * (N - 3)] * delta[N - 3]) / alpha[N - 2];
alpha[N - 1] = diag[d_stride * (N - 1)] - sum - alpha[(N - 2)] * gamma[N - 2] * gamma[N - 2];
/* update */
z[0] = b[0];
for (i = 1; i < N - 1; i++)
{
z[i] = b[b_stride * i] - z[i - 1] * gamma[i - 1];
}
sum = 0.0;
for (i = 0; i < N - 2; i++)
{
sum += delta[i] * z[i];
}
z[N - 1] = b[b_stride * (N - 1)] - sum - gamma[N - 2] * z[N - 2];
for (i = 0; i < N; i++)
{
c[i] = z[i] / alpha[i];
}
/* backsubstitution */
x[x_stride * (N - 1)] = c[N - 1];
x[x_stride * (N - 2)] = c[N - 2] - gamma[N - 2] * x[x_stride * (N - 1)];
if (N >= 3)
{
for (i = N - 3, j = 0; j <= N - 3; j++, i--)
{
x[x_stride * i] = c[i] - gamma[i] * x[x_stride * (i + 1)] - delta[i] * x[x_stride * (N - 1)];
}
}
}
if (z != 0)
free (z);
if (c != 0)
free (c);
if (alpha != 0)
free (alpha);
if (gamma != 0)
free (gamma);
if (delta != 0)
free (delta);
if (status == GSL_EZERODIV) {
GSL_ERROR ("matrix must be positive definite", status);
}
return status;
}
/* Do the reflection described in [Moshier, p. 334].
* Assumes a,b,c != neg integer.
*/
static
int
hyperg_2F1_reflect(const double a, const double b, const double c,
const double x, gsl_sf_result * result)
{
const double d = c - a - b;
const int intd = floor(d+0.5);
const int d_integer = ( fabs(d - intd) < locEPS );
if(d_integer) {
const double ln_omx = log(1.0 - x);
const double ad = fabs(d);
int stat_F2 = GSL_SUCCESS;
double sgn_2;
gsl_sf_result F1;
gsl_sf_result F2;
double d1, d2;
gsl_sf_result lng_c;
gsl_sf_result lng_ad2;
gsl_sf_result lng_bd2;
int stat_c;
int stat_ad2;
int stat_bd2;
if(d >= 0.0) {
d1 = d;
d2 = 0.0;
}
else {
d1 = 0.0;
d2 = d;
}
stat_ad2 = gsl_sf_lngamma_e(a+d2, &lng_ad2);
stat_bd2 = gsl_sf_lngamma_e(b+d2, &lng_bd2);
stat_c = gsl_sf_lngamma_e(c, &lng_c);
/* Evaluate F1.
*/
if(ad < GSL_DBL_EPSILON) {
/* d = 0 */
F1.val = 0.0;
F1.err = 0.0;
}
else {
gsl_sf_result lng_ad;
gsl_sf_result lng_ad1;
gsl_sf_result lng_bd1;
int stat_ad = gsl_sf_lngamma_e(ad, &lng_ad);
int stat_ad1 = gsl_sf_lngamma_e(a+d1, &lng_ad1);
int stat_bd1 = gsl_sf_lngamma_e(b+d1, &lng_bd1);
if(stat_ad1 == GSL_SUCCESS && stat_bd1 == GSL_SUCCESS && stat_ad == GSL_SUCCESS) {
/* Gamma functions in the denominator are ok.
* Proceed with evaluation.
*/
int i;
double sum1 = 1.0;
double term = 1.0;
double ln_pre1_val = lng_ad.val + lng_c.val + d2*ln_omx - lng_ad1.val - lng_bd1.val;
double ln_pre1_err = lng_ad.err + lng_c.err + lng_ad1.err + lng_bd1.err + GSL_DBL_EPSILON * fabs(ln_pre1_val);
int stat_e;
/* Do F1 sum.
*/
for(i=1; i<ad; i++) {
int j = i-1;
term *= (a + d2 + j) * (b + d2 + j) / (1.0 + d2 + j) / i * (1.0-x);
sum1 += term;
}
stat_e = gsl_sf_exp_mult_err_e(ln_pre1_val, ln_pre1_err,
sum1, GSL_DBL_EPSILON*fabs(sum1),
&F1);
if(stat_e == GSL_EOVRFLW) {
OVERFLOW_ERROR(result);
}
}
else {
/* Gamma functions in the denominator were not ok.
* So the F1 term is zero.
*/
F1.val = 0.0;
F1.err = 0.0;
}
} /* end F1 evaluation */
/* Evaluate F2.
*/
if(stat_ad2 == GSL_SUCCESS && stat_bd2 == GSL_SUCCESS) {
/* Gamma functions in the denominator are ok.
* Proceed with evaluation.
*/
const int maxiter = 2000;
double psi_1 = -M_EULER;
gsl_sf_result psi_1pd;
gsl_sf_result psi_apd1;
gsl_sf_result psi_bpd1;
int stat_1pd = gsl_sf_psi_e(1.0 + ad, &psi_1pd);
int stat_apd1 = gsl_sf_psi_e(a + d1, &psi_apd1);
int stat_bpd1 = gsl_sf_psi_e(b + d1, &psi_bpd1);
int stat_dall = GSL_ERROR_SELECT_3(stat_1pd, stat_apd1, stat_bpd1);
double psi_val = psi_1 + psi_1pd.val - psi_apd1.val - psi_bpd1.val - ln_omx;
double psi_err = psi_1pd.err + psi_apd1.err + psi_bpd1.err + GSL_DBL_EPSILON*fabs(psi_val);
double fact = 1.0;
double sum2_val = psi_val;
double sum2_err = psi_err;
double ln_pre2_val = lng_c.val + d1*ln_omx - lng_ad2.val - lng_bd2.val;
double ln_pre2_err = lng_c.err + lng_ad2.err + lng_bd2.err + GSL_DBL_EPSILON * fabs(ln_pre2_val);
int stat_e;
int j;
/* Do F2 sum.
*/
for(j=1; j<maxiter; j++) {
/* values for psi functions use recurrence; Abramowitz+Stegun 6.3.5 */
double term1 = 1.0/(double)j + 1.0/(ad+j);
double term2 = 1.0/(a+d1+j-1.0) + 1.0/(b+d1+j-1.0);
double delta = 0.0;
psi_val += term1 - term2;
psi_err += GSL_DBL_EPSILON * (fabs(term1) + fabs(term2));
fact *= (a+d1+j-1.0)*(b+d1+j-1.0)/((ad+j)*j) * (1.0-x);
delta = fact * psi_val;
sum2_val += delta;
sum2_err += fabs(fact * psi_err) + GSL_DBL_EPSILON*fabs(delta);
if(fabs(delta) < GSL_DBL_EPSILON * fabs(sum2_val)) break;
}
if(j == maxiter) stat_F2 = GSL_EMAXITER;
if(sum2_val == 0.0) {
F2.val = 0.0;
F2.err = 0.0;
}
else {
stat_e = gsl_sf_exp_mult_err_e(ln_pre2_val, ln_pre2_err,
sum2_val, sum2_err,
&F2);
if(stat_e == GSL_EOVRFLW) {
result->val = 0.0;
result->err = 0.0;
GSL_ERROR ("error", GSL_EOVRFLW);
}
}
stat_F2 = GSL_ERROR_SELECT_2(stat_F2, stat_dall);
}
else {
/* Gamma functions in the denominator not ok.
* So the F2 term is zero.
*/
F2.val = 0.0;
F2.err = 0.0;
} /* end F2 evaluation */
sgn_2 = ( GSL_IS_ODD(intd) ? -1.0 : 1.0 );
result->val = F1.val + sgn_2 * F2.val;
result->err = F1.err + F2. err;
result->err += 2.0 * GSL_DBL_EPSILON * (fabs(F1.val) + fabs(F2.val));
result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);
return stat_F2;
}
else {
/* d not an integer */
gsl_sf_result pre1, pre2;
double sgn1, sgn2;
gsl_sf_result F1, F2;
int status_F1, status_F2;
/* These gamma functions appear in the denominator, so we
* catch their harmless domain errors and set the terms to zero.
*/
gsl_sf_result ln_g1ca, ln_g1cb, ln_g2a, ln_g2b;
double sgn_g1ca, sgn_g1cb, sgn_g2a, sgn_g2b;
int stat_1ca = gsl_sf_lngamma_sgn_e(c-a, &ln_g1ca, &sgn_g1ca);
int stat_1cb = gsl_sf_lngamma_sgn_e(c-b, &ln_g1cb, &sgn_g1cb);
int stat_2a = gsl_sf_lngamma_sgn_e(a, &ln_g2a, &sgn_g2a);
int stat_2b = gsl_sf_lngamma_sgn_e(b, &ln_g2b, &sgn_g2b);
int ok1 = (stat_1ca == GSL_SUCCESS && stat_1cb == GSL_SUCCESS);
int ok2 = (stat_2a == GSL_SUCCESS && stat_2b == GSL_SUCCESS);
gsl_sf_result ln_gc, ln_gd, ln_gmd;
double sgn_gc, sgn_gd, sgn_gmd;
gsl_sf_lngamma_sgn_e( c, &ln_gc, &sgn_gc);
gsl_sf_lngamma_sgn_e( d, &ln_gd, &sgn_gd);
gsl_sf_lngamma_sgn_e(-d, &ln_gmd, &sgn_gmd);
sgn1 = sgn_gc * sgn_gd * sgn_g1ca * sgn_g1cb;
sgn2 = sgn_gc * sgn_gmd * sgn_g2a * sgn_g2b;
if(ok1 && ok2) {
double ln_pre1_val = ln_gc.val + ln_gd.val - ln_g1ca.val - ln_g1cb.val;
double ln_pre2_val = ln_gc.val + ln_gmd.val - ln_g2a.val - ln_g2b.val + d*log(1.0-x);
double ln_pre1_err = ln_gc.err + ln_gd.err + ln_g1ca.err + ln_g1cb.err;
double ln_pre2_err = ln_gc.err + ln_gmd.err + ln_g2a.err + ln_g2b.err;
if(ln_pre1_val < GSL_LOG_DBL_MAX && ln_pre2_val < GSL_LOG_DBL_MAX) {
gsl_sf_exp_err_e(ln_pre1_val, ln_pre1_err, &pre1);
gsl_sf_exp_err_e(ln_pre2_val, ln_pre2_err, &pre2);
pre1.val *= sgn1;
pre2.val *= sgn2;
}
else {
OVERFLOW_ERROR(result);
}
}
else if(ok1 && !ok2) {
double ln_pre1_val = ln_gc.val + ln_gd.val - ln_g1ca.val - ln_g1cb.val;
double ln_pre1_err = ln_gc.err + ln_gd.err + ln_g1ca.err + ln_g1cb.err;
if(ln_pre1_val < GSL_LOG_DBL_MAX) {
gsl_sf_exp_err_e(ln_pre1_val, ln_pre1_err, &pre1);
pre1.val *= sgn1;
pre2.val = 0.0;
pre2.err = 0.0;
}
else {
OVERFLOW_ERROR(result);
}
}
else if(!ok1 && ok2) {
double ln_pre2_val = ln_gc.val + ln_gmd.val - ln_g2a.val - ln_g2b.val + d*log(1.0-x);
double ln_pre2_err = ln_gc.err + ln_gmd.err + ln_g2a.err + ln_g2b.err;
if(ln_pre2_val < GSL_LOG_DBL_MAX) {
pre1.val = 0.0;
pre1.err = 0.0;
gsl_sf_exp_err_e(ln_pre2_val, ln_pre2_err, &pre2);
pre2.val *= sgn2;
}
else {
OVERFLOW_ERROR(result);
}
}
else {
pre1.val = 0.0;
pre2.val = 0.0;
UNDERFLOW_ERROR(result);
}
status_F1 = hyperg_2F1_series( a, b, 1.0-d, 1.0-x, &F1);
status_F2 = hyperg_2F1_series(c-a, c-b, 1.0+d, 1.0-x, &F2);
result->val = pre1.val*F1.val + pre2.val*F2.val;
result->err = fabs(pre1.val*F1.err) + fabs(pre2.val*F2.err);
result->err += fabs(pre1.err*F1.val) + fabs(pre2.err*F2.val);
result->err += 2.0 * GSL_DBL_EPSILON * (fabs(pre1.val*F1.val) + fabs(pre2.val*F2.val));
result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);
return GSL_SUCCESS;
}
}
int
gsl_sf_hyperg_2F1_e(double a, double b, const double c,
const double x,
gsl_sf_result * result)
{
const double d = c - a - b;
const double rinta = floor(a + 0.5);
const double rintb = floor(b + 0.5);
const double rintc = floor(c + 0.5);
const int a_neg_integer = ( a < 0.0 && fabs(a - rinta) < locEPS );
const int b_neg_integer = ( b < 0.0 && fabs(b - rintb) < locEPS );
const int c_neg_integer = ( c < 0.0 && fabs(c - rintc) < locEPS );
result->val = 0.0;
result->err = 0.0;
/* Handle x == 1.0 RJM */
if (fabs (x - 1.0) < locEPS && (c - a - b) > 0 && c != 0 && !c_neg_integer) {
gsl_sf_result lngamc, lngamcab, lngamca, lngamcb;
double lngamc_sgn, lngamca_sgn, lngamcb_sgn;
int status;
int stat1 = gsl_sf_lngamma_sgn_e (c, &lngamc, &lngamc_sgn);
int stat2 = gsl_sf_lngamma_e (c - a - b, &lngamcab);
int stat3 = gsl_sf_lngamma_sgn_e (c - a, &lngamca, &lngamca_sgn);
int stat4 = gsl_sf_lngamma_sgn_e (c - b, &lngamcb, &lngamcb_sgn);
if (stat1 != GSL_SUCCESS || stat2 != GSL_SUCCESS
|| stat3 != GSL_SUCCESS || stat4 != GSL_SUCCESS)
{
DOMAIN_ERROR (result);
}
status =
gsl_sf_exp_err_e (lngamc.val + lngamcab.val - lngamca.val - lngamcb.val,
lngamc.err + lngamcab.err + lngamca.err + lngamcb.err,
result);
result->val *= lngamc_sgn / (lngamca_sgn * lngamcb_sgn);
return status;
}
if(x < -1.0 || 1.0 <= x) {
DOMAIN_ERROR(result);
}
if(c_neg_integer) {
/* If c is a negative integer, then either a or b must be a
negative integer of smaller magnitude than c to ensure
cancellation of the series. */
if(! (a_neg_integer && a > c + 0.1) && ! (b_neg_integer && b > c + 0.1)) {
DOMAIN_ERROR(result);
}
}
if(fabs(c-b) < locEPS || fabs(c-a) < locEPS) {
return pow_omx(x, d, result); /* (1-x)^(c-a-b) */
}
if(a >= 0.0 && b >= 0.0 && c >=0.0 && x >= 0.0 && x < 0.995) {
/* Series has all positive definite
* terms and x is not close to 1.
*/
return hyperg_2F1_series(a, b, c, x, result);
}
if(fabs(a) < 10.0 && fabs(b) < 10.0) {
/* a and b are not too large, so we attempt
* variations on the series summation.
*/
if(a_neg_integer) {
return hyperg_2F1_series(rinta, b, c, x, result);
}
if(b_neg_integer) {
return hyperg_2F1_series(a, rintb, c, x, result);
}
if(x < -0.25) {
return hyperg_2F1_luke(a, b, c, x, result);
}
else if(x < 0.5) {
return hyperg_2F1_series(a, b, c, x, result);
}
else {
if(fabs(c) > 10.0) {
return hyperg_2F1_series(a, b, c, x, result);
}
else {
return hyperg_2F1_reflect(a, b, c, x, result);
}
}
}
else {
/* Either a or b or both large.
* Introduce some new variables ap,bp so that bp is
* the larger in magnitude.
*/
double ap, bp;
if(fabs(a) > fabs(b)) {
bp = a;
ap = b;
}
else {
bp = b;
ap = a;
}
if(x < 0.0) {
/* What the hell, maybe Luke will converge.
*/
return hyperg_2F1_luke(a, b, c, x, result);
}
if(GSL_MAX_DBL(fabs(a),1.0)*fabs(bp)*fabs(x) < 2.0*fabs(c)) {
/* If c is large enough or x is small enough,
* we can attempt the series anyway.
*/
return hyperg_2F1_series(a, b, c, x, result);
}
if(fabs(bp*bp*x*x) < 0.001*fabs(bp) && fabs(a) < 10.0) {
/* The famous but nearly worthless "large b" asymptotic.
*/
int stat = gsl_sf_hyperg_1F1_e(a, c, bp*x, result);
result->err = 0.001 * fabs(result->val);
return stat;
}
/* We give up. */
result->val = 0.0;
result->err = 0.0;
GSL_ERROR ("error", GSL_EUNIMPL);
}
}
int
gsl_eigen_gensymmv (gsl_matrix * A, gsl_matrix * B, gsl_vector * eval,
gsl_matrix * evec, gsl_eigen_gensymmv_workspace * w)
{
const size_t N = A->size1;
/* check matrix and vector sizes */
if (N != A->size2)
{
GSL_ERROR ("matrix must be square to compute eigenvalues", GSL_ENOTSQR);
}
else if ((N != B->size1) || (N != B->size2))
{
GSL_ERROR ("B matrix dimensions must match A", GSL_EBADLEN);
}
else if (eval->size != N)
{
GSL_ERROR ("eigenvalue vector must match matrix size", GSL_EBADLEN);
}
else if (evec->size1 != evec->size2)
{
GSL_ERROR ("eigenvector matrix must be square", GSL_ENOTSQR);
}
else if (evec->size1 != N)
{
GSL_ERROR ("eigenvector matrix has wrong size", GSL_EBADLEN);
}
else if (w->size != N)
{
GSL_ERROR ("matrix size does not match workspace", GSL_EBADLEN);
}
else
{
int s;
/* compute Cholesky factorization of B */
s = gsl_linalg_cholesky_decomp(B);
if (s != GSL_SUCCESS)
return s; /* B is not positive definite */
/* transform to standard symmetric eigenvalue problem */
gsl_eigen_gensymm_standardize(A, B);
/* compute eigenvalues and eigenvectors */
s = gsl_eigen_symmv(A, eval, evec, w->symmv_workspace_p);
if (s != GSL_SUCCESS)
return s;
/* backtransform eigenvectors: evec -> L^{-T} evec */
gsl_blas_dtrsm(CblasLeft,
CblasLower,
CblasTrans,
CblasNonUnit,
1.0,
B,
evec);
/* the blas call destroyed the normalization - renormalize */
gensymmv_normalize_eigenvectors(evec);
return GSL_SUCCESS;
}
} /* gsl_eigen_gensymmv() */
int
gsl_linalg_HH_svx (gsl_matrix * A, gsl_vector * x)
{
if (A->size1 > A->size2)
{
/* System is underdetermined. */
GSL_ERROR ("System is underdetermined", GSL_EINVAL);
}
else if (A->size2 != x->size)
{
GSL_ERROR ("matrix and vector sizes must be equal", GSL_EBADLEN);
}
else
{
const size_t N = A->size1;
const size_t M = A->size2;
size_t i, j, k;
REAL *d = (REAL *) malloc (N * sizeof (REAL));
if (d == 0)
{
GSL_ERROR ("could not allocate memory for workspace", GSL_ENOMEM);
}
/* Perform Householder transformation. */
for (i = 0; i < N; i++)
{
const REAL aii = gsl_matrix_get (A, i, i);
REAL alpha;
REAL f;
REAL ak;
REAL max_norm = 0.0;
REAL r = 0.0;
for (k = i; k < M; k++)
{
REAL aki = gsl_matrix_get (A, k, i);
r += aki * aki;
}
if (r == 0.0)
{
/* Rank of matrix is less than size1. */
free (d);
GSL_ERROR ("matrix is rank deficient", GSL_ESING);
}
alpha = sqrt (r) * GSL_SIGN (aii);
ak = 1.0 / (r + alpha * aii);
gsl_matrix_set (A, i, i, aii + alpha);
d[i] = -alpha;
for (k = i + 1; k < N; k++)
{
REAL norm = 0.0;
f = 0.0;
for (j = i; j < M; j++)
{
REAL ajk = gsl_matrix_get (A, j, k);
REAL aji = gsl_matrix_get (A, j, i);
norm += ajk * ajk;
f += ajk * aji;
}
max_norm = GSL_MAX (max_norm, norm);
f *= ak;
for (j = i; j < M; j++)
{
REAL ajk = gsl_matrix_get (A, j, k);
REAL aji = gsl_matrix_get (A, j, i);
gsl_matrix_set (A, j, k, ajk - f * aji);
}
}
if (fabs (alpha) < 2.0 * GSL_DBL_EPSILON * sqrt (max_norm))
{
/* Apparent singularity. */
free (d);
GSL_ERROR("apparent singularity detected", GSL_ESING);
}
/* Perform update of RHS. */
f = 0.0;
for (j = i; j < M; j++)
{
f += gsl_vector_get (x, j) * gsl_matrix_get (A, j, i);
}
f *= ak;
for (j = i; j < M; j++)
{
REAL xj = gsl_vector_get (x, j);
REAL aji = gsl_matrix_get (A, j, i);
gsl_vector_set (x, j, xj - f * aji);
}
}
/* Perform back-substitution. */
for (i = N; i-- > 0;)
{
REAL xi = gsl_vector_get (x, i);
REAL sum = 0.0;
for (k = i + 1; k < N; k++)
{
sum += gsl_matrix_get (A, i, k) * gsl_vector_get (x, k);
}
gsl_vector_set (x, i, (xi - sum) / d[i]);
}
free (d);
return GSL_SUCCESS;
}
}
static int
qagp (const gsl_function * f,
const double *pts, const size_t npts,
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 res_ext, err_ext;
double result0, abserr0, resabs0;
double tolerance;
double ertest = 0;
double error_over_large_intervals = 0;
double reseps = 0, abseps = 0, correc = 0;
size_t ktmin = 0;
int roundoff_type1 = 0, roundoff_type2 = 0, roundoff_type3 = 0;
int error_type = 0, error_type2 = 0;
size_t iteration = 0;
int positive_integrand = 0;
int extrapolate = 0;
int disallow_extrapolation = 0;
struct extrapolation_table table;
const size_t nint = npts - 1; /* number of intervals */
size_t *ndin = workspace->level; /* temporarily alias ndin to level */
size_t i;
/* Initialize results */
*result = 0;
*abserr = 0;
/* Test on validity of parameters */
if (limit > workspace->limit)
{
GSL_ERROR ("iteration limit exceeds available workspace", GSL_EINVAL) ;
}
if (npts > workspace->limit)
{
GSL_ERROR ("npts exceeds size of 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);
}
/* Check that the integration range and break points are an
ascending sequence */
for (i = 0; i < nint; i++)
{
if (pts[i + 1] < pts[i])
{
GSL_ERROR ("points are not in an ascending sequence", GSL_EINVAL);
}
}
/* Perform the first integration */
result0 = 0;
abserr0 = 0;
resabs0 = 0;
initialise (workspace, 0.0, 0.0) ;
for (i = 0; i < nint; i++)
{
double area1, error1, resabs1, resasc1;
const double a1 = pts[i];
const double b1 = pts[i + 1];
q (f, a1, b1, &area1, &error1, &resabs1, &resasc1);
result0 = result0 + area1;
abserr0 = abserr0 + error1;
resabs0 = resabs0 + resabs1;
append_interval (workspace, a1, b1, area1, error1);
if (error1 == resasc1 && error1 != 0.0)
{
ndin[i] = 1;
}
else
{
ndin[i] = 0;
}
}
/* Compute the initial error estimate */
errsum = 0.0;
for (i = 0; i < nint; i++)
{
if (ndin[i])
{
workspace->elist[i] = abserr0;
}
errsum = errsum + workspace->elist[i];
}
for (i = 0; i < nint; i++)
{
workspace->level[i] = 0;
}
/* Sort results into order of decreasing error via the indirection
array order[] */
sort_results (workspace);
/* Test on accuracy */
tolerance = GSL_MAX_DBL (epsabs, epsrel * fabs (result0));
if (abserr0 <= 100 * GSL_DBL_EPSILON * resabs0 && abserr0 > tolerance)
{
*result = result0;
*abserr = abserr0;
GSL_ERROR ("cannot reach tolerance because of roundoff error"
"on first attempt", GSL_EROUND);
}
else if (abserr0 <= tolerance)
{
*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);
}
/* Initialization */
initialise_table (&table);
append_table (&table, result0);
area = result0;
res_ext = result0;
err_ext = GSL_DBL_MAX;
error_over_large_intervals = errsum;
ertest = tolerance;
positive_integrand = test_positivity (result0, resabs0);
iteration = nint - 1;
do
{
size_t current_level;
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;
double last_e_i;
/* Bisect the subinterval with the largest error estimate */
retrieve (workspace, &a_i, &b_i, &r_i, &e_i);
current_level = workspace->level[workspace->i] + 1;
a1 = a_i;
b1 = 0.5 * (a_i + b_i);
a2 = b1;
b2 = b_i;
iteration++;
q (f, a1, b1, &area1, &error1, &resabs1, &resasc1);
q (f, a2, b2, &area2, &error2, &resabs2, &resasc2);
area12 = area1 + area2;
error12 = error1 + error2;
last_e_i = e_i;
/* Improve previous approximations to the integral and test for
accuracy.
We write these expressions in the same way as the original
QUADPACK code so that the rounding errors are the same, which
makes testing easier. */
errsum = errsum + error12 - e_i;
area = area + area12 - r_i;
tolerance = GSL_MAX_DBL (epsabs, epsrel * fabs (area));
if (resasc1 != error1 && resasc2 != error2)
{
double delta = r_i - area12;
if (fabs (delta) <= 1.0e-5 * fabs (area12) && error12 >= 0.99 * e_i)
{
if (!extrapolate)
{
roundoff_type1++;
}
else
{
roundoff_type2++;
}
}
if (i > 10 && error12 > e_i)
{
roundoff_type3++;
}
}
/* Test for roundoff and eventually set error flag */
if (roundoff_type1 + roundoff_type2 >= 10 || roundoff_type3 >= 20)
{
error_type = 2; /* round off error */
}
if (roundoff_type2 >= 5)
{
error_type2 = 1;
}
/* 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 = 4;
}
/* append the newly-created intervals to the list */
update (workspace, a1, b1, area1, error1, a2, b2, area2, error2);
if (errsum <= tolerance)
{
goto compute_result;
}
if (error_type)
{
break;
}
if (iteration >= limit - 1)
{
error_type = 1;
break;
}
if (disallow_extrapolation)
{
continue;
}
error_over_large_intervals += -last_e_i;
if (current_level < workspace->maximum_level)
{
error_over_large_intervals += error12;
}
if (!extrapolate)
{
/* test whether the interval to be bisected next is the
smallest interval. */
if (large_interval (workspace))
continue;
extrapolate = 1;
workspace->nrmax = 1;
}
/* The smallest interval has the largest error. Before
bisecting decrease the sum of the errors over the larger
intervals (error_over_large_intervals) and perform
extrapolation. */
if (!error_type2 && error_over_large_intervals > ertest)
{
if (increase_nrmax (workspace))
continue;
}
/* Perform extrapolation */
append_table (&table, area);
if (table.n < 3)
{
goto skip_extrapolation;
}
qelg (&table, &reseps, &abseps);
ktmin++;
if (ktmin > 5 && err_ext < 0.001 * errsum)
{
error_type = 5;
}
if (abseps < err_ext)
{
ktmin = 0;
err_ext = abseps;
res_ext = reseps;
correc = error_over_large_intervals;
ertest = GSL_MAX_DBL (epsabs, epsrel * fabs (reseps));
if (err_ext <= ertest)
break;
}
/* Prepare bisection of the smallest interval. */
if (table.n == 1)
{
disallow_extrapolation = 1;
}
if (error_type == 5)
{
break;
}
skip_extrapolation:
reset_nrmax (workspace);
extrapolate = 0;
error_over_large_intervals = errsum;
}
while (iteration < limit);
*result = res_ext;
*abserr = err_ext;
if (err_ext == GSL_DBL_MAX)
goto compute_result;
if (error_type || error_type2)
{
if (error_type2)
{
err_ext += correc;
}
if (error_type == 0)
error_type = 3;
if (result != 0 && area != 0)
{
if (err_ext / fabs (res_ext) > errsum / fabs (area))
goto compute_result;
}
else if (err_ext > errsum)
{
goto compute_result;
}
else if (area == 0.0)
{
goto return_error;
}
}
/* Test on divergence. */
{
double max_area = GSL_MAX_DBL (fabs (res_ext), fabs (area));
if (!positive_integrand && max_area < 0.01 * resabs0)
goto return_error;
}
{
double ratio = res_ext / area;
if (ratio < 0.01 || ratio > 100 || errsum > fabs (area))
error_type = 6;
}
goto return_error;
compute_result:
*result = sum_results (workspace);
*abserr = errsum;
return_error:
if (error_type > 2)
error_type--;
if (error_type == 0)
{
return GSL_SUCCESS;
}
else if (error_type == 1)
{
GSL_ERROR ("number of iterations was insufficient", GSL_EMAXITER);
}
else if (error_type == 2)
{
GSL_ERROR ("cannot reach tolerance because of roundoff error",
GSL_EROUND);
}
else if (error_type == 3)
{
GSL_ERROR ("bad integrand behavior found in the integration interval",
GSL_ESING);
}
else if (error_type == 4)
{
GSL_ERROR ("roundoff error detected in the extrapolation table",
GSL_EROUND);
}
else if (error_type == 5)
{
GSL_ERROR ("integral is divergent, or slowly convergent",
GSL_EDIVERGE);
}
else
{
GSL_ERROR ("could not integrate function", GSL_EFAILED);
}
}
int
gsl_linalg_pcholesky_invert(const gsl_matrix * LDLT, const gsl_permutation * p,
gsl_matrix * Ainv)
{
const size_t M = LDLT->size1;
const size_t N = LDLT->size2;
if (M != N)
{
GSL_ERROR ("LDLT matrix must be square", GSL_ENOTSQR);
}
else if (LDLT->size1 != p->size)
{
GSL_ERROR ("matrix size must match permutation size", GSL_EBADLEN);
}
else if (Ainv->size1 != Ainv->size2)
{
GSL_ERROR ("Ainv matrix must be square", GSL_ENOTSQR);
}
else if (Ainv->size1 != M)
{
GSL_ERROR ("Ainv matrix has wrong dimensions", GSL_EBADLEN);
}
else
{
size_t i, j;
gsl_vector_view v1, v2;
/* invert the lower triangle of LDLT */
gsl_matrix_memcpy(Ainv, LDLT);
gsl_linalg_tri_lower_unit_invert(Ainv);
/* compute sqrt(D^{-1}) L^{-1} in the lower triangle of Ainv */
for (i = 0; i < N; ++i)
{
double di = gsl_matrix_get(LDLT, i, i);
double sqrt_di = sqrt(di);
for (j = 0; j < i; ++j)
{
double *Lij = gsl_matrix_ptr(Ainv, i, j);
*Lij /= sqrt_di;
}
gsl_matrix_set(Ainv, i, i, 1.0 / sqrt_di);
}
/*
* The lower triangle of Ainv now contains D^{-1/2} L^{-1}. Now compute
* A^{-1} = L^{-T} D^{-1} L^{-1}
*/
for (i = 0; i < N; ++i)
{
double aii = gsl_matrix_get(Ainv, i, i);
if (i < N - 1)
{
double tmp;
v1 = gsl_matrix_subcolumn(Ainv, i, i, N - i);
gsl_blas_ddot(&v1.vector, &v1.vector, &tmp);
gsl_matrix_set(Ainv, i, i, tmp);
if (i > 0)
{
gsl_matrix_view m = gsl_matrix_submatrix(Ainv, i + 1, 0, N - i - 1, i);
v1 = gsl_matrix_subcolumn(Ainv, i, i + 1, N - i - 1);
v2 = gsl_matrix_subrow(Ainv, i, 0, i);
gsl_blas_dgemv(CblasTrans, 1.0, &m.matrix, &v1.vector, aii, &v2.vector);
}
}
else
{
v1 = gsl_matrix_row(Ainv, N - 1);
gsl_blas_dscal(aii, &v1.vector);
}
}
/* copy lower triangle to upper */
gsl_matrix_transpose_tricpy('L', 0, Ainv, Ainv);
/* now apply permutation p to the matrix */
/* compute L^{-T} D^{-1} L^{-1} P^T */
for (i = 0; i < N; ++i)
{
v1 = gsl_matrix_row(Ainv, i);
gsl_permute_vector_inverse(p, &v1.vector);
}
/* compute P L^{-T} D^{-1} L^{-1} P^T */
for (i = 0; i < N; ++i)
{
v1 = gsl_matrix_column(Ainv, i);
gsl_permute_vector_inverse(p, &v1.vector);
}
return GSL_SUCCESS;
}
}
int
gsl_multifit_wlinear (const gsl_matrix * X,
const gsl_vector * w,
const gsl_vector * y,
gsl_vector * c,
gsl_matrix * cov,
double *chisq, gsl_multifit_linear_workspace * work)
{
if (X->size1 != y->size)
{
GSL_ERROR
("number of observations in y does not match rows of matrix X",
GSL_EBADLEN);
}
else if (X->size2 != c->size)
{
GSL_ERROR ("number of parameters c does not match columns of matrix X",
GSL_EBADLEN);
}
else if (w->size != y->size)
{
GSL_ERROR ("number of weights does not match number of observations",
GSL_EBADLEN);
}
else if (cov->size1 != cov->size2)
{
GSL_ERROR ("covariance matrix is not square", GSL_ENOTSQR);
}
else if (c->size != cov->size1)
{
GSL_ERROR
("number of parameters does not match size of covariance matrix",
GSL_EBADLEN);
}
else if (X->size1 != work->n || X->size2 != work->p)
{
GSL_ERROR
("size of workspace does not match size of observation matrix",
GSL_EBADLEN);
}
else
{
const size_t n = X->size1;
const size_t p = X->size2;
size_t i, j;
gsl_matrix *A = work->A;
gsl_matrix *Q = work->Q;
gsl_matrix *QSI = work->QSI;
gsl_vector *S = work->S;
gsl_vector *t = work->t;
gsl_vector *xt = work->xt;
gsl_vector *D = work->D;
/* Scale X, A = sqrt(w) X */
gsl_matrix_memcpy (A, X);
for (i = 0; i < n; i++)
{
double wi = gsl_vector_get (w, i);
if (wi < 0)
wi = 0;
{
gsl_vector_view row = gsl_matrix_row (A, i);
gsl_vector_scale (&row.vector, sqrt (wi));
}
}
/* Balance the columns of the matrix A */
gsl_linalg_balance_columns (A, D);
/* Decompose A into U S Q^T */
gsl_linalg_SV_decomp_mod (A, QSI, Q, S, xt);
/* Solve sqrt(w) y = A c for c, by first computing t = sqrt(w) y */
for (i = 0; i < n; i++)
{
double wi = gsl_vector_get (w, i);
double yi = gsl_vector_get (y, i);
if (wi < 0)
wi = 0;
gsl_vector_set (t, i, sqrt (wi) * yi);
}
gsl_blas_dgemv (CblasTrans, 1.0, A, t, 0.0, xt);
/* Scale the matrix Q, Q' = Q S^-1 */
gsl_matrix_memcpy (QSI, Q);
for (j = 0; j < p; j++)
{
gsl_vector_view column = gsl_matrix_column (QSI, j);
double alpha = gsl_vector_get (S, j);
if (alpha != 0)
alpha = 1.0 / alpha;
gsl_vector_scale (&column.vector, alpha);
}
gsl_vector_set_zero (c);
/* Solution */
gsl_blas_dgemv (CblasNoTrans, 1.0, QSI, xt, 0.0, c);
/* Unscale the balancing factors */
gsl_vector_div (c, D);
/* Form covariance matrix cov = (Q S^-1) (Q S^-1)^T */
for (i = 0; i < p; i++)
{
gsl_vector_view row_i = gsl_matrix_row (QSI, i);
double d_i = gsl_vector_get (D, i);
for (j = i; j < p; j++)
{
gsl_vector_view row_j = gsl_matrix_row (QSI, j);
double d_j = gsl_vector_get (D, j);
double s;
gsl_blas_ddot (&row_i.vector, &row_j.vector, &s);
gsl_matrix_set (cov, i, j, s / (d_i * d_j));
gsl_matrix_set (cov, j, i, s / (d_i * d_j));
}
}
/* Compute chisq, from residual r = y - X c */
{
double r2 = 0;
for (i = 0; i < n; i++)
{
double yi = gsl_vector_get (y, i);
double wi = gsl_vector_get (w, i);
gsl_vector_const_view row = gsl_matrix_const_row (X, i);
double y_est, ri;
gsl_blas_ddot (&row.vector, c, &y_est);
ri = yi - y_est;
r2 += wi * ri * ri;
}
*chisq = r2;
}
return GSL_SUCCESS;
}
}
int
gsl_spblas_dgemv(const CBLAS_TRANSPOSE_t TransA, const double alpha,
const gsl_spmatrix *A, const gsl_vector *x,
const double beta, gsl_vector *y)
{
const size_t M = A->size1;
const size_t N = A->size2;
if ((TransA == CblasNoTrans && N != x->size) ||
(TransA == CblasTrans && M != x->size))
{
GSL_ERROR("invalid length of x vector", GSL_EBADLEN);
}
else if ((TransA == CblasNoTrans && M != y->size) ||
(TransA == CblasTrans && N != y->size))
{
GSL_ERROR("invalid length of y vector", GSL_EBADLEN);
}
else
{
size_t j;
size_t incX, incY;
size_t lenX, lenY;
double *X, *Y;
double *Ad;
int *Ap, *Ai, *Aj;
int p;
if (TransA == CblasNoTrans)
{
lenX = N;
lenY = M;
}
else
{
lenX = M;
lenY = N;
}
/* form y := beta*y */
Y = y->data;
incY = y->stride;
if (beta == 0.0)
{
size_t jy = 0;
for (j = 0; j < lenY; ++j)
{
Y[jy] = 0.0;
jy += incY;
}
}
else if (beta != 1.0)
{
size_t jy = 0;
for (j = 0; j < lenY; ++j)
{
Y[jy] *= beta;
jy += incY;
}
}
if (alpha == 0.0)
return GSL_SUCCESS;
/* form y := alpha*op(A)*x + y */
Ap = A->p;
Ad = A->data;
X = x->data;
incX = x->stride;
if ((GSL_SPMATRIX_ISCCS(A) && (TransA == CblasNoTrans)) ||
(GSL_SPMATRIX_ISCRS(A) && (TransA == CblasTrans)))
{
Ai = A->i;
for (j = 0; j < lenX; ++j)
{
for (p = Ap[j]; p < Ap[j + 1]; ++p)
{
Y[Ai[p] * incY] += alpha * Ad[p] * X[j * incX];
}
}
}
else if ((GSL_SPMATRIX_ISCCS(A) && (TransA == CblasTrans)) ||
(GSL_SPMATRIX_ISCRS(A) && (TransA == CblasNoTrans)))
{
Ai = A->i;
for (j = 0; j < lenY; ++j)
{
for (p = Ap[j]; p < Ap[j + 1]; ++p)
{
Y[j * incY] += alpha * Ad[p] * X[Ai[p] * incX];
}
}
}
else if (GSL_SPMATRIX_ISTRIPLET(A))
{
if (TransA == CblasNoTrans)
{
Ai = A->i;
Aj = A->p;
}
else
{
Ai = A->p;
Aj = A->i;
}
for (p = 0; p < (int) A->nz; ++p)
{
Y[Ai[p] * incY] += alpha * Ad[p] * X[Aj[p] * incX];
}
}
else
{
GSL_ERROR("unsupported matrix type", GSL_EINVAL);
}
return GSL_SUCCESS;
}
} /* gsl_spblas_dgemv() */
static int
hybridj_alloc (void *vstate, size_t n)
{
hybridj_state_t *state = (hybridj_state_t *) vstate;
gsl_matrix *q, *r;
gsl_vector *tau, *diag, *qtf, *newton, *gradient, *x_trial, *f_trial,
*df, *qtdf, *rdx, *w, *v;
q = gsl_matrix_calloc (n, n);
if (q == 0)
{
GSL_ERROR ("failed to allocate space for q", GSL_ENOMEM);
}
state->q = q;
r = gsl_matrix_calloc (n, n);
if (r == 0)
{
gsl_matrix_free (q);
GSL_ERROR ("failed to allocate space for r", GSL_ENOMEM);
}
state->r = r;
tau = gsl_vector_calloc (n);
if (tau == 0)
{
gsl_matrix_free (q);
gsl_matrix_free (r);
GSL_ERROR ("failed to allocate space for tau", GSL_ENOMEM);
}
state->tau = tau;
diag = gsl_vector_calloc (n);
if (diag == 0)
{
gsl_matrix_free (q);
gsl_matrix_free (r);
gsl_vector_free (tau);
GSL_ERROR ("failed to allocate space for diag", GSL_ENOMEM);
}
state->diag = diag;
qtf = gsl_vector_calloc (n);
if (qtf == 0)
{
gsl_matrix_free (q);
gsl_matrix_free (r);
gsl_vector_free (tau);
gsl_vector_free (diag);
GSL_ERROR ("failed to allocate space for qtf", GSL_ENOMEM);
}
state->qtf = qtf;
newton = gsl_vector_calloc (n);
if (newton == 0)
{
gsl_matrix_free (q);
gsl_matrix_free (r);
gsl_vector_free (tau);
gsl_vector_free (diag);
gsl_vector_free (qtf);
GSL_ERROR ("failed to allocate space for newton", GSL_ENOMEM);
}
state->newton = newton;
gradient = gsl_vector_calloc (n);
if (gradient == 0)
{
gsl_matrix_free (q);
gsl_matrix_free (r);
gsl_vector_free (tau);
gsl_vector_free (diag);
gsl_vector_free (qtf);
gsl_vector_free (newton);
GSL_ERROR ("failed to allocate space for gradient", GSL_ENOMEM);
}
state->gradient = gradient;
x_trial = gsl_vector_calloc (n);
if (x_trial == 0)
{
gsl_matrix_free (q);
gsl_matrix_free (r);
gsl_vector_free (tau);
gsl_vector_free (diag);
gsl_vector_free (qtf);
gsl_vector_free (newton);
gsl_vector_free (gradient);
GSL_ERROR ("failed to allocate space for x_trial", GSL_ENOMEM);
}
state->x_trial = x_trial;
f_trial = gsl_vector_calloc (n);
if (f_trial == 0)
{
gsl_matrix_free (q);
gsl_matrix_free (r);
gsl_vector_free (tau);
gsl_vector_free (diag);
gsl_vector_free (qtf);
gsl_vector_free (newton);
gsl_vector_free (gradient);
gsl_vector_free (x_trial);
GSL_ERROR ("failed to allocate space for f_trial", GSL_ENOMEM);
}
state->f_trial = f_trial;
df = gsl_vector_calloc (n);
if (df == 0)
{
gsl_matrix_free (q);
gsl_matrix_free (r);
gsl_vector_free (tau);
gsl_vector_free (diag);
gsl_vector_free (qtf);
gsl_vector_free (newton);
gsl_vector_free (gradient);
gsl_vector_free (x_trial);
gsl_vector_free (f_trial);
GSL_ERROR ("failed to allocate space for df", GSL_ENOMEM);
}
state->df = df;
qtdf = gsl_vector_calloc (n);
if (qtdf == 0)
{
gsl_matrix_free (q);
gsl_matrix_free (r);
gsl_vector_free (tau);
gsl_vector_free (diag);
gsl_vector_free (qtf);
gsl_vector_free (newton);
gsl_vector_free (gradient);
gsl_vector_free (x_trial);
gsl_vector_free (f_trial);
gsl_vector_free (df);
GSL_ERROR ("failed to allocate space for qtdf", GSL_ENOMEM);
}
state->qtdf = qtdf;
rdx = gsl_vector_calloc (n);
if (rdx == 0)
{
gsl_matrix_free (q);
gsl_matrix_free (r);
gsl_vector_free (tau);
gsl_vector_free (diag);
gsl_vector_free (qtf);
gsl_vector_free (newton);
gsl_vector_free (gradient);
gsl_vector_free (x_trial);
gsl_vector_free (f_trial);
gsl_vector_free (df);
gsl_vector_free (qtdf);
GSL_ERROR ("failed to allocate space for rdx", GSL_ENOMEM);
}
state->rdx = rdx;
w = gsl_vector_calloc (n);
if (w == 0)
{
gsl_matrix_free (q);
gsl_matrix_free (r);
gsl_vector_free (tau);
gsl_vector_free (diag);
gsl_vector_free (qtf);
gsl_vector_free (newton);
gsl_vector_free (gradient);
gsl_vector_free (x_trial);
gsl_vector_free (f_trial);
gsl_vector_free (df);
gsl_vector_free (qtdf);
gsl_vector_free (rdx);
GSL_ERROR ("failed to allocate space for w", GSL_ENOMEM);
}
state->w = w;
v = gsl_vector_calloc (n);
if (v == 0)
{
gsl_matrix_free (q);
gsl_matrix_free (r);
gsl_vector_free (tau);
gsl_vector_free (diag);
gsl_vector_free (qtf);
gsl_vector_free (newton);
gsl_vector_free (gradient);
gsl_vector_free (x_trial);
gsl_vector_free (f_trial);
gsl_vector_free (df);
gsl_vector_free (qtdf);
gsl_vector_free (rdx);
gsl_vector_free (w);
GSL_ERROR ("failed to allocate space for v", GSL_ENOMEM);
}
state->v = v;
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;
}
int
gsl_linalg_hessenberg_unpack_accum(gsl_matrix * H, gsl_vector * tau,
gsl_matrix * V)
{
const size_t N = H->size1;
if (N != H->size2)
{
GSL_ERROR ("Hessenberg reduction requires square matrix",
GSL_ENOTSQR);
}
else if (N != tau->size)
{
GSL_ERROR ("tau vector must match matrix size", GSL_EBADLEN);
}
else if (N != V->size2)
{
GSL_ERROR ("V matrix has wrong dimension", GSL_EBADLEN);
}
else
{
size_t j; /* looping */
double tau_j; /* householder coefficient */
gsl_vector_view c, /* matrix column */
hv; /* householder vector */
gsl_matrix_view m;
if (N < 3)
{
/* nothing to do */
return GSL_SUCCESS;
}
for (j = 0; j < (N - 2); ++j)
{
c = gsl_matrix_column(H, j);
tau_j = gsl_vector_get(tau, j);
/*
* get a view to the householder vector in column j, but
* make sure hv(2) starts at the element below the
* subdiagonal, since hv(1) was never stored and is always
* 1
*/
hv = gsl_vector_subvector(&c.vector, j + 1, N - (j + 1));
/*
* Only operate on part of the matrix since the first
* j + 1 entries of the real householder vector are 0
*
* V -> V * U(j)
*
* Note here that V->size1 is not necessarily equal to N
*/
m = gsl_matrix_submatrix(V, 0, j + 1, V->size1, N - (j + 1));
/* apply right Householder matrix to V */
gsl_linalg_householder_mh(tau_j, &hv.vector, &m.matrix);
}
return GSL_SUCCESS;
}
} /* gsl_linalg_hessenberg_unpack_accum() */
/* plain gauss elimination, only not bothering with the zeroes
*
* diag[0] abovediag[0] 0 .....
* belowdiag[0] diag[1] abovediag[1] .....
* 0 belowdiag[1] diag[2]
* 0 0 belowdiag[2] .....
*/
static
int
solve_tridiag_nonsym(
const double diag[], size_t d_stride,
const double abovediag[], size_t a_stride,
const double belowdiag[], size_t b_stride,
const double rhs[], size_t r_stride,
double x[], size_t x_stride,
size_t N)
{
int status = GSL_SUCCESS;
double *alpha = (double *) malloc (N * sizeof (double));
double *z = (double *) malloc (N * sizeof (double));
if (alpha == 0 || z == 0)
{
GSL_ERROR("failed to allocate working space", GSL_ENOMEM);
}
else
{
size_t i, j;
/* Bidiagonalization (eliminating belowdiag)
& rhs update
diag' = alpha
rhs' = z
*/
alpha[0] = diag[0];
z[0] = rhs[0];
if (alpha[0] == 0) {
status = GSL_EZERODIV;
}
for (i = 1; i < N; i++)
{
const double t = belowdiag[b_stride*(i - 1)]/alpha[i-1];
alpha[i] = diag[d_stride*i] - t*abovediag[a_stride*(i - 1)];
z[i] = rhs[r_stride*i] - t*z[i-1];
if (alpha[i] == 0) {
status = GSL_EZERODIV;
}
}
/* backsubstitution */
x[x_stride * (N - 1)] = z[N - 1]/alpha[N - 1];
if (N >= 2)
{
for (i = N - 2, j = 0; j <= N - 2; j++, i--)
{
x[x_stride * i] = (z[i] - abovediag[a_stride*i] * x[x_stride * (i + 1)])/alpha[i];
}
}
}
if (z != 0)
free (z);
if (alpha != 0)
free (alpha);
if (status == GSL_EZERODIV) {
GSL_ERROR ("matrix must be positive definite", status);
}
return status;
}
int
gsl_linalg_hessenberg_decomp(gsl_matrix *A, gsl_vector *tau)
{
const size_t N = A->size1;
if (N != A->size2)
{
GSL_ERROR ("Hessenberg reduction requires square matrix",
GSL_ENOTSQR);
}
else if (N != tau->size)
{
GSL_ERROR ("tau vector must match matrix size", GSL_EBADLEN);
}
else if (N < 3)
{
/* nothing to do */
return GSL_SUCCESS;
}
else
{
size_t i; /* looping */
gsl_vector_view c, /* matrix column */
hv; /* householder vector */
gsl_matrix_view m;
double tau_i; /* beta in algorithm 7.4.2 */
for (i = 0; i < N - 2; ++i)
{
/*
* make a copy of A(i + 1:n, i) and store it in the section
* of 'tau' that we haven't stored coefficients in yet
*/
c = gsl_matrix_subcolumn(A, i, i + 1, N - i - 1);
hv = gsl_vector_subvector(tau, i + 1, N - (i + 1));
gsl_vector_memcpy(&hv.vector, &c.vector);
/* compute householder transformation of A(i+1:n,i) */
tau_i = gsl_linalg_householder_transform(&hv.vector);
/* apply left householder matrix (I - tau_i v v') to A */
m = gsl_matrix_submatrix(A, i + 1, i, N - (i + 1), N - i);
gsl_linalg_householder_hm(tau_i, &hv.vector, &m.matrix);
/* apply right householder matrix (I - tau_i v v') to A */
m = gsl_matrix_submatrix(A, 0, i + 1, N, N - (i + 1));
gsl_linalg_householder_mh(tau_i, &hv.vector, &m.matrix);
/* save Householder coefficient */
gsl_vector_set(tau, i, tau_i);
/*
* store Householder vector below the subdiagonal in column
* i of the matrix. hv(1) does not need to be stored since
* it is always 1.
*/
c = gsl_vector_subvector(&c.vector, 1, c.vector.size - 1);
hv = gsl_vector_subvector(&hv.vector, 1, hv.vector.size - 1);
gsl_vector_memcpy(&c.vector, &hv.vector);
}
return GSL_SUCCESS;
}
} /* gsl_linalg_hessenberg_decomp() */
/* solve following system w/o the corner elements and then use
* Sherman-Morrison formula to compensate for them
*
* diag[0] abovediag[0] 0 ..... belowdiag[N-1]
* belowdiag[0] diag[1] abovediag[1] .....
* 0 belowdiag[1] diag[2]
* 0 0 belowdiag[2] .....
* ... ...
* abovediag[N-1] ...
*/
static
int solve_cyc_tridiag_nonsym(
const double diag[], size_t d_stride,
const double abovediag[], size_t a_stride,
const double belowdiag[], size_t b_stride,
const double rhs[], size_t r_stride,
double x[], size_t x_stride,
size_t N)
{
int status = GSL_SUCCESS;
double *alpha = (double *) malloc (N * sizeof (double));
double *zb = (double *) malloc (N * sizeof (double));
double *zu = (double *) malloc (N * sizeof (double));
double *w = (double *) malloc (N * sizeof (double));
if (alpha == 0 || zb == 0 || zu == 0 || w == 0)
{
GSL_ERROR("failed to allocate working space", GSL_ENOMEM);
}
else
{
double beta;
/* Bidiagonalization (eliminating belowdiag)
& rhs update
diag' = alpha
rhs' = zb
rhs' for Aq=u is zu
*/
zb[0] = rhs[0];
if (diag[0] != 0) beta = -diag[0]; else beta = 1;
{
const double q = 1 - abovediag[0]*belowdiag[0]/(diag[0]*diag[d_stride]);
if (fabs(q/beta) > 0.5 && fabs(q/beta) < 2) {
beta *= (fabs(q/beta) < 1) ? 0.5 : 2;
}
}
zu[0] = beta;
alpha[0] = diag[0] - beta;
if (alpha[0] == 0) {
status = GSL_EZERODIV;
}
{
size_t i;
for (i = 1; i+1 < N; i++)
{
const double t = belowdiag[b_stride*(i - 1)]/alpha[i-1];
alpha[i] = diag[d_stride*i] - t*abovediag[a_stride*(i - 1)];
zb[i] = rhs[r_stride*i] - t*zb[i-1];
zu[i] = -t*zu[i-1];
/* FIXME!!! */
if (alpha[i] == 0) {
status = GSL_EZERODIV;
}
}
}
{
const size_t i = N-1;
const double t = belowdiag[b_stride*(i - 1)]/alpha[i-1];
alpha[i] = diag[d_stride*i]
- abovediag[a_stride*i]*belowdiag[b_stride*i]/beta
- t*abovediag[a_stride*(i - 1)];
zb[i] = rhs[r_stride*i] - t*zb[i-1];
zu[i] = abovediag[a_stride*i] - t*zu[i-1];
/* FIXME!!! */
if (alpha[i] == 0) {
status = GSL_EZERODIV;
}
}
/* backsubstitution */
{
size_t i, j;
w[N-1] = zu[N-1]/alpha[N-1];
x[x_stride*(N-1)] = zb[N-1]/alpha[N-1];
for (i = N - 2, j = 0; j <= N - 2; j++, i--)
{
w[i] = (zu[i] - abovediag[a_stride*i] * w[i+1])/alpha[i];
x[i*x_stride] = (zb[i] - abovediag[a_stride*i] * x[x_stride*(i + 1)])/alpha[i];
}
}
/* Sherman-Morrison */
{
const double vw = w[0] + belowdiag[b_stride*(N - 1)]/beta * w[N-1];
const double vx = x[0] + belowdiag[b_stride*(N - 1)]/beta * x[x_stride*(N - 1)];
/* FIXME!!! */
if (vw + 1 == 0) {
status = GSL_EZERODIV;
}
{
size_t i;
for (i = 0; i < N; i++)
x[i*x_stride] -= vx/(1 + vw)*w[i];
}
}
}
if (zb != 0)
free (zb);
if (zu != 0)
free (zu);
if (w != 0)
free (w);
if (alpha != 0)
free (alpha);
if (status == GSL_EZERODIV) {
GSL_ERROR ("matrix must be positive definite", status);
}
return status;
}
int
gsl_ieee_set_mode (int precision, int rounding, int exception_mask)
{
fp_except mode = 0;
fp_rnd rnd = 0;
switch (precision)
{
case GSL_IEEE_SINGLE_PRECISION:
GSL_ERROR ("OpenBSD only supports default precision rounding",
GSL_EUNSUP);
break;
case GSL_IEEE_DOUBLE_PRECISION:
GSL_ERROR ("OpenBSD only supports default precision rounding",
GSL_EUNSUP);
break;
case GSL_IEEE_EXTENDED_PRECISION:
GSL_ERROR ("OpenBSD only supports default precision rounding",
GSL_EUNSUP);
break;
}
switch (rounding)
{
case GSL_IEEE_ROUND_TO_NEAREST:
rnd = FP_RN;
fpsetround (rnd);
break;
case GSL_IEEE_ROUND_DOWN:
rnd = FP_RM;
fpsetround (rnd);
break;
case GSL_IEEE_ROUND_UP:
rnd = FP_RP;
fpsetround (rnd);
break;
case GSL_IEEE_ROUND_TO_ZERO:
rnd = FP_RZ;
fpsetround (rnd);
break;
default:
rnd = FP_RN;
fpsetround (rnd);
}
/* Turn on all available exceptions apart from 'inexact'.
Denormalized operand exception not available on all platforms. */
mode = FP_X_INV | FP_X_DZ | FP_X_OFL | FP_X_UFL;
#ifdef FP_X_DNML
mode = mode | FP_X_DNML;
#endif
if (exception_mask & GSL_IEEE_MASK_INVALID)
mode &= ~ FP_X_INV;
if (exception_mask & GSL_IEEE_MASK_DENORMALIZED)
{
#ifdef FP_X_DNML
mode &= ~ FP_X_DNML;
#endif
}
else
{
#ifndef FP_X_DNML
GSL_ERROR ("OpenBSD does not support the denormalized operand exception on this platform. "
"Use 'mask-denormalized' to work around this.",
GSL_EUNSUP);
#endif
}
if (exception_mask & GSL_IEEE_MASK_DIVISION_BY_ZERO)
mode &= ~ FP_X_DZ;
if (exception_mask & GSL_IEEE_MASK_OVERFLOW)
mode &= ~ FP_X_OFL;
if (exception_mask & GSL_IEEE_MASK_UNDERFLOW)
mode &= ~ FP_X_UFL;
if (exception_mask & GSL_IEEE_TRAP_INEXACT)
{
mode |= FP_X_IMP;
}
else
{
mode &= ~ FP_X_IMP;
}
fpsetmask (mode);
return GSL_SUCCESS;
}
int gsl_fft_real_transform (double data[], const size_t stride, const size_t n,
const gsl_fft_real_wavetable * wavetable,
gsl_fft_real_workspace * work)
{
const size_t nf = wavetable->nf;
size_t i;
size_t q, product = 1;
size_t tskip;
size_t product_1;
double *const scratch = work->scratch;
gsl_complex *twiddle1, *twiddle2, *twiddle3, *twiddle4;
size_t state = 0;
double *in = data;
size_t istride = stride ;
double *out = scratch;
size_t ostride = 1 ;
if (n == 0)
{
GSL_ERROR ("length n must be positive integer", GSL_EDOM);
}
if (n == 1)
{ /* FFT of one data point is the identity */
return 0;
}
if (n != wavetable->n)
{
GSL_ERROR ("wavetable does not match length of data", GSL_EINVAL);
}
if (n != work->n)
{
GSL_ERROR ("workspace does not match length of data", GSL_EINVAL);
}
for (i = 0; i < nf; i++)
{
const size_t factor = wavetable->factor[i];
product_1 = product;
product *= factor;
q = n / product;
tskip = (product_1 + 1) / 2 - 1;
if (state == 0)
{
in = data;
istride = stride;
out = scratch;
ostride = 1;
state = 1;
}
else
{
in = scratch;
istride = 1;
out = data;
ostride = stride;
state = 0;
}
if (factor == 2)
{
twiddle1 = wavetable->twiddle[i];
fft_real_pass_2 (in, istride, out, ostride, product, n, twiddle1);
}
else if (factor == 3)
{
twiddle1 = wavetable->twiddle[i];
twiddle2 = twiddle1 + tskip;
fft_real_pass_3 (in, istride, out, ostride, product, n, twiddle1,
twiddle2);
}
else if (factor == 4)
{
twiddle1 = wavetable->twiddle[i];
twiddle2 = twiddle1 + tskip;
twiddle3 = twiddle2 + tskip;
fft_real_pass_4 (in, istride, out, ostride, product, n, twiddle1,
twiddle2, twiddle3);
}
else if (factor == 5)
{
twiddle1 = wavetable->twiddle[i];
twiddle2 = twiddle1 + tskip;
twiddle3 = twiddle2 + tskip;
twiddle4 = twiddle3 + tskip;
fft_real_pass_5 (in, istride, out, ostride, product, n, twiddle1,
twiddle2, twiddle3, twiddle4);
}
else
{
twiddle1 = wavetable->twiddle[i];
fft_real_pass_n (in, istride, out, ostride, factor, product, n,
twiddle1);
}
}
if (state == 1) /* copy results back from scratch to data */
{
for (i = 0; i < n; i++)
{
data[stride*i] = scratch[i] ;
}
}
return 0;
}
int
gsl_integration_qng (const gsl_function *f,
double a, double b,
double epsabs, double epsrel,
double * result, double * abserr, size_t * neval)
{
double fv1[5], fv2[5], fv3[5], fv4[5];
double savfun[21]; /* array of function values which have been computed */
double res10, res21, res43, res87; /* 10, 21, 43 and 87 point results */
double result_kronrod, err ;
double resabs; /* approximation to the integral of abs(f) */
double resasc; /* approximation to the integral of abs(f-i/(b-a)) */
const double half_length = 0.5 * (b - a);
const double abs_half_length = fabs (half_length);
const double center = 0.5 * (b + a);
const double f_center = GSL_FN_EVAL(f, center);
int k ;
if (epsabs <= 0 && (epsrel < 50 * GSL_DBL_EPSILON || epsrel < 0.5e-28))
{
* result = 0;
* abserr = 0;
* neval = 0;
GSL_ERROR ("tolerance cannot be acheived with given epsabs and epsrel",
GSL_EBADTOL);
};
/* Compute the integral using the 10- and 21-point formula. */
res10 = 0;
res21 = w21b[5] * f_center;
resabs = w21b[5] * fabs (f_center);
for (k = 0; k < 5; k++)
{
const double abscissa = half_length * x1[k];
const double fval1 = GSL_FN_EVAL(f, center + abscissa);
const double fval2 = GSL_FN_EVAL(f, center - abscissa);
const double fval = fval1 + fval2;
res10 += w10[k] * fval;
res21 += w21a[k] * fval;
resabs += w21a[k] * (fabs (fval1) + fabs (fval2));
savfun[k] = fval;
fv1[k] = fval1;
fv2[k] = fval2;
}
for (k = 0; k < 5; k++)
{
const double abscissa = half_length * x2[k];
const double fval1 = GSL_FN_EVAL(f, center + abscissa);
const double fval2 = GSL_FN_EVAL(f, center - abscissa);
const double fval = fval1 + fval2;
res21 += w21b[k] * fval;
resabs += w21b[k] * (fabs (fval1) + fabs (fval2));
savfun[k + 5] = fval;
fv3[k] = fval1;
fv4[k] = fval2;
}
resabs *= abs_half_length ;
{
const double mean = 0.5 * res21;
resasc = w21b[5] * fabs (f_center - mean);
for (k = 0; k < 5; k++)
{
resasc +=
(w21a[k] * (fabs (fv1[k] - mean) + fabs (fv2[k] - mean))
+ w21b[k] * (fabs (fv3[k] - mean) + fabs (fv4[k] - mean)));
}
resasc *= abs_half_length ;
}
result_kronrod = res21 * half_length;
err = rescale_error ((res21 - res10) * half_length, resabs, resasc) ;
/* test for convergence. */
if (err < epsabs || err < epsrel * fabs (result_kronrod))
{
* result = result_kronrod ;
* abserr = err ;
* neval = 21;
return GSL_SUCCESS;
}
/* compute the integral using the 43-point formula. */
res43 = w43b[11] * f_center;
for (k = 0; k < 10; k++)
{
res43 += savfun[k] * w43a[k];
}
for (k = 0; k < 11; k++)
{
const double abscissa = half_length * x3[k];
const double fval = (GSL_FN_EVAL(f, center + abscissa)
+ GSL_FN_EVAL(f, center - abscissa));
res43 += fval * w43b[k];
savfun[k + 10] = fval;
}
/* test for convergence */
result_kronrod = res43 * half_length;
err = rescale_error ((res43 - res21) * half_length, resabs, resasc);
if (err < epsabs || err < epsrel * fabs (result_kronrod))
{
* result = result_kronrod ;
* abserr = err ;
* neval = 43;
return GSL_SUCCESS;
}
/* compute the integral using the 87-point formula. */
res87 = w87b[22] * f_center;
for (k = 0; k < 21; k++)
{
res87 += savfun[k] * w87a[k];
}
for (k = 0; k < 22; k++)
{
const double abscissa = half_length * x4[k];
res87 += w87b[k] * (GSL_FN_EVAL(f, center + abscissa)
+ GSL_FN_EVAL(f, center - abscissa));
}
/* test for convergence */
result_kronrod = res87 * half_length ;
err = rescale_error ((res87 - res43) * half_length, resabs, resasc);
if (err < epsabs || err < epsrel * fabs (result_kronrod))
{
* result = result_kronrod ;
* abserr = err ;
* neval = 87;
return GSL_SUCCESS;
}
/* failed to converge */
* result = result_kronrod ;
* abserr = err ;
* neval = 87;
GSL_ERROR("failed to reach tolerance with highest-order rule", GSL_ETOL) ;
}
int
gsl_ieee_set_mode (int precision, int rounding, int exception_mask)
{
int mode;
switch (precision)
{
case GSL_IEEE_SINGLE_PRECISION:
GSL_ERROR ("HPUX PA-RISC only supports default precision rounding",
GSL_EUNSUP) ;
break ;
case GSL_IEEE_DOUBLE_PRECISION:
GSL_ERROR ("HPUX PA-RISC only supports default precision rounding",
GSL_EUNSUP) ;
break ;
case GSL_IEEE_EXTENDED_PRECISION:
GSL_ERROR ("HPUX PA-RISC only supports default precision rounding",
GSL_EUNSUP) ;
break ;
}
switch (rounding)
{
case GSL_IEEE_ROUND_TO_NEAREST:
fesetround (FE_TONEAREST) ;
break ;
case GSL_IEEE_ROUND_DOWN:
fesetround (FE_DOWNWARD) ;
break ;
case GSL_IEEE_ROUND_UP:
fesetround (FE_UPWARD) ;
break ;
case GSL_IEEE_ROUND_TO_ZERO:
fesetround (FE_TOWARDZERO) ;
break ;
default:
fesetround (FE_TONEAREST) ;
}
/* Turn on all the exceptions apart from 'inexact' */
mode = FE_INVALID | FE_DIVBYZERO | FE_OVERFLOW | FE_UNDERFLOW ;
if (exception_mask & GSL_IEEE_MASK_INVALID)
mode &= ~ FE_INVALID ;
if (exception_mask & GSL_IEEE_MASK_DENORMALIZED)
{
/* do nothing */
}
else
{
GSL_ERROR ("HP-UX does not support the denormalized operand exception. "
"Use 'mask-denormalized' to work around this.",
GSL_EUNSUP) ;
}
if (exception_mask & GSL_IEEE_MASK_DIVISION_BY_ZERO)
mode &= ~ FE_DIVBYZERO ;
if (exception_mask & GSL_IEEE_MASK_OVERFLOW)
mode &= ~ FE_OVERFLOW ;
if (exception_mask & GSL_IEEE_MASK_UNDERFLOW)
mode &= ~ FE_UNDERFLOW ;
if (exception_mask & GSL_IEEE_TRAP_INEXACT)
{
mode |= FE_INEXACT ;
}
else
{
mode &= ~ FE_INEXACT ;
}
fesettrapenable (mode) ;
return GSL_SUCCESS ;
}
static int
vector_bfgs_alloc (void *vstate, size_t n)
{
vector_bfgs_state_t *state = (vector_bfgs_state_t *) vstate;
state->x1 = gsl_vector_calloc (n);
if (state->x1 == 0)
{
GSL_ERROR ("failed to allocate space for x1", GSL_ENOMEM);
}
state->dx1 = gsl_vector_calloc (n);
if (state->dx1 == 0)
{
gsl_vector_free (state->x1);
GSL_ERROR ("failed to allocate space for dx1", GSL_ENOMEM);
}
state->x2 = gsl_vector_calloc (n);
if (state->x2 == 0)
{
gsl_vector_free (state->dx1);
gsl_vector_free (state->x1);
GSL_ERROR ("failed to allocate space for x2", GSL_ENOMEM);
}
state->p = gsl_vector_calloc (n);
if (state->p == 0)
{
gsl_vector_free (state->x2);
gsl_vector_free (state->dx1);
gsl_vector_free (state->x1);
GSL_ERROR ("failed to allocate space for p", GSL_ENOMEM);
}
state->x0 = gsl_vector_calloc (n);
if (state->x0 == 0)
{
gsl_vector_free (state->p);
gsl_vector_free (state->x2);
gsl_vector_free (state->dx1);
gsl_vector_free (state->x1);
GSL_ERROR ("failed to allocate space for g0", GSL_ENOMEM);
}
state->g0 = gsl_vector_calloc (n);
if (state->g0 == 0)
{
gsl_vector_free (state->x0);
gsl_vector_free (state->p);
gsl_vector_free (state->x2);
gsl_vector_free (state->dx1);
gsl_vector_free (state->x1);
GSL_ERROR ("failed to allocate space for g0", GSL_ENOMEM);
}
state->dx0 = gsl_vector_calloc (n);
if (state->dx0 == 0)
{
gsl_vector_free (state->g0);
gsl_vector_free (state->x0);
gsl_vector_free (state->p);
gsl_vector_free (state->x2);
gsl_vector_free (state->dx1);
gsl_vector_free (state->x1);
GSL_ERROR ("failed to allocate space for g0", GSL_ENOMEM);
}
state->dg0 = gsl_vector_calloc (n);
if (state->dg0 == 0)
{
gsl_vector_free (state->dx0);
gsl_vector_free (state->g0);
gsl_vector_free (state->x0);
gsl_vector_free (state->p);
gsl_vector_free (state->x2);
gsl_vector_free (state->dx1);
gsl_vector_free (state->x1);
GSL_ERROR ("failed to allocate space for g0", GSL_ENOMEM);
}
return GSL_SUCCESS;
}
int
gsl_multiroot_fdjacobian (gsl_multiroot_function * F,
const gsl_vector * x, const gsl_vector * f,
double epsrel, gsl_matrix * jacobian)
{
const size_t n = x->size;
const size_t m = f->size;
const size_t n1 = jacobian->size1;
const size_t n2 = jacobian->size2;
if (m != n1 || n != n2)
{
GSL_ERROR ("function and jacobian are not conformant", GSL_EBADLEN);
}
{
size_t i,j;
gsl_vector *x1, *f1;
x1 = gsl_vector_alloc (n);
if (x1 == 0)
{
GSL_ERROR ("failed to allocate space for x1 workspace", GSL_ENOMEM);
}
f1 = gsl_vector_alloc (m);
if (f1 == 0)
{
gsl_vector_free (x1);
GSL_ERROR ("failed to allocate space for f1 workspace", GSL_ENOMEM);
}
gsl_vector_memcpy (x1, x); /* copy x into x1 */
for (j = 0; j < n; j++)
{
double xj = gsl_vector_get (x, j);
double dx = epsrel * fabs (xj);
if (dx == 0)
{
dx = epsrel;
}
gsl_vector_set (x1, j, xj + dx);
{
int status = GSL_MULTIROOT_FN_EVAL (F, x1, f1);
if (status != GSL_SUCCESS)
{
return GSL_EBADFUNC;
}
}
gsl_vector_set (x1, j, xj);
for (i = 0; i < m; i++)
{
double g1 = gsl_vector_get (f1, i);
double g0 = gsl_vector_get (f, i);
gsl_matrix_set (jacobian, i, j, (g1 - g0) / dx);
}
}
gsl_vector_free (x1);
gsl_vector_free (f1);
}
return GSL_SUCCESS;
}
int
gsl_multifit_linear_svd (const gsl_matrix * X,
const gsl_vector * y,
double tol,
size_t * rank,
gsl_vector * c,
gsl_matrix * cov,
double *chisq, gsl_multifit_linear_workspace * work)
{
if (X->size1 != y->size)
{
GSL_ERROR
("number of observations in y does not match rows of matrix X",
GSL_EBADLEN);
}
else if (X->size2 != c->size)
{
GSL_ERROR ("number of parameters c does not match columns of matrix X",
GSL_EBADLEN);
}
else if (cov->size1 != cov->size2)
{
GSL_ERROR ("covariance matrix is not square", GSL_ENOTSQR);
}
else if (c->size != cov->size1)
{
GSL_ERROR
("number of parameters does not match size of covariance matrix",
GSL_EBADLEN);
}
else if (X->size1 != work->n || X->size2 != work->p)
{
GSL_ERROR
("size of workspace does not match size of observation matrix",
GSL_EBADLEN);
}
else if (tol <= 0)
{
GSL_ERROR ("tolerance must be positive", GSL_EINVAL);
}
else
{
const size_t n = X->size1;
const size_t p = X->size2;
size_t i, j, p_eff;
gsl_matrix *A = work->A;
gsl_matrix *Q = work->Q;
gsl_matrix *QSI = work->QSI;
gsl_vector *S = work->S;
gsl_vector *xt = work->xt;
gsl_vector *D = work->D;
/* Copy X to workspace, A <= X */
gsl_matrix_memcpy (A, X);
/* Balance the columns of the matrix A */
gsl_linalg_balance_columns (A, D);
/* Decompose A into U S Q^T */
gsl_linalg_SV_decomp_mod (A, QSI, Q, S, xt);
/* Solve y = A c for c */
gsl_blas_dgemv (CblasTrans, 1.0, A, y, 0.0, xt);
/* Scale the matrix Q, Q' = Q S^-1 */
gsl_matrix_memcpy (QSI, Q);
{
double alpha0 = gsl_vector_get (S, 0);
p_eff = 0;
for (j = 0; j < p; j++)
{
gsl_vector_view column = gsl_matrix_column (QSI, j);
double alpha = gsl_vector_get (S, j);
if (alpha <= tol * alpha0) {
alpha = 0.0;
} else {
alpha = 1.0 / alpha;
p_eff++;
}
gsl_vector_scale (&column.vector, alpha);
}
*rank = p_eff;
}
gsl_vector_set_zero (c);
gsl_blas_dgemv (CblasNoTrans, 1.0, QSI, xt, 0.0, c);
/* Unscale the balancing factors */
gsl_vector_div (c, D);
/* Compute chisq, from residual r = y - X c */
{
double s2 = 0, r2 = 0;
for (i = 0; i < n; i++)
{
double yi = gsl_vector_get (y, i);
gsl_vector_const_view row = gsl_matrix_const_row (X, i);
double y_est, ri;
gsl_blas_ddot (&row.vector, c, &y_est);
ri = yi - y_est;
r2 += ri * ri;
}
s2 = r2 / (n - p_eff); /* p_eff == rank */
*chisq = r2;
/* Form variance-covariance matrix cov = s2 * (Q S^-1) (Q S^-1)^T */
for (i = 0; i < p; i++)
{
gsl_vector_view row_i = gsl_matrix_row (QSI, i);
double d_i = gsl_vector_get (D, i);
for (j = i; j < p; j++)
{
gsl_vector_view row_j = gsl_matrix_row (QSI, j);
double d_j = gsl_vector_get (D, j);
double s;
gsl_blas_ddot (&row_i.vector, &row_j.vector, &s);
gsl_matrix_set (cov, i, j, s * s2 / (d_i * d_j));
gsl_matrix_set (cov, j, i, s * s2 / (d_i * d_j));
}
}
}
return GSL_SUCCESS;
}
}
int
gsl_ieee_set_mode (int precision, int rounding, int exception_mask)
{
fptrap_t mode = 0 ;
fprnd_t rnd = 0 ;
switch (precision)
{
/* I'm not positive about AIX only supporting default precision rounding,
* but this is the best assumption until it's proven otherwise. */
case GSL_IEEE_SINGLE_PRECISION:
GSL_ERROR ("AIX only supports default precision rounding",
GSL_EUNSUP) ;
break ;
case GSL_IEEE_DOUBLE_PRECISION:
GSL_ERROR ("AIX only supports default precision rounding",
GSL_EUNSUP) ;
break ;
case GSL_IEEE_EXTENDED_PRECISION:
GSL_ERROR ("AIX only supports default precision rounding",
GSL_EUNSUP) ;
break ;
}
switch (rounding)
{
case GSL_IEEE_ROUND_TO_NEAREST:
rnd = FP_RND_RN ;
fp_swap_rnd (rnd) ;
break ;
case GSL_IEEE_ROUND_DOWN:
rnd = FP_RND_RM ;
fp_swap_rnd (rnd) ;
break ;
case GSL_IEEE_ROUND_UP:
rnd = FP_RND_RP ;
fp_swap_rnd (rnd) ;
break ;
case GSL_IEEE_ROUND_TO_ZERO:
rnd = FP_RND_RZ ;
fp_swap_rnd (rnd) ;
break ;
default:
rnd = FP_RND_RN ;
fp_swap_rnd (rnd) ;
}
/* Turn on all the exceptions apart from 'inexact' */
mode = TRP_INVALID | TRP_DIV_BY_ZERO | TRP_OVERFLOW | TRP_UNDERFLOW ;
if (exception_mask & GSL_IEEE_MASK_INVALID)
mode &= ~ TRP_INVALID ;
if (exception_mask & GSL_IEEE_MASK_DENORMALIZED)
{
/* do nothing */
}
else
{
GSL_ERROR ("AIX does not support the denormalized operand exception. "
"Use 'mask-denormalized' to work around this.",
GSL_EUNSUP) ;
}
if (exception_mask & GSL_IEEE_MASK_DIVISION_BY_ZERO)
mode &= ~ TRP_DIV_BY_ZERO ;
if (exception_mask & GSL_IEEE_MASK_OVERFLOW)
mode &= ~ TRP_OVERFLOW ;
if (exception_mask & GSL_IEEE_MASK_UNDERFLOW)
mode &= ~ TRP_UNDERFLOW ;
if (exception_mask & GSL_IEEE_TRAP_INEXACT)
{
mode |= TRP_INEXACT ;
}
else
{
mode &= ~ TRP_INEXACT ;
}
/* AIX appears to require two steps -- first enable floating point traps
* in general... */
fp_trap(FP_TRAP_SYNC);
/* next, enable the traps we're interested in */
fp_enable(mode);
return GSL_SUCCESS ;
}
int
gsl_eigen_symm (gsl_matrix * A, gsl_vector * eval,
gsl_eigen_symm_workspace * w)
{
if (A->size1 != A->size2)
{
GSL_ERROR ("matrix must be square to compute eigenvalues", GSL_ENOTSQR);
}
else if (eval->size != A->size1)
{
GSL_ERROR ("eigenvalue vector must match matrix size", GSL_EBADLEN);
}
else
{
const size_t N = A->size1;
double *const d = w->d;
double *const sd = w->sd;
size_t a, b;
/* handle special case */
if (N == 1)
{
double A00 = gsl_matrix_get (A, 0, 0);
gsl_vector_set (eval, 0, A00);
return GSL_SUCCESS;
}
/* use sd as the temporary workspace for the decomposition,
since we can discard the tau result immediately if we are not
computing eigenvectors */
{
gsl_vector_view d_vec = gsl_vector_view_array (d, N);
gsl_vector_view sd_vec = gsl_vector_view_array (sd, N - 1);
gsl_vector_view tau = gsl_vector_view_array (sd, N - 1);
gsl_linalg_symmtd_decomp (A, &tau.vector);
gsl_linalg_symmtd_unpack_T (A, &d_vec.vector, &sd_vec.vector);
}
/* Make an initial pass through the tridiagonal decomposition
to remove off-diagonal elements which are effectively zero */
chop_small_elements (N, d, sd);
/* Progressively reduce the matrix until it is diagonal */
b = N - 1;
while (b > 0)
{
if (sd[b - 1] == 0.0 || isnan(sd[b - 1]))
{
b--;
continue;
}
/* Find the largest unreduced block (a,b) starting from b
and working backwards */
a = b - 1;
while (a > 0)
{
if (sd[a - 1] == 0.0)
{
break;
}
a--;
}
{
const size_t n_block = b - a + 1;
double *d_block = d + a;
double *sd_block = sd + a;
/* apply QR reduction with implicit deflation to the
unreduced block */
qrstep (n_block, d_block, sd_block, NULL, NULL);
/* remove any small off-diagonal elements */
chop_small_elements (n_block, d_block, sd_block);
}
}
{
gsl_vector_view d_vec = gsl_vector_view_array (d, N);
gsl_vector_memcpy (eval, &d_vec.vector);
}
return GSL_SUCCESS;
}
}
