int
test_beta(gsl_vector *obs, gsl_vector *expected,
gsl_matrix *A, gsl_matrix *B, const char *obsname,
const char *expname)
{
size_t N = expected->size;
size_t i, k;
double max, max_abserr, max_relerr;
max = 0.0;
max_abserr = 0.0;
max_relerr = 0.0;
k = 0;
for (i = 0; i < N; ++i)
{
double z = gsl_vector_get(expected, i);
max = GSL_MAX_DBL(max, fabs(z));
}
for (i = 0; i < N; ++i)
{
double v_obs = gsl_vector_get(obs, i);
double v_exp = gsl_vector_get(expected, i);
double abserr = fabs(v_obs - v_exp);
double noise = max * GSL_DBL_EPSILON * N * N;
max_abserr = GSL_MAX_DBL(max_abserr, abserr);
if (abserr < noise)
continue;
if (abserr > 1.0e-6)
++k;
}
if (k)
{
printf("==== CASE %lu ===========================\n\n", count);
print_matrix(A, "A");
print_matrix(B, "B");
printf("=== beta - %s ===\n", expname);
printf("%s = [\n", expname);
gsl_vector_fprintf(stdout, expected, "%.12e");
printf("]\n");
printf("=== beta - %s ===\n", obsname);
printf("%s = [\n", obsname);
gsl_vector_fprintf(stdout, obs, "%.12e");
printf("]\n");
printf("max abserr = %g max relerr = %g\n", max_abserr, max_relerr);
printf("=========================================\n\n");
}
return k;
} /* test_beta() */
int
gsl_sf_hypot_e(const double x, const double y, gsl_sf_result * result)
{
/* CHECK_POINTER(result) */
if(x == 0.0 && y == 0.0) {
result->val = 0.0;
result->err = 0.0;
return GSL_SUCCESS;
}
else {
const double a = fabs(x);
const double b = fabs(y);
const double min = GSL_MIN_DBL(a,b);
const double max = GSL_MAX_DBL(a,b);
const double rat = min/max;
const double root_term = sqrt(1.0 + rat*rat);
if(max < GSL_DBL_MAX/root_term) {
result->val = max * root_term;
result->err = 2.0 * GSL_DBL_EPSILON * fabs(result->val);
return GSL_SUCCESS;
}
else {
OVERFLOW_ERROR(result);
}
}
}
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);
}
}
}
int
gsl_sf_hyperg_1F1_series_e(const double a, const double b, const double x,
gsl_sf_result * result
)
{
double an = a;
double bn = b;
double n = 1.0;
double del = 1.0;
double abs_del = 1.0;
double max_abs_del = 1.0;
double sum_val = 1.0;
double sum_err = 0.0;
while(abs_del/fabs(sum_val) > GSL_DBL_EPSILON) {
double u, abs_u;
if(bn == 0.0) {
DOMAIN_ERROR(result);
}
if(an == 0.0 || n > 1000.0) {
result->val = sum_val;
result->err = sum_err;
result->err += 2.0 * GSL_DBL_EPSILON * n * fabs(sum_val);
return GSL_SUCCESS;
}
u = x * (an/(bn*n));
abs_u = fabs(u);
if(abs_u > 1.0 && max_abs_del > GSL_DBL_MAX/abs_u) {
result->val = sum_val;
result->err = fabs(sum_val);
GSL_ERROR ("overflow", GSL_EOVRFLW);
}
del *= u;
sum_val += del;
if(fabs(sum_val) > SUM_LARGE) {
result->val = sum_val;
result->err = fabs(sum_val);
GSL_ERROR ("overflow", GSL_EOVRFLW);
}
abs_del = fabs(del);
max_abs_del = GSL_MAX_DBL(abs_del, max_abs_del);
sum_err += 2.0*GSL_DBL_EPSILON*abs_del;
an += 1.0;
bn += 1.0;
n += 1.0;
}
result->val = sum_val;
result->err = sum_err;
result->err += abs_del;
result->err += 2.0 * GSL_DBL_EPSILON * n * fabs(sum_val);
return GSL_SUCCESS;
}
static int
sc_control_hadjust(void * vstate, size_t dim, unsigned int ord, const double y[], const double yerr[], const double yp[], double * h)
{
sc_control_state_t *state = (sc_control_state_t *) vstate;
const double eps_abs = state->eps_abs;
const double eps_rel = state->eps_rel;
const double a_y = state->a_y;
const double a_dydt = state->a_dydt;
const double * scale_abs = state->scale_abs;
const double S = 0.9;
const double h_old = *h;
double rmax = DBL_MIN;
size_t i;
for(i=0; i<dim; i++) {
const double D0 =
eps_rel * (a_y * fabs(y[i]) + a_dydt * fabs(h_old * yp[i]))
+ eps_abs * scale_abs[i];
const double r = fabs(yerr[i]) / fabs(D0);
rmax = GSL_MAX_DBL(r, rmax);
}
if(rmax > 1.1) {
/* decrease step, no more than factor of 5, but a fraction S more
than scaling suggests (for better accuracy) */
double r = S / pow(rmax, 1.0/ord);
if (r < 0.2)
r = 0.2;
*h = r * h_old;
return GSL_ODEIV_HADJ_DEC;
}
else if(rmax < 0.5) {
/* increase step, no more than factor of 5 */
double r = S / pow(rmax, 1.0/(ord+1.0));
if (r > 5.0)
r = 5.0;
if (r < 1.0) /* don't allow any decrease caused by S<1 */
r = 1.0;
*h = r * h_old;
return GSL_ODEIV_HADJ_INC;
}
else {
/* no change */
return GSL_ODEIV_HADJ_NIL;
}
}
static VALUE rb_GSL_MAX(VALUE obj, VALUE aa, VALUE bb)
{
double a, b;
double max;
/* Need_Float(aa); Need_Float(bb);*/
a = NUM2DBL(aa);
b = NUM2DBL(bb);
max = GSL_MAX_DBL(a, b);
if (gsl_fcmp(max, a, 1.0e-10) == 0) return aa;
else return bb;
}
void FittingPerfomanceInfo::GetSolverResults( gsl_multifit_fdfsolver *s )
{
double chi, dof, c; size_t p=s->x->size, n=s->f->size;
gsl_matrix *covar = gsl_matrix_alloc (p, p);
if(covar!=NULL)
{
gsl_multifit_covar (s->J, 0.0, covar);
chi = gsl_blas_dnrm2(s->f); dof = n - p; c = GSL_MAX_DBL(1, chi / sqrt(dof)); chisq_dof=chi*chi / dof;
for(size_t i=0;i<p;i++)
{
a[i]=gsl_vector_get(s->x, i);
da[i]=fabs(c*sqrt(gsl_matrix_get(covar,i,i)));
}
gsl_matrix_free(covar);
}
}
/* Halley iteration (eqn. 5.12, Corless et al) */
static int
halley_iteration(
double x,
double w_initial,
unsigned int max_iters,
gsl_sf_result * result
)
{
double w = w_initial;
unsigned int i;
for(i=0; i<max_iters; i++) {
double tol;
const double e = exp(w);
const double p = w + 1.0;
double t = w*e - x;
/* printf("FOO: %20.16g %20.16g\n", w, t); */
if (w > 0) {
t = (t/p)/e; /* Newton iteration */
} else {
t /= e*p - 0.5*(p + 1.0)*t/p; /* Halley iteration */
};
w -= t;
tol = 10 * GSL_DBL_EPSILON * GSL_MAX_DBL(fabs(w), 1.0/(fabs(p)*e));
if(fabs(t) < tol)
{
result->val = w;
result->err = 2.0*tol;
return GSL_SUCCESS;
}
}
/* should never get here */
result->val = w;
result->err = fabs(w);
return GSL_EMAXITER;
}
int
gsl_sf_exp_err_e(const double x, const double dx, gsl_sf_result * result)
{
const double adx = fabs(dx);
/* CHECK_POINTER(result) */
if(x + adx > GSL_LOG_DBL_MAX) {
OVERFLOW_ERROR(result);
}
else if(x - adx < GSL_LOG_DBL_MIN) {
UNDERFLOW_ERROR(result);
}
else {
const double ex = exp(x);
const double edx = exp(adx);
result->val = ex;
result->err = ex * GSL_MAX_DBL(GSL_DBL_EPSILON, edx - 1.0/edx);
result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);
return GSL_SUCCESS;
}
}
static int
modnewton1_solve (void *vstate, const gsl_matrix * A,
const double c[], const double t, const double h,
const double y0[], const gsl_odeiv2_system * sys,
double YZ[], const double errlev[])
{
/* Solves the non-linear equation system resulting from implicit
Runge-Kutta methods by a modified Newton iteration. The
modified Newton iteration with this problem is stated in the
form
IhAJ * dYk = rhs
in which IhAJ is the iteration matrix: IhAJ = (I - hA (*) J) in
which (*) is the Kronecker matrix product (size of IhAJ =
dim*stage, dim*stage), dYk is the Runge-Kutta point (Y)
difference vector for kth Newton iteration: dYk = Y(k+1) - Y(k),
and rhs = Y(k) - y0 - h * sum j=1..stage (a_j * f(Y(k)))
This function solves dYk by LU-decomposition of IhAJ with partial
pivoting.
*/
modnewton1_state_t *state = (modnewton1_state_t *) vstate;
gsl_matrix *const IhAJ = state->IhAJ;
gsl_permutation *const p = state->p;
gsl_vector *const dYk = state->dYk;
double *const Yk = state->Yk;
double *const fYk = state->fYk;
gsl_vector *const rhs = state->rhs;
double *const eeta_prev = &(state->eeta_prev);
gsl_vector *const dScal = state->dScal;
const size_t dim = sys->dimension;
const size_t stage = A->size1;
int status = GSL_CONTINUE; /* Convergence status for Newton iteration */
/* Set starting values for iteration. Use starting values of Y(k) =
y0. FIXME: Implement better initial guess described in Hairer and
Wanner.
*/
{
size_t j, m;
gsl_vector_set_zero (dYk);
for (j = 0; j < stage; j++)
for (m = 0; m < dim; m++)
Yk[j * dim + m] = y0[m];
}
/* Loop modified Newton iterations */
{
size_t iter = 0;
size_t j, m, n;
/* Maximum number of Newton iterations. */
const size_t max_iter = 7;
double dScal_norm = 0.0; /* Newton iteration step length */
double dScal_norm_prev = 0.0; /* Previous dScal_norm */
while (status == GSL_CONTINUE && iter < max_iter)
{
iter++;
/* Update Y(k) and evaluate function */
for (j = 0; j < stage; j++)
{
for (m = 0; m < dim; m++)
{
Yk[j * dim + m] += gsl_vector_get (dYk, j * dim + m);
}
{
int s = GSL_ODEIV_FN_EVAL (sys, t + c[j] * h, &Yk[j * dim],
&fYk[j * dim]);
if (s != GSL_SUCCESS)
{
return s;
}
}
}
/* Calculate rhs */
for (j = 0; j < stage; j++)
for (m = 0; m < dim; m++)
{
double sum = 0;
for (n = 0; n < stage; n++)
sum += gsl_matrix_get (A, j, n) * fYk[n * dim + m];
gsl_vector_set (rhs, j * dim + m,
-1.0 * Yk[j * dim + m] + y0[m] + h * sum);
}
/* Solve dYk */
{
int s = gsl_linalg_LU_solve (IhAJ, p, rhs, dYk);
if (s != GSL_SUCCESS)
{
return s;
}
}
/* Evaluate convergence according to method by Hairer and
Wanner, section IV.8. The iteration step is normalized by
desired error level before calculation of the norm, to take
the tolerance on each component of y into account.
*/
{
/* relative change in two Newton iteration steps */
double theta_k;
/* transformation of theta_k */
double eeta_k = 0.0;
for (j = 0; j < stage; j++)
for (m = 0; m < dim; m++)
{
gsl_vector_set (dScal, j * dim + m,
gsl_vector_get (dYk, j * dim + m)
/ errlev[m]);
}
dScal_norm_prev = dScal_norm;
dScal_norm = gsl_blas_dnrm2 (dScal);
theta_k = dScal_norm / dScal_norm_prev;
if (iter > 1)
{
/* check for increase in step size, which indicates divergence */
if (theta_k >= 1.0)
{
return GSL_FAILURE;
}
eeta_k = theta_k / (1.0 - theta_k);
}
else
{
eeta_k = pow (GSL_MAX_DBL (*eeta_prev, GSL_DBL_EPSILON), 0.8);
}
*eeta_prev = eeta_k;
if (eeta_k * dScal_norm < 1.0)
{
status = GSL_SUCCESS;
}
}
}
}
/* No convergence reached within allowed iterations */
if (status != GSL_SUCCESS)
{
return GSL_FAILURE;
}
/* Give solution in YZ */
else
{
size_t j, m;
for (j = 0; j < stage; j++)
for (m = 0; m < dim; m++)
YZ[j * dim + m] =
Yk[j * dim + m] + gsl_vector_get (dYk, j * dim + m);
return status;
}
}
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);
}
}
f_all_sol do_fit_duplex(f_info *f, int n, real *t_min, real *t_max, bool bVerbose, bool bUpdate)
{
int i,j,k;
int iter=0;
int tot_points=0;
int status;
int tot_abs=0;
int tot_inv_t=0;
real inv_t=0;
real tss_inv=0;
real mean_inv_t=0;
real abs_t=0;
real mean_abs_t=0;
real tss_abs=0;
real tss_tot=0;
f_all_sol fit;
f_info *local_f;
snew(local_f,n);
// count points within boundaries, allocate
// and copy to new array. Only copy the xp (derivative)
// as is the one that matters for the fitting
for(i=0; i<n; i++){
for(j=0; j<f[i].nts; j++){
if( f[i].xp[0][j] >= t_min[i] && f[i].xp[0][j] <= t_max[i] ) { local_f[i].nts++ ; }
}
snew(local_f[i].xp[0],local_f[i].nts);
snew(local_f[i].xp[1],local_f[i].nts);
}
// now copy the data
// not only the derivatives of the absorbance, also the conc
k=0;
for(i=0; i<n; i++){
local_f[i].conc = f[i].conc ;
for(j=0; j<f[i].nts; j++){
if( f[i].xp[0][j] >= t_min[i] && f[i].xp[0][j] <= t_max[i] ) {
local_f[i].xp[0][k] = f[i].xp[0][j] ;
local_f[i].xp[1][k] = f[i].xp[1][j] ;
// we use this loop to compute the TSS, the total sum of squares of the
// "y" data, to be used for r_squared after we know chi_sq
abs_t += local_f[i].xp[1][k] ;
tot_abs++;
k++;
}
}
k=0;
}
// Total number of points to fit
size_t pp = 4;
const gsl_multifit_fdfsolver_type *T;
T = gsl_multifit_fdfsolver_lmsder;
gsl_multifit_fdfsolver *s;
// do a fit for each triplex curve
for (i=0; i<n; i++){
// Total number of points to fit
if (bVerbose){printf("Working on curve n %d\n",i);}
struct fit_data d = { n,i, local_f};
tot_points = local_f[i].nts ;
gsl_matrix *covar = gsl_matrix_alloc (pp, pp);
gsl_multifit_function_fdf ff;
gsl_vector *x;
x = gsl_vector_alloc(pp);
gsl_vector_set(x,0,f[i].tm2);
gsl_vector_set(x,1,f[i].c);
gsl_vector_set(x,2,-70);
gsl_vector_set(x,3,-0.1);
s = gsl_multifit_fdfsolver_alloc (T, tot_points, pp);
// copy data to function
ff.f = &eq_fit;
ff.df = NULL;
ff.fdf = NULL;
ff.p = pp;
// total number of points is total of points
// in the curve plus the number of points for the inv. fit
ff.n = tot_points;
ff.params = &d;
gsl_multifit_fdfsolver_set (s, &ff, x);
iter=0;
do
{
iter++;
status = gsl_multifit_fdfsolver_iterate (s);
if(bVerbose){
printf ("iter: %3u x = % 15.8f % 15.8f %15.8f "
"|f(x)| = %g\n",iter,
gsl_vector_get (s->x, 0),
gsl_vector_get (s->x, 1),
gsl_vector_get (s->x, 2),
gsl_blas_dnrm2 (s->f));
}
if (status)
break;
status = gsl_multifit_test_delta (s->dx, s->x,
1e-8, 1e-8);
}
while (status == GSL_CONTINUE && iter < 500);
gsl_multifit_covar (s->J, 0.0, covar);
gsl_matrix_free (covar);
gsl_vector_free(x);
// copy tm2 data adjusted from each curve
local_f[i].tm2 = gsl_vector_get(s->x, 0);
}
//free first solver
gsl_multifit_fdfsolver_free (s);
// do the 1/tm vs ln(ct) fitting
const gsl_multifit_fdfsolver_type *Tl;
gsl_multifit_fdfsolver *sl;
// fit params in the straight line
int ppl = 2;
gsl_matrix *covarl = gsl_matrix_alloc (ppl, ppl);
struct fit_data dl = { n,i, local_f};
gsl_multifit_function_fdf ffl;
gsl_vector *xl;
xl = gsl_vector_alloc(ppl);
// DH and DS
gsl_vector_set(xl,0,-70);
gsl_vector_set(xl,1,-0.1);
Tl = gsl_multifit_fdfsolver_lmsder;
sl = gsl_multifit_fdfsolver_alloc (Tl, n, ppl);
// copy data to function
ffl.f=&eq_fit_straight;
ffl.df = NULL;
ffl.fdf = NULL;
ffl.p = ppl;
// total number of points the number of curves
ffl.n = n;
ffl.params = &dl;
gsl_multifit_fdfsolver_set (sl, &ffl, xl);
iter=0;
do
{
iter++;
status = gsl_multifit_fdfsolver_iterate (sl);
if(bVerbose){
printf ("iter: %3u x = % 15.8f % 15.8f "
"|f(x)| = %g\n",iter,
gsl_vector_get (sl->x, 0),
gsl_vector_get (sl->x, 1),
gsl_blas_dnrm2 (sl->f));
}
if (status)
break;
status = gsl_multifit_test_delta (sl->dx, sl->x,
1e-8, 1e-8);
}
while (status == GSL_CONTINUE && iter < 500);
gsl_multifit_covar (sl->J, 0.0, covarl);
#define FIT(i) gsl_vector_get(sl->x, i)
#define ERR(i) sqrt(gsl_matrix_get(covarl,i,i))
// compute contribution of inverse temperature to TSS
for(i=0;i<n;i++){
inv_t += ((real)1.0/(real)local_f[i].tm2);
tot_inv_t++;
}
mean_inv_t = inv_t / (real)tot_inv_t;
for(i=0;i<n;i++){
tss_inv += (1.0/(real)local_f[i].tm2 - mean_inv_t ) * (1.0/(real)local_f[i].tm2 - mean_inv_t);
}
if (bUpdate){
fit.dh2 = gsl_vector_get(sl->x, 0);
fit.ds2 = gsl_vector_get(sl->x, 1);
fit.dg2 = fit.dh2 - 298.15*fit.ds2;
for(i=0; i<n; i++){
f[i].tm2 = local_f[i].tm2 ;
}
}
tss_tot = tss_inv ;
double chi = gsl_blas_dnrm2(sl->f);
fit.r2 = 1.0 - ( chi*chi / tss_tot ) ;
double dof = n - ppl;
double c = GSL_MAX_DBL(1, chi / sqrt(dof));
if(bVerbose)
{
printf ("chisq/dof = %g\n", pow(chi, 2.0) / dof);
printf ("r2 = %g\n", fit.r2);
printf ("DH3 = %.5f +/- %.5f\n", FIT(0), c*ERR(0));
printf ("DS3 = %.5f +/- %.5f\n", FIT(1), c*ERR(1));
printf ("DG3 = %.5f +/- %.5f\n", FIT(0)-298*FIT(1),c*ERR(1)+c*298*ERR(0));
printf ("status = %s\n", gsl_strerror (status));
}
gsl_multifit_fdfsolver_free (sl);
gsl_matrix_free (covarl);
gsl_vector_free(xl);
return fit;
}
static VALUE rb_GSL_MIN_DBL(VALUE obj, VALUE aa, VALUE bb)
{
Need_Float(aa); Need_Float(bb);
return rb_float_new(GSL_MAX_DBL(NUM2DBL(aa), NUM2DBL(bb)));
}
/* Assumes a>0 and a+x>0.
*/
static
int
lnpoch_pos(const double a, const double x, gsl_sf_result * result)
{
double absx = fabs(x);
if(absx > 0.1*a || absx*log(GSL_MAX_DBL(a,2.0)) > 0.1) {
if(a < GSL_SF_GAMMA_XMAX && a+x < GSL_SF_GAMMA_XMAX) {
/* If we can do it by calculating the gamma functions
* directly, then that will be more accurate than
* doing the subtraction of the logs.
*/
gsl_sf_result g1;
gsl_sf_result g2;
gsl_sf_gammainv_e(a, &g1);
gsl_sf_gammainv_e(a+x, &g2);
result->val = -log(g2.val/g1.val);
result->err = g1.err/fabs(g1.val) + g2.err/fabs(g2.val);
result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);
return GSL_SUCCESS;
}
else {
/* Otherwise we must do the subtraction.
*/
gsl_sf_result lg1;
gsl_sf_result lg2;
int stat_1 = gsl_sf_lngamma_e(a, &lg1);
int stat_2 = gsl_sf_lngamma_e(a+x, &lg2);
result->val = lg2.val - lg1.val;
result->err = lg2.err + lg1.err;
result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);
return GSL_ERROR_SELECT_2(stat_1, stat_2);
}
}
else if(absx < 0.1*a && a > 15.0) {
/* Be careful about the implied subtraction.
* Note that both a+x and and a must be
* large here since a is not small
* and x is not relatively large.
* So we calculate using Stirling for Log[Gamma(z)].
*
* Log[Gamma(a+x)/Gamma(a)] = x(Log[a]-1) + (x+a-1/2)Log[1+x/a]
* + (1/(1+eps) - 1) / (12 a)
* - (1/(1+eps)^3 - 1) / (360 a^3)
* + (1/(1+eps)^5 - 1) / (1260 a^5)
* - (1/(1+eps)^7 - 1) / (1680 a^7)
* + ...
*/
const double eps = x/a;
const double den = 1.0 + eps;
const double d3 = den*den*den;
const double d5 = d3*den*den;
const double d7 = d5*den*den;
const double c1 = -eps/den;
const double c3 = -eps*(3.0+eps*(3.0+eps))/d3;
const double c5 = -eps*(5.0+eps*(10.0+eps*(10.0+eps*(5.0+eps))))/d5;
const double c7 = -eps*(7.0+eps*(21.0+eps*(35.0+eps*(35.0+eps*(21.0+eps*(7.0+eps))))))/d7;
const double p8 = gsl_sf_pow_int(1.0+eps,8);
const double c8 = 1.0/p8 - 1.0; /* these need not */
const double c9 = 1.0/(p8*(1.0+eps)) - 1.0; /* be very accurate */
const double a4 = a*a*a*a;
const double a6 = a4*a*a;
const double ser_1 = c1 + c3/(30.0*a*a) + c5/(105.0*a4) + c7/(140.0*a6);
const double ser_2 = c8/(99.0*a6*a*a) - 691.0/360360.0 * c9/(a6*a4);
const double ser = (ser_1 + ser_2)/ (12.0*a);
double term1 = x * log(a/M_E);
double term2;
gsl_sf_result ln_1peps;
gsl_sf_log_1plusx_e(eps, &ln_1peps); /* log(1 + x/a) */
term2 = (x + a - 0.5) * ln_1peps.val;
result->val = term1 + term2 + ser;
result->err = GSL_DBL_EPSILON*fabs(term1);
result->err += fabs((x + a - 0.5)*ln_1peps.err);
result->err += fabs(ln_1peps.val) * GSL_DBL_EPSILON * (fabs(x) + fabs(a) + 0.5);
result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);
return GSL_SUCCESS;
}
else {
gsl_sf_result poch_rel;
int stat_p = pochrel_smallx(a, x, &poch_rel);
double eps = x*poch_rel.val;
int stat_e = gsl_sf_log_1plusx_e(eps, result);
result->err = 2.0 * fabs(x * poch_rel.err / (1.0 + eps));
result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);
return GSL_ERROR_SELECT_2(stat_e, stat_p);
}
}
int cspl_qrs_fit (void * params) {
int status;
unsigned int iter;
struct cspl_qrs_data * data = (struct cspl_qrs_data *) params;
/* This is the data to be fitted */
gsl_multifit_function_fdf f;
// const gsl_rng_type * type;
// gsl_rng * r;
// gsl_rng_env_setup();
// type = gsl_rng_default;
// r = gsl_rng_alloc (type);
f.f = &cspl_qrs_f;
f.df = &cspl_qrs_df;
f.fdf = &cspl_qrs_fdf;
f.n = data->n;
f.p = data->p;
f.params = data;
gsl_multifit_fdfsolver_set (data->s, &f, &data->x.vector);
iter = 0;
//print_state (iter, data->s);
do
{
iter++;
status = gsl_multifit_fdfsolver_iterate (data->s);
#ifdef DEBUG
printf ("status = %s\n", gsl_strerror (status));
print_state (iter, data->s);
#endif
if (status)
break;
status = gsl_multifit_test_delta (data->s->dx, data->s->x,
1e-12, 1e-12);
}
while (status == GSL_CONTINUE && iter < 500);
gsl_multifit_covar (data->s->J, 0.0, data->covar);
double chi = gsl_blas_dnrm2(data->s->f);
double dof = data->n - data->p;
double c = GSL_MAX_DBL(1, chi / sqrt(dof));
data->c = c;
data->chisq_pdof = pow(chi, 2.0) / dof;
#ifdef DEBUG
#define FIT(i) gsl_vector_get(data->s->x, i)
#define ERR(i) sqrt(gsl_matrix_get(data->covar,i,i))
printf("chisq/dof = %g\n", pow(chi, 2.0) / dof);
printf ("A = %.5f +/- %.5f\n", FIT(0), c*ERR(0));
printf ("t_beat = %.5f +/- %.5f\n", FIT(1), c*ERR(1));
printf ("S_0 = %.5f +/- %.5f\n", FIT(2), c*ERR(2));
printf ("S_1 = %.5f +/- %.5f\n", FIT(3), c*ERR(3));
printf ("status = %s\n", gsl_strerror (status));
#endif
// gsl_rng_free (r);
return GSL_SUCCESS;
}
//--------------------------------------------------------------------------------------------------
double triangular_kernel( const double& h, const double& c, const double& alpha ) {
return c * GSL_MAX_DBL( alpha - h, 0 );
}
int InterpolaVPR_GSL::interpola_VPR(const float* vpr, int hvprmax, int livmin)
{
LOG_CATEGORY("radar.vpr");
static const unsigned N = 10;
const gsl_multifit_fdfsolver_type *T;
gsl_multifit_fdfsolver *s;
int status;
unsigned int i;
const size_t n = N;
const size_t p = 5;
char file_vprint[512];
gsl_matrix *covar = gsl_matrix_alloc (p, p);
double a[5];
struct data d(N);
gsl_multifit_function_fdf f;
double x_init[5] = { 4, 0.2, 3. , 1.4, -0.4 };
gsl_vector_view x = gsl_vector_view_array (x_init, p);
//////////////////////////////////////////////////////////////////////////////
int ier_int=0;
double xint,yint;
/* punti interessanti per inizializzare parametri*/
int in1=(int)((hvprmax-TCK_VPR/2)/TCK_VPR); //indice del massimo
int in2=(int)((hvprmax+HALF_BB)/TCK_VPR); //indice del massimo + 500 m
int in3=in2+1;
int in4=in2+5; //indice del massimo + 1000 m
if (in4 > NMAXLAYER-1) {
ier_int=1;
return ier_int;
}
B=vpr[in1]-vpr[in2];
E=hvprmax/1000.;
G=0.25;
C=vpr[in2-1];
F=vpr[in4]<vpr[in3]?(vpr[in4]-vpr[in3])/((in4-in3)*TCK_VPR/1000.):0.;
// fprintf(stderr, "const unsigned NMAXLAYER=%d;\n", NMAXLAYER);
// fprintf(stderr, "float vpr[] = {");
// for (unsigned i = 0; i < NMAXLAYER; ++i)
// fprintf(stderr, "%s%f", i==0?"":",", (double)vpr[i]);
// fprintf(stderr, "};\n");
x_init[0]= a[0]=B;
x_init[1]= a[1]=E;
x_init[2]= a[2]=G;
x_init[3]= a[3]=C;
x_init[4]= a[4]=F;
/////////////////////////////////////////////////////////////////////////////////////////////////////////
f.f = &expb_f;
f.df = &expb_df;
f.fdf = &expb_fdf;
f.n = n;
f.p = p;
f.params = &d;
/* This is the data to be fitted */
for (i = 0; i < n; i++)
{
d.t[i]= ((hvprmax-1000.)>livmin)? (i*TCK_VPR+(hvprmax-800)-TCK_VPR)/1000. : (livmin+i*TCK_VPR)/1000.;
d.y[i]= ((hvprmax-1000.)>livmin)? vpr[i+(int)(((hvprmax-800)-TCK_VPR)/TCK_VPR)] : vpr[i+(int)(livmin/TCK_VPR)];
d.sigma[i] = 0.5;
};
T = gsl_multifit_fdfsolver_lmsder;
s = gsl_multifit_fdfsolver_alloc (T, n, p);
gsl_multifit_fdfsolver_set (s, &f, &x.vector);
//print_state (0, s);
bool found = false;
for (unsigned iter = 0; !found && iter < 500; ++iter)
{
//fprintf(stderr, "Iter %d\n", iter);
//d.print();
int status = gsl_multifit_fdfsolver_iterate (s);
if (status != 0)
{
LOG_ERROR("gsl_multifit_fdfsolver_iterate: %s", gsl_strerror(status));
return 1;
}
//print_state (iter, s);
status = gsl_multifit_test_delta (s->dx, s->x,
1e-4, 1e-4);
switch (status)
{
case GSL_SUCCESS: found = true; break;
case GSL_CONTINUE: break;
default:
LOG_ERROR("gsl_multifit_test_delta: %s", gsl_strerror(status));
return 1;
}
}
#if GSL_MAJOR_VERSION == 2
// Use of GSL 2.0 taken from https://sft.its.cern.ch/jira/browse/ROOT-7776
gsl_matrix* J = gsl_matrix_alloc(s->fdf->n, s->fdf->p);
gsl_multifit_fdfsolver_jac(s, J);
gsl_multifit_covar(J, 0.0, covar);
#else
gsl_multifit_covar(s->J, 0.0, covar);
#endif
#define FIT(i) gsl_vector_get(s->x, i)
#define ERR(i) sqrt(gsl_matrix_get(covar,i,i))
{
double chi = gsl_blas_dnrm2(s->f);
double dof = n - p;
double c = GSL_MAX_DBL(1, chi / sqrt(dof));
// printf("chisq/dof = %g\n", pow(chi, 2.0) / dof);
// printf ("B = %.5f +/- %.5f\n", FIT(0), c*ERR(0));
// printf ("E = %.5f +/- %.5f\n", FIT(1), c*ERR(1));
// printf ("G = %.5f +/- %.5f\n", FIT(2), c*ERR(2));
// printf ("C = %.5f +/- %.5f\n", FIT(3), c*ERR(3));
// printf ("F = %.5f +/- %.5f\n", FIT(4), c*ERR(4));
}
B = a[0] = FIT(0);
E = a[1] = FIT(1);
G = a[2] = FIT(2);
C = a[3] = FIT(3);
F = a[4] = FIT(4);
gsl_multifit_fdfsolver_free (s);
gsl_matrix_free (covar);
/////////////////////////////////////////////////////////
if (testfit(a) == 1)
return 1;
for (i=1; i<=N; i++)
{
xint=(i*TCK_VPR-TCK_VPR/2)/1000.;
yint= lineargauss(xint, a);
vpr_int[i-1] = yint;
}
return 0;
}
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);
}
}
static int
qags (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 res_ext, err_ext;
double result0, abserr0, resabs0, resasc0;
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;
/* Initialize results */
initialise (workspace, a, b);
*result = 0;
*abserr = 0;
if (limit > workspace->limit)
{
GSL_ERROR ("iteration limit exceeds available workspace", GSL_EINVAL) ;
}
/* Test on accuracy */
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);
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 && 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);
}
/* Initialization */
initialise_table (&table);
append_table (&table, result0);
area = result0;
errsum = abserr0;
res_ext = result0;
err_ext = GSL_DBL_MAX;
positive_integrand = test_positivity (result0, resabs0);
iteration = 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 (iteration > 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 (iteration == 2) /* set up variables on first iteration */
{
error_over_large_intervals = errsum;
ertest = tolerance;
append_table (&table, area);
continue;
}
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;
}
if (!error_type2 && error_over_large_intervals > ertest)
{
if (increase_nrmax (workspace))
continue;
}
/* Perform extrapolation */
append_table (&table, area);
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;
}
/* work on interval with largest error */
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 (res_ext != 0.0 && area != 0.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.0 || 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);
}
}
static int vector_bfgs3_iterate(void *vstate, gsl_multimin_function_fdf * fdf, gsl_vector * x, double *f, gsl_vector * gradient, gsl_vector * dx)
{
vector_bfgs3_state_t *state = (vector_bfgs3_state_t *) vstate;
double alpha = 0.0, alpha1;
gsl_vector *x0 = state->x0;
gsl_vector *g0 = state->g0;
gsl_vector *p = state->p;
double g0norm = state->g0norm;
double pnorm = state->pnorm;
double delta_f = state->delta_f;
double pg, dir;
int status;
double f0 = *f;
if (pnorm == 0.0 || g0norm == 0.0 || state->fp0 == 0) {
gsl_vector_set_zero(dx);
return GSL_ENOPROG;
}
if (delta_f < 0) {
double del = GSL_MAX_DBL(-delta_f, 10 * GSL_DBL_EPSILON * fabs(f0));
alpha1 = GSL_MIN_DBL(1.0, 2.0 * del / (-state->fp0));
} else {
alpha1 = fabs(state->step);
}
/*
* line minimisation, with cubic interpolation (order = 3)
*/
if (debug)
printf("...call minimize()\n");
status = minimize(&state->wrap.fdf_linear, state->rho, state->sigma, state->tau1, state->tau2, state->tau3, state->order, alpha1, &alpha);
if (debug)
printf("...end minimize()\n");
if (status != GSL_SUCCESS) {
update_position(&(state->wrap), alpha, x, f, gradient); /* YES! hrue */
return status;
}
update_position(&(state->wrap), alpha, x, f, gradient);
state->delta_f = *f - f0;
/*
* Choose a new direction for the next step
*/
{
/*
* This is the BFGS update:
*/
/*
* p' = g1 - A dx - B dg
*/
/*
* A = - (1+ dg.dg/dx.dg) B + dg.g/dx.dg
*/
/*
* B = dx.g/dx.dg
*/
gsl_vector *dx0 = state->dx0;
gsl_vector *dg0 = state->dg0;
double dxg, dgg, dxdg, dgnorm, A, B;
/*
* dx0 = x - x0
*/
gsl_vector_memcpy(dx0, x);
gsl_blas_daxpy(-1.0, x0, dx0);
gsl_vector_memcpy(dx, dx0); /* keep a copy */
/*
* dg0 = g - g0
*/
gsl_vector_memcpy(dg0, gradient);
gsl_blas_daxpy(-1.0, g0, dg0);
gsl_blas_ddot(dx0, gradient, &dxg);
gsl_blas_ddot(dg0, gradient, &dgg);
gsl_blas_ddot(dx0, dg0, &dxdg);
dgnorm = gsl_blas_dnrm2(dg0);
if (dxdg != 0) {
B = dxg / dxdg;
A = -(1.0 + dgnorm * dgnorm / dxdg) * B + dgg / dxdg;
} else {
B = 0;
A = 0;
}
gsl_vector_memcpy(p, gradient);
gsl_blas_daxpy(-A, dx0, p);
gsl_blas_daxpy(-B, dg0, p);
}
gsl_vector_memcpy(g0, gradient);
gsl_vector_memcpy(x0, x);
state->g0norm = gsl_blas_dnrm2(g0);
state->pnorm = gsl_blas_dnrm2(p);
/*
* update direction and fp0
*/
gsl_blas_ddot(p, gradient, &pg);
dir = (pg >= 0.0) ? -1.0 : +1.0;
gsl_blas_dscal(dir / state->pnorm, p);
state->pnorm = gsl_blas_dnrm2(p);
gsl_blas_ddot(p, g0, &state->fp0);
change_direction(&state->wrap);
return GSL_SUCCESS;
}
int
gsl_integration_qawf (gsl_function * f,
const double a,
const double epsabs,
const size_t limit,
gsl_integration_workspace * workspace,
gsl_integration_workspace * cycle_workspace,
gsl_integration_qawo_table * wf,
double *result, double *abserr)
{
double area, errsum;
double res_ext, err_ext;
double correc, total_error = 0.0, truncation_error;
size_t ktmin = 0;
size_t iteration = 0;
struct extrapolation_table table;
double cycle;
double omega = wf->omega;
const double p = 0.9;
double factor = 1;
double initial_eps, eps;
int error_type = 0;
/* Initialize results */
initialise (workspace, a, a);
*result = 0;
*abserr = 0;
if (limit > workspace->limit)
{
GSL_ERROR ("iteration limit exceeds available workspace", GSL_EINVAL) ;
}
/* Test on accuracy */
if (epsabs <= 0)
{
GSL_ERROR ("absolute tolerance epsabs must be positive", GSL_EBADTOL) ;
}
if (omega == 0.0)
{
if (wf->sine == GSL_INTEG_SINE)
{
/* The function sin(w x) f(x) is always zero for w = 0 */
*result = 0;
*abserr = 0;
return GSL_SUCCESS;
}
else
{
/* The function cos(w x) f(x) is always f(x) for w = 0 */
int status = gsl_integration_qagiu (f, a, epsabs, 0.0,
cycle_workspace->limit,
cycle_workspace,
result, abserr);
return status;
}
}
if (epsabs > GSL_DBL_MIN / (1 - p))
{
eps = epsabs * (1 - p);
}
else
{
eps = epsabs;
}
initial_eps = eps;
area = 0;
errsum = 0;
res_ext = 0;
err_ext = GSL_DBL_MAX;
correc = 0;
cycle = (2 * floor (fabs (omega)) + 1) * M_PI / fabs (omega);
gsl_integration_qawo_table_set_length (wf, cycle);
initialise_table (&table);
for (iteration = 0; iteration < limit; iteration++)
{
double area1, error1, reseps, erreps;
double a1 = a + iteration * cycle;
double b1 = a1 + cycle;
double epsabs1 = eps * factor;
int status = gsl_integration_qawo (f, a1, epsabs1, 0.0, limit,
cycle_workspace, wf,
&area1, &error1);
append_interval (workspace, a1, b1, area1, error1);
factor *= p;
area = area + area1;
errsum = errsum + error1;
/* estimate the truncation error as 50 times the final term */
truncation_error = 50 * fabs (area1);
total_error = errsum + truncation_error;
if (total_error < epsabs && iteration > 4)
{
goto compute_result;
}
if (error1 > correc)
{
correc = error1;
}
if (status)
{
eps = GSL_MAX_DBL (initial_eps, correc * (1.0 - p));
}
if (status && total_error < 10 * correc && iteration > 3)
{
goto compute_result;
}
append_table (&table, area);
if (table.n < 2)
{
continue;
}
qelg (&table, &reseps, &erreps);
ktmin++;
if (ktmin >= 15 && err_ext < 0.001 * total_error)
{
error_type = 4;
}
if (erreps < err_ext)
{
ktmin = 0;
err_ext = erreps;
res_ext = reseps;
if (err_ext + 10 * correc <= epsabs)
break;
if (err_ext <= epsabs && 10 * correc >= epsabs)
break;
}
}
if (iteration == limit)
error_type = 1;
if (err_ext == GSL_DBL_MAX)
goto compute_result;
err_ext = err_ext + 10 * correc;
*result = res_ext;
*abserr = err_ext;
if (error_type == 0)
{
return GSL_SUCCESS ;
}
if (res_ext != 0.0 && area != 0.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;
}
if (error_type == 4)
{
err_ext = err_ext + truncation_error;
}
goto return_error;
compute_result:
*result = area;
*abserr = total_error;
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);
}
}
double fit_n(set_const* Init, double n0){
const gsl_multifit_fdfsolver_type *T;
gsl_multifit_fdfsolver *s;
int status;
unsigned int i, iter = 0;
const size_t n = 11;
const size_t p = 5;
double k = n0/0.16;
gsl_matrix *covar = gsl_matrix_alloc (p, p);
double y[11] = {4.45, 6.45 , 9.65, 13.29, 17.94, 22.92, 27.49, 38.82, 54.95, 75.13, 99.75};
double t[11] = {k*0.02,k*0.04, k*0.08,k*0.12,k*0.16,k*0.2,k*0.24, k*0.32, k*0.4,k*0.48, k*0.56};
struct data d = { n, y, t, Init};
gsl_multifit_function_fdf f;
double x_init[5] = {Init->C_s,Init->C_o, Init->b,Init->c, Init->C_r};
//double x_init[6] = {11.56279437,7.49931859,0.00871711,0.00267620,0.86859184,0.5};
//double x_init[4] = { sqrt(130.746),sqrt(120.7244),1.0,10.0};
gsl_vector_view x = gsl_vector_view_array (x_init, p);
const gsl_rng_type * type;
gsl_rng * r;
gsl_rng_env_setup();
type = gsl_rng_default;
r = gsl_rng_alloc (type);
f.f = &func_fit_n;
f.df = NULL;
f.fdf = NULL;
f.n = n;
f.p = p;
f.params = &d;
/* This is the data to be fitted */
/*for (i = 0; i < n; i++)
{
double t = i;
y[i] = 1.0 + 5 * exp (-0.1 * t)
+ gsl_ran_gaussian (r, 0.1);
sigma[i] = 0.1;
printf ("data: %u %g %g\n", i, y[i], sigma[i]);
};*/
T = gsl_multifit_fdfsolver_lmsder;
s = gsl_multifit_fdfsolver_alloc (T, n, p);
gsl_multifit_fdfsolver_set (s, &f, &x.vector);
print_state (iter, s);
do
{
iter++;
status = gsl_multifit_fdfsolver_iterate (s);
//printf ("status = %s\n", gsl_strerror (status));
print_state (iter, s);
if (status)
break;
status = gsl_multifit_test_delta (s->dx, s->x,
1e-15, 0.0);
}
while (status == GSL_CONTINUE && iter < 2000);
gsl_multifit_covar (s->J, 0.0, covar);
#define FIT(i) gsl_vector_get(s->x, i)
#define ERR(i) sqrt(gsl_matrix_get(covar,i,i))
cond(Init, FIT(0), FIT(1), FIT(2), FIT(3), FIT(4));
{
double chi = gsl_blas_dnrm2(s->f);
double dof = n - p;
double c = GSL_MAX_DBL(1, chi / sqrt(dof));
//double c = 1.0;
/*printf("chisq/dof = %g\n", pow(chi, 2.0) / dof);
printf ("Cs = %.5f +/- %.5f\n", Init->C_s, c*ERR(0));
printf ("Co = %.5f +/- %.5f\n", Init->C_o, c*ERR(1));
printf ("b = %.5f +/- %.5f\n", Init->c, c*ERR(2));
printf ("c = %.5f +/- %.5f\n", Init->b, c*ERR(3));
printf ("Cr = %.5f +/- %.5f\n", Init->C_r, c*ERR(4));*/
}
// printf ("status = %s\n", gsl_strerror (status));
double z = 0.65;
gsl_matrix_free (covar);
gsl_rng_free (r);
double yi = 0;
/*for (int i = 0; i < 11; i++){
double yi = EoS::t_E(t[i],0, Init)/(D*t[i]) - m_n ;
printf("n = %.3f, %.3f %.3f %.3f \n",
t[i],
yi,
y[i],
yi-y[i]);
}*/
/*return *(new set_const("APR_fit return constant set",FIT(0), FIT(1), 10.0, FIT(2),abs(FIT(3)), z,
[](double f){return (1-f);},
[](double f){return 1.0;},
[=](double f){return eta_o(f);},
[](double f){return 1.0;}));*/
double rr = gsl_blas_dnrm2(s->x);
gsl_multifit_fdfsolver_free (s);
return rr;
}
int
main (void)
{
const gsl_multifit_fdfsolver_type *T;
gsl_multifit_fdfsolver *s;
int status;
unsigned int i, iter = 0;
const size_t n = N;
const size_t p = 3;
gsl_matrix *covar = gsl_matrix_alloc (p, p);
double y[N], sigma[N];
struct data d = { n, y, sigma};
gsl_multifit_function_fdf f;
double x_init[3] = { 1.0, 0.0, 0.0 };
gsl_vector_view x = gsl_vector_view_array (x_init, p);
const gsl_rng_type * type;
gsl_rng * r;
gsl_rng_env_setup();
type = gsl_rng_default;
r = gsl_rng_alloc (type);
f.f = &expb_f;
f.df = &expb_df;
f.fdf = &expb_fdf;
f.n = n;
f.p = p;
f.params = &d;
/* This is the data to be fitted */
for (i = 0; i < n; i++)
{
double t = i;
y[i] = 1.0 + 5 * exp (-0.1 * t)
+ gsl_ran_gaussian (r, 0.1);
sigma[i] = 0.1;
printf ("data: %u %g %g\n", i, y[i], sigma[i]);
};
T = gsl_multifit_fdfsolver_lmsder;
s = gsl_multifit_fdfsolver_alloc (T, n, p);
gsl_multifit_fdfsolver_set (s, &f, &x.vector);
print_state (iter, s);
do
{
iter++;
status = gsl_multifit_fdfsolver_iterate (s);
printf ("status = %s\n", gsl_strerror (status));
print_state (iter, s);
if (status)
break;
status = gsl_multifit_test_delta (s->dx, s->x,
1e-4, 1e-4);
}
while (status == GSL_CONTINUE && iter < 500);
gsl_multifit_covar (s->J, 0.0, covar);
#define FIT(i) gsl_vector_get(s->x, i)
#define ERR(i) sqrt(gsl_matrix_get(covar,i,i))
{
double chi = gsl_blas_dnrm2(s->f);
double dof = n - p;
double c = GSL_MAX_DBL(1, chi / sqrt(dof));
printf("chisq/dof = %g\n", pow(chi, 2.0) / dof);
printf ("A = %.5f +/- %.5f\n", FIT(0), c*ERR(0));
printf ("lambda = %.5f +/- %.5f\n", FIT(1), c*ERR(1));
printf ("b = %.5f +/- %.5f\n", FIT(2), c*ERR(2));
}
printf ("status = %s\n", gsl_strerror (status));
gsl_multifit_fdfsolver_free (s);
gsl_matrix_free (covar);
gsl_rng_free (r);
return 0;
}
/*! \fn double max_three(double a, double b, double c)
* \brief Returns the max of 3 numbers */
double max_three(double a, double b, double c)
{
return GSL_MAX_DBL(GSL_MAX_DBL(a,b),c);
}
int
main (void)
{
const gsl_multifit_nlinear_type *T = gsl_multifit_nlinear_trust;
gsl_multifit_nlinear_workspace *w;
gsl_multifit_nlinear_fdf fdf;
gsl_multifit_nlinear_parameters fdf_params =
gsl_multifit_nlinear_default_parameters();
const size_t n = N;
const size_t p = 3;
gsl_vector *f;
gsl_matrix *J;
gsl_matrix *covar = gsl_matrix_alloc (p, p);
double y[N], weights[N];
struct data d = { n, y };
double x_init[3] = { 1.0, 1.0, 0.0 }; /* starting values */
gsl_vector_view x = gsl_vector_view_array (x_init, p);
gsl_vector_view wts = gsl_vector_view_array(weights, n);
gsl_rng * r;
double chisq, chisq0;
int status, info;
size_t i;
const double xtol = 1e-8;
const double gtol = 1e-8;
const double ftol = 0.0;
gsl_rng_env_setup();
r = gsl_rng_alloc(gsl_rng_default);
/* define the function to be minimized */
fdf.f = expb_f;
fdf.df = expb_df; /* set to NULL for finite-difference Jacobian */
fdf.fvv = NULL; /* not using geodesic acceleration */
fdf.n = n;
fdf.p = p;
fdf.params = &d;
/* this is the data to be fitted */
for (i = 0; i < n; i++)
{
double t = i;
double yi = 1.0 + 5 * exp (-0.1 * t);
double si = 0.1 * yi;
double dy = gsl_ran_gaussian(r, si);
weights[i] = 1.0 / (si * si);
y[i] = yi + dy;
printf ("data: "F_ZU" %g %g\n", i, y[i], si);
};
/* allocate workspace with default parameters */
w = gsl_multifit_nlinear_alloc (T, &fdf_params, n, p);
/* initialize solver with starting point and weights */
gsl_multifit_nlinear_winit (&x.vector, &wts.vector, &fdf, w);
/* compute initial cost function */
f = gsl_multifit_nlinear_residual(w);
gsl_blas_ddot(f, f, &chisq0);
/* solve the system with a maximum of 20 iterations */
status = gsl_multifit_nlinear_driver(20, xtol, gtol, ftol,
callback, NULL, &info, w);
/* compute covariance of best fit parameters */
J = gsl_multifit_nlinear_jac(w);
gsl_multifit_nlinear_covar (J, 0.0, covar);
/* compute final cost */
gsl_blas_ddot(f, f, &chisq);
#define FIT(i) gsl_vector_get(w->x, i)
#define ERR(i) sqrt(gsl_matrix_get(covar,i,i))
fprintf(stderr, "summary from method '%s/%s'\n",
gsl_multifit_nlinear_name(w),
gsl_multifit_nlinear_trs_name(w));
fprintf(stderr, "number of iterations: "F_ZU"\n",
gsl_multifit_nlinear_niter(w));
fprintf(stderr, "function evaluations: "F_ZU"\n", fdf.nevalf);
fprintf(stderr, "Jacobian evaluations: "F_ZU"\n", fdf.nevaldf);
fprintf(stderr, "reason for stopping: %s\n",
(info == 1) ? "small step size" : "small gradient");
fprintf(stderr, "initial |f(x)| = %f\n", sqrt(chisq0));
fprintf(stderr, "final |f(x)| = %f\n", sqrt(chisq));
{
double dof = n - p;
double c = GSL_MAX_DBL(1, sqrt(chisq / dof));
fprintf(stderr, "chisq/dof = %g\n", chisq / dof);
fprintf (stderr, "A = %.5f +/- %.5f\n", FIT(0), c*ERR(0));
fprintf (stderr, "lambda = %.5f +/- %.5f\n", FIT(1), c*ERR(1));
fprintf (stderr, "b = %.5f +/- %.5f\n", FIT(2), c*ERR(2));
}
fprintf (stderr, "status = %s\n", gsl_strerror (status));
gsl_multifit_nlinear_free (w);
gsl_matrix_free (covar);
gsl_rng_free (r);
return 0;
}
static int
bundle_method_iterate (void *vstate, gsl_multimin_function_fsdf * fsdf, gsl_vector * x, double * f,
gsl_vector * subgradient, gsl_vector * dx, double * eps)
{
bundle_method_state_t *state = (bundle_method_state_t *) vstate;
bundle_element *item;
size_t i, debug=0;
int status;
double tmp_d, t_old, t_int_l; /* local variables */
gsl_vector *y; /* a trial point (the next iteration point by the serios step) */
gsl_vector *sgr_y; /* subgradient at y */
double f_y; /* the function value at y */
gsl_vector *p; /* the aggregate subgradient */
double p_norm, lin_error_p; /* norm of p, the aggregate linear. error */
gsl_vector *tmp_v;
/* data for the convex quadratic problem (for the dual problem) */
gsl_vector *q; /* elements of the array are the linearization errors */
gsl_matrix *Q; /* Q=G^T*G (G is matrix which collumns are subgradients) */
gsl_vector *lambda; /* the convex combination coefficients of the subgradients (solution of the dual problem) */
lambda = gsl_vector_alloc(state->bundle_size);
if(lambda == 0)
{
GSL_ERROR_VAL ("failed to allocate workspace", GSL_ENOMEM, 0);
}
q = gsl_vector_alloc(lambda->size);
if(q == 0)
{
gsl_vector_free(lambda);
GSL_ERROR_VAL ("failed to allocate workspace", GSL_ENOMEM, 0);
}
y = gsl_vector_calloc(x->size);
if(y == 0)
{
gsl_vector_free(q);
gsl_vector_free(lambda);
GSL_ERROR_VAL ("failed to allocate workspace", GSL_ENOMEM, 0);
}
sgr_y = gsl_vector_calloc(x->size);
if(sgr_y == 0)
{
gsl_vector_free(y);
gsl_vector_free(q);
gsl_vector_free(lambda);
GSL_ERROR_VAL ("failed to allocate workspace", GSL_ENOMEM, 0);
}
Q = gsl_matrix_alloc(state->bundle_size, state->bundle_size);
if(Q == 0)
{
gsl_vector_free(sgr_y);
gsl_vector_free(y);
gsl_vector_free(q);
gsl_vector_free(lambda);
GSL_ERROR_VAL ("failed to allocate workspace", GSL_ENOMEM, 0);
}
p = gsl_vector_calloc(x->size);
if(p == 0)
{
gsl_matrix_free(Q);
gsl_vector_free(sgr_y);
gsl_vector_free(y);
gsl_vector_free(q);
gsl_vector_free(lambda);
GSL_ERROR_VAL ("failed to allocate workspace", GSL_ENOMEM, 0);
}
tmp_v = gsl_vector_calloc(x->size);
if(tmp_v == 0)
{
gsl_vector_free(p);
gsl_matrix_free(Q);
gsl_vector_free(sgr_y);
gsl_vector_free(y);
gsl_vector_free(q);
gsl_vector_free(lambda);
GSL_ERROR_VAL ("failed to allocate workspace", GSL_ENOMEM, 0);
}
/* solve the dual problem */
status = build_cqp_data(state, Q, q);
status = solve_qp_pdip(Q, q, lambda);
gsl_matrix_free(Q);
gsl_vector_free(q);
/* compute the aggregate subgradient (it is called p in the documantation)*/
/* and the appropriated linearization error */
lin_error_p = 0.0;
item = state->head;
for(i=0; i<lambda->size; i++)
{
status = gsl_blas_daxpy(gsl_vector_get(lambda,i), item->sgr, p);
lin_error_p += gsl_vector_get(lambda,i)*(item->lin_error);
item = item->next;
}
if(debug)
{
printf("the dual problem solution:\n");
for(i=0;i<lambda->size;i++)
printf("%7.6e ",gsl_vector_get(lambda,i));
printf("\n\n");
printf("the aggregate subgradient: \n");
for(i=0;i<p->size;i++)
printf("%.6e ",gsl_vector_get(p,i));
printf("\n");
printf("lin. error for aggr subgradient = %e\n",lin_error_p);
}
/* the norm of the aggr subgradient */
p_norm = gsl_blas_dnrm2(p);
/* search direction dx=-t*p (t is the length of step) */
status = gsl_vector_memcpy(dx,p);
status = gsl_vector_scale(dx,-1.0*state->t);
/* v =-t*norm(p)^2-alpha_p */
state->v = -gsl_pow_2(p_norm)*(state->t)-lin_error_p;
/* the subgradient is the aggegate sungradient */
status = gsl_blas_dcopy(p,subgradient);
/* iteration step */
/* y=x+dx */
status = gsl_blas_dcopy(dx,y);
status = gsl_blas_daxpy(1.0,x,y);
/* function value at y */
f_y = GSL_MULTIMIN_FN_EVAL_F(fsdf, y);
state->f_eval++;
/* for t-update */
if(!state->fixed_step_length)
{
t_old = state->t;
if(fabs(state->v-(f_y-*f)) < state->rg || state->v-(f_y-*f) > state->rg)
t_int_l = state->t_max;
else
t_int_l = 0.5*t_old*(state->v)/(state->v-(f_y-*f));
}
else
{
t_old = state->t;
t_int_l = state->t;
}
if( f_y-*f <= state->m_ss*state->v ) /* Serious-Step */
{
if(debug)
printf("\nSerious-Step\n");
/* the relaxation step */
if(state->relaxation)
{
if(f_y-*f <= state->v*state->m_rel)
{
double f_z;
gsl_vector * z = gsl_vector_alloc(y->size);
/* z = y+dx = x+2*dx */
status = gsl_blas_dcopy(x,z);
status = gsl_blas_daxpy(2.0,dx,z);
f_z = GSL_MULTIMIN_FN_EVAL_F(fsdf, z);
state->f_eval++;
if(0.5*f_z-f_y+0.5*(*f) > state->rg)
state->rel_parameter = GSL_MIN_DBL(-0.5*(-0.5*f_z+2.0*f_y-1.5*(*f))/(0.5*f_z-f_y+0.5*(*f)),1.999);
else if (fabs(0.5*f_z-f_y+0.5*(*f)) > state->rg)
state->rel_parameter = 1.999;
else
/* something is wrong */
state->rel_parameter = 1.0;
/* save the old iteration point */
status = gsl_blas_dcopy(y,z);
/* y = (1-rel_parameter)*x+rel_parameter*y */
gsl_blas_dscal(state->rel_parameter,y);
status = gsl_blas_daxpy(1.0-state->rel_parameter,x,y);
/* f(y) und sgr_f(y) */
tmp_d = GSL_MULTIMIN_FN_EVAL_F(fsdf, y);
state->f_eval++;
if(tmp_d > f_y)
{
/* keep y as the current point */
status = gsl_blas_dcopy(z,y);
state->rel_counter++;
}
else
{
f_y = tmp_d;
/* dx = y-x */
status = gsl_blas_dcopy(y,dx);
status = gsl_blas_daxpy(-1.0,x,dx);
/* if iteration points bevor and after the rel. step are closly,
the rel_step counte will be increased */
/* |1-rel_parameter| <= 0.1*/
if( fabs(1.0-state->rel_parameter) < 0.1)
state->rel_counter++;
}
GSL_MULTIMIN_FN_EVAL_SDF(fsdf, y, sgr_y);
state->sgr_eval++;
if(state->rel_counter > state->rel_counter_max)
state->relaxation = 0;
/* */
status = gsl_blas_daxpy(-1.0,y,z);
status = gsl_blas_ddot(p, z, &tmp_d);
*eps = f_y-*f-(state->v)+tmp_d;
gsl_vector_free(z);
}
else
{
*eps = f_y-(state->v)-*f;
GSL_MULTIMIN_FN_EVAL_SDF(fsdf, y, sgr_y);
state->sgr_eval++;
}
}
else
{
*eps = f_y-(state->v)-*f;
GSL_MULTIMIN_FN_EVAL_SDF(fsdf, y, sgr_y);
state->sgr_eval++;
}
/* calculate linearization errors at new iteration point */
item = state->head;
for(i=0; i<state->bundle_size; i++)
{
status = gsl_blas_ddot(item->sgr, dx, &tmp_d);
item->lin_error += f_y-*f-tmp_d;
item = item->next;
}
/* linearization error at new iteration point */
status = gsl_blas_ddot(p, dx, &tmp_d);
lin_error_p += f_y-*f-tmp_d;
/* update the bundle */
status = update_bundle(state, sgr_y, 0.0, lambda, p, lin_error_p, 1);
/* adapt the step length */
if(!state->fixed_step_length)
{
if(f_y-*f <= state->v*state->m_t && state->step_counter > 0)
state->t = t_int_l;
else if(state->step_counter>3)
state->t=2.0*t_old;
state->t = GSL_MIN_DBL(GSL_MIN_DBL(state->t,10.0*t_old),state->t_max);
/*state->eps_v = GSL_MAX_DBL(state->eps_v,-2.0*state->v);*/
state->step_counter = GSL_MAX_INT(state->step_counter+1,1);
if(fabs(state->t-t_old) > state->rg)
state->step_counter=1;
}
/* x=y, f=f(y) */
status = gsl_blas_dcopy(y,x);
*f = f_y;
}
else /* Null-Step */
{
if(debug)
printf("\nNull-Step\n");
GSL_MULTIMIN_FN_EVAL_SDF(fsdf, y, sgr_y);
state->sgr_eval++;
/* eps for the eps_subdifferential */
*eps = lin_error_p;
/*calculate the liniarization error at y */
status = gsl_blas_ddot(sgr_y,dx,&tmp_d);
tmp_d += *f-f_y;
/* Bundle update */
status = update_bundle(state, sgr_y, tmp_d, lambda, p, lin_error_p, 0);
/* adapt the step length */
if(!state->fixed_step_length)
{
/*state->eps_v = GSL_MIN_DBL(state->eps_v,lin_error_p);*/
if(tmp_d > GSL_MAX_DBL(p_norm,lin_error_p) && state->step_counter < -1)
state->t = t_int_l;
else if(state->step_counter < -3)
state->t = 0.5*t_old;
state->t = GSL_MAX_DBL(GSL_MAX_DBL(0.1*t_old,state->t),state->t_min);
state->step_counter = GSL_MIN_INT(state->step_counter-1,-1);
if(fabs(state->t-t_old) > state->rg)
state->step_counter = -1;
}
}
state->lambda_min = p_norm * state->lm_accuracy;
if(debug)
{
printf("\nthe new bundle:\n");
bundle_out_liste(state);
printf("\n\n");
printf("the curent itarationspoint (1 x %d)\n",x->size);
for(i=0;i<x->size;i++)
printf("%12.6f ",gsl_vector_get(x,i));
printf("\n\n");
printf("functions value at current point: f=%.8f\n",*f);
printf("\nstep length t=%.5e\n",state->t);
printf("\nstep_counter sc=%d\n",state->step_counter);
printf("\naccuracy: v=%.5e\n",state->v);
printf("\nlambda_min=%e\n",state->lambda_min);
printf("\n");
}
gsl_vector_free(lambda);
gsl_vector_free(y);
gsl_vector_free(sgr_y);
gsl_vector_free(p);
return GSL_SUCCESS;
}
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);
}
}
static inline void
qelg (struct extrapolation_table *table, double *result, double *abserr)
{
double *epstab = table->rlist2;
double *res3la = table->res3la;
const size_t n = table->n - 1;
const double current = epstab[n];
double absolute = GSL_DBL_MAX;
double relative = 5 * GSL_DBL_EPSILON * fabs (current);
const size_t newelm = n / 2;
const size_t n_orig = n;
size_t n_final = n;
size_t i;
const size_t nres_orig = table->nres;
*result = current;
*abserr = GSL_DBL_MAX;
if (n < 2)
{
*result = current;
*abserr = GSL_MAX_DBL (absolute, relative);
return;
}
epstab[n + 2] = epstab[n];
epstab[n] = GSL_DBL_MAX;
for (i = 0; i < newelm; i++)
{
double res = epstab[n - 2 * i + 2];
double e0 = epstab[n - 2 * i - 2];
double e1 = epstab[n - 2 * i - 1];
double e2 = res;
double e1abs = fabs (e1);
double delta2 = e2 - e1;
double err2 = fabs (delta2);
double tol2 = GSL_MAX_DBL (fabs (e2), e1abs) * GSL_DBL_EPSILON;
double delta3 = e1 - e0;
double err3 = fabs (delta3);
double tol3 = GSL_MAX_DBL (e1abs, fabs (e0)) * GSL_DBL_EPSILON;
double e3, delta1, err1, tol1, ss;
if (err2 <= tol2 && err3 <= tol3)
{
/* If e0, e1 and e2 are equal to within machine accuracy,
convergence is assumed. */
*result = res;
absolute = err2 + err3;
relative = 5 * GSL_DBL_EPSILON * fabs (res);
*abserr = GSL_MAX_DBL (absolute, relative);
return;
}
e3 = epstab[n - 2 * i];
epstab[n - 2 * i] = e1;
delta1 = e1 - e3;
err1 = fabs (delta1);
tol1 = GSL_MAX_DBL (e1abs, fabs (e3)) * GSL_DBL_EPSILON;
/* If two elements are very close to each other, omit a part of
the table by adjusting the value of n */
if (err1 <= tol1 || err2 <= tol2 || err3 <= tol3)
{
n_final = 2 * i;
break;
}
ss = (1 / delta1 + 1 / delta2) - 1 / delta3;
/* Test to detect irregular behaviour in the table, and
eventually omit a part of the table by adjusting the value of
n. */
if (fabs (ss * e1) <= 0.0001)
{
n_final = 2 * i;
break;
}
/* Compute a new element and eventually adjust the value of
result. */
res = e1 + 1 / ss;
epstab[n - 2 * i] = res;
{
const double error = err2 + fabs (res - e2) + err3;
if (error <= *abserr)
{
*abserr = error;
*result = res;
}
}
}
/* Shift the table */
{
const size_t limexp = 50 - 1;
if (n_final == limexp)
{
n_final = 2 * (limexp / 2);
}
}
if (n_orig % 2 == 1)
{
for (i = 0; i <= newelm; i++)
{
epstab[1 + i * 2] = epstab[i * 2 + 3];
}
}
else
{
for (i = 0; i <= newelm; i++)
{
epstab[i * 2] = epstab[i * 2 + 2];
}
}
if (n_orig != n_final)
{
for (i = 0; i <= n_final; i++)
{
epstab[i] = epstab[n_orig - n_final + i];
}
}
table->n = n_final + 1;
if (nres_orig < 3)
{
res3la[nres_orig] = *result;
*abserr = GSL_DBL_MAX;
}
else
{ /* Compute error estimate */
*abserr = (fabs (*result - res3la[2]) + fabs (*result - res3la[1])
+ fabs (*result - res3la[0]));
res3la[0] = res3la[1];
res3la[1] = res3la[2];
res3la[2] = *result;
}
/* In QUADPACK the variable table->nres is incremented at the top of
qelg, so it increases on every call. This leads to the array
res3la being accessed when its elements are still undefined, so I
have moved the update to this point so that its value more
useful. */
table->nres = nres_orig + 1;
*abserr = GSL_MAX_DBL (*abserr, 5 * GSL_DBL_EPSILON * fabs (*result));
return;
}
int
main (void)
{
const gsl_multifit_fdfsolver_type *T = gsl_multifit_fdfsolver_lmsder;
gsl_multifit_fdfsolver *s;
int status, info;
size_t i;
const size_t n = N;
const size_t p = 3;
gsl_matrix *J = gsl_matrix_alloc(n, p);
gsl_matrix *covar = gsl_matrix_alloc (p, p);
double y[N], weights[N];
struct data d = { n, y };
gsl_multifit_function_fdf f;
double x_init[3] = { 1.0, 0.0, 0.0 };
gsl_vector_view x = gsl_vector_view_array (x_init, p);
gsl_vector_view w = gsl_vector_view_array(weights, n);
const gsl_rng_type * type;
gsl_rng * r;
gsl_vector *res_f;
double chi, chi0;
const double xtol = 1e-8;
const double gtol = 1e-8;
const double ftol = 0.0;
gsl_rng_env_setup();
type = gsl_rng_default;
r = gsl_rng_alloc (type);
f.f = &expb_f;
f.df = &expb_df; /* set to NULL for finite-difference Jacobian */
f.n = n;
f.p = p;
f.params = &d;
/* This is the data to be fitted */
for (i = 0; i < n; i++)
{
double t = i;
double yi = 1.0 + 5 * exp (-0.1 * t);
double si = 0.1 * yi;
double dy = gsl_ran_gaussian(r, si);
weights[i] = 1.0 / (si * si);
y[i] = yi + dy;
printf ("data: %zu %g %g\n", i, y[i], si);
};
s = gsl_multifit_fdfsolver_alloc (T, n, p);
/* initialize solver with starting point and weights */
gsl_multifit_fdfsolver_wset (s, &f, &x.vector, &w.vector);
/* compute initial residual norm */
res_f = gsl_multifit_fdfsolver_residual(s);
chi0 = gsl_blas_dnrm2(res_f);
/* solve the system with a maximum of 20 iterations */
status = gsl_multifit_fdfsolver_driver(s, 20, xtol, gtol, ftol, &info);
gsl_multifit_fdfsolver_jac(s, J);
gsl_multifit_covar (J, 0.0, covar);
/* compute final residual norm */
chi = gsl_blas_dnrm2(res_f);
#define FIT(i) gsl_vector_get(s->x, i)
#define ERR(i) sqrt(gsl_matrix_get(covar,i,i))
fprintf(stderr, "summary from method '%s'\n",
gsl_multifit_fdfsolver_name(s));
fprintf(stderr, "number of iterations: %zu\n",
gsl_multifit_fdfsolver_niter(s));
fprintf(stderr, "function evaluations: %zu\n", f.nevalf);
fprintf(stderr, "Jacobian evaluations: %zu\n", f.nevaldf);
fprintf(stderr, "reason for stopping: %s\n",
(info == 1) ? "small step size" : "small gradient");
fprintf(stderr, "initial |f(x)| = %g\n", chi0);
fprintf(stderr, "final |f(x)| = %g\n", chi);
{
double dof = n - p;
double c = GSL_MAX_DBL(1, chi / sqrt(dof));
fprintf(stderr, "chisq/dof = %g\n", pow(chi, 2.0) / dof);
fprintf (stderr, "A = %.5f +/- %.5f\n", FIT(0), c*ERR(0));
fprintf (stderr, "lambda = %.5f +/- %.5f\n", FIT(1), c*ERR(1));
fprintf (stderr, "b = %.5f +/- %.5f\n", FIT(2), c*ERR(2));
}
fprintf (stderr, "status = %s\n", gsl_strerror (status));
gsl_multifit_fdfsolver_free (s);
gsl_matrix_free (covar);
gsl_matrix_free (J);
gsl_rng_free (r);
return 0;
}
int
test_alpha(gsl_vector_complex *obs, gsl_vector_complex *expected,
gsl_matrix *A, gsl_matrix *B, const char *obsname,
const char *expname)
{
size_t N = expected->size;
size_t i, k;
double max, max_abserr, max_relerr;
max = 0.0;
max_abserr = 0.0;
max_relerr = 0.0;
k = 0;
for (i = 0; i < N; ++i)
{
gsl_complex z = gsl_vector_complex_get(expected, i);
max = GSL_MAX_DBL(max, gsl_complex_abs(z));
}
for (i = 0; i < N; ++i)
{
gsl_complex z_obs = gsl_vector_complex_get(obs, i);
gsl_complex z_exp = gsl_vector_complex_get(expected, i);
double x_obs = GSL_REAL(z_obs);
double y_obs = fabs(GSL_IMAG(z_obs));
double x_exp = GSL_REAL(z_exp);
double y_exp = fabs(GSL_IMAG(z_exp));
double abserr_x = fabs(x_obs - x_exp);
double abserr_y = fabs(y_obs - y_exp);
double noise = max * GSL_DBL_EPSILON * N * N;
max_abserr = GSL_MAX_DBL(max_abserr, abserr_x + abserr_y);
if (abserr_x < noise && abserr_y < noise)
continue;
if (abserr_x > 1.0e-6 || abserr_y > 1.0e-6)
++k;
}
if (k)
{
printf("==== CASE %lu ===========================\n\n", count);
print_matrix(A, "A");
print_matrix(B, "B");
printf("=== alpha - %s ===\n", expname);
print_vector(expected, expname);
printf("=== alpha - %s ===\n", obsname);
print_vector(obs, obsname);
printf("max abserr = %g max relerr = %g\n", max_abserr, max_relerr);
printf("=========================================\n\n");
}
return k;
} /* test_alpha() */
