/*----------------------------------------------------------------
Function : SpfgmrFree
---------------------------------------------------------------*/
void SpfgmrFree(SpfgmrMem mem)
{
int i;
if (mem == NULL) return;
for (i=0; i<=mem->l_max; i++) {
free(mem->Hes[i]);
mem->Hes[i] = NULL;
}
free(mem->Hes); mem->Hes = NULL;
free(mem->givens); mem->givens = NULL;
free(mem->yg); mem->yg = NULL;
N_VDestroyVectorArray(mem->V, mem->l_max+1);
N_VDestroyVectorArray(mem->Z, mem->l_max+1);
N_VDestroy(mem->xcor);
N_VDestroy(mem->vtemp);
free(mem); mem = NULL;
}
void SptfqmrFree(SptfqmrMem mem)
{
if (mem == NULL) return;
N_VDestroy(r_star);
N_VDestroy(q_);
N_VDestroy(d_);
N_VDestroy(v_);
N_VDestroy(p_);
N_VDestroyVectorArray(r_, 2);
N_VDestroy(u_);
N_VDestroy(vtemp1);
N_VDestroy(vtemp2);
N_VDestroy(vtemp3);
free(mem); mem = NULL;
}
N_Vector *N_VCloneVectorArray(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_VClone(w);
if (vs[j] == NULL) {
N_VDestroyVectorArray(vs, j-1);
return(NULL);
}
}
return(vs);
}
void SpgmrFree(SpgmrMem mem)
{
int i, l_max;
realtype **Hes, *givens, *yg;
if (mem == NULL) return;
l_max = mem->l_max;
Hes = mem->Hes;
givens = mem->givens;
yg = mem->yg;
for (i = 0; i <= l_max; i++) {free(Hes[i]); Hes[i] = NULL;}
free(Hes); Hes = NULL;
free(mem->givens); givens = NULL;
free(mem->yg); yg = NULL;
N_VDestroyVectorArray(mem->V, l_max+1);
N_VDestroy(mem->xcor);
N_VDestroy(mem->vtemp);
free(mem); mem = NULL;
}
/*----------------------------------------------------------------
Function : SpfgmrMalloc
---------------------------------------------------------------*/
SpfgmrMem SpfgmrMalloc(int l_max, N_Vector vec_tmpl)
{
SpfgmrMem mem;
N_Vector *V, *Z, xcor, vtemp;
realtype **Hes, *givens, *yg;
int k, i;
/* Check the input parameters. */
if (l_max <= 0) return(NULL);
/* Get memory for the Krylov basis vectors V[0], ..., V[l_max]. */
V = N_VCloneVectorArray(l_max+1, vec_tmpl);
if (V == NULL) return(NULL);
/* Get memory for the preconditioned basis vectors Z[0], ..., Z[l_max]. */
Z = N_VCloneVectorArray(l_max+1, vec_tmpl);
if (Z == NULL) {
N_VDestroyVectorArray(V, l_max+1);
return(NULL);
}
/* Get memory for the Hessenberg matrix Hes. */
Hes = NULL;
Hes = (realtype **) malloc((l_max+1)*sizeof(realtype *));
if (Hes == NULL) {
N_VDestroyVectorArray(V, l_max+1);
N_VDestroyVectorArray(Z, l_max+1);
return(NULL);
}
for (k=0; k<=l_max; k++) {
Hes[k] = NULL;
Hes[k] = (realtype *) malloc(l_max*sizeof(realtype));
if (Hes[k] == NULL) {
for (i=0; i<k; i++) {free(Hes[i]); Hes[i] = NULL;}
free(Hes); Hes = NULL;
N_VDestroyVectorArray(V, l_max+1);
N_VDestroyVectorArray(Z, l_max+1);
return(NULL);
}
}
/* Get memory for Givens rotation components. */
givens = NULL;
givens = (realtype *) malloc(2*l_max*sizeof(realtype));
if (givens == NULL) {
for (i=0; i<=l_max; i++) {free(Hes[i]); Hes[i] = NULL;}
free(Hes); Hes = NULL;
N_VDestroyVectorArray(V, l_max+1);
N_VDestroyVectorArray(Z, l_max+1);
return(NULL);
}
/* Get memory to hold the correction to z_tilde. */
xcor = N_VClone(vec_tmpl);
if (xcor == NULL) {
free(givens); givens = NULL;
for (i=0; i<=l_max; i++) {free(Hes[i]); Hes[i] = NULL;}
free(Hes); Hes = NULL;
N_VDestroyVectorArray(V, l_max+1);
N_VDestroyVectorArray(Z, l_max+1);
return(NULL);
}
/* Get memory to hold SPFGMR y and g vectors. */
yg = NULL;
yg = (realtype *) malloc((l_max+1)*sizeof(realtype));
if (yg == NULL) {
N_VDestroy(xcor);
free(givens); givens = NULL;
for (i=0; i<=l_max; i++) {free(Hes[i]); Hes[i] = NULL;}
free(Hes); Hes = NULL;
N_VDestroyVectorArray(V, l_max+1);
N_VDestroyVectorArray(Z, l_max+1);
return(NULL);
}
/* Get an array to hold a temporary vector. */
vtemp = N_VClone(vec_tmpl);
if (vtemp == NULL) {
free(yg); yg = NULL;
N_VDestroy(xcor);
free(givens); givens = NULL;
for (i=0; i<=l_max; i++) {free(Hes[i]); Hes[i] = NULL;}
free(Hes); Hes = NULL;
N_VDestroyVectorArray(V, l_max+1);
N_VDestroyVectorArray(Z, l_max+1);
return(NULL);
}
/* Get memory for an SpfgmrMemRec containing SPFGMR matrices and vectors. */
mem = NULL;
mem = (SpfgmrMem) malloc(sizeof(SpfgmrMemRec));
if (mem == NULL) {
N_VDestroy(vtemp);
free(yg); yg = NULL;
N_VDestroy(xcor);
free(givens); givens = NULL;
for (i=0; i<=l_max; i++) {free(Hes[i]); Hes[i] = NULL;}
free(Hes); Hes = NULL;
N_VDestroyVectorArray(V, l_max+1);
N_VDestroyVectorArray(Z, l_max+1);
return(NULL);
}
/* Set the fields of mem. */
mem->l_max = l_max;
mem->V = V;
mem->Z = Z;
mem->Hes = Hes;
mem->givens = givens;
mem->xcor = xcor;
mem->yg = yg;
mem->vtemp = vtemp;
/* Return the pointer to SPFGMR memory. */
return(mem);
}
SptfqmrMem SptfqmrMalloc(int l_max, N_Vector vec_tmpl)
{
SptfqmrMem mem;
N_Vector *r;
N_Vector q, d, v, p, u;
N_Vector r_star, vtemp1, vtemp2, vtemp3;
/* Check the input parameters */
if ((l_max <= 0) || (vec_tmpl == NULL)) return(NULL);
/* Allocate space for vectors */
r_star = NULL;
r_star = N_VClone(vec_tmpl);
if (r_star == NULL) return(NULL);
q = NULL;
q = N_VClone(vec_tmpl);
if (q == NULL) {
N_VDestroy(r_star);
return(NULL);
}
d = NULL;
d = N_VClone(vec_tmpl);
if (d == NULL) {
N_VDestroy(r_star);
N_VDestroy(q);
return(NULL);
}
v = NULL;
v = N_VClone(vec_tmpl);
if (v == NULL) {
N_VDestroy(r_star);
N_VDestroy(q);
N_VDestroy(d);
return(NULL);
}
p = NULL;
p = N_VClone(vec_tmpl);
if (p == NULL) {
N_VDestroy(r_star);
N_VDestroy(q);
N_VDestroy(d);
N_VDestroy(v);
return(NULL);
}
r = NULL;
r = N_VCloneVectorArray(2, vec_tmpl);
if (r == NULL) {
N_VDestroy(r_star);
N_VDestroy(q);
N_VDestroy(d);
N_VDestroy(v);
N_VDestroy(p);
return(NULL);
}
u = NULL;
u = N_VClone(vec_tmpl);
if (u == NULL) {
N_VDestroy(r_star);
N_VDestroy(q);
N_VDestroy(d);
N_VDestroy(v);
N_VDestroy(p);
N_VDestroyVectorArray(r, 2);
return(NULL);
}
vtemp1 = NULL;
vtemp1 = N_VClone(vec_tmpl);
if (vtemp1 == NULL) {
N_VDestroy(r_star);
N_VDestroy(q);
N_VDestroy(d);
N_VDestroy(v);
N_VDestroy(p);
N_VDestroyVectorArray(r, 2);
N_VDestroy(u);
return(NULL);
}
vtemp2 = NULL;
vtemp2 = N_VClone(vec_tmpl);
if (vtemp2 == NULL) {
N_VDestroy(r_star);
N_VDestroy(q);
N_VDestroy(d);
N_VDestroy(v);
N_VDestroy(p);
N_VDestroyVectorArray(r, 2);
N_VDestroy(u);
N_VDestroy(vtemp1);
return(NULL);
}
vtemp3 = NULL;
vtemp3 = N_VClone(vec_tmpl);
if (vtemp3 == NULL) {
N_VDestroy(r_star);
N_VDestroy(q);
N_VDestroy(d);
N_VDestroy(v);
N_VDestroy(p);
N_VDestroyVectorArray(r, 2);
N_VDestroy(u);
N_VDestroy(vtemp1);
N_VDestroy(vtemp2);
return(NULL);
}
/* Allocate memory for SptfqmrMemRec */
mem = NULL;
mem = (SptfqmrMem) malloc(sizeof(SptfqmrMemRec));
if (mem == NULL) {
N_VDestroy(r_star);
N_VDestroy(q);
N_VDestroy(d);
N_VDestroy(v);
N_VDestroy(p);
N_VDestroyVectorArray(r, 2);
N_VDestroy(u);
N_VDestroy(vtemp1);
N_VDestroy(vtemp2);
N_VDestroy(vtemp3);
return(NULL);
}
/* Intialize SptfqmrMemRec data structure */
mem->l_max = l_max;
mem->r_star = r_star;
mem->q = q;
mem->d = d;
mem->v = v;
mem->p = p;
mem->r = r;
mem->u = u;
mem->vtemp1 = vtemp1;
mem->vtemp2 = vtemp2;
mem->vtemp3 = vtemp3;
/* Return pointer to SPTFQMR memory block */
return(mem);
}
int main(int argc, char *argv[])
{
SUNMatrix A;
SUNLinearSolver LS;
void *cvode_mem;
UserData data;
realtype t, tout;
N_Vector y, constraints;
int iout, retval;
realtype pbar[NS];
int is;
N_Vector *yS;
booleantype sensi, err_con;
int sensi_meth;
cvode_mem = NULL;
data = NULL;
y = NULL;
yS = NULL;
A = NULL;
LS = NULL;
constraints = NULL;
/* Process arguments */
ProcessArgs(argc, argv, &sensi, &sensi_meth, &err_con);
/* User data structure */
data = (UserData) malloc(sizeof *data);
if (check_retval((void *)data, "malloc", 2)) return(1);
data->p[0] = RCONST(0.04);
data->p[1] = RCONST(1.0e4);
data->p[2] = RCONST(3.0e7);
/* Initial conditions */
y = N_VNew_Serial(NEQ);
if (check_retval((void *)y, "N_VNew_Serial", 0)) return(1);
Ith(y,1) = Y1;
Ith(y,2) = Y2;
Ith(y,3) = Y3;
/* Set constraints to all 1's for nonnegative solution values. */
constraints = N_VNew_Serial(NEQ);
if(check_retval((void *)constraints, "N_VNew_Serial", 0)) return(1);
N_VConst(ONE, constraints);
/* Create CVODES object */
cvode_mem = CVodeCreate(CV_BDF);
if (check_retval((void *)cvode_mem, "CVodeCreate", 0)) return(1);
/* Allocate space for CVODES */
retval = CVodeInit(cvode_mem, f, T0, y);
if (check_retval(&retval, "CVodeInit", 1)) return(1);
/* Use private function to compute error weights */
retval = CVodeWFtolerances(cvode_mem, ewt);
if (check_retval(&retval, "CVodeSetEwtFn", 1)) return(1);
/* Attach user data */
retval = CVodeSetUserData(cvode_mem, data);
if (check_retval(&retval, "CVodeSetUserData", 1)) return(1);
/* Call CVodeSetConstraints to initialize constraints */
retval = CVodeSetConstraints(cvode_mem, constraints);
if(check_retval(&retval, "CVodeSetConstraints", 1)) return(1);
N_VDestroy(constraints);
/* Create dense SUNMatrix */
A = SUNDenseMatrix(NEQ, NEQ);
if (check_retval((void *)A, "SUNDenseMatrix", 0)) return(1);
/* Create dense SUNLinearSolver */
LS = SUNLinSol_Dense(y, A);
if (check_retval((void *)LS, "SUNLinSol_Dense", 0)) return(1);
/* Attach the matrix and linear solver */
retval = CVDlsSetLinearSolver(cvode_mem, LS, A);
if (check_retval(&retval, "CVDlsSetLinearSolver", 1)) return(1);
/* Set the user-supplied Jacobian routine Jac */
retval = CVDlsSetJacFn(cvode_mem, Jac);
if (check_retval(&retval, "CVDlsSetJacFn", 1)) return(1);
printf("\n3-species chemical kinetics problem\n");
/* Sensitivity-related settings */
if (sensi) {
/* Set parameter scaling factor */
pbar[0] = data->p[0];
pbar[1] = data->p[1];
pbar[2] = data->p[2];
/* Set sensitivity initial conditions */
yS = N_VCloneVectorArray(NS, y);
if (check_retval((void *)yS, "N_VCloneVectorArray", 0)) return(1);
for (is=0;is<NS;is++) N_VConst(ZERO, yS[is]);
/* Call CVodeSensInit1 to activate forward sensitivity computations
and allocate internal memory for COVEDS related to sensitivity
calculations. Computes the right-hand sides of the sensitivity
ODE, one at a time */
retval = CVodeSensInit1(cvode_mem, NS, sensi_meth, fS, yS);
if(check_retval(&retval, "CVodeSensInit", 1)) return(1);
/* Call CVodeSensEEtolerances to estimate tolerances for sensitivity
variables based on the rolerances supplied for states variables and
the scaling factor pbar */
retval = CVodeSensEEtolerances(cvode_mem);
if(check_retval(&retval, "CVodeSensEEtolerances", 1)) return(1);
/* Set sensitivity analysis optional inputs */
/* Call CVodeSetSensErrCon to specify the error control strategy for
sensitivity variables */
retval = CVodeSetSensErrCon(cvode_mem, err_con);
if (check_retval(&retval, "CVodeSetSensErrCon", 1)) return(1);
/* Call CVodeSetSensParams to specify problem parameter information for
sensitivity calculations */
retval = CVodeSetSensParams(cvode_mem, NULL, pbar, NULL);
if (check_retval(&retval, "CVodeSetSensParams", 1)) return(1);
printf("Sensitivity: YES ");
if(sensi_meth == CV_SIMULTANEOUS)
printf("( SIMULTANEOUS +");
else
if(sensi_meth == CV_STAGGERED) printf("( STAGGERED +");
else printf("( STAGGERED1 +");
if(err_con) printf(" FULL ERROR CONTROL )");
else printf(" PARTIAL ERROR CONTROL )");
} else {
printf("Sensitivity: NO ");
}
/* In loop over output points, call CVode, print results, test for error */
printf("\n\n");
printf("===========================================");
printf("============================\n");
printf(" T Q H NST y1");
printf(" y2 y3 \n");
printf("===========================================");
printf("============================\n");
for (iout=1, tout=T1; iout <= NOUT; iout++, tout *= TMULT) {
retval = CVode(cvode_mem, tout, y, &t, CV_NORMAL);
if (check_retval(&retval, "CVode", 1)) break;
PrintOutput(cvode_mem, t, y);
/* Call CVodeGetSens to get the sensitivity solution vector after a
successful return from CVode */
if (sensi) {
retval = CVodeGetSens(cvode_mem, &t, yS);
if (check_retval(&retval, "CVodeGetSens", 1)) break;
PrintOutputS(yS);
}
printf("-----------------------------------------");
printf("------------------------------\n");
}
/* Print final statistics */
PrintFinalStats(cvode_mem, sensi);
/* Free memory */
N_VDestroy(y); /* Free y vector */
if (sensi) {
N_VDestroyVectorArray(yS, NS); /* Free yS vector */
}
free(data); /* Free user data */
CVodeFree(&cvode_mem); /* Free CVODES memory */
SUNLinSolFree(LS); /* Free the linear solver memory */
SUNMatDestroy(A); /* Free the matrix memory */
return(0);
}
int main(int argc, char *argv[])
{
realtype dx, reltol, abstol, t, tout;
N_Vector u;
UserData data;
void *cvode_mem;
int iout, flag, my_pe, npes;
long int local_N, nperpe, nrem, my_base;
realtype *pbar;
int is, *plist;
N_Vector *uS;
booleantype sensi, err_con;
int sensi_meth;
MPI_Comm comm;
u = NULL;
data = NULL;
cvode_mem = NULL;
pbar = NULL;
plist = NULL;
uS = NULL;
/* Get processor number, total number of pe's, and my_pe. */
MPI_Init(&argc, &argv);
comm = MPI_COMM_WORLD;
MPI_Comm_size(comm, &npes);
MPI_Comm_rank(comm, &my_pe);
/* Process arguments */
ProcessArgs(argc, argv, my_pe, &sensi, &sensi_meth, &err_con);
/* Set local vector length. */
nperpe = NEQ/npes;
nrem = NEQ - npes*nperpe;
local_N = (my_pe < nrem) ? nperpe+1 : nperpe;
my_base = (my_pe < nrem) ? my_pe*local_N : my_pe*nperpe + nrem;
/* USER DATA STRUCTURE */
data = (UserData) malloc(sizeof *data); /* Allocate data memory */
data->p = NULL;
if(check_flag((void *)data, "malloc", 2, my_pe)) MPI_Abort(comm, 1);
data->comm = comm;
data->npes = npes;
data->my_pe = my_pe;
data->p = (realtype *) malloc(NP * sizeof(realtype));
if(check_flag((void *)data->p, "malloc", 2, my_pe)) MPI_Abort(comm, 1);
dx = data->dx = XMAX/((realtype)(MX+1));
data->p[0] = RCONST(1.0);
data->p[1] = RCONST(0.5);
/* INITIAL STATES */
u = N_VNew_Parallel(comm, local_N, NEQ); /* Allocate u vector */
if(check_flag((void *)u, "N_VNew_Parallel", 0, my_pe)) MPI_Abort(comm, 1);
SetIC(u, dx, local_N, my_base); /* Initialize u vector */
/* TOLERANCES */
reltol = ZERO; /* Set the tolerances */
abstol = ATOL;
/* CVODE_CREATE & CVODE_MALLOC */
cvode_mem = CVodeCreate(CV_ADAMS, CV_FUNCTIONAL);
if(check_flag((void *)cvode_mem, "CVodeCreate", 0, my_pe)) MPI_Abort(comm, 1);
flag = CVodeSetUserData(cvode_mem, data);
if(check_flag(&flag, "CVodeSetUserData", 1, my_pe)) MPI_Abort(comm, 1);
flag = CVodeInit(cvode_mem, f, T0, u);
if(check_flag(&flag, "CVodeInit", 1, my_pe)) MPI_Abort(comm, 1);
flag = CVodeSStolerances(cvode_mem, reltol, abstol);
if(check_flag(&flag, "CVodeSStolerances", 1, my_pe)) MPI_Abort(comm, 1);
if (my_pe == 0) {
printf("\n1-D advection-diffusion equation, mesh size =%3d \n", MX);
printf("\nNumber of PEs = %3d \n",npes);
}
if(sensi) {
plist = (int *) malloc(NS * sizeof(int));
if(check_flag((void *)plist, "malloc", 2, my_pe)) MPI_Abort(comm, 1);
for(is=0; is<NS; is++)
plist[is] = is; /* sensitivity w.r.t. i-th parameter */
pbar = (realtype *) malloc(NS * sizeof(realtype));
if(check_flag((void *)pbar, "malloc", 2, my_pe)) MPI_Abort(comm, 1);
for(is=0; is<NS; is++) pbar[is] = data->p[plist[is]];
uS = N_VCloneVectorArray_Parallel(NS, u);
if(check_flag((void *)uS, "N_VCloneVectorArray_Parallel", 0, my_pe))
MPI_Abort(comm, 1);
for(is=0;is<NS;is++)
N_VConst(ZERO,uS[is]);
flag = CVodeSensInit1(cvode_mem, NS, sensi_meth, NULL, uS);
if(check_flag(&flag, "CVodeSensInit1", 1, my_pe)) MPI_Abort(comm, 1);
flag = CVodeSensEEtolerances(cvode_mem);
if(check_flag(&flag, "CVodeSensEEtolerances", 1, my_pe)) MPI_Abort(comm, 1);
flag = CVodeSetSensErrCon(cvode_mem, err_con);
if(check_flag(&flag, "CVodeSetSensErrCon", 1, my_pe)) MPI_Abort(comm, 1);
flag = CVodeSetSensDQMethod(cvode_mem, CV_CENTERED, ZERO);
if(check_flag(&flag, "CVodeSetSensDQMethod", 1, my_pe)) MPI_Abort(comm, 1);
flag = CVodeSetSensParams(cvode_mem, data->p, pbar, plist);
if(check_flag(&flag, "CVodeSetSensParams", 1, my_pe)) MPI_Abort(comm, 1);
if(my_pe == 0) {
printf("Sensitivity: YES ");
if(sensi_meth == CV_SIMULTANEOUS)
printf("( SIMULTANEOUS +");
else
if(sensi_meth == CV_STAGGERED) printf("( STAGGERED +");
else printf("( STAGGERED1 +");
if(err_con) printf(" FULL ERROR CONTROL )");
else printf(" PARTIAL ERROR CONTROL )");
}
} else {
if(my_pe == 0) printf("Sensitivity: NO ");
}
/* In loop over output points, call CVode, print results, test for error */
if(my_pe == 0) {
printf("\n\n");
printf("============================================================\n");
printf(" T Q H NST Max norm \n");
printf("============================================================\n");
}
for (iout=1, tout=T1; iout <= NOUT; iout++, tout += DTOUT) {
flag = CVode(cvode_mem, tout, u, &t, CV_NORMAL);
if(check_flag(&flag, "CVode", 1, my_pe)) break;
PrintOutput(cvode_mem, my_pe, t, u);
if (sensi) {
flag = CVodeGetSens(cvode_mem, &t, uS);
if(check_flag(&flag, "CVodeGetSens", 1, my_pe)) break;
PrintOutputS(my_pe, uS);
}
if (my_pe == 0)
printf("------------------------------------------------------------\n");
}
/* Print final statistics */
if (my_pe == 0)
PrintFinalStats(cvode_mem, sensi);
/* Free memory */
N_VDestroy(u); /* Free the u vector */
if (sensi)
N_VDestroyVectorArray(uS, NS); /* Free the uS vectors */
free(data->p); /* Free the p vector */
free(data); /* Free block of UserData */
CVodeFree(&cvode_mem); /* Free the CVODES problem memory */
free(pbar);
if(sensi) free(plist);
MPI_Finalize();
return(0);
}
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);
}
