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() */