/*==========================================================================*/
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_event_func (int *n, double *t, double *y) {
int i;
SEXP R_fcall, Time, ans;
for (i = 0; i < *n; i++) REAL(Y)[i] = y[i];
PROTECT(Time = ScalarReal(*t)); incr_N_Protect();
PROTECT(R_fcall = lang3(R_event_func,Time,Y)); incr_N_Protect();
PROTECT(ans = eval(R_fcall, R_envir)); incr_N_Protect();
for (i = 0; i < *n; i++) y[i] = REAL(ans)[i];
my_unprotect(3);
}
static void C_acdc_bound_func (int *ii, int *n, double *y, double *gout,
double *eps, double *rpar, int *ipar)
{
int i;
SEXP R_fcall, J, ans;
REAL(EPS)[0] = *eps;
for (i = 0; i < n_eq ; i++) REAL(Y)[i] = y[i];
PROTECT(J = ScalarInteger(*ii)); incr_N_Protect();
PROTECT(R_fcall = lang4(R_cont_bound_func,J,Y,EPS)); incr_N_Protect();
PROTECT(ans = eval(R_fcall, R_envir)); incr_N_Protect();
/* only one element returned... */
gout[0] = REAL(ans)[0];
my_unprotect(3);
}
/* interface between fortran call to jacobian and R function */
static void C_acdc_jac_func (int *n, double *x, double *y, double *pd,
double *eps, double *rpar, int *ipar)
{
int i;
SEXP R_fcall, X, ans;
REAL(EPS)[0] = *eps;
for (i = 0; i < n_eq; i++) REAL(Y)[i] = y[i];
PROTECT(X = ScalarReal(*x)); incr_N_Protect();
PROTECT(R_fcall = lang4(R_cont_jac_func,X,Y,EPS)); incr_N_Protect();
PROTECT(ans = eval(R_fcall, R_envir)); incr_N_Protect();
for (i = 0; i < n_eq * n_eq; i++) pd[i] = REAL(ans)[i];
my_unprotect(3);
}
static void C_zjac_func (int *neq, double *t, Rcomplex *y, int *ml,
int *mu, Rcomplex *pd, int *nrowpd, Rcomplex *yout, int *iout)
{
int i;
SEXP R_fcall, Time, ans;
for (i = 0; i < *neq; i++) COMPLEX(cY)[i] = y[i];
PROTECT(Time = ScalarReal(*t)); incr_N_Protect();
PROTECT(R_fcall = lang3(R_zjac_func,Time,cY)); incr_N_Protect();
PROTECT(ans = eval(R_fcall, R_vode_envir)); incr_N_Protect();
for (i = 0; i < *neq * *nrowpd; i++) pd[i ] = COMPLEX(ans)[i ];
my_unprotect(3);
}
static void C_zderiv_func (int *neq, double *t, Rcomplex *y,
Rcomplex *ydot, Rcomplex *yout, int *iout)
{
int i;
SEXP R_fcall, Time, ans;
for (i = 0; i < *neq; i++) COMPLEX(cY)[i] = y[i];
PROTECT(Time = ScalarReal(*t)); incr_N_Protect();
PROTECT(R_fcall = lang3(R_zderiv_func,Time,cY)) ;incr_N_Protect();
PROTECT(ans = eval(R_fcall, R_vode_envir)) ;incr_N_Protect();
for (i = 0; i < *neq; i++) ydot[i] = COMPLEX(VECTOR_ELT(ans,0))[i];
my_unprotect(3);
}
static void C_stsparse_derivs (int *neq, double *t, double *y, double *ydot,
double *yout, int *iout)
{
int i;
SEXP R_fcall, ans;
REAL(Time)[0] = *t;
for (i = 0; i < *neq; i++) REAL(Y)[i] = y[i];
PROTECT(R_fcall = lang3(stsparse_deriv_func,Time,Y)) ;incr_N_Protect();
PROTECT(ans = eval(R_fcall, stsparse_envir)) ;incr_N_Protect();
for (i = 0; i < *neq; i++) ydot[i] = REAL(VECTOR_ELT(ans,0))[i];
my_unprotect(2);
}
static void C_deriv_func_gb (int *neq, double *t, double *y,
double *ydot, double *yout, int *iout)
{
int i;
SEXP R_fcall, Time, ans;
for (i = 0; i < *neq; i++) REAL(Y)[i] = y[i];
PROTECT(Time = ScalarReal(*t)); incr_N_Protect();
PROTECT(R_fcall = lang3(R_deriv_func,Time,Y)); incr_N_Protect();
PROTECT(ans = eval(R_fcall, R_envir)); incr_N_Protect();
for (i = 0; i < *neq; i++) ydot[i] = REAL(ans)[i];
my_unprotect(3);
}
static void C_jac_func_gb (int *neq, double *t, double *y, int *ml,
int *mu, double *pd, int *nrowpd, double *yout, int *iout)
{
int i;
SEXP R_fcall, Time, ans;
for (i = 0; i < *neq; i++) REAL(Y)[i] = y[i];
PROTECT(Time = ScalarReal(*t)); incr_N_Protect();
PROTECT(R_fcall = lang3(R_jac_func,Time,Y)); incr_N_Protect();
PROTECT(ans = eval(R_fcall, R_envir)); incr_N_Protect();
for (i = 0; i < *neq * *nrowpd; i++) pd[i] = REAL(ans)[i];
my_unprotect(3);
}
static void C_res_func (double *t, double *y, double *yprime, double *cj,
double *delta, int *ires, double *yout, int *iout)
{
int i;
SEXP R_fcall, Time, ans;
for (i = 0; i < n_eq; i++)
{
REAL(Y)[i] = y[i];
REAL (YPRIME)[i] = yprime[i];
}
PROTECT(Time = ScalarReal(*t)); incr_N_Protect();
PROTECT(R_fcall = lang4(R_res_func,Time, Y, YPRIME)); incr_N_Protect();
PROTECT(ans = eval(R_fcall, R_envir)); incr_N_Protect();
for (i = 0; i < n_eq; i++) delta[i] = REAL(ans)[i];
my_unprotect(3);
}
/* the mass matrix function */
static void C_mas_func (int *neq, double *am, int *lmas,
double *yout, int *iout)
{
int i;
SEXP NEQ, LM, R_fcall, ans;
PROTECT(NEQ = NEW_INTEGER(1)); incr_N_Protect();
PROTECT(LM = NEW_INTEGER(1)); incr_N_Protect();
INTEGER(NEQ)[0] = *neq;
INTEGER(LM) [0] = *lmas;
PROTECT(R_fcall = lang3(R_mas_func,NEQ,LM)); incr_N_Protect();
PROTECT(ans = eval(R_fcall, R_envir)); incr_N_Protect();
for (i = 0; i <*lmas * *neq; i++) am[i] = REAL(ans)[i];
my_unprotect(4);
}
static void C_jac_func (double *t, double *y, double *yprime,
double *pd, double *cj, double *RPAR, int *IPAR)
{
int i;
SEXP R_fcall, ans;
REAL(Rin)[0] = *t;
REAL(Rin)[1] = *cj;
for (i = 0; i < n_eq; i++)
{
REAL(Y)[i] = y[i];
REAL (YPRIME)[i] = yprime[i];
}
PROTECT(R_fcall = lang4(R_daejac_func, Rin, Y, YPRIME)); incr_N_Protect();
PROTECT(ans = eval(R_fcall, R_envir)); incr_N_Protect();
for (i = 0; i < n_eq * nrowpd; i++) pd[i] = REAL(ans)[i];
my_unprotect(2);
}
