void tst_resm_hexd_(const char *file, const int lineno, int ttype,
const void *buf, size_t size, const char *arg_fmt, ...)
{
char tmesg[USERMESG];
static const size_t symb_num = 2; /* xx */
static const size_t size_max = 16;
size_t offset;
size_t i;
char *pmesg = tmesg;
tst_res_func_t res_func;
if (tst_test)
res_func = tst_res_;
else
res_func = tst_res__;
EXPAND_VAR_ARGS(tmesg, arg_fmt, USERMESG);
offset = strlen(tmesg);
if (size > size_max || size == 0 ||
(offset + size * (symb_num + 1)) >= USERMESG)
res_func(file, lineno, ttype, "%s", tmesg);
else
pmesg += offset;
for (i = 0; i < size; ++i) {
/* add space before byte except first one */
if (pmesg != tmesg)
*(pmesg++) = ' ';
sprintf(pmesg, "%02x", ((unsigned char *)buf)[i]);
pmesg += symb_num;
if ((i + 1) % size_max == 0 || i + 1 == size) {
res_func(file, lineno, ttype, "%s", tmesg);
pmesg = tmesg;
}
}
}
void*
resolve_thread( void *data )
{
method_list_t *m_list;
mc_t *mc;
cs_t *cs;
method_prototype method;
char *cs_dboid;
resolve_function res_func;
ev_queue_t *res_queue;
png_t *conf;
gen_t *g;
obj_t *obj;
conf = (png_t*) data;
res_queue = &conf->res_queue;
m_list = conf->m_list;
/* Set default resolve function */
res_func = &resolve;
printf( "[Resolve Thread] Started.\n" );
while( 1 )
{
/* locks the signal variable and wait */
/*
pthread_mutex_lock( conf->resolve_sig_lock );
pthread_cond_wait( conf->resolve_sig, conf->resolve_sig_lock );
pthread_mutex_unlock( conf->resolve_sig_lock );
*/
ev_queue_listen( res_queue );
/* Get what conflict set that send the signal */
cs_dboid = ev_queue_pop( res_queue );
cs = cs_list_find( &((png_t*)data)->cs_list, cs_dboid );
/* Fetch a generation that needs to be resolved */
g = cs_pop( cs );
if( g != NULL )
{
/* Fetch the object from the storage */
imdb_fetch( &conf->stable_db, "obj", (void*)&obj );
/* Perform some conflict resolution */
mc = res_func( g );
/* Fetch the function pointer */
method = method_list_find( m_list, mc->method_name );
/* Perform the method on the object */
method( obj, mc->params, mc->num_param );
/* Put the object back */
imdb_store( &conf->stable_db, "obj", obj, sizeof( obj_t ) );
printf( "Conflict resolved generation %d\n", g->num );
gen_free( g );
free( obj );
}
}
return NULL;
}
/************************************************************
general_newton_raphson():
-- performs Newton-Rapshon method on an arbitrary system.
-- inspired in part by Num. Rec.'s routine newt();
*****************************************************************/
static int general_newton_raphson( FTYPE x[], int n, int do_line_search,
void (*funcd) (FTYPE [], FTYPE [], FTYPE [], FTYPE [][NEWT_DIM], FTYPE *, FTYPE *, int),
FTYPE (*res_func) (FTYPE []) )
{
FTYPE f, f_old, df, df_old, dx[NEWT_DIM], dx_old[NEWT_DIM], x_old[NEWT_DIM], resid[NEWT_DIM], jac[NEWT_DIM][NEWT_DIM];
FTYPE errx, errx_old, errx_oldest, x_orig[NEWT_DIM];
int n_iter, id, jd, i_extra, doing_extra;
FTYPE randtmp, tmp;
FTYPE dW,dvsq,vsq_old,vsq,W,W_old;
FTYPE resid_norm, resid_check, grad_check;
FTYPE res_func_val, res_func_old, res_func_new;
FTYPE dn[NEWT_DIM], del_f[NEWT_DIM];
static void my_lnsrch(int, FTYPE [], FTYPE, FTYPE [], FTYPE [], FTYPE [], FTYPE *,
FTYPE, FTYPE, int *, FTYPE (*res_func) (FTYPE []));
static void bin_newt_data( FTYPE errx, int niters, int conv_type, int print_now ) ;
int keep_iterating, i_increase, retval2,retval = 0;
const int ltrace = 0;
const int ltrace2 = 1;
retval = 0;
errx = 1. ;
errx_old = 2.;
df = df_old = f = f_old = 1.;
i_extra = doing_extra = 0;
for( id = 0; id < n ; id++) x_old[id] = x_orig[id] = x[id] ;
vsq_old = vsq = W = W_old = 0.;
n_iter = 0;
/* Start the Newton-Raphson iterations : */
keep_iterating = 1;
while( keep_iterating ) {
nstroke++;
lntries++;
(*funcd) (x, dx, resid, jac, &f, &df, n); /* returns with new dx, f, df */
#if(!OPTIMIZED)
/* Check for bad untrapped divergences : */
if( (finite(f)==0) || (finite(df)==0) ) {
if( debugfail >= 2 ) {
dualfprintf(fail_file,"general_newton_raphson(): nan encountered in f or df!! \n");
dualfprintf(fail_file,"gnr nan(): f, df, x0, dx0 = %21.15g %21.15g %21.15g %21.15g \n", f,df,x[0],dx[0]);
}
return(1);
}
#endif
#if(!OPTIMIZED)
/* Randomly rescale Newton step to break out of iteration cycles: */
if( ((n_iter+1) % CYCLE_BREAK_PERIOD) == 0 ) {
randtmp = ( (1.*rand())/(1.*RAND_MAX) );
for( id = 0; id < n ; id++) dx[id] *= randtmp;
// for( id = 0; id < n ; id++) dx[id] *= ( (1.*rand())/(1.*RAND_MAX) );
}
#endif
/* Save old values before calculating the new: */
errx_oldest = errx_old;
errx_old = errx;
lerrx=errx;
errx = 0.;
f_old = f;
for( id = 0; id < n ; id++) {
x_old[id] = x[id] ;
}
/* Make the newton step: */
if( do_line_search == 1 ) {
/* Compare the residual to its initial value */
if( n_iter == 0 ) {
resid_norm = 0.0e0;
for( id = 0; id < n ; id++) {
resid_norm += fabs(resid[id]);
}
resid_norm /= 1.0*n ;
if( resid_norm == 0.0 ) resid_norm = 1.0;
}
for( id = 0; id < n ; id++) {
tmp = 0.;
for( jd = 0; jd < n ; jd++) {
tmp += jac[jd][id] * resid[jd];
}
del_f[id] = tmp;
}
for( id = 0; id < n ; id++) {
dn[id] = dx[id];
}
my_lnsrch(n, x_old-1, f_old, del_f-1, dn-1, x-1, &f, TOL_LINE_STEP, SCALEMAX, &retval, res_func);
/* dx is needed for errx calculation below: */
for( id = 0; id < n ; id++) {
dx[id] = x[id] - x_old[id];
}
#if(!OPTIMIZED)
if( ltrace ) {
res_func_val = res_func(x);
res_func_old = res_func(x_old);
dualfprintf(fail_file,"gnr(): f_old, f, res_func_old, res_func_val = %21.15g %21.15g %21.15g %21.15g \n",
f_old, f, res_func_old, res_func_val );
dualfprintf(fail_file,"gnr(): x_old = ");
for( id = 0; id < n ; id++) {
dualfprintf(fail_file," %21.15g ",x_old[id]);
}
dualfprintf(fail_file,"\n ");
dualfprintf(fail_file,"gnr(): x = ");
for( id = 0; id < n ; id++) {
dualfprintf(fail_file," %21.15g ",x[id]);
}
dualfprintf(fail_file,"\n ");
dualfprintf(fail_file,"gnr(): dn = ");
for( id = 0; id < n ; id++) {
dualfprintf(fail_file," %21.15g ",dn[id]);
}
dualfprintf(fail_file,"\n ");
dualfprintf(fail_file,"gnr(): del_f = ");
for( id = 0; id < n ; id++) {
dualfprintf(fail_file," %21.15g ",del_f[id]);
}
dualfprintf(fail_file,"\n ");
}
#endif
/* Check to see if line search problem is because the residual vector is already small enough */
if( retval == 1 ) {
resid_check = 0.0e0;
for( id = 0; id < n ; id++) {
resid_check += fabs(resid[id]);
}
resid_check /= 1.0*n;
if( resid_check <= resid_norm * NEWT_FUNC_TOL ) {
retval = 0;
}
if( ltrace && retval ) {
dualfprintf(fail_file,"general_newton_raphson(): retval, resid_check = %4i %21.15g \n",retval, resid_check);
}
}
/* If initial Newton step is bad, then try again without line searching: */
if( (retval == 2) && (USE_LINE_SEARCH == do_line_search) ) {
#if(!OPTIMIZED)
if( ltrace ) {
dualfprintf(fail_file,"gnr(): bad first step: retval, f_old, f = %4i %21.15g %21.15g \n",retval,f_old,f);
dualfprintf(fail_file,"gnr: doing recursive call, retval, errx = %4i %21.15g \n", retval, errx );
}
#endif
retval = general_newton_raphson( x_orig, n, ((do_line_search+1)%2), funcd, res_func );
for( id = 0; id < n ; id++) x[id] = x_orig[id] ;
return( retval );
}
/* Check to see if it is trapped in a local minimum, i.e. gradient is too small */
if( retval == 1 ) {
grad_check = 0.0e0;
for( id = 0; id < n ; id++) {
resid_check = (x[id] == 0.) ? 1.0 : fabs(x[id]) ;
grad_check += del_f[id] * resid_check ;
}
resid_check = (f == 0.) ? 1.0 : fabs(f) ;
grad_check /= resid_check;
/* Then we've most likely found a solution: */
if( grad_check > GRADMIN ) {
retval = -1;
}
else if( ltrace ) {
dualfprintf(fail_file,"general_newton_raphson(): retval, grad_check = %4i %21.15g \n",retval, grad_check);
}
}
}
else {
/* don't use line search : */
for( id = 0; id < n ; id++) {
x[id] += dx[id] ;
}
} /* End of "to do line search or not to do line search..." */
/****************************************/
/* Calculate the convergence criterion */
/****************************************/
/* For the new criterion, always look at error in "W" : */
// METHOD specific:
#if( NEWCONVERGE == 1 )
errx = (x[0]==0.) ? fabs(dx[0]) : fabs(dx[0]/x[0]);
/* For the old criterion, look at errors in each indep. variable(s) (except for 5D) : */
#else
for( id = 0; id < n ; id++) {
errx += (x[id]==0.) ? fabs(dx[id]) : fabs(dx[id]/x[id]);
}
errx /= 1.*n;
#endif
/****************************************/
/* Make sure that the new x[] is physical : */
/****************************************/
// METHOD specific:
validate_x( x, x_old ) ;
/****************************************/
/* Check to see if we're in a infinite loop with error function: */
/****************************************/
#if( CHECK_FOR_STALL )
if( ( (errx_old == errx) || (errx_oldest == errx) ) && (errx <= MIN_NEWT_TOL) ) errx = -errx;
#endif
/****************************************/
/* If there's a problem with line search, then stop iterating: */
/****************************************/
if( (retval == 1) || (retval == -1) ) errx = -errx;
#if(!OPTIMIZED)
if( ltrace ) {
dualfprintf(fail_file," general_newton_raphson(): niter,f_old,f,errx_old,errx = %4i %21.15g %21.15g %21.15g %21.15g\n",
n_iter,f_old,f,errx_old,errx );
dualfprintf(fail_file,"gnr(): x_old = ");
for( id = 0; id < n ; id++) {
dualfprintf(fail_file," %21.15g ",x_old[id]);
}
dualfprintf(fail_file,"\n ");
dualfprintf(fail_file,"gnr(): x = ");
for( id = 0; id < n ; id++) {
dualfprintf(fail_file," %21.15g ",x[id]);
}
dualfprintf(fail_file,"\n ");
dualfprintf(fail_file,"gnr(): dx = ");
for( id = 0; id < n ; id++) {
dualfprintf(fail_file," %21.15g ",dx[id]);
}
dualfprintf(fail_file,"\n ");
}
#endif
/****************************************/
/* Prepare for the next iteration, set the "old" variables: */
/****************************************/
for( id = 0; id < n ; id++) dx_old[id] = dx[id] ;
f_old = f;
df_old = df;
/****************************************/
/* If we've reached the tolerance level, then just do a few extra iterations before stopping */
/****************************************/
if( (fabs(errx) <= NEWT_TOL) && (doing_extra == 0) && (EXTRA_NEWT_ITER > 0) ) {
doing_extra = 1;
}
if( doing_extra == 1 ) i_extra++ ;
if( ((fabs(errx) <= NEWT_TOL)&&(doing_extra == 0)) || (i_extra > EXTRA_NEWT_ITER) || (n_iter >= (MAX_NEWT_ITER-1)) ) {
keep_iterating = 0;
}
n_iter++;
#if(CRAZYDEBUG)
if(icurr==0 && jcurr==31 && nstep==9 && steppart==2){
dualfprintf(fail_file,"n_iter=%d errx=%21.15g %21.15g\n",n_iter,errx,MIN_NEWT_TOL);
}
#endif
} // END of while(keep_iterating)
/* Check for bad untrapped divergences : */
if( (finite(f)==0) || (finite(df)==0) || (finite(x[0])==0) || (finite(x[1])==0)) {
#if(!OPTIMIZED)
if( debugfail >= 2 ) {
dualfprintf(fail_file,"general_newton_raphson(): nan encountered in f or df!! \n");
dualfprintf(fail_file,"gnr nan(): f, df, x0, dx0 = %21.15g %21.15g %21.15g %21.15g \n", f,df,x[0],dx[0]);
}
#endif
return(1);
}
if( fabs(errx) > MIN_NEWT_TOL){
if( (do_line_search != USE_LINE_SEARCH) || (USE_LINE_SEARCH < 0) ) {
#if(DOHISTOGRAM)
bin_newt_data( errx, n_iter, 0, 0 );
#endif
#if(!OPTIMIZED)
if(ltrace2) {
dualfprintf(fail_file," totalcount = %d 0 %d %d %d %21.15g \n",n_iter,retval,do_line_search,i_extra,errx);
}
if(ltrace) {
dualfprintf(fail_file,"general_newton_raphson(): did not find solution \n");
if( retval == -1 ) {
dualfprintf(fail_file,"general_newton_raphson(): lnsrch converged: x = ");
for( id = 0; id < n ; id++) dualfprintf(fail_file," %21.15g ",x[id]);
dualfprintf(fail_file,"\n");
dualfprintf(fail_file,"general_newton_raphson(): lnsrch converged: x_old = ");
for( id = 0; id < n ; id++) dualfprintf(fail_file," %21.15g ",x_old[id]);
dualfprintf(fail_file,"\n");
}
}
// dualfprintf(fail_file,"gnr retval2 = %4i \n", 1);
#endif
return(1);
}
else {
/* If bad return and we tried line searching, try it without before giving up: */
// dualfprintf(fail_file,"gnr: doing recursive call, do_line_search, retval, errx = %4i %4i %21.15g \n", do_line_search, retval, errx );
//
retval2 = general_newton_raphson( x_orig, n, ((do_line_search+1)%2), funcd, res_func );
for( id = 0; id < n ; id++) x[id] = x_orig[id] ;
// dualfprintf(fail_file,"gnr retval3 = %4i \n", retval2);
return( retval2 );
}
}
if( (fabs(errx) <= MIN_NEWT_TOL) && (fabs(errx) > NEWT_TOL) ){
#if(DOHISTOGRAM)
bin_newt_data( errx, n_iter, 1, 0 );
#endif
#if(!OPTIMIZED)
if(ltrace2) {
dualfprintf(fail_file," totalcount = %d 1 %d %d %d %21.15g \n",n_iter,retval,do_line_search,i_extra,errx);
}
if(ltrace) {
dualfprintf(fail_file,"general_newton_raphson(): found minimal solution \n");
}
// dualfprintf(fail_file,"gnr retval4 = %4i \n", 0);
#endif
return(0);
}
if( fabs(errx) <= NEWT_TOL ){
#if(DOHISTOGRAM)
bin_newt_data( errx, n_iter, 2, 0 );
#endif
#if(!OPTIMIZED)
if(ltrace2) {
dualfprintf(fail_file," totalcount = %d 2 %d %d %d %21.15g \n",n_iter,retval,do_line_search,i_extra, errx);
}
// dualfprintf(fail_file,"gnr retval5 = %4i \n", 0);
#endif
return(0);
}
#if(!OPTIMIZED)
dualfprintf(fail_file,"gnr retval6 = %4i \n", 0);
#endif
return(0);
}
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);
}
