realtype N_VMin_SensWrapper(N_Vector x)
{
int i;
realtype min, tmp;
min = N_VMin(NV_VEC_SW(x,0));
for (i=1; i < NV_NVECS_SW(x); i++) {
tmp = N_VMin(NV_VEC_SW(x,i));
if (tmp < min) min = tmp;
}
return(min);
}
/* 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;
}
int CVodeSetQuadTolerances(void *cvode_mem, int itolQ,
realtype *reltolQ, void *abstolQ)
{
CVodeMem cv_mem;
booleantype neg_abstol;
if (cvode_mem==NULL) {
fprintf(stderr, MSGCVS_SET_NO_MEM);
return(CV_MEM_NULL);
}
cv_mem = (CVodeMem) cvode_mem;
if ((itolQ != CV_SS) && (itolQ != CV_SV)) {
if(errfp!=NULL) fprintf(errfp, MSGCVS_BAD_ITOLQ);
return(CV_ILL_INPUT);
}
if (reltolQ == NULL) {
if(errfp!=NULL) fprintf(errfp, MSGCVS_RELTOLQ_NULL);
return(CV_ILL_INPUT);
}
if (*reltolQ < ZERO) {
if(errfp!=NULL) fprintf(errfp, MSGCVS_BAD_RELTOLQ);
return(CV_ILL_INPUT);
}
if (abstolQ == NULL) {
if(errfp!=NULL) fprintf(errfp, MSGCVS_ABSTOLQ_NULL);
return(CV_ILL_INPUT);
}
if (itolQ == CV_SS) {
neg_abstol = (*((realtype *)abstolQ) < ZERO);
} else {
neg_abstol = (N_VMin((N_Vector)abstolQ) < ZERO);
}
if (neg_abstol) {
if(errfp!=NULL) fprintf(errfp, MSGCVS_BAD_ABSTOLQ);
return(CV_ILL_INPUT);
}
cv_mem->cv_itolQ = itolQ;
cv_mem->cv_reltolQ = reltolQ;
cv_mem->cv_abstolQ = abstolQ;
return(CV_SUCCESS);
}
int IDACalcIC(void *ida_mem, int icopt, realtype tout1)
{
int ewtsetOK;
int ier, nwt, nh, mxnh, icret, retval=0;
realtype tdist, troundoff, minid, hic, ypnorm;
IDAMem IDA_mem;
/* Check if IDA memory exists */
if(ida_mem == NULL) {
IDAProcessError(NULL, IDA_MEM_NULL, "IDA", "IDACalcIC", MSG_NO_MEM);
return(IDA_MEM_NULL);
}
IDA_mem = (IDAMem) ida_mem;
/* Check if problem was malloc'ed */
if(IDA_mem->ida_MallocDone == FALSE) {
IDAProcessError(IDA_mem, IDA_NO_MALLOC, "IDA", "IDACalcIC", MSG_NO_MALLOC);
return(IDA_NO_MALLOC);
}
/* Check inputs to IDA for correctness and consistency */
ier = IDAInitialSetup(IDA_mem);
if(ier != IDA_SUCCESS) return(IDA_ILL_INPUT);
IDA_mem->ida_SetupDone = TRUE;
/* Check legality of input arguments, and set IDA memory copies. */
if(icopt != IDA_YA_YDP_INIT && icopt != IDA_Y_INIT) {
IDAProcessError(IDA_mem, IDA_ILL_INPUT, "IDA", "IDACalcIC", MSG_IC_BAD_ICOPT);
return(IDA_ILL_INPUT);
}
IDA_mem->ida_icopt = icopt;
if(icopt == IDA_YA_YDP_INIT && (id == NULL)) {
IDAProcessError(IDA_mem, IDA_ILL_INPUT, "IDA", "IDACalcIC", MSG_IC_MISSING_ID);
return(IDA_ILL_INPUT);
}
tdist = SUNRabs(tout1 - tn);
troundoff = TWO*uround*(SUNRabs(tn) + SUNRabs(tout1));
if(tdist < troundoff) {
IDAProcessError(IDA_mem, IDA_ILL_INPUT, "IDA", "IDACalcIC", MSG_IC_TOO_CLOSE);
return(IDA_ILL_INPUT);
}
/* Allocate space and initialize temporary vectors */
yy0 = N_VClone(ee);
yp0 = N_VClone(ee);
t0 = tn;
N_VScale(ONE, phi[0], yy0);
N_VScale(ONE, phi[1], yp0);
/* For use in the IDA_YA_YP_INIT case, set sysindex and tscale. */
IDA_mem->ida_sysindex = 1;
IDA_mem->ida_tscale = tdist;
if(icopt == IDA_YA_YDP_INIT) {
minid = N_VMin(id);
if(minid < ZERO) {
IDAProcessError(IDA_mem, IDA_ILL_INPUT, "IDA", "IDACalcIC", MSG_IC_BAD_ID);
return(IDA_ILL_INPUT);
}
if(minid > HALF) IDA_mem->ida_sysindex = 0;
}
/* Set the test constant in the Newton convergence test */
IDA_mem->ida_epsNewt = epiccon;
/* Initializations:
cjratio = 1 (for use in direct linear solvers);
set nbacktr = 0; */
cjratio = ONE;
nbacktr = 0;
/* Set hic, hh, cj, and mxnh. */
hic = PT001*tdist;
ypnorm = IDAWrmsNorm(IDA_mem, yp0, ewt, suppressalg);
if(ypnorm > HALF/hic) hic = HALF/ypnorm;
if(tout1 < tn) hic = -hic;
hh = hic;
if(icopt == IDA_YA_YDP_INIT) {
cj = ONE/hic;
mxnh = maxnh;
}
else {
cj = ZERO;
mxnh = 1;
}
/* Loop over nwt = number of evaluations of ewt vector. */
for(nwt = 1; nwt <= 2; nwt++) {
/* Loop over nh = number of h values. */
for(nh = 1; nh <= mxnh; nh++) {
/* Call the IC nonlinear solver function. */
retval = IDAnlsIC(IDA_mem);
/* Cut h and loop on recoverable IDA_YA_YDP_INIT failure; else break. */
if(retval == IDA_SUCCESS) break;
ncfn++;
if(retval < 0) break;
if(nh == mxnh) break;
/* If looping to try again, reset yy0 and yp0 if not converging. */
if(retval != IC_SLOW_CONVRG) {
N_VScale(ONE, phi[0], yy0);
N_VScale(ONE, phi[1], yp0);
}
hic *= PT1;
cj = ONE/hic;
hh = hic;
} /* End of nh loop */
/* Break on failure; else reset ewt, save yy0, yp0 in phi, and loop. */
if(retval != IDA_SUCCESS) break;
ewtsetOK = efun(yy0, ewt, edata);
if(ewtsetOK != 0) {
retval = IDA_BAD_EWT;
break;
}
N_VScale(ONE, yy0, phi[0]);
N_VScale(ONE, yp0, phi[1]);
} /* End of nwt loop */
/* Free temporary space */
N_VDestroy(yy0);
N_VDestroy(yp0);
/* Load the optional outputs. */
if(icopt == IDA_YA_YDP_INIT) hused = hic;
/* On any failure, print message and return proper flag. */
if(retval != IDA_SUCCESS) {
icret = IDAICFailFlag(IDA_mem, retval);
return(icret);
}
/* Otherwise return success flag. */
return(IDA_SUCCESS);
}
int IDASetTolerances(void *ida_mem,
int itol, realtype rtol, void *atol)
{
IDAMem IDA_mem;
booleantype neg_atol;
if (ida_mem==NULL) {
IDAProcessError(NULL, IDA_MEM_NULL, "IDA", "IDASetTolerances", MSG_NO_MEM);
return(IDA_MEM_NULL);
}
IDA_mem = (IDAMem) ida_mem;
/* Check if ida_mem was allocated */
if (IDA_mem->ida_MallocDone == FALSE) {
IDAProcessError(IDA_mem, IDA_NO_MALLOC, "IDA", "IDASetTolerances", MSG_NO_MALLOC);
return(IDA_NO_MALLOC);
}
/* Check inputs */
if ((itol != IDA_SS) && (itol != IDA_SV)) {
IDAProcessError(IDA_mem, IDA_ILL_INPUT, "IDA", "IDASetTolerances", MSG_BAD_ITOL);
return(IDA_ILL_INPUT);
}
if (atol == NULL) {
IDAProcessError(IDA_mem, IDA_ILL_INPUT, "IDA", "IDASetTolerances", MSG_ATOL_NULL);
return(IDA_ILL_INPUT);
}
if (rtol < ZERO) {
IDAProcessError(IDA_mem, IDA_ILL_INPUT, "IDA", "IDASetTolerances", MSG_BAD_RTOL);
return(IDA_ILL_INPUT);
}
if (itol == IDA_SS) {
neg_atol = (*((realtype *)atol) < ZERO);
} else {
neg_atol = (N_VMin((N_Vector)atol) < ZERO);
}
if (neg_atol) {
IDAProcessError(IDA_mem, IDA_ILL_INPUT, "IDA", "IDASetTolerances", MSG_BAD_ATOL);
return(IDA_ILL_INPUT);
}
/* Copy tolerances into memory */
if ( (itol != IDA_SV) && (IDA_mem->ida_VatolMallocDone) ) {
N_VDestroy(IDA_mem->ida_Vatol);
lrw -= lrw1;
liw -= liw1;
IDA_mem->ida_VatolMallocDone = FALSE;
}
if ( (itol == IDA_SV) && !(IDA_mem->ida_VatolMallocDone) ) {
IDA_mem->ida_Vatol = NULL;
IDA_mem->ida_Vatol = N_VClone(IDA_mem->ida_ewt);
lrw += lrw1;
liw += liw1;
IDA_mem->ida_VatolMallocDone = TRUE;
}
IDA_mem->ida_itol = itol;
IDA_mem->ida_rtol = rtol;
if (itol == IDA_SS)
IDA_mem->ida_Satol = *((realtype *)atol);
else
N_VScale(ONE, (N_Vector)atol, IDA_mem->ida_Vatol);
IDA_mem->ida_efun = IDAEwtSet;
IDA_mem->ida_edata = ida_mem;
return(IDA_SUCCESS);
}
static int KINSolInit(void *kinmem, integer Neq,
N_Vector uu, SysFn func, int globalstrategy,
N_Vector uscale, N_Vector fscale,
real fnormtol, real scsteptol, N_Vector constraints,
boole optIn, long int iopt[], real ropt[], void *f_data)
{
boole ioptExists, roptExists, ioptBad, roptNeg;
KINMem kin_mem;
FILE *fp;
/* Check for legal input parameters */
kin_mem = (KINMem)kinmem;
fp = kin_mem->kin_msgfp;
if (Neq <= 0)
{
fprintf(fp, MSG_BAD_NEQ, Neq);
return(-1);
}
if (uu == NULL)
{
fprintf(fp, MSG_UU_NULL);
return(-1);
}
if (func == NULL)
{
fprintf(fp, MSG_FUNC_NULL);
return(-1);
}
if ((globalstrategy != INEXACT_NEWTON) && (globalstrategy != LINESEARCH))
{
fprintf(fp, MSG_BAD_GLSTRAT, globalstrategy, INEXACT_NEWTON, LINESEARCH);
return(-1);
}
if (uscale == NULL)
{
fprintf(fp, MSG_BAD_USCALE);
return(-1);
}
if (N_VMin(uscale) <= ZERO)
{
fprintf(fp, MSG_USCALE_NONPOSITIVE);
return(-1);
}
if (fscale == NULL)
{
fprintf(fp, MSG_BAD_FSCALE);
return(-1);
}
if (N_VMin(fscale) <= ZERO)
{
fprintf(fp, MSG_FSCALE_NONPOSITIVE);
return(-1);
}
if (fnormtol < ZERO)
{
fprintf(fp, MSG_BAD_FNORMTOL, fnormtol);
return(-1);
}
if (scsteptol < ZERO)
{
fprintf(fp, MSG_BAD_SCSTEPTOL, scsteptol);
return(-1);
}
if ((optIn != FALSE) && (optIn != TRUE))
{
fprintf(fp, MSG_BAD_OPTIN, optIn, FALSE, TRUE);
return(-1);
}
if ((optIn) && (iopt == NULL) && (ropt == NULL))
{
fprintf(fp, MSG_BAD_OPT);
return(-1);
}
kin_mem->kin_ioptExists = ioptExists = (iopt != NULL);
kin_mem->kin_roptExists = roptExists = (ropt != NULL);
/* Set the constraints flag */
if (constraints == NULL)
constraintsSet = FALSE;
else
constraintsSet = TRUE;
/* All error checking is complete at this point */
/* Copy the input parameters into KINSol state */
kin_mem->kin_uu = uu;
kin_mem->kin_func = func;
kin_mem->kin_f_data = f_data;
kin_mem->kin_globalstrategy = globalstrategy;
kin_mem->kin_fnormtol = fnormtol;
kin_mem->kin_scsteptol = scsteptol;
kin_mem->kin_iopt = iopt;
kin_mem->kin_ropt = ropt;
kin_mem->kin_constraints = constraints;
kin_mem->kin_uscale = uscale;
kin_mem->kin_fscale = fscale;
kin_mem->kin_precondflag = FALSE; /* set to the correct state in KINSpgmr */
/* (additional readability constants are defined below/after KINMalloc) */
/* check the value of the two tolerances */
if (scsteptol <= ZERO)
scsteptol = RPowerR(uround, TWOTHIRDS);
if (fnormtol <= ZERO)
fnormtol = RPowerR(uround, ONETHIRD);
/* Handle the remaining optional inputs */
printfl = PRINTFL_DEFAULT;
mxiter = MXITER_DEFAULT;
if (ioptExists && optIn)
{
if (iopt[PRINTFL] > 0 && iopt[PRINTFL] < 4)
printfl = iopt[PRINTFL];
if (iopt[MXITER] > 0)
mxiter = iopt[MXITER];
ioptBad = (iopt[PRINTFL] < 0 || iopt[MXITER] < 0 || iopt[PRINTFL] > 3);
if (ioptBad)
{
fprintf(fp, MSG_IOPT_OUT);
free(kin_mem);
return(-1);
}
}
if (printfl > 0)
fprintf(fp, "scsteptol used: %12.3g \n", scsteptol);
if (printfl > 0)
fprintf(fp, "fnormtol used: %12.3g \n", fnormtol);
sqrt_relfunc = RSqrt(uround);
/* calculate the default value for mxnewtstep (max Newton step) */
mxnewtstep = THOUSAND * N_VWL2Norm(uu, uscale);
if (mxnewtstep < ONE)
mxnewtstep = ONE;
relu = RELU_DEFAULT;
if (roptExists && optIn)
{
if (ropt[MXNEWTSTEP] > ZERO)
mxnewtstep = ropt[MXNEWTSTEP];
if (ropt[RELFUNC] > ZERO)
sqrt_relfunc = RSqrt(ropt[RELFUNC]);
if (ropt[RELU] > ZERO)
relu = ropt[RELU];
roptNeg = (ropt[MXNEWTSTEP] < ZERO || ropt[RELFUNC] < ZERO || ropt[RELU] < ZERO);
if (roptNeg)
{
fprintf(fp, MSG_ROPT_OUT);
free(kin_mem);
return(-1);
}
}
/* set up the coefficients for the eta calculation */
etaflag = ETACHOICE1; /* default choice */
if (ioptExists && optIn)
{
etaflag = iopt[ETACHOICE];
if (etaflag < ETACHOICE1 || etaflag > ETACONSTANT)
{
fprintf(fp, MSG_BAD_ETACHOICE);
etaflag = ETACHOICE1;
}
}
callForcingTerm = (etaflag != ETACONSTANT);
if (etaflag == ETACHOICE1)
/* this value ALWAYS used for Choice 1 */
ealpha = ONE + HALF * RSqrt(FIVE);
if (etaflag == ETACHOICE2)
{
/* default values: */
ealpha = TWO;
egamma = POINT9;
}
if (etaflag == ETACONSTANT)
eta = POINT1;
/* default value used --constant case */
else
eta = HALF;
/* Initial value for eta set to 0.5 for other than the ETACONSTANT option */
if (roptExists && optIn)
{
if (etaflag == ETACHOICE2)
{
ealpha = ropt[ETAALPHA];
egamma = ropt[ETAGAMMA];
if (ealpha <= ONE || ealpha > TWO)
{
/* alpha value out of range */
if (ealpha != ZERO)
fprintf(fp, MSG_ALPHA_BAD);
ealpha = 2.;
}
if (egamma <= ZERO || egamma > ONE)
{
/* gamma value out of range */
if (egamma != ZERO)
fprintf(fp, MSG_GAMMA_BAD);
egamma = POINT9;
}
}
else if (etaflag == ETACONSTANT)
eta = ropt[ETACONST];
if (eta <= ZERO || eta > ONE)
{
if (eta != ZERO)
fprintf(fp, MSG_ETACONST_BAD);
eta = POINT1;
}
}
/* Initialize all the counters */
nfe = nnilpre = nni = nbcf = nbktrk = 0;
/* Initialize optional output locations in iopt, ropt */
if (ioptExists)
{
iopt[NFE] = iopt[NNI] = 0;
iopt[NBKTRK] = 0;
}
if (roptExists)
{
ropt[FNORM] = ZERO;
ropt[STEPL] = ZERO;
}
/* check the initial guess uu against the constraints, if any, and
* also see if the system func(uu) = 0 is satisfied by the initial guess uu */
if (constraintsSet)
{
if (!KINInitialConstraint(kin_mem))
{
fprintf(fp, MSG_INITIAL_CNSTRNT);
KINFreeVectors(kin_mem);
free(kin_mem);
return(-1);
}
}
if (KINInitialStop(kin_mem))
return(+1);
/* initialize the L2 norms of f for the linear iteration steps */
fnorm = N_VWL2Norm(fval, fscale);
f1norm = HALF * fnorm * fnorm;
if (printfl > 0)
fprintf(fp,
"KINSolInit nni= %4ld fnorm= %26.16g nfe=%6ld \n", nni, fnorm, nfe);
/* Problem has been successfully initialized */
return(0);
}
/* 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;
}
/* 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;
}
int CPodeSetQuadErrCon(void *cpode_mem, booleantype errconQ,
int tol_typeQ, realtype reltolQ, void *abstolQ)
{
CPodeMem cp_mem;
booleantype neg_abstol;
if (cpode_mem==NULL) {
cpProcessError(NULL, CP_MEM_NULL, "CPODES", "CPodeSetQuadErrCon", MSGCP_NO_MEM);
return(CP_MEM_NULL);
}
cp_mem = (CPodeMem) cpode_mem;
cp_mem->cp_errconQ = errconQ;
/* Ckeck if quadrature was initialized? */
if (cp_mem->cp_quadMallocDone == FALSE) {
cpProcessError(cp_mem, CP_NO_QUAD, "CPODES", "CPodeSetQuadErrCon", MSGCP_NO_QUAD);
return(CP_NO_QUAD);
}
/* Check inputs */
if(errconQ == FALSE) {
if (cp_mem->cp_VabstolQMallocDone) {
N_VDestroy(cp_mem->cp_VabstolQ);
lrw -= lrw1Q;
liw -= liw1Q;
cp_mem->cp_VabstolQMallocDone = FALSE;
}
return(CP_SUCCESS);
}
if ((tol_typeQ != CP_SS) && (tol_typeQ != CP_SV)) {
cpProcessError(cp_mem, CP_ILL_INPUT, "CPODES", "CPodeSetQuadErrCon", MSGCP_BAD_ITOLQ);
return(CP_ILL_INPUT);
}
if (abstolQ == NULL) {
cpProcessError(cp_mem, CP_ILL_INPUT, "CPODES", "CPodeSetQuadErrCon", MSGCP_NULL_ABSTOLQ);
return(CP_ILL_INPUT);
}
if (reltolQ < ZERO) {
cpProcessError(cp_mem, CP_ILL_INPUT, "CPODES", "CPodeSetQuadErrCon", MSGCP_BAD_RELTOLQ);
return(CP_ILL_INPUT);
}
if (tol_typeQ == CP_SS)
neg_abstol = (*((realtype *)abstolQ) < ZERO);
else
neg_abstol = (N_VMin((N_Vector)abstolQ) < ZERO);
if (neg_abstol) {
cpProcessError(cp_mem, CP_ILL_INPUT, "CPODES", "CPodeSetQuadErrCon", MSGCP_BAD_ABSTOLQ);
return(CP_ILL_INPUT);
}
/* See if we need to free or allocate memory */
if ( (tol_typeQ != CP_SV) && (cp_mem->cp_VabstolQMallocDone) ) {
N_VDestroy(cp_mem->cp_VabstolQ);
lrw -= lrw1Q;
liw -= liw1Q;
cp_mem->cp_VabstolQMallocDone = FALSE;
}
if ( (tol_typeQ == CP_SV) && !(cp_mem->cp_VabstolQMallocDone) ) {
cp_mem->cp_VabstolQ = N_VClone(cp_mem->cp_tempvQ);
lrw += lrw1Q;
liw += liw1Q;
cp_mem->cp_VabstolQMallocDone = TRUE;
}
/* Copy tolerances into memory */
cp_mem->cp_tol_typeQ = tol_typeQ;
cp_mem->cp_reltolQ = reltolQ;
if (tol_typeQ == CP_SS)
cp_mem->cp_SabstolQ = *((realtype *)abstolQ);
else
N_VScale(ONE, (N_Vector)abstolQ, cp_mem->cp_VabstolQ);
return(CP_SUCCESS);
}
int CPodeSetTolerances(void *cpode_mem,
int tol_type, realtype reltol, void *abstol)
{
CPodeMem cp_mem;
booleantype neg_abstol;
/* Check CPODES memory */
if (cpode_mem==NULL) {
cpProcessError(NULL, CP_MEM_NULL, "CPODES", "CPodeSetTolerances", MSGCP_NO_MEM);
return(CP_MEM_NULL);
}
cp_mem = (CPodeMem) cpode_mem;
/* Check if cpode_mem was allocated */
if (cp_mem->cp_MallocDone == FALSE) {
cpProcessError(cp_mem, CP_NO_MALLOC, "CPODES", "CPodeSetTolerances", MSGCP_NO_MALLOC);
return(CP_NO_MALLOC);
}
/* Check inputs for legal values */
if ( (tol_type != CP_SS) && (tol_type != CP_SV) ) {
cpProcessError(cp_mem, CP_ILL_INPUT, "CPODES", "CPodeSetTolerances", MSGCP_BAD_ITOL);
return(CP_ILL_INPUT);
}
if (abstol == NULL) {
cpProcessError(cp_mem, CP_ILL_INPUT, "CPODES", "CPodeSetTolerances", MSGCP_NULL_ABSTOL);
return(CP_ILL_INPUT);
}
/* Check positivity of tolerances */
if (reltol < ZERO) {
cpProcessError(cp_mem, CP_ILL_INPUT, "CPODES", "CPodeSetTolerances", MSGCP_BAD_RELTOL);
return(CP_ILL_INPUT);
}
if (tol_type == CP_SS)
neg_abstol = (*((realtype *)abstol) < ZERO);
else
neg_abstol = (N_VMin((N_Vector)abstol) < ZERO);
if (neg_abstol) {
cpProcessError(cp_mem, CP_ILL_INPUT, "CPODES", "CPodeSetTolerances", MSGCP_BAD_ABSTOL);
return(CP_ILL_INPUT);
}
/* Copy tolerances into memory */
cp_mem->cp_tol_type = tol_type;
cp_mem->cp_reltol = reltol;
if (tol_type == CP_SS) {
cp_mem->cp_Sabstol = *((realtype *)abstol);
} else {
if ( !(cp_mem->cp_VabstolMallocDone) ) {
cp_mem->cp_Vabstol = N_VClone(cp_mem->cp_ewt);
lrw += lrw1;
liw += liw1;
cp_mem->cp_VabstolMallocDone = TRUE;
}
N_VScale(ONE, (N_Vector)abstol, cp_mem->cp_Vabstol);
}
return(CP_SUCCESS);
}
int IDACalcIC(void *ida_mem, int icopt, realtype tout1)
{
int ewtsetOK;
int ier, nwt, nh, mxnh, icret, retval=0;
int is;
realtype tdist, troundoff, minid, hic, ypnorm;
IDAMem IDA_mem;
booleantype sensi_stg, sensi_sim;
/* Check if IDA memory exists */
if(ida_mem == NULL) {
IDAProcessError(NULL, IDA_MEM_NULL, "IDAS", "IDACalcIC", MSG_NO_MEM);
return(IDA_MEM_NULL);
}
IDA_mem = (IDAMem) ida_mem;
/* Check if problem was malloc'ed */
if(IDA_mem->ida_MallocDone == FALSE) {
IDAProcessError(IDA_mem, IDA_NO_MALLOC, "IDAS", "IDACalcIC", MSG_NO_MALLOC);
return(IDA_NO_MALLOC);
}
/* Check inputs to IDA for correctness and consistency */
ier = IDAInitialSetup(IDA_mem);
if(ier != IDA_SUCCESS) return(IDA_ILL_INPUT);
IDA_mem->ida_SetupDone = TRUE;
/* Check legality of input arguments, and set IDA memory copies. */
if(icopt != IDA_YA_YDP_INIT && icopt != IDA_Y_INIT) {
IDAProcessError(IDA_mem, IDA_ILL_INPUT, "IDAS", "IDACalcIC", MSG_IC_BAD_ICOPT);
return(IDA_ILL_INPUT);
}
IDA_mem->ida_icopt = icopt;
if(icopt == IDA_YA_YDP_INIT && (id == NULL)) {
IDAProcessError(IDA_mem, IDA_ILL_INPUT, "IDAS", "IDACalcIC", MSG_IC_MISSING_ID);
return(IDA_ILL_INPUT);
}
tdist = SUNRabs(tout1 - tn);
troundoff = TWO*uround*(SUNRabs(tn) + SUNRabs(tout1));
if(tdist < troundoff) {
IDAProcessError(IDA_mem, IDA_ILL_INPUT, "IDAS", "IDACalcIC", MSG_IC_TOO_CLOSE);
return(IDA_ILL_INPUT);
}
/* Are we computing sensitivities? */
sensi_stg = (sensi && (ism==IDA_STAGGERED));
sensi_sim = (sensi && (ism==IDA_SIMULTANEOUS));
/* Allocate space and initialize temporary vectors */
yy0 = N_VClone(ee);
yp0 = N_VClone(ee);
t0 = tn;
N_VScale(ONE, phi[0], yy0);
N_VScale(ONE, phi[1], yp0);
if (sensi) {
/* Allocate temporary space required for sensitivity IC: yyS0 and ypS0. */
yyS0 = N_VCloneVectorArray(Ns, ee);
ypS0 = N_VCloneVectorArray(Ns, ee);
/* Initialize sensitivity vector. */
for (is=0; is<Ns; is++) {
N_VScale(ONE, phiS[0][is], yyS0[is]);
N_VScale(ONE, phiS[1][is], ypS0[is]);
}
/* Initialize work space vectors needed for sensitivities. */
savresS = phiS[2];
delnewS = phiS[3];
yyS0new = phiS[4];
ypS0new = eeS;
}
/* For use in the IDA_YA_YP_INIT case, set sysindex and tscale. */
IDA_mem->ida_sysindex = 1;
IDA_mem->ida_tscale = tdist;
if(icopt == IDA_YA_YDP_INIT) {
minid = N_VMin(id);
if(minid < ZERO) {
IDAProcessError(IDA_mem, IDA_ILL_INPUT, "IDAS", "IDACalcIC", MSG_IC_BAD_ID);
return(IDA_ILL_INPUT);
}
if(minid > HALF) IDA_mem->ida_sysindex = 0;
}
/* Set the test constant in the Newton convergence test */
IDA_mem->ida_epsNewt = epiccon;
/* Initializations:
cjratio = 1 (for use in direct linear solvers);
set nbacktr = 0; */
cjratio = ONE;
nbacktr = 0;
/* Set hic, hh, cj, and mxnh. */
hic = PT001*tdist;
ypnorm = IDAWrmsNorm(IDA_mem, yp0, ewt, suppressalg);
if (sensi_sim)
ypnorm = IDASensWrmsNormUpdate(IDA_mem, ypnorm, ypS0, ewtS, FALSE);
if(ypnorm > HALF/hic) hic = HALF/ypnorm;
if(tout1 < tn) hic = -hic;
hh = hic;
if(icopt == IDA_YA_YDP_INIT) {
cj = ONE/hic;
mxnh = maxnh;
}
else {
cj = ZERO;
mxnh = 1;
}
/* Loop over nwt = number of evaluations of ewt vector. */
for(nwt = 1; nwt <= 2; nwt++) {
/* Loop over nh = number of h values. */
for(nh = 1; nh <= mxnh; nh++) {
/* Call the IC nonlinear solver function. */
retval = IDANlsIC(IDA_mem);
/* Cut h and loop on recoverable IDA_YA_YDP_INIT failure; else break. */
if(retval == IDA_SUCCESS) break;
ncfn++;
if(retval < 0) break;
if(nh == mxnh) break;
/* If looping to try again, reset yy0 and yp0 if not converging. */
if(retval != IC_SLOW_CONVRG) {
N_VScale(ONE, phi[0], yy0);
N_VScale(ONE, phi[1], yp0);
if (sensi_sim) {
/* Reset yyS0 and ypS0. */
/* Copy phiS[0] and phiS[1] into yyS0 and ypS0. */
for (is=0; is<Ns; is++) {
N_VScale(ONE, phiS[0][is], yyS0[is]);
N_VScale(ONE, phiS[1][is], ypS0[is]);
}
}
}
hic *= PT1;
cj = ONE/hic;
hh = hic;
} /* End of nh loop */
/* Break on failure */
if(retval != IDA_SUCCESS) break;
/* Reset ewt, save yy0, yp0 in phi, and loop. */
ewtsetOK = efun(yy0, ewt, edata);
if(ewtsetOK != 0) {
retval = IDA_BAD_EWT;
break;
}
N_VScale(ONE, yy0, phi[0]);
N_VScale(ONE, yp0, phi[1]);
if (sensi_sim) {
/* Reevaluate ewtS. */
ewtsetOK = IDASensEwtSet(IDA_mem, yyS0, ewtS);
if(ewtsetOK != 0) {
retval = IDA_BAD_EWT;
break;
}
/* Save yyS0 and ypS0. */
for (is=0; is<Ns; is++) {
N_VScale(ONE, yyS0[is], phiS[0][is]);
N_VScale(ONE, ypS0[is], phiS[1][is]);
}
}
} /* End of nwt loop */
/* Load the optional outputs. */
if(icopt == IDA_YA_YDP_INIT) hused = hic;
/* On any failure, free memory, print error message and return */
if(retval != IDA_SUCCESS) {
N_VDestroy(yy0);
N_VDestroy(yp0);
if(sensi) {
N_VDestroyVectorArray(yyS0, Ns);
N_VDestroyVectorArray(ypS0, Ns);
}
icret = IDAICFailFlag(IDA_mem, retval);
return(icret);
}
/* Unless using the STAGGERED approach for sensitivities, return now */
if (!sensi_stg) {
N_VDestroy(yy0);
N_VDestroy(yp0);
if(sensi) {
N_VDestroyVectorArray(yyS0, Ns);
N_VDestroyVectorArray(ypS0, Ns);
}
return(IDA_SUCCESS);
}
/* Find consistent I.C. for sensitivities using a staggered approach */
/* Evaluate res at converged y, needed for future evaluations of sens. RHS
If res() fails recoverably, treat it as a convergence failure and
attempt the step again */
retval = res(t0, yy0, yp0, delta, user_data);
nre++;
if(retval < 0)
/* res function failed unrecoverably. */
return(IDA_RES_FAIL);
if(retval > 0)
/* res function failed recoverably but no recovery possible. */
return(IDA_FIRST_RES_FAIL);
/* Loop over nwt = number of evaluations of ewt vector. */
for(nwt = 1; nwt <= 2; nwt++) {
/* Loop over nh = number of h values. */
for(nh = 1; nh <= mxnh; nh++) {
retval = IDASensNlsIC(IDA_mem);
if(retval == IDA_SUCCESS) break;
/* Increment the number of the sensitivity related corrector convergence failures. */
ncfnS++;
if(retval < 0) break;
if(nh == mxnh) break;
/* If looping to try again, reset yyS0 and ypS0 if not converging. */
if(retval != IC_SLOW_CONVRG) {
for (is=0; is<Ns; is++) {
N_VScale(ONE, phiS[0][is], yyS0[is]);
N_VScale(ONE, phiS[1][is], ypS0[is]);
}
}
hic *= PT1;
cj = ONE/hic;
hh = hic;
} /* End of nh loop */
/* Break on failure */
if(retval != IDA_SUCCESS) break;
/* Since it was successful, reevaluate ewtS with the new values of yyS0, save
yyS0 and ypS0 in phiS[0] and phiS[1] and loop one more time to check and
maybe correct the new sensitivities IC with respect to the new weights. */
/* Reevaluate ewtS. */
ewtsetOK = IDASensEwtSet(IDA_mem, yyS0, ewtS);
if(ewtsetOK != 0) {
retval = IDA_BAD_EWT;
break;
}
/* Save yyS0 and ypS0. */
for (is=0; is<Ns; is++) {
N_VScale(ONE, yyS0[is], phiS[0][is]);
N_VScale(ONE, ypS0[is], phiS[1][is]);
}
} /* End of nwt loop */
/* Load the optional outputs. */
if(icopt == IDA_YA_YDP_INIT) hused = hic;
/* Free temporary space */
N_VDestroy(yy0);
N_VDestroy(yp0);
/* Here sensi is TRUE, so deallocate sensitivity temporary vectors. */
N_VDestroyVectorArray(yyS0, Ns);
N_VDestroyVectorArray(ypS0, Ns);
/* On any failure, print message and return proper flag. */
if(retval != IDA_SUCCESS) {
icret = IDAICFailFlag(IDA_mem, retval);
return(icret);
}
/* Otherwise return success flag. */
return(IDA_SUCCESS);
}