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_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_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_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_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);
}
