/*==========================================================================*/ 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); }