int main()
{
int pitch=10;
IplImage *matherImg = 0;
IplImage* sampleImg =0;
if ((sampleImg = cvLoadImage("../cvtest/rotate degree1.00.jpg",0))==NULL)printf("load sample erro\n");
printf("src height:%d,width:%d,src channel:%d,depth:%d\n",sampleImg->height,sampleImg->width,sampleImg->nChannels,sampleImg->depth);
if((matherImg = cvLoadImage("../cvtest/geZiBu.jpg",0))==NULL)printf("load erro\n");
printf("src height:%d,width:%d,src channel:%d,depth:%d\n",matherImg->height,sampleImg->width,matherImg->nChannels,matherImg->depth);
IplImage* lineImg = cvCloneImage(matherImg);
formatImg(lineImg,pitch);
IMG_SHOW(lineImg,lineImg);
int hdrWidth = 30;
int hdrHeight = 11;//3,5,7...
int gradSlideTol = 2;
int targetLineNum = 200;
int gradStep =3;
initParms();
initMatherHeaderSects(matherImg,hdrWidth,hdrHeight,gradStep);
cal_mather_header(matherImg,getMatherSecByIdx(0),hdrWidth,hdrHeight);
int rst = find_sample_hdr_pos(sampleImg,targetLineNum,hdrWidth,hdrHeight,gradSlideTol);
printf("targetline:%d,find line:%d\n",targetLineNum,rst);
llf_printf("the end of print\n");
formatImg(sampleImg,pitch);
IMG_SHOW(sampleImg,sampleImg);
cvWaitKey();
freeMatherHeadSecs();
return 0;
}
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_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_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);
}
/*----------------------------------------------------------------------
Parameters:
Description:
----------------------------------------------------------------------*/
static int
get_option(int argc, char *argv[])
{
int n,nargs = 0 ;
char *option ;
float f ;
option = argv[1] + 1 ; /* past '-' */
if (!stricmp(option, "-help")||!stricmp(option, "-usage"))
{
print_help() ;
}
else if (!stricmp(option, "-version"))
{
print_version() ;
}
else if (!stricmp(option, "median"))
{
which_norm = NORM_MEDIAN ;
printf("using median normalization\n") ;
}
else if (!stricmp(option, "vnum") || !stricmp(option, "distances"))
{
parms.nbhd_size = atof(argv[2]) ;
parms.max_nbrs = atof(argv[3]) ;
nargs = 2 ;
fprintf(stderr, "nbr size = %d, max neighbors = %d\n",
parms.nbhd_size, parms.max_nbrs) ;
}
else if (!stricmp(option, "nonorm"))
{
which_norm = NORM_NONE ;
printf("disabling normalization\n") ;
}
else if (!stricmp(option, "vsmooth"))
{
parms.var_smoothness = 1 ;
printf("using space/time varying smoothness weighting\n") ;
}
else if (!stricmp(option, "sigma"))
{
if (nsigmas >= MAX_SIGMAS)
{
ErrorExit(ERROR_NOMEMORY, "%s: too many sigmas specified (%d)\n",
Progname, nsigmas) ;
}
sigmas[nsigmas] = atof(argv[2]) ;
nargs = 1 ;
nsigmas++ ;
}
else if (!stricmp(option, "vector"))
{
fprintf(stderr,
"\nMultiframe Mode:\n");
fprintf(stderr,
"Use -addframe option to add extra-fields into average atlas\n");
fprintf(stderr,
"\t-addframe which_field where_in_atlas l_corr l_pcorr\n");
fprintf(stderr,
"\tfield code:\n");
for (n=0 ; n < NUMBER_OF_VECTORIAL_FIELDS ; n++)
fprintf(stderr,
"\t field %d is '%s' (type = %d)\n",
n,ReturnFieldName(n),IsDistanceField(n));
exit(1);
}
else if (!stricmp(option, "annot"))
{
annot_name = argv[2] ;
fprintf(stderr,"zeroing medial wall in %s\n", annot_name) ;
nargs=1;
}
else if (!stricmp(option, "init"))
{
use_initial_registration=1;
fprintf(stderr,"use initial registration\n");
}
else if (!stricmp(option, "addframe"))
{
int which_field,where_in_atlas;
float l_corr,l_pcorr;
if (multiframes==0)
{
/* activate multiframes mode */
initParms();
multiframes = 1;
}
which_field=atoi(argv[2]);
where_in_atlas=atoi(argv[3]);
l_corr=atof(argv[4]);
l_pcorr=atof(argv[5]);
fprintf(stderr,
"adding field %d (%s) with location %d in the atlas\n",
which_field,ReturnFieldName(which_field),where_in_atlas) ;
/* check if this field exist or not */
for (n = 0 ; n < parms.nfields ; n++)
{
if (parms.fields[n].field==which_field)
{
fprintf(stderr,"ERROR: field already exists\n");
exit(1);
}
}
/* adding field into parms */
n=parms.nfields++;
SetFieldLabel(&parms.fields[n],
which_field,
where_in_atlas,
l_corr,
l_pcorr,
0,
which_norm);
nargs = 4 ;
}
/* else if (!stricmp(option, "hippocampus")) */
/* { */
/* if(multiframes==0){ */
/* multiframes = 1 ; */
/* initParms(); */
/* } */
/* where=atoi(argv[2]); */
/* parms.l_corrs[]=atof(argv[3]); */
/* parms.l_pcorrs[]=atof(argv[4]); */
/* parms.frames[]=; */
/* parms. */
/* fprintf(stderr, "using hippocampus distance map\n") ; */
/* nargs=3; */
/* } */
else if (!stricmp(option, "topology"))
{
parms.flags |= IPFLAG_PRESERVE_SPHERICAL_POSITIVE_AREA;
fprintf(stderr, "preserving the topology of positive area triangles\n");
}
else if (!stricmp(option, "vnum") || !stricmp(option, "distances"))
{
parms.nbhd_size = atof(argv[2]) ;
parms.max_nbrs = atof(argv[3]) ;
nargs = 2 ;
fprintf(stderr, "nbr size = %d, max neighbors = %d\n",
parms.nbhd_size, parms.max_nbrs) ;
}
else if (!stricmp(option, "rotate"))
{
dalpha = atof(argv[2]) ;
dbeta = atof(argv[3]) ;
dgamma = atof(argv[4]) ;
fprintf(stderr, "rotating brain by (%2.2f, %2.2f, %2.2f)\n",
dalpha, dbeta, dgamma) ;
nargs = 3 ;
}
else if (!stricmp(option, "reverse"))
{
reverse_flag = 1 ;
fprintf(stderr, "mirror image reversing brain before morphing...\n") ;
}
else if (!stricmp(option, "min_degrees"))
{
min_degrees = atof(argv[2]) ;
fprintf(stderr,
"setting min angle for search to %2.2f degrees\n",
min_degrees) ;
nargs = 1 ;
}
else if (!stricmp(option, "max_degrees"))
{
max_degrees = atof(argv[2]) ;
fprintf(stderr,
"setting max angle for search to %2.2f degrees\n",
max_degrees) ;
nargs = 1 ;
}
else if (!stricmp(option, "nangles"))
{
nangles = atoi(argv[2]) ;
fprintf(stderr, "setting # of angles/search per scale to %d\n", nangles) ;
nargs = 1 ;
}
else if (!stricmp(option, "jacobian"))
{
jacobian_fname = argv[2] ;
nargs = 1 ;
printf("writing out jacobian of mapping to %s\n", jacobian_fname) ;
}
else if (!stricmp(option, "dist"))
{
sscanf(argv[2], "%f", &parms.l_dist) ;
nargs = 1 ;
use_defaults = 0 ;
fprintf(stderr, "l_dist = %2.3f\n", parms.l_dist) ;
}
else if (!stricmp(option, "norot"))
{
fprintf(stderr, "disabling initial rigid alignment...\n") ;
parms.flags |= IP_NO_RIGID_ALIGN ;
}
else if (!stricmp(option, "inflated"))
{
fprintf(stderr, "using inflated surface for initial alignment\n") ;
parms.flags |= IP_USE_INFLATED ;
}
else if (!stricmp(option, "multi_scale"))
{
multi_scale = atoi(argv[2]) ;
fprintf(stderr, "using %d scales for morphing\n", multi_scale) ;
nargs = 1 ;
}
else if (!stricmp(option, "nsurfaces"))
{
parms.nsurfaces = atoi(argv[2]) ;
nargs = 1 ;
fprintf(stderr,
"using %d surfaces/curvatures for alignment\n",
parms.nsurfaces) ;
}
else if (!stricmp(option, "infname"))
{
char fname[STRLEN] ;
inflated_name = argv[2] ;
surface_names[0] = argv[2] ;
nargs = 1 ;
printf("using %s as inflated surface name, "
"and using it for initial alignment\n", inflated_name) ;
sprintf(fname, "%s.H", argv[2]) ;
curvature_names[0] = (char *)calloc(strlen(fname)+1, sizeof(char)) ;
strcpy(curvature_names[0], fname) ;
parms.flags |= IP_USE_INFLATED ;
}
else if (!stricmp(option, "nosulc"))
{
fprintf(stderr, "disabling initial sulc alignment...\n") ;
parms.flags |= IP_NO_SULC ;
}
else if (!stricmp(option, "sulc"))
{
curvature_names[1] = argv[2] ;
fprintf(stderr, "using %s to replace 'sulc' alignment\n",
curvature_names[1]) ;
nargs = 1 ;
MRISsetSulcFileName(argv[2]);
}
else if (!stricmp(option, "surf0"))
{
surface_names[0] = argv[2];
fprintf(stderr, "using %s as input surface 0.\n",
surface_names[0]) ;
nargs = 1 ;
}
else if (!stricmp(option, "surf1"))
{
surface_names[1] = argv[2];
fprintf(stderr, "using %s as input surface 1.\n",
surface_names[1]) ;
nargs = 1 ;
}
else if (!stricmp(option, "surf2"))
{
surface_names[2] = argv[2];
fprintf(stderr, "using %s as input surface 2.\n",
surface_names[2]) ;
nargs = 1 ;
}
else if (!stricmp(option, "curv0"))
{
curvature_names[0] = argv[2];
fprintf(stderr, "using %s as curvature function for surface 0.\n",
curvature_names[0]) ;
nargs = 1 ;
}
else if (!stricmp(option, "curv1"))
{
curvature_names[1] = argv[2];
fprintf(stderr, "using %s as curvature function for surface 1.\n",
curvature_names[1]) ;
nargs = 1 ;
}
else if (!stricmp(option, "curv2"))
{
curvature_names[2] = argv[2];
fprintf(stderr, "using %s as curvature function for surface 2.\n",
curvature_names[2]) ;
nargs = 1 ;
}
else if (!stricmp(option, "lm"))
{
parms.integration_type = INTEGRATE_LINE_MINIMIZE ;
fprintf(stderr, "integrating with line minimization\n") ;
}
else if (!stricmp(option, "search"))
{
parms.integration_type = INTEGRATE_LM_SEARCH ;
fprintf(stderr, "integrating with binary search line minimization\n") ;
}
else if (!stricmp(option, "dt"))
{
parms.dt = atof(argv[2]) ;
parms.base_dt = .2*parms.dt ;
nargs = 1 ;
fprintf(stderr, "momentum with dt = %2.2f\n", parms.dt) ;
}
else if (!stricmp(option, "area"))
{
use_defaults = 0 ;
sscanf(argv[2], "%f", &parms.l_area) ;
nargs = 1 ;
fprintf(stderr, "using l_area = %2.3f\n", parms.l_area) ;
}
else if (!stricmp(option, "parea"))
{
use_defaults = 0 ;
sscanf(argv[2], "%f", &parms.l_parea) ;
nargs = 1 ;
fprintf(stderr, "using l_parea = %2.3f\n", parms.l_parea) ;
}
else if (!stricmp(option, "nlarea"))
{
use_defaults = 0 ;
sscanf(argv[2], "%f", &parms.l_nlarea) ;
nargs = 1 ;
fprintf(stderr, "using l_nlarea = %2.3f\n", parms.l_nlarea) ;
}
else if (!stricmp(option, "spring"))
{
use_defaults = 0 ;
sscanf(argv[2], "%f", &parms.l_spring) ;
nargs = 1 ;
fprintf(stderr, "using l_spring = %2.3f\n", parms.l_spring) ;
}
else if (!stricmp(option, "corr"))
{
use_defaults = 0 ;
sscanf(argv[2], "%f", &parms.l_corr) ;
nargs = 1 ;
fprintf(stderr, "using l_corr = %2.3f\n", parms.l_corr) ;
}
else if (!stricmp(option, "remove_negative"))
{
remove_negative = atoi(argv[2]) ;
nargs = 1 ;
fprintf(stderr, "%sremoving negative triangles with iterative smoothing\n",
remove_negative ? "" : "not ") ;
}
else if (!stricmp(option, "curv"))
{
parms.flags |= IP_USE_CURVATURE ;
fprintf(stderr, "using smoothwm curvature for final alignment\n") ;
}
else if (!stricmp(option, "nocurv"))
{
parms.flags &= ~IP_USE_CURVATURE ;
fprintf(stderr, "NOT using smoothwm curvature for final alignment\n") ;
}
else if (!stricmp(option, "sreg"))
{
starting_reg_fname = argv[2] ;
nargs = 1 ;
fprintf(stderr, "starting registration with coordinates in %s\n",
starting_reg_fname) ;
}
else if (!stricmp(option, "adaptive"))
{
parms.integration_type = INTEGRATE_ADAPTIVE ;
fprintf(stderr, "using adaptive time step integration\n") ;
}
else if (!stricmp(option, "nbrs"))
{
nbrs = atoi(argv[2]) ;
nargs = 1 ;
fprintf(stderr, "using neighborhood size=%d\n", nbrs) ;
}
else if (!stricmp(option, "tol"))
{
if (sscanf(argv[2], "%e", &f) < 1)
ErrorExit(ERROR_BADPARM, "%s: could not scan tol from %s",
Progname, argv[2]) ;
parms.tol = (double)f ;
nargs = 1 ;
fprintf(stderr, "using tol = %2.2e\n", (float)parms.tol) ;
}
else if (!stricmp(option, "error_ratio"))
{
parms.error_ratio = atof(argv[2]) ;
nargs = 1 ;
fprintf(stderr, "error_ratio=%2.3f\n", parms.error_ratio) ;
}
else if (!stricmp(option, "dt_inc"))
{
parms.dt_increase = atof(argv[2]) ;
nargs = 1 ;
fprintf(stderr, "dt_increase=%2.3f\n", parms.dt_increase) ;
}
else if (!stricmp(option, "lap") || !stricmp(option, "lap"))
{
parms.l_lap = atof(argv[2]) ;
nargs = 1 ;
fprintf(stderr, "l_laplacian = %2.3f\n", parms.l_lap) ;
}
else if (!stricmp(option, "vnum"))
{
parms.nbhd_size = atof(argv[2]) ;
parms.max_nbrs = atof(argv[3]) ;
nargs = 2 ;
fprintf(stderr, "nbr size = %d, max neighbors = %d\n",
parms.nbhd_size, parms.max_nbrs) ;
}
else if (!stricmp(option, "dt_dec"))
{
parms.dt_decrease = atof(argv[2]) ;
nargs = 1 ;
fprintf(stderr, "dt_decrease=%2.3f\n", parms.dt_decrease) ;
}
else if (!stricmp(option, "ocorr"))
{
l_ocorr = atof(argv[2]) ;
printf("setting overlay correlation coefficient to %2.1f\n", l_ocorr) ;
nargs = 1 ;
fprintf(stderr, "dt_decrease=%2.3f\n", parms.dt_decrease) ;
}
else if (!stricmp(option, "overlay"))
{
int navgs ;
if (noverlays == 0)
{
atlas_size = 0 ;
}
if (multiframes == 0)
{
initParms() ;
multiframes = 1 ;
}
overlays[noverlays++] = argv[2] ;
navgs = atof(argv[3]) ;
printf("reading overlay from %s and smoothing it %d times\n",
argv[2], navgs) ;
n=parms.nfields++;
SetFieldLabel(&parms.fields[n],
OVERLAY_FRAME,
atlas_size,
l_ocorr,
0.0,
navgs,
which_norm);
SetFieldName(&parms.fields[n], argv[2]) ;
atlas_size++ ;
nargs = 2 ;
}
else if (!stricmp(option, "distance"))
{
int navgs ;
if (noverlays == 0)
{
atlas_size = 0 ;
}
if (multiframes == 0)
{
initParms() ;
multiframes = 1 ;
}
overlays[noverlays++] = argv[2] ;
navgs = atof(argv[3]) ;
printf("reading overlay from %s and smoothing it %d times\n",
argv[2], navgs) ;
n=parms.nfields++;
SetFieldLabel(&parms.fields[n],
DISTANCE_TRANSFORM_FRAME,
atlas_size,
l_ocorr,
0.0,
navgs,
NORM_MAX) ;
SetFieldName(&parms.fields[n], argv[2]) ;
atlas_size++ ;
nargs = 2 ;
}
else if (!stricmp(option, "canon"))
{
canon_name = argv[2] ;
nargs = 1 ;
fprintf(stderr, "using %s for canonical properties...\n", canon_name) ;
}
else if (!stricmp(option, "overlay-dir"))
{
parms.overlay_dir = strcpyalloc(argv[2]) ;
nargs = 1 ;
}
else switch (toupper(*option))
{
case 'M':
parms.integration_type = INTEGRATE_MOMENTUM ;
parms.momentum = atof(argv[2]) ;
nargs = 1 ;
fprintf(stderr, "momentum = %2.2f\n", (float)parms.momentum) ;
break ;
case 'L':
if (nlabels >= MAX_LABELS-1)
ErrorExit(ERROR_NO_MEMORY,
"%s: too many labels specified (%d max)",
Progname, MAX_LABELS) ;
nargs = 3 ;
labels[nlabels] = LabelRead(NULL, argv[2]) ;
if (labels[nlabels] == NULL)
ErrorExit(ERROR_NOFILE,
"%s: could not read label file %s",
Progname, argv[2]) ;
label_gcsa[nlabels] = GCSAread(argv[3]) ;
if (label_gcsa[nlabels] == NULL)
ErrorExit(ERROR_NOFILE,
"%s: could not read GCSA file %s",
Progname, argv[3]) ;
label_names[nlabels] = argv[4] ;
CTABfindName(label_gcsa[nlabels]->ct, argv[4],&label_indices[nlabels]) ;
if (label_indices[nlabels] < 0)
ErrorExit(ERROR_NOFILE,
"%s: could not map name %s to index",
Progname, argv[3]) ;
CTABannotationAtIndex(label_gcsa[nlabels]->ct, label_indices[nlabels],
&label_annots[nlabels]);
nlabels++ ;
gMRISexternalSSE = gcsaSSE ;
break ;
case 'E':
parms.l_external = atof(argv[2]) ;
nargs = 1 ;
printf("setting l_external = %2.1f\n", parms.l_external) ;
break ;
case 'C':
strcpy(curvature_fname, argv[2]) ;
nargs = 1 ;
break ;
case 'A':
sscanf(argv[2], "%d", &parms.n_averages) ;
nargs = 1 ;
fprintf(stderr, "using n_averages = %d\n", parms.n_averages) ;
break ;
case '1':
single_surf = True ;
printf("treating target as a single subject's surface...\n") ;
break ;
case 'S':
scale = atof(argv[2]) ;
fprintf(stderr, "scaling distances by %2.2f\n", scale) ;
nargs = 1 ;
break ;
case 'N':
sscanf(argv[2], "%d", &parms.niterations) ;
nargs = 1 ;
fprintf(stderr, "using niterations = %d\n", parms.niterations) ;
break ;
case 'W':
Gdiag |= DIAG_WRITE ;
sscanf(argv[2], "%d", &parms.write_iterations) ;
nargs = 1 ;
fprintf(stderr,
"using write iterations = %d\n",
parms.write_iterations) ;
break ;
case 'V':
Gdiag_no = atoi(argv[2]) ;
nargs = 1 ;
break ;
case 'O':
orig_name = argv[2] ;
nargs = 1 ;
fprintf(stderr, "using %s for original properties...\n", orig_name) ;
break ;
case 'P':
max_passes = atoi(argv[2]) ;
fprintf(stderr, "limiting unfolding to %d passes\n", max_passes) ;
nargs = 1 ;
break ;
case '?':
case 'H':
case 'U':
print_help() ;
exit(1) ;
break ;
default:
fprintf(stderr, "unknown option %s\n", argv[1]) ;
exit(1) ;
break ;
}
return(nargs) ;
}
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_mebdfi(SEXP y, SEXP yprime, SEXP times, SEXP resfunc, SEXP parms,
SEXP rtol, SEXP atol, SEXP itol, SEXP rho, SEXP Tcrit, SEXP Hini,
SEXP Maxord, SEXP maxIt, SEXP nind, SEXP jacfunc, SEXP initfunc,
SEXP verbose, SEXP Mf, SEXP Mbnd, SEXP Liw, SEXP Lrw,
SEXP nOut, SEXP Rpar, SEXP Ipar, SEXP flist, SEXP Funtype, SEXP Mass)
{
/******************************************************************************/
/****** DECLARATION SECTION ******/
/******************************************************************************/
/* These R-structures will be allocated and returned to R*/
SEXP yout, yout2=NULL, dyout=NULL, ISTATE, RWORK;
int i, j, k, nt, latol, lrtol, lrw, liw, isDll;
int isForcing , Itol, *mbnd, mf, maxord, isOut;
double *xytmp, *xdytmp, *rwork, tin, tout, *Atol, *Rtol, tcrit, hini;
double *delta=NULL, cj;
int idid, *iwork, ires, ierr, funtype;
C_res_func_type *res_func = NULL;
C_jac_func_type *jac_func = NULL;
/******************************************************************************/
/****** STATEMENTS ******/
/******************************************************************************/
/* #### initialisation #### */
init_N_Protect();
n_eq = LENGTH(y);
nt = LENGTH(times);
// mflag = INTEGER(verbose)[0];
nout = INTEGER(nOut)[0];
funtype = INTEGER(Funtype)[0]; /* 1 = res, 2 = func */
ntot = n_eq;
mf = INTEGER(Mf)[0];
maxord = INTEGER(Maxord)[0];
tcrit = REAL(Tcrit)[0];
hini = REAL(Hini)[0];
ierr = 0;
/* function is a dll ?*/
if (inherits(resfunc, "NativeSymbol"))
isDll = 1;
else
isDll = 0;
isOut = 0;
if (isDll == 0 && nout > 0) isOut =1;
else if (isDll == 1 ) ntot = ntot+ nout;
/* initialise output vectors ... */
if (isDll==1) { /* function is a dll */
lrpar = nout + LENGTH(Rpar); /* length of rpar */
lipar = 3 + LENGTH(Ipar); /* length of ipar */
} else { /* function is not a dll */
lipar = 1;
lrpar = 1;
}
out = (double *) R_alloc(lrpar, sizeof(double));
ipar = (int *) R_alloc(lipar, sizeof(int));
if (isDll ==1) {
ipar[0] = nout; /* first 3 elements of ipar are special */
ipar[1] = lrpar;
ipar[2] = lipar;
/* other elements of ipar are set in R-function lsodx via argument *ipar* */
for (j = 0; j < LENGTH(Ipar); j++) ipar[j+3] = INTEGER(Ipar)[j];
/* first nout elements of rpar reserved for output variables
other elements are set in R-function lsodx via argument *rpar* */
for (j = 0; j < nout; j++) out[j] = 0.;
for (j = 0; j < LENGTH(Rpar);j++) out[nout+j] = REAL(Rpar)[j];
} else {
for (j = 0; j < lrpar; j++) out[j] = 0.;
for (j = 0; j < lipar; j++) ipar[j] = 0.;
}
/* copies of all variables that will be changed in the FORTRAN subroutine */
xytmp = (double *) R_alloc(n_eq, sizeof(double));
for (j = 0; j < n_eq; j++) xytmp[j] = REAL(y)[j];
xdytmp = (double *) R_alloc(n_eq, sizeof(double));
for (j = 0; j < n_eq; j++) xdytmp[j] = REAL(yprime)[j];
/* tolerance */
latol = LENGTH(atol);
Atol = (double *) R_alloc((int) latol, sizeof(double));
for (j = 0; j < latol; j++) Atol[j] = REAL(atol)[j];
lrtol = LENGTH(rtol);
Rtol = (double *) R_alloc((int) lrtol, sizeof(double));
for (j = 0; j < lrtol; j++) Rtol[j] = REAL(rtol)[j];
Itol = INTEGER(itol)[0];
/* work arrays */
liw = INTEGER(Liw)[0];
iwork = (int *) R_alloc(liw, sizeof(int));
for (j = 0; j<3; j++) iwork[j] = INTEGER(nind)[j];
for (j = 3; j<liw; j++) iwork[j] = 0;
iwork[13] = INTEGER(maxIt)[0];
lrw = INTEGER(Lrw)[0];
rwork = (double *) R_alloc(lrw, sizeof(double));
for (j = 0; j < lrw; j++) rwork[j] = 0.;
rwork[0] = DBL_EPSILON;
mbnd = (int *) R_alloc(4, sizeof(int));
for (j = 0; j<4; j++) mbnd[j] = INTEGER(Mbnd)[j];
nrowpd = mbnd[3];
/* initialise global variables... */
PROTECT(Rin = NEW_NUMERIC(2)); incr_N_Protect();
PROTECT(Y = allocVector(REALSXP,n_eq)); incr_N_Protect();
PROTECT(YPRIME = allocVector(REALSXP,n_eq)); incr_N_Protect();
PROTECT(yout = allocMatrix(REALSXP,ntot+1,nt)); incr_N_Protect();
if (isOut == 1) {
PROTECT(dyout = allocMatrix(REALSXP,n_eq+1,nt)); incr_N_Protect();
}
/**************************************************************************/
/****** Initialization of Parameters and Forcings (DLL functions) ******/
/**************************************************************************/
initParms(initfunc, parms);
// error("till here");
isForcing = initForcings(flist);
/* pointers to functions passed to the FORTRAN subroutine */
isMass = 0;
if (isDll == 1) { /* DLL address passed to fortran */
if (funtype == 1) {
res_func = (C_res_func_type *) R_ExternalPtrAddrFn_(resfunc);
if(isForcing==1) {
DLL_res_func = (C_res_func_type *) R_ExternalPtrAddrFn_(resfunc);
res_func = (C_res_func_type *) DLL_res_func_forc;
}
} else if (funtype <= 3) {
res_func = DLL_res_ode;
DLL_deriv_func = (C_deriv_func_type *) R_ExternalPtrAddrFn_(resfunc);
if(isForcing==1)
res_func = (C_res_func_type *) DLL_res_func_forc2;
if (funtype == 3) { /* mass matrix */
isMass = 1;
mass = (double *)R_alloc(n_eq * n_eq, sizeof(double));
for (j = 0; j < n_eq * n_eq; j++) mass[j] = REAL(Mass)[j];
dytmp = (double *) R_alloc(n_eq, sizeof(double));
}
} else /* for MASS matrix .... */
error("DLL function type not yet implemented");
delta = (double *) R_alloc(n_eq, sizeof(double));
for (j = 0; j < n_eq; j++) delta[j] = 0.;
} else {
/* interface function between fortran and R passed to Fortran*/
res_func = (C_res_func_type *) C_res_func;
/* needed to communicate with R */
PROTECT(R_res_func = resfunc); incr_N_Protect();
PROTECT(R_envir = rho); incr_N_Protect();
}
if (!isNull(jacfunc))
{
if (inherits(jacfunc,"NativeSymbol"))
jac_func = (C_jac_func_type *) R_ExternalPtrAddrFn_(jacfunc);
else {
jac_func = (C_jac_func_type *) C_jac_func;
PROTECT(R_daejac_func = jacfunc); incr_N_Protect();
}
}
/* #### initial time step #### */
idid = 1;
REAL(yout)[0] = REAL(times)[0];
for (j = 0; j < n_eq; j++)
REAL(yout)[j+1] = REAL(y)[j];
if (nout>0) {
tin = REAL(times)[0];
if (isDll == 1) {
res_func (&tin, xytmp, xdytmp, &cj, delta, &ires, out, ipar) ;
// for (j = 0; j < nout; j++)
// REAL(yout)[n_eq + j + 1] = out[j];
}
else for (j = 0; j < n_eq; j++)
REAL(dyout)[j] = xdytmp[j];
}
/* #### main time loop #### */
for (i = 0; i < nt-1; i++)
{
//
tin = REAL(times)[i];
tout = REAL(times)[i+1];
// Rprintf("idid %i tin %g tout %g xdytmp %g \n", idid, tin, tout, xdytmp[0]);
F77_CALL(mebdfi)(&n_eq, &tin, &hini, xytmp, xdytmp, &tout, &tcrit,
&mf, &idid, &lrw, rwork, &liw, iwork, mbnd, &maxord,
&Itol, Rtol, Atol, out, ipar, jac_func, res_func, &ierr);
// Rprintf(" hini, xytmp %g %g %g %g %g %g\n", hini, xytmp[0], xytmp[1],xytmp[2] ,xytmp[3], xytmp[4] );
// error("here");
if (idid == 1) {
idid = 0;
F77_CALL(mebdfi)(&n_eq, &tin, &hini, xytmp, xdytmp, &tout, &tcrit,
&mf, &idid, &lrw, rwork, &liw, iwork, mbnd, &maxord,
&Itol, Rtol, Atol, out, ipar, jac_func, res_func, &ierr);
}
// Rprintf("idid %i tin %g tout %g tin-tout %g \n", idid, tin, tout, tin-tout);
if (idid == -1) {
warning("the integration failed to pass the error test, even after reducing h by factor 1e10");
} else if (idid == -2) {
warning("the integration failed by repeated error test failures or by a test on rtol/atol. too much accuracy requested");
} else if (idid == -3) {
warning("the integration failed to achieve corrector convergence, even after reducing h by factor 1e10");
} else if (idid == -4) {
warning("illegal values of input parameters - see printed message");
} else if (idid == -5) {
warning("idid was -1 on input, but tout was not beyond t");
} else if (idid == -6) {
warning("maximum number of integration steps exceeded");
} else if (idid == -7) {
warning("stepsize is too small, < sqrt(uround)/100");
} else if (idid == -11) {
warning("insufficient real workspace for the integration");
} else if (idid == -12) {
warning("insufficient integer workspace for the integration");
}
// Rprintf(" i, tin, tout, ntot %i, %g, %g, %i\n", i, tin, tout, ntot);
REAL(yout)[(i+1)*(ntot+1)] = tin;
for (j = 0; j < n_eq; j++)
REAL(yout)[(i+1)*(ntot + 1) + j + 1] = xytmp[j];
if (nout>0) {
if (isDll == 1) {
res_func (&tin, xytmp, xdytmp, &cj, delta, &ires, out, ipar) ;
for (j = 0; j < nout; j++)
REAL(yout)[(i+1)*(ntot + 1) + n_eq + j + 1] = out[j];
}
else for (j = 0; j < n_eq; j++)
REAL(dyout)[(i+1)*(n_eq) + j + 1] = xdytmp[j];
}
/**/
/* #### an error occurred #### */
if (tin < tout) {
if (idid >=0) idid = -10;
warning("Returning early from mebdfi Results are accurate, as far as they go\n");
/* redimension yout */
PROTECT(yout2 = allocMatrix(REALSXP,ntot+1,(i+2)));incr_N_Protect();
for (k = 0; k < i+2; k++)
for (j = 0; j < ntot+1; j++)
REAL(yout2)[k*(ntot+1) + j] = REAL(yout)[k*(ntot+1) + j];
break;
}
} /* end main time loop */
/* error("tillhere");
#### returning output #### */
PROTECT(ISTATE = allocVector(INTSXP, 15));incr_N_Protect();
for (k = 0;k<14;k++) INTEGER(ISTATE)[k+1] = iwork[k];
INTEGER(ISTATE)[0] = idid;
PROTECT(RWORK = allocVector(REALSXP, 1));incr_N_Protect();
REAL(RWORK)[0] = rwork[1];
if (idid >= 0)
{
setAttrib(yout, install("istate"), ISTATE);
setAttrib(yout, install("rstate"), RWORK);
if (isOut ==1) setAttrib(yout, install("dy"), dyout);
}
else
{
setAttrib(yout2, install("istate"), ISTATE);
setAttrib(yout2, install("rstate"), RWORK);
if (isOut ==1) setAttrib(yout2, install("dy"), dyout);
}
//
/* #### termination #### */
unprotect_all();
if (idid >= 0)
return(yout);
else
return(yout2);
}
SEXP call_gambim(SEXP y, SEXP times, SEXP derivfunc, SEXP parms, SEXP rtol,
SEXP atol, SEXP rho, SEXP Tcrit, SEXP jacfunc, SEXP initfunc,
SEXP verbose, SEXP LRW, SEXP rWork, SEXP iWork, SEXP jT,
SEXP nOut, SEXP Nrmas, SEXP masfunc, SEXP ML, SEXP MU, SEXP Hini,
SEXP Rpar, SEXP Ipar, SEXP flist, SEXP Type)
{
/******************************************************************************/
/****** DECLARATION SECTION ******/
/******************************************************************************/
int j, nt, latol, lrtol, imas, mlmas, mumas, type;
int isForcing, runOK;
double *Atol, *Rtol, hini;
int itol, ijac, ml, mu, iout, idid, liw, lrw, sum;
/* pointers to functions passed to FORTRAN */
C_jac_func_type_gb *jac_func_gb = NULL;
C_solout_type *solout = NULL;
C_solout_type_bim *solout_bim = NULL;
C_mas_type *mas_func = NULL;
/******************************************************************************/
/****** STATEMENTS ******/
/******************************************************************************/
/* #### initialisation #### */
init_N_Protect();
type = INTEGER(Type)[0]; /* jacobian type */
ijac = INTEGER(jT)[0]; /* jacobian type */
n_eq = LENGTH(y); /* number of equations */
nt = LENGTH(times); /* number of output times */
maxt = nt;
tt = (double *) R_alloc(nt, sizeof(double));
for (j = 0; j < nt; j++) tt[j] = REAL(times)[j];
// mflag = INTEGER(verbose)[0];
/* is function a dll ?*/
isDll = inherits(derivfunc, "NativeSymbol");
/* initialise output ... */
initOutC(isDll, n_eq, nOut, Rpar, Ipar);
/* copies of variables that will be changed in the FORTRAN subroutine */
xytmp = (double *) R_alloc(n_eq, sizeof(double));
for (j = 0; j < n_eq; j++) xytmp[j] = REAL(y)[j];
ytmp = (double *) R_alloc(n_eq, sizeof(double));
for (j = 0; j < n_eq; j++) ytmp[j] = 0.;
latol = LENGTH(atol);
Atol = (double *) R_alloc((int) latol, sizeof(double));
for (j = 0; j < latol; j++) Atol[j] = REAL(atol)[j];
lrtol = LENGTH(rtol);
Rtol = (double *) R_alloc((int) lrtol, sizeof(double));
for (j = 0; j < lrtol; j++) Rtol[j] = REAL(rtol)[j];
/* tolerance specifications */
if (latol == 1 ) itol = 0;
else itol = 1;
/* mass matrix */
imas = INTEGER(Nrmas)[0];
mlmas = INTEGER(Nrmas)[1];
mumas = INTEGER(Nrmas)[2];
/* work vectors */
if (type == 1) {
liw = 27;
lrw = 21;
} else { // if (type == 2)
liw = n_eq + 40;
lrw = INTEGER(LRW)[0];
}
iwork = (int *) R_alloc(liw, sizeof(int));
for (j=0; j<LENGTH(iWork); j++) iwork[j] = INTEGER(iWork)[j];
for (j=LENGTH(iWork); j<liw; j++) iwork[j] = 0;
rwork = (double *) R_alloc(lrw, sizeof(double));
for (j=0; j<length(rWork); j++) rwork[j] = REAL(rWork)[j];
for (j=length(rWork); j<lrw; j++) rwork[j] = 0.;
ml = INTEGER(ML)[0];
mu = INTEGER(MU)[0];
hini = REAL(Hini)[0];
/* initialise global R-variables... */
initglobals (nt);
/* Initialization of Parameters, Forcings (DLL) */
initParms(initfunc, parms);
isForcing = initForcings(flist);
if (nout > 0 ) {
xdytmp= (double *) R_alloc(n_eq, sizeof(double));
for (j = 0; j < n_eq; j++) xdytmp[j] = 0.;
}
/* pointers to functions deriv_func, jac_func, jac_vec, root_func, passed to FORTRAN */
if (isDll) { /* DLL address passed to FORTRAN */
deriv_func = (C_deriv_func_type *) R_ExternalPtrAddrFn_(derivfunc);
/* overruling deriv_func if forcing */
if (isForcing) {
DLL_deriv_func = deriv_func;
deriv_func = (C_deriv_func_type *) C_deriv_func_forc_gb;
}
} else {
/* interface function between FORTRAN and C/R passed to FORTRAN */
deriv_func = (C_deriv_func_type *) C_deriv_func_gb;
/* needed to communicate with R */
R_deriv_func = derivfunc;
R_envir = rho;
}
if (!isNull(jacfunc)) {
if (isDll)
jac_func_gb = (C_jac_func_type_gb *) R_ExternalPtrAddrFn_(jacfunc);
else {
R_jac_func = jacfunc;
jac_func_gb= C_jac_func_gb;
}
}
if (!isNull(masfunc)) {
R_mas_func = masfunc;
mas_func= C_mas_func;
}
solout = C_solout_gam;
solout_bim = C_solout_bim;
iout = 1; /* solout used */
idid = 0;
/* #### integration #### */
it = 0;
tin = REAL(times)[0];
tout = REAL(times)[nt-1];
saveOut (tin, xytmp); /* save initial condition */
it = it +1;
if (type == 1)
F77_CALL(gamd) ( &n_eq, deriv_func, &tin, xytmp, &tout, &hini,
Rtol, Atol, &itol, jac_func_gb, &ijac, &ml, &mu,
mas_func, &imas, &mlmas, &mumas, solout, &iout,
rwork, &lrw, iwork, &liw, out, ipar, &idid);
else if (type == 2)
F77_CALL(bimd) ( &n_eq, deriv_func, &tin, &tout, xytmp, &hini,
Rtol, Atol, &itol, jac_func_gb, &ijac, &ml, &mu,
mas_func, &imas, &mlmas, &mumas, solout_bim, &iout,
rwork, &lrw, iwork, &liw, out, ipar, &idid);
if (idid == -1)
warning("input is not consistent");
else if (idid == -2)
warning("larger maxsteps needed");
else if (idid == -3)
warning("step size becomes too small");
else if (idid == -4)
warning("matrix is repeatedly singular");
/* #### an error occurred #### */
if(it <= nt-1) saveOut (tin, xytmp); /* save final condition */
if (idid < 0 ) {
it = it-1;
returnearly (1);
}
/* #### returning output #### */
/* feval */
PROTECT(RWORK = allocVector(REALSXP, 3)); incr_N_Protect();
REAL(RWORK)[0] = hini;
REAL(RWORK)[1] = hini;
REAL(RWORK)[2] = tin;
PROTECT(ISTATE = allocVector(INTSXP, 6)); incr_N_Protect();
INTEGER(ISTATE)[0] = idid;
/* nsteps */
sum = 0;
runOK = 0;
if (type == 1) {
for (j = 11; j < 23; j++) sum = sum + iwork[j];
INTEGER(ISTATE)[1] = sum;
/* feval */
INTEGER(ISTATE)[2] = iwork[9];
/* jacobian eval */
INTEGER(ISTATE)[3] = iwork[10];
/* LU decomp */
INTEGER(ISTATE)[4] = iwork[23];
/* number rejected steps */
sum = 0;
for (j = 11; j < 15; j++) sum = sum + iwork[j];
INTEGER(ISTATE)[5] = INTEGER(ISTATE)[1]- sum;
if(idid > 0) runOK = 1;
} else {
for (j = 20; j < 25; j++) sum = sum + iwork[j];
INTEGER(ISTATE)[1] = sum;
/* feval */
INTEGER(ISTATE)[2] = iwork[11];
/* jacobian eval */
INTEGER(ISTATE)[3] = iwork[12];
/* LU decomp */
INTEGER(ISTATE)[4] = iwork[13];
/* number rejected steps */
sum = 0;
for (j = 25; j < 29; j++) sum = sum + iwork[j];
INTEGER(ISTATE)[5] = INTEGER(ISTATE)[1]- sum;
if(idid >= 0) runOK = 1;
}
if (runOK) {
setAttrib(YOUT, install("istate"), ISTATE);
setAttrib(YOUT, install("rstate"), RWORK);
}
else {
setAttrib(YOUT2, install("istate"), ISTATE);
setAttrib(YOUT2, install("rstate"), RWORK);
}
/* #### termination #### */
unprotect_all();
if (runOK)
return(YOUT);
else
return(YOUT2);
}