/*==========================================================================*/
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);
}
/* 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_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);
}
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_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_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_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_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_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);
}
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);
}
}
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);
}
SEXP call_zvode(SEXP y, SEXP times, SEXP derivfunc, SEXP parms, SEXP rtol,
SEXP atol, SEXP rho, SEXP tcrit, SEXP jacfunc, SEXP initfunc,
SEXP iTask, SEXP rWork, SEXP iWork, SEXP jT, SEXP nOut,
SEXP lZw, SEXP lRw, SEXP lIw, SEXP Rpar, SEXP Ipar, SEXP flist)
{
/******************************************************************************/
/****** DECLARATION SECTION ******/
/******************************************************************************/
int i, j, k, nt, latol, lrtol, lrw, liw, lzw;
double tin, tout, *Atol, *Rtol, ss;
int neq, itol, itask, istate, iopt, jt, //mflag,
is, isDll, isForcing;
Rcomplex *xytmp, *dy = NULL, *zwork;
int *iwork, it, ntot, nout;
double *rwork;
C_zderiv_func_type *zderiv_func;
C_zjac_func_type *zjac_func = NULL;
/******************************************************************************/
/****** STATEMENTS ******/
/******************************************************************************/
lock_solver(); /* prevent nested call of solvers that have global variables */
/* #### initialisation #### */
//init_N_Protect();
long int old_N_Protect = save_N_Protected();
jt = INTEGER(jT)[0];
neq = LENGTH(y);
nt = LENGTH(times);
nout = INTEGER(nOut)[0];
/* The output:
zout and ipar are used to pass output variables (number set by nout)
followed by other input (e.g. forcing functions) provided
by R-arguments rpar, ipar
ipar[0]: number of output variables, ipar[1]: length of rpar,
ipar[2]: length of ipar */
/* is function a dll ?*/
if (inherits(derivfunc, "NativeSymbol")) {
isDll = 1;
} else {
isDll = 0;
}
/* initialise output for Complex variables ... */
initOutComplex(isDll, &nout, &ntot, neq, nOut, Rpar, Ipar);
/* copies of all variables that will be changed in the FORTRAN subroutine */
xytmp = (Rcomplex *) R_alloc(neq, sizeof(Rcomplex));
for (j = 0; j < neq; j++) xytmp[j] = COMPLEX(y)[j];
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];
liw = INTEGER(lIw)[0];
iwork = (int *) R_alloc(liw, sizeof(int));
for (j = 0; j < 30; j++) iwork[j] = INTEGER(iWork)[j];
lrw = INTEGER(lRw)[0];
rwork = (double *) R_alloc(lrw, sizeof(double));
for (j = 0; j < 20; j++) rwork[j] = REAL(rWork)[j];
/* global variable */
//timesteps = (double *) R_alloc(2, sizeof(double));
for (j=0; j<2; j++) timesteps[j] = 0.;
lzw = INTEGER(lZw)[0];
zwork = (Rcomplex *) R_alloc(lzw, sizeof(Rcomplex));
/* initialise global R-variables... */
PROTECT(cY = allocVector(CPLXSXP , neq) ) ;incr_N_Protect();
PROTECT(YOUT = allocMatrix(CPLXSXP,ntot+1,nt)) ;incr_N_Protect();
/**************************************************************************/
/****** Initialization of Parameters and Forcings (DLL functions) ******/
/**************************************************************************/
initParms(initfunc, parms);
isForcing = initForcings(flist);
/* pointers to functions zderiv_func and zjac_func, passed to the FORTRAN subroutine */
if (isDll == 1) { /* DLL address passed to FORTRAN */
zderiv_func = (C_zderiv_func_type *) R_ExternalPtrAddr(derivfunc);
/* no need to communicate with R - but output variables set here */
if (isOut) {
dy = (Rcomplex *) R_alloc(neq, sizeof(Rcomplex));
/* for (j = 0; j < neq; j++) dy[j] = i0; */
}
/* here overruling zderiv_func if forcing */
if (isForcing) {
DLL_cderiv_func = (C_zderiv_func_type *) R_ExternalPtrAddr(derivfunc);
zderiv_func = (C_zderiv_func_type *) C_zderiv_func_forc;
}
} else {
/* interface function between FORTRAN and R passed to FORTRAN*/
zderiv_func = (C_zderiv_func_type *) C_zderiv_func;
/* needed to communicate with R */
R_zderiv_func = derivfunc;
R_vode_envir = rho;
}
if (!isNull(jacfunc)) {
if (isDll == 1) {
zjac_func = (C_zjac_func_type *) R_ExternalPtrAddr(jacfunc);
} else {
R_zjac_func = jacfunc;
zjac_func = C_zjac_func;
}
}
/* tolerance specifications */
if (latol == 1 && lrtol == 1 ) itol = 1;
if (latol > 1 && lrtol == 1 ) itol = 2;
if (latol == 1 && lrtol > 1 ) itol = 3;
if (latol > 1 && lrtol > 1 ) itol = 4;
itask = INTEGER(iTask)[0];
istate = 1;
iopt = 0;
ss = 0.;
is = 0;
for (i = 5; i < 8 ; i++) ss = ss+rwork[i];
for (i = 5; i < 10; i++) is = is+iwork[i];
if (ss >0 || is > 0) iopt = 1; /* non-standard input */
/* #### initial time step #### */
/* COMPLEX(YOUT)[0] = COMPLEX(times)[0];*/
for (j = 0; j < neq; j++) {
COMPLEX(YOUT)[j+1] = COMPLEX(y)[j];
} /* function in DLL and output */
if (isOut == 1) {
tin = REAL(times)[0];
zderiv_func (&neq, &tin, xytmp, dy, zout, ipar) ;
for (j = 0; j < nout; j++)
COMPLEX(YOUT)[j + neq + 1] = zout[j];
}
/* #### main time loop #### */
for (it = 0; it < nt-1; it++) {
tin = REAL(times)[it];
tout = REAL(times)[it+1];
F77_CALL(zvode) (zderiv_func, &neq, xytmp, &tin, &tout,
&itol, Rtol, Atol, &itask, &istate, &iopt, zwork, &lzw, rwork,
&lrw, iwork, &liw, zjac_func, &jt, zout, ipar);
/* in case size of timesteps is called for */
timesteps [0] = rwork[10];
timesteps [1] = rwork[11];
if (istate == -1) {
warning("an excessive amount of work (> mxstep ) was done, but integration was not successful - increase maxsteps ?");
} else if (istate == -2) {
warning("Excessive precision requested. scale up `rtol' and `atol' e.g by the factor %g\n",10.0);
} else if (istate == -4) {
warning("repeated error test failures on a step, but integration was successful - singularity ?");
} else if (istate == -5) {
warning("repeated convergence test failures on a step, but integration was successful - inaccurate Jacobian matrix?");
} else if (istate == -6) {
warning("Error term became zero for some i: pure relative error control (ATOL(i)=0.0) for a variable which is now vanished");
}
if (istate == -3) {
error("illegal input detected before taking any integration steps - see written message");
unprotect_all();
} else {
/* REAL(YOUT)[(it+1)*(ntot+1)] = tin;*/
for (j = 0; j < neq; j++)
COMPLEX(YOUT)[(it+1)*(ntot + 1) + j + 1] = xytmp[j];
if (isOut == 1) {
zderiv_func (&neq, &tin, xytmp, dy, zout, ipar) ;
for (j = 0; j < nout; j++)
COMPLEX(YOUT)[(it+1)*(ntot + 1) + j + neq + 1] = zout[j];
}
}
/* #### an error occurred #### */
if (istate < 0 || tin < tout) {
warning("Returning early from dvode Results are accurate, as far as they go\n");
/* redimension YOUT */
PROTECT(YOUT2 = allocMatrix(CPLXSXP,ntot+1,(it+2)));incr_N_Protect();
for (k = 0; k < it+2; k++)
for (j = 0; j < ntot+1; j++)
COMPLEX(YOUT2)[k*(ntot+1) + j] = COMPLEX(YOUT)[k*(ntot+1) + j];
break;
}
} /* end main time loop */
/* #### returning output #### */
terminate(istate, iwork, 23, 0, rwork, 4, 10);
unlock_solver();
//unprotect_all();
restore_N_Protected(old_N_Protect);
if (istate > 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_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_rkImplicit(SEXP Xstart, SEXP Times, SEXP Func, SEXP Initfunc,
SEXP Parms, SEXP eventfunc, SEXP elist, SEXP Nout, SEXP Rho,
SEXP Tcrit, SEXP Verbose, SEXP Hini, SEXP Rpar, SEXP Ipar,
SEXP Method, SEXP Maxsteps, SEXP Flist) {
/** Initialization **/
long int old_N_Protect = save_N_Protected();
double *tt = NULL, *xs = NULL;
double *y, *f, *Fj, *tmp, *tmp2, *tmp3, *FF, *rr;
SEXP R_yout;
double *y0, *y1, *dy1, *out, *yout;
double t, dt, tmax;
int fsal = FALSE; /* fixed step methods have no FSAL */
int interpolate = TRUE; /* polynomial interpolation is done by default */
int i = 0, j=0, it=0, it_tot=0, it_ext=0, nt = 0, neq=0;
int isForcing, isEvent;
double *alpha;
int *index;
/**************************************************************************/
/****** Processing of Arguments ******/
/**************************************************************************/
double tcrit = REAL(Tcrit)[0];
double hini = REAL(Hini)[0];
int maxsteps = INTEGER(Maxsteps)[0];
int nout = INTEGER(Nout)[0]; /* number of global outputs if func is in a DLL */
int verbose = INTEGER(Verbose)[0];
int stage = (int)REAL(getListElement(Method, "stage"))[0];
SEXP R_A, R_B1, R_C;
double *A, *bb1, *cc=NULL;
PROTECT(R_A = getListElement(Method, "A")); incr_N_Protect();
A = REAL(R_A);
PROTECT(R_B1 = getListElement(Method, "b1")); incr_N_Protect();
bb1 = REAL(R_B1);
PROTECT(R_C = getListElement(Method, "c")); incr_N_Protect();
if (length(R_C)) cc = REAL(R_C);
double qerr = REAL(getListElement(Method, "Qerr"))[0];
PROTECT(Times = AS_NUMERIC(Times)); incr_N_Protect();
tt = NUMERIC_POINTER(Times);
nt = length(Times);
PROTECT(Xstart = AS_NUMERIC(Xstart)); incr_N_Protect();
xs = NUMERIC_POINTER(Xstart);
neq = length(Xstart);
/*------------------------------------------------------------------------*/
/* timesteps (for advection computation in ReacTran) */
/*------------------------------------------------------------------------*/
for (i = 0; i < 2; i++) timesteps[i] = 0;
/**************************************************************************/
/****** DLL, ipar, rpar (to be compatible with lsoda) ******/
/**************************************************************************/
int isDll = FALSE;
//int ntot = 0;
int lrpar= 0, lipar = 0;
int *ipar = NULL;
if (inherits(Func, "NativeSymbol")) { /* function is a dll */
isDll = TRUE;
if (nout > 0) isOut = TRUE;
//ntot = neq + nout; /* length of yout */
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;
//ntot = neq;
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 */
/*------------------------------------------------------------------------*/
y0 = (double *) R_alloc(neq, sizeof(double));
y1 = (double *) R_alloc(neq, sizeof(double));
dy1 = (double *) R_alloc(neq, sizeof(double));
f = (double *) R_alloc(neq, sizeof(double));
y = (double *) R_alloc(neq, sizeof(double));
Fj = (double *) R_alloc(neq, sizeof(double));
FF = (double *) R_alloc(neq * stage, sizeof(double));
rr = (double *) R_alloc(neq * 5, sizeof(double));
/* ks */
alpha = (double *) R_alloc(neq * stage * neq * stage, sizeof(double));
index = (int *) R_alloc(neq * stage, sizeof(int));
tmp = (double *) R_alloc(neq * stage, sizeof(double));
tmp2 = (double *) R_alloc(neq * stage, sizeof(double));
tmp3 = (double *) R_alloc(neq * stage, sizeof(double));
/* matrix for polynomial interpolation */
SEXP R_nknots;
int nknots = 6; /* 6 = 5th order polynomials by default*/
int iknots = 0; /* counter for knots buffer */
double *yknots;
PROTECT(R_nknots = getListElement(Method, "nknots")); incr_N_Protect();
if (length(R_nknots)) nknots = INTEGER(R_nknots)[0] + 1;
if (nknots < 2) {nknots=1; interpolate = FALSE;}
yknots = (double *) R_alloc((neq + 1) * (nknots + 1), sizeof(double));
/* matrix for holding states and global outputs */
PROTECT(R_yout = allocMatrix(REALSXP, nt, neq + nout + 1)); incr_N_Protect();
yout = REAL(R_yout);
/* initialize outputs with NA first */
for (i = 0; i < nt * (neq + nout + 1); i++) yout[i] = NA_REAL;
/* attribute that stores state information, similar to lsoda */
SEXP R_istate;
int *istate;
PROTECT(R_istate = allocVector(INTSXP, 22)); incr_N_Protect();
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) */
/*------------------------------------------------------------------------*/
PROTECT(Y = allocVector(REALSXP,(neq))); incr_N_Protect();
initParms(Initfunc, Parms);
isForcing = initForcings(Flist);
isEvent = initEvents(elist, eventfunc,0);
if (isEvent) interpolate = FALSE;
/*------------------------------------------------------------------------*/
/* Initialization of Integration Loop */
/*------------------------------------------------------------------------*/
yout[0] = tt[0]; /* initial time */
yknots[0] = tt[0]; /* for polynomial interpolation */
for (i = 0; i < neq; i++) {
y0[i] = xs[i]; /* initial values */
yout[(i + 1) * nt] = y0[i]; /* output array */
yknots[iknots + nknots * (i + 1)] = xs[i]; /* for polynomials */
}
iknots++;
t = tt[0];
tmax = fmax(tt[nt - 1], tcrit);
/* Initialization of work arrays (to be on the safe side, remove this later) */
for (i = 0; i < neq; i++) {
y1[i] = 0;
Fj[i] = 0;
for (j= 0; j < stage; j++) {
FF[i + j * neq] = 0;
}
}
/*------------------------------------------------------------------------*/
/* Main Loop */
/*------------------------------------------------------------------------*/
it = 1; /* step counter; zero element is initial state */
it_ext = 0; /* counter for external time step (dense output) */
it_tot = 0; /* total number of time steps */
if (interpolate) {
/* integrate over the whole time step and interpolate internally */
rk_implicit( alpha, index,
fsal, neq, stage, isDll, isForcing, verbose, nknots, interpolate,
maxsteps, nt,
&iknots, &it, &it_ext, &it_tot,
istate, ipar,
t, tmax, hini,
&dt,
tt, y0, y1, dy1, f, y, Fj, tmp, tmp2, tmp3, FF, rr, A,
out, bb1, cc, yknots, yout,
Func, Parms, Rho
);
} else {
for (int j = 0; j < nt - 1; j++) {
t = tt[j];
tmax = fmin(tt[j + 1], tcrit);
dt = tmax - t;
if (isEvent) {
updateevent(&t, y0, istate);
}
rk_implicit(alpha, index,
fsal, neq, stage, isDll, isForcing, verbose, nknots, interpolate,
maxsteps, nt,
&iknots, &it, &it_ext, &it_tot,
istate, ipar,
t, tmax, hini,
&dt,
tt, y0, y1, dy1, f, y, Fj, tmp, tmp2, tmp3, FF, rr, A,
out, bb1, cc, yknots, yout,
Func, Parms, Rho
);
/* in this mode, internal interpolation is skipped,
so we can simply store the results at the end of each call */
yout[j + 1] = tmax;
for (i = 0; i < neq; i++) yout[j + 1 + nt * (1 + i)] = y1[i];
}
}
/*====================================================================*/
/* call derivs again to get global outputs */
/* j = -1 suppresses unnecessary internal copying */
/*====================================================================*/
if(nout > 0) {
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_tot, stage, fsal, qerr, 0);
/* release R resources */
if (verbose) {
Rprintf("Number of time steps it = %d, it_ext = %d, it_tot = %d\n", it, it_ext, it_tot);
Rprintf("Maxsteps %d\n", maxsteps);
}
/* release R resources */
timesteps[0] = 0;
timesteps[1] = 0;
restore_N_Protected(old_N_Protect);
return(R_yout);
}
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_rkAuto(SEXP Xstart, SEXP Times, SEXP Func, SEXP Initfunc,
SEXP Parms, SEXP eventfunc, SEXP elist, SEXP Nout, SEXP Rho,
SEXP Rtol, SEXP Atol, SEXP Tcrit, SEXP Verbose,
SEXP Hmin, SEXP Hmax, SEXP Hini, SEXP Rpar, SEXP Ipar,
SEXP Method, SEXP Maxsteps, SEXP Flist) {
/** Initialization **/
long int old_N_Protect = save_N_Protected();
double *tt = NULL, *xs = NULL;
double *y, *f, *Fj, *tmp, *FF, *rr;
SEXP R_yout;
double *y0, *y1, *y2, *dy1, *dy2, *out, *yout;
double errold = 0.0, t, dt, tmax;
SEXP R_FSAL, Alpha, Beta;
int fsal = FALSE; /* assume no FSAL */
/* Use polynomial interpolation if not disabled by the method
or when events come in to play (stop-and-go mode).
Methods with dense output interpolate by default,
all others do not.
*/
int interpolate = TRUE;
int i = 0, j = 0, it = 0, it_tot = 0, it_ext = 0, nt = 0, neq = 0, it_rej = 0;
int isForcing, isEvent;
/*------------------------------------------------------------------------*/
/* Processing of Arguments */
/*------------------------------------------------------------------------*/
int lAtol = LENGTH(Atol);
double *atol = (double*) R_alloc((int) lAtol, sizeof(double));
int lRtol = LENGTH(Rtol);
double *rtol = (double*) R_alloc((int) lRtol, sizeof(double));
for (j = 0; j < lRtol; j++) rtol[j] = REAL(Rtol)[j];
for (j = 0; j < lAtol; j++) atol[j] = REAL(Atol)[j];
double tcrit = REAL(Tcrit)[0];
double hmin = REAL(Hmin)[0];
double hmax = REAL(Hmax)[0];
double hini = REAL(Hini)[0];
int maxsteps = INTEGER(Maxsteps)[0];
int nout = INTEGER(Nout)[0]; /* number of global outputs is func is in a DLL */
int verbose = INTEGER(Verbose)[0];
int stage = (int)REAL(getListElement(Method, "stage"))[0];
SEXP R_A, R_B1, R_B2, R_C, R_D, R_densetype;
double *A, *bb1, *bb2 = NULL, *cc = NULL, *dd = NULL;
PROTECT(R_A = getListElement(Method, "A")); incr_N_Protect();
A = REAL(R_A);
PROTECT(R_B1 = getListElement(Method, "b1")); incr_N_Protect();
bb1 = REAL(R_B1);
PROTECT(R_B2 = getListElement(Method, "b2")); incr_N_Protect();
if (length(R_B2)) bb2 = REAL(R_B2);
PROTECT(R_C = getListElement(Method, "c")); incr_N_Protect();
if (length(R_C)) cc = REAL(R_C);
PROTECT(R_D = getListElement(Method, "d")); incr_N_Protect();
if (length(R_D)) dd = REAL(R_D);
/* dense output Cash-Karp: densetype = 2 */
int densetype = 0;
PROTECT(R_densetype = getListElement(Method, "densetype")); incr_N_Protect();
if (length(R_densetype)) densetype = INTEGER(R_densetype)[0];
double qerr = REAL(getListElement(Method, "Qerr"))[0];
double beta = 0; /* 0.4/qerr; */
PROTECT(Beta = getListElement(Method, "beta")); incr_N_Protect();
if (length(Beta)) beta = REAL(Beta)[0];
double alpha = 1/qerr - 0.75 * beta;
PROTECT(Alpha = getListElement(Method, "alpha")); incr_N_Protect();
if (length(Alpha)) alpha = REAL(Alpha)[0];
PROTECT(R_FSAL = getListElement(Method, "FSAL")); incr_N_Protect();
if (length(R_FSAL)) fsal = INTEGER(R_FSAL)[0];
PROTECT(Times = AS_NUMERIC(Times)); incr_N_Protect();
tt = NUMERIC_POINTER(Times);
nt = length(Times);
PROTECT(Xstart = AS_NUMERIC(Xstart)); incr_N_Protect();
xs = NUMERIC_POINTER(Xstart);
neq = length(Xstart);
/*------------------------------------------------------------------------*/
/* 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;
/* code adapted from lsoda to improve compatibility */
if (inherits(Func, "NativeSymbol")) {
/* function is a dll */
isDll = TRUE;
if (nout > 0) isOut = TRUE;
//ntot = neq + nout; /* length of yout */
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;
//ntot = neq;
lipar = 3; /* in lsoda = 1 */
lrpar = nout; /* in lsoda = 1 */
}
out = (double*) R_alloc(lrpar, sizeof(double));
ipar = (int *) R_alloc(lipar, sizeof(int));
/* first 3 elements of ipar are special */
ipar[0] = nout;
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 */
/*------------------------------------------------------------------------*/
y0 = (double*) R_alloc(neq, sizeof(double));
y1 = (double*) R_alloc(neq, sizeof(double));
y2 = (double*) R_alloc(neq, sizeof(double));
dy1 = (double*) R_alloc(neq, sizeof(double));
dy2 = (double*) R_alloc(neq, sizeof(double));
f = (double*) R_alloc(neq, sizeof(double));
y = (double*) R_alloc(neq, sizeof(double));
Fj = (double*) R_alloc(neq, sizeof(double));
tmp = (double*) R_alloc(neq, sizeof(double));
FF = (double*) R_alloc(neq * stage, sizeof(double));
rr = (double*) R_alloc(neq * 5, sizeof(double));
/* matrix for polynomial interpolation */
SEXP R_nknots;
int nknots = 6; /* 6 = 5th order polynomials by default*/
int iknots = 0; /* counter for knots buffer */
double *yknots;
PROTECT(R_nknots = getListElement(Method, "nknots")); incr_N_Protect();
if (length(R_nknots)) nknots = INTEGER(R_nknots)[0] + 1;
if (nknots < 2) {nknots = 1; interpolate = FALSE;}
if (densetype > 0) interpolate = TRUE;
yknots = (double*) R_alloc((neq + 1) * (nknots + 1), sizeof(double));
/* matrix for holding states and global outputs */
PROTECT(R_yout = allocMatrix(REALSXP, nt, neq + nout + 1)); incr_N_Protect();
yout = REAL(R_yout);
/* initialize outputs with NA first */
for (i = 0; i < nt * (neq + nout + 1); i++) yout[i] = NA_REAL;
/* attribute that stores state information, similar to lsoda */
SEXP R_istate;
int *istate;
PROTECT(R_istate = allocVector(INTSXP, 22)); incr_N_Protect();
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) */
/*------------------------------------------------------------------------*/
PROTECT(Y = allocVector(REALSXP,(neq))); incr_N_Protect();
initParms(Initfunc, Parms);
isForcing = initForcings(Flist);
isEvent = initEvents(elist, eventfunc, 0);
if (isEvent) interpolate = FALSE;
/*------------------------------------------------------------------------*/
/* Initialization of Integration Loop */
/*------------------------------------------------------------------------*/
yout[0] = tt[0]; /* initial time */
yknots[0] = tt[0]; /* for polynomial interpolation */
for (i = 0; i < neq; i++) {
y0[i] = xs[i]; /* initial values */
yout[(i + 1) * nt] = y0[i]; /* output array */
yknots[iknots + nknots * (i + 1)] = xs[i]; /* for polynomials */
}
iknots++;
t = tt[0];
tmax = fmax(tt[nt - 1], tcrit);
dt = fmin(hmax, hini);
hmax = fmin(hmax, tmax - t);
/* Initialize work arrays (to be on the safe side, remove this later) */
for (i = 0; i < neq; i++) {
y1[i] = 0;
y2[i] = 0;
Fj[i] = 0;
for (j= 0; j < stage; j++) {
FF[i + j * neq] = 0;
}
}
/*------------------------------------------------------------------------*/
/* Main Loop */
/*------------------------------------------------------------------------*/
it = 1; /* step counter; zero element is initial state */
it_ext = 0; /* counter for external time step (dense output) */
it_tot = 0; /* total number of time steps */
it_rej = 0;
if (interpolate) {
/* integrate over the whole time step and interpolate internally */
rk_auto(
fsal, neq, stage, isDll, isForcing, verbose, nknots, interpolate,
densetype, maxsteps, nt,
&iknots, &it, &it_ext, &it_tot, &it_rej,
istate, ipar,
t, tmax, hmin, hmax, alpha, beta,
&dt, &errold,
tt, y0, y1, y2, dy1, dy2, f, y, Fj, tmp, FF, rr, A,
out, bb1, bb2, cc, dd, atol, rtol, yknots, yout,
Func, Parms, Rho
);
} else {
/* integrate separately between external time steps; do not interpolate */
for (int j = 0; j < nt - 1; j++) {
t = tt[j];
tmax = fmin(tt[j + 1], tcrit);
dt = tmax - t;
if (isEvent) {
updateevent(&t, y0, istate);
}
if (verbose) Rprintf("\n %d th time interval = %g ... %g", j, t, tmax);
rk_auto(
fsal, neq, stage, isDll, isForcing, verbose, nknots, interpolate,
densetype, maxsteps, nt,
&iknots, &it, &it_ext, &it_tot, &it_rej,
istate, ipar,
t, tmax, hmin, hmax, alpha, beta,
&dt, &errold,
tt, y0, y1, y2, dy1, dy2, f, y, Fj, tmp, FF, rr, A,
out, bb1, bb2, cc, dd, atol, rtol, yknots, yout,
Func, Parms, Rho
);
/* in this mode, internal interpolation is skipped,
so we can simply store the results at the end of each call */
yout[j + 1] = tmax;
for (i = 0; i < neq; i++) yout[j + 1 + nt * (1 + i)] = y2[i];
}
}
/*====================================================================*/
/* call derivs again to get global outputs */
/* j = -1 suppresses unnecessary internal copying */
/*====================================================================*/
if (nout > 0) {
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_tot, stage, fsal, qerr, it_rej);
if (densetype == 2) istate[12] = it_tot * stage + 2; /* number of function evaluations */
/* verbose printing in debugging mode*/
if (verbose)
Rprintf("\nNumber of time steps it = %d, it_ext = %d, it_tot = %d it_rej %d\n",
it, it_ext, it_tot, it_rej);
/* release R resources */
timesteps[0] = 0;
timesteps[1] = 0;
restore_N_Protected(old_N_Protect);
return(R_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);
}