void FIDA_SETVIN(char key_name[], realtype *vval, int *ier)
{
N_Vector Vec;
*ier = 0;
if (!strncmp(key_name,"ID_VEC",6)) {
Vec = NULL;
Vec = N_VCloneEmpty(F2C_IDA_vec);
if (Vec == NULL) {
*ier = -1;
return;
}
N_VSetArrayPointer(vval, Vec);
IDASetId(IDA_idamem, Vec);
N_VDestroy(Vec);
} else if (!strncmp(key_name,"CONSTR_VEC",10)) {
Vec = NULL;
Vec = N_VCloneEmpty(F2C_IDA_vec);
if (Vec == NULL) {
*ier = -1;
return;
}
N_VSetArrayPointer(vval, Vec);
IDASetConstraints(IDA_idamem, Vec);
N_VDestroy(Vec);
} else {
*ier = -99;
printf("FIDASETVIN: Unrecognized key.\n\n");
}
}
/*-----------------------------------------------------------------
cvDlsDenseDQJac
-----------------------------------------------------------------
This routine generates a dense difference quotient approximation
to the Jacobian of f(t,y). It assumes that a dense SUNMatrix is
stored column-wise, and that elements within each column are
contiguous. The address of the jth column of J is obtained via
the accessor function SUNDenseMatrix_Column, and this pointer
is associated with an N_Vector using the N_VSetArrayPointer
function. Finally, the actual computation of the jth column of
the Jacobian is done with a call to N_VLinearSum.
-----------------------------------------------------------------*/
int cvDlsDenseDQJac(realtype t, N_Vector y, N_Vector fy,
SUNMatrix Jac, CVodeMem cv_mem, N_Vector tmp1)
{
realtype fnorm, minInc, inc, inc_inv, yjsaved, srur;
realtype *y_data, *ewt_data;
N_Vector ftemp, jthCol;
sunindextype j, N;
int retval = 0;
CVDlsMem cvdls_mem;
/* access DlsMem interface structure */
cvdls_mem = (CVDlsMem) cv_mem->cv_lmem;
/* access matrix dimension */
N = SUNDenseMatrix_Rows(Jac);
/* Rename work vector for readibility */
ftemp = tmp1;
/* Create an empty vector for matrix column calculations */
jthCol = N_VCloneEmpty(tmp1);
/* Obtain pointers to the data for ewt, y */
ewt_data = N_VGetArrayPointer(cv_mem->cv_ewt);
y_data = N_VGetArrayPointer(y);
/* Set minimum increment based on uround and norm of f */
srur = SUNRsqrt(cv_mem->cv_uround);
fnorm = N_VWrmsNorm(fy, cv_mem->cv_ewt);
minInc = (fnorm != ZERO) ?
(MIN_INC_MULT * SUNRabs(cv_mem->cv_h) * cv_mem->cv_uround * N * fnorm) : ONE;
for (j = 0; j < N; j++) {
/* Generate the jth col of J(tn,y) */
N_VSetArrayPointer(SUNDenseMatrix_Column(Jac,j), jthCol);
yjsaved = y_data[j];
inc = SUNMAX(srur*SUNRabs(yjsaved), minInc/ewt_data[j]);
y_data[j] += inc;
retval = cv_mem->cv_f(t, y, ftemp, cv_mem->cv_user_data);
cvdls_mem->nfeDQ++;
if (retval != 0) break;
y_data[j] = yjsaved;
inc_inv = ONE/inc;
N_VLinearSum(inc_inv, ftemp, -inc_inv, fy, jthCol);
/* DENSE_COL(Jac,j) = N_VGetArrayPointer(jthCol); /\*UNNECESSARY?? *\/ */
}
/* Destroy jthCol vector */
N_VSetArrayPointer(NULL, jthCol); /* SHOULDN'T BE NEEDED */
N_VDestroy(jthCol);
return(retval);
}
/* Fortran interface routine to set residual tolerance
scalar/array; functions as an all-in-one interface to the C
routines ARKodeResStolerance and ARKodeResVtolerance;
see farkode.h for further details */
void FARK_SETRESTOLERANCE(int *itol, realtype *atol, int *ier) {
N_Vector Vatol;
realtype abstol;
*ier = 0;
/* Set tolerance, based on itol argument */
abstol=1.e-9;
switch (*itol) {
case 1:
if (*atol > 0.0) abstol = *atol;
*ier = ARKodeResStolerance(ARK_arkodemem, abstol);
break;
case 2:
Vatol = NULL;
Vatol = N_VCloneEmpty(F2C_ARKODE_vec);
if (Vatol == NULL) {
*ier = -1;
return;
}
N_VSetArrayPointer(atol, Vatol);
if (N_VMin(Vatol) <= 0.0) N_VConst(abstol, Vatol);
*ier = ARKodeResVtolerance(ARK_arkodemem, Vatol);
N_VDestroy(Vatol);
break;
}
return;
}
static void KIM_Solve(int nlhs, mxArray *plhs[], int nrhs, const mxArray *prhs[])
{
double *y0, *ys, *fs;
N_Vector yscale, fscale;
int buflen, status, strategy;
char *bufval;
if ( kim_Kdata == NULL) return ;
/* Exract y0 and load initial guess in y */
y0 = mxGetPr(prhs[0]);
PutData(y, y0, N);
/* Extract strategy */
buflen = mxGetM(prhs[1]) * mxGetN(prhs[1]) + 1;
bufval = mxCalloc(buflen, sizeof(char));
status = mxGetString(prhs[1], bufval, buflen);
if(!strcmp(bufval,"None")) strategy = KIN_NONE;
if(!strcmp(bufval,"LineSearch")) strategy = KIN_LINESEARCH;
/* Extract yscale */
ys = mxGetPr(prhs[2]);
yscale = N_VCloneEmpty(y);
N_VSetArrayPointer(ys, yscale);
/* Extract fscale */
fs = mxGetPr(prhs[3]);
fscale = N_VCloneEmpty(y);
N_VSetArrayPointer(fs, fscale);
/* call KINSol() */
status = KINSol(kin_mem, y, strategy, yscale, fscale);
/* KINSOL return flag */
plhs[0] = mxCreateScalarDouble((double)status);
/* Solution vector */
plhs[1] = mxCreateDoubleMatrix(N,1,mxREAL);
GetData(y, mxGetPr(plhs[1]), N);
/* Free temporary N_Vectors */
N_VDestroy(yscale);
N_VDestroy(fscale);
return;
}
void FIDA_REINIT(realtype *t0, realtype *yy0, realtype *yp0,
int *iatol, realtype *rtol, realtype *atol,
int *ier)
{
N_Vector Vatol;
*ier = 0;
/* Initialize all pointers to NULL */
Vatol = NULL;
/* Attach user's yy0 to F2C_IDA_vec */
N_VSetArrayPointer(yy0, F2C_IDA_vec);
/* Attach user's yp0 to F2C_IDA_ypvec */
N_VSetArrayPointer(yp0, F2C_IDA_ypvec);
/* Call IDAReInit */
*ier = IDAReInit(IDA_idamem, *t0, F2C_IDA_vec, F2C_IDA_ypvec);
/* Reset data pointers */
N_VSetArrayPointer(NULL, F2C_IDA_vec);
N_VSetArrayPointer(NULL, F2C_IDA_ypvec);
/* On failure, exit */
if (*ier != IDA_SUCCESS) {
*ier = -1;
return;
}
/* Set tolerances */
switch (*iatol) {
case 1:
*ier = IDASStolerances(IDA_idamem, *rtol, *atol);
break;
case 2:
Vatol = NULL;
Vatol= N_VCloneEmpty(F2C_IDA_vec);
if (Vatol == NULL) {
*ier = -1;
return;
}
N_VSetArrayPointer(atol, Vatol);
*ier = IDASVtolerances(IDA_idamem, *rtol, Vatol);
N_VDestroy(Vatol);
break;
}
/* On failure, exit */
if (*ier != IDA_SUCCESS) {
*ier = -1;
return;
}
return;
}
void FCV_REINIT(realtype *t0, realtype *y0,
int *iatol, realtype *rtol, realtype *atol,
int *ier)
{
N_Vector Vatol;
*ier = 0;
/* Initialize all pointers to NULL */
Vatol = NULL;
/* Set data in F2C_CVODE_vec to y0 */
N_VSetArrayPointer(y0, F2C_CVODE_vec);
/* Call CVReInit */
*ier = CVodeReInit(CV_cvodemem, *t0, F2C_CVODE_vec);
/* Reset data pointers */
N_VSetArrayPointer(NULL, F2C_CVODE_vec);
/* On failure, exit */
if (*ier != CV_SUCCESS) {
*ier = -1;
return;
}
/* Set tolerances */
switch (*iatol) {
case 1:
*ier = CVodeSStolerances(CV_cvodemem, *rtol, *atol);
break;
case 2:
Vatol = NULL;
Vatol = N_VCloneEmpty(F2C_CVODE_vec);
if (Vatol == NULL) {
*ier = -1;
return;
}
N_VSetArrayPointer(atol, Vatol);
*ier = CVodeSVtolerances(CV_cvodemem, *rtol, Vatol);
N_VDestroy(Vatol);
break;
}
/* On failure, exit */
if (*ier != CV_SUCCESS) {
*ier = -1;
return;
}
return;
}
void FKIN_SETVIN(char key_name[], realtype *vval, int *ier, int key_len)
{
N_Vector Vec;
if (!strncmp(key_name,"CONSTR_VEC", (size_t)key_len)) {
Vec = NULL;
Vec = N_VCloneEmpty(F2C_KINSOL_vec);
if (Vec == NULL) {
*ier = -1;
return;
}
N_VSetArrayPointer(vval, Vec);
KINSetConstraints(KIN_kinmem, Vec);
N_VDestroy(Vec);
} else {
*ier = -99;
printf("FKINSETVIN: Unrecognized key.\n\n");
}
}
N_Vector *N_VCloneEmptyVectorArray(int count, N_Vector w)
{
N_Vector *vs = NULL;
int j;
if (count <= 0) return(NULL);
vs = (N_Vector *) malloc(count * sizeof(N_Vector));
if(vs == NULL) return(NULL);
for (j = 0; j < count; j++) {
vs[j] = N_VCloneEmpty(w);
if (vs[j] == NULL) {
N_VDestroyVectorArray(vs, j-1);
return(NULL);
}
}
return(vs);
}
void FIDA_TOLREINIT(int *iatol, realtype *rtol, realtype *atol, int *ier)
{
N_Vector Vatol=NULL;
*ier = 0;
if (*iatol == 1) {
*ier = IDASStolerances(IDA_idamem, *rtol, *atol);
} else {
Vatol = NULL;
Vatol = N_VCloneEmpty(F2C_IDA_vec);
if (Vatol == NULL) {
*ier = -1;
return;
}
N_VSetArrayPointer(atol, Vatol);
*ier = IDASVtolerances(IDA_idamem, *rtol, Vatol);
N_VDestroy(Vatol);
}
return;
}
void FCV_SETVIN(char key_name[], realtype *vval, int *ier)
{
N_Vector Vec;
*ier = 0;
if (!strncmp(key_name,"CONSTR_VEC",10)) {
Vec = NULL;
Vec = N_VCloneEmpty(F2C_CVODE_vec);
if (Vec == NULL) {
*ier = -1;
return;
}
N_VSetArrayPointer(vval, Vec);
CVodeSetConstraints(CV_cvodemem, Vec);
N_VDestroy(Vec);
}
else {
*ier = -99;
fprintf(stderr, "FCVSETVIN: Unrecognized key. \n\n");
}
}
/* Fortran interface routine to re-initialize ARKode memory
structure for a problem with a new size but similar time
scale; functions as an all-in-one interface to the C
routines ARKodeResize (and potentially ARKodeSVtolerances);
see farkode.h for further details */
void FARK_RESIZE(realtype *t0, realtype *y0, realtype *hscale,
int *itol, realtype *rtol, realtype *atol, int *ier) {
*ier = 0;
/* Set data in F2C_ARKODE_vec to y0 */
N_VSetArrayPointer(y0, F2C_ARKODE_vec);
/* Call ARKodeResize (currently does not allow Fortran
user-supplied vector resize function) */
*ier = ARKodeResize(ARK_arkodemem, F2C_ARKODE_vec, *hscale,
*t0, NULL, NULL);
/* Reset data pointer */
N_VSetArrayPointer(NULL, F2C_ARKODE_vec);
/* On failure, exit */
if (*ier != ARK_SUCCESS) {
*ier = -1;
return;
}
/* Set tolerances, based on itol argument */
if (*itol) {
N_Vector Vatol = NULL;
Vatol = N_VCloneEmpty(F2C_ARKODE_vec);
if (Vatol == NULL) {
*ier = -1;
return;
}
N_VSetArrayPointer(atol, Vatol);
*ier = ARKodeSVtolerances(ARK_arkodemem, *rtol, Vatol);
N_VDestroy(Vatol);
}
return;
}
void FIDA_MALLOC(realtype *t0, realtype *yy0, realtype *yp0,
int *iatol, realtype *rtol, realtype *atol,
long int *iout, realtype *rout,
long int *ipar, realtype *rpar,
int *ier)
{
N_Vector Vatol;
FIDAUserData IDA_userdata;
*ier = 0;
/* Check for required vector operations */
if ((F2C_IDA_vec->ops->nvgetarraypointer == NULL) ||
(F2C_IDA_vec->ops->nvsetarraypointer == NULL)) {
*ier = -1;
printf("A required vector operation is not implemented.\n\n");
return;
}
/* Initialize all pointers to NULL */
IDA_idamem = NULL;
Vatol = NULL;
F2C_IDA_ypvec = F2C_IDA_ewtvec = NULL;
/* Create IDA object */
IDA_idamem = IDACreate();
if (IDA_idamem == NULL) {
*ier = -1;
return;
}
/* Set and attach user data */
IDA_userdata = NULL;
IDA_userdata = (FIDAUserData) malloc(sizeof *IDA_userdata);
if (IDA_userdata == NULL) {
*ier = -1;
return;
}
IDA_userdata->rpar = rpar;
IDA_userdata->ipar = ipar;
*ier = IDASetUserData(IDA_idamem, IDA_userdata);
if(*ier != IDA_SUCCESS) {
free(IDA_userdata); IDA_userdata = NULL;
*ier = -1;
return;
}
/* Attach user's yy0 to F2C_IDA_vec */
N_VSetArrayPointer(yy0, F2C_IDA_vec);
/* Create F2C_IDA_ypvec and attach user's yp0 to it */
F2C_IDA_ypvec = NULL;
F2C_IDA_ypvec = N_VCloneEmpty(F2C_IDA_vec);
if (F2C_IDA_ypvec == NULL) {
free(IDA_userdata); IDA_userdata = NULL;
*ier = -1;
}
N_VSetArrayPointer(yp0, F2C_IDA_ypvec);
/* Call IDAInit */
*ier = IDAInit(IDA_idamem, FIDAresfn, *t0, F2C_IDA_vec, F2C_IDA_ypvec);
/* Reset data pointers */
N_VSetArrayPointer(NULL, F2C_IDA_vec);
N_VSetArrayPointer(NULL, F2C_IDA_ypvec);
/* On failure, clean-up and exit */
if (*ier != IDA_SUCCESS) {
N_VDestroy(F2C_IDA_ypvec);
free(IDA_userdata); IDA_userdata = NULL;
*ier = -1;
return;
}
/* Set tolerances */
switch (*iatol) {
case 1:
*ier = IDASStolerances(IDA_idamem, *rtol, *atol);
break;
case 2:
Vatol = NULL;
Vatol= N_VCloneEmpty(F2C_IDA_vec);
if (Vatol == NULL) {
free(IDA_userdata); IDA_userdata = NULL;
*ier = -1;
return;
}
N_VSetArrayPointer(atol, Vatol);
*ier = IDASVtolerances(IDA_idamem, *rtol, Vatol);
N_VDestroy(Vatol);
break;
}
/* On failure, clean-up and exit */
if (*ier != IDA_SUCCESS) {
free(IDA_userdata); IDA_userdata = NULL;
*ier = -1;
return;
}
/* Grab optional output arrays and store them in global variables */
IDA_iout = iout;
IDA_rout = rout;
/* Store the unit roundoff in rout for user access */
IDA_rout[5] = UNIT_ROUNDOFF;
/* Set F2C_IDA_ewtvec on NULL */
F2C_IDA_ewtvec = NULL;
return;
}
void FCV_MALLOC(realtype *t0, realtype *y0,
int *meth, int *iatol,
realtype *rtol, realtype *atol,
long int *iout, realtype *rout,
long int *ipar, realtype *rpar,
int *ier)
{
int lmm;
N_Vector Vatol;
FCVUserData CV_userdata;
*ier = 0;
/* Check for required vector operations */
if(F2C_CVODE_vec->ops->nvgetarraypointer == NULL ||
F2C_CVODE_vec->ops->nvsetarraypointer == NULL) {
*ier = -1;
fprintf(stderr, "A required vector operation is not implemented.\n\n");
return;
}
/* Initialize all pointers to NULL */
CV_cvodemem = NULL;
Vatol = NULL;
FCVNullNonlinSol();
/* initialize global constants to disable each option */
CV_nrtfn = 0;
CV_ls = -1;
/* Create CVODE object */
lmm = (*meth == 1) ? CV_ADAMS : CV_BDF;
CV_cvodemem = CVodeCreate(lmm);
if (CV_cvodemem == NULL) {
*ier = -1;
return;
}
/* Set and attach user data */
CV_userdata = NULL;
CV_userdata = (FCVUserData) malloc(sizeof *CV_userdata);
if (CV_userdata == NULL) {
*ier = -1;
return;
}
CV_userdata->rpar = rpar;
CV_userdata->ipar = ipar;
*ier = CVodeSetUserData(CV_cvodemem, CV_userdata);
if(*ier != CV_SUCCESS) {
free(CV_userdata); CV_userdata = NULL;
*ier = -1;
return;
}
/* Set data in F2C_CVODE_vec to y0 */
N_VSetArrayPointer(y0, F2C_CVODE_vec);
/* Call CVodeInit */
*ier = CVodeInit(CV_cvodemem, FCVf, *t0, F2C_CVODE_vec);
/* Reset data pointers */
N_VSetArrayPointer(NULL, F2C_CVODE_vec);
/* On failure, exit */
if(*ier != CV_SUCCESS) {
free(CV_userdata); CV_userdata = NULL;
*ier = -1;
return;
}
/* Set tolerances */
switch (*iatol) {
case 1:
*ier = CVodeSStolerances(CV_cvodemem, *rtol, *atol);
break;
case 2:
Vatol = NULL;
Vatol = N_VCloneEmpty(F2C_CVODE_vec);
if (Vatol == NULL) {
free(CV_userdata); CV_userdata = NULL;
*ier = -1;
return;
}
N_VSetArrayPointer(atol, Vatol);
*ier = CVodeSVtolerances(CV_cvodemem, *rtol, Vatol);
N_VDestroy(Vatol);
break;
}
/* On failure, exit */
if(*ier != CV_SUCCESS) {
free(CV_userdata); CV_userdata = NULL;
*ier = -1;
return;
}
/* Grab optional output arrays and store them in global variables */
CV_iout = iout;
CV_rout = rout;
/* Store the unit roundoff in rout for user access */
CV_rout[5] = UNIT_ROUNDOFF;
return;
}
void FKIN_SOL(realtype *uu, int *globalstrategy,
realtype *uscale , realtype *fscale, int *ier)
{
N_Vector uuvec, uscalevec, fscalevec;
*ier = 0;
uuvec = uscalevec = fscalevec = NULL;
uuvec = F2C_KINSOL_vec;
N_VSetArrayPointer(uu, uuvec);
uscalevec = NULL;
uscalevec = N_VCloneEmpty(F2C_KINSOL_vec);
if (uscalevec == NULL) {
*ier = -4; /* KIN_MEM_FAIL */
return;
}
N_VSetArrayPointer(uscale, uscalevec);
fscalevec = NULL;
fscalevec = N_VCloneEmpty(F2C_KINSOL_vec);
if (fscalevec == NULL) {
N_VDestroy(uscalevec);
*ier = -4; /* KIN_MEM_FAIL */
return;
}
N_VSetArrayPointer(fscale, fscalevec);
/* Call main solver function */
*ier = KINSol(KIN_kinmem, uuvec, *globalstrategy, uscalevec, fscalevec);
N_VSetArrayPointer(NULL, uuvec);
N_VSetArrayPointer(NULL, uscalevec);
N_VDestroy(uscalevec);
N_VSetArrayPointer(NULL, fscalevec);
N_VDestroy(fscalevec);
/* load optional outputs into iout[] and rout[] */
KINGetWorkSpace(KIN_kinmem, &KIN_iout[0], &KIN_iout[1]); /* LENRW & LENIW */
KINGetNumNonlinSolvIters(KIN_kinmem, &KIN_iout[2]); /* NNI */
KINGetNumFuncEvals(KIN_kinmem, &KIN_iout[3]); /* NFE */
KINGetNumBetaCondFails(KIN_kinmem, &KIN_iout[4]); /* NBCF */
KINGetNumBacktrackOps(KIN_kinmem, &KIN_iout[5]); /* NBCKTRK */
KINGetFuncNorm(KIN_kinmem, &KIN_rout[0]); /* FNORM */
KINGetStepLength(KIN_kinmem, &KIN_rout[1]); /* SSTEP */
switch(KIN_ls) {
case KIN_LS_DENSE:
case KIN_LS_BAND:
case KIN_LS_LAPACKDENSE:
case KIN_LS_LAPACKBAND:
KINDlsGetWorkSpace(KIN_kinmem, &KIN_iout[6], &KIN_iout[7]); /* LRW & LIW */
KINDlsGetLastFlag(KIN_kinmem, (int *) &KIN_iout[8]); /* LSTF */
KINDlsGetNumFuncEvals(KIN_kinmem, &KIN_iout[9]); /* NFE */
KINDlsGetNumJacEvals(KIN_kinmem, &KIN_iout[10]); /* NJE */
case KIN_LS_SPTFQMR:
case KIN_LS_SPBCG:
case KIN_LS_SPGMR:
KINSpilsGetWorkSpace(KIN_kinmem, &KIN_iout[6], &KIN_iout[7]); /* LRW & LIW */
KINSpilsGetLastFlag(KIN_kinmem, (int *) &KIN_iout[8]); /* LSTF */
KINSpilsGetNumFuncEvals(KIN_kinmem, &KIN_iout[9]); /* NFE */
KINSpilsGetNumJtimesEvals(KIN_kinmem, &KIN_iout[10]); /* NJE */
KINSpilsGetNumPrecEvals(KIN_kinmem, &KIN_iout[11]); /* NPE */
KINSpilsGetNumPrecSolves(KIN_kinmem, &KIN_iout[12]); /* NPS */
KINSpilsGetNumLinIters(KIN_kinmem, &KIN_iout[13]); /* NLI */
KINSpilsGetNumConvFails(KIN_kinmem, &KIN_iout[14]); /* NCFL */
break;
}
return;
}
/* Fortran interface routine to re-initialize ARKode memory
structure; functions as an all-in-one interface to the C
routines ARKodeReInit and ARKodeSStolerances (or
ARKodeSVtolerances); see farkode.h for further details */
void FARK_REINIT(realtype *t0, realtype *y0, int *imex, int *iatol,
realtype *rtol, realtype *atol, int *ier) {
N_Vector Vatol;
realtype reltol, abstol;
*ier = 0;
/* Initialize all pointers to NULL */
Vatol = NULL;
/* Set data in F2C_ARKODE_vec to y0 */
N_VSetArrayPointer(y0, F2C_ARKODE_vec);
/* Call ARKodeReInit based on imex argument */
switch (*imex) {
case 0: /* purely implicit */
*ier = ARKodeReInit(ARK_arkodemem, NULL, FARKfi,
*t0, F2C_ARKODE_vec);
break;
case 1: /* purely explicit */
*ier = ARKodeReInit(ARK_arkodemem, FARKfe, NULL,
*t0, F2C_ARKODE_vec);
break;
case 2: /* imex */
*ier = ARKodeReInit(ARK_arkodemem, FARKfe, FARKfi,
*t0, F2C_ARKODE_vec);
break;
}
/* Reset data pointers */
N_VSetArrayPointer(NULL, F2C_ARKODE_vec);
/* On failure, exit */
if (*ier != ARK_SUCCESS) {
*ier = -1;
return;
}
/* Set tolerances */
reltol=1.e-4;
abstol=1.e-9;
if (*rtol > 0.0) reltol = *rtol;
switch (*iatol) {
case 1:
if (*atol > 0.0) abstol = *atol;
*ier = ARKodeSStolerances(ARK_arkodemem, reltol, abstol);
break;
case 2:
Vatol = N_VCloneEmpty(F2C_ARKODE_vec);
if (Vatol == NULL) {
*ier = -1;
return;
}
N_VSetArrayPointer(atol, Vatol);
if (N_VMin(Vatol) <= 0.0) N_VConst(abstol, Vatol);
*ier = ARKodeSVtolerances(ARK_arkodemem, reltol, Vatol);
N_VDestroy(Vatol);
break;
}
/* On failure, exit */
if (*ier != ARK_SUCCESS) {
*ier = -1;
return;
}
return;
}
static void KIM_Malloc(int nlhs, mxArray *plhs[], int nrhs, const mxArray *prhs[])
{
int status;
mxArray *mx_in[3], *mx_out[2];
int mxiter, msbset, msbsetsub, etachoice, mxnbcf;
double eta, egamma, ealpha, mxnewtstep, relfunc, fnormtol, scsteptol;
booleantype verbose, noInitSetup, noMinEps;
double *constraints;
N_Vector NVconstraints;
int ptype;
int mudq, mldq, mupper, mlower;
int maxl, maxrs;
double dqrely;
/*
* -----------------------------
* Find out the vector type and
* then pass it to the vector
* library.
* -----------------------------
*/
/* Send vec_type and mx_comm */
InitVectors();
/*
* -----------------------------
* Extract stuff from arguments:
* - SYS function
* - problem dimension
* - solver options
* - user data
* -----------------------------
*/
/* Matlab user-provided function */
mxDestroyArray(mx_SYSfct);
mx_SYSfct = mxDuplicateArray(prhs[0]);
/* problem dimension */
N = (int) mxGetScalar(prhs[1]);
/* Solver Options -- optional argument */
status = get_SolverOptions(prhs[2],
&verbose,
&mxiter, &msbset, &msbsetsub, &etachoice, &mxnbcf,
&eta, &egamma, &ealpha, &mxnewtstep,
&relfunc, &fnormtol, &scsteptol,
&constraints,
&noInitSetup, &noMinEps);
/* User data -- optional argument */
mxDestroyArray(mx_data);
mx_data = mxDuplicateArray(prhs[3]);
/*
* -----------------------------------------------------
* Set solution vector (used as a template to KINMAlloc)
* -----------------------------------------------------
*/
y = NewVector(N);
/*
* ----------------------------------------
* Create kinsol object and allocate memory
* ----------------------------------------
*/
kin_mem = KINCreate();
/* attach error handler function */
status = KINSetErrHandlerFn(kin_mem, mtlb_KINErrHandler, NULL);
if (verbose) {
status = KINSetPrintLevel(kin_mem,3);
/* attach info handler function */
status = KINSetInfoHandlerFn(kin_mem, mtlb_KINInfoHandler, NULL);
/* initialize the output window */
mx_in[0] = mxCreateScalarDouble(0);
mx_in[1] = mxCreateScalarDouble(0); /* ignored */
mx_in[2] = mxCreateScalarDouble(0); /* ignored */
mexCallMATLAB(1,mx_out,3,mx_in,"kim_info");
fig_handle = (int)*mxGetPr(mx_out[0]);
}
/* Call KINMalloc */
status = KINMalloc(kin_mem, mtlb_KINSys, y);
/* Redirect output */
status = KINSetErrFile(kin_mem, stdout);
/* Optional inputs */
status = KINSetNumMaxIters(kin_mem,mxiter);
status = KINSetNoInitSetup(kin_mem,noInitSetup);
status = KINSetNoMinEps(kin_mem,noMinEps);
status = KINSetMaxSetupCalls(kin_mem,msbset);
status = KINSetMaxSubSetupCalls(kin_mem,msbsetsub);
status = KINSetMaxBetaFails(kin_mem,mxnbcf);
status = KINSetEtaForm(kin_mem,etachoice);
status = KINSetEtaConstValue(kin_mem,eta);
status = KINSetEtaParams(kin_mem,egamma,ealpha);
status = KINSetMaxNewtonStep(kin_mem,mxnewtstep);
status = KINSetRelErrFunc(kin_mem,relfunc);
status = KINSetFuncNormTol(kin_mem,fnormtol);
status = KINSetScaledStepTol(kin_mem,scsteptol);
if (constraints != NULL) {
NVconstraints = N_VCloneEmpty(y);
N_VSetArrayPointer(constraints, NVconstraints);
status = KINSetConstraints(kin_mem,NVconstraints);
N_VDestroy(NVconstraints);
}
status = get_LinSolvOptions(prhs[2],
&mupper, &mlower,
&mudq, &mldq, &dqrely,
&ptype, &maxrs, &maxl);
switch (ls) {
case LS_NONE:
mexErrMsgTxt("KINMalloc:: no linear solver specified.");
break;
case LS_DENSE:
status = KINDense(kin_mem, N);
if (!mxIsEmpty(mx_JACfct))
status = KINDenseSetJacFn(kin_mem, mtlb_KINDenseJac, NULL);
break;
case LS_BAND:
status = KINBand(kin_mem, N, mupper, mlower);
if (!mxIsEmpty(mx_JACfct))
status = KINBandSetJacFn(kin_mem, mtlb_KINBandJac, NULL);
break;
case LS_SPGMR:
switch(pm) {
case PM_NONE:
status = KINSpgmr(kin_mem, maxl);
if (!mxIsEmpty(mx_PSOLfct)) {
if (!mxIsEmpty(mx_PSETfct))
status = KINSpilsSetPreconditioner(kin_mem, mtlb_KINSpilsPset, mtlb_KINSpilsPsol, NULL);
else
status = KINSpilsSetPreconditioner(kin_mem, NULL, mtlb_KINSpilsPsol, NULL);
}
break;
case PM_BBDPRE:
if (!mxIsEmpty(mx_GCOMfct))
bbd_data = KINBBDPrecAlloc(kin_mem, N, mudq, mldq, mupper, mlower, dqrely, mtlb_KINGloc, mtlb_KINGcom);
else
bbd_data = KINBBDPrecAlloc(kin_mem, N, mudq, mldq, mupper, mlower, dqrely, mtlb_KINGloc, NULL);
status = KINBBDSpgmr(kin_mem, maxl, bbd_data);
break;
}
status = KINSpilsSetMaxRestarts(kin_mem, maxrs);
if (!mxIsEmpty(mx_JACfct))
status = KINSpilsSetJacTimesVecFn(kin_mem, mtlb_KINSpilsJac, NULL);
break;
case LS_SPBCG:
switch(pm) {
case PM_NONE:
status = KINSpbcg(kin_mem, maxl);
if (!mxIsEmpty(mx_PSOLfct)) {
if (!mxIsEmpty(mx_PSETfct))
status = KINSpilsSetPreconditioner(kin_mem, mtlb_KINSpilsPset, mtlb_KINSpilsPsol, NULL);
else
status = KINSpilsSetPreconditioner(kin_mem, NULL, mtlb_KINSpilsPsol, NULL);
}
break;
case PM_BBDPRE:
if (!mxIsEmpty(mx_GCOMfct))
bbd_data = KINBBDPrecAlloc(kin_mem, N, mudq, mldq, mupper, mlower, dqrely, mtlb_KINGloc, mtlb_KINGcom);
else
bbd_data = KINBBDPrecAlloc(kin_mem, N, mudq, mldq, mupper, mlower, dqrely, mtlb_KINGloc, NULL);
status = KINBBDSpbcg(kin_mem, maxl, bbd_data);
break;
}
if (!mxIsEmpty(mx_JACfct))
status = KINSpilsSetJacTimesVecFn(kin_mem, mtlb_KINSpilsJac, NULL);
break;
case LS_SPTFQMR:
switch(pm) {
case PM_NONE:
status = KINSptfqmr(kin_mem, maxl);
if (!mxIsEmpty(mx_PSOLfct)) {
if (!mxIsEmpty(mx_PSETfct))
status = KINSpilsSetPreconditioner(kin_mem, mtlb_KINSpilsPset, mtlb_KINSpilsPsol, NULL);
else
status = KINSpilsSetPreconditioner(kin_mem, NULL, mtlb_KINSpilsPsol, NULL);
}
break;
case PM_BBDPRE:
if (!mxIsEmpty(mx_GCOMfct))
bbd_data = KINBBDPrecAlloc(kin_mem, N, mudq, mldq, mupper, mlower, dqrely, mtlb_KINGloc, mtlb_KINGcom);
else
bbd_data = KINBBDPrecAlloc(kin_mem, N, mudq, mldq, mupper, mlower, dqrely, mtlb_KINGloc, NULL);
status = KINBBDSptfqmr(kin_mem, maxl, bbd_data);
break;
}
if (!mxIsEmpty(mx_JACfct))
status = KINSpilsSetJacTimesVecFn(kin_mem, mtlb_KINSpilsJac, NULL);
break;
}
return;
}
/* Fortran interface routine to initialize ARKode memory
structure; functions as an all-in-one interface to the C
routines ARKodeCreate, ARKodeSetUserData, ARKodeInit, and
ARKodeSStolerances (or ARKodeSVtolerances); see farkode.h
for further details */
void FARK_MALLOC(realtype *t0, realtype *y0, int *imex,
int *iatol, realtype *rtol, realtype *atol,
long int *iout, realtype *rout,
long int *ipar, realtype *rpar, int *ier) {
N_Vector Vatol;
FARKUserData ARK_userdata;
realtype reltol, abstol;
*ier = 0;
/* Check for required vector operations */
if(F2C_ARKODE_vec->ops->nvgetarraypointer == NULL) {
*ier = -1;
printf("Error: getarraypointer vector operation is not implemented.\n\n");
return;
}
if(F2C_ARKODE_vec->ops->nvsetarraypointer == NULL) {
*ier = -1;
printf("Error: setarraypointer vector operation is not implemented.\n\n");
return;
}
if(F2C_ARKODE_vec->ops->nvcloneempty == NULL) {
*ier = -1;
printf("Error: cloneempty vector operation is not implemented.\n\n");
return;
}
/* Initialize all pointers to NULL */
ARK_arkodemem = NULL;
Vatol = NULL;
/* initialize global constants to zero */
ARK_nrtfn = 0;
ARK_ls = 0;
ARK_mass_ls = 0;
/* Create ARKODE object */
ARK_arkodemem = ARKodeCreate();
if (ARK_arkodemem == NULL) {
*ier = -1;
return;
}
/* Set and attach user data */
ARK_userdata = NULL;
ARK_userdata = (FARKUserData) malloc(sizeof *ARK_userdata);
if (ARK_userdata == NULL) {
*ier = -1;
return;
}
ARK_userdata->rpar = rpar;
ARK_userdata->ipar = ipar;
*ier = ARKodeSetUserData(ARK_arkodemem, ARK_userdata);
if(*ier != ARK_SUCCESS) {
free(ARK_userdata); ARK_userdata = NULL;
*ier = -1;
return;
}
/* Set data in F2C_ARKODE_vec to y0 */
N_VSetArrayPointer(y0, F2C_ARKODE_vec);
/* Call ARKodeInit based on imex argument */
switch (*imex) {
case 0: /* purely implicit */
*ier = ARKodeInit(ARK_arkodemem, NULL, FARKfi,
*t0, F2C_ARKODE_vec);
break;
case 1: /* purely explicit */
*ier = ARKodeInit(ARK_arkodemem, FARKfe, NULL,
*t0, F2C_ARKODE_vec);
break;
case 2: /* imex */
*ier = ARKodeInit(ARK_arkodemem, FARKfe, FARKfi,
*t0, F2C_ARKODE_vec);
break;
}
/* Reset data pointers */
N_VSetArrayPointer(NULL, F2C_ARKODE_vec);
/* On failure, exit */
if(*ier != ARK_SUCCESS) {
free(ARK_userdata);
ARK_userdata = NULL;
*ier = -1;
return;
}
/* Set tolerances -- if <= 0, keep as defaults */
reltol=1.e-4;
abstol=1.e-9;
if (*rtol > 0.0) reltol = *rtol;
switch (*iatol) {
case 1:
if (*atol > 0.0) abstol = *atol;
*ier = ARKodeSStolerances(ARK_arkodemem, reltol, abstol);
break;
case 2:
Vatol = N_VCloneEmpty(F2C_ARKODE_vec);
if (Vatol == NULL) {
free(ARK_userdata);
ARK_userdata = NULL;
*ier = -1;
return;
}
N_VSetArrayPointer(atol, Vatol);
if (N_VMin(Vatol) <= 0.0) N_VConst(abstol, Vatol);
*ier = ARKodeSVtolerances(ARK_arkodemem, reltol, Vatol);
N_VDestroy(Vatol);
break;
}
/* On failure, exit */
if(*ier != ARK_SUCCESS) {
free(ARK_userdata);
ARK_userdata = NULL;
*ier = -1;
return;
}
/* store pointers to optional output arrays in global vars */
ARK_iout = iout;
ARK_rout = rout;
/* Store the unit roundoff in rout for user access */
ARK_rout[5] = UNIT_ROUNDOFF;
return;
}