/*==========================================================================*/
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);
}
}
void initParms(SEXP Initfunc, SEXP Parms) {
// ks: added this to prevent entering this if initfunc does not exist
if (Initfunc == NA_STRING) return;
if (inherits(Initfunc, "NativeSymbol")) {
init_func *initializer;
PROTECT(bvp_gparms = Parms); incr_N_Protect();
initializer = (init_func *) R_ExternalPtrAddrFn_(Initfunc);
initializer(Initbvpparms);
}
}
SEXP call_acdc(SEXP Ncomp, SEXP Fixpnt, SEXP Aleft, SEXP Aright,
SEXP Nlbc, SEXP Tol, SEXP Linear, SEXP Full, SEXP Givmesh, SEXP Givu,
SEXP Nmesh, SEXP Nmax, SEXP Lwrkfl, SEXP Lwrkin, SEXP Xguess, SEXP Yguess,
SEXP Rpar, SEXP Ipar, SEXP UseC, SEXP Epsini, SEXP Eps,
SEXP derivfunc, SEXP jacfunc, SEXP boundfunc, SEXP jacboundfunc,
SEXP Initfunc, SEXP Parms, SEXP flist, SEXP Absent, SEXP Rwork, SEXP rho)
{
/******************************************************************************/
/****** DECLARATION SECTION ******/
/******************************************************************************/
/* These R-structures will be allocated and returned to R*/
SEXP yout=NULL, ISTATE, RSTATE, EPSS;
int j, ii, ncomp, nlbc, nmax, lwrkfl, lwrkin, nx, *ipar, isForcing;
double *wrk, *tol, *fixpnt, *u, *xx, *rpar, *precis, *xguess, *yguess;
double epsmin, epsini, aleft, aright, ckappa1, gamma1, sigma, ckappa, ckappa2;
int *icount, *ltol, *iwrk, ntol, iflag, nfixpnt, linear, givmesh;
int full, useC, givu, giveps, nmesh, isDll, nugdim, nmshguess;
int *absent;
double *rwork;
/* pointers to functions passed to FORTRAN */
C_acdc_deriv_func_type *deriv_func;
C_acdc_jac_func_type *jac_func;
C_acdc_bound_func_type *bound_func;
C_acdc_jacbound_func_type *jacbound_func = NULL;
/******************************************************************************/
/****** STATEMENTS ******/
/******************************************************************************/
/* #### initialisation #### */
init_N_Protect();
aleft =REAL(Aleft)[0];
aright =REAL(Aright)[0];
ncomp = INTEGER(Ncomp)[0]; /* number of equations */
n_eq = ncomp;
nlbc = INTEGER(Nlbc)[0]; /* number of left boundary conditions */
nmax = INTEGER(Nmax)[0]; /* max number of mesh points */
lwrkfl = INTEGER(Lwrkfl)[0]; /* length of double workspace */
lwrkin = INTEGER(Lwrkin)[0]; /* length of integer workspace */
linear = INTEGER(Linear)[0]; /* true if linear problem */
full = INTEGER(Full)[0]; /* true if verbose output */
givu = INTEGER(Givu)[0]; /* true if initial trial solution given */
givmesh = INTEGER(Givmesh)[0]; /* true if initial mesh given */
nmesh = INTEGER(Nmesh)[0]; /* size of mesh */
useC = INTEGER(UseC)[0]; /* conditioning or not */
ii = LENGTH(Absent);
absent = (int *) R_alloc(ii, sizeof(int));
for (j=0; j<ii; j++) absent[j] = INTEGER(Absent)[j];
ii = LENGTH(Rwork);
rwork = (double *) R_alloc(ii, sizeof(double));
for (j=0; j<ii; j++) rwork[j] = REAL(Rwork)[j];
/* is function a dll ?*/
if (inherits(derivfunc, "NativeSymbol")) {
isDll = 1;
} else {
isDll = 0;
}
/* copies of variables that will be changed in the FORTRAN subroutine */
ntol = LENGTH(Tol);
tol =(double *) R_alloc(ntol, sizeof(double));
for (j = 0; j < ntol; j++) tol[j] = REAL(Tol)[j];
ltol =(int *) R_alloc(ntol, sizeof(int));
for (j = 0; j < ntol; j++) ltol[j] = j+1;
nfixpnt = LENGTH(Fixpnt);
fixpnt =(double *) R_alloc(nfixpnt, sizeof(double));
for (j = 0; j < nfixpnt;j++) fixpnt[j] = REAL(Fixpnt)[j];
xx =(double *) R_alloc(nmax, sizeof(double));
for (j = 0; j < nmesh; j++) xx[j] = REAL(Xguess)[j];
for (j = nmesh; j < nmax; j++) xx[j] = 0;
// to be used in fortran code initu
if (givu) {
xguess = (double *) R_alloc(nmesh, sizeof(double));
for (j = 0; j < nmesh; j++) xguess[j] = REAL(Xguess)[j];
yguess = (double *) R_alloc(nmesh*ncomp, sizeof(double));
for (j = 0; j < nmesh*ncomp; j++) yguess[j] = REAL(Yguess)[j];
} else { /* dummy variables */
xguess = (double *) R_alloc(1, sizeof(double));
xguess[0] = 0.;
yguess = (double *) R_alloc(ncomp, sizeof(double));
for (j = 0; j < ncomp; j++) yguess[j] = 0.;
}
ii = nmax*ncomp;
u =(double *) R_alloc(ii, sizeof(double));
for (j = 0; j < nmesh*ncomp; j++) u[j] = REAL(Yguess)[j];
for (j = nmesh*ncomp; j < nmax*ncomp; j++) u[j] = 0;
wrk = (double *) R_alloc(lwrkfl, sizeof(double));
for (j = 0; j < lwrkfl; j++) wrk[j] = 0.;
iwrk = (int *) R_alloc(lwrkin, sizeof(int));
for (j = 0; j < lwrkin; j++) iwrk[j] = 0;
precis = (double *) R_alloc(3,sizeof(double));
precis[0] = DBL_MIN;
precis[1] = DBL_MAX;
precis[2] = DBL_EPSILON/FLT_RADIX;
epsmin = REAL(Eps)[0];
epsini = REAL(Epsini)[0];
giveps = 1;
icount = (int *) R_alloc(8, sizeof(int));
ii = LENGTH(Ipar);
ipar = (int *) R_alloc(ii, sizeof(int));
for (j=0; j<ii; j++) ipar[j] = INTEGER(Ipar)[j];
ii = LENGTH(Rpar);
rpar = (double *) R_alloc(ii, sizeof(double));
for (j=0; j<ii; j++) rpar[j] = REAL(Rpar)[j];
/* initialise global R-variables... */
if (isDll == 0) {
PROTECT(EPS = NEW_NUMERIC(1)); incr_N_Protect();
PROTECT(Y = allocVector(REALSXP,ncomp)); incr_N_Protect();
}
/* Initialization of Parameters and Forcings (DLL functions) */
epsval = (double *) R_alloc(1, sizeof(double)); epsval[0] = 0.;
isForcing = initForcings(flist);
initParms(Initfunc, Parms);
R_envir = rho;
/* pointers to functions passed to FORTRAN */
if (isDll) {
deriv_func = (C_acdc_deriv_func_type *) dll_bvp_deriv_func;
if (absent[0] == 0)
jac_func = (C_acdc_jac_func_type *) dll_bvp_jac_func;
if (absent[1] == 0)
bound_func = (C_acdc_bound_func_type *) dll_bvp_bound_func;
if (absent[2] == 0)
jacbound_func = (C_acdc_jacbound_func_type *) dll_bvp_jacbound_func;
derfun = (C_deriv_func_type *) R_ExternalPtrAddrFn_(derivfunc);
jacfun = (C_jac_func_type *) R_ExternalPtrAddrFn_(jacfunc);
boundfun = (C_bound_func_type *) R_ExternalPtrAddrFn_(boundfunc);
jacboundfun = (C_jacbound_func_type *) R_ExternalPtrAddrFn_(jacboundfunc);
/* here overruling deriv_func if forcing */
if (isForcing) {
deriv_func = (C_acdc_deriv_func_type *) dll_bvp_deriv_func_forc_eps;
}
} else {
deriv_func = (C_acdc_deriv_func_type *) C_acdc_deriv_func;
R_cont_deriv_func = derivfunc;
if (absent[0] == 0) {
jac_func = C_acdc_jac_func;
R_cont_jac_func = jacfunc;
}
if (absent[1] == 0) {
bound_func = C_acdc_bound_func;
R_cont_bound_func = boundfunc;
}
if (absent[0] == 0) {
jacbound_func = C_acdc_jacbound_func;
R_cont_jacbound_func = jacboundfunc;
}
}
/* if numerical approximates should be used */
if (absent[0] == 1) {
dy = (double *) R_alloc(ncomp, sizeof(double));
dycopy = (double *) R_alloc(ncomp, sizeof(double));
ycopy = (double *) R_alloc(ncomp, sizeof(double));
jac_func = (C_acdc_jac_func_type *) C_num_acdcjac_func;
jaderfun = (C_acdc_deriv_func_type *) deriv_func;
}
if (absent[1] == 1) {
bound_func = (C_acdc_bound_func_type *) C_num_acdcbound_func;
iibb = (int *) R_alloc(ncomp, sizeof(int));
for (j = 0; j < ncomp; j++)
iibb[j] = absent[3 + j];
bb = (double *) R_alloc(ncomp, sizeof(double));
for (j = 0; j < ncomp; j++)
bb[j] = rwork[j];
}
if (absent[2] == 1) {
jacbound_func = (C_acdc_jacbound_func_type *) C_num_acdcjacbound_func;
jabndfun = (C_acdc_bound_func_type *) bound_func;
if (absent[0] != 1)
ycopy = (double *) R_alloc(ncomp, sizeof(double));
}
/* Call the fortran function acdc */
nugdim = ncomp;
nmshguess = nmesh;
/* Rprintf("precis %g %g %g\n",precis[0],precis[1],precis[2]);*/
F77_CALL(acdc) (&ncomp, &nlbc, &nmax, &aleft, &aright, &nfixpnt, fixpnt,
&ntol, ltol, tol, &linear, &givmesh, &givu, &full, &nmshguess,
xguess, &nugdim, yguess, &nmesh, xx, &ncomp, u, &nmax, &lwrkfl,
wrk, &lwrkin, iwrk, &giveps, &epsini, &epsmin,
deriv_func, jac_func, bound_func, jacbound_func,
&ckappa1, &gamma1, &sigma, &ckappa, &ckappa2, rpar, ipar, icount,
precis, &useC, &iflag);
/* error("Till here.\n"); iflag - The Mode Of Return From acdc */
if (iflag == 4) {
unprotect_all();
error("One of the input parameters is invalid.\n");
} else if (iflag == 1) {
unprotect_all();
error("Terminated: final problem not solved.\n");
} else if (iflag == 2) {
unprotect_all();
error("Terminated: too many continuation steps\n");
} else if (iflag == 3) {
unprotect_all();
error("Terminated: ill conditioned problem.\n");
} else {
/* #### returning output #### */
nx = nmesh;
PROTECT(yout = allocVector(REALSXP,(ncomp+1)*(nx))); incr_N_Protect();
for (j = 0; j < nx; j++) REAL(yout)[j] = xx[j];
for (j = 0; j < ncomp*nx; j++) REAL(yout)[nx+j] = u[j];
}
PROTECT(ISTATE = allocVector(INTSXP, 13)); incr_N_Protect();
for (j = 0; j < 13; j++)
INTEGER(ISTATE)[j] = 0;
INTEGER(ISTATE)[0] = iflag;
for (j = 0; j < 7; j++)
INTEGER(ISTATE)[1+j] = icount[j];
INTEGER(ISTATE)[9] = nmax;
INTEGER(ISTATE)[10] = nmesh;
INTEGER(ISTATE)[11] = lwrkfl;
INTEGER(ISTATE)[12] = lwrkin;
setAttrib(yout, install("istate"), ISTATE);
PROTECT(EPSS = allocVector(REALSXP, 2)); incr_N_Protect();
REAL(EPSS)[0] = epsini;
REAL(EPSS)[1] = epsmin;
setAttrib(yout, install("eps"), EPSS);
PROTECT(RSTATE = allocVector(REALSXP, 5)); incr_N_Protect();
REAL(RSTATE)[0] = ckappa1;
REAL(RSTATE)[1] = gamma1;
REAL(RSTATE)[2] = sigma;
REAL(RSTATE)[3] = ckappa;
REAL(RSTATE)[4] = ckappa2;
setAttrib(yout, install("rstate"), RSTATE);
/* #### termination #### */
unprotect_all();
return(yout);
}
SEXP call_stsparse(SEXP y, SEXP time, SEXP func, SEXP parms, SEXP forcs,
SEXP chtol,
SEXP atol, SEXP rtol, SEXP itol, SEXP rho, SEXP initfunc, SEXP initforc,
SEXP verbose, SEXP NNZ, SEXP NSP, SEXP NGP, SEXP nIter, SEXP Posit,
SEXP Pos, SEXP nOut, SEXP Rpar, SEXP Ipar, SEXP Type, SEXP Ian, SEXP Jan,
SEXP Met, SEXP Option)
{
SEXP yout, RWORK, IWORK;
int j, k, ny, maxit, isSteady, method, lenplufac, lenplumx, lfill;
double *svar, *dsvar, *beta, *alpha, tin, *Atol, *Rtol, Chtol;
double *x, *precis, *ewt, droptol, permtol;
int neq, nnz, nsp, ngp, niter, mflag, posit, TotN, ipos, Itol, type;
int *ian, *jan, *igp, *jgp, *dims, *pos;
int len, isDll, ilumethod;
double *rsp= NULL, *plu= NULL, *rwork= NULL;
int *R= NULL, *C= NULL, *IC= NULL, *indDIM = NULL;
int *isp= NULL, *iwork= NULL, *iperm= NULL, *jlu= NULL, *ju= NULL;
C_deriv_func_type *derivs;
init_N_Protect();
nnz = INTEGER(NNZ)[0];
nsp = INTEGER(NSP)[0];
ngp = INTEGER(NGP)[0];
ny = LENGTH(y);
Itol = INTEGER(itol)[0];
maxit = INTEGER(nIter)[0];
type = INTEGER(Type)[0];
method = INTEGER(Met)[0];
posit = INTEGER(Posit)[0]; /* positivity of state variables: either specified at once, or via a vector..*/
ipos = LENGTH(Pos);
pos = (int *) R_alloc(ipos, sizeof(int));
for (j = 0; j < ipos; j++) pos[j] = INTEGER(Pos)[j];
neq = ny;
mflag = INTEGER(verbose)[0];
if (inherits(func, "NativeSymbol")) /* function is a dll */
isDll = 1;
else
isDll = 0;
if (nout > 0) isOut = 1;
/* initialise output ... */
initOut(isDll, neq, nOut, Rpar, Ipar);
/* initialise global variables... */
PROTECT(Time = NEW_NUMERIC(1)) ;incr_N_Protect();
PROTECT(Y = allocVector(REALSXP, neq)) ;incr_N_Protect();
/* copies of all variables that will be changed in the FORTRAN subroutine */
if (method == 1) { /* yale sparse matrix solver */
R = (int *) R_alloc(neq, sizeof(int));
for (j = 0; j < ny; j++) R[j] = 0;
C = (int *) R_alloc(neq, sizeof(int));
for (j = 0; j < ny; j++) C[j] = 0;
IC = (int *) R_alloc(neq, sizeof(int));
for (j = 0; j < ny; j++) IC[j] = 0;
rsp = (double *) R_alloc(nsp, sizeof(double));
for (j = 0; j < nsp; j++) rsp[j] = 0.;
isp = (int *) R_alloc(2*nsp, sizeof(int));
for (j = 0; j < 2*nsp; j++) isp[j] = 0;
} else { /* sparskit matrix solver */
/* get options */
lenplufac = INTEGER(getListElement(Option, "lenplufac"))[0];
lfill = INTEGER(getListElement(Option, "fillin") )[0];
droptol = REAL (getListElement(Option, "droptol") )[0];
permtol = REAL (getListElement(Option, "permtol") )[0];
ilumethod = method - 1; /* 1 = ilut, 2 = ilutp */
lenplumx = nnz + lenplufac*neq;
jlu = (int *) R_alloc(lenplumx, sizeof(int));
for (j = 0; j < lenplumx; j++) jlu[j] = 0;
ju = (int *) R_alloc(neq, sizeof(int));
for (j = 0; j < neq; j++) ju[j] = 0;
iwork = (int *) R_alloc(2*neq, sizeof(int));
for (j = 0; j < 2*neq; j++) iwork[j] = 0;
iperm = (int *) R_alloc(2*neq, sizeof(int));
for (j = 0; j < 2*neq; j++) iperm[j] = 0;
plu = (double *) R_alloc(lenplumx, sizeof(double));
for (j = 0; j < lenplumx; j++) plu[j] = 0.;
rwork = (double *) R_alloc(neq, sizeof(double));
for (j = 0; j < neq; j++) rwork[j] = 0.;
}
dims = (int *) R_alloc(7, sizeof(int)); /* 7 is maximal amount */
for (j = 0; j < 7; j++) dims[j] = 0;
svar = (double *) R_alloc(neq, sizeof(double));
for (j = 0; j < ny; j++) svar[j] = REAL(y)[j];
dsvar = (double *) R_alloc(neq, sizeof(double));
for (j = 0; j < ny; j++) dsvar[j] = 0;
beta = (double *) R_alloc(neq, sizeof(double));
for (j = 0; j < ny; j++) beta[j] = 0;
x = (double *) R_alloc(neq, sizeof(double));
for (j = 0; j < ny; j++) x[j] = 0;
alpha = (double *) R_alloc(nnz, sizeof(double));
for (j = 0; j < nnz; j++) alpha[j] = 0;
ewt = (double *) R_alloc(neq, sizeof(double));
for (j = 0; j < ny; j++) ewt[j] = 0;
ian = (int *) R_alloc(neq+1, sizeof(int));
if (type == 0) {for (j = 0; j < neq; j++) ian[j] = INTEGER(Ian)[j];}
else {for (j = 0; j < neq; j++) ian[j] = 0;}
jan = (int *) R_alloc(nnz, sizeof(int));
if (type == 0)
{for (j = 0; j < nnz; j++) jan[j] = INTEGER(Jan)[j];}
else {for (j = 0; j < nnz; j++) jan[j] = 0;}
/* 1-D, 2-D, 3-D problem: */
if (type == 2) /* 1=ncomp,2:dim(x), 3: cyclic(x)*/
for (j = 0; j<3 ; j++) dims[j] = INTEGER(NNZ)[j+1];
else if (type == 3) /* 1=ncomp,2-3:dim(x,y), 4-5: cyclic(x,y)*/
for (j = 0; j<5 ; j++) dims[j] = INTEGER(NNZ)[j+1];
else if (type == 4) /* 1=ncomp,2-4:dim(x,y,z), 5-7: cyclic(x,y,z)*/
for (j = 0; j<7 ; j++) dims[j] = INTEGER(NNZ)[j+1];
else if (type == 30) { /* same as type 3 (2-D) but with mapping */
for (j = 0; j<5 ; j++) dims[j] = INTEGER(NNZ)[j+1];
TotN = INTEGER(NNZ)[6];
indDIM = (int *) R_alloc(TotN, sizeof(int));
for (j = 0; j < TotN ; j++) indDIM[j] = INTEGER(NNZ)[j+7];
} else if (type == 40) { /* same as type 4 (3-D) but with mapping */
for (j = 0; j<7 ; j++) dims[j] = INTEGER(NNZ)[j+1];
TotN = INTEGER(NNZ)[8];
indDIM = (int *) R_alloc(TotN, sizeof(int));
for (j = 0; j < TotN ; j++) indDIM[j] = INTEGER(NNZ)[j+9];
}
igp = (int *) R_alloc(ngp+1, sizeof(int));
for (j = 0; j < ngp+1; j++) igp[j] = 0;
jgp = (int *) R_alloc(neq, sizeof(int));
for (j = 0; j < neq; j++) jgp[j] = 0;
len = LENGTH(atol);
Atol = (double *) R_alloc(len, sizeof(double));
for (j = 0; j < len; j++) Atol[j] = REAL(atol)[j];
len = LENGTH(rtol);
Rtol = (double *) R_alloc(len, sizeof(double));
for (j = 0; j < len; j++) Rtol[j] = REAL(rtol)[j];
Chtol = REAL(chtol)[0];
precis =(double *) R_alloc(maxit, sizeof(double));
for (j = 0; j < maxit; j++) precis[j] = 0;
PROTECT(yout = allocVector(REALSXP,ntot)) ; incr_N_Protect();
/* The initialisation routine */
initParms(initfunc, parms);
initForcs(initforc, forcs);
/* pointers to functions derivs and jac, passed to the FORTRAN subroutine */
if (isDll)
{
derivs = (C_deriv_func_type *) R_ExternalPtrAddrFn_(func);
} else { derivs = (C_deriv_func_type *) C_stsparse_derivs;
PROTECT(stsparse_deriv_func = func); incr_N_Protect();
PROTECT(stsparse_envir = rho);incr_N_Protect();
}
tin = REAL(time)[0];
if (method == 1) {
F77_CALL(dsparse) (derivs, &neq, &nnz, &nsp, &tin, svar, dsvar, beta, x,
alpha, ewt, rsp, ian, jan, igp, jgp, &ngp, R, C, IC, isp,
&maxit, &Chtol, Atol, Rtol, &Itol, &posit, pos, &ipos, &isSteady,
precis, &niter, dims, out, ipar, &type, indDIM);
} else {
F77_CALL(dsparsekit) (derivs, &neq, &nnz, &nsp, &tin, svar, dsvar, beta, x,
alpha, ewt, ian, jan, igp, jgp, &ngp, jlu, ju, iwork, iperm,
&maxit, &Chtol, Atol, Rtol, &Itol, &posit, pos, &ipos, &isSteady,
precis, &niter, dims, out, ipar, &type, &droptol, &permtol, &ilumethod,
&lfill, &lenplumx, plu, rwork, indDIM);
}
for (j = 0; j < ny; j++)
REAL(yout)[j] = svar[j];
if (isOut == 1)
{
derivs (&neq, &tin, svar, dsvar, out, ipar) ;
for (j = 0; j < nout; j++)
REAL(yout)[j + ny] = out[j];
}
PROTECT(RWORK = allocVector(REALSXP, niter));incr_N_Protect();
for (k = 0;k<niter;k++) REAL(RWORK)[k] = precis[k];
if (mflag == 1) Rprintf("mean residual derivative %g\n",precis[niter-1]);
setAttrib(yout, install("precis"), RWORK);
PROTECT(IWORK = allocVector(INTSXP, 4));incr_N_Protect();
INTEGER(IWORK)[0] = isSteady;
for (k = 0; k<3; k++) INTEGER(IWORK)[k+1] = dims[k];
setAttrib(yout, install("steady"), IWORK);
unprotect_all();
return(yout);
}
SEXP call_mebdfi(SEXP y, SEXP yprime, SEXP times, SEXP resfunc, SEXP parms,
SEXP rtol, SEXP atol, SEXP itol, SEXP rho, SEXP Tcrit, SEXP Hini,
SEXP Maxord, SEXP maxIt, SEXP nind, SEXP jacfunc, SEXP initfunc,
SEXP verbose, SEXP Mf, SEXP Mbnd, SEXP Liw, SEXP Lrw,
SEXP nOut, SEXP Rpar, SEXP Ipar, SEXP flist, SEXP Funtype, SEXP Mass)
{
/******************************************************************************/
/****** DECLARATION SECTION ******/
/******************************************************************************/
/* These R-structures will be allocated and returned to R*/
SEXP yout, yout2=NULL, dyout=NULL, ISTATE, RWORK;
int i, j, k, nt, latol, lrtol, lrw, liw, isDll;
int isForcing , Itol, *mbnd, mf, maxord, isOut;
double *xytmp, *xdytmp, *rwork, tin, tout, *Atol, *Rtol, tcrit, hini;
double *delta=NULL, cj;
int idid, *iwork, ires, ierr, funtype;
C_res_func_type *res_func = NULL;
C_jac_func_type *jac_func = NULL;
/******************************************************************************/
/****** STATEMENTS ******/
/******************************************************************************/
/* #### initialisation #### */
init_N_Protect();
n_eq = LENGTH(y);
nt = LENGTH(times);
// mflag = INTEGER(verbose)[0];
nout = INTEGER(nOut)[0];
funtype = INTEGER(Funtype)[0]; /* 1 = res, 2 = func */
ntot = n_eq;
mf = INTEGER(Mf)[0];
maxord = INTEGER(Maxord)[0];
tcrit = REAL(Tcrit)[0];
hini = REAL(Hini)[0];
ierr = 0;
/* function is a dll ?*/
if (inherits(resfunc, "NativeSymbol"))
isDll = 1;
else
isDll = 0;
isOut = 0;
if (isDll == 0 && nout > 0) isOut =1;
else if (isDll == 1 ) ntot = ntot+ nout;
/* initialise output vectors ... */
if (isDll==1) { /* function is a dll */
lrpar = nout + LENGTH(Rpar); /* length of rpar */
lipar = 3 + LENGTH(Ipar); /* length of ipar */
} else { /* function is not a dll */
lipar = 1;
lrpar = 1;
}
out = (double *) R_alloc(lrpar, sizeof(double));
ipar = (int *) R_alloc(lipar, sizeof(int));
if (isDll ==1) {
ipar[0] = nout; /* first 3 elements of ipar are special */
ipar[1] = lrpar;
ipar[2] = lipar;
/* other elements of ipar are set in R-function lsodx via argument *ipar* */
for (j = 0; j < LENGTH(Ipar); j++) ipar[j+3] = INTEGER(Ipar)[j];
/* first nout elements of rpar reserved for output variables
other elements are set in R-function lsodx via argument *rpar* */
for (j = 0; j < nout; j++) out[j] = 0.;
for (j = 0; j < LENGTH(Rpar);j++) out[nout+j] = REAL(Rpar)[j];
} else {
for (j = 0; j < lrpar; j++) out[j] = 0.;
for (j = 0; j < lipar; j++) ipar[j] = 0.;
}
/* copies of all variables that will be changed in the FORTRAN subroutine */
xytmp = (double *) R_alloc(n_eq, sizeof(double));
for (j = 0; j < n_eq; j++) xytmp[j] = REAL(y)[j];
xdytmp = (double *) R_alloc(n_eq, sizeof(double));
for (j = 0; j < n_eq; j++) xdytmp[j] = REAL(yprime)[j];
/* tolerance */
latol = LENGTH(atol);
Atol = (double *) R_alloc((int) latol, sizeof(double));
for (j = 0; j < latol; j++) Atol[j] = REAL(atol)[j];
lrtol = LENGTH(rtol);
Rtol = (double *) R_alloc((int) lrtol, sizeof(double));
for (j = 0; j < lrtol; j++) Rtol[j] = REAL(rtol)[j];
Itol = INTEGER(itol)[0];
/* work arrays */
liw = INTEGER(Liw)[0];
iwork = (int *) R_alloc(liw, sizeof(int));
for (j = 0; j<3; j++) iwork[j] = INTEGER(nind)[j];
for (j = 3; j<liw; j++) iwork[j] = 0;
iwork[13] = INTEGER(maxIt)[0];
lrw = INTEGER(Lrw)[0];
rwork = (double *) R_alloc(lrw, sizeof(double));
for (j = 0; j < lrw; j++) rwork[j] = 0.;
rwork[0] = DBL_EPSILON;
mbnd = (int *) R_alloc(4, sizeof(int));
for (j = 0; j<4; j++) mbnd[j] = INTEGER(Mbnd)[j];
nrowpd = mbnd[3];
/* initialise global variables... */
PROTECT(Rin = NEW_NUMERIC(2)); incr_N_Protect();
PROTECT(Y = allocVector(REALSXP,n_eq)); incr_N_Protect();
PROTECT(YPRIME = allocVector(REALSXP,n_eq)); incr_N_Protect();
PROTECT(yout = allocMatrix(REALSXP,ntot+1,nt)); incr_N_Protect();
if (isOut == 1) {
PROTECT(dyout = allocMatrix(REALSXP,n_eq+1,nt)); incr_N_Protect();
}
/**************************************************************************/
/****** Initialization of Parameters and Forcings (DLL functions) ******/
/**************************************************************************/
initParms(initfunc, parms);
// error("till here");
isForcing = initForcings(flist);
/* pointers to functions passed to the FORTRAN subroutine */
isMass = 0;
if (isDll == 1) { /* DLL address passed to fortran */
if (funtype == 1) {
res_func = (C_res_func_type *) R_ExternalPtrAddrFn_(resfunc);
if(isForcing==1) {
DLL_res_func = (C_res_func_type *) R_ExternalPtrAddrFn_(resfunc);
res_func = (C_res_func_type *) DLL_res_func_forc;
}
} else if (funtype <= 3) {
res_func = DLL_res_ode;
DLL_deriv_func = (C_deriv_func_type *) R_ExternalPtrAddrFn_(resfunc);
if(isForcing==1)
res_func = (C_res_func_type *) DLL_res_func_forc2;
if (funtype == 3) { /* mass matrix */
isMass = 1;
mass = (double *)R_alloc(n_eq * n_eq, sizeof(double));
for (j = 0; j < n_eq * n_eq; j++) mass[j] = REAL(Mass)[j];
dytmp = (double *) R_alloc(n_eq, sizeof(double));
}
} else /* for MASS matrix .... */
error("DLL function type not yet implemented");
delta = (double *) R_alloc(n_eq, sizeof(double));
for (j = 0; j < n_eq; j++) delta[j] = 0.;
} else {
/* interface function between fortran and R passed to Fortran*/
res_func = (C_res_func_type *) C_res_func;
/* needed to communicate with R */
PROTECT(R_res_func = resfunc); incr_N_Protect();
PROTECT(R_envir = rho); incr_N_Protect();
}
if (!isNull(jacfunc))
{
if (inherits(jacfunc,"NativeSymbol"))
jac_func = (C_jac_func_type *) R_ExternalPtrAddrFn_(jacfunc);
else {
jac_func = (C_jac_func_type *) C_jac_func;
PROTECT(R_daejac_func = jacfunc); incr_N_Protect();
}
}
/* #### initial time step #### */
idid = 1;
REAL(yout)[0] = REAL(times)[0];
for (j = 0; j < n_eq; j++)
REAL(yout)[j+1] = REAL(y)[j];
if (nout>0) {
tin = REAL(times)[0];
if (isDll == 1) {
res_func (&tin, xytmp, xdytmp, &cj, delta, &ires, out, ipar) ;
// for (j = 0; j < nout; j++)
// REAL(yout)[n_eq + j + 1] = out[j];
}
else for (j = 0; j < n_eq; j++)
REAL(dyout)[j] = xdytmp[j];
}
/* #### main time loop #### */
for (i = 0; i < nt-1; i++)
{
//
tin = REAL(times)[i];
tout = REAL(times)[i+1];
// Rprintf("idid %i tin %g tout %g xdytmp %g \n", idid, tin, tout, xdytmp[0]);
F77_CALL(mebdfi)(&n_eq, &tin, &hini, xytmp, xdytmp, &tout, &tcrit,
&mf, &idid, &lrw, rwork, &liw, iwork, mbnd, &maxord,
&Itol, Rtol, Atol, out, ipar, jac_func, res_func, &ierr);
// Rprintf(" hini, xytmp %g %g %g %g %g %g\n", hini, xytmp[0], xytmp[1],xytmp[2] ,xytmp[3], xytmp[4] );
// error("here");
if (idid == 1) {
idid = 0;
F77_CALL(mebdfi)(&n_eq, &tin, &hini, xytmp, xdytmp, &tout, &tcrit,
&mf, &idid, &lrw, rwork, &liw, iwork, mbnd, &maxord,
&Itol, Rtol, Atol, out, ipar, jac_func, res_func, &ierr);
}
// Rprintf("idid %i tin %g tout %g tin-tout %g \n", idid, tin, tout, tin-tout);
if (idid == -1) {
warning("the integration failed to pass the error test, even after reducing h by factor 1e10");
} else if (idid == -2) {
warning("the integration failed by repeated error test failures or by a test on rtol/atol. too much accuracy requested");
} else if (idid == -3) {
warning("the integration failed to achieve corrector convergence, even after reducing h by factor 1e10");
} else if (idid == -4) {
warning("illegal values of input parameters - see printed message");
} else if (idid == -5) {
warning("idid was -1 on input, but tout was not beyond t");
} else if (idid == -6) {
warning("maximum number of integration steps exceeded");
} else if (idid == -7) {
warning("stepsize is too small, < sqrt(uround)/100");
} else if (idid == -11) {
warning("insufficient real workspace for the integration");
} else if (idid == -12) {
warning("insufficient integer workspace for the integration");
}
// Rprintf(" i, tin, tout, ntot %i, %g, %g, %i\n", i, tin, tout, ntot);
REAL(yout)[(i+1)*(ntot+1)] = tin;
for (j = 0; j < n_eq; j++)
REAL(yout)[(i+1)*(ntot + 1) + j + 1] = xytmp[j];
if (nout>0) {
if (isDll == 1) {
res_func (&tin, xytmp, xdytmp, &cj, delta, &ires, out, ipar) ;
for (j = 0; j < nout; j++)
REAL(yout)[(i+1)*(ntot + 1) + n_eq + j + 1] = out[j];
}
else for (j = 0; j < n_eq; j++)
REAL(dyout)[(i+1)*(n_eq) + j + 1] = xdytmp[j];
}
/**/
/* #### an error occurred #### */
if (tin < tout) {
if (idid >=0) idid = -10;
warning("Returning early from mebdfi Results are accurate, as far as they go\n");
/* redimension yout */
PROTECT(yout2 = allocMatrix(REALSXP,ntot+1,(i+2)));incr_N_Protect();
for (k = 0; k < i+2; k++)
for (j = 0; j < ntot+1; j++)
REAL(yout2)[k*(ntot+1) + j] = REAL(yout)[k*(ntot+1) + j];
break;
}
} /* end main time loop */
/* error("tillhere");
#### returning output #### */
PROTECT(ISTATE = allocVector(INTSXP, 15));incr_N_Protect();
for (k = 0;k<14;k++) INTEGER(ISTATE)[k+1] = iwork[k];
INTEGER(ISTATE)[0] = idid;
PROTECT(RWORK = allocVector(REALSXP, 1));incr_N_Protect();
REAL(RWORK)[0] = rwork[1];
if (idid >= 0)
{
setAttrib(yout, install("istate"), ISTATE);
setAttrib(yout, install("rstate"), RWORK);
if (isOut ==1) setAttrib(yout, install("dy"), dyout);
}
else
{
setAttrib(yout2, install("istate"), ISTATE);
setAttrib(yout2, install("rstate"), RWORK);
if (isOut ==1) setAttrib(yout2, install("dy"), dyout);
}
//
/* #### termination #### */
unprotect_all();
if (idid >= 0)
return(yout);
else
return(yout2);
}
SEXP call_gambim(SEXP y, SEXP times, SEXP derivfunc, SEXP parms, SEXP rtol,
SEXP atol, SEXP rho, SEXP Tcrit, SEXP jacfunc, SEXP initfunc,
SEXP verbose, SEXP LRW, SEXP rWork, SEXP iWork, SEXP jT,
SEXP nOut, SEXP Nrmas, SEXP masfunc, SEXP ML, SEXP MU, SEXP Hini,
SEXP Rpar, SEXP Ipar, SEXP flist, SEXP Type)
{
/******************************************************************************/
/****** DECLARATION SECTION ******/
/******************************************************************************/
int j, nt, latol, lrtol, imas, mlmas, mumas, type;
int isForcing, runOK;
double *Atol, *Rtol, hini;
int itol, ijac, ml, mu, iout, idid, liw, lrw, sum;
/* pointers to functions passed to FORTRAN */
C_jac_func_type_gb *jac_func_gb = NULL;
C_solout_type *solout = NULL;
C_solout_type_bim *solout_bim = NULL;
C_mas_type *mas_func = NULL;
/******************************************************************************/
/****** STATEMENTS ******/
/******************************************************************************/
/* #### initialisation #### */
init_N_Protect();
type = INTEGER(Type)[0]; /* jacobian type */
ijac = INTEGER(jT)[0]; /* jacobian type */
n_eq = LENGTH(y); /* number of equations */
nt = LENGTH(times); /* number of output times */
maxt = nt;
tt = (double *) R_alloc(nt, sizeof(double));
for (j = 0; j < nt; j++) tt[j] = REAL(times)[j];
// mflag = INTEGER(verbose)[0];
/* is function a dll ?*/
isDll = inherits(derivfunc, "NativeSymbol");
/* initialise output ... */
initOutC(isDll, n_eq, nOut, Rpar, Ipar);
/* copies of variables that will be changed in the FORTRAN subroutine */
xytmp = (double *) R_alloc(n_eq, sizeof(double));
for (j = 0; j < n_eq; j++) xytmp[j] = REAL(y)[j];
ytmp = (double *) R_alloc(n_eq, sizeof(double));
for (j = 0; j < n_eq; j++) ytmp[j] = 0.;
latol = LENGTH(atol);
Atol = (double *) R_alloc((int) latol, sizeof(double));
for (j = 0; j < latol; j++) Atol[j] = REAL(atol)[j];
lrtol = LENGTH(rtol);
Rtol = (double *) R_alloc((int) lrtol, sizeof(double));
for (j = 0; j < lrtol; j++) Rtol[j] = REAL(rtol)[j];
/* tolerance specifications */
if (latol == 1 ) itol = 0;
else itol = 1;
/* mass matrix */
imas = INTEGER(Nrmas)[0];
mlmas = INTEGER(Nrmas)[1];
mumas = INTEGER(Nrmas)[2];
/* work vectors */
if (type == 1) {
liw = 27;
lrw = 21;
} else { // if (type == 2)
liw = n_eq + 40;
lrw = INTEGER(LRW)[0];
}
iwork = (int *) R_alloc(liw, sizeof(int));
for (j=0; j<LENGTH(iWork); j++) iwork[j] = INTEGER(iWork)[j];
for (j=LENGTH(iWork); j<liw; j++) iwork[j] = 0;
rwork = (double *) R_alloc(lrw, sizeof(double));
for (j=0; j<length(rWork); j++) rwork[j] = REAL(rWork)[j];
for (j=length(rWork); j<lrw; j++) rwork[j] = 0.;
ml = INTEGER(ML)[0];
mu = INTEGER(MU)[0];
hini = REAL(Hini)[0];
/* initialise global R-variables... */
initglobals (nt);
/* Initialization of Parameters, Forcings (DLL) */
initParms(initfunc, parms);
isForcing = initForcings(flist);
if (nout > 0 ) {
xdytmp= (double *) R_alloc(n_eq, sizeof(double));
for (j = 0; j < n_eq; j++) xdytmp[j] = 0.;
}
/* pointers to functions deriv_func, jac_func, jac_vec, root_func, passed to FORTRAN */
if (isDll) { /* DLL address passed to FORTRAN */
deriv_func = (C_deriv_func_type *) R_ExternalPtrAddrFn_(derivfunc);
/* overruling deriv_func if forcing */
if (isForcing) {
DLL_deriv_func = deriv_func;
deriv_func = (C_deriv_func_type *) C_deriv_func_forc_gb;
}
} else {
/* interface function between FORTRAN and C/R passed to FORTRAN */
deriv_func = (C_deriv_func_type *) C_deriv_func_gb;
/* needed to communicate with R */
R_deriv_func = derivfunc;
R_envir = rho;
}
if (!isNull(jacfunc)) {
if (isDll)
jac_func_gb = (C_jac_func_type_gb *) R_ExternalPtrAddrFn_(jacfunc);
else {
R_jac_func = jacfunc;
jac_func_gb= C_jac_func_gb;
}
}
if (!isNull(masfunc)) {
R_mas_func = masfunc;
mas_func= C_mas_func;
}
solout = C_solout_gam;
solout_bim = C_solout_bim;
iout = 1; /* solout used */
idid = 0;
/* #### integration #### */
it = 0;
tin = REAL(times)[0];
tout = REAL(times)[nt-1];
saveOut (tin, xytmp); /* save initial condition */
it = it +1;
if (type == 1)
F77_CALL(gamd) ( &n_eq, deriv_func, &tin, xytmp, &tout, &hini,
Rtol, Atol, &itol, jac_func_gb, &ijac, &ml, &mu,
mas_func, &imas, &mlmas, &mumas, solout, &iout,
rwork, &lrw, iwork, &liw, out, ipar, &idid);
else if (type == 2)
F77_CALL(bimd) ( &n_eq, deriv_func, &tin, &tout, xytmp, &hini,
Rtol, Atol, &itol, jac_func_gb, &ijac, &ml, &mu,
mas_func, &imas, &mlmas, &mumas, solout_bim, &iout,
rwork, &lrw, iwork, &liw, out, ipar, &idid);
if (idid == -1)
warning("input is not consistent");
else if (idid == -2)
warning("larger maxsteps needed");
else if (idid == -3)
warning("step size becomes too small");
else if (idid == -4)
warning("matrix is repeatedly singular");
/* #### an error occurred #### */
if(it <= nt-1) saveOut (tin, xytmp); /* save final condition */
if (idid < 0 ) {
it = it-1;
returnearly (1);
}
/* #### returning output #### */
/* feval */
PROTECT(RWORK = allocVector(REALSXP, 3)); incr_N_Protect();
REAL(RWORK)[0] = hini;
REAL(RWORK)[1] = hini;
REAL(RWORK)[2] = tin;
PROTECT(ISTATE = allocVector(INTSXP, 6)); incr_N_Protect();
INTEGER(ISTATE)[0] = idid;
/* nsteps */
sum = 0;
runOK = 0;
if (type == 1) {
for (j = 11; j < 23; j++) sum = sum + iwork[j];
INTEGER(ISTATE)[1] = sum;
/* feval */
INTEGER(ISTATE)[2] = iwork[9];
/* jacobian eval */
INTEGER(ISTATE)[3] = iwork[10];
/* LU decomp */
INTEGER(ISTATE)[4] = iwork[23];
/* number rejected steps */
sum = 0;
for (j = 11; j < 15; j++) sum = sum + iwork[j];
INTEGER(ISTATE)[5] = INTEGER(ISTATE)[1]- sum;
if(idid > 0) runOK = 1;
} else {
for (j = 20; j < 25; j++) sum = sum + iwork[j];
INTEGER(ISTATE)[1] = sum;
/* feval */
INTEGER(ISTATE)[2] = iwork[11];
/* jacobian eval */
INTEGER(ISTATE)[3] = iwork[12];
/* LU decomp */
INTEGER(ISTATE)[4] = iwork[13];
/* number rejected steps */
sum = 0;
for (j = 25; j < 29; j++) sum = sum + iwork[j];
INTEGER(ISTATE)[5] = INTEGER(ISTATE)[1]- sum;
if(idid >= 0) runOK = 1;
}
if (runOK) {
setAttrib(YOUT, install("istate"), ISTATE);
setAttrib(YOUT, install("rstate"), RWORK);
}
else {
setAttrib(YOUT2, install("istate"), ISTATE);
setAttrib(YOUT2, install("rstate"), RWORK);
}
/* #### termination #### */
unprotect_all();
if (runOK)
return(YOUT);
else
return(YOUT2);
}
SEXP call_rk4(SEXP Xstart, SEXP Times, SEXP Func, SEXP Initfunc,
SEXP Parms, SEXP Nout, SEXP Rho, SEXP Verbose,
SEXP Rpar, SEXP Ipar, SEXP Flist) {
/* Initialization */
int nprot = 0;
double *tt = NULL, *xs = NULL;
double *tmp, *FF, *out;
SEXP R_y, R_f, R_f1, R_f2, R_f3, R_f4;
double *y, *f, *f1, *f2, *f3, *f4;
SEXP R_y0, R_yout;
double *y0, *yout;
double t, dt;
int i = 0, j=0, it=0, nt = 0, neq=0;
int isForcing;
/*------------------------------------------------------------------------*/
/* Processing of Arguments */
/*------------------------------------------------------------------------*/
PROTECT(Times = AS_NUMERIC(Times)); nprot++;
tt = NUMERIC_POINTER(Times);
nt = length(Times);
PROTECT(Xstart = AS_NUMERIC(Xstart)); nprot++;
xs = NUMERIC_POINTER(Xstart);
neq = length(Xstart);
tmp = (double *) R_alloc(neq, sizeof(double));
FF = (double *) R_alloc(neq, sizeof(double));
int nout = INTEGER(Nout)[0]; /* n of global outputs if func is in a DLL */
int verbose = INTEGER(Verbose)[0];
/*------------------------------------------------------------------------*/
/* timesteps (for advection computation in ReacTran) */
/*------------------------------------------------------------------------*/
for (i = 0; i < 2; i++) timesteps[i] = 0;
/*------------------------------------------------------------------------*/
/* DLL, ipar, rpar (for compatibility with lsoda) */
/*------------------------------------------------------------------------*/
int isDll = FALSE;
int lrpar= 0, lipar = 0;
int *ipar = NULL;
if (inherits(Func, "NativeSymbol")) { /* function is a dll */
isDll = TRUE;
if (nout > 0) isOut = TRUE;
lrpar = nout + LENGTH(Rpar); /* length of rpar; LENGTH(Rpar) is always >0 */
lipar = 3 + LENGTH(Ipar); /* length of ipar */
} else { /* function is not a dll */
isDll = FALSE;
isOut = FALSE;
lipar = 3; /* in lsoda = 1; */
lrpar = nout; /* in lsoda = 1; */
}
out = (double *) R_alloc(lrpar, sizeof(double));
ipar = (int *) R_alloc(lipar, sizeof(int));
ipar[0] = nout; /* first 3 elements of ipar are special */
ipar[1] = lrpar;
ipar[2] = lipar;
if (isDll == 1) {
/* other elements of ipar are set in R-function lsodx via argument *ipar* */
for (j = 0; j < LENGTH(Ipar); j++) ipar[j+3] = INTEGER(Ipar)[j];
/* out: first nout elements of out are reserved for output variables
other elements are set via argument *rpar* */
for (j = 0; j < nout; j++) out[j] = 0.0;
for (j = 0; j < LENGTH(Rpar); j++) out[nout+j] = REAL(Rpar)[j];
}
/*------------------------------------------------------------------------*/
/* Allocation of Workspace */
/*------------------------------------------------------------------------*/
PROTECT(R_y0 = allocVector(REALSXP, neq)); nprot++;
PROTECT(R_f = allocVector(REALSXP, neq)); nprot++;
PROTECT(R_y = allocVector(REALSXP, neq)); nprot++;
PROTECT(R_f1 = allocVector(REALSXP, neq)); nprot++;
PROTECT(R_f2 = allocVector(REALSXP, neq)); nprot++;
PROTECT(R_f3 = allocVector(REALSXP, neq)); nprot++;
PROTECT(R_f4 = allocVector(REALSXP, neq)); nprot++;
y0 = REAL(R_y0);
f = REAL(R_f);
y = REAL(R_y);
f1 = REAL(R_f1);
f2 = REAL(R_f2);
f3 = REAL(R_f3);
f4 = REAL(R_f4);
/* matrix for holding the outputs */
PROTECT(R_yout = allocMatrix(REALSXP, nt, neq + nout + 1)); nprot++;
yout = REAL(R_yout);
/* attribute that stores state information, similar to lsoda */
SEXP R_istate;
int *istate;
PROTECT(R_istate = allocVector(INTSXP, 22)); nprot++;
istate = INTEGER(R_istate);
istate[0] = 0; /* assume succesful return */
for (i = 0; i < 22; i++) istate[i] = 0;
/*------------------------------------------------------------------------*/
/* Initialization of Parameters (for DLL functions) */
/*------------------------------------------------------------------------*/
if (Initfunc != NA_STRING) {
if (inherits(Initfunc, "NativeSymbol")) {
init_func_type *initializer;
PROTECT(de_gparms = Parms); nprot++;
initializer = (init_func_type *) R_ExternalPtrAddrFn_(Initfunc);
initializer(Initdeparms);
}
}
isForcing = initForcings(Flist);
/*------------------------------------------------------------------------*/
/* Initialization of Integration Loop */
/*------------------------------------------------------------------------*/
yout[0] = tt[0]; /* initial time */
for (i = 0; i < neq; i++) {
y0[i] = xs[i];
yout[(i + 1) * nt] = y0[i];
}
/*------------------------------------------------------------------------*/
/* Main Loop */
/*------------------------------------------------------------------------*/
for (it = 0; it < nt - 1; it++) {
t = tt[it];
dt = tt[it + 1] - t;
timesteps[0] = timesteps[1];
timesteps[1] = dt;
if (verbose)
Rprintf("Time steps = %d / %d time = %e\n", it + 1, nt, t);
derivs(Func, t, y0, Parms, Rho, f1, out, 0, neq, ipar, isDll, isForcing);
for (i = 0; i < neq; i++) {
f1[i] = dt * f1[i];
f[i] = y0[i] + 0.5 * f1[i];
}
derivs(Func, t + 0.5*dt, f, Parms, Rho, f2, out, 0, neq, ipar, isDll, isForcing);
for (i = 0; i < neq; i++) {
f2[i] = dt * f2[i];
f[i] = y0[i] + 0.5 * f2[i];
}
derivs(Func, t + 0.5*dt, f, Parms, Rho, f3, out, 0, neq, ipar, isDll, isForcing);
for (i = 0; i < neq; i++) {
f3[i] = dt * f3[i];
f[i] = y0[i] + f3[i];
}
derivs(Func, t + dt, f, Parms, Rho, f4, out, 0, neq, ipar, isDll, isForcing);
for (i = 0; i < neq; i++) {
f4[i] = dt * f4[i];
}
/* Final computation of y */
for (i = 0; i < neq; i++) {
f[i] = (f1[i] + 2.0 * f2[i] + 2.0 * f3[i] + f4[i]) / 6.0;
y[i] = y0[i] + f[i];
y0[i] = y[i]; /* next time step */
}
/* Store outputs */
if (it < nt) {
yout[it + 1] = t + dt;
for (i = 0; i < neq; i++) yout[it + 1 + nt * (1 + i)] = y[i];
}
} /* end of rk main loop */
/*------------------------------------------------------------------------*/
/* call derivs again to get global outputs */
/* "-1" in derivs suppresses unnecessary copying */
/*------------------------------------------------------------------------*/
for (int j = 0; j < nt; j++) {
t = yout[j];
for (i = 0; i < neq; i++) tmp[i] = yout[j + nt * (1 + i)];
derivs(Func, t, tmp, Parms, Rho, FF, out, -1, neq, ipar, isDll, isForcing);
for (i = 0; i < nout; i++) {
yout[j + nt * (1 + neq + i)] = out[i];
}
}
/* Attach diagnostic information (codes are compatible to lsoda) */
setIstate(R_yout, R_istate, istate, it, 4, 0, 4, 0);
/* release R resources */
timesteps[0] = 0;
timesteps[1] = 0;
UNPROTECT(nprot);
return(R_yout);
}