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;
}
static int
msbdf_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)
{
/* Carries out a step by BDF linear multistep methods. */
msbdf_state_t *state = (msbdf_state_t *) vstate;
double *const z = state->z;
double *const zbackup = state->zbackup;
double *const ytmp = state->ytmp;
double *const ytmp2 = state->ytmp2;
double *const l = state->l;
double *const hprev = state->hprev;
double *const hprevbackup = state->hprevbackup;
size_t *const ordprev = state->ordprev;
size_t *const ordprevbackup = state->ordprevbackup;
double *const errlev = state->errlev;
gsl_vector *const abscor = state->abscor;
gsl_vector *const relcor = state->relcor;
gsl_vector *const svec = state->svec;
gsl_vector *const tempvec = state->tempvec;
size_t ord = state->ord; /* order for this step */
double ordm1coeff = 0.0;
double ordp1coeff = 0.0;
double ordp2coeff = 0.0;
double errcoeff = 0.0; /* error coefficient */
double gamma = 0.0; /* gamma coefficient */
const size_t max_failcount = 3;
size_t i;
#ifdef DEBUG
{
size_t di;
printf ("msbdf_apply: t=%.5e, ord=%d, h=%.5e, y:", t, (int) ord, h);
for (di = 0; di < dim; di++)
{
printf ("%.5e ", y[di]);
}
printf ("\n");
}
#endif
/* Check if t is the same as on previous stepper call (or last
failed call). This means that calculation of previous step failed
or the step was rejected, and therefore previous state will be
restored or the method will be reset.
*/
if (state->ni > 0 && (t == state->tprev || t == state->failt))
{
if (state->ni == 1)
{
/* No step has been accepted yet, reset method */
msbdf_reset (vstate, dim);
#ifdef DEBUG
printf ("-- first step was REJECTED, msbdf_reset called\n");
#endif
}
else
{
/* A succesful step has been saved, restore previous state. */
/* If previous step suggests order increase, but the step was
rejected, then do not increase order.
*/
if (ord > ordprev[0])
{
state->ord = ordprev[0];
ord = state->ord;
}
/* Restore previous state */
DBL_MEMCPY (z, zbackup, (MSBDF_MAX_ORD + 1) * dim);
DBL_MEMCPY (hprev, hprevbackup, MSBDF_MAX_ORD);
for (i = 0; i < MSBDF_MAX_ORD; i++)
{
ordprev[i] = ordprevbackup[i];
}
state->ordwait = state->ordwaitbackup;
state->gammaprev = state->gammaprevbackup;
#ifdef DEBUG
printf ("-- previous step was REJECTED, state restored\n");
#endif
}
/* If step is repeatedly rejected, then reset method */
state->failcount++;
if (state->failcount > max_failcount && state->ni > 1)
{
msbdf_reset (vstate, dim);
ord = state->ord;
#ifdef DEBUG
printf ("-- max_failcount reached, msbdf_reset called\n");
#endif
}
}
else
{
/* The previous step was accepted. Backup current state. */
DBL_MEMCPY (zbackup, z, (MSBDF_MAX_ORD + 1) * dim);
DBL_MEMCPY (hprevbackup, hprev, MSBDF_MAX_ORD);
for (i = 0; i < MSBDF_MAX_ORD; i++)
{
ordprevbackup[i] = ordprev[i];
}
state->ordwaitbackup = state->ordwait;
state->gammaprevbackup = state->gammaprev;
state->failcount = 0;
#ifdef DEBUG
if (state->ni > 0)
{
printf ("-- previous step was ACCEPTED, state saved\n");
}
#endif
}
#ifdef DEBUG
printf ("-- ord=%d, ni=%ld, ordwait=%d\n", (int) ord, state->ni,
(int) state->ordwait);
size_t di;
printf ("-- ordprev: ");
for (di = 0; di < MSBDF_MAX_ORD; di++)
{
printf ("%d ", (int) ordprev[di]);
}
printf ("\n");
#endif
/* 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]);
}
}
}
#ifdef DEBUG
{
size_t di;
printf ("-- errlev: ");
for (di = 0; di < dim; di++)
{
printf ("%.5e ", errlev[di]);
}
printf ("\n");
}
#endif
/* On first call initialize Nordsieck matrix */
if (state->ni == 0)
{
size_t i;
DBL_ZERO_MEMSET (z, (MSBDF_MAX_ORD + 1) * dim);
if (dydt_in != NULL)
{
DBL_MEMCPY (ytmp, dydt_in, dim);
}
else
{
int s = GSL_ODEIV_FN_EVAL (sys, t, y, ytmp);
if (s != GSL_SUCCESS)
{
return s;
}
}
DBL_MEMCPY (&z[0 * dim], y, dim);
DBL_MEMCPY (&z[1 * dim], ytmp, dim);
for (i = 0; i < dim; i++)
{
z[1 * dim + i] *= h;
}
}
/* Stability enhancement heuristic for msbdf: If order > 1 and order
has not been changed, check for decrease in step size, that is
not accompanied by a decrease in method order. This condition may
be indication of BDF method stability problems, a change in ODE
system, or convergence problems in Newton iteration. In all
cases, the strategy is to decrease method order.
*/
#ifdef DEBUG
printf ("-- check_no_order_decrease %d, check_step_size_decrease %d\n",
msbdf_check_no_order_decrease (ordprev),
msbdf_check_step_size_decrease (hprev));
#endif
if (ord > 1 &&
ord - ordprev[0] == 0 &&
msbdf_check_no_order_decrease (ordprev) &&
msbdf_check_step_size_decrease (hprev))
{
state->ord--;
state->ordwait = ord + 2;
ord = state->ord;
#ifdef DEBUG
printf ("-- stability enhancement decreased order to %d\n", (int) ord);
#endif
}
/* Sanity check */
{
const int deltaord = ord - ordprev[0];
if (deltaord > 1 || deltaord < -1)
{
printf ("-- order change %d\n", deltaord);
GSL_ERROR_NULL ("msbdf_apply too large order change", GSL_ESANITY);
}
/* Modify Nordsieck matrix if order or step length has been changed */
/* If order increased by 1, adjust Nordsieck matrix */
if (deltaord == 1)
{
if (ord > 2)
{
size_t i, j;
double hsum = h;
double coeff1 = -1.0;
double coeff2 = 1.0;
double hrelprev = 1.0;
double hrelprod = 1.0;
double hrel = 0.0;
/* Calculate coefficients used in adjustment to l */
DBL_ZERO_MEMSET (l, MSBDF_MAX_ORD + 1);
l[2] = 1.0;
for (i = 1; i < ord - 1; i++)
{
hsum += hprev[i];
hrel = hsum / h;
hrelprod *= hrel;
coeff1 -= 1.0 / (i + 1);
coeff2 += 1.0 / hrel;
for (j = i + 2; j > 1; j--)
{
l[j] *= hrelprev;
l[j] += l[j - 1];
}
hrelprev = hrel;
}
/* Scale Nordsieck matrix */
{
const double c = (-coeff1 - coeff2) / hrelprod;
for (i = 0; i < dim; i++)
{
z[ord * dim + i] = c * gsl_vector_get (abscor, i);
}
}
for (i = 2; i < ord; i++)
for (j = 0; j < dim; j++)
{
z[i * dim + j] += l[i] * z[ord * dim + j];
}
}
else
{
/* zero new vector for order incease from 1 to 2 */
DBL_ZERO_MEMSET (&z[ord * dim], dim);
}
#ifdef DEBUG
printf ("-- order increase detected, Nordsieck modified\n");
#endif
}
/* If order decreased by 1, adjust Nordsieck matrix */
if (deltaord == -1)
{
size_t i, j;
double hsum = 0.0;
/* Calculate coefficients used in adjustment to l */
DBL_ZERO_MEMSET (l, MSBDF_MAX_ORD + 1);
l[2] = 1.0;
for (i = 1; i < ord; i++)
{
hsum += hprev[i - 1];
for (j = i + 2; j > 1; j--)
{
l[j] *= hsum / h;
l[j] += l[j - 1];
}
}
/* Scale Nordsieck matrix */
for (i = 2; i < ord + 1; i++)
for (j = 0; j < dim; j++)
{
z[i * dim + j] += -l[i] * z[(ord + 1) * dim + j];
}
#ifdef DEBUG
printf ("-- order decrease detected, Nordsieck modified\n");
#endif
}
/* Scale Nordsieck vectors if step size has been changed */
if (state->ni > 0 && h != hprev[0])
{
size_t i, j;
const double hrel = h / hprev[0];
double coeff = hrel;
for (i = 1; i < ord + 1; i++)
{
for (j = 0; j < dim; j++)
{
z[i * dim + j] *= coeff;
}
coeff *= hrel;
}
#ifdef DEBUG
printf ("-- h != hprev, Nordsieck modified\n");
#endif
}
/* Calculate polynomial coefficients (l), error coefficient and
auxiliary coefficients
*/
msbdf_calccoeffs (ord, state->ordwait, h, hprev, l, &errcoeff,
º1coeff, &ordp1coeff, &ordp2coeff, &gamma);
/* Carry out the prediction step */
{
size_t i, j, k;
for (i = 1; i < ord + 1; i++)
for (j = ord; j > i - 1; j--)
for (k = 0; k < dim; k++)
{
z[(j - 1) * dim + k] += z[j * dim + k];
}
#ifdef DEBUG
{
size_t di;
printf ("-- predicted y: ");
for (di = 0; di < dim; di++)
{
printf ("%.5e ", z[di]);
}
printf ("\n");
}
#endif
}
/* Calculate correction step to abscor */
{
int s;
s = msbdf_corrector (vstate, sys, t, h, dim, z, errlev, l, errcoeff,
abscor, relcor, ytmp, ytmp2,
state->dfdy, state->dfdt, state->M,
state->p, state->rhs,
&(state->nJ), &(state->nM),
state->tprev, state->failt, gamma,
state->gammaprev, hprev[0]);
if (s != GSL_SUCCESS)
{
return s;
}
}
{
/* Add accepted final correction step to Nordsieck matrix */
size_t i, j;
for (i = 0; i < ord + 1; i++)
for (j = 0; j < dim; j++)
{
z[i * dim + j] += l[i] * gsl_vector_get (abscor, j);
}
#ifdef DEBUG
{
size_t di;
printf ("---- l: ");
for (di = 0; di < ord + 1; di++)
{
printf ("%.5e ", l[di]);
}
printf ("\n");
printf ("-- corrected y: ");
for (di = 0; di < dim; di++)
{
printf ("%.5e ", z[di]);
}
printf ("\n");
}
#endif
/* Derivatives at output */
if (dydt_out != NULL)
{
int s = GSL_ODEIV_FN_EVAL (sys, t + h, z, dydt_out);
if (s == GSL_EBADFUNC)
{
return s;
}
if (s != GSL_SUCCESS)
{
msbdf_failurehandler (vstate, dim, t);
#ifdef DEBUG
printf ("-- FAIL at user function evaluation\n");
#endif
return s;
}
}
/* Calculate error estimate */
for (i = 0; i < dim; i++)
{
yerr[i] = fabs (gsl_vector_get (abscor, i)) * errcoeff;
}
#ifdef DEBUG
{
size_t di;
printf ("-- yerr: ");
for (di = 0; di < dim; di++)
{
printf ("%.5e ", yerr[di]);
}
printf ("\n");
}
#endif
/* Save y values */
for (i = 0; i < dim; i++)
{
y[i] = z[0 * dim + i];
}
}
/* Scale abscor with errlev for later use in norm calculations */
{
size_t i;
for (i = 0; i < dim; i++)
{
gsl_vector_set (abscor, i, gsl_vector_get (abscor, i) / errlev[i]);
}
}
/* Save items needed for evaluation of order increase on next
call, if needed
*/
if (state->ordwait == 1 && ord < MSBDF_MAX_ORD)
{
size_t i;
state->ordp1coeffprev = ordp1coeff;
for (i = 0; i < dim; i++)
{
gsl_vector_set (svec, i, gsl_vector_get (abscor, i));
}
}
/* Consider and execute order change for next step */
if (state->ordwait == 0)
{
msbdf_eval_order (abscor, tempvec, svec, errcoeff, dim, errlev,
ordm1coeff, ordp1coeff,
state->ordp1coeffprev, ordp2coeff,
hprev, h, z, &(state->ord), &(state->ordwait));
}
/* Undo scaling of abscor for possible order increase on next step */
{
size_t i;
for (i = 0; i < dim; i++)
{
gsl_vector_set (abscor, i, gsl_vector_get (abscor, i) * errlev[i]);
}
}
/* Save information about current step in state and update counters */
{
size_t i;
for (i = MSBDF_MAX_ORD - 1; i > 0; i--)
{
hprev[i] = hprev[i - 1];
ordprev[i] = ordprev[i - 1];
}
}
hprev[0] = h;
ordprev[0] = ord;
#ifdef DEBUG
{
size_t di;
printf ("-- hprev: ");
for (di = 0; di < MSBDF_MAX_ORD; di++)
{
printf ("%.5e ", hprev[di]);
}
printf ("\n");
}
#endif
state->tprev = t;
state->ordwait--;
state->ni++;
state->gammaprev = gamma;
state->nJ++;
state->nM++;
#ifdef DEBUG
printf ("-- nJ=%d, nM=%d\n", (int) state->nJ, (int) state->nM);
#endif
}
return GSL_SUCCESS;
}
