int jacrob(realtype tt, realtype cj,
N_Vector yy, N_Vector yp, N_Vector resvec,
SlsMat JacMat, void *user_data,
N_Vector tempv1, N_Vector tempv2, N_Vector tempv3)
{
realtype *yval;
yval = NV_DATA_S(yy);
SlsSetToZero(JacMat);
JacMat->colptrs[0] = 0;
JacMat->colptrs[1] = 3;
JacMat->colptrs[2] = 6;
JacMat->colptrs[3] = 9;
JacMat->data[0] = RCONST(-0.04) - cj;
JacMat->rowvals[0] = 0;
JacMat->data[1] = RCONST(0.04);
JacMat->rowvals[1] = 1;
JacMat->data[2] = ONE;
JacMat->rowvals[2] = 2;
JacMat->data[3] = RCONST(1.0e4)*yval[2];
JacMat->rowvals[3] = 0;
JacMat->data[4] = (RCONST(-1.0e4)*yval[2]) - (RCONST(6.0e7)*yval[1]) - cj;
JacMat->rowvals[4] = 1;
JacMat->data[5] = ONE;
JacMat->rowvals[5] = 2;
JacMat->data[6] = RCONST(1.0e4)*yval[1];
JacMat->rowvals[6] = 0;
JacMat->data[7] = RCONST(-1.0e4)*yval[1];
JacMat->rowvals[7] = 1;
JacMat->data[8] = ONE;
JacMat->rowvals[8] = 2;
return(0);
}
static int Jac(realtype t,
N_Vector y, N_Vector fy, SlsMat JacMat, void *user_data,
N_Vector tmp1, N_Vector tmp2, N_Vector tmp3)
{
realtype *yval;
yval = NV_DATA_S(y);
SlsSetToZero(JacMat);
JacMat->colptrs[0] = 0;
JacMat->colptrs[1] = 3;
JacMat->colptrs[2] = 6;
JacMat->colptrs[3] = 9;
JacMat->data[0] = RCONST(-0.04);
JacMat->rowvals[0] = 0;
JacMat->data[1] = RCONST(0.04);
JacMat->rowvals[1] = 1;
JacMat->data[2] = ZERO;
JacMat->rowvals[2] = 2;
JacMat->data[3] = RCONST(1.0e4)*yval[2];
JacMat->rowvals[3] = 0;
JacMat->data[4] = (RCONST(-1.0e4)*yval[2]) - (RCONST(6.0e7)*yval[1]);
JacMat->rowvals[4] = 1;
JacMat->data[5] = RCONST(6.0e7)*yval[1];
JacMat->rowvals[5] = 2;
JacMat->data[6] = RCONST(1.0e4)*yval[1];
JacMat->rowvals[6] = 0;
JacMat->data[7] = RCONST(-1.0e4)*yval[1];
JacMat->rowvals[7] = 1;
JacMat->data[8] = ZERO;
JacMat->rowvals[8] = 2;
return(0);
}
/*
* function calculates a jacobian matrix by
* numerical method finite differences with coloring
* into a sparse SlsMat matrix
*/
static
int nlsSparseJac(N_Vector vecX, N_Vector vecFX, SlsMat Jac, void *userData, N_Vector tmp1, N_Vector tmp2)
{
NLS_KINSOL_USERDATA *kinsolUserData = (NLS_KINSOL_USERDATA*) userData;
DATA* data = kinsolUserData->data;
threadData_t *threadData = kinsolUserData->threadData;
int sysNumber = kinsolUserData->sysNumber;
NONLINEAR_SYSTEM_DATA *nlsData = &(data->simulationInfo->nonlinearSystemData[sysNumber]);
NLS_KINSOL_DATA* kinsolData = (NLS_KINSOL_DATA*) nlsData->solverData;
/* prepare variables */
double *x = N_VGetArrayPointer(vecX);
double *fx = N_VGetArrayPointer(vecFX);
double *xsave = N_VGetArrayPointer(tmp1);
double *delta_hh = N_VGetArrayPointer(tmp2);
double *xScaling = NV_DATA_S(kinsolData->xScale);
double *fRes = NV_DATA_S(kinsolData->fRes);
SPARSE_PATTERN* sparsePattern = &(nlsData->sparsePattern);
const double delta_h = sqrt(DBL_EPSILON*2e1);
long int i,j,ii;
int nth = 0;
/* performance measurement */
rt_ext_tp_tick(&nlsData->jacobianTimeClock);
/* reset matrix */
SlsSetToZero(Jac);
for(i = 0; i < sparsePattern->maxColors; i++)
{
for(ii=0; ii < kinsolData->size; ii++)
{
if(sparsePattern->colorCols[ii]-1 == i)
{
xsave[ii] = x[ii];
delta_hh[ii] = delta_h * (fabs(xsave[ii]) + 1.0);
if ((xsave[ii] + delta_hh[ii] >= nlsData->max[ii]))
delta_hh[ii] *= -1;
x[ii] += delta_hh[ii];
/* Calculate scaled difference quotient */
delta_hh[ii] = 1. / delta_hh[ii];
}
}
nlsKinsolResiduals(vecX, kinsolData->fRes, userData);
for(ii = 0; ii < kinsolData->size; ii++)
{
if(sparsePattern->colorCols[ii]-1 == i)
{
nth = sparsePattern->leadindex[ii];
while(nth < sparsePattern->leadindex[ii+1])
{
j = sparsePattern->index[nth];
setJacElementKluSparse(j, ii, (fRes[j] - fx[j]) * delta_hh[ii], nth, Jac);
nth++;
};
x[ii] = xsave[ii];
}
}
}
/* finish sparse matrix */
finishSparseColPtr(Jac);
/* debug */
if (ACTIVE_STREAM(LOG_NLS_JAC)){
infoStreamPrint(LOG_NLS_JAC, 1, "##KINSOL## Sparse Matrix.");
PrintSparseMat(Jac);
nlsKinsolJacSumSparse(Jac);
messageClose(LOG_NLS_JAC);
}
/* performance measurement and statistics */
nlsData->jacobianTime += rt_ext_tp_tock(&(nlsData->jacobianTimeClock));
nlsData->numberOfJEval++;
return 0;
}
static int cvKLUSetup(CVodeMem cv_mem, int convfail, N_Vector ypred,
N_Vector fpred, booleantype *jcurPtr,
N_Vector vtemp1, N_Vector vtemp2, N_Vector vtemp3)
{
booleantype jbad, jok;
int retval;
long int nst, nstlj;
realtype tn, gamma, gammap, dgamma;
CVSlsMem cvsls_mem;
CVSlsSparseJacFn jaceval;
KLUData klu_data;
SlsMat JacMat, savedJ;
void *jacdata;
realtype uround_twothirds;
uround_twothirds = SUNRpowerR(cv_mem->cv_uround,TWOTHIRDS);
cvsls_mem = (CVSlsMem) (cv_mem->cv_lmem);
tn = cv_mem->cv_tn;
gamma = cv_mem->cv_gamma;
gammap = cv_mem->cv_gammap;
nst = cv_mem->cv_nst;
klu_data = (KLUData) cvsls_mem->s_solver_data;
jaceval = cvsls_mem->s_jaceval;
jacdata = cvsls_mem->s_jacdata;
JacMat = cvsls_mem->s_JacMat;
savedJ = cvsls_mem->s_savedJ;
nstlj = cvsls_mem->s_nstlj;
/* Check that Jacobian eval routine is set */
if (jaceval == NULL) {
cvProcessError(cv_mem, CVSLS_JAC_NOSET, "CVSLS", "cvKLUSetup",
MSGSP_JAC_NOSET);
free(cvsls_mem); cvsls_mem = NULL;
return(CVSLS_JAC_NOSET);
}
/* Determine whether Jacobian needs to be recalculated */
dgamma = SUNRabs((gamma/gammap) - ONE);
jbad = (nst == 0) || (nst > nstlj + CVS_MSBJ) ||
((convfail == CV_FAIL_BAD_J) && (dgamma < CVS_DGMAX)) ||
(convfail == CV_FAIL_OTHER);
jok = !jbad;
if (jok) {
/* If jok = TRUE, use saved copy of J */
*jcurPtr = FALSE;
CopySparseMat(savedJ, JacMat);
} else {
/* If jok = FALSE, call jac routine for new J value */
cvsls_mem->s_nje++;
cvsls_mem->s_nstlj = nst;
*jcurPtr = TRUE;
SlsSetToZero(JacMat);
retval = jaceval(tn, ypred, fpred, JacMat, jacdata, vtemp1, vtemp2, vtemp3);
if (retval < 0) {
cvProcessError(cv_mem, CVSLS_JACFUNC_UNRECVR, "CVSLS", "cvKLUSetup", MSGSP_JACFUNC_FAILED);
cvsls_mem->s_last_flag = CVSLS_JACFUNC_UNRECVR;
return(-1);
}
if (retval > 0) {
cvsls_mem->s_last_flag = CVSLS_JACFUNC_RECVR;
return(1);
}
CopySparseMat(JacMat, savedJ);
}
/* Scale and add I to get M = I - gamma*J */
ScaleSparseMat(-gamma, JacMat);
AddIdentitySparseMat(JacMat);
if (cvsls_mem->s_first_factorize) {
/* ------------------------------------------------------------
Get the symbolic factorization
------------------------------------------------------------*/
/* Update the ordering option with any user-updated values from
calls to CVKLUSetOrdering */
klu_data->s_Common.ordering = klu_data->s_ordering;
klu_data->s_Symbolic = klu_analyze(JacMat->N, JacMat->colptrs,
JacMat->rowvals, &(klu_data->s_Common));
if (klu_data->s_Symbolic == NULL) {
cvProcessError(cv_mem, CVSLS_PACKAGE_FAIL, "CVSLS", "CVKLUSetup",
MSGSP_PACKAGE_FAIL);
return(CVSLS_PACKAGE_FAIL);
}
/* ------------------------------------------------------------
Compute the LU factorization of the Jacobian.
------------------------------------------------------------*/
klu_data->s_Numeric = klu_factor(JacMat->colptrs, JacMat->rowvals,
JacMat->data,
klu_data->s_Symbolic, &(klu_data->s_Common));
if (klu_data->s_Numeric == NULL) {
cvProcessError(cv_mem, CVSLS_PACKAGE_FAIL, "CVSLS", "CVKLUSetup",
MSGSP_PACKAGE_FAIL);
return(CVSLS_PACKAGE_FAIL);
}
cvsls_mem->s_first_factorize = 0;
}
else {
retval = klu_refactor(JacMat->colptrs, JacMat->rowvals, JacMat->data,
klu_data->s_Symbolic, klu_data->s_Numeric,
&(klu_data->s_Common));
if (retval == 0) {
cvProcessError(cv_mem, CVSLS_PACKAGE_FAIL, "CVSLS", "cvKLUSetup",
MSGSP_PACKAGE_FAIL);
return(CVSLS_PACKAGE_FAIL);
}
/*-----------------------------------------------------------
Check if a cheap estimate of the reciprocal of the condition
number is getting too small. If so, delete
the prior numeric factorization and recompute it.
-----------------------------------------------------------*/
retval = klu_rcond(klu_data->s_Symbolic, klu_data->s_Numeric,
&(klu_data->s_Common));
if (retval == 0) {
cvProcessError(cv_mem, CVSLS_PACKAGE_FAIL, "CVSLS", "CVKLUSetup",
MSGSP_PACKAGE_FAIL);
return(CVSLS_PACKAGE_FAIL);
}
if ( (klu_data->s_Common.rcond) < uround_twothirds ) {
/* Condition number may be getting large.
Compute more accurate estimate */
retval = klu_condest(JacMat->colptrs, JacMat->data,
klu_data->s_Symbolic, klu_data->s_Numeric,
&(klu_data->s_Common));
if (retval == 0) {
cvProcessError(cv_mem, CVSLS_PACKAGE_FAIL, "CVSLS", "CVKLUSetup",
MSGSP_PACKAGE_FAIL);
return(CVSLS_PACKAGE_FAIL);
}
if ( (klu_data->s_Common.condest) >
(1.0/uround_twothirds) ) {
/* More accurate estimate also says condition number is
large, so recompute the numeric factorization */
klu_free_numeric(&(klu_data->s_Numeric), &(klu_data->s_Common));
klu_data->s_Numeric = klu_factor(JacMat->colptrs, JacMat->rowvals,
JacMat->data, klu_data->s_Symbolic,
&(klu_data->s_Common));
if (klu_data->s_Numeric == NULL) {
cvProcessError(cv_mem, CVSLS_PACKAGE_FAIL, "CVSLS", "CVKLUSetup",
MSGSP_PACKAGE_FAIL);
return(CVSLS_PACKAGE_FAIL);
}
}
}
}
cvsls_mem->s_last_flag = CVSLS_SUCCESS;
return(0);
}
/* Routine to compute the Jacobian matrix from R(y) */
static int ReactionJac(N_Vector y, SlsMat Jac, UserData udata)
{
int N = udata->N; /* set shortcuts */
int i, nz=0;
realtype u, v, w;
realtype ep = udata->ep;
realtype *Ydata = N_VGetArrayPointer(y); /* access solution array */
if (check_flag((void *) Ydata, "N_VGetArrayPointer", 0)) return 1;
/* clear out matrix */
SlsSetToZero(Jac);
/* set first matrix column to zero */
Jac->colptrs[IDX(0,0)] = 0;
Jac->colptrs[IDX(0,1)] = 0;
Jac->colptrs[IDX(0,2)] = 0;
/* iterate over interior nodes, filling in Jacobian entries */
for (i=1; i<N-1; i++) {
/* set nodal value shortcuts */
u = Ydata[IDX(i,0)];
v = Ydata[IDX(i,1)];
w = Ydata[IDX(i,2)];
/* dependence on u at this node */
Jac->colptrs[IDX(i,0)] = nz;
Jac->rowvals[nz] = IDX(i,0); /* fu wrt u */
Jac->data[nz++] = TWO*u*v - w - ONE;
Jac->rowvals[nz] = IDX(i,1); /* fv wrt u */
Jac->data[nz++] = w - TWO*u*v;
Jac->rowvals[nz] = IDX(i,2); /* fw wrt u */
Jac->data[nz++] = -w;
/* dependence on v at this node */
Jac->colptrs[IDX(i,1)] = nz;
Jac->rowvals[nz] = IDX(i,0); /* fu wrt v */
Jac->data[nz++] = u*u;
Jac->rowvals[nz] = IDX(i,1); /* fv wrt v */
Jac->data[nz++] = -u*u;
/* dependence on w at this node */
Jac->colptrs[IDX(i,2)] = nz;
Jac->rowvals[nz] = IDX(i,0); /* fu wrt w */
Jac->data[nz++] = -u;
Jac->rowvals[nz] = IDX(i,1); /* fv wrt w */
Jac->data[nz++] = u;
Jac->rowvals[nz] = IDX(i,2); /* fw wrt w */
Jac->data[nz++] = -ONE/ep - u;
}
/* set last matrix column to zero */
Jac->colptrs[IDX(N-1,0)] = nz;
Jac->colptrs[IDX(N-1,1)] = nz;
Jac->colptrs[IDX(N-1,2)] = nz;
/* end of data */
Jac->colptrs[IDX(N-1,2)+1] = nz;
return 0;
}
/* Routine to compute the stiffness matrix from (L*y) */
static int LaplaceMatrix(SlsMat Lap, UserData udata)
{
int N = udata->N; /* set shortcuts */
int i, nz=0;
realtype uconst, uconst2, vconst, vconst2, wconst, wconst2;
/* clear out matrix */
SlsSetToZero(Lap);
/* set first column to zero */
Lap->colptrs[IDX(0,0)] = nz;
Lap->colptrs[IDX(0,1)] = nz;
Lap->colptrs[IDX(0,2)] = nz;
/* iterate over nodes, filling in Laplacian entries depending on these */
uconst = (udata->du)/(udata->dx)/(udata->dx);
uconst2 = -TWO*uconst;
vconst = (udata->dv)/(udata->dx)/(udata->dx);
vconst2 = -TWO*vconst;
wconst = (udata->dw)/(udata->dx)/(udata->dx);
wconst2 = -TWO*wconst;
for (i=1; i<N-1; i++) {
/* dependence on u at this node */
Lap->colptrs[IDX(i,0)] = nz;
if (i>1) { /* node to left */
Lap->data[nz] = uconst;
Lap->rowvals[nz++] = IDX(i-1,0);
}
Lap->data[nz] = uconst2; /* self */
Lap->rowvals[nz++] = IDX(i,0);
if (i<N-2) { /* node to right */
Lap->data[nz] = uconst;
Lap->rowvals[nz++] = IDX(i+1,0);
}
/* dependence on v at this node */
Lap->colptrs[IDX(i,1)] = nz;
if (i>1) { /* node to left */
Lap->data[nz] = vconst;
Lap->rowvals[nz++] = IDX(i-1,1);
}
Lap->data[nz] = vconst2; /* self */
Lap->rowvals[nz++] = IDX(i,1);
if (i<N-2) { /* node to right */
Lap->data[nz] = vconst;
Lap->rowvals[nz++] = IDX(i+1,1);
}
/* dependence on w at this node */
Lap->colptrs[IDX(i,2)] = nz;
if (i>1) { /* node to left */
Lap->data[nz] = wconst;
Lap->rowvals[nz++] = IDX(i-1,2);
}
Lap->data[nz] = wconst2; /* self */
Lap->rowvals[nz++] = IDX(i,2);
if (i<N-2) { /* node to right */
Lap->data[nz] = wconst;
Lap->rowvals[nz++] = IDX(i+1,2);
}
}
/* set last column to zero */
Lap->colptrs[IDX(N-1,0)] = nz;
Lap->colptrs[IDX(N-1,1)] = nz;
Lap->colptrs[IDX(N-1,2)] = nz;
/* end of data */
Lap->colptrs[IDX(N-1,2)+1] = nz;
return 0;
}
