/*---------------------------------------------------------------
ARKSpbcgSolve:
This routine handles the call to the generic solver SpbcgSolve
for the solution of the linear system Ax = b with the SPBCG
method. The solution x is returned in the vector b.
If the WRMS norm of b is small, we return x = b (if this is the
first Newton iteration) or x = 0 (if a later Newton iteration).
Otherwise, we set the tolerance parameter and initial guess
(x = 0), call SpbcgSolve, and copy the solution x into b. The
x-scaling and b-scaling arrays are both equal to weight.
The counters nli, nps, and ncfl are incremented, and the return
value is set according to the success of SpbcgSolve. The
success flag is returned if SpbcgSolve converged, or if this is
the first Newton iteration and the residual norm was reduced
below its initial value.
---------------------------------------------------------------*/
static int ARKSpbcgSolve(ARKodeMem ark_mem, N_Vector b,
N_Vector weight, N_Vector ynow,
N_Vector fnow)
{
realtype bnorm, res_norm;
ARKSpilsMem arkspils_mem;
SpbcgMem spbcg_mem;
int nli_inc, nps_inc, retval;
arkspils_mem = (ARKSpilsMem) ark_mem->ark_lmem;
spbcg_mem = (SpbcgMem) arkspils_mem->s_spils_mem;
/* Test norm(b); if small, return x = 0 or x = b */
arkspils_mem->s_deltar = arkspils_mem->s_eplifac * ark_mem->ark_eLTE;
bnorm = N_VWrmsNorm(b, weight);
if (bnorm <= arkspils_mem->s_deltar) {
if (ark_mem->ark_mnewt > 0) N_VConst(ZERO, b);
return(0);
}
/* Set vectors ycur and fcur for use by the Atimes and Psolve routines */
arkspils_mem->s_ycur = ynow;
arkspils_mem->s_fcur = fnow;
/* Set inputs delta and initial guess x = 0 to SpbcgSolve */
arkspils_mem->s_delta = arkspils_mem->s_deltar * arkspils_mem->s_sqrtN;
N_VConst(ZERO, arkspils_mem->s_x);
/* N_VConst(ark_mem->ark_uround, arkspils_mem->s_x); */
/* Call SpbcgSolve and copy x to b */
retval = SpbcgSolve(spbcg_mem, ark_mem, arkspils_mem->s_x, b,
arkspils_mem->s_pretype, arkspils_mem->s_delta,
ark_mem, weight, weight, ARKSpilsAtimes,
ARKSpilsPSolve, &res_norm, &nli_inc, &nps_inc);
N_VScale(ONE, arkspils_mem->s_x, b);
/* Increment counters nli, nps, and ncfl */
arkspils_mem->s_nli += nli_inc;
arkspils_mem->s_nps += nps_inc;
if (retval != SPBCG_SUCCESS) arkspils_mem->s_ncfl++;
/* Log solver statistics to diagnostics file (if requested) */
if (ark_mem->ark_report)
fprintf(ark_mem->ark_diagfp, " kry %19.16g %19.16g %i %i\n",
bnorm, res_norm, nli_inc, nps_inc);
/* Interpret return value from SpbcgSolve */
arkspils_mem->s_last_flag = retval;
switch(retval) {
case SPBCG_SUCCESS:
return(0);
break;
case SPBCG_RES_REDUCED:
/* allow reduction but not solution on first Newton iteration,
otherwise return with a recoverable failure */
if (ark_mem->ark_mnewt == 0) return(0);
else return(1);
break;
case SPBCG_CONV_FAIL:
return(1);
break;
case SPBCG_PSOLVE_FAIL_REC:
return(1);
break;
case SPBCG_ATIMES_FAIL_REC:
return(1);
break;
case SPBCG_MEM_NULL:
return(-1);
break;
case SPBCG_ATIMES_FAIL_UNREC:
arkProcessError(ark_mem, SPBCG_ATIMES_FAIL_UNREC, "ARKSPBCG",
"ARKSpbcgSolve", MSGS_JTIMES_FAILED);
return(-1);
break;
case SPBCG_PSOLVE_FAIL_UNREC:
arkProcessError(ark_mem, SPBCG_PSOLVE_FAIL_UNREC, "ARKSPBCG",
"ARKSpbcgSolve", MSGS_PSOLVE_FAILED);
return(-1);
break;
}
return(0);
}
int SptfqmrSolve(SptfqmrMem mem, void *A_data, N_Vector x, N_Vector b,
int pretype, realtype delta, void *P_data, N_Vector sx,
N_Vector sb, ATimesFn atimes, PSolveFn psolve,
realtype *res_norm, int *nli, int *nps)
{
realtype alpha, tau, eta, beta, c, sigma, v_bar, omega;
realtype rho[2];
realtype r_init_norm, r_curr_norm;
realtype temp_val;
booleantype preOnLeft, preOnRight, scale_x, scale_b, converged;
booleantype b_ok;
int n, m, ier;
/* Exit immediately if memory pointer is NULL */
if (mem == NULL) return(SPTFQMR_MEM_NULL);
temp_val = r_curr_norm = -ONE; /* Initialize to avoid compiler warnings */
*nli = *nps = 0; /* Initialize counters */
converged = FALSE; /* Initialize convergence flag */
b_ok = FALSE;
if ((pretype != PREC_LEFT) &&
(pretype != PREC_RIGHT) &&
(pretype != PREC_BOTH)) pretype = PREC_NONE;
preOnLeft = ((pretype == PREC_BOTH) || (pretype == PREC_LEFT));
preOnRight = ((pretype == PREC_BOTH) || (pretype == PREC_RIGHT));
scale_x = (sx != NULL);
scale_b = (sb != NULL);
/* Set r_star to initial (unscaled) residual r_star = r_0 = b - A*x_0 */
/* NOTE: if x == 0 then just set residual to b and continue */
if (N_VDotProd(x, x) == ZERO) N_VScale(ONE, b, r_star);
else {
ier = atimes(A_data, x, r_star);
if (ier != 0)
return((ier < 0) ? SPTFQMR_ATIMES_FAIL_UNREC : SPTFQMR_ATIMES_FAIL_REC);
N_VLinearSum(ONE, b, -ONE, r_star, r_star);
}
/* Apply left preconditioner and b-scaling to r_star (or really just r_0) */
if (preOnLeft) {
ier = psolve(P_data, r_star, vtemp1, PREC_LEFT);
(*nps)++;
if (ier != 0)
return((ier < 0) ? SPTFQMR_PSOLVE_FAIL_UNREC : SPTFQMR_PSOLVE_FAIL_REC);
}
else N_VScale(ONE, r_star, vtemp1);
if (scale_b) N_VProd(sb, vtemp1, r_star);
else N_VScale(ONE, vtemp1, r_star);
/* Initialize rho[0] */
/* NOTE: initialized here to reduce number of computations - avoid need
to compute r_star^T*r_star twice, and avoid needlessly squaring
values */
rho[0] = N_VDotProd(r_star, r_star);
/* Compute norm of initial residual (r_0) to see if we really need
to do anything */
*res_norm = r_init_norm = RSqrt(rho[0]);
if (r_init_norm <= delta) return(SPTFQMR_SUCCESS);
/* Set v_ = A*r_0 (preconditioned and scaled) */
if (scale_x) N_VDiv(r_star, sx, vtemp1);
else N_VScale(ONE, r_star, vtemp1);
if (preOnRight) {
N_VScale(ONE, vtemp1, v_);
ier = psolve(P_data, v_, vtemp1, PREC_RIGHT);
(*nps)++;
if (ier != 0) return((ier < 0) ? SPTFQMR_PSOLVE_FAIL_UNREC : SPTFQMR_PSOLVE_FAIL_REC);
}
ier = atimes(A_data, vtemp1, v_);
if (ier != 0)
return((ier < 0) ? SPTFQMR_ATIMES_FAIL_UNREC : SPTFQMR_ATIMES_FAIL_REC);
if (preOnLeft) {
ier = psolve(P_data, v_, vtemp1, PREC_LEFT);
(*nps)++;
if (ier != 0) return((ier < 0) ? SPTFQMR_PSOLVE_FAIL_UNREC : SPTFQMR_PSOLVE_FAIL_REC);
}
else N_VScale(ONE, v_, vtemp1);
if (scale_b) N_VProd(sb, vtemp1, v_);
else N_VScale(ONE, vtemp1, v_);
/* Initialize remaining variables */
N_VScale(ONE, r_star, r_[0]);
N_VScale(ONE, r_star, u_);
N_VScale(ONE, r_star, p_);
N_VConst(ZERO, d_);
tau = r_init_norm;
v_bar = eta = ZERO;
/* START outer loop */
for (n = 0; n < l_max; ++n) {
/* Increment linear iteration counter */
(*nli)++;
/* sigma = r_star^T*v_ */
sigma = N_VDotProd(r_star, v_);
/* alpha = rho[0]/sigma */
alpha = rho[0]/sigma;
/* q_ = u_-alpha*v_ */
N_VLinearSum(ONE, u_, -alpha, v_, q_);
/* r_[1] = r_[0]-alpha*A*(u_+q_) */
N_VLinearSum(ONE, u_, ONE, q_, r_[1]);
if (scale_x) N_VDiv(r_[1], sx, r_[1]);
if (preOnRight) {
N_VScale(ONE, r_[1], vtemp1);
ier = psolve(P_data, vtemp1, r_[1], PREC_RIGHT);
(*nps)++;
if (ier != 0) return((ier < 0) ? SPTFQMR_PSOLVE_FAIL_UNREC : SPTFQMR_PSOLVE_FAIL_REC);
}
ier = atimes(A_data, r_[1], vtemp1);
if (ier != 0)
return((ier < 0) ? SPTFQMR_ATIMES_FAIL_UNREC : SPTFQMR_ATIMES_FAIL_REC);
if (preOnLeft) {
ier = psolve(P_data, vtemp1, r_[1], PREC_LEFT);
(*nps)++;
if (ier != 0) return((ier < 0) ? SPTFQMR_PSOLVE_FAIL_UNREC : SPTFQMR_PSOLVE_FAIL_REC);
}
else N_VScale(ONE, vtemp1, r_[1]);
if (scale_b) N_VProd(sb, r_[1], vtemp1);
else N_VScale(ONE, r_[1], vtemp1);
N_VLinearSum(ONE, r_[0], -alpha, vtemp1, r_[1]);
/* START inner loop */
for (m = 0; m < 2; ++m) {
/* d_ = [*]+(v_bar^2*eta/alpha)*d_ */
/* NOTES:
* (1) [*] = u_ if m == 0, and q_ if m == 1
* (2) using temp_val reduces the number of required computations
* if the inner loop is executed twice
*/
if (m == 0) {
temp_val = RSqrt(N_VDotProd(r_[1], r_[1]));
omega = RSqrt(RSqrt(N_VDotProd(r_[0], r_[0]))*temp_val);
N_VLinearSum(ONE, u_, SQR(v_bar)*eta/alpha, d_, d_);
}
else {
omega = temp_val;
N_VLinearSum(ONE, q_, SQR(v_bar)*eta/alpha, d_, d_);
}
/* v_bar = omega/tau */
v_bar = omega/tau;
/* c = (1+v_bar^2)^(-1/2) */
c = ONE / RSqrt(ONE+SQR(v_bar));
/* tau = tau*v_bar*c */
tau = tau*v_bar*c;
/* eta = c^2*alpha */
eta = SQR(c)*alpha;
/* x = x+eta*d_ */
N_VLinearSum(ONE, x, eta, d_, x);
/* Check for convergence... */
/* NOTE: just use approximation to norm of residual, if possible */
*res_norm = r_curr_norm = tau*RSqrt(m+1);
/* Exit inner loop if iteration has converged based upon approximation
to norm of current residual */
if (r_curr_norm <= delta) {
converged = TRUE;
break;
}
/* Decide if actual norm of residual vector should be computed */
/* NOTES:
* (1) if r_curr_norm > delta, then check if actual residual norm
* is OK (recall we first compute an approximation)
* (2) if r_curr_norm >= r_init_norm and m == 1 and n == l_max, then
* compute actual residual norm to see if the iteration can be
* saved
* (3) the scaled and preconditioned right-hand side of the given
* linear system (denoted by b) is only computed once, and the
* result is stored in vtemp3 so it can be reused - reduces the
* number of psovles if using left preconditioning
*/
if ((r_curr_norm > delta) ||
(r_curr_norm >= r_init_norm && m == 1 && n == l_max)) {
/* Compute norm of residual ||b-A*x||_2 (preconditioned and scaled) */
if (scale_x) N_VDiv(x, sx, vtemp1);
else N_VScale(ONE, x, vtemp1);
if (preOnRight) {
ier = psolve(P_data, vtemp1, vtemp2, PREC_RIGHT);
(*nps)++;
if (ier != 0) return((ier < 0) ? SPTFQMR_PSOLVE_FAIL_UNREC : SPTFQMR_PSOLVE_FAIL_UNREC);
N_VScale(ONE, vtemp2, vtemp1);
}
ier = atimes(A_data, vtemp1, vtemp2);
if (ier != 0)
return((ier < 0) ? SPTFQMR_ATIMES_FAIL_UNREC : SPTFQMR_ATIMES_FAIL_REC);
if (preOnLeft) {
ier = psolve(P_data, vtemp2, vtemp1, PREC_LEFT);
(*nps)++;
if (ier != 0) return((ier < 0) ? SPTFQMR_PSOLVE_FAIL_UNREC : SPTFQMR_PSOLVE_FAIL_REC);
}
else N_VScale(ONE, vtemp2, vtemp1);
if (scale_b) N_VProd(sb, vtemp1, vtemp2);
else N_VScale(ONE, vtemp1, vtemp2);
/* Only precondition and scale b once (result saved for reuse) */
if (!b_ok) {
b_ok = TRUE;
if (preOnLeft) {
ier = psolve(P_data, b, vtemp3, PREC_LEFT);
(*nps)++;
if (ier != 0) return((ier < 0) ? SPTFQMR_PSOLVE_FAIL_UNREC : SPTFQMR_PSOLVE_FAIL_REC);
}
else N_VScale(ONE, b, vtemp3);
if (scale_b) N_VProd(sb, vtemp3, vtemp3);
}
N_VLinearSum(ONE, vtemp3, -ONE, vtemp2, vtemp1);
*res_norm = r_curr_norm = RSqrt(N_VDotProd(vtemp1, vtemp1));
/* Exit inner loop if inequality condition is satisfied
(meaning exit if we have converged) */
if (r_curr_norm <= delta) {
converged = TRUE;
break;
}
}
} /* END inner loop */
/* If converged, then exit outer loop as well */
if (converged == TRUE) break;
/* rho[1] = r_star^T*r_[1] */
rho[1] = N_VDotProd(r_star, r_[1]);
/* beta = rho[1]/rho[0] */
beta = rho[1]/rho[0];
/* u_ = r_[1]+beta*q_ */
N_VLinearSum(ONE, r_[1], beta, q_, u_);
/* p_ = u_+beta*(q_+beta*p_) */
N_VLinearSum(beta, q_, SQR(beta), p_, p_);
N_VLinearSum(ONE, u_, ONE, p_, p_);
/* v_ = A*p_ */
if (scale_x) N_VDiv(p_, sx, vtemp1);
else N_VScale(ONE, p_, vtemp1);
if (preOnRight) {
N_VScale(ONE, vtemp1, v_);
ier = psolve(P_data, v_, vtemp1, PREC_RIGHT);
(*nps)++;
if (ier != 0) return((ier < 0) ? SPTFQMR_PSOLVE_FAIL_UNREC : SPTFQMR_PSOLVE_FAIL_REC);
}
ier = atimes(A_data, vtemp1, v_);
if (ier != 0)
return((ier < 0) ? SPTFQMR_ATIMES_FAIL_UNREC : SPTFQMR_ATIMES_FAIL_REC);
if (preOnLeft) {
ier = psolve(P_data, v_, vtemp1, PREC_LEFT);
(*nps)++;
if (ier != 0) return((ier < 0) ? SPTFQMR_PSOLVE_FAIL_UNREC : SPTFQMR_PSOLVE_FAIL_REC);
}
else N_VScale(ONE, v_, vtemp1);
if (scale_b) N_VProd(sb, vtemp1, v_);
else N_VScale(ONE, vtemp1, v_);
/* Shift variable values */
/* NOTE: reduces storage requirements */
N_VScale(ONE, r_[1], r_[0]);
rho[0] = rho[1];
} /* END outer loop */
/* Determine return value */
/* If iteration converged or residual was reduced, then return current iterate (x) */
if ((converged == TRUE) || (r_curr_norm < r_init_norm)) {
if (scale_x) N_VDiv(x, sx, x);
if (preOnRight) {
ier = psolve(P_data, x, vtemp1, PREC_RIGHT);
(*nps)++;
if (ier != 0) return((ier < 0) ? SPTFQMR_PSOLVE_FAIL_UNREC : SPTFQMR_PSOLVE_FAIL_UNREC);
N_VScale(ONE, vtemp1, x);
}
if (converged == TRUE) return(SPTFQMR_SUCCESS);
else return(SPTFQMR_RES_REDUCED);
}
/* Otherwise, return error code */
else return(SPTFQMR_CONV_FAIL);
}
int main(void)
{
UserData data;
void *mem;
N_Vector yy, yp, id;
realtype rtol, atol;
realtype t0, tf, tout, dt, tret;
int flag, iout;
/* User data */
data = (UserData) malloc(sizeof *data);
data->a = 0.5; /* half-length of crank */
data->J1 = 1.0; /* crank moment of inertia */
data->m2 = 1.0; /* mass of connecting rod */
data->J2 = 2.0; /* moment of inertia of connecting rod */
data->k = 1.0; /* spring constant */
data->c = 1.0; /* damper constant */
data->l0 = 1.0; /* spring free length */
data->F = 1.0; /* external constant force */
/* Create N_Vectors */
yy = N_VNew_Serial(NEQ);
yp = N_VNew_Serial(NEQ);
id = N_VNew_Serial(NEQ);
/* Consistent IC */
setIC(yy, yp, data);
/* ID array */
N_VConst(ONE, id);
NV_Ith_S(id,6) = ZERO;
NV_Ith_S(id,7) = ZERO;
NV_Ith_S(id,8) = ZERO;
NV_Ith_S(id,9) = ZERO;
/* Tolerances */
rtol = RCONST(1.0e-6);
atol = RCONST(1.0e-6);
/* Integration limits */
t0 = ZERO;
tf = TEND;
dt = (tf-t0)/(NOUT-1);
/* IDA initialization */
mem = IDACreate();
flag = IDAInit(mem, ressc, t0, yy, yp);
flag = IDASStolerances(mem, rtol, atol);
flag = IDASetUserData(mem, data);
flag = IDASetId(mem, id);
flag = IDASetSuppressAlg(mem, TRUE);
/* Call IDADense and set up the linear solver. */
flag = IDADense(mem, NEQ);
PrintHeader(rtol, atol, yy);
/* In loop, call IDASolve, print results, and test for error. */
PrintOutput(mem,t0,yy);
tout = dt;
for (iout=1; iout<NOUT; iout++) {
tout = iout*dt;
flag = IDASolve(mem, tout, &tret, yy, yp, IDA_NORMAL);
if (flag < 0) break;
PrintOutput(mem,tret,yy);
}
PrintFinalStats(mem);
/* Free memory */
free(data);
IDAFree(&mem);
N_VDestroy_Serial(yy);
N_VDestroy_Serial(yp);
N_VDestroy_Serial(id);
return(0);
}
int main(int argc, char *argv[])
{
int globalstrategy;
realtype fnormtol, scsteptol;
N_Vector cc, sc, constraints;
UserData data;
int flag, maxl, maxlrst;
void *kmem;
int num_threads;
cc = sc = constraints = NULL;
kmem = NULL;
data = NULL;
/* Allocate memory, and set problem data, initial values, tolerances */
globalstrategy = KIN_NONE;
/* Set the number of threads to use */
num_threads = 1; /* default value*/
#ifdef _OPENMP
num_threads = omp_get_max_threads(); /* Overwrite with OMP_NUM_THREADS environment variable */
#endif
if (argc > 1) /* overwrithe with command line value, if supplied */
num_threads = strtol(argv[1], NULL, 0);
data = AllocUserData();
if (check_flag((void *)data, "AllocUserData", 2)) return(1);
InitUserData(data);
data->nthreads = num_threads;
/* Create serial vectors of length NEQ */
cc = N_VNew_OpenMP(NEQ, num_threads);
if (check_flag((void *)cc, "N_VNew_OpenMP", 0)) return(1);
sc = N_VNew_OpenMP(NEQ, num_threads);
if (check_flag((void *)sc, "N_VNew_OpenMP", 0)) return(1);
data->rates = N_VNew_OpenMP(NEQ, num_threads);
if (check_flag((void *)data->rates, "N_VNew_OpenMP", 0)) return(1);
constraints = N_VNew_OpenMP(NEQ, num_threads);
if (check_flag((void *)constraints, "N_VNew_OpenMP", 0)) return(1);
N_VConst(TWO, constraints);
SetInitialProfiles(cc, sc);
fnormtol=FTOL; scsteptol=STOL;
/* Call KINCreate/KINInit to initialize KINSOL.
A pointer to KINSOL problem memory is returned and stored in kmem. */
kmem = KINCreate();
if (check_flag((void *)kmem, "KINCreate", 0)) return(1);
/* Vector cc passed as template vector. */
flag = KINInit(kmem, func, cc);
if (check_flag(&flag, "KINInit", 1)) return(1);
flag = KINSetUserData(kmem, data);
if (check_flag(&flag, "KINSetUserData", 1)) return(1);
flag = KINSetConstraints(kmem, constraints);
if (check_flag(&flag, "KINSetConstraints", 1)) return(1);
flag = KINSetFuncNormTol(kmem, fnormtol);
if (check_flag(&flag, "KINSetFuncNormTol", 1)) return(1);
flag = KINSetScaledStepTol(kmem, scsteptol);
if (check_flag(&flag, "KINSetScaledStepTol", 1)) return(1);
/* We no longer need the constraints vector since KINSetConstraints
creates a private copy for KINSOL to use. */
N_VDestroy_OpenMP(constraints);
/* Call KINSpgmr to specify the linear solver KINSPGMR with preconditioner
routines PrecSetupBD and PrecSolveBD. */
maxl = 15;
maxlrst = 2;
flag = KINSpgmr(kmem, maxl);
if (check_flag(&flag, "KINSpgmr", 1)) return(1);
flag = KINSpilsSetMaxRestarts(kmem, maxlrst);
if (check_flag(&flag, "KINSpilsSetMaxRestarts", 1)) return(1);
flag = KINSpilsSetPreconditioner(kmem,
PrecSetupBD,
PrecSolveBD);
if (check_flag(&flag, "KINSpilsSetPreconditioner", 1)) return(1);
/* Print out the problem size, solution parameters, initial guess. */
PrintHeader(globalstrategy, maxl, maxlrst, fnormtol, scsteptol);
/* Call KINSol and print output concentration profile */
flag = KINSol(kmem, /* KINSol memory block */
cc, /* initial guess on input; solution vector */
globalstrategy, /* global strategy choice */
sc, /* scaling vector, for the variable cc */
sc); /* scaling vector for function values fval */
if (check_flag(&flag, "KINSol", 1)) return(1);
printf("\n\nComputed equilibrium species concentrations:\n");
PrintOutput(cc);
/* Print final statistics and free memory */
PrintFinalStats(kmem);
printf("num_threads = %i\n", num_threads);
N_VDestroy_OpenMP(cc);
N_VDestroy_OpenMP(sc);
KINFree(&kmem);
FreeUserData(data);
return(0);
}
int CPSpbcg(void *cpode_mem, int pretype, int maxl)
{
CPodeMem cp_mem;
CPSpilsMem cpspils_mem;
SpbcgMem spbcg_mem;
int mxl;
/* Return immediately if cpode_mem is NULL */
if (cpode_mem == NULL) {
cpProcessError(NULL, CPSPILS_MEM_NULL, "CPSPBCG", "CPSpbcg", MSGS_CPMEM_NULL);
return(CPSPILS_MEM_NULL);
}
cp_mem = (CPodeMem) cpode_mem;
/* Check if N_VDotProd is present */
if (vec_tmpl->ops->nvdotprod == NULL) {
cpProcessError(cp_mem, CPSPILS_ILL_INPUT, "CPSPBCG", "CPSpbcg", MSGS_BAD_NVECTOR);
return(CPSPILS_ILL_INPUT);
}
if (lfree != NULL) lfree(cp_mem);
/* Set four main function fields in cp_mem */
linit = cpSpbcgInit;
lsetup = cpSpbcgSetup;
lsolve = cpSpbcgSolve;
lfree = cpSpbcgFree;
/* Get memory for CPSpilsMemRec */
cpspils_mem = NULL;
cpspils_mem = (CPSpilsMem) malloc(sizeof(CPSpilsMemRec));
if (cpspils_mem == NULL) {
cpProcessError(cp_mem, CPSPILS_MEM_FAIL, "CPSPBCG", "CPSpbcg", MSGS_MEM_FAIL);
return(CPSPILS_MEM_FAIL);
}
/* Set ILS type */
cpspils_mem->s_type = SPILS_SPBCG;
/* Set Spbcg parameters that have been passed in call sequence */
cpspils_mem->s_pretype = pretype;
mxl = cpspils_mem->s_maxl = (maxl <= 0) ? CPSPILS_MAXL : maxl;
/* Set default values for the rest of the Spbcg parameters */
cpspils_mem->s_delt = CPSPILS_DELT;
cpspils_mem->s_psetE = NULL;
cpspils_mem->s_psetI = NULL;
cpspils_mem->s_pslvE = NULL;
cpspils_mem->s_pslvI = NULL;
cpspils_mem->s_jtvE = NULL;
cpspils_mem->s_jtvI = NULL;
cpspils_mem->s_P_data = NULL;
cpspils_mem->s_j_data = NULL;
cpspils_mem->s_last_flag = CPSPILS_SUCCESS;
lsetup_exists = FALSE;
/* Check for legal pretype */
if ((pretype != PREC_NONE) && (pretype != PREC_LEFT) &&
(pretype != PREC_RIGHT) && (pretype != PREC_BOTH)) {
cpProcessError(cp_mem, CPSPILS_ILL_INPUT, "CPSPBCG", "CPSpbcg", MSGS_BAD_PRETYPE);
free(cpspils_mem);
return(CPSPILS_ILL_INPUT);
}
/* Alocate memory */
spbcg_mem = NULL;
ytemp = NULL;
yptemp = NULL;
x = NULL;
/* Call SpbcgMalloc to allocate workspace for Spbcg */
spbcg_mem = SpbcgMalloc(mxl, vec_tmpl);
if (spbcg_mem == NULL) {
cpProcessError(cp_mem, CPSPILS_MEM_FAIL, "CPSPBCG", "CPSpbcg", MSGS_MEM_FAIL);
free(cpspils_mem);
return(CPSPILS_MEM_FAIL);
}
/* Allocate memory for x, ytemp and (if needed) yptemp */
x = N_VClone(vec_tmpl);
if (x == NULL) {
cpProcessError(cp_mem, CPSPILS_MEM_FAIL, "CPSPBCG", "CPSpbcg", MSGS_MEM_FAIL);
SpbcgFree(spbcg_mem);
free(cpspils_mem);
return(CPSPILS_MEM_FAIL);
}
ytemp = N_VClone(vec_tmpl);
if (ytemp == NULL) {
cpProcessError(cp_mem, CPSPILS_MEM_FAIL, "CPSPBCG", "CPSpbcg", MSGS_MEM_FAIL);
SpbcgFree(spbcg_mem);
N_VDestroy(x);
free(cpspils_mem);
return(CPSPILS_MEM_FAIL);
}
if (ode_type == CP_IMPL) {
yptemp = N_VClone(vec_tmpl);
if (yptemp == NULL) {
cpProcessError(cp_mem, CPSPILS_MEM_FAIL, "CPSPBCG", "CPSpbcg", MSGS_MEM_FAIL);
SpbcgFree(spbcg_mem);
N_VDestroy(x);
N_VDestroy(ytemp);
free(cpspils_mem);
return(CPSPILS_MEM_FAIL);
}
}
/* Compute sqrtN from a dot product */
N_VConst(ONE, ytemp);
sqrtN = RSqrt(N_VDotProd(ytemp, ytemp));
/* Attach SPBCG memory to spils memory structure */
spils_mem = (void *) spbcg_mem;
/* Attach linear solver memory to integrator memory */
lmem = cpspils_mem;
return(CPSPILS_SUCCESS);
}
static int IDASpgmrSolve(IDAMem IDA_mem, N_Vector bb, N_Vector weight,
N_Vector yy_now, N_Vector yp_now, N_Vector rr_now)
{
IDASpilsMem idaspils_mem;
SpgmrMem spgmr_mem;
int pretype, nli_inc, nps_inc, retval;
realtype res_norm;
idaspils_mem = (IDASpilsMem) lmem;
spgmr_mem = (SpgmrMem) spils_mem;
/* Set SpgmrSolve convergence test constant epslin, in terms of the
Newton convergence test constant epsNewt and safety factors. The factor
sqrt(Neq) assures that the GMRES convergence test is applied to the
WRMS norm of the residual vector, rather than the weighted L2 norm. */
epslin = sqrtN*eplifac*epsNewt;
/* Set vectors ycur, ypcur, and rcur for use by the Atimes and Psolve */
ycur = yy_now;
ypcur = yp_now;
rcur = rr_now;
/* Set SpgmrSolve inputs pretype and initial guess xx = 0. */
pretype = (psolve == NULL) ? PREC_NONE : PREC_LEFT;
N_VConst(ZERO, xx);
/* Call SpgmrSolve and copy xx to bb. */
retval = SpgmrSolve(spgmr_mem, IDA_mem, xx, bb, pretype, gstype, epslin,
maxrs, IDA_mem, weight, weight, IDASpilsAtimes,
IDASpilsPSolve, &res_norm, &nli_inc, &nps_inc);
if (nli_inc == 0) N_VScale(ONE, SPGMR_VTEMP(spgmr_mem), bb);
else N_VScale(ONE, xx, bb);
/* Increment counters nli, nps, and return if successful. */
nli += nli_inc;
nps += nps_inc;
if (retval != SPGMR_SUCCESS) ncfl++;
/* Interpret return value from SpgmrSolve */
last_flag = retval;
switch(retval) {
case SPGMR_SUCCESS:
return(0);
break;
case SPGMR_RES_REDUCED:
return(1);
break;
case SPGMR_CONV_FAIL:
return(1);
break;
case SPGMR_QRFACT_FAIL:
return(1);
break;
case SPGMR_PSOLVE_FAIL_REC:
return(1);
break;
case SPGMR_ATIMES_FAIL_REC:
return(1);
break;
case SPGMR_MEM_NULL:
return(-1);
break;
case SPGMR_ATIMES_FAIL_UNREC:
IDAProcessError(IDA_mem, SPGMR_ATIMES_FAIL_UNREC, "IDASPGMR", "IDASpgmrSolve", MSGS_JTIMES_FAILED);
return(-1);
break;
case SPGMR_PSOLVE_FAIL_UNREC:
IDAProcessError(IDA_mem, SPGMR_PSOLVE_FAIL_UNREC, "IDASPGMR", "IDASpgmrSolve", MSGS_PSOLVE_FAILED);
return(-1);
break;
case SPGMR_GS_FAIL:
return(-1);
break;
case SPGMR_QRSOL_FAIL:
return(-1);
break;
}
return(0);
}
/*-----------------------------------------------------------------
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);
}
static int KINSptfqmrSolve(KINMem kin_mem, N_Vector xx, N_Vector bb,
realtype *sJpnorm, realtype *sFdotJp)
{
KINSpilsMem kinspils_mem;
SptfqmrMem sptfqmr_mem;
int ret, nli_inc, nps_inc;
realtype res_norm;
kinspils_mem = (KINSpilsMem) lmem;
sptfqmr_mem = (SptfqmrMem) spils_mem;
/* Set initial guess to xx = 0. bb is set, by the routine
calling KINSptfqmrSolve, to the RHS vector for the system
to be solved. */
N_VConst(ZERO, xx);
new_uu = TRUE; /* set flag required for user Jacobian routine */
/* call SptfqmrSolve */
ret = SptfqmrSolve(sptfqmr_mem, kin_mem, xx, bb, pretype, eps,
kin_mem, fscale, fscale, KINSpilsAtimes,
KINSpilsPSolve, &res_norm, &nli_inc, &nps_inc);
/* increment counters nli, nps, and ncfl
(nni is updated in the KINSol main iteration loop) */
nli = nli + (long int) nli_inc;
nps = nps + (long int) nps_inc;
if (printfl > 2)
KINPrintInfo(kin_mem, PRNT_NLI, "KINSPTFQMR", "KINSptfqmrSolve", INFO_NLI, nli_inc);
if (ret != 0) ncfl++;
last_flag = ret;
if ( (ret != 0) && (ret != SPTFQMR_RES_REDUCED) ) {
/* Handle all failure returns from SptfqmrSolve */
switch(ret) {
case SPTFQMR_PSOLVE_FAIL_REC:
case SPTFQMR_ATIMES_FAIL_REC:
return(1);
break;
case SPTFQMR_CONV_FAIL:
case SPTFQMR_MEM_NULL:
case SPTFQMR_ATIMES_FAIL_UNREC:
case SPTFQMR_PSOLVE_FAIL_UNREC:
return(-1);
break;
}
}
/* SptfqmrSolve returned either SPTFQMR_SUCCESS or SPTFQMR_RES_REDUCED.
Compute the terms sJpnorm and sFdotJp for use in the linesearch
routine and in KINForcingTerm. Both of these terms are subsequently
corrected if the step is reduced by constraints or the linesearch.
sJpnorm is the norm of the scaled product (scaled by fscale) of the
current Jacobian matrix J and the step vector p (= solution vector xx).
sFdotJp is the dot product of the scaled f vector and the scaled
vector J*p, where the scaling uses fscale. */
ret = KINSpilsAtimes(kin_mem, xx, bb);
if (ret > 0) {
last_flag = SPTFQMR_ATIMES_FAIL_REC;
return(1);
}
else if (ret < 0) {
last_flag = SPTFQMR_ATIMES_FAIL_UNREC;
return(-1);
}
*sJpnorm = N_VWL2Norm(bb, fscale);
N_VProd(bb, fscale, bb);
N_VProd(bb, fscale, bb);
*sFdotJp = N_VDotProd(fval, bb);
if (printfl > 2) KINPrintInfo(kin_mem, PRNT_EPS, "KINSPTFQMR",
"KINSptfqmrSolve", INFO_EPS, res_norm, eps);
return(0);
}
static int KINSpbcgSolve(KINMem kin_mem, N_Vector xx, N_Vector bb,
realtype *res_norm)
{
KINSpilsMem kinspils_mem;
SpbcgMem spbcg_mem;
int ret, nli_inc, nps_inc;
kinspils_mem = (KINSpilsMem) lmem;
spbcg_mem = (SpbcgMem) spils_mem;
/* Set initial guess to xx = 0. bb is set, by the routine
calling KINSpbcgSolve, to the RHS vector for the system
to be solved. */
N_VConst(ZERO, xx);
new_uu = TRUE; /* set flag required for user Jacobian routine */
/* call SpbcgSolve */
ret = SpbcgSolve(spbcg_mem, kin_mem, xx, bb, pretype, eps,
kin_mem, fscale, fscale, KINSpilsAtimes,
KINSpilsPSolve, res_norm, &nli_inc, &nps_inc);
/* increment counters nli, nps, and ncfl
(nni is updated in the KINSol main iteration loop) */
nli = nli + (long int) nli_inc;
nps = nps + (long int) nps_inc;
if (printfl > 2)
KINPrintInfo(kin_mem, PRNT_NLI, "KINSPBCG", "KINSpbcgSolve", INFO_NLI, nli_inc);
if (ret != 0) ncfl++;
/* Compute the terms sJpnorm and sfdotJp for use in the global strategy
routines and in KINForcingTerm. Both of these terms are subsequently
corrected if the step is reduced by constraints or the line search.
sJpnorm is the norm of the scaled product (scaled by fscale) of
the current Jacobian matrix J and the step vector p.
sfdotJp is the dot product of the scaled f vector and the scaled
vector J*p, where the scaling uses fscale. */
ret = KINSpilsAtimes(kin_mem, xx, bb);
if (ret == 0) ret = SPBCG_SUCCESS;
else if (ret > 0) ret = SPBCG_ATIMES_FAIL_REC;
else if (ret < 0) ret = SPBCG_ATIMES_FAIL_UNREC;
sJpnorm = N_VWL2Norm(bb,fscale);
N_VProd(bb, fscale, bb);
N_VProd(bb, fscale, bb);
sfdotJp = N_VDotProd(fval, bb);
if (printfl > 2)
KINPrintInfo(kin_mem, PRNT_EPS, "KINSPBCG", "KINSpbcgSolve", INFO_EPS, *res_norm, eps);
/* Interpret return value from SpbcgSolve */
last_flag = ret;
switch(ret) {
case SPBCG_SUCCESS:
case SPBCG_RES_REDUCED:
return(0);
break;
case SPBCG_PSOLVE_FAIL_REC:
case SPBCG_ATIMES_FAIL_REC:
return(1);
break;
case SPBCG_CONV_FAIL:
case SPBCG_MEM_NULL:
case SPBCG_ATIMES_FAIL_UNREC:
case SPBCG_PSOLVE_FAIL_UNREC:
return(-1);
break;
}
return(0);
}
int CVSpgmr(void *cvode_mem, int pretype, int maxl)
{
CVodeMem cv_mem;
CVSpgmrMem cvspgmr_mem;
int mxl;
/* Return immediately if cvode_mem is NULL */
if (cvode_mem == NULL) {
fprintf(stderr, MSGS_CVMEM_NULL);
return(CVSPGMR_MEM_NULL);
}
cv_mem = (CVodeMem) cvode_mem;
/* Check if N_VDotProd is present */
if(vec_tmpl->ops->nvdotprod == NULL) {
if(errfp!=NULL) fprintf(errfp, MSGS_BAD_NVECTOR);
return(CVSPGMR_ILL_INPUT);
}
if (lfree != NULL) lfree(cv_mem);
/* Set four main function fields in cv_mem */
linit = CVSpgmrInit;
lsetup = CVSpgmrSetup;
lsolve = CVSpgmrSolve;
lfree = CVSpgmrFree;
/* Get memory for CVSpgmrMemRec */
cvspgmr_mem = (CVSpgmrMem) malloc(sizeof(CVSpgmrMemRec));
if (cvspgmr_mem == NULL) {
if(errfp!=NULL) fprintf(errfp, MSGS_MEM_FAIL);
return(CVSPGMR_MEM_FAIL);
}
/* Set Spgmr parameters that have been passed in call sequence */
cvspgmr_mem->g_pretype = pretype;
mxl = cvspgmr_mem->g_maxl = (maxl <= 0) ? CVSPGMR_MAXL : maxl;
/* Set default values for the rest of the Spgmr parameters */
cvspgmr_mem->g_gstype = MODIFIED_GS;
cvspgmr_mem->g_delt = CVSPGMR_DELT;
cvspgmr_mem->g_P_data = NULL;
cvspgmr_mem->g_pset = NULL;
cvspgmr_mem->g_psolve = NULL;
cvspgmr_mem->g_jtimes = CVSpgmrDQJtimes;
cvspgmr_mem->g_j_data = cvode_mem;
cvspgmr_mem->g_last_flag = CVSPGMR_SUCCESS;
setupNonNull = FALSE;
/* Check for legal pretype */
if ((pretype != PREC_NONE) && (pretype != PREC_LEFT) &&
(pretype != PREC_RIGHT) && (pretype != PREC_BOTH)) {
if(errfp!=NULL)
fprintf(errfp, MSGS_BAD_PRETYPE);
return(CVSPGMR_ILL_INPUT);
}
/* Allocate memory for ytemp and x */
ytemp = N_VClone(vec_tmpl);
if (ytemp == NULL) {
if(errfp!=NULL) fprintf(errfp, MSGS_MEM_FAIL);
return(CVSPGMR_MEM_FAIL);
}
x = N_VClone(vec_tmpl);
if (x == NULL) {
if(errfp!=NULL) fprintf(errfp, MSGS_MEM_FAIL);
N_VDestroy(ytemp);
return(CVSPGMR_MEM_FAIL);
}
/* Compute sqrtN from a dot product */
N_VConst(ONE, ytemp);
sqrtN = RSqrt( N_VDotProd(ytemp, ytemp) );
/* Call SpgmrMalloc to allocate workspace for Spgmr */
spgmr_mem = SpgmrMalloc(mxl, vec_tmpl);
if (spgmr_mem == NULL) {
if(errfp!=NULL) fprintf(errfp, MSGS_MEM_FAIL);
N_VDestroy(ytemp);
N_VDestroy(x);
return(CVSPGMR_MEM_FAIL);
}
/* Attach linear solver memory to integrator memory */
lmem = cvspgmr_mem;
return(CVSPGMR_SUCCESS);
}
/* 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 main(int argc, char *argv[])
{
realtype dx, reltol, abstol, t, tout;
N_Vector u;
UserData data;
void *cvode_mem;
int iout, flag, my_pe, npes;
long int local_N, nperpe, nrem, my_base;
realtype *pbar;
int is, *plist;
N_Vector *uS;
booleantype sensi, err_con;
int sensi_meth;
MPI_Comm comm;
u = NULL;
data = NULL;
cvode_mem = NULL;
pbar = NULL;
plist = NULL;
uS = NULL;
/* Get processor number, total number of pe's, and my_pe. */
MPI_Init(&argc, &argv);
comm = MPI_COMM_WORLD;
MPI_Comm_size(comm, &npes);
MPI_Comm_rank(comm, &my_pe);
/* Process arguments */
ProcessArgs(argc, argv, my_pe, &sensi, &sensi_meth, &err_con);
/* Set local vector length. */
nperpe = NEQ/npes;
nrem = NEQ - npes*nperpe;
local_N = (my_pe < nrem) ? nperpe+1 : nperpe;
my_base = (my_pe < nrem) ? my_pe*local_N : my_pe*nperpe + nrem;
/* USER DATA STRUCTURE */
data = (UserData) malloc(sizeof *data); /* Allocate data memory */
data->p = NULL;
if(check_flag((void *)data, "malloc", 2, my_pe)) MPI_Abort(comm, 1);
data->comm = comm;
data->npes = npes;
data->my_pe = my_pe;
data->p = (realtype *) malloc(NP * sizeof(realtype));
if(check_flag((void *)data->p, "malloc", 2, my_pe)) MPI_Abort(comm, 1);
dx = data->dx = XMAX/((realtype)(MX+1));
data->p[0] = RCONST(1.0);
data->p[1] = RCONST(0.5);
/* INITIAL STATES */
u = N_VNew_Parallel(comm, local_N, NEQ); /* Allocate u vector */
if(check_flag((void *)u, "N_VNew_Parallel", 0, my_pe)) MPI_Abort(comm, 1);
SetIC(u, dx, local_N, my_base); /* Initialize u vector */
/* TOLERANCES */
reltol = ZERO; /* Set the tolerances */
abstol = ATOL;
/* CVODE_CREATE & CVODE_MALLOC */
cvode_mem = CVodeCreate(CV_ADAMS, CV_FUNCTIONAL);
if(check_flag((void *)cvode_mem, "CVodeCreate", 0, my_pe)) MPI_Abort(comm, 1);
flag = CVodeSetUserData(cvode_mem, data);
if(check_flag(&flag, "CVodeSetUserData", 1, my_pe)) MPI_Abort(comm, 1);
flag = CVodeInit(cvode_mem, f, T0, u);
if(check_flag(&flag, "CVodeInit", 1, my_pe)) MPI_Abort(comm, 1);
flag = CVodeSStolerances(cvode_mem, reltol, abstol);
if(check_flag(&flag, "CVodeSStolerances", 1, my_pe)) MPI_Abort(comm, 1);
if (my_pe == 0) {
printf("\n1-D advection-diffusion equation, mesh size =%3d \n", MX);
printf("\nNumber of PEs = %3d \n",npes);
}
if(sensi) {
plist = (int *) malloc(NS * sizeof(int));
if(check_flag((void *)plist, "malloc", 2, my_pe)) MPI_Abort(comm, 1);
for(is=0; is<NS; is++)
plist[is] = is; /* sensitivity w.r.t. i-th parameter */
pbar = (realtype *) malloc(NS * sizeof(realtype));
if(check_flag((void *)pbar, "malloc", 2, my_pe)) MPI_Abort(comm, 1);
for(is=0; is<NS; is++) pbar[is] = data->p[plist[is]];
uS = N_VCloneVectorArray_Parallel(NS, u);
if(check_flag((void *)uS, "N_VCloneVectorArray_Parallel", 0, my_pe))
MPI_Abort(comm, 1);
for(is=0;is<NS;is++)
N_VConst(ZERO,uS[is]);
flag = CVodeSensInit1(cvode_mem, NS, sensi_meth, NULL, uS);
if(check_flag(&flag, "CVodeSensInit1", 1, my_pe)) MPI_Abort(comm, 1);
flag = CVodeSensEEtolerances(cvode_mem);
if(check_flag(&flag, "CVodeSensEEtolerances", 1, my_pe)) MPI_Abort(comm, 1);
flag = CVodeSetSensErrCon(cvode_mem, err_con);
if(check_flag(&flag, "CVodeSetSensErrCon", 1, my_pe)) MPI_Abort(comm, 1);
flag = CVodeSetSensDQMethod(cvode_mem, CV_CENTERED, ZERO);
if(check_flag(&flag, "CVodeSetSensDQMethod", 1, my_pe)) MPI_Abort(comm, 1);
flag = CVodeSetSensParams(cvode_mem, data->p, pbar, plist);
if(check_flag(&flag, "CVodeSetSensParams", 1, my_pe)) MPI_Abort(comm, 1);
if(my_pe == 0) {
printf("Sensitivity: YES ");
if(sensi_meth == CV_SIMULTANEOUS)
printf("( SIMULTANEOUS +");
else
if(sensi_meth == CV_STAGGERED) printf("( STAGGERED +");
else printf("( STAGGERED1 +");
if(err_con) printf(" FULL ERROR CONTROL )");
else printf(" PARTIAL ERROR CONTROL )");
}
} else {
if(my_pe == 0) printf("Sensitivity: NO ");
}
/* In loop over output points, call CVode, print results, test for error */
if(my_pe == 0) {
printf("\n\n");
printf("============================================================\n");
printf(" T Q H NST Max norm \n");
printf("============================================================\n");
}
for (iout=1, tout=T1; iout <= NOUT; iout++, tout += DTOUT) {
flag = CVode(cvode_mem, tout, u, &t, CV_NORMAL);
if(check_flag(&flag, "CVode", 1, my_pe)) break;
PrintOutput(cvode_mem, my_pe, t, u);
if (sensi) {
flag = CVodeGetSens(cvode_mem, &t, uS);
if(check_flag(&flag, "CVodeGetSens", 1, my_pe)) break;
PrintOutputS(my_pe, uS);
}
if (my_pe == 0)
printf("------------------------------------------------------------\n");
}
/* Print final statistics */
if (my_pe == 0)
PrintFinalStats(cvode_mem, sensi);
/* Free memory */
N_VDestroy(u); /* Free the u vector */
if (sensi)
N_VDestroyVectorArray(uS, NS); /* Free the uS vectors */
free(data->p); /* Free the p vector */
free(data); /* Free block of UserData */
CVodeFree(&cvode_mem); /* Free the CVODES problem memory */
free(pbar);
if(sensi) free(plist);
MPI_Finalize();
return(0);
}
/*---------------------------------------------------------------
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);
}
/*---------------------------------------------------------------
ARKMassSpbcgSolve:
This routine handles the call to the generic solver SpbcgSolve
for the solution of the mass matrix system Mx = b with the SPBCG
method. The solution x is returned in the vector b.
We set the tolerance parameter and initial guess (x = 0), call
SpbcgSolve, and copy the solution x into b. The
x-scaling and b-scaling arrays are both equal to weight.
The counters nli, nps, and ncfl are incremented, and the return
value is set according to the success of SpbcgSolve.
---------------------------------------------------------------*/
static int ARKMassSpbcgSolve(ARKodeMem ark_mem, N_Vector b,
N_Vector weight)
{
realtype res_norm;
ARKSpilsMassMem arkspils_mem;
SpbcgMem spbcg_mem;
int nli_inc, nps_inc, retval;
arkspils_mem = (ARKSpilsMassMem) ark_mem->ark_mass_mem;
spbcg_mem = (SpbcgMem) arkspils_mem->s_spils_mem;
/* Set inputs delta and initial guess x = 0 to SpbcgSolve */
arkspils_mem->s_deltar = arkspils_mem->s_eplifac * ark_mem->ark_eLTE;
arkspils_mem->s_delta = arkspils_mem->s_deltar * arkspils_mem->s_sqrtN;
N_VConst(ZERO, arkspils_mem->s_x);
/* Call SpbcgSolve and copy x to b */
retval = SpbcgSolve(spbcg_mem, ark_mem, arkspils_mem->s_x, b,
arkspils_mem->s_pretype, arkspils_mem->s_delta,
ark_mem, weight, weight, ARKSpilsMtimes,
ARKSpilsMPSolve, &res_norm, &nli_inc, &nps_inc);
N_VScale(ONE, arkspils_mem->s_x, b);
/* Increment counters nli, nps, and ncfl */
arkspils_mem->s_nli += nli_inc;
arkspils_mem->s_nps += nps_inc;
if (retval != SPBCG_SUCCESS) arkspils_mem->s_ncfl++;
/* Log solver statistics to diagnostics file (if requested) */
if (ark_mem->ark_report)
fprintf(ark_mem->ark_diagfp, " mass %19.16g %i %i\n",
res_norm, nli_inc, nps_inc);
/* Interpret return value from SpbcgSolve */
arkspils_mem->s_last_flag = retval;
switch(retval) {
case SPBCG_SUCCESS:
return(0);
break;
case SPBCG_RES_REDUCED:
return(1);
break;
case SPBCG_CONV_FAIL:
return(1);
break;
case SPBCG_PSOLVE_FAIL_REC:
return(1);
break;
case SPBCG_ATIMES_FAIL_REC:
return(1);
break;
case SPBCG_MEM_NULL:
return(-1);
break;
case SPBCG_ATIMES_FAIL_UNREC:
arkProcessError(ark_mem, SPBCG_ATIMES_FAIL_UNREC, "ARKSPBCG",
"ARKMassSpbcgSolve", MSGS_MTIMES_FAILED);
return(-1);
break;
case SPBCG_PSOLVE_FAIL_UNREC:
arkProcessError(ark_mem, SPBCG_PSOLVE_FAIL_UNREC, "ARKSPBCG",
"ARKMassSpbcgSolve", MSGS_PSOLVE_FAILED);
return(-1);
break;
}
return(0);
}
int main(void)
{
UserData data;
void *mem;
N_Vector yy, yp, id, q;
realtype tret, tout;
int flag;
id = N_VNew_Serial(NEQ);
yy = N_VNew_Serial(NEQ);
yp = N_VNew_Serial(NEQ);
q = N_VNew_Serial(1);
data = (UserData) malloc(sizeof *data);
data->a = 0.5; /* half-length of crank */
data->J1 = 1.0; /* crank moment of inertia */
data->m2 = 1.0; /* mass of connecting rod */
data->m1 = 1.0;
data->J2 = 2.0; /* moment of inertia of connecting rod */
data->params[0] = 1.0; /* spring constant */
data->params[1] = 1.0; /* damper constant */
data->l0 = 1.0; /* spring free length */
data->F = 1.0; /* external constant force */
N_VConst(ONE, id);
NV_Ith_S(id, 9) = ZERO;
NV_Ith_S(id, 8) = ZERO;
NV_Ith_S(id, 7) = ZERO;
NV_Ith_S(id, 6) = ZERO;
/* Consistent IC*/
setIC(yy, yp, data);
/* IDAS initialization */
mem = IDACreate();
flag = IDAInit(mem, ressc, TBEGIN, yy, yp);
flag = IDASStolerances(mem, RTOLF, ATOLF);
flag = IDASetUserData(mem, data);
flag = IDASetId(mem, id);
flag = IDASetSuppressAlg(mem, TRUE);
flag = IDASetMaxNumSteps(mem, 20000);
/* Call IDADense and set up the linear solver. */
flag = IDADense(mem, NEQ);
N_VConst(ZERO, q);
flag = IDAQuadInit(mem, rhsQ, q);
flag = IDAQuadSStolerances(mem, RTOLQ, ATOLQ);
flag = IDASetQuadErrCon(mem, TRUE);
PrintHeader(RTOLF, ATOLF, yy);
/* Print initial states */
PrintOutput(mem,0.0,yy);
/* Perform forward run */
tout = TEND/NOUT;
while (1) {
flag = IDASolve(mem, tout, &tret, yy, yp, IDA_NORMAL);
if (check_flag(&flag, "IDASolve", 1)) return(1);
PrintOutput(mem,tret,yy);
tout += TEND/NOUT;
if (tret > TEND) break;
}
PrintFinalStats(mem);
IDAGetQuad(mem, &tret, q);
printf("--------------------------------------------\n");
printf(" G = %24.16f\n", Ith(q,1));
printf("--------------------------------------------\n\n");
IDAFree(&mem);
/* Free memory */
free(data);
N_VDestroy(id);
N_VDestroy_Serial(yy);
N_VDestroy_Serial(yp);
N_VDestroy_Serial(q);
return(0);
}
int main(void)
{
UserData data;
void *mem;
N_Vector yy, yp, id, q, *yyS, *ypS, *qS;
realtype tret;
realtype pbar[2];
realtype dp, G, Gm[2], Gp[2];
int flag, is;
realtype atolS[NP];
id = N_VNew_Serial(NEQ);
yy = N_VNew_Serial(NEQ);
yp = N_VNew_Serial(NEQ);
q = N_VNew_Serial(1);
yyS= N_VCloneVectorArray(NP,yy);
ypS= N_VCloneVectorArray(NP,yp);
qS = N_VCloneVectorArray_Serial(NP, q);
data = (UserData) malloc(sizeof *data);
data->a = 0.5; /* half-length of crank */
data->J1 = 1.0; /* crank moment of inertia */
data->m2 = 1.0; /* mass of connecting rod */
data->m1 = 1.0;
data->J2 = 2.0; /* moment of inertia of connecting rod */
data->params[0] = 1.0; /* spring constant */
data->params[1] = 1.0; /* damper constant */
data->l0 = 1.0; /* spring free length */
data->F = 1.0; /* external constant force */
N_VConst(ONE, id);
NV_Ith_S(id, 9) = ZERO;
NV_Ith_S(id, 8) = ZERO;
NV_Ith_S(id, 7) = ZERO;
NV_Ith_S(id, 6) = ZERO;
printf("\nSlider-Crank example for IDAS:\n");
/* Consistent IC*/
setIC(yy, yp, data);
for (is=0;is<NP;is++) {
N_VConst(ZERO, yyS[is]);
N_VConst(ZERO, ypS[is]);
}
/* IDA initialization */
mem = IDACreate();
flag = IDAInit(mem, ressc, TBEGIN, yy, yp);
flag = IDASStolerances(mem, RTOLF, ATOLF);
flag = IDASetUserData(mem, data);
flag = IDASetId(mem, id);
flag = IDASetSuppressAlg(mem, TRUE);
flag = IDASetMaxNumSteps(mem, 20000);
/* Call IDADense and set up the linear solver. */
flag = IDADense(mem, NEQ);
flag = IDASensInit(mem, NP, IDA_SIMULTANEOUS, NULL, yyS, ypS);
pbar[0] = data->params[0];pbar[1] = data->params[1];
flag = IDASetSensParams(mem, data->params, pbar, NULL);
flag = IDASensEEtolerances(mem);
IDASetSensErrCon(mem, TRUE);
N_VConst(ZERO, q);
flag = IDAQuadInit(mem, rhsQ, q);
flag = IDAQuadSStolerances(mem, RTOLQ, ATOLQ);
flag = IDASetQuadErrCon(mem, TRUE);
N_VConst(ZERO, qS[0]);
flag = IDAQuadSensInit(mem, rhsQS, qS);
atolS[0] = atolS[1] = ATOLQ;
flag = IDAQuadSensSStolerances(mem, RTOLQ, atolS);
flag = IDASetQuadSensErrCon(mem, TRUE);
/* Perform forward run */
printf("\nForward integration ... ");
flag = IDASolve(mem, TEND, &tret, yy, yp, IDA_NORMAL);
if (check_flag(&flag, "IDASolve", 1)) return(1);
printf("done!\n");
PrintFinalStats(mem);
IDAGetQuad(mem, &tret, q);
printf("--------------------------------------------\n");
printf(" G = %24.16f\n", Ith(q,1));
printf("--------------------------------------------\n\n");
IDAGetQuadSens(mem, &tret, qS);
printf("-------------F O R W A R D------------------\n");
printf(" dG/dp: %12.4le %12.4le\n", Ith(qS[0],1), Ith(qS[1],1));
printf("--------------------------------------------\n\n");
IDAFree(&mem);
/* Finite differences for dG/dp */
dp = 0.00001;
data->params[0] = ONE;
data->params[1] = ONE;
mem = IDACreate();
setIC(yy, yp, data);
flag = IDAInit(mem, ressc, TBEGIN, yy, yp);
flag = IDASStolerances(mem, RTOLFD, ATOLFD);
flag = IDASetUserData(mem, data);
flag = IDASetId(mem, id);
flag = IDASetSuppressAlg(mem, TRUE);
/* Call IDADense and set up the linear solver. */
flag = IDADense(mem, NEQ);
N_VConst(ZERO, q);
IDAQuadInit(mem, rhsQ, q);
IDAQuadSStolerances(mem, RTOLQ, ATOLQ);
IDASetQuadErrCon(mem, TRUE);
IDASolve(mem, TEND, &tret, yy, yp, IDA_NORMAL);
IDAGetQuad(mem,&tret,q);
G = Ith(q,1);
/*printf(" G =%12.6e\n", Ith(q,1));*/
/******************************
* BACKWARD for k
******************************/
data->params[0] -= dp;
setIC(yy, yp, data);
IDAReInit(mem, TBEGIN, yy, yp);
N_VConst(ZERO, q);
IDAQuadReInit(mem, q);
IDASolve(mem, TEND, &tret, yy, yp, IDA_NORMAL);
IDAGetQuad(mem, &tret, q);
Gm[0] = Ith(q,1);
/*printf("Gm[0]=%12.6e\n", Ith(q,1));*/
/****************************
* FORWARD for k *
****************************/
data->params[0] += (TWO*dp);
setIC(yy, yp, data);
IDAReInit(mem, TBEGIN, yy, yp);
N_VConst(ZERO, q);
IDAQuadReInit(mem, q);
IDASolve(mem, TEND, &tret, yy, yp, IDA_NORMAL);
IDAGetQuad(mem, &tret, q);
Gp[0] = Ith(q,1);
/*printf("Gp[0]=%12.6e\n", Ith(q,1));*/
/* Backward for c */
data->params[0] = ONE;
data->params[1] -= dp;
setIC(yy, yp, data);
IDAReInit(mem, TBEGIN, yy, yp);
N_VConst(ZERO, q);
IDAQuadReInit(mem, q);
IDASolve(mem, TEND, &tret, yy, yp, IDA_NORMAL);
IDAGetQuad(mem, &tret, q);
Gm[1] = Ith(q,1);
/* Forward for c */
data->params[1] += (TWO*dp);
setIC(yy, yp, data);
IDAReInit(mem, TBEGIN, yy, yp);
N_VConst(ZERO, q);
IDAQuadReInit(mem, q);
IDASolve(mem, TEND, &tret, yy, yp, IDA_NORMAL);
IDAGetQuad(mem, &tret, q);
Gp[1] = Ith(q,1);
IDAFree(&mem);
printf("\n\n Checking using Finite Differences \n\n");
printf("---------------BACKWARD------------------\n");
printf(" dG/dp: %12.4le %12.4le\n", (G-Gm[0])/dp, (G-Gm[1])/dp);
printf("-----------------------------------------\n\n");
printf("---------------FORWARD-------------------\n");
printf(" dG/dp: %12.4le %12.4le\n", (Gp[0]-G)/dp, (Gp[1]-G)/dp);
printf("-----------------------------------------\n\n");
printf("--------------CENTERED-------------------\n");
printf(" dG/dp: %12.4le %12.4le\n", (Gp[0]-Gm[0])/(TWO*dp) ,(Gp[1]-Gm[1])/(TWO*dp));
printf("-----------------------------------------\n\n");
/* Free memory */
free(data);
N_VDestroy(id);
N_VDestroy_Serial(yy);
N_VDestroy_Serial(yp);
N_VDestroy_Serial(q);
return(0);
}
int IDASpgmr(void *ida_mem, int maxl)
{
IDAMem IDA_mem;
IDASpilsMem idaspils_mem;
SpgmrMem spgmr_mem;
int flag, maxl1;
/* Return immediately if ida_mem is NULL */
if (ida_mem == NULL) {
IDAProcessError(NULL, IDASPILS_MEM_NULL, "IDASPGMR", "IDASpgmr", 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, "IDASPGMR", "IDASpgmr", MSGS_BAD_NVECTOR);
return(IDASPILS_ILL_INPUT);
}
if (lfree != NULL) flag = lfree((IDAMem) ida_mem);
/* Set five main function fields in ida_mem */
linit = IDASpgmrInit;
lsetup = IDASpgmrSetup;
lsolve = IDASpgmrSolve;
lperf = IDASpgmrPerf;
lfree = IDASpgmrFree;
/* Get memory for IDASpilsMemRec */
idaspils_mem = NULL;
idaspils_mem = (IDASpilsMem) malloc(sizeof(struct IDASpilsMemRec));
if (idaspils_mem == NULL) {
IDAProcessError(NULL, IDASPILS_MEM_FAIL, "IDASPGMR", "IDASpgmr", MSGS_MEM_FAIL);
return(IDASPILS_MEM_FAIL);
}
/* Set ILS type */
idaspils_mem->s_type = SPILS_SPGMR;
/* Set SPGMR 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 Spgmr parameters */
idaspils_mem->s_gstype = MODIFIED_GS;
idaspils_mem->s_maxrs = IDA_SPILS_MAXRS;
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, "IDASPGMR", "IDASpgmr", 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, "IDASPGMR", "IDASpgmr", 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, "IDASPGMR", "IDASpgmr", 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 SpgmrMalloc to allocate workspace for Spgmr */
spgmr_mem = NULL;
spgmr_mem = SpgmrMalloc(maxl1, vec_tmpl);
if (spgmr_mem == NULL) {
IDAProcessError(NULL, IDASPILS_MEM_FAIL, "IDASPGMR", "IDASpgmr", MSGS_MEM_FAIL);
N_VDestroy(ytemp);
N_VDestroy(yptemp);
N_VDestroy(xx);
free(idaspils_mem); idaspils_mem = NULL;
return(IDASPILS_MEM_FAIL);
}
/* Attach SPGMR memory to spils memory structure */
spils_mem = (void *)spgmr_mem;
/* Attach linear solver memory to the integrator memory */
lmem = idaspils_mem;
return(IDASPILS_SUCCESS);
}
/* ----------------------------------------------------------------------
* SUNLinSol_SPGMR Linear Solver Testing Routine
*
* We run multiple tests to exercise this solver:
* 1. simple tridiagonal system (no preconditioning)
* 2. simple tridiagonal system (Jacobi preconditioning)
* 3. tridiagonal system w/ scale vector s1 (no preconditioning)
* 4. tridiagonal system w/ scale vector s1 (Jacobi preconditioning)
* 5. tridiagonal system w/ scale vector s2 (no preconditioning)
* 6. tridiagonal system w/ scale vector s2 (Jacobi preconditioning)
*
* Note: We construct a tridiagonal matrix Ahat, a random solution xhat,
* and a corresponding rhs vector bhat = Ahat*xhat, such that each
* of these is unit-less. To test row/column scaling, we use the
* matrix A = S1-inverse Ahat S2, rhs vector b = S1-inverse bhat,
* and solution vector x = (S2-inverse) xhat; hence the linear
* system has rows scaled by S1-inverse and columns scaled by S2,
* where S1 and S2 are the diagonal matrices with entries from the
* vectors s1 and s2, the 'scaling' vectors supplied to SPGMR
* having strictly positive entries. When this is combined with
* preconditioning, assume that Phat is the desired preconditioner
* for Ahat, then our preconditioning matrix P \approx A should be
* left prec: P-inverse \approx S1-inverse Ahat-inverse S1
* right prec: P-inverse \approx S2-inverse Ahat-inverse S2.
* Here we use a diagonal preconditioner D, so the S*-inverse
* and S* in the product cancel one another.
* --------------------------------------------------------------------*/
int main(int argc, char *argv[])
{
int fails=0; /* counter for test failures */
int passfail=0; /* overall pass/fail flag */
SUNLinearSolver LS; /* linear solver object */
N_Vector xhat, x, b; /* test vectors */
UserData ProbData; /* problem data structure */
int gstype, pretype, maxl, print_timing;
sunindextype i;
realtype *vecdata;
double tol;
/* check inputs: local problem size, timing flag */
if (argc < 7) {
printf("ERROR: SIX (6) Inputs required:\n");
printf(" Problem size should be >0\n");
printf(" Gram-Schmidt orthogonalization type should be 1 or 2\n");
printf(" Preconditioning type should be 1 or 2\n");
printf(" Maximum Krylov subspace dimension should be >0\n");
printf(" Solver tolerance should be >0\n");
printf(" timing output flag should be 0 or 1 \n");
return 1;
}
ProbData.N = atol(argv[1]);
problem_size = ProbData.N;
if (ProbData.N <= 0) {
printf("ERROR: Problem size must be a positive integer\n");
return 1;
}
gstype = atoi(argv[2]);
if ((gstype < 1) || (gstype > 2)) {
printf("ERROR: Gram-Schmidt orthogonalization type must be either 1 or 2\n");
return 1;
}
pretype = atoi(argv[3]);
if ((pretype < 1) || (pretype > 2)) {
printf("ERROR: Preconditioning type must be either 1 or 2\n");
return 1;
}
maxl = atoi(argv[4]);
if (maxl <= 0) {
printf("ERROR: Maximum Krylov subspace dimension must be a positive integer\n");
return 1;
}
tol = atof(argv[5]);
if (tol <= ZERO) {
printf("ERROR: Solver tolerance must be a positive real number\n");
return 1;
}
print_timing = atoi(argv[6]);
SetTiming(print_timing);
printf("\nSPGMR linear solver test:\n");
printf(" Problem size = %ld\n", (long int) ProbData.N);
printf(" Gram-Schmidt orthogonalization type = %i\n", gstype);
printf(" Preconditioning type = %i\n", pretype);
printf(" Maximum Krylov subspace dimension = %i\n", maxl);
printf(" Solver Tolerance = %"GSYM"\n", tol);
printf(" timing output flag = %i\n\n", print_timing);
/* Create vectors */
x = N_VNew_Serial(ProbData.N);
if (check_flag(x, "N_VNew_Serial", 0)) return 1;
xhat = N_VNew_Serial(ProbData.N);
if (check_flag(xhat, "N_VNew_Serial", 0)) return 1;
b = N_VNew_Serial(ProbData.N);
if (check_flag(b, "N_VNew_Serial", 0)) return 1;
ProbData.d = N_VNew_Serial(ProbData.N);
if (check_flag(ProbData.d, "N_VNew_Serial", 0)) return 1;
ProbData.s1 = N_VNew_Serial(ProbData.N);
if (check_flag(ProbData.s1, "N_VNew_Serial", 0)) return 1;
ProbData.s2 = N_VNew_Serial(ProbData.N);
if (check_flag(ProbData.s2, "N_VNew_Serial", 0)) return 1;
/* Fill xhat vector with uniform random data in [1,2] */
vecdata = N_VGetArrayPointer(xhat);
for (i=0; i<ProbData.N; i++)
vecdata[i] = ONE + urand();
/* Fill Jacobi vector with matrix diagonal */
N_VConst(FIVE, ProbData.d);
/* Create SPGMR linear solver */
LS = SUNLinSol_SPGMR(x, pretype, maxl);
fails += Test_SUNLinSolGetType(LS, SUNLINEARSOLVER_ITERATIVE, 0);
fails += Test_SUNLinSolSetATimes(LS, &ProbData, ATimes, 0);
fails += Test_SUNLinSolSetPreconditioner(LS, &ProbData, PSetup, PSolve, 0);
fails += Test_SUNLinSolSetScalingVectors(LS, ProbData.s1, ProbData.s2, 0);
fails += Test_SUNLinSolInitialize(LS, 0);
fails += Test_SUNLinSolSpace(LS, 0);
fails += SUNLinSol_SPGMRSetGSType(LS, gstype);
if (fails) {
printf("FAIL: SUNLinSol_SPGMR module failed %i initialization tests\n\n", fails);
return 1;
} else {
printf("SUCCESS: SUNLinSol_SPGMR module passed all initialization tests\n\n");
}
/*** Test 1: simple Poisson-like solve (no preconditioning) ***/
/* set scaling vectors */
N_VConst(ONE, ProbData.s1);
N_VConst(ONE, ProbData.s2);
/* Fill x vector with scaled version */
N_VDiv(xhat,ProbData.s2,x);
/* Fill b vector with result of matrix-vector product */
fails = ATimes(&ProbData, x, b);
if (check_flag(&fails, "ATimes", 1)) return 1;
/* Run tests with this setup */
fails += SUNLinSol_SPGMRSetPrecType(LS, PREC_NONE);
fails += Test_SUNLinSolSetup(LS, NULL, 0);
fails += Test_SUNLinSolSolve(LS, NULL, x, b, tol, 0);
fails += Test_SUNLinSolLastFlag(LS, 0);
fails += Test_SUNLinSolNumIters(LS, 0);
fails += Test_SUNLinSolResNorm(LS, 0);
fails += Test_SUNLinSolResid(LS, 0);
/* Print result */
if (fails) {
printf("FAIL: SUNLinSol_SPGMR module, problem 1, failed %i tests\n\n", fails);
passfail += 1;
} else {
printf("SUCCESS: SUNLinSol_SPGMR module, problem 1, passed all tests\n\n");
}
/*** Test 2: simple Poisson-like solve (Jacobi preconditioning) ***/
/* set scaling vectors */
N_VConst(ONE, ProbData.s1);
N_VConst(ONE, ProbData.s2);
/* Fill x vector with scaled version */
N_VDiv(xhat,ProbData.s2,x);
/* Fill b vector with result of matrix-vector product */
fails = ATimes(&ProbData, x, b);
if (check_flag(&fails, "ATimes", 1)) return 1;
/* Run tests with this setup */
fails += SUNLinSol_SPGMRSetPrecType(LS, pretype);
fails += Test_SUNLinSolSetup(LS, NULL, 0);
fails += Test_SUNLinSolSolve(LS, NULL, x, b, tol, 0);
fails += Test_SUNLinSolLastFlag(LS, 0);
fails += Test_SUNLinSolNumIters(LS, 0);
fails += Test_SUNLinSolResNorm(LS, 0);
fails += Test_SUNLinSolResid(LS, 0);
/* Print result */
if (fails) {
printf("FAIL: SUNLinSol_SPGMR module, problem 2, failed %i tests\n\n", fails);
passfail += 1;
} else {
printf("SUCCESS: SUNLinSol_SPGMR module, problem 2, passed all tests\n\n");
}
/*** Test 3: Poisson-like solve w/ scaled rows (no preconditioning) ***/
/* set scaling vectors */
vecdata = N_VGetArrayPointer(ProbData.s1);
for (i=0; i<ProbData.N; i++)
vecdata[i] = ONE + THOUSAND*urand();
N_VConst(ONE, ProbData.s2);
/* Fill x vector with scaled version */
N_VDiv(xhat,ProbData.s2,x);
/* Fill b vector with result of matrix-vector product */
fails = ATimes(&ProbData, x, b);
if (check_flag(&fails, "ATimes", 1)) return 1;
/* Run tests with this setup */
fails += SUNLinSol_SPGMRSetPrecType(LS, PREC_NONE);
fails += Test_SUNLinSolSetup(LS, NULL, 0);
fails += Test_SUNLinSolSolve(LS, NULL, x, b, tol, 0);
fails += Test_SUNLinSolLastFlag(LS, 0);
fails += Test_SUNLinSolNumIters(LS, 0);
fails += Test_SUNLinSolResNorm(LS, 0);
fails += Test_SUNLinSolResid(LS, 0);
/* Print result */
if (fails) {
printf("FAIL: SUNLinSol_SPGMR module, problem 3, failed %i tests\n\n", fails);
passfail += 1;
} else {
printf("SUCCESS: SUNLinSol_SPGMR module, problem 3, passed all tests\n\n");
}
/*** Test 4: Poisson-like solve w/ scaled rows (Jacobi preconditioning) ***/
/* set scaling vectors */
vecdata = N_VGetArrayPointer(ProbData.s1);
for (i=0; i<ProbData.N; i++)
vecdata[i] = ONE + THOUSAND*urand();
N_VConst(ONE, ProbData.s2);
/* Fill x vector with scaled version */
N_VDiv(xhat,ProbData.s2,x);
/* Fill b vector with result of matrix-vector product */
fails = ATimes(&ProbData, x, b);
if (check_flag(&fails, "ATimes", 1)) return 1;
/* Run tests with this setup */
fails += SUNLinSol_SPGMRSetPrecType(LS, pretype);
fails += Test_SUNLinSolSetup(LS, NULL, 0);
fails += Test_SUNLinSolSolve(LS, NULL, x, b, tol, 0);
fails += Test_SUNLinSolLastFlag(LS, 0);
fails += Test_SUNLinSolNumIters(LS, 0);
fails += Test_SUNLinSolResNorm(LS, 0);
fails += Test_SUNLinSolResid(LS, 0);
/* Print result */
if (fails) {
printf("FAIL: SUNLinSol_SPGMR module, problem 4, failed %i tests\n\n", fails);
passfail += 1;
} else {
printf("SUCCESS: SUNLinSol_SPGMR module, problem 4, passed all tests\n\n");
}
/*** Test 5: Poisson-like solve w/ scaled columns (no preconditioning) ***/
/* set scaling vectors */
N_VConst(ONE, ProbData.s1);
vecdata = N_VGetArrayPointer(ProbData.s2);
for (i=0; i<ProbData.N; i++)
vecdata[i] = ONE + THOUSAND*urand();
/* Fill x vector with scaled version */
N_VDiv(xhat,ProbData.s2,x);
/* Fill b vector with result of matrix-vector product */
fails = ATimes(&ProbData, x, b);
if (check_flag(&fails, "ATimes", 1)) return 1;
/* Run tests with this setup */
fails += SUNLinSol_SPGMRSetPrecType(LS, PREC_NONE);
fails += Test_SUNLinSolSetup(LS, NULL, 0);
fails += Test_SUNLinSolSolve(LS, NULL, x, b, tol, 0);
fails += Test_SUNLinSolLastFlag(LS, 0);
fails += Test_SUNLinSolNumIters(LS, 0);
fails += Test_SUNLinSolResNorm(LS, 0);
fails += Test_SUNLinSolResid(LS, 0);
/* Print result */
if (fails) {
printf("FAIL: SUNLinSol_SPGMR module, problem 5, failed %i tests\n\n", fails);
passfail += 1;
} else {
printf("SUCCESS: SUNLinSol_SPGMR module, problem 5, passed all tests\n\n");
}
/*** Test 6: Poisson-like solve w/ scaled columns (Jacobi preconditioning) ***/
/* set scaling vector, Jacobi solver vector */
N_VConst(ONE, ProbData.s1);
vecdata = N_VGetArrayPointer(ProbData.s2);
for (i=0; i<ProbData.N; i++)
vecdata[i] = ONE + THOUSAND*urand();
/* Fill x vector with scaled version */
N_VDiv(xhat,ProbData.s2,x);
/* Fill b vector with result of matrix-vector product */
fails = ATimes(&ProbData, x, b);
if (check_flag(&fails, "ATimes", 1)) return 1;
/* Run tests with this setup */
fails += SUNLinSol_SPGMRSetPrecType(LS, pretype);
fails += Test_SUNLinSolSetup(LS, NULL, 0);
fails += Test_SUNLinSolSolve(LS, NULL, x, b, tol, 0);
fails += Test_SUNLinSolLastFlag(LS, 0);
fails += Test_SUNLinSolNumIters(LS, 0);
fails += Test_SUNLinSolResNorm(LS, 0);
fails += Test_SUNLinSolResid(LS, 0);
/* Print result */
if (fails) {
printf("FAIL: SUNLinSol_SPGMR module, problem 6, failed %i tests\n\n", fails);
passfail += 1;
} else {
printf("SUCCESS: SUNLinSol_SPGMR module, problem 6, passed all tests\n\n");
}
/* Free solver and vectors */
SUNLinSolFree(LS);
N_VDestroy(x);
N_VDestroy(xhat);
N_VDestroy(b);
N_VDestroy(ProbData.d);
N_VDestroy(ProbData.s1);
N_VDestroy(ProbData.s2);
return(passfail);
}
int main(int argc, char *argv[])
{
SUNMatrix A;
SUNLinearSolver LS;
void *cvode_mem;
UserData data;
realtype t, tout;
N_Vector y, constraints;
int iout, retval;
realtype pbar[NS];
int is;
N_Vector *yS;
booleantype sensi, err_con;
int sensi_meth;
cvode_mem = NULL;
data = NULL;
y = NULL;
yS = NULL;
A = NULL;
LS = NULL;
constraints = NULL;
/* Process arguments */
ProcessArgs(argc, argv, &sensi, &sensi_meth, &err_con);
/* User data structure */
data = (UserData) malloc(sizeof *data);
if (check_retval((void *)data, "malloc", 2)) return(1);
data->p[0] = RCONST(0.04);
data->p[1] = RCONST(1.0e4);
data->p[2] = RCONST(3.0e7);
/* Initial conditions */
y = N_VNew_Serial(NEQ);
if (check_retval((void *)y, "N_VNew_Serial", 0)) return(1);
Ith(y,1) = Y1;
Ith(y,2) = Y2;
Ith(y,3) = Y3;
/* Set constraints to all 1's for nonnegative solution values. */
constraints = N_VNew_Serial(NEQ);
if(check_retval((void *)constraints, "N_VNew_Serial", 0)) return(1);
N_VConst(ONE, constraints);
/* Create CVODES object */
cvode_mem = CVodeCreate(CV_BDF);
if (check_retval((void *)cvode_mem, "CVodeCreate", 0)) return(1);
/* Allocate space for CVODES */
retval = CVodeInit(cvode_mem, f, T0, y);
if (check_retval(&retval, "CVodeInit", 1)) return(1);
/* Use private function to compute error weights */
retval = CVodeWFtolerances(cvode_mem, ewt);
if (check_retval(&retval, "CVodeSetEwtFn", 1)) return(1);
/* Attach user data */
retval = CVodeSetUserData(cvode_mem, data);
if (check_retval(&retval, "CVodeSetUserData", 1)) return(1);
/* Call CVodeSetConstraints to initialize constraints */
retval = CVodeSetConstraints(cvode_mem, constraints);
if(check_retval(&retval, "CVodeSetConstraints", 1)) return(1);
N_VDestroy(constraints);
/* Create dense SUNMatrix */
A = SUNDenseMatrix(NEQ, NEQ);
if (check_retval((void *)A, "SUNDenseMatrix", 0)) return(1);
/* Create dense SUNLinearSolver */
LS = SUNLinSol_Dense(y, A);
if (check_retval((void *)LS, "SUNLinSol_Dense", 0)) return(1);
/* Attach the matrix and linear solver */
retval = CVDlsSetLinearSolver(cvode_mem, LS, A);
if (check_retval(&retval, "CVDlsSetLinearSolver", 1)) return(1);
/* Set the user-supplied Jacobian routine Jac */
retval = CVDlsSetJacFn(cvode_mem, Jac);
if (check_retval(&retval, "CVDlsSetJacFn", 1)) return(1);
printf("\n3-species chemical kinetics problem\n");
/* Sensitivity-related settings */
if (sensi) {
/* Set parameter scaling factor */
pbar[0] = data->p[0];
pbar[1] = data->p[1];
pbar[2] = data->p[2];
/* Set sensitivity initial conditions */
yS = N_VCloneVectorArray(NS, y);
if (check_retval((void *)yS, "N_VCloneVectorArray", 0)) return(1);
for (is=0;is<NS;is++) N_VConst(ZERO, yS[is]);
/* Call CVodeSensInit1 to activate forward sensitivity computations
and allocate internal memory for COVEDS related to sensitivity
calculations. Computes the right-hand sides of the sensitivity
ODE, one at a time */
retval = CVodeSensInit1(cvode_mem, NS, sensi_meth, fS, yS);
if(check_retval(&retval, "CVodeSensInit", 1)) return(1);
/* Call CVodeSensEEtolerances to estimate tolerances for sensitivity
variables based on the rolerances supplied for states variables and
the scaling factor pbar */
retval = CVodeSensEEtolerances(cvode_mem);
if(check_retval(&retval, "CVodeSensEEtolerances", 1)) return(1);
/* Set sensitivity analysis optional inputs */
/* Call CVodeSetSensErrCon to specify the error control strategy for
sensitivity variables */
retval = CVodeSetSensErrCon(cvode_mem, err_con);
if (check_retval(&retval, "CVodeSetSensErrCon", 1)) return(1);
/* Call CVodeSetSensParams to specify problem parameter information for
sensitivity calculations */
retval = CVodeSetSensParams(cvode_mem, NULL, pbar, NULL);
if (check_retval(&retval, "CVodeSetSensParams", 1)) return(1);
printf("Sensitivity: YES ");
if(sensi_meth == CV_SIMULTANEOUS)
printf("( SIMULTANEOUS +");
else
if(sensi_meth == CV_STAGGERED) printf("( STAGGERED +");
else printf("( STAGGERED1 +");
if(err_con) printf(" FULL ERROR CONTROL )");
else printf(" PARTIAL ERROR CONTROL )");
} else {
printf("Sensitivity: NO ");
}
/* In loop over output points, call CVode, print results, test for error */
printf("\n\n");
printf("===========================================");
printf("============================\n");
printf(" T Q H NST y1");
printf(" y2 y3 \n");
printf("===========================================");
printf("============================\n");
for (iout=1, tout=T1; iout <= NOUT; iout++, tout *= TMULT) {
retval = CVode(cvode_mem, tout, y, &t, CV_NORMAL);
if (check_retval(&retval, "CVode", 1)) break;
PrintOutput(cvode_mem, t, y);
/* Call CVodeGetSens to get the sensitivity solution vector after a
successful return from CVode */
if (sensi) {
retval = CVodeGetSens(cvode_mem, &t, yS);
if (check_retval(&retval, "CVodeGetSens", 1)) break;
PrintOutputS(yS);
}
printf("-----------------------------------------");
printf("------------------------------\n");
}
/* Print final statistics */
PrintFinalStats(cvode_mem, sensi);
/* Free memory */
N_VDestroy(y); /* Free y vector */
if (sensi) {
N_VDestroyVectorArray(yS, NS); /* Free yS vector */
}
free(data); /* Free user data */
CVodeFree(&cvode_mem); /* Free CVODES memory */
SUNLinSolFree(LS); /* Free the linear solver memory */
SUNMatDestroy(A); /* Free the matrix memory */
return(0);
}
static void GSIter(realtype gamma, N_Vector z, N_Vector x,
WebData wdata)
{
int i, ic, iter, iyoff, jx, jy, ns, mxns, mx, my, x_loc, y_loc;
realtype beta[NS], beta2[NS], cof1[NS], gam[NS], gam2[NS];
realtype temp, *cox, *coy, *xd, *zd;
xd = N_VGetArrayPointer(x);
zd = N_VGetArrayPointer(z);
ns = wdata->ns;
mx = wdata->mx;
my = wdata->my;
mxns = wdata->mxns;
cox = wdata->cox;
coy = wdata->coy;
/* Write matrix as P = D - L - U.
Load local arrays beta, beta2, gam, gam2, and cof1. */
for (i = 0; i < ns; i++) {
temp = ONE/(ONE + RCONST(2.0)*gamma*(cox[i] + coy[i]));
beta[i] = gamma*cox[i]*temp;
beta2[i] = RCONST(2.0)*beta[i];
gam[i] = gamma*coy[i]*temp;
gam2[i] = RCONST(2.0)*gam[i];
cof1[i] = temp;
}
/* Begin iteration loop.
Load vector x with (D-inverse)*z for first iteration. */
for (jy = 0; jy < my; jy++) {
iyoff = mxns*jy;
for (jx = 0; jx < mx; jx++) {
ic = iyoff + ns*jx;
v_prod(xd+ic, cof1, zd+ic, ns); /* x[ic+i] = cof1[i]z[ic+i] */
}
}
N_VConst(ZERO, z);
/* Looping point for iterations. */
for (iter=1; iter <= ITMAX; iter++) {
/* Calculate (D-inverse)*U*x if not the first iteration. */
if (iter > 1) {
for (jy=0; jy < my; jy++) {
iyoff = mxns*jy;
for (jx=0; jx < mx; jx++) { /* order of loops matters */
ic = iyoff + ns*jx;
x_loc = (jx == 0) ? 0 : ((jx == mx-1) ? 2 : 1);
y_loc = (jy == 0) ? 0 : ((jy == my-1) ? 2 : 1);
switch (3*y_loc+x_loc) {
case 0 : /* jx == 0, jy == 0 */
/* x[ic+i] = beta2[i]x[ic+ns+i] + gam2[i]x[ic+mxns+i] */
v_sum_prods(xd+ic, beta2, xd+ic+ns, gam2, xd+ic+mxns, ns);
break;
case 1 : /* 1 <= jx <= mx-2, jy == 0 */
/* x[ic+i] = beta[i]x[ic+ns+i] + gam2[i]x[ic+mxns+i] */
v_sum_prods(xd+ic, beta, xd+ic+ns, gam2, xd+ic+mxns, ns);
break;
case 2 : /* jx == mx-1, jy == 0 */
/* x[ic+i] = gam2[i]x[ic+mxns+i] */
v_prod(xd+ic, gam2, xd+ic+mxns, ns);
break;
case 3 : /* jx == 0, 1 <= jy <= my-2 */
/* x[ic+i] = beta2[i]x[ic+ns+i] + gam[i]x[ic+mxns+i] */
v_sum_prods(xd+ic, beta2, xd+ic+ns, gam, xd+ic+mxns, ns);
break;
case 4 : /* 1 <= jx <= mx-2, 1 <= jy <= my-2 */
/* x[ic+i] = beta[i]x[ic+ns+i] + gam[i]x[ic+mxns+i] */
v_sum_prods(xd+ic, beta, xd+ic+ns, gam, xd+ic+mxns, ns);
break;
case 5 : /* jx == mx-1, 1 <= jy <= my-2 */
/* x[ic+i] = gam[i]x[ic+mxns+i] */
v_prod(xd+ic, gam, xd+ic+mxns, ns);
break;
case 6 : /* jx == 0, jy == my-1 */
/* x[ic+i] = beta2[i]x[ic+ns+i] */
v_prod(xd+ic, beta2, xd+ic+ns, ns);
break;
case 7 : /* 1 <= jx <= mx-2, jy == my-1 */
/* x[ic+i] = beta[i]x[ic+ns+i] */
v_prod(xd+ic, beta, xd+ic+ns, ns);
break;
case 8 : /* jx == mx-1, jy == my-1 */
/* x[ic+i] = ZERO */
v_zero(xd+ic, ns);
break;
}
}
}
} /* end if (iter > 1) */
/* Overwrite x with [(I - (D-inverse)*L)-inverse]*x. */
for (jy=0; jy < my; jy++) {
iyoff = mxns*jy;
for (jx=0; jx < mx; jx++) { /* order of loops matters */
ic = iyoff + ns*jx;
x_loc = (jx == 0) ? 0 : ((jx == mx-1) ? 2 : 1);
y_loc = (jy == 0) ? 0 : ((jy == my-1) ? 2 : 1);
switch (3*y_loc+x_loc) {
case 0 : /* jx == 0, jy == 0 */
break;
case 1 : /* 1 <= jx <= mx-2, jy == 0 */
/* x[ic+i] += beta[i]x[ic-ns+i] */
v_inc_by_prod(xd+ic, beta, xd+ic-ns, ns);
break;
case 2 : /* jx == mx-1, jy == 0 */
/* x[ic+i] += beta2[i]x[ic-ns+i] */
v_inc_by_prod(xd+ic, beta2, xd+ic-ns, ns);
break;
case 3 : /* jx == 0, 1 <= jy <= my-2 */
/* x[ic+i] += gam[i]x[ic-mxns+i] */
v_inc_by_prod(xd+ic, gam, xd+ic-mxns, ns);
break;
case 4 : /* 1 <= jx <= mx-2, 1 <= jy <= my-2 */
/* x[ic+i] += beta[i]x[ic-ns+i] + gam[i]x[ic-mxns+i] */
v_inc_by_prod(xd+ic, beta, xd+ic-ns, ns);
v_inc_by_prod(xd+ic, gam, xd+ic-mxns, ns);
break;
case 5 : /* jx == mx-1, 1 <= jy <= my-2 */
/* x[ic+i] += beta2[i]x[ic-ns+i] + gam[i]x[ic-mxns+i] */
v_inc_by_prod(xd+ic, beta2, xd+ic-ns, ns);
v_inc_by_prod(xd+ic, gam, xd+ic-mxns, ns);
break;
case 6 : /* jx == 0, jy == my-1 */
/* x[ic+i] += gam2[i]x[ic-mxns+i] */
v_inc_by_prod(xd+ic, gam2, xd+ic-mxns, ns);
break;
case 7 : /* 1 <= jx <= mx-2, jy == my-1 */
/* x[ic+i] += beta[i]x[ic-ns+i] + gam2[i]x[ic-mxns+i] */
v_inc_by_prod(xd+ic, beta, xd+ic-ns, ns);
v_inc_by_prod(xd+ic, gam2, xd+ic-mxns, ns);
break;
case 8 : /* jx == mx-1, jy == my-1 */
/* x[ic+i] += beta2[i]x[ic-ns+i] + gam2[i]x[ic-mxns+i] */
v_inc_by_prod(xd+ic, beta2, xd+ic-ns, ns);
v_inc_by_prod(xd+ic, gam2, xd+ic-mxns, ns);
break;
}
}
}
/* Add increment x to z : z <- z+x */
N_VLinearSum(ONE, z, ONE, x, z);
}
}
/*---------------------------------------------------------------
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);
}
int main(int argc, char *argv[])
{
realtype abstol=ATOL, reltol=RTOL, t;
N_Vector c;
WebData wdata;
void *cvode_mem;
SUNLinearSolver LS, LSB;
int retval, ncheck;
int indexB;
realtype reltolB=RTOL, abstolB=ATOL;
N_Vector cB;
c = NULL;
cB = NULL;
wdata = NULL;
cvode_mem = NULL;
LS = LSB = NULL;
/* Allocate and initialize user data */
wdata = AllocUserData();
if(check_retval((void *)wdata, "AllocUserData", 2)) return(1);
InitUserData(wdata);
/* Set-up forward problem */
/* Initializations */
c = N_VNew_Serial(NEQ+1);
if(check_retval((void *)c, "N_VNew_Serial", 0)) return(1);
CInit(c, wdata);
/* Call CVodeCreate/CVodeInit for forward run */
printf("\nCreate and allocate CVODES memory for forward run\n");
cvode_mem = CVodeCreate(CV_BDF);
if(check_retval((void *)cvode_mem, "CVodeCreate", 0)) return(1);
wdata->cvode_mem = cvode_mem; /* Used in Precond */
retval = CVodeSetUserData(cvode_mem, wdata);
if(check_retval(&retval, "CVodeSetUserData", 1)) return(1);
retval = CVodeInit(cvode_mem, f, T0, c);
if(check_retval(&retval, "CVodeInit", 1)) return(1);
retval = CVodeSStolerances(cvode_mem, reltol, abstol);
if(check_retval(&retval, "CVodeSStolerances", 1)) return(1);
/* Create SUNLinSol_SPGMR linear solver for forward run */
LS = SUNLinSol_SPGMR(c, PREC_LEFT, 0);
if(check_retval((void *)LS, "SUNLinSol_SPGMR", 0)) return(1);
/* Attach the linear sovler */
retval = CVodeSetLinearSolver(cvode_mem, LS, NULL);
if (check_retval(&retval, "CVodeSetLinearSolver", 1)) return 1;
/* Set the preconditioner solve and setup functions */
retval = CVodeSetPreconditioner(cvode_mem, Precond, PSolve);
if(check_retval(&retval, "CVodeSetPreconditioner", 1)) return(1);
/* Set-up adjoint calculations */
printf("\nAllocate global memory\n");
retval = CVodeAdjInit(cvode_mem, NSTEPS, CV_HERMITE);
if(check_retval(&retval, "CVadjInit", 1)) return(1);
/* Perform forward run */
printf("\nForward integration\n");
retval = CVodeF(cvode_mem, TOUT, c, &t, CV_NORMAL, &ncheck);
if(check_retval(&retval, "CVodeF", 1)) return(1);
printf("\nncheck = %d\n", ncheck);
#if defined(SUNDIALS_EXTENDED_PRECISION)
printf("\n G = int_t int_x int_y c%d(t,x,y) dx dy dt = %Lf \n\n",
ISPEC, N_VGetArrayPointer(c)[NEQ]);
#else
printf("\n G = int_t int_x int_y c%d(t,x,y) dx dy dt = %f \n\n",
ISPEC, N_VGetArrayPointer(c)[NEQ]);
#endif
/* Set-up backward problem */
/* Allocate cB */
cB = N_VNew_Serial(NEQ);
if(check_retval((void *)cB, "N_VNew_Serial", 0)) return(1);
/* Initialize cB = 0 */
N_VConst(ZERO, cB);
/* Create and allocate CVODES memory for backward run */
printf("\nCreate and allocate CVODES memory for backward run\n");
retval = CVodeCreateB(cvode_mem, CV_BDF, &indexB);
if(check_retval(&retval, "CVodeCreateB", 1)) return(1);
retval = CVodeSetUserDataB(cvode_mem, indexB, wdata);
if(check_retval(&retval, "CVodeSetUserDataB", 1)) return(1);
retval = CVodeSetMaxNumStepsB(cvode_mem, indexB, 1000);
if(check_retval(&retval, "CVodeSetMaxNumStepsB", 1)) return(1);
retval = CVodeInitB(cvode_mem, indexB, fB, TOUT, cB);
if(check_retval(&retval, "CVodeInitB", 1)) return(1);
retval = CVodeSStolerancesB(cvode_mem, indexB, reltolB, abstolB);
if(check_retval(&retval, "CVodeSStolerancesB", 1)) return(1);
wdata->indexB = indexB;
/* Create SUNLinSol_SPGMR linear solver for backward run */
LSB = SUNLinSol_SPGMR(cB, PREC_LEFT, 0);
if(check_retval((void *)LSB, "SUNLinSol_SPGMR", 0)) return(1);
/* Attach the linear sovler */
retval = CVodeSetLinearSolverB(cvode_mem, indexB, LSB, NULL);
if (check_retval(&retval, "CVodeSetLinearSolverB", 1)) return 1;
/* Set the preconditioner solve and setup functions */
retval = CVodeSetPreconditionerB(cvode_mem, indexB, PrecondB, PSolveB);
if(check_retval(&retval, "CVodeSetPreconditionerB", 1)) return(1);
/* Perform backward integration */
printf("\nBackward integration\n");
retval = CVodeB(cvode_mem, T0, CV_NORMAL);
if(check_retval(&retval, "CVodeB", 1)) return(1);
retval = CVodeGetB(cvode_mem, indexB, &t, cB);
if(check_retval(&retval, "CVodeGetB", 1)) return(1);
PrintOutput(cB, NS, MXNS, wdata);
/* Free all memory */
CVodeFree(&cvode_mem);
N_VDestroy(c);
N_VDestroy(cB);
SUNLinSolFree(LS);
SUNLinSolFree(LSB);
FreeUserData(wdata);
return(0);
}
int main(void)
{
void *mem;
UserData data;
N_Vector uu, up, constraints, id, res;
int ier, iout;
long int mu, ml, netf, ncfn;
realtype rtol, atol, t0, t1, tout, tret;
mem = NULL;
data = NULL;
uu = up = constraints = id = res = NULL;
/* Create vectors uu, up, res, constraints, id. */
uu = N_VNew_Serial(NEQ);
if(check_flag((void *)uu, "N_VNew_Serial", 0)) return(1);
up = N_VNew_Serial(NEQ);
if(check_flag((void *)up, "N_VNew_Serial", 0)) return(1);
res = N_VNew_Serial(NEQ);
if(check_flag((void *)res, "N_VNew_Serial", 0)) return(1);
constraints = N_VNew_Serial(NEQ);
if(check_flag((void *)constraints, "N_VNew_Serial", 0)) return(1);
id = N_VNew_Serial(NEQ);
if(check_flag((void *)id, "N_VNew_Serial", 0)) return(1);
/* Create and load problem data block. */
data = (UserData) malloc(sizeof *data);
if(check_flag((void *)data, "malloc", 2)) return(1);
data->mm = MGRID;
data->dx = ONE/(MGRID - ONE);
data->coeff = ONE/( (data->dx) * (data->dx) );
/* Initialize uu, up, id. */
SetInitialProfile(data, uu, up, id, res);
/* Set constraints to all 1's for nonnegative solution values. */
N_VConst(ONE, constraints);
/* Set remaining input parameters. */
t0 = ZERO;
t1 = RCONST(0.01);
rtol = ZERO;
atol = RCONST(1.0e-3);
/* Call IDACreate and IDAMalloc to initialize solution */
mem = IDACreate();
if(check_flag((void *)mem, "IDACreate", 0)) return(1);
ier = IDASetUserData(mem, data);
if(check_flag(&ier, "IDASetUserData", 1)) return(1);
ier = IDASetId(mem, id);
if(check_flag(&ier, "IDASetId", 1)) return(1);
ier = IDASetConstraints(mem, constraints);
if(check_flag(&ier, "IDASetConstraints", 1)) return(1);
N_VDestroy_Serial(constraints);
ier = IDAInit(mem, heatres, t0, uu, up);
if(check_flag(&ier, "IDAInit", 1)) return(1);
ier = IDASStolerances(mem, rtol, atol);
if(check_flag(&ier, "IDASStolerances", 1)) return(1);
/* Call IDABand to specify the linear solver. */
mu = MGRID; ml = MGRID;
ier = IDABand(mem, NEQ, mu, ml);
if(check_flag(&ier, "IDABand", 1)) return(1);
/* Call IDACalcIC to correct the initial values. */
ier = IDACalcIC(mem, IDA_YA_YDP_INIT, t1);
if(check_flag(&ier, "IDACalcIC", 1)) return(1);
/* Print output heading. */
PrintHeader(rtol, atol);
PrintOutput(mem, t0, uu);
/* Loop over output times, call IDASolve, and print results. */
for (tout = t1, iout = 1; iout <= NOUT; iout++, tout *= TWO) {
ier = IDASolve(mem, tout, &tret, uu, up, IDA_NORMAL);
if(check_flag(&ier, "IDASolve", 1)) return(1);
PrintOutput(mem, tret, uu);
}
/* Print remaining counters and free memory. */
ier = IDAGetNumErrTestFails(mem, &netf);
check_flag(&ier, "IDAGetNumErrTestFails", 1);
ier = IDAGetNumNonlinSolvConvFails(mem, &ncfn);
check_flag(&ier, "IDAGetNumNonlinSolvConvFails", 1);
printf("\n netf = %ld, ncfn = %ld \n", netf, ncfn);
IDAFree(&mem);
N_VDestroy_Serial(uu);
N_VDestroy_Serial(up);
N_VDestroy_Serial(id);
N_VDestroy_Serial(res);
free(data);
return(0);
}
/* Fortran interface routine to re-initialize ARKStep memory
structure; functions as an all-in-one interface to the C
routines ARKStepReInit and ARKStepSStolerances (or
ARKStepSVtolerances); see farkode.h for further details */
void FARK_REINIT(realtype *t0, realtype *y0, int *imex, int *iatol,
realtype *rtol, realtype *atol, int *ier) {
N_Vector Vatol;
realtype reltol, abstol;
*ier = 0;
/* Initialize all pointers to NULL */
Vatol = NULL;
/* Set data in F2C_ARKODE_vec to y0 */
N_VSetArrayPointer(y0, F2C_ARKODE_vec);
/* Call ARKStepReInit based on imex argument */
switch (*imex) {
case 0: /* purely implicit */
*ier = ARKStepReInit(ARK_arkodemem, NULL, FARKfi,
*t0, F2C_ARKODE_vec);
break;
case 1: /* purely explicit */
*ier = ARKStepReInit(ARK_arkodemem, FARKfe, NULL,
*t0, F2C_ARKODE_vec);
break;
case 2: /* imex */
*ier = ARKStepReInit(ARK_arkodemem, FARKfe, FARKfi,
*t0, F2C_ARKODE_vec);
break;
}
/* Reset data pointers */
N_VSetArrayPointer(NULL, F2C_ARKODE_vec);
/* On failure, exit */
if (*ier != ARK_SUCCESS) {
*ier = -1;
return;
}
/* Set tolerances */
reltol = RELTOL;
abstol = ABSTOL;
if (*rtol > ZERO) reltol = *rtol;
switch (*iatol) {
case 1:
if (*atol > ZERO) abstol = *atol;
*ier = ARKStepSStolerances(ARK_arkodemem, reltol, abstol);
break;
case 2:
Vatol = N_VCloneEmpty(F2C_ARKODE_vec);
if (Vatol == NULL) {
*ier = -1;
return;
}
N_VSetArrayPointer(atol, Vatol);
if (N_VMin(Vatol) <= ZERO) N_VConst(abstol, Vatol);
*ier = ARKStepSVtolerances(ARK_arkodemem, reltol, Vatol);
N_VDestroy(Vatol);
break;
}
/* On failure, exit */
if (*ier != ARK_SUCCESS) {
*ier = -1;
return;
}
return;
}
/*
* -----------------------------------------------------------------
* Function : cpSpbcgSolve
* -----------------------------------------------------------------
* This routine handles the call to the generic solver SpbcgSolve
* for the solution of the linear system Ax = b with the SPBCG method.
* The solution x is returned in the vector b.
*
* If the WRMS norm of b is small, we return x = b (if this is the first
* Newton iteration) or x = 0 (if a later Newton iteration).
*
* Otherwise, we set the tolerance parameter and initial guess (x = 0),
* call SpbcgSolve, and copy the solution x into b. The x-scaling and
* b-scaling arrays are both equal to weight.
*
* The counters nli, nps, and ncfl are incremented, and the return value
* is set according to the success of SpbcgSolve. The success flag is
* returned if SpbcgSolve converged, or if this is the first Newton
* iteration and the residual norm was reduced below its initial value.
* -----------------------------------------------------------------
*/
static int cpSpbcgSolve(CPodeMem cp_mem, N_Vector b, N_Vector weight,
N_Vector yC, N_Vector ypC, N_Vector fctC)
{
realtype bnorm, res_norm;
CPSpilsMem cpspils_mem;
SpbcgMem spbcg_mem;
int nli_inc, nps_inc, retval;
cpspils_mem = (CPSpilsMem) lmem;
spbcg_mem = (SpbcgMem) spils_mem;
/* Test norm(b); if small, return x = 0 or x = b */
deltar = delt * tq[4];
bnorm = N_VWrmsNorm(b, weight);
if (bnorm <= deltar) {
if (mnewt > 0) N_VConst(ZERO, b);
return(0);
}
/* Set vectors ycur and fcur for use by the Atimes and Psolve routines */
ycur = yC;
ypcur = ypC;
fcur = fctC;
/* Set inputs delta and initial guess x = 0 to SpbcgSolve */
delta = deltar * sqrtN;
N_VConst(ZERO, x);
/* Call SpbcgSolve and copy x to b */
retval = SpbcgSolve(spbcg_mem, cp_mem, x, b, pretype, delta,
cp_mem, weight, weight, cpSpilsAtimes, cpSpilsPSolve,
&res_norm, &nli_inc, &nps_inc);
N_VScale(ONE, x, b);
/* Increment counters nli, nps, and ncfl */
nli += nli_inc;
nps += nps_inc;
if (retval != SPBCG_SUCCESS) ncfl++;
/* Interpret return value from SpbcgSolve */
last_flag = retval;
switch(retval) {
case SPBCG_SUCCESS:
return(0);
break;
case SPBCG_RES_REDUCED:
if (mnewt == 0) return(0);
else return(1);
break;
case SPBCG_CONV_FAIL:
return(1);
break;
case SPBCG_PSOLVE_FAIL_REC:
return(1);
break;
case SPBCG_ATIMES_FAIL_REC:
return(1);
break;
case SPBCG_MEM_NULL:
return(-1);
break;
case SPBCG_ATIMES_FAIL_UNREC:
cpProcessError(cp_mem, SPBCG_ATIMES_FAIL_UNREC, "CPSPBCG", "CPSpbcgSolve", MSGS_JTIMES_FAILED);
return(-1);
break;
case SPBCG_PSOLVE_FAIL_UNREC:
cpProcessError(cp_mem, SPBCG_PSOLVE_FAIL_UNREC, "CPSPBCG", "CPSpbcgSolve", MSGS_PSOLVE_FAILED);
return(-1);
break;
}
return(0);
}
/* Fortran interface routine to initialize ARKStep memory
structure; functions as an all-in-one interface to the C
routines ARKStepCreate, ARKStepSetUserData, and
ARKStepSStolerances (or ARKStepSVtolerances); see farkode.h
for further details */
void FARK_MALLOC(realtype *t0, realtype *y0, int *imex,
int *iatol, realtype *rtol, realtype *atol,
long int *iout, realtype *rout,
long int *ipar, realtype *rpar, int *ier) {
N_Vector Vatol;
FARKUserData ARK_userdata;
realtype reltol, abstol;
*ier = 0;
/* Check for required vector operations */
if(F2C_ARKODE_vec->ops->nvgetarraypointer == NULL) {
*ier = -1;
fprintf(stderr, "Error: getarraypointer vector operation is not implemented.\n\n");
return;
}
if(F2C_ARKODE_vec->ops->nvsetarraypointer == NULL) {
*ier = -1;
fprintf(stderr, "Error: setarraypointer vector operation is not implemented.\n\n");
return;
}
if(F2C_ARKODE_vec->ops->nvcloneempty == NULL) {
*ier = -1;
fprintf(stderr, "Error: cloneempty vector operation is not implemented.\n\n");
return;
}
/* Initialize all pointers to NULL */
ARK_arkodemem = NULL;
Vatol = NULL;
/* initialize global constants to disable each option */
ARK_nrtfn = 0;
ARK_ls = SUNFALSE;
ARK_mass_ls = SUNFALSE;
/* Set data in F2C_ARKODE_vec to y0 */
N_VSetArrayPointer(y0, F2C_ARKODE_vec);
/* Call ARKStepCreate based on imex argument */
switch (*imex) {
case 0: /* purely implicit */
ARK_arkodemem = ARKStepCreate(NULL, FARKfi, *t0, F2C_ARKODE_vec);
break;
case 1: /* purely explicit */
ARK_arkodemem = ARKStepCreate(FARKfe, NULL, *t0, F2C_ARKODE_vec);
FARKNullMatrix();
FARKNullLinsol();
FARKNullNonlinsol();
break;
case 2: /* imex */
ARK_arkodemem = ARKStepCreate(FARKfe, FARKfi, *t0, F2C_ARKODE_vec);
break;
}
if (ARK_arkodemem == NULL) {
*ier = -1;
return;
}
/* Set and attach user data */
ARK_userdata = NULL;
ARK_userdata = (FARKUserData) malloc(sizeof *ARK_userdata);
if (ARK_userdata == NULL) {
*ier = -1;
return;
}
ARK_userdata->rpar = rpar;
ARK_userdata->ipar = ipar;
*ier = ARKStepSetUserData(ARK_arkodemem, ARK_userdata);
if(*ier != ARK_SUCCESS) {
free(ARK_userdata); ARK_userdata = NULL;
*ier = -1;
return;
}
/* Reset data pointers */
N_VSetArrayPointer(NULL, F2C_ARKODE_vec);
/* Set tolerances -- if <= 0, keep as defaults */
reltol = RELTOL;
abstol = ABSTOL;
if (*rtol > ZERO) reltol = *rtol;
switch (*iatol) {
case 1:
if (*atol > ZERO) abstol = *atol;
*ier = ARKStepSStolerances(ARK_arkodemem, reltol, abstol);
break;
case 2:
Vatol = N_VCloneEmpty(F2C_ARKODE_vec);
if (Vatol == NULL) {
free(ARK_userdata);
ARK_userdata = NULL;
*ier = -1;
return;
}
N_VSetArrayPointer(atol, Vatol);
if (N_VMin(Vatol) <= ZERO) N_VConst(abstol, Vatol);
*ier = ARKStepSVtolerances(ARK_arkodemem, reltol, Vatol);
N_VDestroy(Vatol);
break;
}
/* On failure, exit */
if(*ier != ARK_SUCCESS) {
free(ARK_userdata);
ARK_userdata = NULL;
*ier = -1;
return;
}
/* store pointers to optional output arrays in global vars */
ARK_iout = iout;
ARK_rout = rout;
/* Store the unit roundoff in rout for user access */
ARK_rout[5] = UNIT_ROUNDOFF;
return;
}
int main()
{
void *mem;
UserData data;
N_Vector uu, up, constraints, res;
int ier, iout;
realtype rtol, atol, t0, t1, tout, tret;
long int netf, ncfn, ncfl;
mem = NULL;
data = NULL;
uu = up = constraints = res = NULL;
/* Allocate N-vectors and the user data structure. */
uu = N_VNew_Serial(NEQ);
if(check_flag((void *)uu, "N_VNew_Serial", 0)) return(1);
up = N_VNew_Serial(NEQ);
if(check_flag((void *)up, "N_VNew_Serial", 0)) return(1);
res = N_VNew_Serial(NEQ);
if(check_flag((void *)res, "N_VNew_Serial", 0)) return(1);
constraints = N_VNew_Serial(NEQ);
if(check_flag((void *)constraints, "N_VNew_Serial", 0)) return(1);
data = (UserData) malloc(sizeof *data);
data->pp = NULL;
if(check_flag((void *)data, "malloc", 2)) return(1);
/* Assign parameters in the user data structure. */
data->mm = MGRID;
data->dx = ONE/(MGRID-ONE);
data->coeff = ONE/(data->dx * data->dx);
data->pp = N_VNew_Serial(NEQ);
if(check_flag((void *)data->pp, "N_VNew_Serial", 0)) return(1);
/* Initialize uu, up. */
SetInitialProfile(data, uu, up, res);
/* Set constraints to all 1's for nonnegative solution values. */
N_VConst(ONE, constraints);
/* Assign various parameters. */
t0 = ZERO;
t1 = RCONST(0.01);
rtol = ZERO;
atol = RCONST(1.0e-3);
/* Call IDACreate and IDAMalloc to initialize solution */
mem = IDACreate();
if(check_flag((void *)mem, "IDACreate", 0)) return(1);
ier = IDASetRdata(mem, data);
if(check_flag(&ier, "IDASetRdata", 1)) return(1);
ier = IDASetConstraints(mem, constraints);
if(check_flag(&ier, "IDASetConstraints", 1)) return(1);
N_VDestroy_Serial(constraints);
ier = IDAMalloc(mem, resHeat, t0, uu, up, IDA_SS, rtol, &atol);
if(check_flag(&ier, "IDAMalloc", 1)) return(1);
/* Call IDASpgmr to specify the linear solver. */
ier = IDASpgmr(mem, 0);
if(check_flag(&ier, "IDASpgmr", 1)) return(1);
ier = IDASpgmrSetPreconditioner(mem, PsetupHeat, PsolveHeat, data);
if(check_flag(&ier, "IDASpgmrSetPreconditioner", 1)) return(1);
/* Print output heading. */
PrintHeader(rtol, atol);
/*
* -------------------------------------------------------------------------
* CASE I
* -------------------------------------------------------------------------
*/
/* Print case number, output table heading, and initial line of table. */
printf("\n\nCase 1: gsytpe = MODIFIED_GS\n");
printf("\n Output Summary (umax = max-norm of solution) \n\n");
printf(" time umax k nst nni nje nre nreS h npe nps\n" );
printf("----------------------------------------------------------------------\n");
/* Loop over output times, call IDASolve, and print results. */
for (tout = t1,iout = 1; iout <= NOUT ; iout++, tout *= TWO) {
ier = IDASolve(mem, tout, &tret, uu, up, IDA_NORMAL);
if(check_flag(&ier, "IDASolve", 1)) return(1);
PrintOutput(mem, tret, uu);
}
/* Print remaining counters. */
ier = IDAGetNumErrTestFails(mem, &netf);
check_flag(&ier, "IDAGetNumErrTestFails", 1);
ier = IDAGetNumNonlinSolvConvFails(mem, &ncfn);
check_flag(&ier, "IDAGetNumNonlinSolvConvFails", 1);
ier = IDASpgmrGetNumConvFails(mem, &ncfl);
check_flag(&ier, "IDASpgmrGetNumConvFails", 1);
printf("\nError test failures = %ld\n", netf);
printf("Nonlinear convergence failures = %ld\n", ncfn);
printf("Linear convergence failures = %ld\n", ncfl);
/*
* -------------------------------------------------------------------------
* CASE II
* -------------------------------------------------------------------------
*/
/* Re-initialize uu, up. */
SetInitialProfile(data, uu, up, res);
/* Re-initialize IDA and IDASPGMR */
ier = IDAReInit(mem, resHeat, t0, uu, up, IDA_SS, rtol, &atol);
if(check_flag(&ier, "IDAReInit", 1)) return(1);
ier = IDASpgmrSetGSType(mem, CLASSICAL_GS);
if(check_flag(&ier, "IDASpgmrSetGSType",1)) return(1);
/* Print case number, output table heading, and initial line of table. */
printf("\n\nCase 2: gstype = CLASSICAL_GS\n");
printf("\n Output Summary (umax = max-norm of solution) \n\n");
printf(" time umax k nst nni nje nre nreS h npe nps\n" );
printf("----------------------------------------------------------------------\n");
/* Loop over output times, call IDASolve, and print results. */
for (tout = t1,iout = 1; iout <= NOUT ; iout++, tout *= TWO) {
ier = IDASolve(mem, tout, &tret, uu, up, IDA_NORMAL);
if(check_flag(&ier, "IDASolve", 1)) return(1);
PrintOutput(mem, tret, uu);
}
/* Print remaining counters. */
ier = IDAGetNumErrTestFails(mem, &netf);
check_flag(&ier, "IDAGetNumErrTestFails", 1);
ier = IDAGetNumNonlinSolvConvFails(mem, &ncfn);
check_flag(&ier, "IDAGetNumNonlinSolvConvFails", 1);
ier = IDASpgmrGetNumConvFails(mem, &ncfl);
check_flag(&ier, "IDASpgmrGetNumConvFails", 1);
printf("\nError test failures = %ld\n", netf);
printf("Nonlinear convergence failures = %ld\n", ncfn);
printf("Linear convergence failures = %ld\n", ncfl);
/* Free Memory */
IDAFree(mem);
N_VDestroy_Serial(uu);
N_VDestroy_Serial(up);
N_VDestroy_Serial(res);
N_VDestroy_Serial(data->pp);
free(data);
return(0);
}
int main(int argc, char *argv[])
{
void *cvode_mem;
UserData data;
realtype dx, reltol, abstol, t, tout;
N_Vector u;
int iout, flag;
realtype *pbar;
int is, *plist;
N_Vector *uS;
booleantype sensi, err_con;
int sensi_meth;
cvode_mem = NULL;
data = NULL;
u = NULL;
pbar = NULL;
plist = NULL;
uS = NULL;
/* Process arguments */
ProcessArgs(argc, argv, &sensi, &sensi_meth, &err_con);
/* Set user data */
data = (UserData) malloc(sizeof *data); /* Allocate data memory */
if(check_flag((void *)data, "malloc", 2)) return(1);
data->p = (realtype *) malloc(NP * sizeof(realtype));
dx = data->dx = XMAX/((realtype)(MX+1));
data->p[0] = RCONST(1.0);
data->p[1] = RCONST(0.5);
/* Allocate and set initial states */
u = N_VNew_Serial(NEQ);
if(check_flag((void *)u, "N_VNew_Serial", 0)) return(1);
SetIC(u, dx);
/* Set integration tolerances */
reltol = ZERO;
abstol = ATOL;
/* Create CVODES object */
cvode_mem = CVodeCreate(CV_ADAMS, CV_FUNCTIONAL);
if(check_flag((void *)cvode_mem, "CVodeCreate", 0)) return(1);
flag = CVodeSetUserData(cvode_mem, data);
if(check_flag(&flag, "CVodeSetUserData", 1)) return(1);
/* Allocate CVODES memory */
flag = CVodeInit(cvode_mem, f, T0, u);
if(check_flag(&flag, "CVodeInit", 1)) return(1);
flag = CVodeSStolerances(cvode_mem, reltol, abstol);
if(check_flag(&flag, "CVodeSStolerances", 1)) return(1);
printf("\n1-D advection-diffusion equation, mesh size =%3d\n", MX);
/* Sensitivity-related settings */
if(sensi) {
plist = (int *) malloc(NS * sizeof(int));
if(check_flag((void *)plist, "malloc", 2)) return(1);
for(is=0; is<NS; is++) plist[is] = is;
pbar = (realtype *) malloc(NS * sizeof(realtype));
if(check_flag((void *)pbar, "malloc", 2)) return(1);
for(is=0; is<NS; is++) pbar[is] = data->p[plist[is]];
uS = N_VCloneVectorArray_Serial(NS, u);
if(check_flag((void *)uS, "N_VCloneVectorArray_Serial", 0)) return(1);
for(is=0;is<NS;is++)
N_VConst(ZERO, uS[is]);
flag = CVodeSensInit1(cvode_mem, NS, sensi_meth, NULL, uS);
if(check_flag(&flag, "CVodeSensInit1", 1)) return(1);
flag = CVodeSensEEtolerances(cvode_mem);
if(check_flag(&flag, "CVodeSensEEtolerances", 1)) return(1);
flag = CVodeSetSensErrCon(cvode_mem, err_con);
if(check_flag(&flag, "CVodeSetSensErrCon", 1)) return(1);
flag = CVodeSetSensDQMethod(cvode_mem, CV_CENTERED, ZERO);
if(check_flag(&flag, "CVodeSetSensDQMethod", 1)) return(1);
flag = CVodeSetSensParams(cvode_mem, data->p, pbar, plist);
if(check_flag(&flag, "CVodeSetSensParams", 1)) return(1);
printf("Sensitivity: YES ");
if(sensi_meth == CV_SIMULTANEOUS)
printf("( SIMULTANEOUS +");
else
if(sensi_meth == CV_STAGGERED) printf("( STAGGERED +");
else printf("( STAGGERED1 +");
if(err_con) printf(" FULL ERROR CONTROL )");
else printf(" PARTIAL ERROR CONTROL )");
} else {
printf("Sensitivity: NO ");
}
/* In loop over output points, call CVode, print results, test for error */
printf("\n\n");
printf("============================================================\n");
printf(" T Q H NST Max norm \n");
printf("============================================================\n");
for (iout=1, tout=T1; iout <= NOUT; iout++, tout += DTOUT) {
flag = CVode(cvode_mem, tout, u, &t, CV_NORMAL);
if(check_flag(&flag, "CVode", 1)) break;
PrintOutput(cvode_mem, t, u);
if (sensi) {
flag = CVodeGetSens(cvode_mem, &t, uS);
if(check_flag(&flag, "CVodeGetSens", 1)) break;
PrintOutputS(uS);
}
printf("------------------------------------------------------------\n");
}
/* Print final statistics */
PrintFinalStats(cvode_mem, sensi);
/* Free memory */
N_VDestroy_Serial(u);
if (sensi) {
N_VDestroyVectorArray_Serial(uS, NS);
free(plist);
free(pbar);
}
free(data);
CVodeFree(&cvode_mem);
return(0);
}
int CVSptfqmr(void *cvode_mem, int pretype, int maxl)
{
CVodeMem cv_mem;
CVSpilsMem cvspils_mem;
SptfqmrMem sptfqmr_mem;
int mxl;
/* Return immediately if cvode_mem is NULL */
if (cvode_mem == NULL) {
CVProcessError(NULL, CVSPILS_MEM_NULL, "CVSPTFQMR", "CVSptfqmr", 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, "CVSPTFQMR", "CVSptfqmr", MSGS_BAD_NVECTOR);
return(CVSPILS_ILL_INPUT);
}
if (lfree != NULL) lfree(cv_mem);
/* Set four main function fields in cv_mem */
linit = CVSptfqmrInit;
lsetup = CVSptfqmrSetup;
lsolve = CVSptfqmrSolve;
lfree = CVSptfqmrFree;
/* Get memory for CVSpilsMemRec */
cvspils_mem = NULL;
cvspils_mem = (CVSpilsMem) malloc(sizeof(struct CVSpilsMemRec));
if (cvspils_mem == NULL) {
CVProcessError(cv_mem, CVSPILS_MEM_FAIL, "CVSPTFQMR", "CVSptfqmr", MSGS_MEM_FAIL);
return(CVSPILS_MEM_FAIL);
}
/* Set ILS type */
cvspils_mem->s_type = SPILS_SPTFQMR;
/* Set Sptfqmr 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 Sptfqmr parameters */
cvspils_mem->s_eplifac = CVSPILS_EPLIN;
cvspils_mem->s_last_flag = CVSPILS_SUCCESS;
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, "CVSPTFQMR", "CVSptfqmr", 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, "CVSPTFQMR", "CVSptfqmr", 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, "CVSPTFQMR", "CVSptfqmr", 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 = RSqrt(N_VDotProd(ytemp, ytemp));
/* Call SptfqmrMalloc to allocate workspace for Sptfqmr */
sptfqmr_mem = NULL;
sptfqmr_mem = SptfqmrMalloc(mxl, vec_tmpl);
if (sptfqmr_mem == NULL) {
CVProcessError(cv_mem, CVSPILS_MEM_FAIL, "CVSPTFQMR", "CVSptfqmr", MSGS_MEM_FAIL);
N_VDestroy(ytemp);
N_VDestroy(x);
free(cvspils_mem); cvspils_mem = NULL;
return(CVSPILS_MEM_FAIL);
}
/* Attach SPTFQMR memory to spils memory structure */
spils_mem = (void *) sptfqmr_mem;
/* Attach linear solver memory to integrator memory */
lmem = cvspils_mem;
return(CVSPILS_SUCCESS);
}
int main()
{
PbData data;
realtype R, L, m, g, V0;
void *cpode_mem;
N_Vector yy, yp, ctols;
realtype reltol, abstol;
realtype t0, tf, t;
realtype x1, y1, x2, y2;
realtype vx1, vy1, vx2, vy2;
int flag, Neq, Nc;
int rdir[1], iroots[1];
FILE *fout;
/* --------------------------------
* INITIALIZATIONS
* -------------------------------- */
R = 0.1; /* ball radius */
L = 1.0; /* pendulum length */
m = 1.0; /* pendulum mass */
g = 9.8; /* gravitational acc. */
V0 = 3.0; /* initial velocity for pendulum 1 */
/* Set-up user data structure */
data = (PbData)malloc(sizeof *data);
data->R = R;
data->L = L;
data->m = m;
data->g = g;
/* Problem dimensions */
Neq = 2*2*2;
Nc = 2*2;
/* Solution vectors */
yy = N_VNew_Serial(Neq);
yp = N_VNew_Serial(Neq);
/* Integration limits */
t0 = 0.0;
tf = 6.0;
/* Integration and projection tolerances */
reltol = 1.0e-8;
abstol = 1.0e-8;
ctols = N_VNew_Serial(Nc);
N_VConst(1.0e-8, ctols);
/* Direction of monitored events
* (only zero-crossing with decreasing even function) */
rdir[0] = -1;
/* --------------------------------
* CASE 1
* -------------------------------- */
fout = fopen("newton1.out","w");
/* Initial conditions */
NV_Ith_S(yy,0) = R; NV_Ith_S(yy,4) = -R;
NV_Ith_S(yy,1) = -L; NV_Ith_S(yy,5) = -L;
NV_Ith_S(yy,2) = V0; NV_Ith_S(yy,6) = 0.0;
NV_Ith_S(yy,3) = 0.0; NV_Ith_S(yy,7) = 0.0;
/* Initialize solver */
cpode_mem = CPodeCreate(CP_EXPL, CP_BDF, CP_NEWTON);
flag = CPodeInit(cpode_mem, ffun1, data, t0, yy, yp, CP_SS, reltol, &abstol);
flag = CPDense(cpode_mem, Neq);
flag = CPodeRootInit(cpode_mem, 1, gfun, data);
flag = CPodeSetRootDirection(cpode_mem, rdir);
/* Set-up the internal projection */
flag = CPodeProjInit(cpode_mem, CP_PROJ_L2NORM, CP_CNSTR_NONLIN, cfun, data, ctols);
flag = CPodeSetProjTestCnstr(cpode_mem, TRUE);
flag = CPDenseProj(cpode_mem, Nc, Neq, CPDIRECT_LU);
/* Integrate in ONE_STEP mode, while monitoring events */
t = t0;
while(t<tf) {
flag = CPode(cpode_mem, tf, &t, yy, yp, CP_ONE_STEP);
if (flag < 0) break;
x1 = NV_Ith_S(yy,0); x2 = NV_Ith_S(yy,4);
y1 = NV_Ith_S(yy,1); y2 = NV_Ith_S(yy,5);
vx1 = NV_Ith_S(yy,2); vx2 = NV_Ith_S(yy,6);
vy1 = NV_Ith_S(yy,3); vy2 = NV_Ith_S(yy,7);
fprintf(fout, "%lf %14.10lf %14.10lf %14.10lf %14.10lf %14.10lf %14.10lf %14.10lf %14.10lf",
t, x1, y1, x2, y2, vx1, vy1, vx2, vy2);
if (flag == CP_ROOT_RETURN) {
CPodeGetRootInfo(cpode_mem, iroots);
fprintf(fout, " %d\n", iroots[0]);
/* Note: the test iroots[0]<0 is really needed ONLY if not using rdir */
if (iroots[0] < 0) {
/* Update velocities in yy */
contact(yy, data);
/* reinitialize CPODES solver */
flag = CPodeReInit(cpode_mem, ffun1, data, t, yy, yp, CP_SS, reltol, &abstol);
}
} else {
fprintf(fout, " 0\n");
}
}
PrintFinalStats(cpode_mem);
CPodeFree(&cpode_mem);
fclose(fout);
/* --------------------------------
* CASE 2
* -------------------------------- */
fout = fopen("newton2.out","w");
/* Initial conditions */
NV_Ith_S(yy,0) = R; NV_Ith_S(yy,4) = -R;
NV_Ith_S(yy,1) = -L; NV_Ith_S(yy,5) = -L;
NV_Ith_S(yy,2) = 0.0; NV_Ith_S(yy,6) = 0.0;
NV_Ith_S(yy,3) = 0.0; NV_Ith_S(yy,7) = 0.0;
/* Initialize solver */
cpode_mem = CPodeCreate(CP_EXPL, CP_BDF, CP_NEWTON);
flag = CPodeInit(cpode_mem, ffun2, data, t0, yy, yp, CP_SS, reltol, &abstol);
flag = CPDense(cpode_mem, Neq);
flag = CPodeRootInit(cpode_mem, 1, gfun, data);
flag = CPodeSetRootDirection(cpode_mem, rdir);
/* Set-up the internal projection */
flag = CPodeProjInit(cpode_mem, CP_PROJ_L2NORM, CP_CNSTR_NONLIN, cfun, data, ctols);
flag = CPodeSetProjTestCnstr(cpode_mem, TRUE);
flag = CPDenseProj(cpode_mem, Nc, Neq, CPDIRECT_LU);
/* Integrate in ONE_STEP mode, while monitoring events */
t = t0;
while(t<tf) {
flag = CPode(cpode_mem, tf, &t, yy, yp, CP_ONE_STEP);
if (flag < 0) break;
x1 = NV_Ith_S(yy,0); x2 = NV_Ith_S(yy,4);
y1 = NV_Ith_S(yy,1); y2 = NV_Ith_S(yy,5);
vx1 = NV_Ith_S(yy,2); vx2 = NV_Ith_S(yy,6);
vy1 = NV_Ith_S(yy,3); vy2 = NV_Ith_S(yy,7);
fprintf(fout, "%lf %14.10lf %14.10lf %14.10lf %14.10lf %14.10lf %14.10lf %14.10lf %14.10lf",
t, x1, y1, x2, y2, vx1, vy1, vx2, vy2);
if (flag == CP_ROOT_RETURN) {
CPodeGetRootInfo(cpode_mem, iroots);
fprintf(fout, " %d\n", iroots[0]);
/* Note: the test iroots[0]<0 is really needed ONLY if not using rdir */
if (iroots[0] < 0) {
/* Update velocities in yy */
contact(yy, data);
/* reinitialize CPODES solver */
flag = CPodeReInit(cpode_mem, ffun2, data, t, yy, yp, CP_SS, reltol, &abstol);
}
} else {
fprintf(fout, " 0\n");
}
}
PrintFinalStats(cpode_mem);
CPodeFree(&cpode_mem);
fclose(fout);
/* --------------------------------
* CLEAN-UP
* -------------------------------- */
free(data);
N_VDestroy_Serial(yy);
N_VDestroy_Serial(yp);
N_VDestroy_Serial(ctols);
return(0);
}
