static int Precond(realtype tn, N_Vector y, N_Vector fy, booleantype jok,
booleantype *jcurPtr, realtype gamma, void *P_data,
N_Vector vtemp1, N_Vector vtemp2, N_Vector vtemp3)
{
realtype c1, c2, czdn, czup, diag, zdn, zup, q4coef, delz, verdco, hordco;
realtype **(*P)[MZ], **(*Jbd)[MZ];
long int *(*pivot)[MZ];
int ier, jx, jz;
realtype *ydata, **a, **j;
UserData data;
realtype Q1, Q2, C3, A3, A4, KH, VEL, KV0;
/* Make local copies of pointers in P_data, and of pointer to y's data */
data = (UserData) P_data;
P = data->P;
Jbd = data->Jbd;
pivot = data->pivot;
ydata = NV_DATA_S(y);
/* Load problem coefficients and parameters */
Q1 = data->p[0];
Q2 = data->p[1];
C3 = data->p[2];
A3 = data->p[3];
A4 = data->p[4];
KH = data->p[5];
VEL = data->p[6];
KV0 = data->p[7];
if (jok) {
/* jok = TRUE: Copy Jbd to P */
for (jz=0; jz < MZ; jz++)
for (jx=0; jx < MX; jx++)
dencopy(Jbd[jx][jz], P[jx][jz], NUM_SPECIES);
*jcurPtr = FALSE;
}
else {
/* jok = FALSE: Generate Jbd from scratch and copy to P */
/* Make local copies of problem variables, for efficiency. */
q4coef = data->q4;
delz = data->dz;
verdco = data->vdco;
hordco = data->hdco;
/* Compute 2x2 diagonal Jacobian blocks (using q4 values
computed on the last f call). Load into P. */
for (jz=0; jz < MZ; jz++) {
zdn = ZMIN + (jz - RCONST(0.5))*delz;
zup = zdn + delz;
czdn = verdco*EXP(RCONST(0.2)*zdn);
czup = verdco*EXP(RCONST(0.2)*zup);
diag = -(czdn + czup + RCONST(2.0)*hordco);
for (jx=0; jx < MX; jx++) {
c1 = IJKth(ydata,1,jx,jz);
c2 = IJKth(ydata,2,jx,jz);
j = Jbd[jx][jz];
a = P[jx][jz];
IJth(j,1,1) = (-Q1*C3 - Q2*c2) + diag;
IJth(j,1,2) = -Q2*c1 + q4coef;
IJth(j,2,1) = Q1*C3 - Q2*c2;
IJth(j,2,2) = (-Q2*c1 - q4coef) + diag;
dencopy(j, a, NUM_SPECIES);
}
}
*jcurPtr = TRUE;
}
/* Scale by -gamma */
for (jz=0; jz < MZ; jz++)
for (jx=0; jx < MX; jx++)
denscale(-gamma, P[jx][jz], NUM_SPECIES);
/* Add identity matrix and do LU decompositions on blocks in place. */
for (jx=0; jx < MX; jx++) {
for (jz=0; jz < MZ; jz++) {
denaddI(P[jx][jz], NUM_SPECIES);
ier = gefa(P[jx][jz], NUM_SPECIES, pivot[jx][jz]);
if (ier != 0) return(1);
}
}
return(0);
}
static int Precond(realtype tn, N_Vector u, N_Vector fu,
booleantype jok, booleantype *jcurPtr, realtype gamma,
void *P_data, N_Vector vtemp1, N_Vector vtemp2,
N_Vector vtemp3)
{
realtype c1, c2, cydn, cyup, diag, ydn, yup, q4coef, dely, verdco, hordco;
realtype **(*P)[MY], **(*Jbd)[MY];
long int *(*pivot)[MY], ier;
int jx, jy;
realtype *udata, **a, **j;
UserData data;
/* Make local copies of pointers in P_data, and of pointer to u's data */
data = (UserData) P_data;
P = data->P;
Jbd = data->Jbd;
pivot = data->pivot;
udata = NV_DATA_S(u);
if (jok) {
/* jok = TRUE: Copy Jbd to P */
for (jy=0; jy < MY; jy++)
for (jx=0; jx < MX; jx++)
dencopy(Jbd[jx][jy], P[jx][jy], NUM_SPECIES);
*jcurPtr = FALSE;
}
else {
/* jok = FALSE: Generate Jbd from scratch and copy to P */
/* Make local copies of problem variables, for efficiency. */
q4coef = data->q4;
dely = data->dy;
verdco = data->vdco;
hordco = data->hdco;
/* Compute 2x2 diagonal Jacobian blocks (using q4 values
computed on the last f call). Load into P. */
for (jy=0; jy < MY; jy++) {
ydn = YMIN + (jy - RCONST(0.5))*dely;
yup = ydn + dely;
cydn = verdco*exp(RCONST(0.2)*ydn);
cyup = verdco*exp(RCONST(0.2)*yup);
diag = -(cydn + cyup + TWO*hordco);
for (jx=0; jx < MX; jx++) {
c1 = IJKth(udata,1,jx,jy);
c2 = IJKth(udata,2,jx,jy);
j = Jbd[jx][jy];
a = P[jx][jy];
IJth(j,1,1) = (-Q1*C3 - Q2*c2) + diag;
IJth(j,1,2) = -Q2*c1 + q4coef;
IJth(j,2,1) = Q1*C3 - Q2*c2;
IJth(j,2,2) = (-Q2*c1 - q4coef) + diag;
dencopy(j, a, NUM_SPECIES);
}
}
*jcurPtr = TRUE;
}
/* Scale by -gamma */
for (jy=0; jy < MY; jy++)
for (jx=0; jx < MX; jx++)
denscale(-gamma, P[jx][jy], NUM_SPECIES);
/* Add identity matrix and do LU decompositions on blocks in place. */
for (jx=0; jx < MX; jx++) {
for (jy=0; jy < MY; jy++) {
denaddI(P[jx][jy], NUM_SPECIES);
ier = gefa(P[jx][jy], NUM_SPECIES, pivot[jx][jy]);
if (ier != 0) return(1);
}
}
return(0);
}
void DenseAddI(DenseMat A)
{
denaddI(A->data, A->size);
}
/* Preconditioner setup routine. Generate and preprocess P. */
static int Precond(realtype tn, N_Vector u, N_Vector fu,
booleantype jok, booleantype *jcurPtr,
realtype gamma, void *P_data,
N_Vector vtemp1, N_Vector vtemp2, N_Vector vtemp3)
{
realtype c1, c2, cydn, cyup, diag, ydn, yup, q4coef, dely, verdco, hordco;
realtype **(*P)[MYSUB], **(*Jbd)[MYSUB];
long int nvmxsub, *(*pivot)[MYSUB], ier, offset;
int lx, ly, jx, jy, isubx, isuby;
realtype *udata, **a, **j;
PreconData predata;
UserData data;
/* Make local copies of pointers in P_data, pointer to u's data,
and PE index pair */
predata = (PreconData) P_data;
data = (UserData) (predata->f_data);
P = predata->P;
Jbd = predata->Jbd;
pivot = predata->pivot;
udata = NV_DATA_P(u);
isubx = data->isubx; isuby = data->isuby;
nvmxsub = data->nvmxsub;
if (jok) {
/* jok = TRUE: Copy Jbd to P */
for (ly = 0; ly < MYSUB; ly++)
for (lx = 0; lx < MXSUB; lx++)
dencopy(Jbd[lx][ly], P[lx][ly], NVARS, NVARS);
*jcurPtr = FALSE;
}
else {
/* jok = FALSE: Generate Jbd from scratch and copy to P */
/* Make local copies of problem variables, for efficiency */
q4coef = data->q4;
dely = data->dy;
verdco = data->vdco;
hordco = data->hdco;
/* Compute 2x2 diagonal Jacobian blocks (using q4 values
computed on the last f call). Load into P. */
for (ly = 0; ly < MYSUB; ly++) {
jy = ly + isuby*MYSUB;
ydn = YMIN + (jy - RCONST(0.5))*dely;
yup = ydn + dely;
cydn = verdco*EXP(RCONST(0.2)*ydn);
cyup = verdco*EXP(RCONST(0.2)*yup);
diag = -(cydn + cyup + RCONST(2.0)*hordco);
for (lx = 0; lx < MXSUB; lx++) {
jx = lx + isubx*MXSUB;
offset = lx*NVARS + ly*nvmxsub;
c1 = udata[offset];
c2 = udata[offset+1];
j = Jbd[lx][ly];
a = P[lx][ly];
IJth(j,1,1) = (-Q1*C3 - Q2*c2) + diag;
IJth(j,1,2) = -Q2*c1 + q4coef;
IJth(j,2,1) = Q1*C3 - Q2*c2;
IJth(j,2,2) = (-Q2*c1 - q4coef) + diag;
dencopy(j, a, NVARS, NVARS);
}
}
*jcurPtr = TRUE;
}
/* Scale by -gamma */
for (ly = 0; ly < MYSUB; ly++)
for (lx = 0; lx < MXSUB; lx++)
denscale(-gamma, P[lx][ly], NVARS, NVARS);
/* Add identity matrix and do LU decompositions on blocks in place */
for (lx = 0; lx < MXSUB; lx++) {
for (ly = 0; ly < MYSUB; ly++) {
denaddI(P[lx][ly], NVARS);
ier = denGETRF(P[lx][ly], NVARS, NVARS, pivot[lx][ly]);
if (ier != 0) return(1);
}
}
return(0);
}
/*
This routine generates the block-diagonal part of the Jacobian
corresponding to the interaction rates, multiplies by -gamma, adds
the identity matrix, and calls denGETRF to do the LU decomposition of
each diagonal block. The computation of the diagonal blocks uses
the preset block and grouping information. One block per group is
computed. The Jacobian elements are generated by difference
quotients using calls to the routine fblock.
This routine can be regarded as a prototype for the general case
of a block-diagonal preconditioner. The blocks are of size mp, and
there are ngrp=ngx*ngy blocks computed in the block-grouping scheme.
*/
static int Precond(realtype t, N_Vector c, N_Vector fc,
booleantype jok, booleantype *jcurPtr, realtype gamma,
void *P_data, N_Vector vtemp1, N_Vector vtemp2,
N_Vector vtemp3)
{
realtype ***P;
long int **pivot, ier;
int i, if0, if00, ig, igx, igy, j, jj, jx, jy;
int *jxr, *jyr, mp, ngrp, ngx, ngy, mxmp, flag;
realtype uround, fac, r, r0, save, srur;
realtype *f1, *fsave, *cdata, *rewtdata;
WebData wdata;
void *cvode_mem;
N_Vector rewt;
wdata = (WebData) P_data;
cvode_mem = wdata->cvode_mem;
cdata = NV_DATA_S(c);
rewt = wdata->rewt;
flag = CVodeGetErrWeights(cvode_mem, rewt);
if(check_flag(&flag, "CVodeGetErrWeights", 1)) return(1);
rewtdata = NV_DATA_S(rewt);
uround = UNIT_ROUNDOFF;
P = wdata->P;
pivot = wdata->pivot;
jxr = wdata->jxr;
jyr = wdata->jyr;
mp = wdata->mp;
srur = wdata->srur;
ngrp = wdata->ngrp;
ngx = wdata->ngx;
ngy = wdata->ngy;
mxmp = wdata->mxmp;
fsave = wdata->fsave;
/* Make mp calls to fblock to approximate each diagonal block of Jacobian.
Here, fsave contains the base value of the rate vector and
r0 is a minimum increment factor for the difference quotient. */
f1 = NV_DATA_S(vtemp1);
fac = N_VWrmsNorm (fc, rewt);
r0 = RCONST(1000.0)*ABS(gamma)*uround*NEQ*fac;
if (r0 == ZERO) r0 = ONE;
for (igy = 0; igy < ngy; igy++) {
jy = jyr[igy];
if00 = jy*mxmp;
for (igx = 0; igx < ngx; igx++) {
jx = jxr[igx];
if0 = if00 + jx*mp;
ig = igx + igy*ngx;
/* Generate ig-th diagonal block */
for (j = 0; j < mp; j++) {
/* Generate the jth column as a difference quotient */
jj = if0 + j;
save = cdata[jj];
r = MAX(srur*ABS(save),r0/rewtdata[jj]);
cdata[jj] += r;
fac = -gamma/r;
fblock (t, cdata, jx, jy, f1, wdata);
for (i = 0; i < mp; i++) {
P[ig][j][i] = (f1[i] - fsave[if0+i])*fac;
}
cdata[jj] = save;
}
}
}
/* Add identity matrix and do LU decompositions on blocks. */
for (ig = 0; ig < ngrp; ig++) {
denaddI(P[ig], mp);
ier = denGETRF(P[ig], mp, mp, pivot[ig]);
if (ier != 0) return(1);
}
*jcurPtr = TRUE;
return(0);
}
