void bandGBTRS(realtype **a, long int n, long int smu, long int ml, long int *p, realtype *b)
{
long int k, l, i, first_row_k, last_row_k;
realtype mult, *diag_k;
/* Solve Ly = Pb, store solution y in b */
for (k=0; k < n-1; k++) {
l = p[k];
mult = b[l];
if (l != k) {
b[l] = b[k];
b[k] = mult;
}
diag_k = a[k]+smu;
last_row_k = SUNMIN(n-1,k+ml);
for (i=k+1; i <= last_row_k; i++)
b[i] += mult * diag_k[i-k];
}
/* Solve Ux = y, store solution x in b */
for (k=n-1; k >= 0; k--) {
diag_k = a[k]+smu;
first_row_k = SUNMAX(0,k-smu);
b[k] /= (*diag_k);
mult = -b[k];
for (i=first_row_k; i <= k-1; i++)
b[i] += mult*diag_k[i-k];
}
}
/*-----------------------------------------------------------------
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 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;
}
void SUNBandMatrix_Print(SUNMatrix A, FILE* outfile)
{
sunindextype i, j, start, finish;
/* should not be called unless A is a band matrix;
otherwise return immediately */
if (SUNMatGetID(A) != SUNMATRIX_BAND)
return;
/* perform operation */
fprintf(outfile,"\n");
for (i=0; i<SM_ROWS_B(A); i++) {
start = SUNMAX(0, i-SM_LBAND_B(A));
finish = SUNMIN(SM_COLUMNS_B(A)-1, i+SM_UBAND_B(A));
for (j=0; j<start; j++)
fprintf(outfile,"%12s ","");
for (j=start; j<=finish; j++) {
#if defined(SUNDIALS_EXTENDED_PRECISION)
fprintf(outfile,"%12Lg ", SM_ELEMENT_B(A,i,j));
#elif defined(SUNDIALS_DOUBLE_PRECISION)
fprintf(outfile,"%12g ", SM_ELEMENT_B(A,i,j));
#else
fprintf(outfile,"%12g ", SM_ELEMENT_B(A,i,j));
#endif
}
fprintf(outfile,"\n");
}
fprintf(outfile,"\n");
return;
}
/* ----------------------------------------------------------------------
* 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);
}
/*-------------------------------------------------------------*/
int IDABBDPrecReInit(void *ida_mem, sunindextype mudq,
sunindextype mldq, realtype dq_rel_yy)
{
IDAMem IDA_mem;
IDALsMem idals_mem;
IBBDPrecData pdata;
sunindextype Nlocal;
if (ida_mem == NULL) {
IDAProcessError(NULL, IDALS_MEM_NULL, "IDASBBDPRE",
"IDABBDPrecReInit", MSGBBD_MEM_NULL);
return(IDALS_MEM_NULL);
}
IDA_mem = (IDAMem) ida_mem;
/* Test if the LS linear solver interface has been created */
if (IDA_mem->ida_lmem == NULL) {
IDAProcessError(IDA_mem, IDALS_LMEM_NULL, "IDASBBDPRE",
"IDABBDPrecReInit", MSGBBD_LMEM_NULL);
return(IDALS_LMEM_NULL);
}
idals_mem = (IDALsMem) IDA_mem->ida_lmem;
/* Test if the preconditioner data is non-NULL */
if (idals_mem->pdata == NULL) {
IDAProcessError(IDA_mem, IDALS_PMEM_NULL, "IDASBBDPRE",
"IDABBDPrecReInit", MSGBBD_PMEM_NULL);
return(IDALS_PMEM_NULL);
}
pdata = (IBBDPrecData) idals_mem->pdata;
/* Load half-bandwidths. */
Nlocal = pdata->n_local;
pdata->mudq = SUNMIN(Nlocal-1, SUNMAX(0, mudq));
pdata->mldq = SUNMIN(Nlocal-1, SUNMAX(0, mldq));
/* Set rel_yy based on input value dq_rel_yy (0 implies default). */
pdata->rel_yy = (dq_rel_yy > ZERO) ?
dq_rel_yy : SUNRsqrt(IDA_mem->ida_uround);
/* Re-initialize nge */
pdata->nge = 0;
return(IDALS_SUCCESS);
}
int KINSpilsDQJtimes(N_Vector v, N_Vector Jv,
N_Vector u, booleantype *new_u,
void *data)
{
realtype sigma, sigma_inv, sutsv, sq1norm, sign, vtv;
KINMem kin_mem;
KINSpilsMem kinspils_mem;
int retval;
/* data is kin_mem */
kin_mem = (KINMem) data;
kinspils_mem = (KINSpilsMem) lmem;
/* scale the vector v and put Du*v into vtemp1 */
N_VProd(v, uscale, vtemp1);
/* scale u and put into Jv (used as a temporary storage) */
N_VProd(u, uscale, Jv);
/* compute dot product (Du*u).(Du*v) */
sutsv = N_VDotProd(Jv, vtemp1);
/* compute dot product (Du*v).(Du*v) */
vtv = N_VDotProd(vtemp1, vtemp1);
sq1norm = N_VL1Norm(vtemp1);
sign = (sutsv >= ZERO) ? ONE : -ONE ;
/* this expression for sigma is from p. 469, Brown and Saad paper */
sigma = sign*sqrt_relfunc*SUNMAX(SUNRabs(sutsv),sq1norm)/vtv;
sigma_inv = ONE/sigma;
/* compute the u-prime at which to evaluate the function func */
N_VLinearSum(ONE, u, sigma, v, vtemp1);
/* call the system function to calculate func(u+sigma*v) */
retval = func(vtemp1, vtemp2, user_data);
nfes++;
if (retval != 0) return(retval);
/* finish the computation of the difference quotient */
N_VLinearSum(sigma_inv, vtemp2, -sigma_inv, fval, Jv);
return(0);
}
int CVBBDPrecReInit(void *cvode_mem,
long int mudq, long int mldq,
realtype dqrely)
{
CVodeMem cv_mem;
CVSpilsMem cvspils_mem;
CVBBDPrecData pdata;
long int Nlocal;
if (cvode_mem == NULL) {
cvProcessError(NULL, CVSPILS_MEM_NULL, "CVBBDPRE", "CVBBDPrecReInit", MSGBBD_MEM_NULL);
return(CVSPILS_MEM_NULL);
}
cv_mem = (CVodeMem) cvode_mem;
/* Test if one of the SPILS linear solvers has been attached */
if (cv_mem->cv_lmem == NULL) {
cvProcessError(cv_mem, CVSPILS_LMEM_NULL, "CVBBDPRE", "CVBBDPrecReInit", MSGBBD_LMEM_NULL);
return(CVSPILS_LMEM_NULL);
}
cvspils_mem = (CVSpilsMem) cv_mem->cv_lmem;
/* Test if the preconditioner data is non-NULL */
if (cvspils_mem->s_P_data == NULL) {
cvProcessError(cv_mem, CVSPILS_PMEM_NULL, "CVBBDPRE", "CVBBDPrecReInit", MSGBBD_PMEM_NULL);
return(CVSPILS_PMEM_NULL);
}
pdata = (CVBBDPrecData) cvspils_mem->s_P_data;
/* Load half-bandwidths */
Nlocal = pdata->n_local;
pdata->mudq = SUNMIN(Nlocal-1, SUNMAX(0,mudq));
pdata->mldq = SUNMIN(Nlocal-1, SUNMAX(0,mldq));
/* Set pdata->dqrely based on input dqrely (0 implies default). */
pdata->dqrely = (dqrely > ZERO) ? dqrely : SUNRsqrt(uround);
/* Re-initialize nge */
pdata->nge = 0;
return(CVSPILS_SUCCESS);
}
int ClassicalGS(N_Vector *v, realtype **h, int k, int p, realtype *new_vk_norm,
realtype *stemp, N_Vector *vtemp)
{
int i, i0, k_minus_1, retval;
realtype vk_norm;
k_minus_1 = k - 1;
i0 = SUNMAX(k-p,0);
/* Perform Classical Gram-Schmidt */
retval = N_VDotProdMulti(k-i0+1, v[k], v+i0, stemp);
if (retval != 0) return(-1);
vk_norm = SUNRsqrt(stemp[k-i0]);
for (i=k-i0-1; i >= 0; i--) {
h[i][k_minus_1] = stemp[i];
stemp[i+1] = -stemp[i];
vtemp[i+1] = v[i];
}
stemp[0] = ONE;
vtemp[0] = v[k];
retval = N_VLinearCombination(k-i0+1, stemp, vtemp, v[k]);
if (retval != 0) return(-1);
/* Compute the norm of the new vector at v[k] */
*new_vk_norm = SUNRsqrt(N_VDotProd(v[k], v[k]));
/* Reorthogonalize if necessary */
if ((FACTOR * (*new_vk_norm)) < vk_norm) {
retval = N_VDotProdMulti(k-i0, v[k], v+i0, stemp+1);
if (retval != 0) return(-1);
stemp[0] = ONE;
vtemp[0] = v[k];
for (i=i0; i < k; i++) {
h[i][k_minus_1] += stemp[i-i0+1];
stemp[i-i0+1] = -stemp[i-i0+1];
vtemp[i-i0+1] = v[i-i0];
}
retval = N_VLinearCombination(k+1, stemp, vtemp, v[k]);
if (retval != 0) return(-1);
*new_vk_norm = SUNRsqrt(N_VDotProd(v[k],v[k]));
}
return(0);
}
void PrintMat(DlsMat A)
{
long int i, j, start, finish;
realtype **a;
switch (A->type) {
case SUNDIALS_DENSE:
printf("\n");
for (i=0; i < A->M; i++) {
for (j=0; j < A->N; j++) {
#if defined(SUNDIALS_EXTENDED_PRECISION)
printf("%12Lg ", DENSE_ELEM(A,i,j));
#elif defined(SUNDIALS_DOUBLE_PRECISION)
printf("%12g ", DENSE_ELEM(A,i,j));
#else
printf("%12g ", DENSE_ELEM(A,i,j));
#endif
}
printf("\n");
}
printf("\n");
break;
case SUNDIALS_BAND:
a = A->cols;
printf("\n");
for (i=0; i < A->N; i++) {
start = SUNMAX(0,i-A->ml);
finish = SUNMIN(A->N-1,i+A->mu);
for (j=0; j < start; j++) printf("%12s ","");
for (j=start; j <= finish; j++) {
#if defined(SUNDIALS_EXTENDED_PRECISION)
printf("%12Lg ", a[j][i-j+A->s_mu]);
#elif defined(SUNDIALS_DOUBLE_PRECISION)
printf("%12g ", a[j][i-j+A->s_mu]);
#else
printf("%12g ", a[j][i-j+A->s_mu]);
#endif
}
printf("\n");
}
printf("\n");
break;
}
}
int SMScaleAddNew_Band(realtype c, SUNMatrix A, SUNMatrix B)
{
sunindextype i, j, ml, mu, smu;
realtype *A_colj, *B_colj, *C_colj;
SUNMatrix C;
/* create new matrix large enough to hold both A and B */
ml = SUNMAX(SM_LBAND_B(A),SM_LBAND_B(B));
mu = SUNMAX(SM_UBAND_B(A),SM_UBAND_B(B));
smu = SUNMIN(SM_COLUMNS_B(A)-1, mu + ml);
C = SUNBandMatrix(SM_COLUMNS_B(A), mu, ml, smu);
/* scale/add c*A into new matrix */
for (j=0; j<SM_COLUMNS_B(A); j++) {
A_colj = SM_COLUMN_B(A,j);
C_colj = SM_COLUMN_B(C,j);
for (i=-SM_UBAND_B(A); i<=SM_LBAND_B(A); i++)
C_colj[i] = c*A_colj[i];
}
/* add B into new matrix */
for (j=0; j<SM_COLUMNS_B(B); j++) {
B_colj = SM_COLUMN_B(B,j);
C_colj = SM_COLUMN_B(C,j);
for (i=-SM_UBAND_B(B); i<=SM_LBAND_B(B); i++)
C_colj[i] += B_colj[i];
}
/* replace A contents with C contents, nullify C content pointer, destroy C */
free(SM_DATA_B(A)); SM_DATA_B(A) = NULL;
free(SM_COLS_B(A)); SM_COLS_B(A) = NULL;
free(A->content); A->content = NULL;
A->content = C->content;
C->content = NULL;
SUNMatDestroy_Band(C);
return 0;
}
int SUNMatCopy_Band(SUNMatrix A, SUNMatrix B)
{
sunindextype i, j, colSize, ml, mu, smu;
realtype *A_colj, *B_colj;
/* Verify that A and B have compatible dimensions */
if (!SMCompatible_Band(A, B))
return 1;
/* Grow B if A's bandwidth is larger */
if ( (SM_UBAND_B(A) > SM_UBAND_B(B)) ||
(SM_LBAND_B(A) > SM_LBAND_B(B)) ) {
ml = SUNMAX(SM_LBAND_B(B),SM_LBAND_B(A));
mu = SUNMAX(SM_UBAND_B(B),SM_UBAND_B(A));
smu = SUNMAX(SM_SUBAND_B(B),SM_SUBAND_B(A));
colSize = smu + ml + 1;
SM_CONTENT_B(B)->mu = mu;
SM_CONTENT_B(B)->ml = ml;
SM_CONTENT_B(B)->s_mu = smu;
SM_CONTENT_B(B)->ldim = colSize;
SM_CONTENT_B(B)->ldata = SM_COLUMNS_B(B) * colSize;
SM_CONTENT_B(B)->data = (realtype *)
realloc(SM_CONTENT_B(B)->data, SM_COLUMNS_B(B) * colSize*sizeof(realtype));
for (j=0; j<SM_COLUMNS_B(B); j++)
SM_CONTENT_B(B)->cols[j] = SM_CONTENT_B(B)->data + j * colSize;
}
/* Perform operation */
if (SUNMatZero_Band(B) != 0)
return 1;
for (j=0; j<SM_COLUMNS_B(B); j++) {
B_colj = SM_COLUMN_B(B,j);
A_colj = SM_COLUMN_B(A,j);
for (i=-SM_UBAND_B(A); i<=SM_LBAND_B(A); i++)
B_colj[i] = A_colj[i];
}
return 0;
}
int ModifiedGS(N_Vector *v, realtype **h, int k, int p,
realtype *new_vk_norm)
{
int i, k_minus_1, i0;
realtype new_norm_2, new_product, vk_norm, temp;
vk_norm = SUNRsqrt(N_VDotProd(v[k],v[k]));
k_minus_1 = k - 1;
i0 = SUNMAX(k-p, 0);
/* Perform modified Gram-Schmidt */
for (i=i0; i < k; i++) {
h[i][k_minus_1] = N_VDotProd(v[i], v[k]);
N_VLinearSum(ONE, v[k], -h[i][k_minus_1], v[i], v[k]);
}
/* Compute the norm of the new vector at v[k] */
*new_vk_norm = SUNRsqrt(N_VDotProd(v[k], v[k]));
/* If the norm of the new vector at v[k] is less than
FACTOR (== 1000) times unit roundoff times the norm of the
input vector v[k], then the vector will be reorthogonalized
in order to ensure that nonorthogonality is not being masked
by a very small vector length. */
temp = FACTOR * vk_norm;
if ((temp + (*new_vk_norm)) != temp) return(0);
new_norm_2 = ZERO;
for (i=i0; i < k; i++) {
new_product = N_VDotProd(v[i], v[k]);
temp = FACTOR * h[i][k_minus_1];
if ((temp + new_product) == temp) continue;
h[i][k_minus_1] += new_product;
N_VLinearSum(ONE, v[k],-new_product, v[i], v[k]);
new_norm_2 += SUNSQR(new_product);
}
if (new_norm_2 != ZERO) {
new_product = SUNSQR(*new_vk_norm) - new_norm_2;
*new_vk_norm = (new_product > ZERO) ? SUNRsqrt(new_product) : ZERO;
}
return(0);
}
CAMLprim value sunml_spils_classical_gs(value vargs)
{
CAMLparam1(vargs);
CAMLlocal3(vv, vh, vs);
int k = Int_val(Field(vargs, 2));
int p = Int_val(Field(vargs, 3));
N_Vector temp = NVEC_VAL(Field(vargs, 4));
int i;
int i0 = SUNMAX(k-p, 0);
realtype new_vk_norm;
N_Vector* v;
vv = Field(vargs, 0);
vh = Field(vargs, 1);
vs = Field(vargs, 5);
#if SUNDIALS_ML_SAFE == 1
struct caml_ba_array *bh = ARRAY2_DATA(vh);
intnat hn = bh->dim[0];
intnat hm = bh->dim[1];
if (hn < k + 1)
caml_invalid_argument("classical_gs: h is too small (< k + 1).");
if (hm < k)
caml_invalid_argument("classical_gs: h is too small (< k).");
if (Wosize_val (vv) < k + 1)
caml_invalid_argument("classical_gs: v is too small (< k + 1).");
if (ARRAY1_LEN(vs) < k)
caml_invalid_argument("classical_gs: s is too small (< k).");
#endif
v = calloc(p + 1, sizeof(N_Vector));
if (v == NULL) caml_raise_out_of_memory();
for (i = i0; i <= k; ++i)
v[i] = NVEC_VAL(Field(vv, i));
ClassicalGS(v, ARRAY2_ACOLS(vh), k, p, &new_vk_norm,
temp, REAL_ARRAY(vs));
free(v);
CAMLreturn(caml_copy_double(new_vk_norm));
}
static int cvNlsConvTestSensStg1(SUNNonlinearSolver NLS,
N_Vector ycor, N_Vector delta,
realtype tol, N_Vector ewt, void* cvode_mem)
{
CVodeMem cv_mem;
int m, retval;
realtype del;
realtype dcon;
if (cvode_mem == NULL) {
cvProcessError(NULL, CV_MEM_NULL, "CVODES",
"cvNlsConvTestSensStg1", MSGCV_NO_MEM);
return(CV_MEM_NULL);
}
cv_mem = (CVodeMem) cvode_mem;
/* compute the norm of the state and sensitivity corrections */
del = N_VWrmsNorm(delta, ewt);
/* get the current nonlinear solver iteration count */
retval = SUNNonlinSolGetCurIter(NLS, &m);
if (retval != CV_SUCCESS) return(CV_MEM_NULL);
/* Test for convergence. If m > 0, an estimate of the convergence
rate constant is stored in crate, and used in the test.
*/
if (m > 0) {
cv_mem->cv_crateS = SUNMAX(CRDOWN * cv_mem->cv_crateS, del/cv_mem->cv_delp);
}
dcon = del * SUNMIN(ONE, cv_mem->cv_crateS) / tol;
/* check if nonlinear system was solved successfully */
if (dcon <= ONE) return(CV_SUCCESS);
/* check if the iteration seems to be diverging */
if ((m >= 1) && (del > RDIV*cv_mem->cv_delp)) return(SUN_NLS_CONV_RECVR);
/* Save norm of correction and loop again */
cv_mem->cv_delp = del;
/* Not yet converged */
return(SUN_NLS_CONTINUE);
}
CAMLprim value sunml_spils_modified_gs(value vv, value vh, value vk, value vp)
{
CAMLparam4(vv, vh, vk, vp);
int p = Int_val(vp);
int k = Int_val(vk);
int i;
int i0 = SUNMAX(k-p, 0);
realtype new_vk_norm;
N_Vector* v;
#if SUNDIALS_ML_SAFE == 1
struct caml_ba_array *bh = ARRAY2_DATA(vh);
intnat hn = bh->dim[0];
intnat hm = bh->dim[1];
if (hn < k + 1)
caml_invalid_argument("modified_gs: h is too small (dim1 < k + 1).");
if (hm < k)
caml_invalid_argument("modified_gs: h is too small (dim2 < k).");
if (Wosize_val (vv) < k + 1)
caml_invalid_argument("modified_gs: v is too small (< k + 1).");
#endif
v = calloc(k + 1, sizeof(N_Vector));
if (v == NULL) caml_raise_out_of_memory();
for (i = i0; i <= k; ++i)
v[i] = NVEC_VAL(Field(vv, i));
ModifiedGS(v, ARRAY2_ACOLS(vh), k, p, &new_vk_norm);
free(v);
CAMLreturn(caml_copy_double(new_vk_norm));
}
/* ----------------------------------------------------------------------
* Implementation-specific 'check' routines
* --------------------------------------------------------------------*/
int check_vector(N_Vector X, N_Vector Y, realtype tol)
{
int failure = 0;
sunindextype i;
realtype *Xdata, *Ydata, maxerr;
Xdata = N_VGetArrayPointer(X);
Ydata = N_VGetArrayPointer(Y);
/* check vector data */
for(i=0; i<problem_size; i++)
failure += FNEQ(Xdata[i], Ydata[i], FIVE*tol*SUNRabs(Xdata[i]));
if (failure > ZERO) {
maxerr = ZERO;
for(i=0; i < problem_size; i++)
maxerr = SUNMAX(SUNRabs(Xdata[i]-Ydata[i])/SUNRabs(Xdata[i]), maxerr);
printf("check err failure: maxerr = %g (tol = %g)\n",
maxerr, FIVE*tol);
return(1);
}
else
return(0);
}
int KINBBDPrecInit(void *kinmem, long int Nlocal,
long int mudq, long int mldq,
long int mukeep, long int mlkeep,
realtype dq_rel_uu,
KINLocalFn gloc, KINCommFn gcomm)
{
KBBDPrecData pdata;
KINSpilsMem kinspils_mem;
KINMem kin_mem;
N_Vector vtemp3;
long int muk, mlk, storage_mu;
int flag;
pdata = NULL;
if (kinmem == NULL) {
KINProcessError(NULL, 0, "KINBBDPRE", "KINBBDPrecInit", MSGBBD_MEM_NULL);
return(KINSPILS_MEM_NULL);
}
kin_mem = (KINMem) kinmem;
/* Test if one of the SPILS linear solvers has been attached */
if (kin_mem->kin_lmem == NULL) {
KINProcessError(kin_mem, KINSPILS_LMEM_NULL, "KINBBDPRE", "KINBBDPrecInit", MSGBBD_LMEM_NULL);
return(KINSPILS_LMEM_NULL);
}
kinspils_mem = (KINSpilsMem) kin_mem->kin_lmem;
/* Test if the NVECTOR package is compatible with BLOCK BAND preconditioner.
Note: do NOT need to check for N_VScale since it is required by KINSOL and
so has already been checked for (see KINMalloc) */
if (vec_tmpl->ops->nvgetarraypointer == NULL) {
KINProcessError(kin_mem, KINSPILS_ILL_INPUT, "KINBBDPRE", "KINBBDPrecInit", MSGBBD_BAD_NVECTOR);
return(KINSPILS_ILL_INPUT);
}
pdata = NULL;
pdata = (KBBDPrecData) malloc(sizeof *pdata); /* allocate data memory */
if (pdata == NULL) {
KINProcessError(kin_mem, KINSPILS_MEM_FAIL, "KINBBDPRE", "KINBBDPrecInit", MSGBBD_MEM_FAIL);
return(KINSPILS_MEM_FAIL);
}
/* set pointers to gloc and gcomm and load half-bandwiths */
pdata->kin_mem = kinmem;
pdata->gloc = gloc;
pdata->gcomm = gcomm;
pdata->mudq = SUNMIN(Nlocal-1, SUNMAX(0, mudq));
pdata->mldq = SUNMIN(Nlocal-1, SUNMAX(0, mldq));
muk = SUNMIN(Nlocal-1, SUNMAX(0,mukeep));
mlk = SUNMIN(Nlocal-1, SUNMAX(0,mlkeep));
pdata->mukeep = muk;
pdata->mlkeep = mlk;
/* allocate memory for preconditioner matrix */
storage_mu = SUNMIN(Nlocal-1, muk+mlk);
pdata->PP = NULL;
pdata->PP = NewBandMat(Nlocal, muk, mlk, storage_mu);
if (pdata->PP == NULL) {
free(pdata); pdata = NULL;
KINProcessError(kin_mem, KINSPILS_MEM_FAIL, "KINBBDPRE", "KINBBDPrecInit", MSGBBD_MEM_FAIL);
return(KINSPILS_MEM_FAIL);
}
/* allocate memory for lpivots */
pdata->lpivots = NULL;
pdata->lpivots = NewLintArray(Nlocal);
if (pdata->lpivots == NULL) {
DestroyMat(pdata->PP);
free(pdata); pdata = NULL;
KINProcessError(kin_mem, KINSPILS_MEM_FAIL, "KINBBDPRE", "KINBBDPrecInit", MSGBBD_MEM_FAIL);
return(KINSPILS_MEM_FAIL);
}
/* allocate vtemp3 for use by KBBDDQJac routine */
vtemp3 = NULL;
vtemp3 = N_VClone(kin_mem->kin_vtemp1);
if (vtemp3 == NULL) {
DestroyArray(pdata->lpivots);
DestroyMat(pdata->PP);
free(pdata); pdata = NULL;
KINProcessError(kin_mem, KINSPILS_MEM_FAIL, "KINBBDPRE", "KINBBDPrecInit", MSGBBD_MEM_FAIL);
return(KINSPILS_MEM_FAIL);
}
pdata->vtemp3 = vtemp3;
/* set rel_uu based on input value dq_rel_uu */
if (dq_rel_uu > ZERO) pdata->rel_uu = dq_rel_uu;
else pdata->rel_uu = SUNRsqrt(uround); /* using dq_rel_uu = 0.0 means use default */
/* store Nlocal to be used by the preconditioner routines */
pdata->n_local = Nlocal;
/* set work space sizes and initialize nge */
pdata->rpwsize = Nlocal * (storage_mu*mlk + 1) + 1;
pdata->ipwsize = Nlocal + 1;
pdata->nge = 0;
/* make sure s_P_data is free from any previous allocations */
if (kinspils_mem->s_pfree != NULL) {
kinspils_mem->s_pfree(kin_mem);
}
/* Point to the new P_data field in the SPILS memory */
kinspils_mem->s_P_data = pdata;
/* Attach the pfree function */
kinspils_mem->s_pfree = KINBBDPrecFree;
/* Attach preconditioner solve and setup functions */
flag = KINSpilsSetPreconditioner(kinmem, KINBBDPrecSetup, KINBBDPrecSolve);
return(flag);
}
static int KBBDDQJac(KBBDPrecData pdata,
N_Vector uu, N_Vector uscale,
N_Vector gu, N_Vector gtemp, N_Vector utemp)
{
realtype inc, inc_inv;
long int group, i, j, width, ngroups, i1, i2;
KINMem kin_mem;
realtype *udata, *uscdata, *gudata, *gtempdata, *utempdata, *col_j;
int retval;
kin_mem = (KINMem) pdata->kin_mem;
/* set pointers to the data for all vectors */
udata = N_VGetArrayPointer(uu);
uscdata = N_VGetArrayPointer(uscale);
gudata = N_VGetArrayPointer(gu);
gtempdata = N_VGetArrayPointer(gtemp);
utempdata = N_VGetArrayPointer(utemp);
/* load utemp with uu = predicted solution vector */
N_VScale(ONE, uu, utemp);
/* call gcomm and gloc to get base value of g(uu) */
if (gcomm != NULL) {
retval = gcomm(Nlocal, uu, user_data);
if (retval != 0) return(retval);
}
retval = gloc(Nlocal, uu, gu, user_data);
if (retval != 0) return(retval);
/* set bandwidth and number of column groups for band differencing */
width = mldq + mudq + 1;
ngroups = SUNMIN(width, Nlocal);
/* loop over groups */
for (group = 1; group <= ngroups; group++) {
/* increment all u_j in group */
for(j = group - 1; j < Nlocal; j += width) {
inc = rel_uu * SUNMAX(SUNRabs(udata[j]), (ONE / uscdata[j]));
utempdata[j] += inc;
}
/* evaluate g with incremented u */
retval = gloc(Nlocal, utemp, gtemp, user_data);
if (retval != 0) return(retval);
/* restore utemp, then form and load difference quotients */
for (j = group - 1; j < Nlocal; j += width) {
utempdata[j] = udata[j];
col_j = BAND_COL(PP,j);
inc = rel_uu * SUNMAX(SUNRabs(udata[j]) , (ONE / uscdata[j]));
inc_inv = ONE / inc;
i1 = SUNMAX(0, (j - mukeep));
i2 = SUNMIN((j + mlkeep), (Nlocal - 1));
for (i = i1; i <= i2; i++)
BAND_COL_ELEM(col_j, i, j) = inc_inv * (gtempdata[i] - gudata[i]);
}
}
return(0);
}
int idaDlsBandDQJac(long int N, long int mupper, long int mlower,
realtype tt, realtype c_j,
N_Vector yy, N_Vector yp, N_Vector rr,
DlsMat Jac, void *data,
N_Vector tmp1, N_Vector tmp2, N_Vector tmp3)
{
realtype inc, inc_inv, yj, ypj, srur, conj, ewtj;
realtype *y_data, *yp_data, *ewt_data, *cns_data = NULL;
realtype *ytemp_data, *yptemp_data, *rtemp_data, *r_data, *col_j;
N_Vector rtemp, ytemp, yptemp;
long int i, j, i1, i2, width, ngroups, group;
int retval = 0;
IDAMem IDA_mem;
IDADlsMem idadls_mem;
/* data points to IDA_mem */
IDA_mem = (IDAMem) data;
idadls_mem = (IDADlsMem) lmem;
rtemp = tmp1; /* Rename work vector for use as the perturbed residual. */
ytemp = tmp2; /* Rename work vector for use as a temporary for yy. */
yptemp= tmp3; /* Rename work vector for use as a temporary for yp. */
/* Obtain pointers to the data for all eight vectors used. */
ewt_data = N_VGetArrayPointer(ewt);
r_data = N_VGetArrayPointer(rr);
y_data = N_VGetArrayPointer(yy);
yp_data = N_VGetArrayPointer(yp);
rtemp_data = N_VGetArrayPointer(rtemp);
ytemp_data = N_VGetArrayPointer(ytemp);
yptemp_data = N_VGetArrayPointer(yptemp);
if (constraints != NULL) cns_data = N_VGetArrayPointer(constraints);
/* Initialize ytemp and yptemp. */
N_VScale(ONE, yy, ytemp);
N_VScale(ONE, yp, yptemp);
/* Compute miscellaneous values for the Jacobian computation. */
srur = SUNRsqrt(uround);
width = mlower + mupper + 1;
ngroups = SUNMIN(width, N);
/* Loop over column groups. */
for (group=1; group <= ngroups; group++) {
/* Increment all yy[j] and yp[j] for j in this group. */
for (j=group-1; j<N; j+=width) {
yj = y_data[j];
ypj = yp_data[j];
ewtj = ewt_data[j];
/* Set increment inc to yj based on sqrt(uround)*abs(yj), with
adjustments using ypj and ewtj if this is small, and a further
adjustment to give it the same sign as hh*ypj. */
inc = SUNMAX( srur * SUNMAX( SUNRabs(yj), SUNRabs(hh*ypj) ) , ONE/ewtj );
if (hh*ypj < ZERO) inc = -inc;
inc = (yj + inc) - yj;
/* Adjust sign(inc) again if yj has an inequality constraint. */
if (constraints != NULL) {
conj = cns_data[j];
if (SUNRabs(conj) == ONE) {if((yj+inc)*conj < ZERO) inc = -inc;}
else if (SUNRabs(conj) == TWO) {if((yj+inc)*conj <= ZERO) inc = -inc;}
}
/* Increment yj and ypj. */
ytemp_data[j] += inc;
yptemp_data[j] += cj*inc;
}
/* Call res routine with incremented arguments. */
retval = res(tt, ytemp, yptemp, rtemp, user_data);
nreDQ++;
if (retval != 0) break;
/* Loop over the indices j in this group again. */
for (j=group-1; j<N; j+=width) {
/* Reset ytemp and yptemp components that were perturbed. */
yj = ytemp_data[j] = y_data[j];
ypj = yptemp_data[j] = yp_data[j];
col_j = BAND_COL(Jac, j);
ewtj = ewt_data[j];
/* Set increment inc exactly as above. */
inc = SUNMAX( srur * SUNMAX( SUNRabs(yj), SUNRabs(hh*ypj) ) , ONE/ewtj );
if (hh*ypj < ZERO) inc = -inc;
inc = (yj + inc) - yj;
if (constraints != NULL) {
conj = cns_data[j];
if (SUNRabs(conj) == ONE) {if((yj+inc)*conj < ZERO) inc = -inc;}
else if (SUNRabs(conj) == TWO) {if((yj+inc)*conj <= ZERO) inc = -inc;}
}
/* Load the difference quotient Jacobian elements for column j. */
inc_inv = ONE/inc;
i1 = SUNMAX(0, j-mupper);
i2 = SUNMIN(j+mlower,N-1);
for (i=i1; i<=i2; i++)
BAND_COL_ELEM(col_j,i,j) = inc_inv*(rtemp_data[i]-r_data[i]);
}
}
return(retval);
}
/*
* -----------------------------------------------------------------
* idaDlsDenseDQJac
* -----------------------------------------------------------------
* This routine generates a dense difference quotient approximation to
* the Jacobian F_y + c_j*F_y'. It assumes that a dense matrix of type
* DlsMat is stored column-wise, and that elements within each column
* are contiguous. The address of the jth column of J is obtained via
* the macro LAPACK_DENSE_COL and this pointer is associated with an N_Vector
* using the N_VGetArrayPointer/N_VSetArrayPointer functions.
* Finally, the actual computation of the jth column of the Jacobian is
* done with a call to N_VLinearSum.
* -----------------------------------------------------------------
*/
int idaDlsDenseDQJac(long int N, realtype tt, realtype c_j,
N_Vector yy, N_Vector yp, N_Vector rr,
DlsMat Jac, void *data,
N_Vector tmp1, N_Vector tmp2, N_Vector tmp3)
{
realtype inc, inc_inv, yj, ypj, srur, conj;
realtype *tmp2_data, *y_data, *yp_data, *ewt_data, *cns_data = NULL;
N_Vector rtemp, jthCol;
long int j;
int retval = 0;
IDAMem IDA_mem;
IDADlsMem idadls_mem;
/* data points to IDA_mem */
IDA_mem = (IDAMem) data;
idadls_mem = (IDADlsMem) lmem;
/* Save pointer to the array in tmp2 */
tmp2_data = N_VGetArrayPointer(tmp2);
/* Rename work vectors for readibility */
rtemp = tmp1;
jthCol = tmp2;
/* Obtain pointers to the data for ewt, yy, yp. */
ewt_data = N_VGetArrayPointer(ewt);
y_data = N_VGetArrayPointer(yy);
yp_data = N_VGetArrayPointer(yp);
if(constraints!=NULL) cns_data = N_VGetArrayPointer(constraints);
srur = SUNRsqrt(uround);
for (j=0; j < N; j++) {
/* Generate the jth col of J(tt,yy,yp) as delta(F)/delta(y_j). */
/* Set data address of jthCol, and save y_j and yp_j values. */
N_VSetArrayPointer(DENSE_COL(Jac,j), jthCol);
yj = y_data[j];
ypj = yp_data[j];
/* Set increment inc to y_j based on sqrt(uround)*abs(y_j), with
adjustments using yp_j and ewt_j if this is small, and a further
adjustment to give it the same sign as hh*yp_j. */
inc = SUNMAX( srur * SUNMAX( SUNRabs(yj), SUNRabs(hh*ypj) ) , ONE/ewt_data[j] );
if (hh*ypj < ZERO) inc = -inc;
inc = (yj + inc) - yj;
/* Adjust sign(inc) again if y_j has an inequality constraint. */
if (constraints != NULL) {
conj = cns_data[j];
if (SUNRabs(conj) == ONE) {if((yj+inc)*conj < ZERO) inc = -inc;}
else if (SUNRabs(conj) == TWO) {if((yj+inc)*conj <= ZERO) inc = -inc;}
}
/* Increment y_j and yp_j, call res, and break on error return. */
y_data[j] += inc;
yp_data[j] += c_j*inc;
retval = res(tt, yy, yp, rtemp, user_data);
nreDQ++;
if (retval != 0) break;
/* Construct difference quotient in jthCol */
inc_inv = ONE/inc;
N_VLinearSum(inc_inv, rtemp, -inc_inv, rr, jthCol);
DENSE_COL(Jac,j) = N_VGetArrayPointer(jthCol);
/* reset y_j, yp_j */
y_data[j] = yj;
yp_data[j] = ypj;
}
/* Restore original array pointer in tmp2 */
N_VSetArrayPointer(tmp2_data, tmp2);
return(retval);
}
/*---------------------------------------------------------------
Initialization, Free, and Get Functions
NOTE: The band linear solver assumes a serial implementation
of the NVECTOR package. Therefore, ARKBandPrecInit will
first test for a compatible N_Vector internal
representation by checking that the function
N_VGetArrayPointer exists.
---------------------------------------------------------------*/
int ARKBandPrecInit(void *arkode_mem, long int N,
long int mu, long int ml)
{
ARKodeMem ark_mem;
ARKSpilsMem arkspils_mem;
ARKBandPrecData pdata;
long int mup, mlp, storagemu;
int flag;
if (arkode_mem == NULL) {
arkProcessError(NULL, ARKSPILS_MEM_NULL, "ARKBANDPRE", "ARKBandPrecInit", MSGBP_MEM_NULL);
return(ARKSPILS_MEM_NULL);
}
ark_mem = (ARKodeMem) arkode_mem;
/* Test if one of the SPILS linear solvers has been attached */
if (ark_mem->ark_lmem == NULL) {
arkProcessError(ark_mem, ARKSPILS_LMEM_NULL, "ARKBANDPRE", "ARKBandPrecInit", MSGBP_LMEM_NULL);
return(ARKSPILS_LMEM_NULL);
}
arkspils_mem = (ARKSpilsMem) ark_mem->ark_lmem;
/* Test if the NVECTOR package is compatible with the BAND preconditioner */
if(ark_mem->ark_tempv->ops->nvgetarraypointer == NULL) {
arkProcessError(ark_mem, ARKSPILS_ILL_INPUT, "ARKBANDPRE", "ARKBandPrecInit", MSGBP_BAD_NVECTOR);
return(ARKSPILS_ILL_INPUT);
}
pdata = NULL;
pdata = (ARKBandPrecData) malloc(sizeof *pdata); /* Allocate data memory */
if (pdata == NULL) {
arkProcessError(ark_mem, ARKSPILS_MEM_FAIL, "ARKBANDPRE", "ARKBandPrecInit", MSGBP_MEM_FAIL);
return(ARKSPILS_MEM_FAIL);
}
/* Load pointers and bandwidths into pdata block. */
pdata->arkode_mem = arkode_mem;
pdata->N = N;
pdata->mu = mup = SUNMIN(N-1, SUNMAX(0,mu));
pdata->ml = mlp = SUNMIN(N-1, SUNMAX(0,ml));
/* Initialize nfeBP counter */
pdata->nfeBP = 0;
/* Allocate memory for saved banded Jacobian approximation. */
pdata->savedJ = NULL;
pdata->savedJ = NewBandMat(N, mup, mlp, mup);
if (pdata->savedJ == NULL) {
free(pdata); pdata = NULL;
arkProcessError(ark_mem, ARKSPILS_MEM_FAIL, "ARKBANDPRE", "ARKBandPrecInit", MSGBP_MEM_FAIL);
return(ARKSPILS_MEM_FAIL);
}
/* Allocate memory for banded preconditioner. */
storagemu = SUNMIN(N-1, mup+mlp);
pdata->savedP = NULL;
pdata->savedP = NewBandMat(N, mup, mlp, storagemu);
if (pdata->savedP == NULL) {
DestroyMat(pdata->savedJ);
free(pdata); pdata = NULL;
arkProcessError(ark_mem, ARKSPILS_MEM_FAIL, "ARKBANDPRE", "ARKBandPrecInit", MSGBP_MEM_FAIL);
return(ARKSPILS_MEM_FAIL);
}
/* Allocate memory for pivot array. */
pdata->lpivots = NULL;
pdata->lpivots = NewLintArray(N);
if (pdata->lpivots == NULL) {
DestroyMat(pdata->savedP);
DestroyMat(pdata->savedJ);
free(pdata); pdata = NULL;
arkProcessError(ark_mem, ARKSPILS_MEM_FAIL, "ARKBANDPRE", "ARKBandPrecInit", MSGBP_MEM_FAIL);
return(ARKSPILS_MEM_FAIL);
}
/* make sure s_P_data is free from any previous allocations */
if (arkspils_mem->s_pfree != NULL) {
arkspils_mem->s_pfree(ark_mem);
}
/* Point to the new P_data field in the SPILS memory */
arkspils_mem->s_P_data = pdata;
/* Attach the pfree function */
arkspils_mem->s_pfree = ARKBandPrecFree;
/* Attach preconditioner solve and setup functions */
flag = ARKSpilsSetPreconditioner(arkode_mem, ARKBandPrecSetup, ARKBandPrecSolve);
return(flag);
}
/*---------------------------------------------------------------
ARKBandPDQJac:
This routine generates a banded difference quotient approximation to
the Jacobian of f(t,y). It assumes that a band matrix of type
DlsMat is stored column-wise, and that elements within each column
are contiguous. This makes it possible to get the address of a column
of J via the macro BAND_COL and to write a simple for loop to set
each of the elements of a column in succession.
---------------------------------------------------------------*/
static int ARKBandPDQJac(ARKBandPrecData pdata,
realtype t, N_Vector y, N_Vector fy,
N_Vector ftemp, N_Vector ytemp)
{
ARKodeMem ark_mem;
realtype fnorm, minInc, inc, inc_inv, srur;
long int group, i, j, width, ngroups, i1, i2;
realtype *col_j, *ewt_data, *fy_data, *ftemp_data, *y_data, *ytemp_data;
int retval;
ark_mem = (ARKodeMem) pdata->arkode_mem;
/* Obtain pointers to the data for ewt, fy, ftemp, y, ytemp. */
ewt_data = N_VGetArrayPointer(ark_mem->ark_ewt);
fy_data = N_VGetArrayPointer(fy);
ftemp_data = N_VGetArrayPointer(ftemp);
y_data = N_VGetArrayPointer(y);
ytemp_data = N_VGetArrayPointer(ytemp);
/* Load ytemp with y = predicted y vector. */
N_VScale(ONE, y, ytemp);
/* Set minimum increment based on uround and norm of f. */
srur = SUNRsqrt(ark_mem->ark_uround);
/* fnorm = N_VWrmsNorm(fy, ark_mem->ark_ewt); */
fnorm = N_VWrmsNorm(fy, ark_mem->ark_rwt);
minInc = (fnorm != ZERO) ?
(MIN_INC_MULT * SUNRabs(ark_mem->ark_h) * ark_mem->ark_uround * pdata->N * fnorm) : ONE;
/* Set bandwidth and number of column groups for band differencing. */
width = pdata->ml + pdata->mu + 1;
ngroups = SUNMIN(width, pdata->N);
for (group = 1; group <= ngroups; group++) {
/* Increment all y_j in group. */
for(j = group-1; j < pdata->N; j += width) {
inc = SUNMAX(srur*SUNRabs(y_data[j]), minInc/ewt_data[j]);
ytemp_data[j] += inc;
}
/* Evaluate f with incremented y. */
retval = ark_mem->ark_fi(t, ytemp, ftemp, ark_mem->ark_user_data);
pdata->nfeBP++;
if (retval != 0) return(retval);
/* Restore ytemp, then form and load difference quotients. */
for (j = group-1; j < pdata->N; j += width) {
ytemp_data[j] = y_data[j];
col_j = BAND_COL(pdata->savedJ,j);
inc = SUNMAX(srur*SUNRabs(y_data[j]), minInc/ewt_data[j]);
inc_inv = ONE/inc;
i1 = SUNMAX(0, j-pdata->mu);
i2 = SUNMIN(j+pdata->ml, pdata->N-1);
for (i=i1; i <= i2; i++)
BAND_COL_ELEM(col_j,i,j) =
inc_inv * (ftemp_data[i] - fy_data[i]);
}
}
return(0);
}
static int Precondbd(realtype tt, N_Vector cc,
N_Vector cp, N_Vector rr,
realtype cj, void *user_data,
N_Vector tempv1, N_Vector tempv2, N_Vector tempv3)
{
int flag, thispe;
realtype uround;
realtype xx, yy, *cxy, *ewtxy, cctemp, **Pxy, *ratesxy, *Pxycol, *cpxy;
realtype inc, sqru, fac, perturb_rates[NUM_SPECIES];
int is, js, ix, jy, ret;
UserData webdata;
void *mem;
N_Vector ewt;
realtype hh;
webdata = (UserData)user_data;
uround = UNIT_ROUNDOFF;
sqru = SUNRsqrt(uround);
thispe = webdata->thispe;
mem = webdata->ida_mem;
ewt = webdata->ewt;
flag = IDAGetErrWeights(mem, ewt);
check_flag(&flag, "IDAGetErrWeights", 1, thispe);
flag = IDAGetCurrentStep(mem, &hh);
check_flag(&flag, "IDAGetCurrentStep", 1, thispe);
for (jy = 0; jy < mysub; jy++) {
yy = (jy + jysub*mysub)*dy;
for (ix = 0; ix < mxsub; ix++) {
xx = (ix+ ixsub*mxsub)*dx;
Pxy = (webdata->PP)[ix][jy];
cxy = IJ_Vptr(cc,ix,jy);
cpxy = IJ_Vptr(cp,ix,jy);
ewtxy= IJ_Vptr(ewt,ix,jy);
ratesxy = IJ_Vptr(rates,ix,jy);
for (js = 0; js < ns; js++) {
inc = sqru*(SUNMAX(SUNRabs(cxy[js]), SUNMAX(hh*SUNRabs(cpxy[js]), ONE/ewtxy[js])));
cctemp = cxy[js]; /* Save the (js,ix,jy) element of cc. */
cxy[js] += inc; /* Perturb the (js,ix,jy) element of cc. */
fac = -ONE/inc;
WebRates(xx, yy, cxy, perturb_rates, webdata);
Pxycol = Pxy[js];
for (is = 0; is < ns; is++)
Pxycol[is] = (perturb_rates[is] - ratesxy[is])*fac;
if (js < np) Pxycol[js] += cj; /* Add partial with respect to cp. */
cxy[js] = cctemp; /* Restore (js,ix,jy) element of cc. */
} /* End of js loop. */
/* Do LU decomposition of matrix block for grid point (ix,jy). */
ret = denseGETRF(Pxy, ns, ns, (webdata->pivot)[ix][jy]);
if (ret != 0) return(1);
} /* End of ix loop. */
} /* End of jy loop. */
return(0);
}
/*
This routine generates the block-diagonal part of the Jacobian
corresponding to the interaction rates, multiplies by -gamma, adds
the identity matrix, and calls denseGETRF 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 *user_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, ngrp, ngx, ngy, mxmp, flag;
long int mp;
realtype uround, fac, r, r0, save, srur;
realtype *f1, *fsave, *cdata, *rewtdata;
WebData wdata;
void *cvode_mem;
N_Vector rewt;
wdata = (WebData) user_data;
cvode_mem = wdata->cvode_mem;
cdata = N_VGetArrayPointer_Serial(c);
rewt = wdata->rewt;
flag = CVodeGetErrWeights(cvode_mem, rewt);
if(check_flag(&flag, "CVodeGetErrWeights", 1)) return(1);
rewtdata = N_VGetArrayPointer_Serial(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 = N_VGetArrayPointer_Serial(vtemp1);
fac = N_VWrmsNorm (fc, rewt);
r0 = RCONST(1000.0)*SUNRabs(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 = SUNMAX(srur*SUNRabs(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++) {
denseAddIdentity(P[ig], mp);
ier = denseGETRF(P[ig], mp, mp, pivot[ig]);
if (ier != 0) return(1);
}
*jcurPtr = TRUE;
return(0);
}
static int PrecSetupBD(N_Vector cc, N_Vector cscale,
N_Vector fval, N_Vector fscale,
void *user_data,
N_Vector vtemp1, N_Vector vtemp2)
{
realtype r, r0, uround, sqruround, xx, yy, delx, dely, csave, fac;
realtype *cxy, *scxy, **Pxy, *ratesxy, *Pxycol, perturb_rates[NUM_SPECIES];
long int i, j, jx, jy, ret;
UserData data;
data = (UserData) user_data;
delx = data->dx;
dely = data->dy;
uround = data->uround;
sqruround = data->sqruround;
fac = N_VWL2Norm(fval, fscale);
r0 = THOUSAND * uround * fac * NEQ;
if(r0 == ZERO) r0 = ONE;
/* Loop over spatial points; get size NUM_SPECIES Jacobian block at each */
for (jy = 0; jy < MY; jy++) {
yy = jy*dely;
for (jx = 0; jx < MX; jx++) {
xx = jx*delx;
Pxy = (data->P)[jx][jy];
cxy = IJ_Vptr(cc,jx,jy);
scxy= IJ_Vptr(cscale,jx,jy);
ratesxy = IJ_Vptr((data->rates),jx,jy);
/* Compute difference quotients of interaction rate fn. */
for (j = 0; j < NUM_SPECIES; j++) {
csave = cxy[j]; /* Save the j,jx,jy element of cc */
r = SUNMAX(sqruround*SUNRabs(csave), r0/scxy[j]);
cxy[j] += r; /* Perturb the j,jx,jy element of cc */
fac = ONE/r;
WebRate(xx, yy, cxy, perturb_rates, data);
/* Restore j,jx,jy element of cc */
cxy[j] = csave;
/* Load the j-th column of difference quotients */
Pxycol = Pxy[j];
for (i = 0; i < NUM_SPECIES; i++)
Pxycol[i] = (perturb_rates[i] - ratesxy[i]) * fac;
} /* end of j loop */
/* Do LU decomposition of size NUM_SPECIES preconditioner block */
ret = denseGETRF(Pxy, NUM_SPECIES, NUM_SPECIES, (data->pivot)[jx][jy]);
if (ret != 0) return(1);
} /* end of jx loop */
} /* end of jy loop */
return(0);
}
int cvDlsDenseDQJac(long int N, realtype t,
N_Vector y, N_Vector fy,
DlsMat Jac, void *data,
N_Vector tmp1, N_Vector tmp2, N_Vector tmp3)
{
realtype fnorm, minInc, inc, inc_inv, yjsaved, srur;
realtype *tmp2_data, *y_data, *ewt_data;
N_Vector ftemp, jthCol;
long int j;
int retval = 0;
CVodeMem cv_mem;
CVDlsMem cvdls_mem;
/* data points to cvode_mem */
cv_mem = (CVodeMem) data;
cvdls_mem = (CVDlsMem) lmem;
/* Save pointer to the array in tmp2 */
tmp2_data = N_VGetArrayPointer(tmp2);
/* Rename work vectors for readibility */
ftemp = tmp1;
jthCol = tmp2;
/* Obtain pointers to the data for ewt, y */
ewt_data = N_VGetArrayPointer(ewt);
y_data = N_VGetArrayPointer(y);
/* Set minimum increment based on uround and norm of f */
srur = SUNRsqrt(uround);
fnorm = N_VWrmsNorm(fy, ewt);
minInc = (fnorm != ZERO) ?
(MIN_INC_MULT * SUNRabs(h) * uround * N * fnorm) : ONE;
for (j = 0; j < N; j++) {
/* Generate the jth col of J(tn,y) */
N_VSetArrayPointer(DENSE_COL(Jac,j), jthCol);
yjsaved = y_data[j];
inc = SUNMAX(srur*SUNRabs(yjsaved), minInc/ewt_data[j]);
y_data[j] += inc;
retval = f(t, y, ftemp, user_data);
nfeDQ++;
if (retval != 0) break;
y_data[j] = yjsaved;
inc_inv = ONE/inc;
N_VLinearSum(inc_inv, ftemp, -inc_inv, fy, jthCol);
DENSE_COL(Jac,j) = N_VGetArrayPointer(jthCol);
}
/* Restore original array pointer in tmp2 */
N_VSetArrayPointer(tmp2_data, tmp2);
return(retval);
}
int cvDlsBandDQJac(long int N, long int mupper, long int mlower,
realtype t, N_Vector y, N_Vector fy,
DlsMat Jac, void *data,
N_Vector tmp1, N_Vector tmp2, N_Vector tmp3)
{
N_Vector ftemp, ytemp;
realtype fnorm, minInc, inc, inc_inv, srur;
realtype *col_j, *ewt_data, *fy_data, *ftemp_data, *y_data, *ytemp_data;
long int group, i, j, width, ngroups, i1, i2;
int retval = 0;
CVodeMem cv_mem;
CVDlsMem cvdls_mem;
/* data points to cvode_mem */
cv_mem = (CVodeMem) data;
cvdls_mem = (CVDlsMem) lmem;
/* Rename work vectors for use as temporary values of y and f */
ftemp = tmp1;
ytemp = tmp2;
/* Obtain pointers to the data for ewt, fy, ftemp, y, ytemp */
ewt_data = N_VGetArrayPointer(ewt);
fy_data = N_VGetArrayPointer(fy);
ftemp_data = N_VGetArrayPointer(ftemp);
y_data = N_VGetArrayPointer(y);
ytemp_data = N_VGetArrayPointer(ytemp);
/* Load ytemp with y = predicted y vector */
N_VScale(ONE, y, ytemp);
/* Set minimum increment based on uround and norm of f */
srur = SUNRsqrt(uround);
fnorm = N_VWrmsNorm(fy, ewt);
minInc = (fnorm != ZERO) ?
(MIN_INC_MULT * SUNRabs(h) * uround * N * fnorm) : ONE;
/* Set bandwidth and number of column groups for band differencing */
width = mlower + mupper + 1;
ngroups = SUNMIN(width, N);
/* Loop over column groups. */
for (group=1; group <= ngroups; group++) {
/* Increment all y_j in group */
for(j=group-1; j < N; j+=width) {
inc = SUNMAX(srur*SUNRabs(y_data[j]), minInc/ewt_data[j]);
ytemp_data[j] += inc;
}
/* Evaluate f with incremented y */
retval = f(tn, ytemp, ftemp, user_data);
nfeDQ++;
if (retval != 0) break;
/* Restore ytemp, then form and load difference quotients */
for (j=group-1; j < N; j+=width) {
ytemp_data[j] = y_data[j];
col_j = BAND_COL(Jac,j);
inc = SUNMAX(srur*SUNRabs(y_data[j]), minInc/ewt_data[j]);
inc_inv = ONE/inc;
i1 = SUNMAX(0, j-mupper);
i2 = SUNMIN(j+mlower, N-1);
for (i=i1; i <= i2; i++)
BAND_COL_ELEM(col_j,i,j) = inc_inv * (ftemp_data[i] - fy_data[i]);
}
}
return(retval);
}
int CVBandPrecInit(void *cvode_mem, long int N, long int mu, long int ml)
{
CVodeMem cv_mem;
CVSpilsMem cvspils_mem;
CVBandPrecData pdata;
long int mup, mlp, storagemu;
int flag;
if (cvode_mem == NULL) {
cvProcessError(NULL, CVSPILS_MEM_NULL, "CVBANDPRE", "CVBandPrecInit", MSGBP_MEM_NULL);
return(CVSPILS_MEM_NULL);
}
cv_mem = (CVodeMem) cvode_mem;
/* Test if one of the SPILS linear solvers has been attached */
if (cv_mem->cv_lmem == NULL) {
cvProcessError(cv_mem, CVSPILS_LMEM_NULL, "CVBANDPRE", "CVBandPrecInit", MSGBP_LMEM_NULL);
return(CVSPILS_LMEM_NULL);
}
cvspils_mem = (CVSpilsMem) cv_mem->cv_lmem;
/* Test if the NVECTOR package is compatible with the BAND preconditioner */
if(vec_tmpl->ops->nvgetarraypointer == NULL) {
cvProcessError(cv_mem, CVSPILS_ILL_INPUT, "CVBANDPRE", "CVBandPrecInit", MSGBP_BAD_NVECTOR);
return(CVSPILS_ILL_INPUT);
}
pdata = NULL;
pdata = (CVBandPrecData) malloc(sizeof *pdata); /* Allocate data memory */
if (pdata == NULL) {
cvProcessError(cv_mem, CVSPILS_MEM_FAIL, "CVBANDPRE", "CVBandPrecInit", MSGBP_MEM_FAIL);
return(CVSPILS_MEM_FAIL);
}
/* Load pointers and bandwidths into pdata block. */
pdata->cvode_mem = cvode_mem;
pdata->N = N;
pdata->mu = mup = SUNMIN(N-1, SUNMAX(0,mu));
pdata->ml = mlp = SUNMIN(N-1, SUNMAX(0,ml));
/* Initialize nfeBP counter */
pdata->nfeBP = 0;
/* Allocate memory for saved banded Jacobian approximation. */
pdata->savedJ = NULL;
pdata->savedJ = NewBandMat(N, mup, mlp, mup);
if (pdata->savedJ == NULL) {
free(pdata); pdata = NULL;
cvProcessError(cv_mem, CVSPILS_MEM_FAIL, "CVBANDPRE", "CVBandPrecInit", MSGBP_MEM_FAIL);
return(CVSPILS_MEM_FAIL);
}
/* Allocate memory for banded preconditioner. */
storagemu = SUNMIN(N-1, mup+mlp);
pdata->savedP = NULL;
pdata->savedP = NewBandMat(N, mup, mlp, storagemu);
if (pdata->savedP == NULL) {
DestroyMat(pdata->savedJ);
free(pdata); pdata = NULL;
cvProcessError(cv_mem, CVSPILS_MEM_FAIL, "CVBANDPRE", "CVBandPrecInit", MSGBP_MEM_FAIL);
return(CVSPILS_MEM_FAIL);
}
/* Allocate memory for pivot array. */
pdata->lpivots = NULL;
pdata->lpivots = NewLintArray(N);
if (pdata->lpivots == NULL) {
DestroyMat(pdata->savedP);
DestroyMat(pdata->savedJ);
free(pdata); pdata = NULL;
cvProcessError(cv_mem, CVSPILS_MEM_FAIL, "CVBANDPRE", "CVBandPrecInit", MSGBP_MEM_FAIL);
return(CVSPILS_MEM_FAIL);
}
/* Overwrite the P_data field in the SPILS memory */
cvspils_mem->s_P_data = pdata;
/* Attach the pfree function */
cvspils_mem->s_pfree = CVBandPrecFree;
/* Attach preconditioner solve and setup functions */
flag = CVSpilsSetPreconditioner(cvode_mem, CVBandPrecSetup, CVBandPrecSolve);
return(flag);
}
/*-----------------------------------------------------------------
cvLsBandDQJac
This routine generates a banded difference quotient approximation
to the Jacobian of f(t,y). It assumes that a band SUNMatrix is
stored column-wise, and that elements within each column are
contiguous. This makes it possible to get the address of a column
of J via the accessor function SUNBandMatrix_Column, and to write
a simple for loop to set each of the elements of a column in
succession.
-----------------------------------------------------------------*/
int cvLsBandDQJac(realtype t, N_Vector y, N_Vector fy, SUNMatrix Jac,
CVodeMem cv_mem, N_Vector tmp1, N_Vector tmp2)
{
N_Vector ftemp, ytemp;
realtype fnorm, minInc, inc, inc_inv, srur, conj;
realtype *col_j, *ewt_data, *fy_data, *ftemp_data;
realtype *y_data, *ytemp_data, *cns_data;
sunindextype group, i, j, width, ngroups, i1, i2;
sunindextype N, mupper, mlower;
CVLsMem cvls_mem;
int retval = 0;
/* access LsMem interface structure */
cvls_mem = (CVLsMem) cv_mem->cv_lmem;
/* access matrix dimensions */
N = SUNBandMatrix_Columns(Jac);
mupper = SUNBandMatrix_UpperBandwidth(Jac);
mlower = SUNBandMatrix_LowerBandwidth(Jac);
/* Rename work vectors for use as temporary values of y and f */
ftemp = tmp1;
ytemp = tmp2;
/* Obtain pointers to the data for ewt, fy, ftemp, y, ytemp */
ewt_data = N_VGetArrayPointer(cv_mem->cv_ewt);
fy_data = N_VGetArrayPointer(fy);
ftemp_data = N_VGetArrayPointer(ftemp);
y_data = N_VGetArrayPointer(y);
ytemp_data = N_VGetArrayPointer(ytemp);
if (cv_mem->cv_constraints != NULL)
cns_data = N_VGetArrayPointer(cv_mem->cv_constraints);
/* Load ytemp with y = predicted y vector */
N_VScale(ONE, y, ytemp);
/* Set minimum increment based on uround and norm of f */
srur = SUNRsqrt(cv_mem->cv_uround);
fnorm = N_VWrmsNorm(fy, cv_mem->cv_ewt);
minInc = (fnorm != ZERO) ?
(MIN_INC_MULT * SUNRabs(cv_mem->cv_h) * cv_mem->cv_uround * N * fnorm) : ONE;
/* Set bandwidth and number of column groups for band differencing */
width = mlower + mupper + 1;
ngroups = SUNMIN(width, N);
/* Loop over column groups. */
for (group=1; group <= ngroups; group++) {
/* Increment all y_j in group */
for(j=group-1; j < N; j+=width) {
inc = SUNMAX(srur*SUNRabs(y_data[j]), minInc/ewt_data[j]);
/* Adjust sign(inc) if yj has an inequality constraint. */
if (cv_mem->cv_constraints != NULL) {
conj = cns_data[j];
if (SUNRabs(conj) == ONE) {if ((ytemp_data[j]+inc)*conj < ZERO) inc = -inc;}
else if (SUNRabs(conj) == TWO) {if ((ytemp_data[j]+inc)*conj <= ZERO) inc = -inc;}
}
ytemp_data[j] += inc;
}
/* Evaluate f with incremented y */
retval = cv_mem->cv_f(cv_mem->cv_tn, ytemp, ftemp, cv_mem->cv_user_data);
cvls_mem->nfeDQ++;
if (retval != 0) break;
/* Restore ytemp, then form and load difference quotients */
for (j=group-1; j < N; j+=width) {
ytemp_data[j] = y_data[j];
col_j = SUNBandMatrix_Column(Jac, j);
inc = SUNMAX(srur*SUNRabs(y_data[j]), minInc/ewt_data[j]);
/* Adjust sign(inc) as before. */
if (cv_mem->cv_constraints != NULL) {
conj = cns_data[j];
if (SUNRabs(conj) == ONE) {if ((ytemp_data[j]+inc)*conj < ZERO) inc = -inc;}
else if (SUNRabs(conj) == TWO) {if ((ytemp_data[j]+inc)*conj <= ZERO) inc = -inc;}
}
inc_inv = ONE/inc;
i1 = SUNMAX(0, j-mupper);
i2 = SUNMIN(j+mlower, N-1);
for (i=i1; i <= i2; i++)
SM_COLUMN_ELEMENT_B(col_j,i,j) = inc_inv * (ftemp_data[i] - fy_data[i]);
}
}
return(retval);
}
