static int
fdfridge_f(const gsl_vector * x, void * params, gsl_vector * f)
{
int status;
gsl_multifit_fdfridge *w = (gsl_multifit_fdfridge *) params;
const size_t n = w->n;
const size_t p = w->p;
gsl_vector_view f_user = gsl_vector_subvector(f, 0, n);
gsl_vector_view f_tik = gsl_vector_subvector(f, n, p);
/* call user callback function to get residual vector f */
status = gsl_multifit_eval_wf(w->fdf, x, NULL, &f_user.vector);
if (status)
return status;
if (w->L_diag)
{
/* store diag(L_diag) x in Tikhonov portion of f~ */
gsl_vector_memcpy(&f_tik.vector, x);
gsl_vector_mul(&f_tik.vector, w->L_diag);
}
else if (w->L)
{
/* store Lx in Tikhonov portion of f~ */
gsl_blas_dgemv(CblasNoTrans, 1.0, w->L, x, 0.0, &f_tik.vector);
}
else
{
/* store \lambda x in Tikhonov portion of f~ */
gsl_vector_memcpy(&f_tik.vector, x);
gsl_vector_scale(&f_tik.vector, w->lambda);
}
return GSL_SUCCESS;
} /* fdfridge_f() */
static int
lmniel_set(void *vstate, const gsl_vector *swts,
gsl_multifit_function_fdf *fdf, gsl_vector *x,
gsl_vector *f, gsl_vector *dx)
{
int status;
lmniel_state_t *state = (lmniel_state_t *) vstate;
const size_t p = x->size;
size_t i;
/* initialize counters for function and Jacobian evaluations */
fdf->nevalf = 0;
fdf->nevaldf = 0;
/* evaluate function and Jacobian at x and apply weight transform */
status = gsl_multifit_eval_wf(fdf, x, swts, f);
if (status)
return status;
if (fdf->df)
status = gsl_multifit_eval_wdf(fdf, x, swts, state->J);
else
status = gsl_multifit_fdfsolver_dif_df(x, swts, fdf, f, state->J);
if (status)
return status;
/* compute rhs = -J^T f */
gsl_blas_dgemv(CblasTrans, -1.0, state->J, f, 0.0, state->rhs);
#if SCALE
gsl_vector_set_zero(state->diag);
#else
gsl_vector_set_all(state->diag, 1.0);
#endif
/* set default parameters */
state->nu = 2;
#if SCALE
state->mu = state->tau;
#else
/* compute mu_0 = tau * max(diag(J^T J)) */
state->mu = -1.0;
for (i = 0; i < p; ++i)
{
gsl_vector_view c = gsl_matrix_column(state->J, i);
double result; /* (J^T J)_{ii} */
gsl_blas_ddot(&c.vector, &c.vector, &result);
state->mu = GSL_MAX(state->mu, result);
}
state->mu *= state->tau;
#endif
return GSL_SUCCESS;
} /* lmniel_set() */
int
gsl_multifit_fdfsolver_dif_fdf(const gsl_vector *x,
gsl_multifit_function_fdf *fdf,
gsl_vector *f, gsl_matrix *J)
{
int status = 0;
status = gsl_multifit_eval_wf(fdf, x, NULL, f);
if (status)
return status;
status = fdjac(x, fdf, f, J);
if (status)
return status;
return status;
} /* gsl_multifit_fdfsolver_dif_fdf() */
static int
fdjac(const gsl_vector *x, const gsl_vector *wts,
gsl_multifit_function_fdf *fdf, const gsl_vector *f, gsl_matrix *J)
{
int status = 0;
size_t i, j;
double h;
const double epsfcn = 0.0;
double eps = sqrt(GSL_MAX(epsfcn, GSL_DBL_EPSILON));
for (j = 0; j < fdf->p; ++j)
{
double xj = gsl_vector_get(x, j);
/* use column j of J as temporary storage for f(x + dx) */
gsl_vector_view v = gsl_matrix_column(J, j);
h = eps * fabs(xj);
if (h == 0.0)
h = eps;
/* perturb x_j to compute forward difference */
gsl_vector_set((gsl_vector *) x, j, xj + h);
status += gsl_multifit_eval_wf (fdf, x, wts, &v.vector);
if (status)
return status;
/* restore x_j */
gsl_vector_set((gsl_vector *) x, j, xj);
h = 1.0 / h;
for (i = 0; i < fdf->n; ++i)
{
double fnext = gsl_vector_get(&v.vector, i);
double fi = gsl_vector_get(f, i);
gsl_matrix_set(J, i, j, (fnext - fi) * h);
}
}
return status;
} /* fdjac() */
static int
lmniel_iterate(void *vstate, const gsl_vector *swts,
gsl_multifit_function_fdf *fdf, gsl_vector *x,
gsl_vector *f, gsl_vector *dx)
{
int status;
lmniel_state_t *state = (lmniel_state_t *) vstate;
gsl_matrix *J = state->J; /* Jacobian J(x) */
gsl_matrix *A = state->A; /* J^T J */
gsl_vector *rhs = state->rhs; /* -g = -J^T f */
gsl_vector *x_trial = state->x_trial; /* trial x + dx */
gsl_vector *f_trial = state->f_trial; /* trial f(x + dx) */
gsl_vector *diag = state->diag; /* diag(D) */
double dF; /* F(x) - F(x + dx) */
double dL; /* L(0) - L(dx) */
int foundstep = 0; /* found step dx */
/* compute A = J^T J */
status = gsl_blas_dgemm(CblasTrans, CblasNoTrans, 1.0, J, J, 0.0, A);
if (status)
return status;
#if SCALE
lmniel_update_diag(J, diag);
#endif
/* loop until we find an acceptable step dx */
while (!foundstep)
{
/* solve (A + mu*I) dx = g */
status = lmniel_calc_dx(state->mu, A, rhs, dx, state);
if (status)
return status;
/* compute x_trial = x + dx */
lmniel_trial_step(x, dx, x_trial);
/* compute f(x + dx) */
status = gsl_multifit_eval_wf(fdf, x_trial, swts, f_trial);
if (status)
return status;
/* compute dF = F(x) - F(x + dx) */
dF = lmniel_calc_dF(f, f_trial);
/* compute dL = L(0) - L(dx) = dx^T (mu*dx - g) */
dL = lmniel_calc_dL(state->mu, diag, dx, rhs);
/* check that rho = dF/dL > 0 */
if ((dL > 0.0) && (dF >= 0.0))
{
/* reduction in error, step acceptable */
double tmp;
/* update LM parameter mu */
tmp = 2.0 * (dF / dL) - 1.0;
tmp = 1.0 - tmp*tmp*tmp;
state->mu *= GSL_MAX(LM_ONE_THIRD, tmp);
state->nu = 2;
/* compute J <- J(x + dx) */
if (fdf->df)
status = gsl_multifit_eval_wdf(fdf, x_trial, swts, J);
else
status = gsl_multifit_fdfsolver_dif_df(x_trial, swts, fdf, f_trial, J);
if (status)
return status;
/* update x <- x + dx */
gsl_vector_memcpy(x, x_trial);
/* update f <- f(x + dx) */
gsl_vector_memcpy(f, f_trial);
/* compute new rhs = -J^T f */
gsl_blas_dgemv(CblasTrans, -1.0, J, f, 0.0, rhs);
foundstep = 1;
}
else
{
long nu2;
/* step did not reduce error, reject step */
state->mu *= state->nu;
nu2 = state->nu << 1; /* 2*nu */
if (nu2 <= state->nu)
{
gsl_vector_view d = gsl_matrix_diagonal(A);
/*
* nu has wrapped around / overflown, reset mu and nu
* to original values and break to force another iteration
*/
/*GSL_ERROR("nu parameter has overflown", GSL_EOVRFLW);*/
state->nu = 2;
state->mu = state->tau * gsl_vector_max(&d.vector);
break;
}
state->nu = nu2;
}
} /* while (!foundstep) */
return GSL_SUCCESS;
} /* lmniel_iterate() */
