/*-----------------------------------------------------------------
cvLsDenseDQJac
This routine generates a dense difference quotient approximation
to the Jacobian of f(t,y). It assumes that a dense SUNMatrix is
stored column-wise, and that elements within each column are
contiguous. The address of the jth column of J is obtained via
the accessor function SUNDenseMatrix_Column, and this pointer
is associated with an N_Vector using the N_VSetArrayPointer
function. Finally, the actual computation of the jth column of
the Jacobian is done with a call to N_VLinearSum.
-----------------------------------------------------------------*/
int cvLsDenseDQJac(realtype t, N_Vector y, N_Vector fy,
SUNMatrix Jac, CVodeMem cv_mem, N_Vector tmp1)
{
realtype fnorm, minInc, inc, inc_inv, yjsaved, srur, conj;
realtype *y_data, *ewt_data, *cns_data;
N_Vector ftemp, jthCol;
sunindextype j, N;
CVLsMem cvls_mem;
int retval = 0;
/* access LsMem interface structure */
cvls_mem = (CVLsMem) cv_mem->cv_lmem;
/* access matrix dimension */
N = SUNDenseMatrix_Rows(Jac);
/* Rename work vector for readibility */
ftemp = tmp1;
/* Create an empty vector for matrix column calculations */
jthCol = N_VCloneEmpty(tmp1);
/* Obtain pointers to the data for ewt, y */
ewt_data = N_VGetArrayPointer(cv_mem->cv_ewt);
y_data = N_VGetArrayPointer(y);
if (cv_mem->cv_constraints != NULL)
cns_data = N_VGetArrayPointer(cv_mem->cv_constraints);
/* Set minimum increment based on uround and norm of f */
srur = SUNRsqrt(cv_mem->cv_uround);
fnorm = N_VWrmsNorm(fy, cv_mem->cv_ewt);
minInc = (fnorm != ZERO) ?
(MIN_INC_MULT * SUNRabs(cv_mem->cv_h) * cv_mem->cv_uround * N * fnorm) : ONE;
for (j = 0; j < N; j++) {
/* Generate the jth col of J(tn,y) */
N_VSetArrayPointer(SUNDenseMatrix_Column(Jac,j), jthCol);
yjsaved = y_data[j];
inc = SUNMAX(srur*SUNRabs(yjsaved), minInc/ewt_data[j]);
/* Adjust sign(inc) if y_j has an inequality constraint. */
if (cv_mem->cv_constraints != NULL) {
conj = cns_data[j];
if (SUNRabs(conj) == ONE) {if ((yjsaved+inc)*conj < ZERO) inc = -inc;}
else if (SUNRabs(conj) == TWO) {if ((yjsaved+inc)*conj <= ZERO) inc = -inc;}
}
y_data[j] += inc;
retval = cv_mem->cv_f(t, y, ftemp, cv_mem->cv_user_data);
cvls_mem->nfeDQ++;
if (retval != 0) break;
y_data[j] = yjsaved;
inc_inv = ONE/inc;
N_VLinearSum(inc_inv, ftemp, -inc_inv, fy, jthCol);
}
/* Destroy jthCol vector */
N_VSetArrayPointer(NULL, jthCol); /* SHOULDN'T BE NEEDED */
N_VDestroy(jthCol);
return(retval);
}
/*-----------------------------------------------------------------
cvLsBandDQJac
This routine generates a banded difference quotient approximation
to the Jacobian of f(t,y). It assumes that a band SUNMatrix is
stored column-wise, and that elements within each column are
contiguous. This makes it possible to get the address of a column
of J via the accessor function SUNBandMatrix_Column, and to write
a simple for loop to set each of the elements of a column in
succession.
-----------------------------------------------------------------*/
int cvLsBandDQJac(realtype t, N_Vector y, N_Vector fy, SUNMatrix Jac,
CVodeMem cv_mem, N_Vector tmp1, N_Vector tmp2)
{
N_Vector ftemp, ytemp;
realtype fnorm, minInc, inc, inc_inv, srur, conj;
realtype *col_j, *ewt_data, *fy_data, *ftemp_data;
realtype *y_data, *ytemp_data, *cns_data;
sunindextype group, i, j, width, ngroups, i1, i2;
sunindextype N, mupper, mlower;
CVLsMem cvls_mem;
int retval = 0;
/* access LsMem interface structure */
cvls_mem = (CVLsMem) cv_mem->cv_lmem;
/* access matrix dimensions */
N = SUNBandMatrix_Columns(Jac);
mupper = SUNBandMatrix_UpperBandwidth(Jac);
mlower = SUNBandMatrix_LowerBandwidth(Jac);
/* Rename work vectors for use as temporary values of y and f */
ftemp = tmp1;
ytemp = tmp2;
/* Obtain pointers to the data for ewt, fy, ftemp, y, ytemp */
ewt_data = N_VGetArrayPointer(cv_mem->cv_ewt);
fy_data = N_VGetArrayPointer(fy);
ftemp_data = N_VGetArrayPointer(ftemp);
y_data = N_VGetArrayPointer(y);
ytemp_data = N_VGetArrayPointer(ytemp);
if (cv_mem->cv_constraints != NULL)
cns_data = N_VGetArrayPointer(cv_mem->cv_constraints);
/* Load ytemp with y = predicted y vector */
N_VScale(ONE, y, ytemp);
/* Set minimum increment based on uround and norm of f */
srur = SUNRsqrt(cv_mem->cv_uround);
fnorm = N_VWrmsNorm(fy, cv_mem->cv_ewt);
minInc = (fnorm != ZERO) ?
(MIN_INC_MULT * SUNRabs(cv_mem->cv_h) * cv_mem->cv_uround * N * fnorm) : ONE;
/* Set bandwidth and number of column groups for band differencing */
width = mlower + mupper + 1;
ngroups = SUNMIN(width, N);
/* Loop over column groups. */
for (group=1; group <= ngroups; group++) {
/* Increment all y_j in group */
for(j=group-1; j < N; j+=width) {
inc = SUNMAX(srur*SUNRabs(y_data[j]), minInc/ewt_data[j]);
/* Adjust sign(inc) if yj has an inequality constraint. */
if (cv_mem->cv_constraints != NULL) {
conj = cns_data[j];
if (SUNRabs(conj) == ONE) {if ((ytemp_data[j]+inc)*conj < ZERO) inc = -inc;}
else if (SUNRabs(conj) == TWO) {if ((ytemp_data[j]+inc)*conj <= ZERO) inc = -inc;}
}
ytemp_data[j] += inc;
}
/* Evaluate f with incremented y */
retval = cv_mem->cv_f(cv_mem->cv_tn, ytemp, ftemp, cv_mem->cv_user_data);
cvls_mem->nfeDQ++;
if (retval != 0) break;
/* Restore ytemp, then form and load difference quotients */
for (j=group-1; j < N; j+=width) {
ytemp_data[j] = y_data[j];
col_j = SUNBandMatrix_Column(Jac, j);
inc = SUNMAX(srur*SUNRabs(y_data[j]), minInc/ewt_data[j]);
/* Adjust sign(inc) as before. */
if (cv_mem->cv_constraints != NULL) {
conj = cns_data[j];
if (SUNRabs(conj) == ONE) {if ((ytemp_data[j]+inc)*conj < ZERO) inc = -inc;}
else if (SUNRabs(conj) == TWO) {if ((ytemp_data[j]+inc)*conj <= ZERO) inc = -inc;}
}
inc_inv = ONE/inc;
i1 = SUNMAX(0, j-mupper);
i2 = SUNMIN(j+mlower, N-1);
for (i=i1; i <= i2; i++)
SM_COLUMN_ELEMENT_B(col_j,i,j) = inc_inv * (ftemp_data[i] - fy_data[i]);
}
}
return(retval);
}
/*-----------------------------------------------------------------
cvLsSolve
This routine interfaces between CVode and the generic
SUNLinearSolver object LS, by setting the appropriate tolerance
and scaling vectors, calling the solver, and accumulating
statistics from the solve for use/reporting by CVode.
-----------------------------------------------------------------*/
int cvLsSolve(CVodeMem cv_mem, N_Vector b, N_Vector weight,
N_Vector ynow, N_Vector fnow)
{
CVLsMem cvls_mem;
realtype bnorm, deltar, delta, w_mean;
int curiter, nli_inc, retval, LSType;
/* access CVLsMem structure */
if (cv_mem->cv_lmem==NULL) {
cvProcessError(cv_mem, CVLS_LMEM_NULL, "CVLS",
"cvLsSolve", MSG_LS_LMEM_NULL);
return(CVLS_LMEM_NULL);
}
cvls_mem = (CVLsMem) cv_mem->cv_lmem;
/* Retrieve the LS type */
LSType = SUNLinSolGetType(cvls_mem->LS);
/* get current nonlinear solver iteration */
retval = SUNNonlinSolGetCurIter(cv_mem->NLS, &curiter);
/* If the linear solver is iterative:
test norm(b), if small, return x = 0 or x = b;
set linear solver tolerance (in left/right scaled 2-norm) */
if ( (LSType == SUNLINEARSOLVER_ITERATIVE) ||
(LSType == SUNLINEARSOLVER_MATRIX_ITERATIVE) ) {
deltar = cvls_mem->eplifac * cv_mem->cv_tq[4];
bnorm = N_VWrmsNorm(b, weight);
if (bnorm <= deltar) {
if (curiter > 0) N_VConst(ZERO, b);
cvls_mem->last_flag = CVLS_SUCCESS;
return(cvls_mem->last_flag);
}
delta = deltar * cvls_mem->sqrtN;
} else {
delta = ZERO;
}
/* Set vectors ycur and fcur for use by the Atimes and Psolve
interface routines */
cvls_mem->ycur = ynow;
cvls_mem->fcur = fnow;
/* Set initial guess x = 0 to LS */
N_VConst(ZERO, cvls_mem->x);
/* Set scaling vectors for LS to use (if applicable) */
if (cvls_mem->LS->ops->setscalingvectors) {
retval = SUNLinSolSetScalingVectors(cvls_mem->LS,
weight,
weight);
if (retval != SUNLS_SUCCESS) {
cvProcessError(cv_mem, CVLS_SUNLS_FAIL, "CVLS", "cvLsSolve",
"Error in calling SUNLinSolSetScalingVectors");
cvls_mem->last_flag = CVLS_SUNLS_FAIL;
return(cvls_mem->last_flag);
}
/* If solver is iterative and does not support scaling vectors, update the
tolerance in an attempt to account for weight vector. We make the
following assumptions:
1. w_i = w_mean, for i=0,...,n-1 (i.e. the weights are homogeneous)
2. the linear solver uses a basic 2-norm to measure convergence
Hence (using the notation from sunlinsol_spgmr.h, with S = diag(w)),
|| bbar - Abar xbar ||_2 < tol
<=> || S b - S A x ||_2 < tol
<=> || S (b - A x) ||_2 < tol
<=> \sum_{i=0}^{n-1} (w_i (b - A x)_i)^2 < tol^2
<=> w_mean^2 \sum_{i=0}^{n-1} (b - A x_i)^2 < tol^2
<=> \sum_{i=0}^{n-1} (b - A x_i)^2 < tol^2 / w_mean^2
<=> || b - A x ||_2 < tol / w_mean
So we compute w_mean = ||w||_RMS = ||w||_2 / sqrt(n), and scale
the desired tolerance accordingly. */
} else if ( (LSType == SUNLINEARSOLVER_ITERATIVE) ||
(LSType == SUNLINEARSOLVER_MATRIX_ITERATIVE) ) {
w_mean = SUNRsqrt( N_VDotProd(weight, weight) ) / cvls_mem->sqrtN;
delta /= w_mean;
}
/* If a user-provided jtsetup routine is supplied, call that here */
if (cvls_mem->jtsetup) {
cvls_mem->last_flag = cvls_mem->jtsetup(cv_mem->cv_tn, ynow, fnow,
cvls_mem->jt_data);
cvls_mem->njtsetup++;
if (cvls_mem->last_flag != 0) {
cvProcessError(cv_mem, retval, "CVLS",
"cvLsSolve", MSG_LS_JTSETUP_FAILED);
return(cvls_mem->last_flag);
}
}
/* Call solver, and copy x to b */
retval = SUNLinSolSolve(cvls_mem->LS, cvls_mem->A, cvls_mem->x, b, delta);
N_VScale(ONE, cvls_mem->x, b);
/* If using a direct or matrix-iterative solver, BDF method, and gamma has changed,
scale the correction to account for change in gamma */
if ( ((LSType == SUNLINEARSOLVER_DIRECT) ||
(LSType == SUNLINEARSOLVER_MATRIX_ITERATIVE)) &&
(cv_mem->cv_lmm == CV_BDF) &&
(cv_mem->cv_gamrat != ONE) )
N_VScale(TWO/(ONE + cv_mem->cv_gamrat), b, b);
/* Retrieve statistics from iterative linear solvers */
nli_inc = 0;
if ( ((LSType == SUNLINEARSOLVER_ITERATIVE) ||
(LSType == SUNLINEARSOLVER_MATRIX_ITERATIVE)) &&
(cvls_mem->LS->ops->numiters) )
nli_inc = SUNLinSolNumIters(cvls_mem->LS);
/* Increment counters nli and ncfl */
cvls_mem->nli += nli_inc;
if (retval != SUNLS_SUCCESS) cvls_mem->ncfl++;
/* Interpret solver return value */
cvls_mem->last_flag = retval;
switch(retval) {
case SUNLS_SUCCESS:
return(0);
break;
case SUNLS_RES_REDUCED:
/* allow reduction but not solution on first Newton iteration,
otherwise return with a recoverable failure */
if (curiter == 0) return(0);
else return(1);
break;
case SUNLS_CONV_FAIL:
case SUNLS_ATIMES_FAIL_REC:
case SUNLS_PSOLVE_FAIL_REC:
case SUNLS_PACKAGE_FAIL_REC:
case SUNLS_QRFACT_FAIL:
case SUNLS_LUFACT_FAIL:
return(1);
break;
case SUNLS_MEM_NULL:
case SUNLS_ILL_INPUT:
case SUNLS_MEM_FAIL:
case SUNLS_GS_FAIL:
case SUNLS_QRSOL_FAIL:
return(-1);
break;
case SUNLS_PACKAGE_FAIL_UNREC:
cvProcessError(cv_mem, SUNLS_PACKAGE_FAIL_UNREC, "CVLS",
"cvLsSolve",
"Failure in SUNLinSol external package");
return(-1);
break;
case SUNLS_ATIMES_FAIL_UNREC:
cvProcessError(cv_mem, SUNLS_ATIMES_FAIL_UNREC, "CVLS",
"cvLsSolve", MSG_LS_JTIMES_FAILED);
return(-1);
break;
case SUNLS_PSOLVE_FAIL_UNREC:
cvProcessError(cv_mem, SUNLS_PSOLVE_FAIL_UNREC, "CVLS",
"cvLsSolve", MSG_LS_PSOLVE_FAILED);
return(-1);
break;
}
return(0);
}
/*---------------------------------------------------------------
CVodeSetLinearSolver specifies the linear solver
---------------------------------------------------------------*/
int CVodeSetLinearSolver(void *cvode_mem, SUNLinearSolver LS,
SUNMatrix A)
{
CVodeMem cv_mem;
CVLsMem cvls_mem;
int retval, LSType;
/* Return immediately if either cvode_mem or LS inputs are NULL */
if (cvode_mem == NULL) {
cvProcessError(NULL, CVLS_MEM_NULL, "CVLS",
"CVodeSetLinearSolver", MSG_LS_CVMEM_NULL);
return(CVLS_MEM_NULL);
}
if (LS == NULL) {
cvProcessError(NULL, CVLS_ILL_INPUT, "CVLS",
"CVodeSetLinearSolver",
"LS must be non-NULL");
return(CVLS_ILL_INPUT);
}
cv_mem = (CVodeMem) cvode_mem;
/* Test if solver is compatible with LS interface */
if ( (LS->ops->gettype == NULL) ||
(LS->ops->initialize == NULL) ||
(LS->ops->setup == NULL) ||
(LS->ops->solve == NULL) ) {
cvProcessError(cv_mem, CVLS_ILL_INPUT, "CVLS",
"CVodeSetLinearSolver",
"LS object is missing a required operation");
return(CVLS_ILL_INPUT);
}
/* Test if vector is compatible with LS interface */
if ( (cv_mem->cv_tempv->ops->nvconst == NULL) ||
(cv_mem->cv_tempv->ops->nvdotprod == NULL) ) {
cvProcessError(cv_mem, CVLS_ILL_INPUT, "CVLS",
"CVodeSetLinearSolver", MSG_LS_BAD_NVECTOR);
return(CVLS_ILL_INPUT);
}
/* Retrieve the LS type */
LSType = SUNLinSolGetType(LS);
/* Check for compatible LS type, matrix and "atimes" support */
if ((LSType == SUNLINEARSOLVER_ITERATIVE) && (LS->ops->setatimes == NULL)) {
cvProcessError(cv_mem, CVLS_ILL_INPUT, "CVLS", "CVodeSetLinearSolver",
"Incompatible inputs: iterative LS must support ATimes routine");
return(CVLS_ILL_INPUT);
}
if ((LSType == SUNLINEARSOLVER_DIRECT) && (A == NULL)) {
cvProcessError(cv_mem, CVLS_ILL_INPUT, "CVLS", "CVodeSetLinearSolver",
"Incompatible inputs: direct LS requires non-NULL matrix");
return(CVLS_ILL_INPUT);
}
if ((LSType == SUNLINEARSOLVER_MATRIX_ITERATIVE) && (A == NULL)) {
cvProcessError(cv_mem, CVLS_ILL_INPUT, "CVLS", "CVodeSetLinearSolver",
"Incompatible inputs: matrix-iterative LS requires non-NULL matrix");
return(CVLS_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 = cvLsInitialize;
cv_mem->cv_lsetup = cvLsSetup;
cv_mem->cv_lsolve = cvLsSolve;
cv_mem->cv_lfree = cvLsFree;
/* Allocate memory for CVLsMemRec */
cvls_mem = NULL;
cvls_mem = (CVLsMem) malloc(sizeof(struct CVLsMemRec));
if (cvls_mem == NULL) {
cvProcessError(cv_mem, CVLS_MEM_FAIL, "CVLS",
"CVodeSetLinearSolver", MSG_LS_MEM_FAIL);
return(CVLS_MEM_FAIL);
}
memset(cvls_mem, 0, sizeof(struct CVLsMemRec));
/* set SUNLinearSolver pointer */
cvls_mem->LS = LS;
/* Set defaults for Jacobian-related fields */
if (A != NULL) {
cvls_mem->jacDQ = SUNTRUE;
cvls_mem->jac = cvLsDQJac;
cvls_mem->J_data = cv_mem;
} else {
cvls_mem->jacDQ = SUNFALSE;
cvls_mem->jac = NULL;
cvls_mem->J_data = NULL;
}
cvls_mem->jtimesDQ = SUNTRUE;
cvls_mem->jtsetup = NULL;
cvls_mem->jtimes = cvLsDQJtimes;
cvls_mem->jt_data = cv_mem;
/* Set defaults for preconditioner-related fields */
cvls_mem->pset = NULL;
cvls_mem->psolve = NULL;
cvls_mem->pfree = NULL;
cvls_mem->P_data = cv_mem->cv_user_data;
/* Initialize counters */
cvLsInitializeCounters(cvls_mem);
/* Set default values for the rest of the LS parameters */
cvls_mem->msbj = CVLS_MSBJ;
cvls_mem->jbad = SUNTRUE;
cvls_mem->eplifac = CVLS_EPLIN;
cvls_mem->last_flag = CVLS_SUCCESS;
/* If LS supports ATimes, attach CVLs routine */
if (LS->ops->setatimes) {
retval = SUNLinSolSetATimes(LS, cv_mem, cvLsATimes);
if (retval != SUNLS_SUCCESS) {
cvProcessError(cv_mem, CVLS_SUNLS_FAIL, "CVLS",
"CVodeSetLinearSolver",
"Error in calling SUNLinSolSetATimes");
free(cvls_mem); cvls_mem = NULL;
return(CVLS_SUNLS_FAIL);
}
}
/* If LS supports preconditioning, initialize pset/psol to NULL */
if (LS->ops->setpreconditioner) {
retval = SUNLinSolSetPreconditioner(LS, cv_mem, NULL, NULL);
if (retval != SUNLS_SUCCESS) {
cvProcessError(cv_mem, CVLS_SUNLS_FAIL, "CVLS",
"CVodeSetLinearSolver",
"Error in calling SUNLinSolSetPreconditioner");
free(cvls_mem); cvls_mem = NULL;
return(CVLS_SUNLS_FAIL);
}
}
/* When using a non-NULL SUNMatrix object, store pointer to A and create saved_J */
if (A != NULL) {
cvls_mem->A = A;
cvls_mem->savedJ = SUNMatClone(A);
if (cvls_mem->savedJ == NULL) {
cvProcessError(cv_mem, CVLS_MEM_FAIL, "CVLS",
"CVodeSetLinearSolver", MSG_LS_MEM_FAIL);
free(cvls_mem); cvls_mem = NULL;
return(CVLS_MEM_FAIL);
}
}
/* Allocate memory for ytemp and x */
cvls_mem->ytemp = N_VClone(cv_mem->cv_tempv);
if (cvls_mem->ytemp == NULL) {
cvProcessError(cv_mem, CVLS_MEM_FAIL, "CVLS",
"CVodeSetLinearSolver", MSG_LS_MEM_FAIL);
SUNMatDestroy(cvls_mem->savedJ);
free(cvls_mem); cvls_mem = NULL;
return(CVLS_MEM_FAIL);
}
cvls_mem->x = N_VClone(cv_mem->cv_tempv);
if (cvls_mem->x == NULL) {
cvProcessError(cv_mem, CVLS_MEM_FAIL, "CVLS",
"CVodeSetLinearSolver", MSG_LS_MEM_FAIL);
SUNMatDestroy(cvls_mem->savedJ);
N_VDestroy(cvls_mem->ytemp);
free(cvls_mem); cvls_mem = NULL;
return(CVLS_MEM_FAIL);
}
/* For iterative LS, compute sqrtN from a dot product */
if ( (LSType == SUNLINEARSOLVER_ITERATIVE) ||
(LSType == SUNLINEARSOLVER_MATRIX_ITERATIVE) ) {
N_VConst(ONE, cvls_mem->ytemp);
cvls_mem->sqrtN = SUNRsqrt( N_VDotProd(cvls_mem->ytemp,
cvls_mem->ytemp) );
}
/* Attach linear solver memory to integrator memory */
cv_mem->cv_lmem = cvls_mem;
return(CVLS_SUCCESS);
}
/*
* -----------------------------------------------------------------
* idaDlsDenseDQJac
* -----------------------------------------------------------------
* This routine generates a dense difference quotient approximation to
* the Jacobian F_y + c_j*F_y'. It assumes that a dense matrix of type
* DlsMat is stored column-wise, and that elements within each column
* are contiguous. The address of the jth column of J is obtained via
* the macro LAPACK_DENSE_COL and this pointer is associated with an N_Vector
* using the N_VGetArrayPointer/N_VSetArrayPointer functions.
* Finally, the actual computation of the jth column of the Jacobian is
* done with a call to N_VLinearSum.
* -----------------------------------------------------------------
*/
int idaDlsDenseDQJac(long int N, realtype tt, realtype c_j,
N_Vector yy, N_Vector yp, N_Vector rr,
DlsMat Jac, void *data,
N_Vector tmp1, N_Vector tmp2, N_Vector tmp3)
{
realtype inc, inc_inv, yj, ypj, srur, conj;
realtype *tmp2_data, *y_data, *yp_data, *ewt_data, *cns_data = NULL;
N_Vector rtemp, jthCol;
long int j;
int retval = 0;
IDAMem IDA_mem;
IDADlsMem idadls_mem;
/* data points to IDA_mem */
IDA_mem = (IDAMem) data;
idadls_mem = (IDADlsMem) lmem;
/* Save pointer to the array in tmp2 */
tmp2_data = N_VGetArrayPointer(tmp2);
/* Rename work vectors for readibility */
rtemp = tmp1;
jthCol = tmp2;
/* Obtain pointers to the data for ewt, yy, yp. */
ewt_data = N_VGetArrayPointer(ewt);
y_data = N_VGetArrayPointer(yy);
yp_data = N_VGetArrayPointer(yp);
if(constraints!=NULL) cns_data = N_VGetArrayPointer(constraints);
srur = SUNRsqrt(uround);
for (j=0; j < N; j++) {
/* Generate the jth col of J(tt,yy,yp) as delta(F)/delta(y_j). */
/* Set data address of jthCol, and save y_j and yp_j values. */
N_VSetArrayPointer(DENSE_COL(Jac,j), jthCol);
yj = y_data[j];
ypj = yp_data[j];
/* Set increment inc to y_j based on sqrt(uround)*abs(y_j), with
adjustments using yp_j and ewt_j if this is small, and a further
adjustment to give it the same sign as hh*yp_j. */
inc = SUNMAX( srur * SUNMAX( SUNRabs(yj), SUNRabs(hh*ypj) ) , ONE/ewt_data[j] );
if (hh*ypj < ZERO) inc = -inc;
inc = (yj + inc) - yj;
/* Adjust sign(inc) again if y_j has an inequality constraint. */
if (constraints != NULL) {
conj = cns_data[j];
if (SUNRabs(conj) == ONE) {if((yj+inc)*conj < ZERO) inc = -inc;}
else if (SUNRabs(conj) == TWO) {if((yj+inc)*conj <= ZERO) inc = -inc;}
}
/* Increment y_j and yp_j, call res, and break on error return. */
y_data[j] += inc;
yp_data[j] += c_j*inc;
retval = res(tt, yy, yp, rtemp, user_data);
nreDQ++;
if (retval != 0) break;
/* Construct difference quotient in jthCol */
inc_inv = ONE/inc;
N_VLinearSum(inc_inv, rtemp, -inc_inv, rr, jthCol);
DENSE_COL(Jac,j) = N_VGetArrayPointer(jthCol);
/* reset y_j, yp_j */
y_data[j] = yj;
yp_data[j] = ypj;
}
/* Restore original array pointer in tmp2 */
N_VSetArrayPointer(tmp2_data, tmp2);
return(retval);
}
/*---------------------------------------------------------------
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);
}
int IDASpbcg(void *ida_mem, int maxl)
{
IDAMem IDA_mem;
IDASpilsMem idaspils_mem;
SpbcgMem spbcg_mem;
int maxl1;
/* Return immediately if ida_mem is NULL */
if (ida_mem == NULL) {
IDAProcessError(NULL, IDASPILS_MEM_NULL, "IDASPBCG", "IDASpbcg", 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, "IDASPBCG", "IDASpbcg", MSGS_BAD_NVECTOR);
return(IDASPILS_ILL_INPUT);
}
if (lfree != NULL) lfree((IDAMem) ida_mem);
/* Set five main function fields in ida_mem */
linit = IDASpbcgInit;
lsetup = IDASpbcgSetup;
lsolve = IDASpbcgSolve;
lperf = IDASpbcgPerf;
lfree = IDASpbcgFree;
/* Get memory for IDASpilsMemRec */
idaspils_mem = NULL;
idaspils_mem = (IDASpilsMem) malloc(sizeof(struct IDASpilsMemRec));
if (idaspils_mem == NULL) {
IDAProcessError(NULL, IDASPILS_MEM_FAIL, "IDASPBCG", "IDASpbcg", MSGS_MEM_FAIL);
return(IDASPILS_MEM_FAIL);
}
/* Set ILS type */
idaspils_mem->s_type = SPILS_SPBCG;
/* Set SPBCG 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 Spbcg parameters */
idaspils_mem->s_eplifac = PT05;
idaspils_mem->s_dqincfac = ONE;
idaspils_mem->s_last_flag = IDASPILS_SUCCESS;
idaSpilsInitializeCounters(idaspils_mem);
/* 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, "IDASPBCG", "IDASpbcg", 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, "IDASPBCG", "IDASpbcg", 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, "IDASPBCG", "IDASpbcg", 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 = SUNRsqrt(N_VDotProd(ytemp, ytemp));
/* Call SpbcgMalloc to allocate workspace for Spbcg */
spbcg_mem = NULL;
spbcg_mem = SpbcgMalloc(maxl1, vec_tmpl);
if (spbcg_mem == NULL) {
IDAProcessError(NULL, IDASPILS_MEM_FAIL, "IDASPBCG", "IDASpbcg", MSGS_MEM_FAIL);
N_VDestroy(ytemp);
N_VDestroy(yptemp);
N_VDestroy(xx);
free(idaspils_mem); idaspils_mem = NULL;
return(IDASPILS_MEM_FAIL);
}
/* Attach SPBCG memory to spils memory structure */
spils_mem = (void *)spbcg_mem;
/* Attach linear solver memory to the integrator memory */
lmem = idaspils_mem;
return(IDASPILS_SUCCESS);
}
/*----------------------------------------------------------------
Function : SpfgmrSolve
---------------------------------------------------------------*/
int SpfgmrSolve(SpfgmrMem mem, void *A_data, N_Vector x,
N_Vector b, int pretype, int gstype, realtype delta,
int max_restarts, int maxit, void *P_data,
N_Vector s1, N_Vector s2, ATimesFn atimes,
PSolveFn psolve, realtype *res_norm, int *nli, int *nps)
{
N_Vector *V, *Z, xcor, vtemp;
realtype **Hes, *givens, *yg;
realtype beta, rotation_product, r_norm, s_product, rho;
booleantype preOnRight, scale1, scale2, converged;
int i, j, k, l, l_max, krydim, ier, ntries;
if (mem == NULL) return(SPFGMR_MEM_NULL);
/* Initialize some variables */
krydim = 0;
/* Make local copies of mem variables. */
l_max = mem->l_max;
V = mem->V;
Z = mem->Z;
Hes = mem->Hes;
givens = mem->givens;
xcor = mem->xcor;
yg = mem->yg;
vtemp = mem->vtemp;
*nli = *nps = 0; /* Initialize counters */
converged = SUNFALSE; /* Initialize converged flag */
/* If maxit is greater than l_max, then set maxit=l_max */
if (maxit > l_max) maxit = l_max;
/* Check for legal value of max_restarts */
if (max_restarts < 0) max_restarts = 0;
/* Set preconditioning flag (enabling any preconditioner implies right
preconditioning, since FGMRES does not support left preconditioning) */
preOnRight = ((pretype == PREC_RIGHT) || (pretype == PREC_BOTH) || (pretype == PREC_LEFT));
/* Set scaling flags */
scale1 = (s1 != NULL);
scale2 = (s2 != NULL);
/* Set vtemp to initial (unscaled) residual r_0 = b - A*x_0. */
if (N_VDotProd(x, x) == ZERO) {
N_VScale(ONE, b, vtemp);
} else {
ier = atimes(A_data, x, vtemp);
if (ier != 0)
return((ier < 0) ? SPFGMR_ATIMES_FAIL_UNREC : SPFGMR_ATIMES_FAIL_REC);
N_VLinearSum(ONE, b, -ONE, vtemp, vtemp);
}
/* Apply left scaling to vtemp = r_0 to fill V[0]. */
if (scale1) {
N_VProd(s1, vtemp, V[0]);
} else {
N_VScale(ONE, vtemp, V[0]);
}
/* Set r_norm = beta to L2 norm of V[0] = s1 r_0, and return if small */
*res_norm = r_norm = beta = SUNRsqrt(N_VDotProd(V[0], V[0]));
if (r_norm <= delta)
return(SPFGMR_SUCCESS);
/* Initialize rho to avoid compiler warning message */
rho = beta;
/* Set xcor = 0. */
N_VConst(ZERO, xcor);
/* Begin outer iterations: up to (max_restarts + 1) attempts. */
for (ntries=0; ntries<=max_restarts; ntries++) {
/* Initialize the Hessenberg matrix Hes and Givens rotation
product. Normalize the initial vector V[0]. */
for (i=0; i<=l_max; i++)
for (j=0; j<l_max; j++)
Hes[i][j] = ZERO;
rotation_product = ONE;
N_VScale(ONE/r_norm, V[0], V[0]);
/* Inner loop: generate Krylov sequence and Arnoldi basis. */
for (l=0; l<maxit; l++) {
(*nli)++;
krydim = l + 1;
/* Generate A-tilde V[l], where A-tilde = s1 A P_inv s2_inv. */
/* Apply right scaling: vtemp = s2_inv V[l]. */
if (scale2) N_VDiv(V[l], s2, vtemp);
else N_VScale(ONE, V[l], vtemp);
/* Apply right preconditioner: vtemp = Z[l] = P_inv s2_inv V[l]. */
if (preOnRight) {
N_VScale(ONE, vtemp, V[l+1]);
ier = psolve(P_data, V[l+1], vtemp, delta, PREC_RIGHT);
(*nps)++;
if (ier != 0)
return((ier < 0) ? SPFGMR_PSOLVE_FAIL_UNREC : SPFGMR_PSOLVE_FAIL_REC);
}
N_VScale(ONE, vtemp, Z[l]);
/* Apply A: V[l+1] = A P_inv s2_inv V[l]. */
ier = atimes(A_data, vtemp, V[l+1]);
if (ier != 0)
return((ier < 0) ? SPFGMR_ATIMES_FAIL_UNREC : SPFGMR_ATIMES_FAIL_REC);
/* Apply left scaling: V[l+1] = s1 A P_inv s2_inv V[l]. */
if (scale1) N_VProd(s1, V[l+1], V[l+1]);
/* Orthogonalize V[l+1] against previous V[i]: V[l+1] = w_tilde. */
if (gstype == CLASSICAL_GS) {
if (ClassicalGS(V, Hes, l+1, l_max, &(Hes[l+1][l]),
vtemp, yg) != 0)
return(SPFGMR_GS_FAIL);
} else {
if (ModifiedGS(V, Hes, l+1, l_max, &(Hes[l+1][l])) != 0)
return(SPFGMR_GS_FAIL);
}
/* Update the QR factorization of Hes. */
if(QRfact(krydim, Hes, givens, l) != 0 )
return(SPFGMR_QRFACT_FAIL);
/* Update residual norm estimate; break if convergence test passes. */
rotation_product *= givens[2*l+1];
*res_norm = rho = SUNRabs(rotation_product*r_norm);
if (rho <= delta) { converged = SUNTRUE; break; }
/* Normalize V[l+1] with norm value from the Gram-Schmidt routine. */
N_VScale(ONE/Hes[l+1][l], V[l+1], V[l+1]);
}
/* Inner loop is done. Compute the new correction vector xcor. */
/* Construct g, then solve for y. */
yg[0] = r_norm;
for (i=1; i<=krydim; i++) yg[i]=ZERO;
if (QRsol(krydim, Hes, givens, yg) != 0)
return(SPFGMR_QRSOL_FAIL);
/* Add correction vector Z_l y to xcor. */
for (k=0; k<krydim; k++)
N_VLinearSum(yg[k], Z[k], ONE, xcor, xcor);
/* If converged, construct the final solution vector x and return. */
if (converged) {
N_VLinearSum(ONE, x, ONE, xcor, x);
return(SPFGMR_SUCCESS);
}
/* Not yet converged; if allowed, prepare for restart. */
if (ntries == max_restarts) break;
/* Construct last column of Q in yg. */
s_product = ONE;
for (i=krydim; i>0; i--) {
yg[i] = s_product*givens[2*i-2];
s_product *= givens[2*i-1];
}
yg[0] = s_product;
/* Scale r_norm and yg. */
r_norm *= s_product;
for (i=0; i<=krydim; i++)
yg[i] *= r_norm;
r_norm = SUNRabs(r_norm);
/* Multiply yg by V_(krydim+1) to get last residual vector; restart. */
N_VScale(yg[0], V[0], V[0]);
for (k=1; k<=krydim; k++)
N_VLinearSum(yg[k], V[k], ONE, V[0], V[0]);
}
/* Failed to converge, even after allowed restarts.
If the residual norm was reduced below its initial value, compute
and return x anyway. Otherwise return failure flag. */
if (rho < beta) {
N_VLinearSum(ONE, x, ONE, xcor, x);
return(SPFGMR_RES_REDUCED);
}
return(SPFGMR_CONV_FAIL);
}
/* Main Program */
int main()
{
/* general problem parameters */
realtype T0 = RCONST(0.0); /* initial time */
realtype Tf = RCONST(10.0); /* final time */
int Nt = 100; /* total number of output times */
int Nvar = 3; /* number of solution fields */
UserData udata = NULL;
realtype *data;
long int N = 201; /* spatial mesh size */
realtype a = 0.6; /* problem parameters */
realtype b = 2.0;
realtype du = 0.025;
realtype dv = 0.025;
realtype dw = 0.025;
realtype ep = 1.0e-5; /* stiffness parameter */
realtype reltol = 1.0e-6; /* tolerances */
realtype abstol = 1.0e-10;
long int NEQ, i;
/* general problem variables */
int flag; /* reusable error-checking flag */
N_Vector y = NULL; /* empty vector for storing solution */
N_Vector umask = NULL; /* empty mask vectors for viewing solution components */
N_Vector vmask = NULL;
N_Vector wmask = NULL;
void *arkode_mem = NULL; /* empty ARKode memory structure */
realtype pi, t, dTout, tout, u, v, w;
FILE *FID, *UFID, *VFID, *WFID;
int iout;
long int nst, nst_a, nfe, nfi, nsetups, nje, nfeLS, nni, ncfn, netf;
/* allocate udata structure */
udata = (UserData) malloc(sizeof(*udata));
if (check_flag((void *) udata, "malloc", 2)) return 1;
/* store the inputs in the UserData structure */
udata->N = N;
udata->a = a;
udata->b = b;
udata->du = du;
udata->dv = dv;
udata->dw = dw;
udata->ep = ep;
/* set total allocated vector length */
NEQ = Nvar*udata->N;
/* Initial problem output */
printf("\n1D Brusselator PDE test problem:\n");
printf(" N = %li, NEQ = %li\n", udata->N, NEQ);
printf(" problem parameters: a = %g, b = %g, ep = %g\n",
udata->a, udata->b, udata->ep);
printf(" diffusion coefficients: du = %g, dv = %g, dw = %g\n",
udata->du, udata->dv, udata->dw);
printf(" reltol = %.1e, abstol = %.1e\n\n", reltol, abstol);
/* Initialize data structures */
y = N_VNew_Serial(NEQ); /* Create serial vector for solution */
if (check_flag((void *)y, "N_VNew_Serial", 0)) return 1;
udata->dx = RCONST(1.0)/(N-1); /* set spatial mesh spacing */
data = N_VGetArrayPointer(y); /* Access data array for new NVector y */
if (check_flag((void *)data, "N_VGetArrayPointer", 0)) return 1;
umask = N_VNew_Serial(NEQ); /* Create serial vector masks */
if (check_flag((void *)umask, "N_VNew_Serial", 0)) return 1;
vmask = N_VNew_Serial(NEQ);
if (check_flag((void *)vmask, "N_VNew_Serial", 0)) return 1;
wmask = N_VNew_Serial(NEQ);
if (check_flag((void *)wmask, "N_VNew_Serial", 0)) return 1;
/* Set initial conditions into y */
pi = RCONST(4.0)*atan(RCONST(1.0));
for (i=0; i<N; i++) {
data[IDX(i,0)] = a + RCONST(0.1)*sin(pi*i*udata->dx); /* u */
data[IDX(i,1)] = b/a + RCONST(0.1)*sin(pi*i*udata->dx); /* v */
data[IDX(i,2)] = b + RCONST(0.1)*sin(pi*i*udata->dx); /* w */
}
/* Set mask array values for each solution component */
N_VConst(0.0, umask);
data = N_VGetArrayPointer(umask);
if (check_flag((void *)data, "N_VGetArrayPointer", 0)) return 1;
for (i=0; i<N; i++) data[IDX(i,0)] = RCONST(1.0);
N_VConst(0.0, vmask);
data = N_VGetArrayPointer(vmask);
if (check_flag((void *)data, "N_VGetArrayPointer", 0)) return 1;
for (i=0; i<N; i++) data[IDX(i,1)] = RCONST(1.0);
N_VConst(0.0, wmask);
data = N_VGetArrayPointer(wmask);
if (check_flag((void *)data, "N_VGetArrayPointer", 0)) return 1;
for (i=0; i<N; i++) data[IDX(i,2)] = RCONST(1.0);
/* Create the solver memory */
arkode_mem = ARKodeCreate();
if (check_flag((void *)arkode_mem, "ARKodeCreate", 0)) return 1;
/* Call ARKodeInit to initialize the integrator memory and specify the
right-hand side function in y'=f(t,y), the inital time T0, and
the initial dependent variable vector y. Note: since this
problem is fully implicit, we set f_E to NULL and f_I to f. */
flag = ARKodeInit(arkode_mem, NULL, f, T0, y);
if (check_flag(&flag, "ARKodeInit", 1)) return 1;
/* Set routines */
flag = ARKodeSetUserData(arkode_mem, (void *) udata); /* Pass udata to user functions */
if (check_flag(&flag, "ARKodeSetUserData", 1)) return 1;
flag = ARKodeSStolerances(arkode_mem, reltol, abstol); /* Specify tolerances */
if (check_flag(&flag, "ARKodeSStolerances", 1)) return 1;
/* Linear solver specification */
flag = ARKBand(arkode_mem, NEQ, 4, 4); /* Specify the band linear solver */
if (check_flag(&flag, "ARKBand", 1)) return 1;
flag = ARKDlsSetBandJacFn(arkode_mem, Jac); /* Set the Jacobian routine */
if (check_flag(&flag, "ARKDlsSetBandJacFn", 1)) return 1;
/* output spatial mesh to disk */
FID = fopen("bruss_mesh.txt","w");
for (i=0; i<N; i++) fprintf(FID," %.16e\n", udata->dx*i);
fclose(FID);
/* Open output streams for results, access data array */
UFID=fopen("bruss_u.txt","w");
VFID=fopen("bruss_v.txt","w");
WFID=fopen("bruss_w.txt","w");
/* output initial condition to disk */
data = N_VGetArrayPointer(y);
if (check_flag((void *)data, "N_VGetArrayPointer", 0)) return 1;
for (i=0; i<N; i++) fprintf(UFID," %.16e", data[IDX(i,0)]);
for (i=0; i<N; i++) fprintf(VFID," %.16e", data[IDX(i,1)]);
for (i=0; i<N; i++) fprintf(WFID," %.16e", data[IDX(i,2)]);
fprintf(UFID,"\n");
fprintf(VFID,"\n");
fprintf(WFID,"\n");
/* Main time-stepping loop: calls ARKode to perform the integration, then
prints results. Stops when the final time has been reached */
t = T0;
dTout = (Tf-T0)/Nt;
tout = T0+dTout;
printf(" t ||u||_rms ||v||_rms ||w||_rms\n");
printf(" ----------------------------------------------\n");
for (iout=0; iout<Nt; iout++) {
flag = ARKode(arkode_mem, tout, y, &t, ARK_NORMAL); /* call integrator */
if (check_flag(&flag, "ARKode", 1)) break;
u = N_VWL2Norm(y,umask); /* access/print solution statistics */
u = SUNRsqrt(u*u/N);
v = N_VWL2Norm(y,vmask);
v = SUNRsqrt(v*v/N);
w = N_VWL2Norm(y,wmask);
w = SUNRsqrt(w*w/N);
printf(" %10.6f %10.6f %10.6f %10.6f\n", t, u, v, w);
if (flag >= 0) { /* successful solve: update output time */
tout += dTout;
tout = (tout > Tf) ? Tf : tout;
} else { /* unsuccessful solve: break */
fprintf(stderr,"Solver failure, stopping integration\n");
break;
}
/* output results to disk */
for (i=0; i<N; i++) fprintf(UFID," %.16e", data[IDX(i,0)]);
for (i=0; i<N; i++) fprintf(VFID," %.16e", data[IDX(i,1)]);
for (i=0; i<N; i++) fprintf(WFID," %.16e", data[IDX(i,2)]);
fprintf(UFID,"\n");
fprintf(VFID,"\n");
fprintf(WFID,"\n");
}
printf(" ----------------------------------------------\n");
fclose(UFID);
fclose(VFID);
fclose(WFID);
/* Print some final statistics */
flag = ARKodeGetNumSteps(arkode_mem, &nst);
check_flag(&flag, "ARKodeGetNumSteps", 1);
flag = ARKodeGetNumStepAttempts(arkode_mem, &nst_a);
check_flag(&flag, "ARKodeGetNumStepAttempts", 1);
flag = ARKodeGetNumRhsEvals(arkode_mem, &nfe, &nfi);
check_flag(&flag, "ARKodeGetNumRhsEvals", 1);
flag = ARKodeGetNumLinSolvSetups(arkode_mem, &nsetups);
check_flag(&flag, "ARKodeGetNumLinSolvSetups", 1);
flag = ARKodeGetNumErrTestFails(arkode_mem, &netf);
check_flag(&flag, "ARKodeGetNumErrTestFails", 1);
flag = ARKodeGetNumNonlinSolvIters(arkode_mem, &nni);
check_flag(&flag, "ARKodeGetNumNonlinSolvIters", 1);
flag = ARKodeGetNumNonlinSolvConvFails(arkode_mem, &ncfn);
check_flag(&flag, "ARKodeGetNumNonlinSolvConvFails", 1);
flag = ARKDlsGetNumJacEvals(arkode_mem, &nje);
check_flag(&flag, "ARKDlsGetNumJacEvals", 1);
flag = ARKDlsGetNumRhsEvals(arkode_mem, &nfeLS);
check_flag(&flag, "ARKDlsGetNumRhsEvals", 1);
printf("\nFinal Solver Statistics:\n");
printf(" Internal solver steps = %li (attempted = %li)\n", nst, nst_a);
printf(" Total RHS evals: Fe = %li, Fi = %li\n", nfe, nfi);
printf(" Total linear solver setups = %li\n", nsetups);
printf(" Total RHS evals for setting up the linear system = %li\n", nfeLS);
printf(" Total number of Jacobian evaluations = %li\n", nje);
printf(" Total number of Newton iterations = %li\n", nni);
printf(" Total number of nonlinear solver convergence failures = %li\n", ncfn);
printf(" Total number of error test failures = %li\n\n", netf);
/* Clean up and return with successful completion */
N_VDestroy_Serial(y); /* Free vectors */
N_VDestroy_Serial(umask);
N_VDestroy_Serial(vmask);
N_VDestroy_Serial(wmask);
free(udata); /* Free user data */
ARKodeFree(&arkode_mem); /* Free integrator memory */
return 0;
}
int CVBBDPrecInit(void *cvode_mem, long int Nlocal,
long int mudq, long int mldq,
long int mukeep, long int mlkeep,
realtype dqrely,
CVLocalFn gloc, CVCommFn cfn)
{
CVodeMem cv_mem;
CVSpilsMem cvspils_mem;
CVBBDPrecData pdata;
long int muk, mlk, storage_mu;
int flag;
if (cvode_mem == NULL) {
cvProcessError(NULL, CVSPILS_MEM_NULL, "CVBBDPRE", "CVBBDPrecInit", MSGBBD_MEM_NULL);
return(CVSPILS_MEM_NULL);
}
cv_mem = (CVodeMem) cvode_mem;
/* Test if one of the SPILS linear solvers has been attached */
if (cv_mem->cv_lmem == NULL) {
cvProcessError(cv_mem, CVSPILS_LMEM_NULL, "CVBBDPRE", "CVBBDPrecInit", MSGBBD_LMEM_NULL);
return(CVSPILS_LMEM_NULL);
}
cvspils_mem = (CVSpilsMem) cv_mem->cv_lmem;
/* Test if the NVECTOR package is compatible with the BLOCK BAND preconditioner */
if(vec_tmpl->ops->nvgetarraypointer == NULL) {
cvProcessError(cv_mem, CVSPILS_ILL_INPUT, "CVBBDPRE", "CVBBDPrecInit", MSGBBD_BAD_NVECTOR);
return(CVSPILS_ILL_INPUT);
}
/* Allocate data memory */
pdata = NULL;
pdata = (CVBBDPrecData) malloc(sizeof *pdata);
if (pdata == NULL) {
cvProcessError(cv_mem, CVSPILS_MEM_FAIL, "CVBBDPRE", "CVBBDPrecInit", MSGBBD_MEM_FAIL);
return(CVSPILS_MEM_FAIL);
}
/* Set pointers to gloc and cfn; load half-bandwidths */
pdata->cvode_mem = cvode_mem;
pdata->gloc = gloc;
pdata->cfn = cfn;
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;
/* Allocate memory for saved Jacobian */
pdata->savedJ = NewBandMat(Nlocal, muk, mlk, muk);
if (pdata->savedJ == NULL) {
free(pdata); pdata = NULL;
cvProcessError(cv_mem, CVSPILS_MEM_FAIL, "CVBBDPRE", "CVBBDPrecInit", MSGBBD_MEM_FAIL);
return(CVSPILS_MEM_FAIL);
}
/* Allocate memory for preconditioner matrix */
storage_mu = SUNMIN(Nlocal-1, muk + mlk);
pdata->savedP = NULL;
pdata->savedP = NewBandMat(Nlocal, muk, mlk, storage_mu);
if (pdata->savedP == NULL) {
DestroyMat(pdata->savedJ);
free(pdata); pdata = NULL;
cvProcessError(cv_mem, CVSPILS_MEM_FAIL, "CVBBDPRE", "CVBBDPrecInit", MSGBBD_MEM_FAIL);
return(CVSPILS_MEM_FAIL);
}
/* Allocate memory for lpivots */
pdata->lpivots = NULL;
pdata->lpivots = NewLintArray(Nlocal);
if (pdata->lpivots == NULL) {
DestroyMat(pdata->savedP);
DestroyMat(pdata->savedJ);
free(pdata); pdata = NULL;
cvProcessError(cv_mem, CVSPILS_MEM_FAIL, "CVBBDPRE", "CVBBDPrecInit", MSGBBD_MEM_FAIL);
return(CVSPILS_MEM_FAIL);
}
/* Set pdata->dqrely based on input dqrely (0 implies default). */
pdata->dqrely = (dqrely > ZERO) ? dqrely : SUNRsqrt(uround);
/* Store Nlocal to be used in CVBBDPrecSetup */
pdata->n_local = Nlocal;
/* Set work space sizes and initialize nge */
pdata->rpwsize = Nlocal*(muk + 2*mlk + storage_mu + 2);
pdata->ipwsize = Nlocal;
pdata->nge = 0;
/* Overwrite the P_data field in the SPILS memory */
cvspils_mem->s_P_data = pdata;
/* Attach the pfree function */
cvspils_mem->s_pfree = CVBBDPrecFree;
/* Attach preconditioner solve and setup functions */
flag = CVSpilsSetPreconditioner(cvode_mem, CVBBDPrecSetup, CVBBDPrecSolve);
return(flag);
}
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);
}
/*---------------------------------------------------------------
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);
}
/* Main Program */
int main() {
/* general problem parameters */
realtype T0 = RCONST(0.0); /* initial time */
realtype Tf = RCONST(1.0); /* final time */
int Nt = 10; /* total number of output times */
realtype rtol = 1.e-6; /* relative tolerance */
realtype atol = 1.e-10; /* absolute tolerance */
UserData udata = NULL;
realtype *data;
sunindextype N = 201; /* spatial mesh size */
realtype k = 0.5; /* heat conductivity */
sunindextype i;
/* general problem variables */
int flag; /* reusable error-checking flag */
N_Vector y = NULL; /* empty vector for storing solution */
SUNLinearSolver LS = NULL; /* empty linear solver object */
void *arkode_mem = NULL; /* empty ARKode memory structure */
FILE *FID, *UFID;
realtype t, dTout, tout;
int iout;
long int nst, nst_a, nfe, nfi, nsetups, nli, nJv, nlcf, nni, ncfn, netf;
/* allocate and fill udata structure */
udata = (UserData) malloc(sizeof(*udata));
udata->N = N;
udata->k = k;
udata->dx = RCONST(1.0)/(1.0*N-1.0); /* mesh spacing */
/* Initial problem output */
printf("\n1D Heat PDE test problem:\n");
printf(" N = %li\n", (long int) udata->N);
printf(" diffusion coefficient: k = %"GSYM"\n", udata->k);
/* Initialize data structures */
y = N_VNew_Serial(N); /* Create serial vector for solution */
if (check_flag((void *) y, "N_VNew_Serial", 0)) return 1;
N_VConst(0.0, y); /* Set initial conditions */
/* Call ARKStepCreate to initialize the ARK timestepper module and
specify the right-hand side function in y'=f(t,y), the inital time
T0, and the initial dependent variable vector y. Note: since this
problem is fully implicit, we set f_E to NULL and f_I to f. */
arkode_mem = ARKStepCreate(NULL, f, T0, y);
if (check_flag((void *) arkode_mem, "ARKStepCreate", 0)) return 1;
/* Set routines */
flag = ARKStepSetUserData(arkode_mem, (void *) udata); /* Pass udata to user functions */
if (check_flag(&flag, "ARKStepSetUserData", 1)) return 1;
flag = ARKStepSetMaxNumSteps(arkode_mem, 10000); /* Increase max num steps */
if (check_flag(&flag, "ARKStepSetMaxNumSteps", 1)) return 1;
flag = ARKStepSetPredictorMethod(arkode_mem, 1); /* Specify maximum-order predictor */
if (check_flag(&flag, "ARKStepSetPredictorMethod", 1)) return 1;
flag = ARKStepSStolerances(arkode_mem, rtol, atol); /* Specify tolerances */
if (check_flag(&flag, "ARKStepSStolerances", 1)) return 1;
/* Initialize PCG solver -- no preconditioning, with up to N iterations */
LS = SUNLinSol_PCG(y, 0, N);
if (check_flag((void *)LS, "SUNLinSol_PCG", 0)) return 1;
/* Linear solver interface -- set user-supplied J*v routine (no 'jtsetup' required) */
flag = ARKStepSetLinearSolver(arkode_mem, LS, NULL); /* Attach linear solver to ARKStep */
if (check_flag(&flag, "ARKStepSetLinearSolver", 1)) return 1;
flag = ARKStepSetJacTimes(arkode_mem, NULL, Jac); /* Set the Jacobian routine */
if (check_flag(&flag, "ARKStepSetJacTimes", 1)) return 1;
/* Specify linearly implicit RHS, with non-time-dependent Jacobian */
flag = ARKStepSetLinear(arkode_mem, 0);
if (check_flag(&flag, "ARKStepSetLinear", 1)) return 1;
/* output mesh to disk */
FID=fopen("heat_mesh.txt","w");
for (i=0; i<N; i++) fprintf(FID," %.16"ESYM"\n", udata->dx*i);
fclose(FID);
/* Open output stream for results, access data array */
UFID=fopen("heat1D.txt","w");
data = N_VGetArrayPointer(y);
/* output initial condition to disk */
for (i=0; i<N; i++) fprintf(UFID," %.16"ESYM"", data[i]);
fprintf(UFID,"\n");
/* Main time-stepping loop: calls ARKStepEvolve to perform the integration, then
prints results. Stops when the final time has been reached */
t = T0;
dTout = (Tf-T0)/Nt;
tout = T0+dTout;
printf(" t ||u||_rms\n");
printf(" -------------------------\n");
printf(" %10.6"FSYM" %10.6"FSYM"\n", t, SUNRsqrt(N_VDotProd(y,y)/N));
for (iout=0; iout<Nt; iout++) {
flag = ARKStepEvolve(arkode_mem, tout, y, &t, ARK_NORMAL); /* call integrator */
if (check_flag(&flag, "ARKStepEvolve", 1)) break;
printf(" %10.6"FSYM" %10.6"FSYM"\n", t, SUNRsqrt(N_VDotProd(y,y)/N)); /* print solution stats */
if (flag >= 0) { /* successful solve: update output time */
tout += dTout;
tout = (tout > Tf) ? Tf : tout;
} else { /* unsuccessful solve: break */
fprintf(stderr,"Solver failure, stopping integration\n");
break;
}
/* output results to disk */
for (i=0; i<N; i++) fprintf(UFID," %.16"ESYM"", data[i]);
fprintf(UFID,"\n");
}
printf(" -------------------------\n");
fclose(UFID);
/* Print some final statistics */
flag = ARKStepGetNumSteps(arkode_mem, &nst);
check_flag(&flag, "ARKStepGetNumSteps", 1);
flag = ARKStepGetNumStepAttempts(arkode_mem, &nst_a);
check_flag(&flag, "ARKStepGetNumStepAttempts", 1);
flag = ARKStepGetNumRhsEvals(arkode_mem, &nfe, &nfi);
check_flag(&flag, "ARKStepGetNumRhsEvals", 1);
flag = ARKStepGetNumLinSolvSetups(arkode_mem, &nsetups);
check_flag(&flag, "ARKStepGetNumLinSolvSetups", 1);
flag = ARKStepGetNumErrTestFails(arkode_mem, &netf);
check_flag(&flag, "ARKStepGetNumErrTestFails", 1);
flag = ARKStepGetNumNonlinSolvIters(arkode_mem, &nni);
check_flag(&flag, "ARKStepGetNumNonlinSolvIters", 1);
flag = ARKStepGetNumNonlinSolvConvFails(arkode_mem, &ncfn);
check_flag(&flag, "ARKStepGetNumNonlinSolvConvFails", 1);
flag = ARKStepGetNumLinIters(arkode_mem, &nli);
check_flag(&flag, "ARKStepGetNumLinIters", 1);
flag = ARKStepGetNumJtimesEvals(arkode_mem, &nJv);
check_flag(&flag, "ARKStepGetNumJtimesEvals", 1);
flag = ARKStepGetNumLinConvFails(arkode_mem, &nlcf);
check_flag(&flag, "ARKStepGetNumLinConvFails", 1);
printf("\nFinal Solver Statistics:\n");
printf(" Internal solver steps = %li (attempted = %li)\n", nst, nst_a);
printf(" Total RHS evals: Fe = %li, Fi = %li\n", nfe, nfi);
printf(" Total linear solver setups = %li\n", nsetups);
printf(" Total linear iterations = %li\n", nli);
printf(" Total number of Jacobian-vector products = %li\n", nJv);
printf(" Total number of linear solver convergence failures = %li\n", nlcf);
printf(" Total number of Newton iterations = %li\n", nni);
printf(" Total number of nonlinear solver convergence failures = %li\n", ncfn);
printf(" Total number of error test failures = %li\n", netf);
/* Clean up and return with successful completion */
N_VDestroy(y); /* Free vectors */
free(udata); /* Free user data */
ARKStepFree(&arkode_mem); /* Free integrator memory */
SUNLinSolFree(LS); /* Free linear solver */
return 0;
}
static int CVBandPDQJac(CVBandPrecData pdata,
realtype t, N_Vector y, N_Vector fy,
N_Vector ftemp, N_Vector ytemp)
{
CVodeMem cv_mem;
realtype fnorm, minInc, inc, inc_inv, srur;
long int group, i, j, width, ngroups, i1, i2;
realtype *col_j, *ewt_data, *fy_data, *ftemp_data, *y_data, *ytemp_data;
int retval;
cv_mem = (CVodeMem) pdata->cvode_mem;
/* Obtain pointers to the data for ewt, fy, ftemp, y, ytemp. */
ewt_data = N_VGetArrayPointer(ewt);
fy_data = N_VGetArrayPointer(fy);
ftemp_data = N_VGetArrayPointer(ftemp);
y_data = N_VGetArrayPointer(y);
ytemp_data = N_VGetArrayPointer(ytemp);
/* Load ytemp with y = predicted y vector. */
N_VScale(ONE, y, ytemp);
/* Set minimum increment based on uround and norm of f. */
srur = SUNRsqrt(uround);
fnorm = N_VWrmsNorm(fy, ewt);
minInc = (fnorm != ZERO) ?
(MIN_INC_MULT * SUNRabs(h) * uround * N * fnorm) : ONE;
/* Set bandwidth and number of column groups for band differencing. */
width = ml + mu + 1;
ngroups = SUNMIN(width, N);
for (group = 1; group <= ngroups; group++) {
/* Increment all y_j in group. */
for(j = group-1; j < N; j += width) {
inc = SUNMAX(srur*SUNRabs(y_data[j]), minInc/ewt_data[j]);
ytemp_data[j] += inc;
}
/* Evaluate f with incremented y. */
retval = f(t, ytemp, ftemp, user_data);
nfeBP++;
if (retval != 0) return(retval);
/* Restore ytemp, then form and load difference quotients. */
for (j = group-1; j < N; j += width) {
ytemp_data[j] = y_data[j];
col_j = BAND_COL(savedJ,j);
inc = SUNMAX(srur*SUNRabs(y_data[j]), minInc/ewt_data[j]);
inc_inv = ONE/inc;
i1 = SUNMAX(0, j-mu);
i2 = SUNMIN(j+ml, N-1);
for (i=i1; i <= i2; i++)
BAND_COL_ELEM(col_j,i,j) =
inc_inv * (ftemp_data[i] - fy_data[i]);
}
}
return(0);
}
int cvDlsDenseDQJac(long int N, realtype t,
N_Vector y, N_Vector fy,
DlsMat Jac, void *data,
N_Vector tmp1, N_Vector tmp2, N_Vector tmp3)
{
realtype fnorm, minInc, inc, inc_inv, yjsaved, srur;
realtype *tmp2_data, *y_data, *ewt_data;
N_Vector ftemp, jthCol;
long int j;
int retval = 0;
CVodeMem cv_mem;
CVDlsMem cvdls_mem;
/* data points to cvode_mem */
cv_mem = (CVodeMem) data;
cvdls_mem = (CVDlsMem) lmem;
/* Save pointer to the array in tmp2 */
tmp2_data = N_VGetArrayPointer(tmp2);
/* Rename work vectors for readibility */
ftemp = tmp1;
jthCol = tmp2;
/* Obtain pointers to the data for ewt, y */
ewt_data = N_VGetArrayPointer(ewt);
y_data = N_VGetArrayPointer(y);
/* Set minimum increment based on uround and norm of f */
srur = SUNRsqrt(uround);
fnorm = N_VWrmsNorm(fy, ewt);
minInc = (fnorm != ZERO) ?
(MIN_INC_MULT * SUNRabs(h) * uround * N * fnorm) : ONE;
for (j = 0; j < N; j++) {
/* Generate the jth col of J(tn,y) */
N_VSetArrayPointer(DENSE_COL(Jac,j), jthCol);
yjsaved = y_data[j];
inc = SUNMAX(srur*SUNRabs(yjsaved), minInc/ewt_data[j]);
y_data[j] += inc;
retval = f(t, y, ftemp, user_data);
nfeDQ++;
if (retval != 0) break;
y_data[j] = yjsaved;
inc_inv = ONE/inc;
N_VLinearSum(inc_inv, ftemp, -inc_inv, fy, jthCol);
DENSE_COL(Jac,j) = N_VGetArrayPointer(jthCol);
}
/* Restore original array pointer in tmp2 */
N_VSetArrayPointer(tmp2_data, tmp2);
return(retval);
}
int QRfact(int n, realtype **h, realtype *q, int job)
{
realtype c, s, temp1, temp2, temp3;
int i, j, k, q_ptr, n_minus_1, code=0;
switch (job) {
case 0:
/* Compute a new factorization of H */
code = 0;
for (k=0; k < n; k++) {
/* Multiply column k by the previous k-1 Givens rotations */
for (j=0; j < k-1; j++) {
i = 2*j;
temp1 = h[j][k];
temp2 = h[j+1][k];
c = q[i];
s = q[i+1];
h[j][k] = c*temp1 - s*temp2;
h[j+1][k] = s*temp1 + c*temp2;
}
/* Compute the Givens rotation components c and s */
q_ptr = 2*k;
temp1 = h[k][k];
temp2 = h[k+1][k];
if( temp2 == ZERO) {
c = ONE;
s = ZERO;
} else if (SUNRabs(temp2) >= SUNRabs(temp1)) {
temp3 = temp1/temp2;
s = -ONE/SUNRsqrt(ONE+SUNSQR(temp3));
c = -s*temp3;
} else {
temp3 = temp2/temp1;
c = ONE/SUNRsqrt(ONE+SUNSQR(temp3));
s = -c*temp3;
}
q[q_ptr] = c;
q[q_ptr+1] = s;
if( (h[k][k] = c*temp1 - s*temp2) == ZERO) code = k+1;
}
break;
default:
/* Update the factored H to which a new column has been added */
n_minus_1 = n - 1;
code = 0;
/* Multiply the new column by the previous n-1 Givens rotations */
for (k=0; k < n_minus_1; k++) {
i = 2*k;
temp1 = h[k][n_minus_1];
temp2 = h[k+1][n_minus_1];
c = q[i];
s = q[i+1];
h[k][n_minus_1] = c*temp1 - s*temp2;
h[k+1][n_minus_1] = s*temp1 + c*temp2;
}
/* Compute new Givens rotation and multiply it times the last two
entries in the new column of H. Note that the second entry of
this product will be 0, so it is not necessary to compute it. */
temp1 = h[n_minus_1][n_minus_1];
temp2 = h[n][n_minus_1];
if (temp2 == ZERO) {
c = ONE;
s = ZERO;
} else if (SUNRabs(temp2) >= SUNRabs(temp1)) {
temp3 = temp1/temp2;
s = -ONE/SUNRsqrt(ONE+SUNSQR(temp3));
c = -s*temp3;
} else {
temp3 = temp2/temp1;
c = ONE/SUNRsqrt(ONE+SUNSQR(temp3));
s = -c*temp3;
}
q_ptr = 2*n_minus_1;
q[q_ptr] = c;
q[q_ptr+1] = s;
if ((h[n_minus_1][n_minus_1] = c*temp1 - s*temp2) == ZERO)
code = n;
}
return (code);
}
int cvDlsBandDQJac(long int N, long int mupper, long int mlower,
realtype t, N_Vector y, N_Vector fy,
DlsMat Jac, void *data,
N_Vector tmp1, N_Vector tmp2, N_Vector tmp3)
{
N_Vector ftemp, ytemp;
realtype fnorm, minInc, inc, inc_inv, srur;
realtype *col_j, *ewt_data, *fy_data, *ftemp_data, *y_data, *ytemp_data;
long int group, i, j, width, ngroups, i1, i2;
int retval = 0;
CVodeMem cv_mem;
CVDlsMem cvdls_mem;
/* data points to cvode_mem */
cv_mem = (CVodeMem) data;
cvdls_mem = (CVDlsMem) lmem;
/* Rename work vectors for use as temporary values of y and f */
ftemp = tmp1;
ytemp = tmp2;
/* Obtain pointers to the data for ewt, fy, ftemp, y, ytemp */
ewt_data = N_VGetArrayPointer(ewt);
fy_data = N_VGetArrayPointer(fy);
ftemp_data = N_VGetArrayPointer(ftemp);
y_data = N_VGetArrayPointer(y);
ytemp_data = N_VGetArrayPointer(ytemp);
/* Load ytemp with y = predicted y vector */
N_VScale(ONE, y, ytemp);
/* Set minimum increment based on uround and norm of f */
srur = SUNRsqrt(uround);
fnorm = N_VWrmsNorm(fy, ewt);
minInc = (fnorm != ZERO) ?
(MIN_INC_MULT * SUNRabs(h) * uround * N * fnorm) : ONE;
/* Set bandwidth and number of column groups for band differencing */
width = mlower + mupper + 1;
ngroups = SUNMIN(width, N);
/* Loop over column groups. */
for (group=1; group <= ngroups; group++) {
/* Increment all y_j in group */
for(j=group-1; j < N; j+=width) {
inc = SUNMAX(srur*SUNRabs(y_data[j]), minInc/ewt_data[j]);
ytemp_data[j] += inc;
}
/* Evaluate f with incremented y */
retval = f(tn, ytemp, ftemp, user_data);
nfeDQ++;
if (retval != 0) break;
/* Restore ytemp, then form and load difference quotients */
for (j=group-1; j < N; j+=width) {
ytemp_data[j] = y_data[j];
col_j = BAND_COL(Jac,j);
inc = SUNMAX(srur*SUNRabs(y_data[j]), minInc/ewt_data[j]);
inc_inv = ONE/inc;
i1 = SUNMAX(0, j-mupper);
i2 = SUNMIN(j+mlower, N-1);
for (i=i1; i <= i2; i++)
BAND_COL_ELEM(col_j,i,j) = inc_inv * (ftemp_data[i] - fy_data[i]);
}
}
return(retval);
}
static int Precondbd(realtype tt, N_Vector cc,
N_Vector cp, N_Vector rr,
realtype cj, void *user_data,
N_Vector tempv1, N_Vector tempv2, N_Vector tempv3)
{
int flag, thispe;
realtype uround;
realtype xx, yy, *cxy, *ewtxy, cctemp, **Pxy, *ratesxy, *Pxycol, *cpxy;
realtype inc, sqru, fac, perturb_rates[NUM_SPECIES];
int is, js, ix, jy, ret;
UserData webdata;
void *mem;
N_Vector ewt;
realtype hh;
webdata = (UserData)user_data;
uround = UNIT_ROUNDOFF;
sqru = SUNRsqrt(uround);
thispe = webdata->thispe;
mem = webdata->ida_mem;
ewt = webdata->ewt;
flag = IDAGetErrWeights(mem, ewt);
check_flag(&flag, "IDAGetErrWeights", 1, thispe);
flag = IDAGetCurrentStep(mem, &hh);
check_flag(&flag, "IDAGetCurrentStep", 1, thispe);
for (jy = 0; jy < mysub; jy++) {
yy = (jy + jysub*mysub)*dy;
for (ix = 0; ix < mxsub; ix++) {
xx = (ix+ ixsub*mxsub)*dx;
Pxy = (webdata->PP)[ix][jy];
cxy = IJ_Vptr(cc,ix,jy);
cpxy = IJ_Vptr(cp,ix,jy);
ewtxy= IJ_Vptr(ewt,ix,jy);
ratesxy = IJ_Vptr(rates,ix,jy);
for (js = 0; js < ns; js++) {
inc = sqru*(SUNMAX(SUNRabs(cxy[js]), SUNMAX(hh*SUNRabs(cpxy[js]), ONE/ewtxy[js])));
cctemp = cxy[js]; /* Save the (js,ix,jy) element of cc. */
cxy[js] += inc; /* Perturb the (js,ix,jy) element of cc. */
fac = -ONE/inc;
WebRates(xx, yy, cxy, perturb_rates, webdata);
Pxycol = Pxy[js];
for (is = 0; is < ns; is++)
Pxycol[is] = (perturb_rates[is] - ratesxy[is])*fac;
if (js < np) Pxycol[js] += cj; /* Add partial with respect to cp. */
cxy[js] = cctemp; /* Restore (js,ix,jy) element of cc. */
} /* End of js loop. */
/* Do LU decomposition of matrix block for grid point (ix,jy). */
ret = denseGETRF(Pxy, ns, ns, (webdata->pivot)[ix][jy]);
if (ret != 0) return(1);
} /* End of ix loop. */
} /* End of jy loop. */
return(0);
}
int SUNLinSolSolve_PCG(SUNLinearSolver S, SUNMatrix nul, N_Vector x,
N_Vector b, realtype delta)
{
/* local data and shortcut variables */
realtype alpha, beta, r0_norm, rho, rz, rz_old;
N_Vector r, p, z, Ap, w;
booleantype UsePrec, UseScaling, converged;
int l, l_max, pretype, ier;
void *A_data, *P_data;
ATimesFn atimes;
PSolveFn psolve;
realtype *res_norm;
int *nli;
/* Make local shorcuts to solver variables. */
if (S == NULL) return(SUNLS_MEM_NULL);
l_max = PCG_CONTENT(S)->maxl;
r = PCG_CONTENT(S)->r;
p = PCG_CONTENT(S)->p;
z = PCG_CONTENT(S)->z;
Ap = PCG_CONTENT(S)->Ap;
w = PCG_CONTENT(S)->s;
A_data = PCG_CONTENT(S)->ATData;
P_data = PCG_CONTENT(S)->PData;
atimes = PCG_CONTENT(S)->ATimes;
psolve = PCG_CONTENT(S)->Psolve;
pretype = PCG_CONTENT(S)->pretype;
nli = &(PCG_CONTENT(S)->numiters);
res_norm = &(PCG_CONTENT(S)->resnorm);
/* Initialize counters and convergence flag */
*nli = 0;
converged = SUNFALSE;
/* set booleantype flags for internal solver options */
UsePrec = ( (pretype == PREC_BOTH) ||
(pretype == PREC_LEFT) ||
(pretype == PREC_RIGHT) );
UseScaling = (w != NULL);
/* Set r to initial residual r_0 = b - A*x_0 */
if (N_VDotProd(x, x) == ZERO) N_VScale(ONE, b, r);
else {
ier = atimes(A_data, x, r);
if (ier != 0) {
LASTFLAG(S) = (ier < 0) ?
SUNLS_ATIMES_FAIL_UNREC : SUNLS_ATIMES_FAIL_REC;
return(LASTFLAG(S));
}
N_VLinearSum(ONE, b, -ONE, r, r);
}
/* Set rho to scaled L2 norm of r, and return if small */
if (UseScaling) N_VProd(r, w, Ap);
else N_VScale(ONE, r, Ap);
*res_norm = r0_norm = rho = SUNRsqrt(N_VDotProd(Ap, Ap));
if (rho <= delta) {
LASTFLAG(S) = SUNLS_SUCCESS;
return(LASTFLAG(S));
}
/* Apply preconditioner and b-scaling to r = r_0 */
if (UsePrec) {
ier = psolve(P_data, r, z, delta, PREC_LEFT); /* z = P^{-1}r */
if (ier != 0) {
LASTFLAG(S) = (ier < 0) ?
SUNLS_PSOLVE_FAIL_UNREC : SUNLS_PSOLVE_FAIL_REC;
return(LASTFLAG(S));
}
}
else N_VScale(ONE, r, z);
/* Initialize rz to <r,z> */
rz = N_VDotProd(r, z);
/* Copy z to p */
N_VScale(ONE, z, p);
/* Begin main iteration loop */
for(l=0; l<l_max; l++) {
/* increment counter */
(*nli)++;
/* Generate Ap = A*p */
ier = atimes(A_data, p, Ap);
if (ier != 0) {
LASTFLAG(S) = (ier < 0) ?
SUNLS_ATIMES_FAIL_UNREC : SUNLS_ATIMES_FAIL_REC;
return(LASTFLAG(S));
}
/* Calculate alpha = <r,z> / <Ap,p> */
alpha = rz / N_VDotProd(Ap, p);
/* Update x = x + alpha*p */
N_VLinearSum(ONE, x, alpha, p, x);
/* Update r = r - alpha*Ap */
N_VLinearSum(ONE, r, -alpha, Ap, r);
/* Set rho and check convergence */
if (UseScaling) N_VProd(r, w, Ap);
else N_VScale(ONE, r, Ap);
*res_norm = rho = SUNRsqrt(N_VDotProd(Ap, Ap));
if (rho <= delta) {
converged = SUNTRUE;
break;
}
/* Apply preconditioner: z = P^{-1}*r */
if (UsePrec) {
ier = psolve(P_data, r, z, delta, PREC_LEFT);
if (ier != 0) {
LASTFLAG(S) = (ier < 0) ?
SUNLS_PSOLVE_FAIL_UNREC : SUNLS_PSOLVE_FAIL_REC;
return(LASTFLAG(S));
}
}
else N_VScale(ONE, r, z);
/* update rz */
rz_old = rz;
rz = N_VDotProd(r, z);
/* Calculate beta = <r,z> / <r_old,z_old> */
beta = rz / rz_old;
/* Update p = z + beta*p */
N_VLinearSum(ONE, z, beta, p, p);
}
/* Main loop finished, return with result */
if (converged == SUNTRUE) {
LASTFLAG(S) = SUNLS_SUCCESS;
} else if (rho < r0_norm) {
LASTFLAG(S) = SUNLS_RES_REDUCED;
} else {
LASTFLAG(S) = SUNLS_CONV_FAIL;
}
return(LASTFLAG(S));
}
int idaDlsBandDQJac(long int N, long int mupper, long int mlower,
realtype tt, realtype c_j,
N_Vector yy, N_Vector yp, N_Vector rr,
DlsMat Jac, void *data,
N_Vector tmp1, N_Vector tmp2, N_Vector tmp3)
{
realtype inc, inc_inv, yj, ypj, srur, conj, ewtj;
realtype *y_data, *yp_data, *ewt_data, *cns_data = NULL;
realtype *ytemp_data, *yptemp_data, *rtemp_data, *r_data, *col_j;
N_Vector rtemp, ytemp, yptemp;
long int i, j, i1, i2, width, ngroups, group;
int retval = 0;
IDAMem IDA_mem;
IDADlsMem idadls_mem;
/* data points to IDA_mem */
IDA_mem = (IDAMem) data;
idadls_mem = (IDADlsMem) lmem;
rtemp = tmp1; /* Rename work vector for use as the perturbed residual. */
ytemp = tmp2; /* Rename work vector for use as a temporary for yy. */
yptemp= tmp3; /* Rename work vector for use as a temporary for yp. */
/* Obtain pointers to the data for all eight vectors used. */
ewt_data = N_VGetArrayPointer(ewt);
r_data = N_VGetArrayPointer(rr);
y_data = N_VGetArrayPointer(yy);
yp_data = N_VGetArrayPointer(yp);
rtemp_data = N_VGetArrayPointer(rtemp);
ytemp_data = N_VGetArrayPointer(ytemp);
yptemp_data = N_VGetArrayPointer(yptemp);
if (constraints != NULL) cns_data = N_VGetArrayPointer(constraints);
/* Initialize ytemp and yptemp. */
N_VScale(ONE, yy, ytemp);
N_VScale(ONE, yp, yptemp);
/* Compute miscellaneous values for the Jacobian computation. */
srur = SUNRsqrt(uround);
width = mlower + mupper + 1;
ngroups = SUNMIN(width, N);
/* Loop over column groups. */
for (group=1; group <= ngroups; group++) {
/* Increment all yy[j] and yp[j] for j in this group. */
for (j=group-1; j<N; j+=width) {
yj = y_data[j];
ypj = yp_data[j];
ewtj = ewt_data[j];
/* Set increment inc to yj based on sqrt(uround)*abs(yj), with
adjustments using ypj and ewtj if this is small, and a further
adjustment to give it the same sign as hh*ypj. */
inc = SUNMAX( srur * SUNMAX( SUNRabs(yj), SUNRabs(hh*ypj) ) , ONE/ewtj );
if (hh*ypj < ZERO) inc = -inc;
inc = (yj + inc) - yj;
/* Adjust sign(inc) again if yj has an inequality constraint. */
if (constraints != NULL) {
conj = cns_data[j];
if (SUNRabs(conj) == ONE) {if((yj+inc)*conj < ZERO) inc = -inc;}
else if (SUNRabs(conj) == TWO) {if((yj+inc)*conj <= ZERO) inc = -inc;}
}
/* Increment yj and ypj. */
ytemp_data[j] += inc;
yptemp_data[j] += cj*inc;
}
/* Call res routine with incremented arguments. */
retval = res(tt, ytemp, yptemp, rtemp, user_data);
nreDQ++;
if (retval != 0) break;
/* Loop over the indices j in this group again. */
for (j=group-1; j<N; j+=width) {
/* Reset ytemp and yptemp components that were perturbed. */
yj = ytemp_data[j] = y_data[j];
ypj = yptemp_data[j] = yp_data[j];
col_j = BAND_COL(Jac, j);
ewtj = ewt_data[j];
/* Set increment inc exactly as above. */
inc = SUNMAX( srur * SUNMAX( SUNRabs(yj), SUNRabs(hh*ypj) ) , ONE/ewtj );
if (hh*ypj < ZERO) inc = -inc;
inc = (yj + inc) - yj;
if (constraints != NULL) {
conj = cns_data[j];
if (SUNRabs(conj) == ONE) {if((yj+inc)*conj < ZERO) inc = -inc;}
else if (SUNRabs(conj) == TWO) {if((yj+inc)*conj <= ZERO) inc = -inc;}
}
/* Load the difference quotient Jacobian elements for column j. */
inc_inv = ONE/inc;
i1 = SUNMAX(0, j-mupper);
i2 = SUNMIN(j+mlower,N-1);
for (i=i1; i<=i2; i++)
BAND_COL_ELEM(col_j,i,j) = inc_inv*(rtemp_data[i]-r_data[i]);
}
}
return(retval);
}
static int Precond(realtype tt,
N_Vector cc, N_Vector cp, N_Vector rr,
realtype cj, void *user_data,
N_Vector tmp1, N_Vector tmp2, N_Vector tmp3)
{
int flag;
realtype uround, xx, yy, del_x, del_y;
realtype **Pxy, *ratesxy, *Pxycol, *cxy, *cpxy, *ewtxy, cctmp;
realtype inc, fac, sqru, perturb_rates[NUM_SPECIES];
int is, js, jx, jy, ret;
void *mem;
N_Vector ewt;
realtype hh;
UserData webdata;
webdata = (UserData) user_data;
del_x = webdata->dx;
del_y = webdata->dy;
uround = UNIT_ROUNDOFF;
sqru = SUNRsqrt(uround);
mem = webdata->ida_mem;
ewt = webdata->ewt;
flag = IDAGetErrWeights(mem, ewt);
if(check_flag(&flag, "IDAGetErrWeights", 1)) return(1);
flag = IDAGetCurrentStep(mem, &hh);
if(check_flag(&flag, "IDAGetCurrentStep", 1)) return(1);
for (jy = 0; jy < MY; jy++) {
yy = jy * del_y;
for (jx = 0; jx < MX; jx++) {
xx = jx * del_x;
Pxy = (webdata->PP)[jx][jy];
cxy = IJ_Vptr(cc, jx, jy);
cpxy = IJ_Vptr(cp, jx, jy);
ewtxy = IJ_Vptr(ewt, jx, jy);
ratesxy = IJ_Vptr((webdata->rates), jx, jy);
for (js = 0; js < NUM_SPECIES; js++) {
inc = sqru*(SUNMAX(SUNRabs(cxy[js]), SUNMAX(hh*SUNRabs(cpxy[js]), ONE/ewtxy[js])));
cctmp = cxy[js];
cxy[js] += inc;
fac = -ONE/inc;
WebRates(xx, yy, cxy, perturb_rates, webdata);
Pxycol = Pxy[js];
for (is = 0; is < NUM_SPECIES; is++)
Pxycol[is] = (perturb_rates[is] - ratesxy[is])*fac;
if (js < 1) Pxycol[js] += cj;
cxy[js] = cctmp;
}
ret = denseGETRF(Pxy, NUM_SPECIES, NUM_SPECIES, (webdata->pivot)[jx][jy]);
if (ret != 0) return(1);
}
}
return(0);
}
