int CVSpbcg(void *cvode_mem, int pretype, int maxl)
{
CVodeMem cv_mem;
CVSpilsMem cvspils_mem;
SpbcgMem spbcg_mem;
int mxl;
/* Return immediately if cvode_mem is NULL */
if (cvode_mem == NULL) {
cvProcessError(NULL, CVSPILS_MEM_NULL, "CVSPBCG", "CVSpbcg", MSGS_CVMEM_NULL);
return(CVSPILS_MEM_NULL);
}
cv_mem = (CVodeMem) cvode_mem;
/* Check if N_VDotProd is present */
if (vec_tmpl->ops->nvdotprod == NULL) {
cvProcessError(cv_mem, CVSPILS_ILL_INPUT, "CVSPBCG", "CVSpbcg", MSGS_BAD_NVECTOR);
return(CVSPILS_ILL_INPUT);
}
if (lfree != NULL) lfree(cv_mem);
/* Set four main function fields in cv_mem */
linit = CVSpbcgInit;
lsetup = CVSpbcgSetup;
lsolve = CVSpbcgSolve;
lfree = CVSpbcgFree;
/* Get memory for CVSpilsMemRec */
cvspils_mem = NULL;
cvspils_mem = (CVSpilsMem) malloc(sizeof(struct CVSpilsMemRec));
if (cvspils_mem == NULL) {
cvProcessError(cv_mem, CVSPILS_MEM_FAIL, "CVSPBCG", "CVSpbcg", MSGS_MEM_FAIL);
return(CVSPILS_MEM_FAIL);
}
/* Set ILS type */
cvspils_mem->s_type = SPILS_SPBCG;
/* Set Spbcg parameters that have been passed in call sequence */
cvspils_mem->s_pretype = pretype;
mxl = cvspils_mem->s_maxl = (maxl <= 0) ? CVSPILS_MAXL : maxl;
/* Set defaults for Jacobian-related fileds */
jtimesDQ = TRUE;
jtimes = NULL;
j_data = NULL;
/* Set defaults for preconditioner-related fields */
cvspils_mem->s_pset = NULL;
cvspils_mem->s_psolve = NULL;
cvspils_mem->s_pfree = NULL;
cvspils_mem->s_P_data = cv_mem->cv_user_data;
/* Set default values for the rest of the Spbcg parameters */
cvspils_mem->s_eplifac = CVSPILS_EPLIN;
cvspils_mem->s_last_flag = CVSPILS_SUCCESS;
cvSpilsInitializeCounters(cvspils_mem);
setupNonNull = FALSE;
/* Check for legal pretype */
if ((pretype != PREC_NONE) && (pretype != PREC_LEFT) &&
(pretype != PREC_RIGHT) && (pretype != PREC_BOTH)) {
cvProcessError(cv_mem, CVSPILS_ILL_INPUT, "CVSPBCG", "CVSpbcg", MSGS_BAD_PRETYPE);
free(cvspils_mem);
cvspils_mem = NULL;
return(CVSPILS_ILL_INPUT);
}
/* Allocate memory for ytemp and x */
ytemp = N_VClone(vec_tmpl);
if (ytemp == NULL) {
cvProcessError(cv_mem, CVSPILS_MEM_FAIL, "CVSPBCG", "CVSpbcg", MSGS_MEM_FAIL);
free(cvspils_mem);
cvspils_mem = NULL;
return(CVSPILS_MEM_FAIL);
}
x = N_VClone(vec_tmpl);
if (x == NULL) {
cvProcessError(cv_mem, CVSPILS_MEM_FAIL, "CVSPBCG", "CVSpbcg", MSGS_MEM_FAIL);
N_VDestroy(ytemp);
free(cvspils_mem);
cvspils_mem = NULL;
return(CVSPILS_MEM_FAIL);
}
/* Compute sqrtN from a dot product */
N_VConst(ONE, ytemp);
sqrtN = SUNRsqrt(N_VDotProd(ytemp, ytemp));
/* Call SpbcgMalloc to allocate workspace for Spbcg */
spbcg_mem = NULL;
spbcg_mem = SpbcgMalloc(mxl, vec_tmpl);
if (spbcg_mem == NULL) {
cvProcessError(cv_mem, CVSPILS_MEM_FAIL, "CVSPBCG", "CVSpbcg", MSGS_MEM_FAIL);
N_VDestroy(ytemp);
N_VDestroy(x);
free(cvspils_mem);
cvspils_mem = NULL;
return(CVSPILS_MEM_FAIL);
}
/* Attach SPBCG memory to spils memory structure */
spils_mem = (void *) spbcg_mem;
/* Attach linear solver memory to integrator memory */
lmem = cvspils_mem;
return(CVSPILS_SUCCESS);
}
int IDASetTolerances(void *ida_mem,
int itol, realtype rtol, void *atol)
{
IDAMem IDA_mem;
booleantype neg_atol;
if (ida_mem==NULL) {
fprintf(stderr, MSG_IDAS_NO_MEM);
return(IDA_MEM_NULL);
}
IDA_mem = (IDAMem) ida_mem;
/* Check if ida_mem was allocated */
if (IDA_mem->ida_MallocDone == FALSE) {
if(errfp!=NULL) fprintf(errfp, MSG_IDAS_NO_MALLOC);
return(IDA_NO_MALLOC);
}
/* Check inputs */
if ((itol != IDA_SS) && (itol != IDA_SV)) {
if(errfp!=NULL) fprintf(errfp, MSG_IDAS_BAD_ITOL);
return(IDA_ILL_INPUT);
}
if (atol == NULL) {
if(errfp!=NULL) fprintf(errfp, MSG_IDAS_ATOL_NULL);
return(IDA_ILL_INPUT);
}
if (rtol < ZERO) {
if(errfp!=NULL) fprintf(errfp, MSG_IDAS_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) {
if(errfp!=NULL) fprintf(errfp, MSG_IDAS_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 = 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);
}
/*---------------------------------------------------------------
CVDlsSetLinearSolver specifies the direct linear solver.
---------------------------------------------------------------*/
int CVDlsSetLinearSolver(void *cvode_mem, SUNLinearSolver LS,
SUNMatrix A)
{
CVodeMem cv_mem;
CVDlsMem cvdls_mem;
/* Return immediately if any input is NULL */
if (cvode_mem == NULL) {
cvProcessError(NULL, CVDLS_MEM_NULL, "CVDLS",
"CVDlsSetLinearSolver", MSGD_CVMEM_NULL);
return(CVDLS_MEM_NULL);
}
if ( (LS == NULL) || (A == NULL) ) {
cvProcessError(NULL, CVDLS_ILL_INPUT, "CVDLS",
"CVDlsSetLinearSolver",
"Both LS and A must be non-NULL");
return(CVDLS_ILL_INPUT);
}
cv_mem = (CVodeMem) cvode_mem;
/* Test if solver and vector are compatible with DLS */
if (SUNLinSolGetType(LS) != SUNLINEARSOLVER_DIRECT) {
cvProcessError(cv_mem, CVDLS_ILL_INPUT, "CVDLS",
"CVDlsSetLinearSolver",
"Non-direct LS supplied to CVDls interface");
return(CVDLS_ILL_INPUT);
}
if (cv_mem->cv_tempv->ops->nvgetarraypointer == NULL ||
cv_mem->cv_tempv->ops->nvsetarraypointer == NULL) {
cvProcessError(cv_mem, CVDLS_ILL_INPUT, "CVDLS",
"CVDlsSetLinearSolver", MSGD_BAD_NVECTOR);
return(CVDLS_ILL_INPUT);
}
/* free any existing system solver attached to CVode */
if (cv_mem->cv_lfree) cv_mem->cv_lfree(cv_mem);
/* Set four main system linear solver function fields in cv_mem */
cv_mem->cv_linit = cvDlsInitialize;
cv_mem->cv_lsetup = cvDlsSetup;
cv_mem->cv_lsolve = cvDlsSolve;
cv_mem->cv_lfree = cvDlsFree;
/* Get memory for CVDlsMemRec */
cvdls_mem = NULL;
cvdls_mem = (CVDlsMem) malloc(sizeof(struct CVDlsMemRec));
if (cvdls_mem == NULL) {
cvProcessError(cv_mem, CVDLS_MEM_FAIL, "CVDLS",
"CVDlsSetLinearSolver", MSGD_MEM_FAIL);
return(CVDLS_MEM_FAIL);
}
/* set SUNLinearSolver pointer */
cvdls_mem->LS = LS;
/* Initialize Jacobian-related data */
cvdls_mem->jacDQ = SUNTRUE;
cvdls_mem->jac = cvDlsDQJac;
cvdls_mem->J_data = cv_mem;
cvdls_mem->last_flag = CVDLS_SUCCESS;
/* Initialize counters */
cvDlsInitializeCounters(cvdls_mem);
/* Store pointer to A and create saved_J */
cvdls_mem->A = A;
cvdls_mem->savedJ = SUNMatClone(A);
if (cvdls_mem->savedJ == NULL) {
cvProcessError(cv_mem, CVDLS_MEM_FAIL, "CVDLS",
"CVDlsSetLinearSolver", MSGD_MEM_FAIL);
free(cvdls_mem); cvdls_mem = NULL;
return(CVDLS_MEM_FAIL);
}
/* Allocate memory for x */
cvdls_mem->x = N_VClone(cv_mem->cv_tempv);
if (cvdls_mem->x == NULL) {
cvProcessError(cv_mem, CVDLS_MEM_FAIL, "CVDLS",
"CVDlsSetLinearSolver", MSGD_MEM_FAIL);
SUNMatDestroy(cvdls_mem->savedJ);
free(cvdls_mem); cvdls_mem = NULL;
return(CVDLS_MEM_FAIL);
}
/* Attach linear solver memory to integrator memory */
cv_mem->cv_lmem = cvdls_mem;
return(CVDLS_SUCCESS);
}
int CVDiag(void *cvode_mem)
{
CVodeMem cv_mem;
CVDiagMem cvdiag_mem;
/* Return immediately if cvode_mem is NULL */
if (cvode_mem == NULL) {
CVProcessError(NULL, CVDIAG_MEM_NULL, "CVDIAG", "CVDiag", MSGDG_CVMEM_NULL);
return(CVDIAG_MEM_NULL);
}
cv_mem = (CVodeMem) cvode_mem;
/* Check if N_VCompare and N_VInvTest are present */
if(vec_tmpl->ops->nvcompare == NULL ||
vec_tmpl->ops->nvinvtest == NULL) {
CVProcessError(cv_mem, CVDIAG_ILL_INPUT, "CVDIAG", "CVDiag", MSGDG_BAD_NVECTOR);
return(CVDIAG_ILL_INPUT);
}
if (lfree != NULL) lfree(cv_mem);
/* Set four main function fields in cv_mem */
linit = CVDiagInit;
lsetup = CVDiagSetup;
lsolve = CVDiagSolve;
lfree = CVDiagFree;
/* Get memory for CVDiagMemRec */
cvdiag_mem = NULL;
cvdiag_mem = (CVDiagMem) malloc(sizeof(CVDiagMemRec));
if (cvdiag_mem == NULL) {
CVProcessError(cv_mem, CVDIAG_MEM_FAIL, "CVDIAG", "CVDiag", MSGDG_MEM_FAIL);
return(CVDIAG_MEM_FAIL);
}
last_flag = CVDIAG_SUCCESS;
/* Set flag setupNonNull = TRUE */
setupNonNull = TRUE;
/* Allocate memory for M, bit, and bitcomp */
M = NULL;
M = N_VClone(vec_tmpl);
if (M == NULL) {
CVProcessError(cv_mem, CVDIAG_MEM_FAIL, "CVDIAG", "CVDiag", MSGDG_MEM_FAIL);
free(cvdiag_mem); cvdiag_mem = NULL;
return(CVDIAG_MEM_FAIL);
}
bit = NULL;
bit = N_VClone(vec_tmpl);
if (bit == NULL) {
CVProcessError(cv_mem, CVDIAG_MEM_FAIL, "CVDIAG", "CVDiag", MSGDG_MEM_FAIL);
N_VDestroy(M);
free(cvdiag_mem); cvdiag_mem = NULL;
return(CVDIAG_MEM_FAIL);
}
bitcomp = NULL;
bitcomp = N_VClone(vec_tmpl);
if (bitcomp == NULL) {
CVProcessError(cv_mem, CVDIAG_MEM_FAIL, "CVDIAG", "CVDiag", MSGDG_MEM_FAIL);
N_VDestroy(M);
N_VDestroy(bit);
free(cvdiag_mem); cvdiag_mem = NULL;
return(CVDIAG_MEM_FAIL);
}
/* Attach linear solver memory to integrator memory */
lmem = cvdiag_mem;
return(CVDIAG_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);
}
/*---------------------------------------------------------------
ARKSpbcg:
This routine initializes the memory record and sets various
function fields specific to the Spbcg linear solver module.
ARKSpbcg first calls the existing lfree routine if this is not
NULL. It then sets the ark_linit, ark_lsetup, ark_lsolve,
ark_lfree fields in (*arkode_mem) to be ARKSpbcgInit,
ARKSpbcgSetup, ARKSpbcgSolve, and ARKSpbcgFree, respectively.
It allocates memory for a structure of type ARKSpilsMemRec and
sets the ark_lmem field in (*arkode_mem) to the address of
this structure. It sets setupNonNull in (*arkode_mem),
and sets various fields in the ARKSpilsMemRec structure.
Finally, ARKSpbcg allocates memory for ytemp and x, and calls
SpbcgMalloc to allocate memory for the Spbcg solver.
---------------------------------------------------------------*/
int ARKSpbcg(void *arkode_mem, int pretype, int maxl)
{
ARKodeMem ark_mem;
ARKSpilsMem arkspils_mem;
SpbcgMem spbcg_mem;
int mxl;
/* Return immediately if arkode_mem is NULL */
if (arkode_mem == NULL) {
arkProcessError(NULL, ARKSPILS_MEM_NULL, "ARKSPBCG",
"ARKSpbcg", MSGS_ARKMEM_NULL);
return(ARKSPILS_MEM_NULL);
}
ark_mem = (ARKodeMem) arkode_mem;
/* Check if N_VDotProd and N_VProd are present */
if ((ark_mem->ark_tempv->ops->nvdotprod == NULL) ||
(ark_mem->ark_tempv->ops->nvprod == NULL)) {
arkProcessError(ark_mem, ARKSPILS_ILL_INPUT, "ARKSPBCG",
"ARKSpbcg", MSGS_BAD_NVECTOR);
return(ARKSPILS_ILL_INPUT);
}
if (ark_mem->ark_lfree != NULL) ark_mem->ark_lfree(ark_mem);
/* Set four main function fields in ark_mem */
ark_mem->ark_linit = ARKSpbcgInit;
ark_mem->ark_lsetup = ARKSpbcgSetup;
ark_mem->ark_lsolve = ARKSpbcgSolve;
ark_mem->ark_lfree = ARKSpbcgFree;
ark_mem->ark_lsolve_type = 0;
/* Get memory for ARKSpilsMemRec */
arkspils_mem = NULL;
arkspils_mem = (ARKSpilsMem) malloc(sizeof(struct ARKSpilsMemRec));
if (arkspils_mem == NULL) {
arkProcessError(ark_mem, ARKSPILS_MEM_FAIL, "ARKSPBCG",
"ARKSpbcg", MSGS_MEM_FAIL);
return(ARKSPILS_MEM_FAIL);
}
/* Set ILS type */
arkspils_mem->s_type = SPILS_SPBCG;
/* Set Spbcg parameters that have been passed in call sequence */
arkspils_mem->s_pretype = pretype;
mxl = arkspils_mem->s_maxl = (maxl <= 0) ? ARKSPILS_MAXL : maxl;
/* Set defaults for Jacobian-related fields */
arkspils_mem->s_jtimesDQ = TRUE;
arkspils_mem->s_jtimes = NULL;
arkspils_mem->s_j_data = NULL;
/* Set defaults for preconditioner-related fields */
arkspils_mem->s_pset = NULL;
arkspils_mem->s_psolve = NULL;
arkspils_mem->s_pfree = NULL;
arkspils_mem->s_P_data = ark_mem->ark_user_data;
/* Initialize counters */
arkspils_mem->s_npe = arkspils_mem->s_nli = 0;
arkspils_mem->s_nps = arkspils_mem->s_ncfl = 0;
arkspils_mem->s_nstlpre = arkspils_mem->s_njtimes = 0;
arkspils_mem->s_nfes = 0;
/* Set default values for the rest of the Spbcg parameters */
arkspils_mem->s_eplifac = ARKSPILS_EPLIN;
arkspils_mem->s_last_flag = ARKSPILS_SUCCESS;
ark_mem->ark_setupNonNull = FALSE;
/* Check for legal pretype */
if ((pretype != PREC_NONE) && (pretype != PREC_LEFT) &&
(pretype != PREC_RIGHT) && (pretype != PREC_BOTH)) {
arkProcessError(ark_mem, ARKSPILS_ILL_INPUT, "ARKSPBCG",
"ARKSpbcg", MSGS_BAD_PRETYPE);
free(arkspils_mem); arkspils_mem = NULL;
return(ARKSPILS_ILL_INPUT);
}
/* Allocate memory for ytemp and x */
arkspils_mem->s_ytemp = N_VClone(ark_mem->ark_tempv);
if (arkspils_mem->s_ytemp == NULL) {
arkProcessError(ark_mem, ARKSPILS_MEM_FAIL, "ARKSPBCG",
"ARKSpbcg", MSGS_MEM_FAIL);
free(arkspils_mem); arkspils_mem = NULL;
return(ARKSPILS_MEM_FAIL);
}
arkspils_mem->s_x = N_VClone(ark_mem->ark_tempv);
if (arkspils_mem->s_x == NULL) {
arkProcessError(ark_mem, ARKSPILS_MEM_FAIL, "ARKSPBCG",
"ARKSpbcg", MSGS_MEM_FAIL);
N_VDestroy(arkspils_mem->s_ytemp);
free(arkspils_mem); arkspils_mem = NULL;
return(ARKSPILS_MEM_FAIL);
}
/* Compute sqrtN from a dot product */
N_VConst(ONE, arkspils_mem->s_ytemp);
arkspils_mem->s_sqrtN = SUNRsqrt(N_VDotProd(arkspils_mem->s_ytemp,
arkspils_mem->s_ytemp));
/* Call SpbcgMalloc to allocate workspace for Spbcg */
spbcg_mem = NULL;
spbcg_mem = SpbcgMalloc(mxl, ark_mem->ark_tempv);
if (spbcg_mem == NULL) {
arkProcessError(ark_mem, ARKSPILS_MEM_FAIL, "ARKSPBCG",
"ARKSpbcg", MSGS_MEM_FAIL);
N_VDestroy(arkspils_mem->s_ytemp);
N_VDestroy(arkspils_mem->s_x);
free(arkspils_mem); arkspils_mem = NULL;
return(ARKSPILS_MEM_FAIL);
}
/* Attach SPBCG memory to spils memory structure */
arkspils_mem->s_spils_mem = (void *) spbcg_mem;
/* Attach linear solver memory to integrator memory */
ark_mem->ark_lmem = arkspils_mem;
return(ARKSPILS_SUCCESS);
}
/* ----------------------------------------------------------------------
* Extra ScaleAddI tests for sparse matrices:
* A should not contain values on the diagonal, nor should it contain
* sufficient storage to add those in
* y should already equal A*x
* --------------------------------------------------------------------*/
int Test_SUNMatScaleAddI2(SUNMatrix A, N_Vector x, N_Vector y)
{
int failure;
SUNMatrix B, C, D;
N_Vector w, z;
realtype tol=100*UNIT_ROUNDOFF;
/* create clones for test */
B = SUNMatClone(A);
z = N_VClone(x);
w = N_VClone(x);
/* test 1: add I to a matrix with insufficient storage */
failure = SUNMatCopy(A, B);
if (failure) {
printf(">>> FAILED test -- SUNMatCopy returned %d \n",
failure);
SUNMatDestroy(B); N_VDestroy(z); N_VDestroy(w); return(1);
}
failure = SUNMatScaleAddI(NEG_ONE, B); /* B = I-A */
if (failure) {
printf(">>> FAILED test -- SUNMatScaleAddI returned %d \n",
failure);
SUNMatDestroy(B); N_VDestroy(z); N_VDestroy(w); return(1);
}
failure = SUNMatMatvec(B, x, z);
if (failure) {
printf(">>> FAILED test -- SUNMatMatvec returned %d \n",
failure);
SUNMatDestroy(B); N_VDestroy(z); N_VDestroy(w); return(1);
}
N_VLinearSum(ONE,x,NEG_ONE,y,w);
failure = check_vector(z, w, tol);
if (failure) {
printf(">>> FAILED test -- SUNMatScaleAddI2 check 1 \n");
printf("\nA =\n");
SUNSparseMatrix_Print(A,stdout);
printf("\nB =\n");
SUNSparseMatrix_Print(B,stdout);
printf("\nz =\n");
N_VPrint_Serial(z);
printf("\nw =\n");
N_VPrint_Serial(w);
SUNMatDestroy(B); N_VDestroy(z); N_VDestroy(w); return(1);
}
else {
printf(" PASSED test -- SUNMatScaleAddI2 check 1 \n");
}
/* test 2: add I to a matrix with sufficient but misplaced
storage */
C = SUNMatClone(A);
failure = SUNSparseMatrix_Reallocate(C, SM_NNZ_S(A)+SM_ROWS_S(A));
failure = SUNMatCopy(A, C);
if (failure) {
printf(">>> FAILED test -- SUNMatCopy returned %d \n",
failure);
SUNMatDestroy(B); SUNMatDestroy(C);
N_VDestroy(z); N_VDestroy(w); return(1);
}
failure = SUNMatScaleAddI(NEG_ONE, C); /* C = I-A */
if (failure) {
printf(">>> FAILED test -- SUNMatScaleAddI returned %d \n",
failure);
SUNMatDestroy(B); SUNMatDestroy(C);
N_VDestroy(z); N_VDestroy(w); return(1);
}
failure = SUNMatMatvec(C, x, z);
if (failure) {
printf(">>> FAILED test -- SUNMatMatvec returned %d \n",
failure);
SUNMatDestroy(B); SUNMatDestroy(C);
N_VDestroy(z); N_VDestroy(w); return(1);
}
N_VLinearSum(ONE,x,NEG_ONE,y,w);
failure = check_vector(z, w, tol);
if (failure) {
printf(">>> FAILED test -- SUNMatScaleAddI2 check 2 \n");
printf("\nA =\n");
SUNSparseMatrix_Print(A,stdout);
printf("\nC =\n");
SUNSparseMatrix_Print(C,stdout);
printf("\nz =\n");
N_VPrint_Serial(z);
printf("\nw =\n");
N_VPrint_Serial(w);
SUNMatDestroy(B); SUNMatDestroy(C);
N_VDestroy(z); N_VDestroy(w); return(1);
}
else {
printf(" PASSED test -- SUNMatScaleAddI2 check 2 \n");
}
/* test 3: add I to a matrix with appropriate structure already in place */
D = SUNMatClone(C);
failure = SUNMatCopy(C, D);
if (failure) {
printf(">>> FAILED test -- SUNMatCopy returned %d \n",
failure);
SUNMatDestroy(B); SUNMatDestroy(C); SUNMatDestroy(D);
N_VDestroy(z); N_VDestroy(w); return(1);
}
failure = SUNMatScaleAddI(NEG_ONE, D); /* D = A */
if (failure) {
printf(">>> FAILED test -- SUNMatScaleAddI returned %d \n",
failure);
SUNMatDestroy(B); SUNMatDestroy(C); SUNMatDestroy(D);
N_VDestroy(z); N_VDestroy(w); return(1);
}
failure = SUNMatMatvec(D, x, z);
if (failure) {
printf(">>> FAILED test -- SUNMatMatvec returned %d \n",
failure);
SUNMatDestroy(B); SUNMatDestroy(C); SUNMatDestroy(D);
N_VDestroy(z); N_VDestroy(w); return(1);
}
failure = check_vector(z, y, tol);
if (failure) {
printf(">>> FAILED test -- SUNMatScaleAddI2 check 3 \n");
printf("\nA =\n");
SUNSparseMatrix_Print(A,stdout);
printf("\nD =\n");
SUNSparseMatrix_Print(D,stdout);
printf("\nz =\n");
N_VPrint_Serial(z);
printf("\ny =\n");
N_VPrint_Serial(y);
SUNMatDestroy(B); SUNMatDestroy(C); SUNMatDestroy(D);
N_VDestroy(z); N_VDestroy(w); return(1);
}
else {
printf(" PASSED test -- SUNMatScaleAddI2 check 3 \n");
}
SUNMatDestroy(B);
SUNMatDestroy(C);
SUNMatDestroy(D);
N_VDestroy(z);
N_VDestroy(w);
return(0);
}
int IDASptfqmr(void *ida_mem, int maxl)
{
IDAMem IDA_mem;
IDASpilsMem idaspils_mem;
SptfqmrMem sptfqmr_mem;
int flag, maxl1;
/* Return immediately if ida_mem is NULL */
if (ida_mem == NULL) {
IDAProcessError(NULL, IDASPILS_MEM_NULL, "IDASPTFQMR", "IDASptfqmr", MSGS_IDAMEM_NULL);
return(IDASPILS_MEM_NULL);
}
IDA_mem = (IDAMem) ida_mem;
/* Check if N_VDotProd is present */
if (vec_tmpl->ops->nvdotprod == NULL) {
IDAProcessError(NULL, IDASPILS_ILL_INPUT, "IDASPTFQMR", "IDASptfqmr", MSGS_BAD_NVECTOR);
return(IDASPILS_ILL_INPUT);
}
if (lfree != NULL) flag = lfree((IDAMem) ida_mem);
/* Set five main function fields in ida_mem */
linit = IDASptfqmrInit;
lsetup = IDASptfqmrSetup;
lsolve = IDASptfqmrSolve;
lperf = IDASptfqmrPerf;
lfree = IDASptfqmrFree;
/* Get memory for IDASpilsMemRec */
idaspils_mem = NULL;
idaspils_mem = (IDASpilsMem) malloc(sizeof(struct IDASpilsMemRec));
if (idaspils_mem == NULL) {
IDAProcessError(NULL, IDASPILS_MEM_FAIL, "IDASPTFQMR", "IDASptfqmr", MSGS_MEM_FAIL);
return(IDASPILS_MEM_FAIL);
}
/* Set ILS type */
idaspils_mem->s_type = SPILS_SPTFQMR;
/* Set SPTFQMR parameters that were passed in call sequence */
maxl1 = (maxl <= 0) ? IDA_SPILS_MAXL : maxl;
idaspils_mem->s_maxl = maxl1;
/* Set defaults for Jacobian-related fileds */
jtimesDQ = TRUE;
jtimes = NULL;
jdata = NULL;
/* Set defaults for preconditioner-related fields */
idaspils_mem->s_pset = NULL;
idaspils_mem->s_psolve = NULL;
idaspils_mem->s_pfree = NULL;
idaspils_mem->s_pdata = IDA_mem->ida_user_data;
/* Set default values for the rest of the Sptfqmr parameters */
idaspils_mem->s_eplifac = PT05;
idaspils_mem->s_dqincfac = ONE;
idaspils_mem->s_last_flag = IDASPILS_SUCCESS;
/* Set setupNonNull to FALSE */
setupNonNull = FALSE;
/* Allocate memory for ytemp, yptemp, and xx */
ytemp = N_VClone(vec_tmpl);
if (ytemp == NULL) {
IDAProcessError(NULL, IDASPILS_MEM_FAIL, "IDASPTFQMR", "IDASptfqmr", MSGS_MEM_FAIL);
free(idaspils_mem); idaspils_mem = NULL;
return(IDASPILS_MEM_FAIL);
}
yptemp = N_VClone(vec_tmpl);
if (yptemp == NULL) {
IDAProcessError(NULL, IDASPILS_MEM_FAIL, "IDASPTFQMR", "IDASptfqmr", MSGS_MEM_FAIL);
N_VDestroy(ytemp);
free(idaspils_mem); idaspils_mem = NULL;
return(IDASPILS_MEM_FAIL);
}
xx = N_VClone(vec_tmpl);
if (xx == NULL) {
IDAProcessError(NULL, IDASPILS_MEM_FAIL, "IDASPTFQMR", "IDASptfqmr", MSGS_MEM_FAIL);
N_VDestroy(ytemp);
N_VDestroy(yptemp);
free(idaspils_mem); idaspils_mem = NULL;
return(IDASPILS_MEM_FAIL);
}
/* Compute sqrtN from a dot product */
N_VConst(ONE, ytemp);
sqrtN = RSqrt(N_VDotProd(ytemp, ytemp));
/* Call SptfqmrMalloc to allocate workspace for Sptfqmr */
sptfqmr_mem = NULL;
sptfqmr_mem = SptfqmrMalloc(maxl1, vec_tmpl);
if (sptfqmr_mem == NULL) {
IDAProcessError(NULL, IDASPILS_MEM_FAIL, "IDASPTFQMR", "IDASptfqmr", MSGS_MEM_FAIL);
N_VDestroy(ytemp);
N_VDestroy(yptemp);
N_VDestroy(xx);
free(idaspils_mem); idaspils_mem = NULL;
return(IDASPILS_MEM_FAIL);
}
/* Attach SPTFQMR memory to spils memory structure */
spils_mem = (void *)sptfqmr_mem;
/* Attach linear solver memory to the integrator memory */
lmem = idaspils_mem;
return(IDASPILS_SUCCESS);
}
/* ----------------------------------------------------------------------
* Extra ScaleAdd tests for sparse matrices:
* A and B should have different sparsity patterns, and neither should
* contain sufficient storage to for their sum
* y should already equal A*x
* z should already equal B*x
* --------------------------------------------------------------------*/
int Test_SUNMatScaleAdd2(SUNMatrix A, SUNMatrix B, N_Vector x,
N_Vector y, N_Vector z)
{
int failure;
SUNMatrix C, D, E;
N_Vector u, v;
realtype tol=100*UNIT_ROUNDOFF;
/* create clones for test */
C = SUNMatClone(A);
u = N_VClone(y);
v = N_VClone(y);
/* test 1: add A to B (output must be enlarged) */
failure = SUNMatCopy(A, C); /* C = A */
if (failure) {
printf(">>> FAILED test -- SUNMatCopy returned %d \n",
failure);
SUNMatDestroy(C); N_VDestroy(u); N_VDestroy(v); return(1);
}
failure = SUNMatScaleAdd(ONE, C, B); /* C = A+B */
if (failure) {
printf(">>> FAILED test -- SUNMatScaleAdd returned %d \n",
failure);
SUNMatDestroy(C); N_VDestroy(u); N_VDestroy(v); return(1);
}
failure = SUNMatMatvec(C, x, u); /* u = Cx = Ax+Bx */
if (failure) {
printf(">>> FAILED test -- SUNMatMatvec returned %d \n",
failure);
SUNMatDestroy(C); N_VDestroy(u); N_VDestroy(v); return(1);
}
N_VLinearSum(ONE,y,ONE,z,v); /* v = y+z */
failure = check_vector(u, v, tol); /* u ?= v */
if (failure) {
printf(">>> FAILED test -- SUNMatScaleAdd2 check 1 \n");
printf("\nA =\n");
SUNSparseMatrix_Print(A,stdout);
printf("\nB =\n");
SUNSparseMatrix_Print(B,stdout);
printf("\nC =\n");
SUNSparseMatrix_Print(C,stdout);
printf("\nx =\n");
N_VPrint_Serial(x);
printf("\ny =\n");
N_VPrint_Serial(y);
printf("\nz =\n");
N_VPrint_Serial(z);
printf("\nu =\n");
N_VPrint_Serial(u);
printf("\nv =\n");
N_VPrint_Serial(v);
SUNMatDestroy(C); N_VDestroy(u); N_VDestroy(v); return(1);
}
else {
printf(" PASSED test -- SUNMatScaleAdd2 check 1 \n");
}
/* test 2: add A to a matrix with sufficient but misplaced storage */
D = SUNMatClone(A);
failure = SUNSparseMatrix_Reallocate(D, SM_NNZ_S(A)+SM_NNZ_S(B));
failure = SUNMatCopy(A, D); /* D = A */
if (failure) {
printf(">>> FAILED test -- SUNMatCopy returned %d \n",
failure);
SUNMatDestroy(C); SUNMatDestroy(D);
N_VDestroy(u); N_VDestroy(v); return(1);
}
failure = SUNMatScaleAdd(ONE, D, B); /* D = A+B */
if (failure) {
printf(">>> FAILED test -- SUNMatScaleAdd returned %d \n",
failure);
SUNMatDestroy(C); SUNMatDestroy(D);
N_VDestroy(u); N_VDestroy(v); return(1);
}
failure = SUNMatMatvec(D, x, u); /* u = Cx = Ax+Bx */
if (failure) {
printf(">>> FAILED test -- SUNMatMatvec returned %d \n",
failure);
SUNMatDestroy(C); SUNMatDestroy(D);
N_VDestroy(u); N_VDestroy(v); return(1);
}
N_VLinearSum(ONE,y,ONE,z,v); /* v = y+z */
failure = check_vector(u, v, tol); /* u ?= v */
if (failure) {
printf(">>> FAILED test -- SUNMatScaleAdd2 check 2 \n");
printf("\nA =\n");
SUNSparseMatrix_Print(A,stdout);
printf("\nB =\n");
SUNSparseMatrix_Print(B,stdout);
printf("\nD =\n");
SUNSparseMatrix_Print(D,stdout);
printf("\nx =\n");
N_VPrint_Serial(x);
printf("\ny =\n");
N_VPrint_Serial(y);
printf("\nz =\n");
N_VPrint_Serial(z);
printf("\nu =\n");
N_VPrint_Serial(u);
printf("\nv =\n");
N_VPrint_Serial(v);
SUNMatDestroy(C); SUNMatDestroy(D);
N_VDestroy(u); N_VDestroy(v); return(1);
}
else {
printf(" PASSED test -- SUNMatScaleAdd2 check 2 \n");
}
/* test 3: add A to a matrix with the appropriate structure already in place */
E = SUNMatClone(C);
failure = SUNMatCopy(C, E); /* E = A + B */
if (failure) {
printf(">>> FAILED test -- SUNMatCopy returned %d \n",
failure);
SUNMatDestroy(C); SUNMatDestroy(D); SUNMatDestroy(E);
N_VDestroy(u); N_VDestroy(v); return(1);
}
failure = SUNMatScaleAdd(NEG_ONE, E, B); /* E = -A */
if (failure) {
printf(">>> FAILED test -- SUNMatScaleAdd returned %d \n",
failure);
SUNMatDestroy(C); SUNMatDestroy(D); SUNMatDestroy(E);
N_VDestroy(u); N_VDestroy(v); return(1);
}
failure = SUNMatMatvec(E, x, u); /* u = Ex = -Ax */
if (failure) {
printf(">>> FAILED test -- SUNMatMatvec returned %d \n",
failure);
SUNMatDestroy(C); SUNMatDestroy(D); SUNMatDestroy(E);
N_VDestroy(u); N_VDestroy(v); return(1);
}
N_VLinearSum(NEG_ONE,y,ZERO,z,v); /* v = -y */
failure = check_vector(u, v, tol); /* v ?= u */
if (failure) {
printf(">>> FAILED test -- SUNMatScaleAdd2 check 3 \n");
printf("\nA =\n");
SUNSparseMatrix_Print(A,stdout);
printf("\nB =\n");
SUNSparseMatrix_Print(B,stdout);
printf("\nC =\n");
SUNSparseMatrix_Print(C,stdout);
printf("\nE =\n");
SUNSparseMatrix_Print(E,stdout);
printf("\nx =\n");
N_VPrint_Serial(x);
printf("\ny =\n");
N_VPrint_Serial(y);
printf("\nu =\n");
N_VPrint_Serial(u);
printf("\nv =\n");
N_VPrint_Serial(v);
SUNMatDestroy(C); SUNMatDestroy(D); SUNMatDestroy(E);
N_VDestroy(u); N_VDestroy(v); return(1);
}
else {
printf(" PASSED test -- SUNMatScaleAdd2 check 3 \n");
}
SUNMatDestroy(C);
SUNMatDestroy(D);
SUNMatDestroy(E);
N_VDestroy(u);
N_VDestroy(v);
return(0);
}
SpgmrMem SpgmrMalloc(int l_max, N_Vector vec_tmpl)
{
SpgmrMem mem;
N_Vector *V, 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 Hessenberg matrix Hes. */
Hes = NULL;
Hes = (realtype **) malloc((l_max+1)*sizeof(realtype *));
if (Hes == NULL) {
N_VDestroyVectorArray(V, 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);
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);
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);
return(NULL);
}
/* Get memory to hold SPGMR 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);
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);
return(NULL);
}
/* Get memory for an SpgmrMemRec containing SPGMR matrices and vectors. */
mem = NULL;
mem = (SpgmrMem) malloc(sizeof(SpgmrMemRec));
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);
return(NULL);
}
/* Set the fields of mem. */
mem->l_max = l_max;
mem->V = V;
mem->Hes = Hes;
mem->givens = givens;
mem->xcor = xcor;
mem->yg = yg;
mem->vtemp = vtemp;
/* Return the pointer to SPGMR memory. */
return(mem);
}
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 == SUNFALSE) {
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 = SUNTRUE;
/* 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 && (IDA_mem->ida_id == NULL)) {
IDAProcessError(IDA_mem, IDA_ILL_INPUT, "IDA", "IDACalcIC", MSG_IC_MISSING_ID);
return(IDA_ILL_INPUT);
}
tdist = SUNRabs(tout1 - IDA_mem->ida_tn);
troundoff = TWO * IDA_mem->ida_uround * (SUNRabs(IDA_mem->ida_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 */
IDA_mem->ida_yy0 = N_VClone(IDA_mem->ida_ee);
IDA_mem->ida_yp0 = N_VClone(IDA_mem->ida_ee);
IDA_mem->ida_t0 = IDA_mem->ida_tn;
N_VScale(ONE, IDA_mem->ida_phi[0], IDA_mem->ida_yy0);
N_VScale(ONE, IDA_mem->ida_phi[1], IDA_mem->ida_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(IDA_mem->ida_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 = IDA_mem->ida_epiccon;
/* Initializations:
cjratio = 1 (for use in direct linear solvers);
set nbacktr = 0; */
IDA_mem->ida_cjratio = ONE;
IDA_mem->ida_nbacktr = 0;
/* Set hic, hh, cj, and mxnh. */
hic = PT001*tdist;
ypnorm = IDAWrmsNorm(IDA_mem, IDA_mem->ida_yp0,
IDA_mem->ida_ewt, IDA_mem->ida_suppressalg);
if(ypnorm > HALF/hic) hic = HALF/ypnorm;
if(tout1 < IDA_mem->ida_tn) hic = -hic;
IDA_mem->ida_hh = hic;
if(icopt == IDA_YA_YDP_INIT) {
IDA_mem->ida_cj = ONE/hic;
mxnh = IDA_mem->ida_maxnh;
}
else {
IDA_mem->ida_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;
IDA_mem->ida_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, IDA_mem->ida_phi[0], IDA_mem->ida_yy0);
N_VScale(ONE, IDA_mem->ida_phi[1], IDA_mem->ida_yp0);
}
hic *= PT1;
IDA_mem->ida_cj = ONE/hic;
IDA_mem->ida_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 = IDA_mem->ida_efun(IDA_mem->ida_yy0, IDA_mem->ida_ewt,
IDA_mem->ida_edata);
if(ewtsetOK != 0) {
retval = IDA_BAD_EWT;
break;
}
N_VScale(ONE, IDA_mem->ida_yy0, IDA_mem->ida_phi[0]);
N_VScale(ONE, IDA_mem->ida_yp0, IDA_mem->ida_phi[1]);
} /* End of nwt loop */
/* Free temporary space */
N_VDestroy(IDA_mem->ida_yy0);
N_VDestroy(IDA_mem->ida_yp0);
/* Load the optional outputs. */
if(icopt == IDA_YA_YDP_INIT) IDA_mem->ida_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);
}
SpbcgMem SpbcgMalloc(int l_max, N_Vector vec_tmpl)
{
SpbcgMem mem;
N_Vector r_star, r, p, q, u, Ap, vtemp;
/* Check the input parameters */
if (l_max <= 0) return(NULL);
/* Get arrays to hold temporary vectors */
r_star = N_VClone(vec_tmpl);
if (r_star == NULL) {
return(NULL);
}
r = N_VClone(vec_tmpl);
if (r == NULL) {
N_VDestroy(r_star);
return(NULL);
}
p = N_VClone(vec_tmpl);
if (p == NULL) {
N_VDestroy(r_star);
N_VDestroy(r);
return(NULL);
}
q = N_VClone(vec_tmpl);
if (q == NULL) {
N_VDestroy(r_star);
N_VDestroy(r);
N_VDestroy(p);
return(NULL);
}
u = N_VClone(vec_tmpl);
if (u == NULL) {
N_VDestroy(r_star);
N_VDestroy(r);
N_VDestroy(p);
N_VDestroy(q);
return(NULL);
}
Ap = N_VClone(vec_tmpl);
if (Ap == NULL) {
N_VDestroy(r_star);
N_VDestroy(r);
N_VDestroy(p);
N_VDestroy(q);
N_VDestroy(u);
return(NULL);
}
vtemp = N_VClone(vec_tmpl);
if (vtemp == NULL) {
N_VDestroy(r_star);
N_VDestroy(r);
N_VDestroy(p);
N_VDestroy(q);
N_VDestroy(u);
N_VDestroy(Ap);
return(NULL);
}
/* Get memory for an SpbcgMemRec containing SPBCG matrices and vectors */
mem = NULL;
mem = (SpbcgMem) malloc(sizeof(SpbcgMemRec));
if (mem == NULL) {
N_VDestroy(r_star);
N_VDestroy(r);
N_VDestroy(p);
N_VDestroy(q);
N_VDestroy(u);
N_VDestroy(Ap);
N_VDestroy(vtemp);
return(NULL);
}
/* Set the fields of mem */
mem->l_max = l_max;
mem->r_star = r_star;
mem->r = r;
mem->p = p;
mem->q = q;
mem->u = u;
mem->Ap = Ap;
mem->vtemp = vtemp;
/* Return the pointer to SPBCG memory */
return(mem);
}
/*---------------------------------------------------------------
User-Callable Functions: initialization, reinit and free
---------------------------------------------------------------*/
int IDABBDPrecInit(void *ida_mem, sunindextype Nlocal,
sunindextype mudq, sunindextype mldq,
sunindextype mukeep, sunindextype mlkeep,
realtype dq_rel_yy,
IDABBDLocalFn Gres, IDABBDCommFn Gcomm)
{
IDAMem IDA_mem;
IDALsMem idals_mem;
IBBDPrecData pdata;
sunindextype muk, mlk, storage_mu, lrw1, liw1;
long int lrw, liw;
int flag;
if (ida_mem == NULL) {
IDAProcessError(NULL, IDALS_MEM_NULL, "IDASBBDPRE",
"IDABBDPrecInit", MSGBBD_MEM_NULL);
return(IDALS_MEM_NULL);
}
IDA_mem = (IDAMem) ida_mem;
/* Test if the LS linear solver interface has been created */
if (IDA_mem->ida_lmem == NULL) {
IDAProcessError(IDA_mem, IDALS_LMEM_NULL, "IDASBBDPRE",
"IDABBDPrecInit", MSGBBD_LMEM_NULL);
return(IDALS_LMEM_NULL);
}
idals_mem = (IDALsMem) IDA_mem->ida_lmem;
/* Test compatibility of NVECTOR package with the BBD preconditioner */
if(IDA_mem->ida_tempv1->ops->nvgetarraypointer == NULL) {
IDAProcessError(IDA_mem, IDALS_ILL_INPUT, "IDASBBDPRE",
"IDABBDPrecInit", MSGBBD_BAD_NVECTOR);
return(IDALS_ILL_INPUT);
}
/* Allocate data memory. */
pdata = NULL;
pdata = (IBBDPrecData) malloc(sizeof *pdata);
if (pdata == NULL) {
IDAProcessError(IDA_mem, IDALS_MEM_FAIL, "IDASBBDPRE",
"IDABBDPrecInit", MSGBBD_MEM_FAIL);
return(IDALS_MEM_FAIL);
}
/* Set pointers to glocal and gcomm; load half-bandwidths. */
pdata->ida_mem = IDA_mem;
pdata->glocal = Gres;
pdata->gcomm = Gcomm;
pdata->mudq = SUNMIN(Nlocal-1, SUNMAX(0, mudq));
pdata->mldq = SUNMIN(Nlocal-1, SUNMAX(0, mldq));
muk = SUNMIN(Nlocal-1, SUNMAX(0, mukeep));
mlk = SUNMIN(Nlocal-1, SUNMAX(0, mlkeep));
pdata->mukeep = muk;
pdata->mlkeep = mlk;
/* Set extended upper half-bandwidth for PP (required for pivoting). */
storage_mu = SUNMIN(Nlocal-1, muk+mlk);
/* Allocate memory for preconditioner matrix. */
pdata->PP = NULL;
pdata->PP = SUNBandMatrixStorage(Nlocal, muk, mlk, storage_mu);
if (pdata->PP == NULL) {
free(pdata); pdata = NULL;
IDAProcessError(IDA_mem, IDALS_MEM_FAIL, "IDASBBDPRE",
"IDABBDPrecInit", MSGBBD_MEM_FAIL);
return(IDALS_MEM_FAIL);
}
/* Allocate memory for temporary N_Vectors */
pdata->zlocal = NULL;
pdata->zlocal = N_VNewEmpty_Serial(Nlocal);
if (pdata->zlocal == NULL) {
SUNMatDestroy(pdata->PP);
free(pdata); pdata = NULL;
IDAProcessError(IDA_mem, IDALS_MEM_FAIL, "IDASBBDPRE",
"IDABBDPrecInit", MSGBBD_MEM_FAIL);
return(IDALS_MEM_FAIL);
}
pdata->rlocal = NULL;
pdata->rlocal = N_VNewEmpty_Serial(Nlocal);
if (pdata->rlocal == NULL) {
N_VDestroy(pdata->zlocal);
SUNMatDestroy(pdata->PP);
free(pdata); pdata = NULL;
IDAProcessError(IDA_mem, IDALS_MEM_FAIL, "IDASBBDPRE",
"IDABBDPrecInit", MSGBBD_MEM_FAIL);
return(IDALS_MEM_FAIL);
}
pdata->tempv1 = NULL;
pdata->tempv1 = N_VClone(IDA_mem->ida_tempv1);
if (pdata->tempv1 == NULL){
N_VDestroy(pdata->rlocal);
N_VDestroy(pdata->zlocal);
SUNMatDestroy(pdata->PP);
free(pdata); pdata = NULL;
IDAProcessError(IDA_mem, IDALS_MEM_FAIL, "IDASBBDPRE",
"IDABBDPrecInit", MSGBBD_MEM_FAIL);
return(IDALS_MEM_FAIL);
}
pdata->tempv2 = NULL;
pdata->tempv2 = N_VClone(IDA_mem->ida_tempv1);
if (pdata->tempv2 == NULL){
N_VDestroy(pdata->rlocal);
N_VDestroy(pdata->zlocal);
N_VDestroy(pdata->tempv1);
SUNMatDestroy(pdata->PP);
free(pdata); pdata = NULL;
IDAProcessError(IDA_mem, IDALS_MEM_FAIL, "IDASBBDPRE",
"IDABBDPrecInit", MSGBBD_MEM_FAIL);
return(IDALS_MEM_FAIL);
}
pdata->tempv3 = NULL;
pdata->tempv3 = N_VClone(IDA_mem->ida_tempv1);
if (pdata->tempv3 == NULL){
N_VDestroy(pdata->rlocal);
N_VDestroy(pdata->zlocal);
N_VDestroy(pdata->tempv1);
N_VDestroy(pdata->tempv2);
SUNMatDestroy(pdata->PP);
free(pdata); pdata = NULL;
IDAProcessError(IDA_mem, IDALS_MEM_FAIL, "IDASBBDPRE",
"IDABBDPrecInit", MSGBBD_MEM_FAIL);
return(IDALS_MEM_FAIL);
}
pdata->tempv4 = NULL;
pdata->tempv4 = N_VClone(IDA_mem->ida_tempv1);
if (pdata->tempv4 == NULL){
N_VDestroy(pdata->rlocal);
N_VDestroy(pdata->zlocal);
N_VDestroy(pdata->tempv1);
N_VDestroy(pdata->tempv2);
N_VDestroy(pdata->tempv3);
SUNMatDestroy(pdata->PP);
free(pdata); pdata = NULL;
IDAProcessError(IDA_mem, IDALS_MEM_FAIL, "IDASBBDPRE",
"IDABBDPrecInit", MSGBBD_MEM_FAIL);
return(IDALS_MEM_FAIL);
}
/* Allocate memory for banded linear solver */
pdata->LS = NULL;
pdata->LS = SUNLinSol_Band(pdata->rlocal, pdata->PP);
if (pdata->LS == NULL) {
N_VDestroy(pdata->zlocal);
N_VDestroy(pdata->rlocal);
N_VDestroy(pdata->tempv1);
N_VDestroy(pdata->tempv2);
N_VDestroy(pdata->tempv3);
N_VDestroy(pdata->tempv4);
SUNMatDestroy(pdata->PP);
free(pdata); pdata = NULL;
IDAProcessError(IDA_mem, IDALS_MEM_FAIL, "IDASBBDPRE",
"IDABBDPrecInit", MSGBBD_MEM_FAIL);
return(IDALS_MEM_FAIL);
}
/* initialize band linear solver object */
flag = SUNLinSolInitialize(pdata->LS);
if (flag != SUNLS_SUCCESS) {
N_VDestroy(pdata->zlocal);
N_VDestroy(pdata->rlocal);
N_VDestroy(pdata->tempv1);
N_VDestroy(pdata->tempv2);
N_VDestroy(pdata->tempv3);
N_VDestroy(pdata->tempv4);
SUNMatDestroy(pdata->PP);
SUNLinSolFree(pdata->LS);
free(pdata); pdata = NULL;
IDAProcessError(IDA_mem, IDALS_SUNLS_FAIL, "IDASBBDPRE",
"IDABBDPrecInit", MSGBBD_SUNLS_FAIL);
return(IDALS_SUNLS_FAIL);
}
/* Set rel_yy based on input value dq_rel_yy (0 implies default). */
pdata->rel_yy = (dq_rel_yy > ZERO) ?
dq_rel_yy : SUNRsqrt(IDA_mem->ida_uround);
/* Store Nlocal to be used in IDABBDPrecSetup */
pdata->n_local = Nlocal;
/* Set work space sizes and initialize nge. */
pdata->rpwsize = 0;
pdata->ipwsize = 0;
if (IDA_mem->ida_tempv1->ops->nvspace) {
N_VSpace(IDA_mem->ida_tempv1, &lrw1, &liw1);
pdata->rpwsize += 4*lrw1;
pdata->ipwsize += 4*liw1;
}
if (pdata->rlocal->ops->nvspace) {
N_VSpace(pdata->rlocal, &lrw1, &liw1);
pdata->rpwsize += 2*lrw1;
pdata->ipwsize += 2*liw1;
}
if (pdata->PP->ops->space) {
flag = SUNMatSpace(pdata->PP, &lrw, &liw);
pdata->rpwsize += lrw;
pdata->ipwsize += liw;
}
if (pdata->LS->ops->space) {
flag = SUNLinSolSpace(pdata->LS, &lrw, &liw);
pdata->rpwsize += lrw;
pdata->ipwsize += liw;
}
pdata->nge = 0;
/* make sure pdata is free from any previous allocations */
if (idals_mem->pfree)
idals_mem->pfree(IDA_mem);
/* Point to the new pdata field in the LS memory */
idals_mem->pdata = pdata;
/* Attach the pfree function */
idals_mem->pfree = IDABBDPrecFree;
/* Attach preconditioner solve and setup functions */
flag = IDASetPreconditioner(ida_mem, IDABBDPrecSetup,
IDABBDPrecSolve);
return(flag);
}
