/*-----------------------------------------------------------------
cvDlsDenseDQJac
-----------------------------------------------------------------
This routine generates a dense difference quotient approximation
to the Jacobian of f(t,y). It assumes that a dense SUNMatrix is
stored column-wise, and that elements within each column are
contiguous. The address of the jth column of J is obtained via
the accessor function SUNDenseMatrix_Column, and this pointer
is associated with an N_Vector using the N_VSetArrayPointer
function. Finally, the actual computation of the jth column of
the Jacobian is done with a call to N_VLinearSum.
-----------------------------------------------------------------*/
int cvDlsDenseDQJac(realtype t, N_Vector y, N_Vector fy,
SUNMatrix Jac, CVodeMem cv_mem, N_Vector tmp1)
{
realtype fnorm, minInc, inc, inc_inv, yjsaved, srur;
realtype *y_data, *ewt_data;
N_Vector ftemp, jthCol;
sunindextype j, N;
int retval = 0;
CVDlsMem cvdls_mem;
/* access DlsMem interface structure */
cvdls_mem = (CVDlsMem) cv_mem->cv_lmem;
/* access matrix dimension */
N = SUNDenseMatrix_Rows(Jac);
/* Rename work vector for readibility */
ftemp = tmp1;
/* Create an empty vector for matrix column calculations */
jthCol = N_VCloneEmpty(tmp1);
/* Obtain pointers to the data for ewt, y */
ewt_data = N_VGetArrayPointer(cv_mem->cv_ewt);
y_data = N_VGetArrayPointer(y);
/* Set minimum increment based on uround and norm of f */
srur = SUNRsqrt(cv_mem->cv_uround);
fnorm = N_VWrmsNorm(fy, cv_mem->cv_ewt);
minInc = (fnorm != ZERO) ?
(MIN_INC_MULT * SUNRabs(cv_mem->cv_h) * cv_mem->cv_uround * N * fnorm) : ONE;
for (j = 0; j < N; j++) {
/* Generate the jth col of J(tn,y) */
N_VSetArrayPointer(SUNDenseMatrix_Column(Jac,j), jthCol);
yjsaved = y_data[j];
inc = SUNMAX(srur*SUNRabs(yjsaved), minInc/ewt_data[j]);
y_data[j] += inc;
retval = cv_mem->cv_f(t, y, ftemp, cv_mem->cv_user_data);
cvdls_mem->nfeDQ++;
if (retval != 0) break;
y_data[j] = yjsaved;
inc_inv = ONE/inc;
N_VLinearSum(inc_inv, ftemp, -inc_inv, fy, jthCol);
/* DENSE_COL(Jac,j) = N_VGetArrayPointer(jthCol); /\*UNNECESSARY?? *\/ */
}
/* Destroy jthCol vector */
N_VSetArrayPointer(NULL, jthCol); /* SHOULDN'T BE NEEDED */
N_VDestroy(jthCol);
return(retval);
}
int xdot_model_dirac(realtype t, N_Vector x, N_Vector xdot, void *user_data) {
int status = 0;
UserData *udata = (UserData*) user_data;
realtype *x_tmp = N_VGetArrayPointer(x);
realtype *xdot_tmp = N_VGetArrayPointer(xdot);
int ix;
memset(xdot_tmp,0,sizeof(realtype)*2);
status = w_model_dirac(t,x,NULL,user_data);
xdot_tmp[0] = -p[0]*x_tmp[0];
xdot_tmp[1] = p[2]*x_tmp[0]-p[3]*x_tmp[1];
for(ix = 0; ix<2; ix++) {
if(amiIsNaN(xdot_tmp[ix])) {
xdot_tmp[ix] = 0;
if(!udata->am_nan_xdot) {
warnMsgIdAndTxt("AMICI:mex:fxdot:NaN","AMICI replaced a NaN value in xdot and replaced it by 0.0. This will not be reported again for this simulation run.");
udata->am_nan_xdot = TRUE;
}
}
if(amiIsInf(xdot_tmp[ix])) {
warnMsgIdAndTxt("AMICI:mex:fxdot:Inf","AMICI encountered an Inf value in xdot! Aborting simulation ... ");
return(-1);
} if(qpositivex[ix]>0.5 && x_tmp[ix]<0.0 && xdot_tmp[ix]<0.0) {
xdot_tmp[ix] = -xdot_tmp[ix];
}
}
return(status);
}
int FKINDenseJac(long int N, N_Vector uu, N_Vector fval,
DlsMat J, void *user_data, N_Vector vtemp1, N_Vector vtemp2)
{
realtype *uu_data, *fval_data, *jacdata, *v1_data, *v2_data;
int ier;
/* Initialize all pointers to NULL */
uu_data = fval_data = jacdata = v1_data = v2_data = NULL;
/* NOTE: The user-supplied routine should set ier to an
appropriate value, but we preset the value to zero
(meaning SUCCESS) so the user need only reset the
value if an error occurred */
ier = 0;
/* Get pointers to vector data */
uu_data = N_VGetArrayPointer(uu);
fval_data = N_VGetArrayPointer(fval);
v1_data = N_VGetArrayPointer(vtemp1);
v2_data = N_VGetArrayPointer(vtemp2);
jacdata = DENSE_COL(J,0);
/* Call user-supplied routine */
FK_DJAC(&N, uu_data, fval_data, jacdata, v1_data, v2_data, &ier);
return(ier);
}
int check_vector(N_Vector x, N_Vector y, realtype tol)
{
int failure = 0;
realtype *xdata, *ydata;
sunindextype xldata, yldata;
sunindextype i;
/* get vector data */
xdata = N_VGetArrayPointer(x);
ydata = N_VGetArrayPointer(y);
/* check data lengths */
xldata = N_VGetLength_Serial(x);
yldata = N_VGetLength_Serial(y);
if (xldata != yldata) {
printf(">>> ERROR: check_vector: Different data array lengths \n");
return(1);
}
/* check vector data */
for(i=0; i < xldata; i++){
failure += FNEQ(xdata[i], ydata[i], tol);
}
if (failure > ZERO)
return(1);
else
return(0);
}
/* Jacobian routine to compute J(t,y) = df/dy. */
static int Jac(N_Vector v, N_Vector Jv, realtype t, N_Vector y,
N_Vector fy, void *user_data, N_Vector tmp)
{
UserData udata = (UserData) user_data; /* variable shortcuts */
sunindextype N = udata->N;
realtype k = udata->k;
realtype dx = udata->dx;
realtype *V=NULL, *JV=NULL;
realtype c1, c2;
sunindextype i;
V = N_VGetArrayPointer(v); /* access data arrays */
if (check_flag((void *) V, "N_VGetArrayPointer", 0)) return 1;
JV = N_VGetArrayPointer(Jv);
if (check_flag((void *) JV, "N_VGetArrayPointer", 0)) return 1;
N_VConst(0.0, Jv); /* initialize Jv product to zero */
/* iterate over domain, computing all Jacobian-vector products */
c1 = k/dx/dx;
c2 = -RCONST(2.0)*k/dx/dx;
JV[0] = 0.0;
for (i=1; i<N-1; i++)
JV[i] = c1*V[i-1] + c2*V[i] + c1*V[i+1];
JV[N-1] = 0.0;
return 0; /* Return with success */
}
/* ----------------------------------------------------------------------
* Implementation-specific 'check' routines
* --------------------------------------------------------------------*/
int check_vector(N_Vector X, N_Vector Y, realtype tol)
{
int failure = 0;
sunindextype i, local_length;
realtype *Xdata, *Ydata, maxerr;
Xdata = N_VGetArrayPointer(X);
Ydata = N_VGetArrayPointer(Y);
local_length = N_VGetLength_Serial(X);
/* check vector data */
for(i=0; i < local_length; i++)
failure += FNEQ(Xdata[i], Ydata[i], tol);
if (failure > ZERO) {
maxerr = ZERO;
for(i=0; i < local_length; i++)
maxerr = SUNMAX(SUNRabs(Xdata[i]-Ydata[i]), maxerr);
printf("check err failure: maxerr = %g (tol = %g)\n",
maxerr, tol);
return(1);
}
else
return(0);
}
/* f routine to compute the ODE RHS function f(t,y). */
static int f(realtype t, N_Vector y, N_Vector ydot, void *user_data)
{
UserData udata = (UserData) user_data; /* access problem data */
sunindextype N = udata->N; /* set variable shortcuts */
realtype k = udata->k;
realtype dx = udata->dx;
realtype *Y=NULL, *Ydot=NULL;
realtype c1, c2;
sunindextype i, isource;
Y = N_VGetArrayPointer(y); /* access data arrays */
if (check_flag((void *) Y, "N_VGetArrayPointer", 0)) return 1;
Ydot = N_VGetArrayPointer(ydot);
if (check_flag((void *) Ydot, "N_VGetArrayPointer", 0)) return 1;
N_VConst(0.0, ydot); /* Initialize ydot to zero */
/* iterate over domain, computing all equations */
c1 = k/dx/dx;
c2 = -RCONST(2.0)*k/dx/dx;
isource = N/2;
Ydot[0] = 0.0; /* left boundary condition */
for (i=1; i<N-1; i++)
Ydot[i] = c1*Y[i-1] + c2*Y[i] + c1*Y[i+1];
Ydot[N-1] = 0.0; /* right boundary condition */
Ydot[isource] += 0.01/dx; /* source term */
return 0; /* Return with success */
}
/* Projects one vector onto another:
Nold [input] -- the size of the old mesh
xold [input] -- the old mesh
yold [input] -- the vector defined over the old mesh
Nnew [input] -- the size of the new mesh
xnew [input] -- the new mesh
ynew [output] -- the vector defined over the new mesh
(allocated prior to calling project) */
static int project(long int Nold, realtype *xold, N_Vector yold,
long int Nnew, realtype *xnew, N_Vector ynew)
{
int iv, i, j;
realtype *Yold=NULL, *Ynew=NULL;
/* Access data arrays */
Yold = N_VGetArrayPointer(yold); /* access data arrays */
if (check_flag((void *) Yold, "N_VGetArrayPointer", 0)) return 1;
Ynew = N_VGetArrayPointer(ynew);
if (check_flag((void *) Ynew, "N_VGetArrayPointer", 0)) return 1;
/* loop over new mesh, finding corresponding interval within old mesh,
and perform piecewise linear interpolation from yold to ynew */
iv=0;
for (i=0; i<Nnew; i++) {
/* find old interval, start with previous value since sorted */
for (j=iv; j<Nold-1; j++) {
if (xnew[i] >= xold[j] && xnew[i] <= xold[j+1]) {
iv = j;
break;
}
iv = Nold-1; /* just in case it wasn't found above */
}
/* perform interpolation */
Ynew[i] = Yold[iv]*(xnew[i]-xold[iv+1])/(xold[iv]-xold[iv+1])
+ Yold[iv+1]*(xnew[i]-xold[iv])/(xold[iv+1]-xold[iv]);
}
return 0; /* Return with success */
}
/* Jacobian routine to compute J(t,y) = df/dy. */
static int Jac(N_Vector v, N_Vector Jv, realtype t, N_Vector y,
N_Vector fy, void *user_data, N_Vector tmp)
{
UserData udata = (UserData) user_data; /* variable shortcuts */
long int N = udata->N;
realtype k = udata->k;
realtype *x = udata->x;
realtype *V=NULL, *JV=NULL;
realtype dxL, dxR;
long int i;
V = N_VGetArrayPointer(v); /* access data arrays */
if (check_flag((void *) V, "N_VGetArrayPointer", 0)) return 1;
JV = N_VGetArrayPointer(Jv);
if (check_flag((void *) JV, "N_VGetArrayPointer", 0)) return 1;
N_VConst(0.0, Jv); /* initialize Jv product to zero */
/* iterate over domain, computing all Jacobian-vector products */
JV[0] = 0.0;
for (i=1; i<N-1; i++) {
dxL = x[i]-x[i-1];
dxR = x[i+1]-x[i];
JV[i] = V[i-1]*k*2.0/(dxL*(dxL+dxR))
- V[i]*k*2.0/(dxL*dxR)
+ V[i+1]*k*2.0/(dxR*(dxL+dxR));
}
JV[N-1] = 0.0;
return 0; /* Return with success */
}
int SUNMatMatvec_Band(SUNMatrix A, N_Vector x, N_Vector y)
{
sunindextype i, j, is, ie;
realtype *col_j, *xd, *yd;
/* Verify that A, x and y are compatible */
if (!SMCompatible2_Band(A, x, y))
return 1;
/* access vector data (return if failure) */
xd = N_VGetArrayPointer(x);
yd = N_VGetArrayPointer(y);
if ((xd == NULL) || (yd == NULL) || (xd == yd))
return 1;
/* Perform operation */
for (i=0; i<SM_ROWS_B(A); i++)
yd[i] = ZERO;
for(j=0; j<SM_COLUMNS_B(A); j++) {
col_j = SM_COLUMN_B(A,j);
is = SUNMAX(0, j-SM_UBAND_B(A));
ie = SUNMIN(SM_ROWS_B(A)-1, j+SM_LBAND_B(A));
for (i=is; i<=ie; i++)
yd[i] += col_j[i-j]*xd[j];
}
return 0;
}
/* matrix-vector product */
int ATimes(void* Data, N_Vector v_vec, N_Vector z_vec)
{
/* local variables */
realtype *v, *z, *s1, *s2;
sunindextype i, N;
UserData *ProbData;
/* access user data structure and vector data */
ProbData = (UserData *) Data;
v = N_VGetArrayPointer(v_vec);
if (check_flag(v, "N_VGetArrayPointer", 0)) return 1;
z = N_VGetArrayPointer(z_vec);
if (check_flag(z, "N_VGetArrayPointer", 0)) return 1;
s1 = N_VGetArrayPointer(ProbData->s1);
if (check_flag(s1, "N_VGetArrayPointer", 0)) return 1;
s2 = N_VGetArrayPointer(ProbData->s2);
if (check_flag(s2, "N_VGetArrayPointer", 0)) return 1;
N = ProbData->N;
/* perform product at the left domain boundary (note: v is zero at the boundary)*/
z[0] = (FIVE*v[0]*s2[0] - v[1]*s2[1])/s1[0];
/* iterate through interior of local domain, performing product */
for (i=1; i<N-1; i++)
z[i] = (-v[i-1]*s2[i-1] + FIVE*v[i]*s2[i] - v[i+1]*s2[i+1])/s1[i];
/* perform product at the right domain boundary (note: v is zero at the boundary)*/
z[N-1] = (-v[N-2]*s2[N-2] + FIVE*v[N-1]*s2[N-1])/s1[N-1];
/* return with success */
return 0;
}
int FIDAcfn(long int Nloc, realtype t, N_Vector yy, N_Vector yp,
void *user_data)
{
realtype *yy_data, *yp_data;
int ier;
FIDAUserData IDA_userdata;
/* Initialize all pointers to NULL */
yy_data = yp_data = NULL;
/* NOTE: The user-supplied routine should set ier to an
appropriate value, but we preset the value to zero
(meaning SUCCESS) so the user need only reset the
value if an error occurred */
ier = 0;
/* Get pointers to vector data */
yy_data = N_VGetArrayPointer(yy);
yp_data = N_VGetArrayPointer(yp);
IDA_userdata = (FIDAUserData) user_data;
/* Call user-supplied routine */
FIDA_COMMFN(&Nloc, &t, yy_data, yp_data,
IDA_userdata->ipar, IDA_userdata->rpar, &ier);
return(ier);
}
int FKINLapackBandJac(long int N, long int mupper, long int mlower,
N_Vector uu, N_Vector fval,
DlsMat J, void *user_data,
N_Vector vtemp1, N_Vector vtemp2)
{
realtype *uu_data, *fval_data, *jacdata, *v1_data, *v2_data;
long int eband;
int ier;
/* Initialize all pointers to NULL */
uu_data = fval_data = jacdata = v1_data = v2_data = NULL;
/* NOTE: The user-supplied routine should set ier to an
appropriate value, but we preset the value to zero
(meaning SUCCESS) so the user need only reset the
value if an error occurred */
ier = 0;
/* Get pointers to vector data */
uu_data = N_VGetArrayPointer(uu);
fval_data = N_VGetArrayPointer(fval);
v1_data = N_VGetArrayPointer(vtemp1);
v2_data = N_VGetArrayPointer(vtemp2);
eband = (J->s_mu) + mlower + 1;
jacdata = BAND_COL(J,0) - mupper;
/* Call user-supplied routine */
FK_BJAC(&N, &mupper, &mlower, &eband,
uu_data, fval_data,
jacdata,
v1_data, v2_data, &ier);
return(ier);
}
/* preconditioner solve */
int PSolve(void* Data, N_Vector r_vec, N_Vector z_vec, realtype tol, int lr)
{
/* local variables */
realtype *r, *z, *d, *s;
sunindextype i;
UserData *ProbData;
/* access user data structure and vector data */
ProbData = (UserData *) Data;
r = N_VGetArrayPointer(r_vec);
if (check_flag(r, "N_VGetArrayPointer", 0)) return 1;
z = N_VGetArrayPointer(z_vec);
if (check_flag(z, "N_VGetArrayPointer", 0)) return 1;
d = N_VGetArrayPointer(ProbData->d);
if (check_flag(d, "N_VGetArrayPointer", 0)) return 1;
s = N_VGetArrayPointer(ProbData->s);
if (check_flag(s, "N_VGetArrayPointer", 0)) return 1;
/* iterate through domain, performing Jacobi solve */
for (i=0; i<ProbData->N; i++)
z[i] = s[i] * s[i] * r[i] / d[i];
/* return with success */
return 0;
}
static void PrintHeader(realtype rtol, N_Vector avtol, N_Vector y)
{
realtype *atval, *yval;
atval = N_VGetArrayPointer(avtol);
yval = N_VGetArrayPointer(y);
printf("\nidaRoberts_sps: Robertson kinetics DAE serial example problem for IDA.\n");
printf(" Three equation chemical kinetics problem.\n\n");
printf("Linear solver: SUPERLUMT, with user-supplied Jacobian.\n");
#if defined(SUNDIALS_EXTENDED_PRECISION)
printf("Tolerance parameters: rtol = %Lg atol = %Lg %Lg %Lg \n",
rtol, atval[0],atval[1],atval[2]);
printf("Initial conditions y0 = (%Lg %Lg %Lg)\n",
yval[0], yval[1], yval[2]);
#elif defined(SUNDIALS_DOUBLE_PRECISION)
printf("Tolerance parameters: rtol = %g atol = %g %g %g \n",
rtol, atval[0],atval[1],atval[2]);
printf("Initial conditions y0 = (%g %g %g)\n",
yval[0], yval[1], yval[2]);
#else
printf("Tolerance parameters: rtol = %g atol = %g %g %g \n",
rtol, atval[0],atval[1],atval[2]);
printf("Initial conditions y0 = (%g %g %g)\n",
yval[0], yval[1], yval[2]);
#endif
printf("Constraints and id not used.\n\n");
printf("-----------------------------------------------------------------------\n");
printf(" t y1 y2 y3");
printf(" | nst k h\n");
printf("-----------------------------------------------------------------------\n");
}
int FCVPSet(realtype t, N_Vector y, N_Vector fy, booleantype jok,
booleantype *jcurPtr, realtype gamma,
void *user_data,
N_Vector vtemp1, N_Vector vtemp2, N_Vector vtemp3)
{
int ier = 0;
realtype *ydata, *fydata, *v1data, *v2data, *v3data;
realtype h;
FCVUserData CV_userdata;
CVodeGetLastStep(CV_cvodemem, &h);
ydata = N_VGetArrayPointer(y);
fydata = N_VGetArrayPointer(fy);
v1data = N_VGetArrayPointer(vtemp1);
v2data = N_VGetArrayPointer(vtemp2);
v3data = N_VGetArrayPointer(vtemp3);
CV_userdata = (FCVUserData) user_data;
FCV_PSET(&t, ydata, fydata, &jok, jcurPtr, &gamma, &h,
CV_userdata->ipar, CV_userdata->rpar,
v1data, v2data, v3data, &ier);
return(ier);
}
int FIDAEwtSet(N_Vector y, N_Vector ewt, void *user_data)
{
int ier;
realtype *y_data, *ewt_data;
FIDAUserData IDA_userdata;
/* Initialize all pointers to NULL */
y_data = ewt_data = NULL;
/* NOTE: The user-supplied routine should set ier to an
appropriate value, but we preset the value to zero
(meaning SUCCESS) so the user need only reset the
value if an error occurred */
ier = 0;
y_data = N_VGetArrayPointer(y);
ewt_data = N_VGetArrayPointer(ewt);
IDA_userdata = (FIDAUserData) user_data;
/* Call user-supplied routine */
FIDA_EWT(y_data, ewt_data, IDA_userdata->ipar, IDA_userdata->rpar, &ier);
return(ier);
}
int FIDAresfn(realtype t, N_Vector yy, N_Vector yp,
N_Vector rr, void *user_data)
{
int ier;
realtype *yy_data, *yp_data, *rr_data;
FIDAUserData IDA_userdata;
/* NOTE: The user-supplied routine should set ier to an
appropriate value, but we preset the value to zero
(meaning SUCCESS) so the user need only reset the
value if an error occurred */
ier = 0;
/* Get pointers to vector data */
yy_data = N_VGetArrayPointer(yy);
yp_data = N_VGetArrayPointer(yp);
rr_data = N_VGetArrayPointer(rr);
IDA_userdata = (FIDAUserData) user_data;
/* Call user-supplied routine */
FIDA_RESFUN(&t, yy_data, yp_data, rr_data,
IDA_userdata->ipar, IDA_userdata->rpar, &ier);
return(ier);
}
int TSFunction_Sundials(realtype t,N_Vector y,N_Vector ydot,void *ctx)
{
TS ts = (TS) ctx;
DM dm;
DMTS tsdm;
TSIFunction ifunction;
MPI_Comm comm;
TS_Sundials *cvode = (TS_Sundials*)ts->data;
Vec yy = cvode->w1,yyd = cvode->w2,yydot = cvode->ydot;
PetscScalar *y_data,*ydot_data;
PetscErrorCode ierr;
PetscFunctionBegin;
ierr = PetscObjectGetComm((PetscObject)ts,&comm);CHKERRQ(ierr);
/* Make the PETSc work vectors yy and yyd point to the arrays in the SUNDIALS vectors y and ydot respectively*/
y_data = (PetscScalar*) N_VGetArrayPointer(y);
ydot_data = (PetscScalar*) N_VGetArrayPointer(ydot);
ierr = VecPlaceArray(yy,y_data);CHKERRABORT(comm,ierr);
ierr = VecPlaceArray(yyd,ydot_data);CHKERRABORT(comm,ierr);
/* Now compute the right hand side function, via IFunction unless only the more efficient RHSFunction is set */
ierr = TSGetDM(ts,&dm);CHKERRQ(ierr);
ierr = DMGetDMTS(dm,&tsdm);CHKERRQ(ierr);
ierr = DMTSGetIFunction(dm,&ifunction,NULL);CHKERRQ(ierr);
if (!ifunction) {
ierr = TSComputeRHSFunction(ts,t,yy,yyd);CHKERRQ(ierr);
} else { /* If rhsfunction is also set, this computes both parts and shifts them to the right */
ierr = VecZeroEntries(yydot);CHKERRQ(ierr);
ierr = TSComputeIFunction(ts,t,yy,yydot,yyd,PETSC_FALSE);CHKERRABORT(comm,ierr);
ierr = VecScale(yyd,-1.);CHKERRQ(ierr);
}
ierr = VecResetArray(yy);CHKERRABORT(comm,ierr);
ierr = VecResetArray(yyd);CHKERRABORT(comm,ierr);
PetscFunctionReturn(0);
}
int FCVDenseJac(int N, realtype t,
N_Vector y, N_Vector fy,
DlsMat J, void *user_data,
N_Vector vtemp1, N_Vector vtemp2, N_Vector vtemp3)
{
int ier;
realtype *ydata, *fydata, *jacdata, *v1data, *v2data, *v3data;
realtype h;
FCVUserData CV_userdata;
CVodeGetLastStep(CV_cvodemem, &h);
ydata = N_VGetArrayPointer(y);
fydata = N_VGetArrayPointer(fy);
v1data = N_VGetArrayPointer(vtemp1);
v2data = N_VGetArrayPointer(vtemp2);
v3data = N_VGetArrayPointer(vtemp3);
jacdata = DENSE_COL(J,0);
CV_userdata = (FCVUserData) user_data;
FCV_DJAC(&N, &t, ydata, fydata, jacdata, &h,
CV_userdata->ipar, CV_userdata->rpar, v1data, v2data, v3data, &ier);
return(ier);
}
int FCVJtimes(N_Vector v, N_Vector Jv, realtype t,
N_Vector y, N_Vector fy,
void *jac_data, N_Vector work)
{
realtype *vdata, *Jvdata, *ydata, *fydata, *wkdata;
realtype h;
FCVUserData CV_userdata;
int ier = 0;
CVodeGetLastStep(CV_cvodemem, &h);
vdata = N_VGetArrayPointer(v);
Jvdata = N_VGetArrayPointer(Jv);
ydata = N_VGetArrayPointer(y);
fydata = N_VGetArrayPointer(fy);
wkdata = N_VGetArrayPointer(work);
CV_userdata = (FCVUserData) jac_data;
FCV_JTIMES (vdata, Jvdata, &t, ydata, fydata, &h,
CV_userdata->ipar, CV_userdata->rpar, wkdata, &ier);
return(ier);
}
int TSFunction_Sundials(realtype t,N_Vector y,N_Vector ydot,void *ctx)
{
TS ts = (TS) ctx;
MPI_Comm comm = ((PetscObject)ts)->comm;
TS_Sundials *cvode = (TS_Sundials*)ts->data;
Vec yy = cvode->w1,yyd = cvode->w2,yydot = cvode->ydot;
PetscScalar *y_data,*ydot_data;
PetscErrorCode ierr;
PetscFunctionBegin;
/* Make the PETSc work vectors yy and yyd point to the arrays in the SUNDIALS vectors y and ydot respectively*/
y_data = (PetscScalar *) N_VGetArrayPointer(y);
ydot_data = (PetscScalar *) N_VGetArrayPointer(ydot);
ierr = VecPlaceArray(yy,y_data);CHKERRABORT(comm,ierr);
ierr = VecPlaceArray(yyd,ydot_data); CHKERRABORT(comm,ierr);
/* now compute the right hand side function */
if (!ts->userops->ifunction) {
ierr = TSComputeRHSFunction(ts,t,yy,yyd);CHKERRQ(ierr);
} else { /* If rhsfunction is also set, this computes both parts and shifts them to the right */
ierr = VecZeroEntries(yydot);CHKERRQ(ierr);
ierr = TSComputeIFunction(ts,t,yy,yydot,yyd,PETSC_FALSE); CHKERRABORT(comm,ierr);
ierr = VecScale(yyd,-1.);CHKERRQ(ierr);
}
ierr = VecResetArray(yy); CHKERRABORT(comm,ierr);
ierr = VecResetArray(yyd); CHKERRABORT(comm,ierr);
PetscFunctionReturn(0);
}
int FCVBandJac(long int N, long int mupper, long int mlower,
BandMat J, realtype t,
N_Vector y, N_Vector fy, void *jac_data,
N_Vector vtemp1, N_Vector vtemp2, N_Vector vtemp3)
{
int ier;
realtype *ydata, *fydata, *jacdata, *v1data, *v2data, *v3data;
realtype h;
long int eband;
FCVUserData CV_userdata;
CVodeGetLastStep(CV_cvodemem, &h);
ydata = N_VGetArrayPointer(y);
fydata = N_VGetArrayPointer(fy);
v1data = N_VGetArrayPointer(vtemp1);
v2data = N_VGetArrayPointer(vtemp2);
v3data = N_VGetArrayPointer(vtemp3);
eband = (J->smu) + mlower + 1;
jacdata = BAND_COL(J,0) - mupper;
CV_userdata = (FCVUserData) jac_data;
FCV_BJAC(&N, &mupper, &mlower, &eband, &t, ydata, fydata, jacdata, &h,
CV_userdata->ipar, CV_userdata->rpar, v1data, v2data, v3data, &ier);
return(ier);
}
static void CVDenseDQJac(long int N, DenseMat J, realtype t,
N_Vector y, N_Vector fy, void *jac_data,
N_Vector tmp1, N_Vector tmp2, N_Vector tmp3)
{
realtype fnorm, minInc, inc, inc_inv, yjsaved, srur;
realtype *tmp2_data, *y_data, *ewt_data;
N_Vector ftemp, jthCol;
long int j;
CVodeMem cv_mem;
CVDenseMem cvdense_mem;
/* jac_data points to cvode_mem */
cv_mem = (CVodeMem) jac_data;
cvdense_mem = (CVDenseMem) lmem;
/* Save pointer to the array in tmp2 */
tmp2_data = N_VGetArrayPointer(tmp2);
/* Rename work vectors for readibility */
ftemp = tmp1;
jthCol = tmp2;
/* Obtain pointers to the data for ewt, y */
ewt_data = N_VGetArrayPointer(ewt);
y_data = N_VGetArrayPointer(y);
/* Set minimum increment based on uround and norm of f */
srur = RSqrt(uround);
fnorm = N_VWrmsNorm(fy, ewt);
minInc = (fnorm != ZERO) ?
(MIN_INC_MULT * ABS(h) * uround * N * fnorm) : ONE;
/* This is the only for loop for 0..N-1 in CVODE */
for (j = 0; j < N; j++) {
/* Generate the jth col of J(tn,y) */
N_VSetArrayPointer(DENSE_COL(J,j), jthCol);
yjsaved = y_data[j];
inc = MAX(srur*ABS(yjsaved), minInc/ewt_data[j]);
y_data[j] += inc;
f(tn, y, ftemp, f_data);
y_data[j] = yjsaved;
inc_inv = ONE/inc;
N_VLinearSum(inc_inv, ftemp, -inc_inv, fy, jthCol);
DENSE_COL(J,j) = N_VGetArrayPointer(jthCol);
}
/* Restore original array pointer in tmp2 */
N_VSetArrayPointer(tmp2_data, tmp2);
/* Increment counter nfeD */
nfeD += N;
}
static int fB(realtype t, N_Vector c, N_Vector cB,
N_Vector cBdot, void *user_data)
{
int i, ic, ici, idxl, idxu, idyl, idyu, iyoff, jx, jy, ns, mxns;
realtype dcxli, dcxui, dcyli, dcyui, x, y, *cox, *coy, *fsave, *fBsave, dx, dy;
realtype *cdata, *cBdata, *cBdotdata;
WebData wdata;
realtype gu[NS];
wdata = (WebData) user_data;
cdata = N_VGetArrayPointer(c);
cBdata = N_VGetArrayPointer(cB);
cBdotdata = N_VGetArrayPointer(cBdot);
mxns = wdata->mxns;
ns = wdata->ns;
fsave = wdata->fsave;
fBsave = wdata->fBsave;
cox = wdata->cox;
coy = wdata->coy;
mxns = wdata->mxns;
dx = wdata->dx;
dy = wdata->dy;
for ( i = 0; i < ns; i++ ) gu[i] = ZERO;
gu[ISPEC-1] = ONE;
for (jy = 0; jy < MY; jy++) {
y = jy*dy;
iyoff = mxns*jy;
idyu = (jy == MY-1) ? -mxns : mxns;
idyl = (jy == 0) ? -mxns : mxns;
for (jx = 0; jx < MX; jx++) {
x = jx*dx;
ic = iyoff + ns*jx;
/* Get interaction rates at one point (x,y). */
WebRatesB(x, y, t, cdata+ic, cBdata+ic, fsave+ic, fBsave+ic, wdata);
idxu = (jx == MX-1) ? -ns : ns;
idxl = (jx == 0) ? -ns : ns;
for (i = 1; i <= ns; i++) {
ici = ic + i-1;
/* Do differencing in y. */
dcyli = cBdata[ici] - cBdata[ici-idyl];
dcyui = cBdata[ici+idyu] - cBdata[ici];
/* Do differencing in x. */
dcxli = cBdata[ici] - cBdata[ici-idxl];
dcxui = cBdata[ici+idxu] - cBdata[ici];
/* Collect terms and load cdot elements. */
cBdotdata[ici] = - coy[i-1]*(dcyui - dcyli)
- cox[i-1]*(dcxui - dcxli)
- fBsave[ici]
- gu[i-1];
}
}
}
return(0);
}
double* Cvode::n_vector_data(N_Vector v, int tid) {
if (!v) { return 0; }
if (nctd_ > 1) {
N_Vector subvec = ((N_Vector*)N_VGetArrayPointer(v))[tid];
return N_VGetArrayPointer(subvec);
}
return N_VGetArrayPointer(v);
}
static void CVBandPDQJac(CVBandPrecData pdata,
realtype t, N_Vector y, N_Vector fy,
N_Vector ftemp, N_Vector ytemp)
{
CVodeMem cv_mem;
realtype fnorm, minInc, inc, inc_inv, srur;
long int group, i, j, width, ngroups, i1, i2;
realtype *col_j, *ewt_data, *fy_data, *ftemp_data, *y_data, *ytemp_data;
cv_mem = (CVodeMem) pdata->cvode_mem;
/* Obtain pointers to the data for ewt, fy, ftemp, y, ytemp. */
ewt_data = N_VGetArrayPointer(ewt);
fy_data = N_VGetArrayPointer(fy);
ftemp_data = N_VGetArrayPointer(ftemp);
y_data = N_VGetArrayPointer(y);
ytemp_data = N_VGetArrayPointer(ytemp);
/* Load ytemp with y = predicted y vector. */
N_VScale(ONE, y, ytemp);
/* Set minimum increment based on uround and norm of f. */
srur = RSqrt(uround);
fnorm = N_VWrmsNorm(fy, ewt);
minInc = (fnorm != ZERO) ?
(MIN_INC_MULT * ABS(h) * uround * N * fnorm) : ONE;
/* Set bandwidth and number of column groups for band differencing. */
width = ml + mu + 1;
ngroups = MIN(width, N);
for (group = 1; group <= ngroups; group++) {
/* Increment all y_j in group. */
for(j = group-1; j < N; j += width) {
inc = MAX(srur*ABS(y_data[j]), minInc/ewt_data[j]);
ytemp_data[j] += inc;
}
/* Evaluate f with incremented y. */
f(t, ytemp, ftemp, f_data);
nfeBP++;
/* Restore ytemp, then form and load difference quotients. */
for (j = group-1; j < N; j += width) {
ytemp_data[j] = y_data[j];
col_j = BAND_COL(savedJ,j);
inc = MAX(srur*ABS(y_data[j]), minInc/ewt_data[j]);
inc_inv = ONE/inc;
i1 = MAX(0, j-mu);
i2 = MIN(j+ml, N-1);
for (i=i1; i <= i2; i++)
BAND_COL_ELEM(col_j,i,j) =
inc_inv * (ftemp_data[i] - fy_data[i]);
}
}
}
/*
* function calculates a jacobian matrix
*/
static
int nlsDenseJac(long int N, N_Vector vecX, N_Vector vecFX, DlsMat 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 *xScaling = NV_DATA_S(kinsolData->xScale);
double *fRes = NV_DATA_S(kinsolData->fRes);
double xsave, xscale, sign;
double delta_hh;
const double delta_h = sqrt(DBL_EPSILON*2e1);
long int i,j;
/* performance measurement */
rt_ext_tp_tick(&nlsData->jacobianTimeClock);
for(i = 0; i < N; i++)
{
xsave = x[i];
delta_hh = delta_h * (fabs(xsave) + 1.0);
if ((xsave + delta_hh >= nlsData->max[i]))
delta_hh *= -1;
x[i] += delta_hh;
/* Calculate difference quotient */
nlsKinsolResiduals(vecX, kinsolData->fRes, userData);
/* Calculate scaled difference quotient */
delta_hh = 1. / delta_hh;
for(j = 0; j < N; j++)
{
DENSE_ELEM(Jac, j, i) = (fRes[j] - fx[j]) * delta_hh;
}
x[i] = xsave;
}
/* debug */
if (ACTIVE_STREAM(LOG_NLS_JAC)){
infoStreamPrint(LOG_NLS_JAC, 0, "##KINSOL## omc dense matrix.");
PrintMat(Jac);
}
/* performance measurement and statistics */
nlsData->jacobianTime += rt_ext_tp_tock(&(nlsData->jacobianTimeClock));
nlsData->numberOfJEval++;
return 0;
}
void FCVf(realtype t, N_Vector y, N_Vector ydot, void *f_data)
{
realtype *ydata, *dydata;
ydata = N_VGetArrayPointer(y);
dydata = N_VGetArrayPointer(ydot);
FCV_FUN(&t, ydata, dydata);
}
void FCVgloc(long int Nloc, realtype t, N_Vector yloc, N_Vector gloc,
void *f_data)
{
realtype *yloc_data, *gloc_data;
yloc_data = N_VGetArrayPointer(yloc);
gloc_data = N_VGetArrayPointer(gloc);
FCV_GLOCFN(&Nloc, &t, yloc_data, gloc_data);
}