static void dll_bvp_deriv_func_forc_eps (int *n, double *x, double *y,
double *ydot, double *eps, double *rpar, int *ipar)
{
updatedeforc(x);
epsval[0] = eps[0]; /* value of parameter */
rpar[0] = eps[0];
derfun(n, x, y, ydot, rpar, ipar);
}
/*==========================================================================*/
void derivs(SEXP Func, double t, double* y, SEXP Parms, SEXP Rho,
double *ydot, double *yout, int j, int neq, int *ipar, int isDll,
int isForcing) {
SEXP Val, rVal, R_fcall;
SEXP R_t;
SEXP R_y;
int i = 0;
int nout = ipar[0];
double *yy;
double ytmp[neq];
if (isDll) {
/*------------------------------------------------------------------------*/
/* Function is a DLL function */
/*------------------------------------------------------------------------*/
C_deriv_func_type *cderivs;
if (isForcing) updatedeforc(&t);
cderivs = (C_deriv_func_type *) R_ExternalPtrAddrFn_(Func);
cderivs(&neq, &t, y, ytmp, yout, ipar);
if (j >= 0)
for (i = 0; i < neq; i++) ydot[i + neq * j] = ytmp[i];
} else {
/*------------------------------------------------------------------------*/
/* Function is an R function */
/*------------------------------------------------------------------------*/
PROTECT(R_t = ScalarReal(t)); incr_N_Protect();
PROTECT(R_y = allocVector(REALSXP, neq)); incr_N_Protect();
yy = REAL(R_y);
for (i=0; i< neq; i++) yy[i] = y[i];
PROTECT(R_fcall = lang4(Func, R_t, R_y, Parms)); incr_N_Protect();
PROTECT(Val = eval(R_fcall, Rho)); incr_N_Protect();
/* extract the states from first list element of "Val" */
if (j >= 0)
for (i = 0; i < neq; i++) ydot[i + neq * j] = REAL(VECTOR_ELT(Val, 0))[i];
/* extract outputs from second and following list elements */
/* this is essentially an unlist for non-nested numeric lists */
if (j < 0) {
int elt = 1, ii = 0, l;
for (i = 0; i < nout; i++) {
l = LENGTH(VECTOR_ELT(Val, elt));
if (ii == l) {
ii = 0; elt++;
}
//yout[i] = REAL(VECTOR_ELT(Val, elt))[ii];
// thpe 2012-08-04: make sure the return value is double and not int
PROTECT(rVal = coerceVector(VECTOR_ELT(Val, elt), REALSXP));
yout[i] = REAL(rVal)[ii];
UNPROTECT(1);
ii++;
}
}
my_unprotect(4);
}
}
static void C_zderiv_func_forc (int *neq, double *t, Rcomplex *y,
Rcomplex *ydot, Rcomplex *yout, int *iout)
{
updatedeforc(t);
DLL_cderiv_func(neq, t, y, ydot, yout, iout);
}
static void DLL_res_func_forc2 (double *t, double *y, double *yprime, double *cj,
double *delta, int *ires, double *yout, int *iout)
{
updatedeforc(t);
DLL_res_ode(t, y, yprime, cj, delta, ires, yout, iout);
}
static void C_deriv_func_forc_gb (int *neq, double *t, double *y,
double *ydot, double *yout, int *iout)
{
updatedeforc(t);
DLL_deriv_func(neq, t, y, ydot, yout, iout);
}
