static int
rk1imp_apply (void *vstate, size_t dim, double t, double h,
double y[], double yerr[],
const double dydt_in[], double dydt_out[],
const gsl_odeiv2_system * sys)
{
/* Makes an implicit Euler step with size h and estimates the local
error of the step by step doubling.
*/
rk1imp_state_t *state = (rk1imp_state_t *) vstate;
double *const y_onestep = state->y_onestep;
double *const y_twostep = state->y_twostep;
double *const ytmp = state->ytmp;
double *const y_save = state->y_save;
double *const YZ = state->YZ;
double *const fYZ = state->fYZ;
gsl_matrix *const dfdy = state->dfdy;
double *const dfdt = state->dfdt;
double *const errlev = state->errlev;
const modnewton1_state_t *esol = state->esol;
/* Runge-Kutta coefficients */
gsl_matrix *A = state->A;
const double b[] = { 1.0 };
const double c[] = { 1.0 };
gsl_matrix_set (A, 0, 0, 1.0);
if (esol == NULL)
{
GSL_ERROR ("no non-linear equation solver speficied", GSL_EINVAL);
}
/* Get desired error levels via gsl_odeiv2_control object through driver
object, which is a requirement for this stepper.
*/
if (state->driver == NULL)
{
return GSL_EFAULT;
}
else
{
size_t i;
for (i = 0; i < dim; i++)
{
if (dydt_in != NULL)
{
gsl_odeiv2_control_errlevel (state->driver->c, y[i],
dydt_in[i], h, i, &errlev[i]);
}
else
{
gsl_odeiv2_control_errlevel (state->driver->c, y[i],
0.0, h, i, &errlev[i]);
}
}
}
/* Evaluate Jacobian for modnewton1 */
{
int s = GSL_ODEIV_JA_EVAL (sys, t, y, dfdy->data, dfdt);
if (s != GSL_SUCCESS)
{
return s;
}
}
/* Calculate a single step with size h */
{
int s = modnewton1_init ((void *) esol, A, h, dfdy, sys);
if (s != GSL_SUCCESS)
{
return s;
}
}
{
int s = modnewton1_solve ((void *) esol, A, c, t, h, y,
sys, YZ, errlev);
if (s != GSL_SUCCESS)
{
return s;
}
}
{
int s = GSL_ODEIV_FN_EVAL (sys, t + c[0] * h, YZ, fYZ);
if (s != GSL_SUCCESS)
{
return s;
}
}
{
int s = rksubs (y_onestep, h, y, fYZ, b, RK1IMP_STAGE, dim);
if (s != GSL_SUCCESS)
return s;
}
/* Error estimation by step doubling */
{
int s = modnewton1_init ((void *) esol, A, h / 2.0, dfdy, sys);
if (s != GSL_SUCCESS)
{
return s;
}
}
/* 1st half step */
{
int s = modnewton1_solve ((void *) esol, A, c, t, h / 2.0, y,
sys, YZ, errlev);
if (s != GSL_SUCCESS)
{
return s;
}
}
{
int s = GSL_ODEIV_FN_EVAL (sys, t + c[0] * h / 2.0, YZ, fYZ);
if (s != GSL_SUCCESS)
{
return s;
}
}
{
int s = rksubs (ytmp, h / 2.0, y, fYZ, b, RK1IMP_STAGE, dim);
if (s != GSL_SUCCESS)
return s;
}
/* Save original y values in case of error */
DBL_MEMCPY (y_save, y, dim);
/* 2nd half step */
{
int s = modnewton1_solve ((void *) esol, A, c, t + h / 2.0, h / 2.0,
ytmp, sys, YZ, errlev);
if (s != GSL_SUCCESS)
{
return s;
}
}
{
int s = GSL_ODEIV_FN_EVAL (sys, t + h / 2.0 + c[0] * h / 2.0, YZ, fYZ);
if (s != GSL_SUCCESS)
{
return s;
}
}
{
/* Note: rk1imp returns y using the results from two half steps
instead of the single step since the results are freely
available and more precise.
*/
int s = rksubs (y_twostep, h / 2.0, ytmp, fYZ, b, RK1IMP_STAGE, dim);
if (s != GSL_SUCCESS)
{
DBL_MEMCPY (y, y_save, dim);
return s;
}
}
DBL_MEMCPY (y, y_twostep, dim);
/* Error estimation */
{
size_t i;
for (i = 0; i < dim; i++)
{
yerr[i] = ODEIV_ERR_SAFETY * 0.5 * fabs (y_twostep[i] - y_onestep[i]);
}
}
/* Derivatives at output */
if (dydt_out != NULL)
{
int s = GSL_ODEIV_FN_EVAL (sys, t + h, y, dydt_out);
if (s != GSL_SUCCESS)
{
/* Restore original values */
DBL_MEMCPY (y, y_save, dim);
return s;
}
}
return GSL_SUCCESS;
}
/* Perform the basic semi-implicit extrapolation
* step, of size h, at a Deuflhard determined order.
*/
static int
bsimp_apply (void *vstate,
size_t dim,
double t,
double h,
double y[],
double yerr[],
const double dydt_in[],
double dydt_out[], const gsl_odeiv2_system * sys)
{
bsimp_state_t *state = (bsimp_state_t *) vstate;
double *const x = state->x;
double *const yp = state->yp;
double *const y_save = state->y_save;
double *const yerr_save = state->yerr_save;
double *const y_extrap_sequence = state->y_extrap_sequence;
double *const y_extrap_save = state->y_extrap_save;
double *const extrap_work = state->extrap_work;
double *const dfdt = state->dfdt;
gsl_matrix *d = state->d;
gsl_matrix *dfdy = state->dfdy;
const double t_local = t;
size_t i, k;
if (h + t_local == t_local)
{
return GSL_EUNDRFLW; /* FIXME: error condition */
}
DBL_MEMCPY (y_extrap_save, y, dim);
/* Save inputs */
DBL_MEMCPY (y_save, y, dim);
DBL_MEMCPY (yerr_save, yerr, dim);
/* Evaluate the derivative. */
if (dydt_in != NULL)
{
DBL_MEMCPY (yp, dydt_in, dim);
}
else
{
int s = GSL_ODEIV_FN_EVAL (sys, t_local, y, yp);
if (s != GSL_SUCCESS)
{
return s;
}
}
/* Evaluate the Jacobian for the system. */
{
int s = GSL_ODEIV_JA_EVAL (sys, t_local, y, dfdy->data, dfdt);
if (s != GSL_SUCCESS)
{
return s;
}
}
/* Make a series of refined extrapolations,
* up to the specified maximum order, which
* was calculated based on the Deuflhard
* criterion upon state initialization. */
for (k = 0; k <= state->k_current; k++)
{
const unsigned int N = bd_sequence[k];
const double r = (h / N);
const double x_k = r * r;
int status = bsimp_step_local (state,
dim, t_local, h, N,
y_extrap_save, yp,
dfdt, dfdy,
y_extrap_sequence,
sys);
if (status == GSL_EFAILED)
{
/* If the local step fails, set the error to infinity in
order to force a reduction in the step size */
for (i = 0; i < dim; i++)
{
yerr[i] = GSL_POSINF;
}
break;
}
else if (status != GSL_SUCCESS)
{
return status;
}
x[k] = x_k;
poly_extrap (d, x, k, x_k, y_extrap_sequence, y, yerr, extrap_work,
dim);
}
/* Evaluate dydt_out[]. */
if (dydt_out != NULL)
{
int s = GSL_ODEIV_FN_EVAL (sys, t + h, y, dydt_out);
if (s != GSL_SUCCESS)
{
DBL_MEMCPY (y, y_save, dim);
DBL_MEMCPY (yerr, yerr_save, dim);
return s;
}
}
return GSL_SUCCESS;
}
static int
msbdf_update (void *vstate, const size_t dim, gsl_matrix * dfdy, double *dfdt,
const double t, const double *y, const gsl_odeiv2_system * sys,
gsl_matrix * M, gsl_permutation * p,
const size_t iter, size_t * nJ, size_t * nM,
const double tprev, const double failt,
const double gamma, const double gammaprev, const double hratio)
{
/* Evaluates Jacobian dfdy and updates iteration matrix M
if criteria for update is met.
*/
/* Jacobian is evaluated
- at first step
- if MSBDF_JAC_WAIT steps have been made without re-evaluation
- in case of a convergence failure if
--- change in gamma is small, or
--- convergence failure resulted in step size decrease
*/
const double c = 0.2;
const double gammarel = fabs (gamma / gammaprev - 1.0);
if (*nJ == 0 || *nJ > MSBDF_JAC_WAIT ||
(t == failt && (gammarel < c || hratio < 1.0)))
{
#ifdef DEBUG
printf ("-- evaluate jacobian\n");
#endif
int s = GSL_ODEIV_JA_EVAL (sys, t, y, dfdy->data, dfdt);
if (s == GSL_EBADFUNC)
{
return s;
}
if (s != GSL_SUCCESS)
{
msbdf_failurehandler (vstate, dim, t);
#ifdef DEBUG
printf ("-- FAIL at jacobian function evaluation\n");
#endif
return s;
}
/* Reset counter */
*nJ = 0;
}
/* Iteration matrix M (and it's LU decomposition) is generated
- at first step
- if MSBDF_M_WAIT steps have been made without an update
- if change in gamma is significant (e.g. change in step size)
- if previous step was rejected
*/
if (*nM == 0 || *nM > MSBDF_M_WAIT || gammarel >= c ||
t == tprev || t == failt)
{
#ifdef DEBUG
printf ("-- update M, gamma=%.5e\n", gamma);
#endif
size_t i;
gsl_matrix_memcpy (M, dfdy);
gsl_matrix_scale (M, -gamma);
for (i = 0; i < dim; i++)
{
gsl_matrix_set (M, i, i, gsl_matrix_get (M, i, i) + 1.0);
}
{
int signum;
int s = gsl_linalg_LU_decomp (M, p, &signum);
if (s != GSL_SUCCESS)
{
return GSL_FAILURE;
}
}
/* Reset counter */
*nM = 0;
}
return GSL_SUCCESS;
}
