realtype N_VMinQuotient_Parallel(N_Vector num, N_Vector denom)
{
booleantype notEvenOnce;
long int i, N;
realtype *nd, *dd, min;
MPI_Comm comm;
nd = dd = NULL;
N = NV_LOCLENGTH_P(num);
nd = NV_DATA_P(num);
dd = NV_DATA_P(denom);
comm = NV_COMM_P(num);
notEvenOnce = TRUE;
min = BIG_REAL;
for (i = 0; i < N; i++) {
if (dd[i] == ZERO) continue;
else {
if (!notEvenOnce) min = SUNMIN(min, nd[i]/dd[i]);
else {
min = nd[i]/dd[i];
notEvenOnce = FALSE;
}
}
}
return(VAllReduce_Parallel(min, 3, comm));
}
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];
}
}
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;
}
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;
}
realtype N_VMinQuotient_Petsc(N_Vector num, N_Vector denom)
{
booleantype notEvenOnce = TRUE;
long int i;
long int N = NV_LOCLENGTH_PTC(num);
MPI_Comm comm = NV_COMM_PTC(num);
Vec *nv = NV_PVEC_PTC(num);
Vec *dv = NV_PVEC_PTC(denom);
PetscScalar *nd;
PetscScalar *dd;
PetscReal minval = BIG_REAL;
VecGetArray(*nv, &nd);
VecGetArray(*dv, &dd);
for (i = 0; i < N; i++) {
PetscReal nr = (PetscReal) nd[i];
PetscReal dr = (PetscReal) dd[i];
if (dr == ZERO)
continue;
else {
if (!notEvenOnce)
minval = SUNMIN(minval, nr/dr);
else {
minval = nr/dr;
notEvenOnce = FALSE;
}
}
}
VecRestoreArray(*nv, &nd);
VecRestoreArray(*dv, &dd);
return(VAllReduce_Petsc(minval, 3, comm));
}
CAMLprim value sunml_lsolver_lapack_band(value vnvec, value vbmat)
{
CAMLparam2(vnvec, vbmat);
#if SUNDIALS_LIB_VERSION >= 300 && defined SUNDIALS_ML_LAPACK
SUNMatrix bmat = MAT_VAL(vbmat);
SUNLinearSolver ls = SUNLapackBand(NVEC_VAL(vnvec), bmat);
if (ls == NULL) {
if (SUNBandMatrix_Rows(bmat) != SUNBandMatrix_Columns(bmat))
caml_raise_constant(LSOLVER_EXN(MatrixNotSquare));
if (SUNBandMatrix_StoredUpperBandwidth(bmat) <
SUNMIN(SUNBandMatrix_Rows(bmat) - 1,
SUNBandMatrix_LowerBandwidth(bmat)
+ SUNBandMatrix_UpperBandwidth(bmat)))
caml_raise_constant(LSOLVER_EXN(InsufficientStorageUpperBandwidth));
if (SUNBandMatrix_Rows(bmat) != NV_LENGTH_S(NVEC_VAL(vnvec)))
caml_raise_constant(LSOLVER_EXN(MatrixVectorMismatch));
caml_raise_out_of_memory();
}
CAMLreturn(alloc_lsolver(ls));
#else
CAMLreturn(Val_unit);
#endif
}
static int KINBBDPrecSetup(N_Vector uu, N_Vector uscale,
N_Vector fval, N_Vector fscale,
void *bbd_data,
N_Vector vtemp1, N_Vector vtemp2)
{
KBBDPrecData pdata;
KINMem kin_mem;
int retval;
long int ier;
pdata = (KBBDPrecData) bbd_data;
kin_mem = (KINMem) pdata->kin_mem;
/* call KBBDDQJac for a new jacobian and store in PP */
SetToZero(PP);
retval = KBBDDQJac(pdata, uu, uscale, vtemp1, vtemp2, vtemp3);
if (retval != 0) {
KINProcessError(kin_mem, -1, "KINBBDPRE", "KINBBDPrecSetup", MSGBBD_FUNC_FAILED);
return(-1);
}
nge += (1 + SUNMIN(mldq+mudq+1, Nlocal));
/* do LU factorization of P in place (in PP) */
ier = BandGBTRF(PP, lpivots);
/* return 0 if the LU was complete, else return 1 */
if (ier > 0) return(1);
else return(0);
}
int IDASetMaxOrd(void *ida_mem, int maxord)
{
IDAMem IDA_mem;
int maxord_alloc;
if (ida_mem==NULL) {
IDAProcessError(NULL, IDA_MEM_NULL, "IDA", "IDASetMaxOrd", MSG_NO_MEM);
return(IDA_MEM_NULL);
}
IDA_mem = (IDAMem) ida_mem;
if (maxord <= 0) {
IDAProcessError(IDA_mem, IDA_ILL_INPUT, "IDA", "IDASetMaxOrd", MSG_NEG_MAXORD);
return(IDA_ILL_INPUT);
}
/* Cannot increase maximum order beyond the value that
was used when allocating memory */
maxord_alloc = IDA_mem->ida_maxord_alloc;
if (maxord > maxord_alloc) {
IDAProcessError(IDA_mem, IDA_ILL_INPUT, "IDA", "IDASetMaxOrd", MSG_BAD_MAXORD);
return(IDA_ILL_INPUT);
}
IDA_mem->ida_maxord = SUNMIN(maxord,MAXORD_DEFAULT);
return(IDA_SUCCESS);
}
/*-------------------------------------------------------------*/
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 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);
}
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;
}
}
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);
}
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 CVBandPrecGetWorkSpace(void *cvode_mem, long int *lenrwBP, long int *leniwBP)
{
CVodeMem cv_mem;
CVSpilsMem cvspils_mem;
CVBandPrecData pdata;
long int N, ml, mu, smu;
if (cvode_mem == NULL) {
cvProcessError(NULL, CVSPILS_MEM_NULL, "CVBANDPRE", "CVBandPrecGetWorkSpace", MSGBP_MEM_NULL);
return(CVSPILS_MEM_NULL);
}
cv_mem = (CVodeMem) cvode_mem;
if (cv_mem->cv_lmem == NULL) {
cvProcessError(cv_mem, CVSPILS_LMEM_NULL, "CVBANDPRE", "CVBandPrecGetWorkSpace", MSGBP_LMEM_NULL);
return(CVSPILS_LMEM_NULL);
}
cvspils_mem = (CVSpilsMem) cv_mem->cv_lmem;
if (cvspils_mem->s_P_data == NULL) {
cvProcessError(cv_mem, CVSPILS_PMEM_NULL, "CVBANDPRE", "CVBandPrecGetWorkSpace", MSGBP_PMEM_NULL);
return(CVSPILS_PMEM_NULL);
}
pdata = (CVBandPrecData) cvspils_mem->s_P_data;
N = pdata->N;
mu = pdata->mu;
ml = pdata->ml;
smu = SUNMIN( N-1, mu + ml);
*leniwBP = pdata->N;
*lenrwBP = N * ( 2*ml + smu + mu + 2 );
return(CVSPILS_SUCCESS);
}
int ARKBandPrecGetWorkSpace(void *arkode_mem, long int *lenrwBP, long int *leniwBP)
{
ARKodeMem ark_mem;
ARKSpilsMem arkspils_mem;
ARKBandPrecData pdata;
long int N, ml, mu, smu;
if (arkode_mem == NULL) {
arkProcessError(NULL, ARKSPILS_MEM_NULL, "ARKBANDPRE", "ARKBandPrecGetWorkSpace", MSGBP_MEM_NULL);
return(ARKSPILS_MEM_NULL);
}
ark_mem = (ARKodeMem) arkode_mem;
if (ark_mem->ark_lmem == NULL) {
arkProcessError(ark_mem, ARKSPILS_LMEM_NULL, "ARKBANDPRE", "ARKBandPrecGetWorkSpace", MSGBP_LMEM_NULL);
return(ARKSPILS_LMEM_NULL);
}
arkspils_mem = (ARKSpilsMem) ark_mem->ark_lmem;
if (arkspils_mem->s_P_data == NULL) {
arkProcessError(ark_mem, ARKSPILS_PMEM_NULL, "ARKBANDPRE", "ARKBandPrecGetWorkSpace", MSGBP_PMEM_NULL);
return(ARKSPILS_PMEM_NULL);
}
pdata = (ARKBandPrecData) arkspils_mem->s_P_data;
N = pdata->N;
mu = pdata->mu;
ml = pdata->ml;
smu = SUNMIN( N-1, mu + ml);
*leniwBP = pdata->N;
*lenrwBP = N * ( 2*ml + smu + mu + 2 );
return(ARKSPILS_SUCCESS);
}
/*---------------------------------------------------------------
User-Callable Functions: initialization, reinit and free
---------------------------------------------------------------*/
int IDABBDPrecInit(void *ida_mem, sunindextype Nlocal,
sunindextype mudq, sunindextype mldq,
sunindextype mukeep, sunindextype mlkeep,
realtype dq_rel_yy,
IDABBDLocalFn Gres, IDABBDCommFn Gcomm)
{
IDAMem IDA_mem;
IDALsMem idals_mem;
IBBDPrecData pdata;
sunindextype muk, mlk, storage_mu, lrw1, liw1;
long int lrw, liw;
int flag;
if (ida_mem == NULL) {
IDAProcessError(NULL, IDALS_MEM_NULL, "IDASBBDPRE",
"IDABBDPrecInit", 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",
"IDABBDPrecInit", MSGBBD_LMEM_NULL);
return(IDALS_LMEM_NULL);
}
idals_mem = (IDALsMem) IDA_mem->ida_lmem;
/* Test compatibility of NVECTOR package with the BBD preconditioner */
if(IDA_mem->ida_tempv1->ops->nvgetarraypointer == NULL) {
IDAProcessError(IDA_mem, IDALS_ILL_INPUT, "IDASBBDPRE",
"IDABBDPrecInit", MSGBBD_BAD_NVECTOR);
return(IDALS_ILL_INPUT);
}
/* Allocate data memory. */
pdata = NULL;
pdata = (IBBDPrecData) malloc(sizeof *pdata);
if (pdata == NULL) {
IDAProcessError(IDA_mem, IDALS_MEM_FAIL, "IDASBBDPRE",
"IDABBDPrecInit", MSGBBD_MEM_FAIL);
return(IDALS_MEM_FAIL);
}
/* Set pointers to glocal and gcomm; load half-bandwidths. */
pdata->ida_mem = IDA_mem;
pdata->glocal = Gres;
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;
/* Set extended upper half-bandwidth for PP (required for pivoting). */
storage_mu = SUNMIN(Nlocal-1, muk+mlk);
/* Allocate memory for preconditioner matrix. */
pdata->PP = NULL;
pdata->PP = SUNBandMatrixStorage(Nlocal, muk, mlk, storage_mu);
if (pdata->PP == NULL) {
free(pdata); pdata = NULL;
IDAProcessError(IDA_mem, IDALS_MEM_FAIL, "IDASBBDPRE",
"IDABBDPrecInit", MSGBBD_MEM_FAIL);
return(IDALS_MEM_FAIL);
}
/* Allocate memory for temporary N_Vectors */
pdata->zlocal = NULL;
pdata->zlocal = N_VNewEmpty_Serial(Nlocal);
if (pdata->zlocal == NULL) {
SUNMatDestroy(pdata->PP);
free(pdata); pdata = NULL;
IDAProcessError(IDA_mem, IDALS_MEM_FAIL, "IDASBBDPRE",
"IDABBDPrecInit", MSGBBD_MEM_FAIL);
return(IDALS_MEM_FAIL);
}
pdata->rlocal = NULL;
pdata->rlocal = N_VNewEmpty_Serial(Nlocal);
if (pdata->rlocal == NULL) {
N_VDestroy(pdata->zlocal);
SUNMatDestroy(pdata->PP);
free(pdata); pdata = NULL;
IDAProcessError(IDA_mem, IDALS_MEM_FAIL, "IDASBBDPRE",
"IDABBDPrecInit", MSGBBD_MEM_FAIL);
return(IDALS_MEM_FAIL);
}
pdata->tempv1 = NULL;
pdata->tempv1 = N_VClone(IDA_mem->ida_tempv1);
if (pdata->tempv1 == NULL){
N_VDestroy(pdata->rlocal);
N_VDestroy(pdata->zlocal);
SUNMatDestroy(pdata->PP);
free(pdata); pdata = NULL;
IDAProcessError(IDA_mem, IDALS_MEM_FAIL, "IDASBBDPRE",
"IDABBDPrecInit", MSGBBD_MEM_FAIL);
return(IDALS_MEM_FAIL);
}
pdata->tempv2 = NULL;
pdata->tempv2 = N_VClone(IDA_mem->ida_tempv1);
if (pdata->tempv2 == NULL){
N_VDestroy(pdata->rlocal);
N_VDestroy(pdata->zlocal);
N_VDestroy(pdata->tempv1);
SUNMatDestroy(pdata->PP);
free(pdata); pdata = NULL;
IDAProcessError(IDA_mem, IDALS_MEM_FAIL, "IDASBBDPRE",
"IDABBDPrecInit", MSGBBD_MEM_FAIL);
return(IDALS_MEM_FAIL);
}
pdata->tempv3 = NULL;
pdata->tempv3 = N_VClone(IDA_mem->ida_tempv1);
if (pdata->tempv3 == NULL){
N_VDestroy(pdata->rlocal);
N_VDestroy(pdata->zlocal);
N_VDestroy(pdata->tempv1);
N_VDestroy(pdata->tempv2);
SUNMatDestroy(pdata->PP);
free(pdata); pdata = NULL;
IDAProcessError(IDA_mem, IDALS_MEM_FAIL, "IDASBBDPRE",
"IDABBDPrecInit", MSGBBD_MEM_FAIL);
return(IDALS_MEM_FAIL);
}
pdata->tempv4 = NULL;
pdata->tempv4 = N_VClone(IDA_mem->ida_tempv1);
if (pdata->tempv4 == NULL){
N_VDestroy(pdata->rlocal);
N_VDestroy(pdata->zlocal);
N_VDestroy(pdata->tempv1);
N_VDestroy(pdata->tempv2);
N_VDestroy(pdata->tempv3);
SUNMatDestroy(pdata->PP);
free(pdata); pdata = NULL;
IDAProcessError(IDA_mem, IDALS_MEM_FAIL, "IDASBBDPRE",
"IDABBDPrecInit", MSGBBD_MEM_FAIL);
return(IDALS_MEM_FAIL);
}
/* Allocate memory for banded linear solver */
pdata->LS = NULL;
pdata->LS = SUNLinSol_Band(pdata->rlocal, pdata->PP);
if (pdata->LS == NULL) {
N_VDestroy(pdata->zlocal);
N_VDestroy(pdata->rlocal);
N_VDestroy(pdata->tempv1);
N_VDestroy(pdata->tempv2);
N_VDestroy(pdata->tempv3);
N_VDestroy(pdata->tempv4);
SUNMatDestroy(pdata->PP);
free(pdata); pdata = NULL;
IDAProcessError(IDA_mem, IDALS_MEM_FAIL, "IDASBBDPRE",
"IDABBDPrecInit", MSGBBD_MEM_FAIL);
return(IDALS_MEM_FAIL);
}
/* initialize band linear solver object */
flag = SUNLinSolInitialize(pdata->LS);
if (flag != SUNLS_SUCCESS) {
N_VDestroy(pdata->zlocal);
N_VDestroy(pdata->rlocal);
N_VDestroy(pdata->tempv1);
N_VDestroy(pdata->tempv2);
N_VDestroy(pdata->tempv3);
N_VDestroy(pdata->tempv4);
SUNMatDestroy(pdata->PP);
SUNLinSolFree(pdata->LS);
free(pdata); pdata = NULL;
IDAProcessError(IDA_mem, IDALS_SUNLS_FAIL, "IDASBBDPRE",
"IDABBDPrecInit", MSGBBD_SUNLS_FAIL);
return(IDALS_SUNLS_FAIL);
}
/* 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);
/* Store Nlocal to be used in IDABBDPrecSetup */
pdata->n_local = Nlocal;
/* Set work space sizes and initialize nge. */
pdata->rpwsize = 0;
pdata->ipwsize = 0;
if (IDA_mem->ida_tempv1->ops->nvspace) {
N_VSpace(IDA_mem->ida_tempv1, &lrw1, &liw1);
pdata->rpwsize += 4*lrw1;
pdata->ipwsize += 4*liw1;
}
if (pdata->rlocal->ops->nvspace) {
N_VSpace(pdata->rlocal, &lrw1, &liw1);
pdata->rpwsize += 2*lrw1;
pdata->ipwsize += 2*liw1;
}
if (pdata->PP->ops->space) {
flag = SUNMatSpace(pdata->PP, &lrw, &liw);
pdata->rpwsize += lrw;
pdata->ipwsize += liw;
}
if (pdata->LS->ops->space) {
flag = SUNLinSolSpace(pdata->LS, &lrw, &liw);
pdata->rpwsize += lrw;
pdata->ipwsize += liw;
}
pdata->nge = 0;
/* make sure pdata is free from any previous allocations */
if (idals_mem->pfree)
idals_mem->pfree(IDA_mem);
/* Point to the new pdata field in the LS memory */
idals_mem->pdata = pdata;
/* Attach the pfree function */
idals_mem->pfree = IDABBDPrecFree;
/* Attach preconditioner solve and setup functions */
flag = IDASetPreconditioner(ida_mem, IDABBDPrecSetup,
IDABBDPrecSolve);
return(flag);
}
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);
}
/*---------------------------------------------------------------
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);
}
/*---------------------------------------------------------------
ARKMassLapackBand:
This routine initializes the memory record and sets various
function fields specific to the band mass matrix solver module.
It first calls the existing mfree routine if this is not NULL.
It then sets the ark_minit, ark_msetup, ark_msolve, and ark_mfree
fields in (*arkode_mem) to be arkMassLapackBandInit,
arkMassLapackBandSetup, arkMassLapackBandSolve, and
arkMassLapackBandFree, respectively. It allocates memory for a
structure of type ARKMassLapackBandMemRec and sets the
ark_mass_mem field in (*arkode_mem) to the address of this
structure. It sets MassSetupNonNull in (*arkode_mem) to be TRUE,
mu to be mupper, and ml to be mlower. Finally, it allocates
memory for M and pivots. The ARKMassLapackBand return value is
ARKDLS_SUCCESS=0, ARKDLS_MEM_FAIL=-1, or ARKDLS_ILL_INPUT=-2.
NOTE: The ARKLAPACK linear solver assumes a serial implementation
of the NVECTOR package. Therefore, ARKMassLapackBand will first
test for compatible a compatible N_Vector internal
representation by checking that the function
N_VGetArrayPointer exists. Again, this test is insufficient
to guarantee the serial NVECTOR package, but it's a start.
---------------------------------------------------------------*/
int ARKMassLapackBand(void *arkode_mem, int N, int mupper,
int mlower, ARKDlsBandMassFn bmass)
{
ARKodeMem ark_mem;
ARKDlsMassMem arkdls_mem;
/* Return immediately if arkode_mem is NULL */
if (arkode_mem == NULL) {
arkProcessError(NULL, ARKDLS_MEM_NULL, "ARKLAPACK",
"ARKMassLapackBand", MSGD_ARKMEM_NULL);
return(ARKDLS_MEM_NULL);
}
ark_mem = (ARKodeMem) arkode_mem;
/* Test if the NVECTOR package is compatible with the BAND solver */
if (ark_mem->ark_tempv->ops->nvgetarraypointer == NULL) {
arkProcessError(ark_mem, ARKDLS_ILL_INPUT, "ARKLAPACK",
"ARKMassLapackBand", MSGD_BAD_NVECTOR);
return(ARKDLS_ILL_INPUT);
}
if (ark_mem->ark_mfree != NULL) ark_mem->ark_mfree(ark_mem);
/* Set four main function fields in ark_mem, enable mass matrix */
ark_mem->ark_mass_matrix = TRUE;
ark_mem->ark_minit = arkMassLapackBandInit;
ark_mem->ark_msetup = arkMassLapackBandSetup;
ark_mem->ark_msolve = arkMassLapackBandSolve;
ark_mem->ark_mfree = arkMassLapackBandFree;
ark_mem->ark_mtimes = arkMassLapackBandMultiply;
ark_mem->ark_mtimes_data = (void *) ark_mem;
ark_mem->ark_msolve_type = 2;
/* Get memory for ARKDlsMassMemRec */
arkdls_mem = NULL;
arkdls_mem = (ARKDlsMassMem) malloc(sizeof(struct ARKDlsMassMemRec));
if (arkdls_mem == NULL) {
arkProcessError(ark_mem, ARKDLS_MEM_FAIL, "ARKLAPACK",
"ARKMassLapackBand", MSGD_MEM_FAIL);
return(ARKDLS_MEM_FAIL);
}
/* Set matrix type */
arkdls_mem->d_type = SUNDIALS_BAND;
/* Initialize mass-matrix-related data */
arkdls_mem->d_bmass = bmass;
arkdls_mem->d_M_data = NULL;
arkdls_mem->d_last_flag = ARKDLS_SUCCESS;
ark_mem->ark_MassSetupNonNull = TRUE;
/* Load problem dimension */
arkdls_mem->d_n = (long int) N;
/* Load half-bandwiths in arkdls_mem */
arkdls_mem->d_ml = (long int) mlower;
arkdls_mem->d_mu = (long int) mupper;
/* Test ml and mu for legality */
if ((arkdls_mem->d_ml < 0) || (arkdls_mem->d_mu < 0) ||
(arkdls_mem->d_ml >= arkdls_mem->d_n) ||
(arkdls_mem->d_mu >= arkdls_mem->d_n)) {
arkProcessError(ark_mem, ARKDLS_ILL_INPUT, "ARKLAPACK",
"ARKMassLapackBand", MSGD_BAD_SIZES);
free(arkdls_mem); arkdls_mem = NULL;
return(ARKDLS_ILL_INPUT);
}
/* Set extended upper half-bandwith for M (required for pivoting) */
arkdls_mem->d_smu = SUNMIN(arkdls_mem->d_n-1,
arkdls_mem->d_mu + arkdls_mem->d_ml);
/* Allocate memory for M and pivot array */
arkdls_mem->d_M = NULL;
arkdls_mem->d_pivots = NULL;
arkdls_mem->d_M = NewBandMat(arkdls_mem->d_n, arkdls_mem->d_mu,
arkdls_mem->d_ml, arkdls_mem->d_smu);
if (arkdls_mem->d_M == NULL) {
arkProcessError(ark_mem, ARKDLS_MEM_FAIL, "ARKLAPACK",
"ARKMassLapackBand", MSGD_MEM_FAIL);
free(arkdls_mem); arkdls_mem = NULL;
return(ARKDLS_MEM_FAIL);
}
arkdls_mem->d_pivots = NewIntArray(N);
if (arkdls_mem->d_pivots == NULL) {
arkProcessError(ark_mem, ARKDLS_MEM_FAIL, "ARKLAPACK",
"ARKMassLapackBand", MSGD_MEM_FAIL);
DestroyMat(arkdls_mem->d_M);
free(arkdls_mem); arkdls_mem = NULL;
return(ARKDLS_MEM_FAIL);
}
/* Attach linear solver memory to integrator memory */
ark_mem->ark_mass_mem = arkdls_mem;
return(ARKDLS_SUCCESS);
}
long int bandGBTRF(realtype **a, long int n, long int mu, long int ml, long int smu, long int *p)
{
long int c, r, num_rows;
long int i, j, k, l, storage_l, storage_k, last_col_k, last_row_k;
realtype *a_c, *col_k, *diag_k, *sub_diag_k, *col_j, *kptr, *jptr;
realtype max, temp, mult, a_kj;
booleantype swap;
/* zero out the first smu - mu rows of the rectangular array a */
num_rows = smu - mu;
if (num_rows > 0) {
for (c=0; c < n; c++) {
a_c = a[c];
for (r=0; r < num_rows; r++) {
a_c[r] = ZERO;
}
}
}
/* k = elimination step number */
for (k=0; k < n-1; k++, p++) {
col_k = a[k];
diag_k = col_k + smu;
sub_diag_k = diag_k + 1;
last_row_k = SUNMIN(n-1,k+ml);
/* find l = pivot row number */
l=k;
max = SUNRabs(*diag_k);
for (i=k+1, kptr=sub_diag_k; i <= last_row_k; i++, kptr++) {
if (SUNRabs(*kptr) > max) {
l=i;
max = SUNRabs(*kptr);
}
}
storage_l = ROW(l, k, smu);
*p = l;
/* check for zero pivot element */
if (col_k[storage_l] == ZERO) return(k+1);
/* swap a(l,k) and a(k,k) if necessary */
if ( (swap = (l != k) )) {
temp = col_k[storage_l];
col_k[storage_l] = *diag_k;
*diag_k = temp;
}
/* Scale the elements below the diagonal in */
/* column k by -1.0 / a(k,k). After the above swap, */
/* a(k,k) holds the pivot element. This scaling */
/* stores the pivot row multipliers -a(i,k)/a(k,k) */
/* in a(i,k), i=k+1, ..., SUNMIN(n-1,k+ml). */
mult = -ONE / (*diag_k);
for (i=k+1, kptr = sub_diag_k; i <= last_row_k; i++, kptr++)
(*kptr) *= mult;
/* row_i = row_i - [a(i,k)/a(k,k)] row_k, i=k+1, ..., SUNMIN(n-1,k+ml) */
/* row k is the pivot row after swapping with row l. */
/* The computation is done one column at a time, */
/* column j=k+1, ..., SUNMIN(k+smu,n-1). */
last_col_k = SUNMIN(k+smu,n-1);
for (j=k+1; j <= last_col_k; j++) {
col_j = a[j];
storage_l = ROW(l,j,smu);
storage_k = ROW(k,j,smu);
a_kj = col_j[storage_l];
/* Swap the elements a(k,j) and a(k,l) if l!=k. */
if (swap) {
col_j[storage_l] = col_j[storage_k];
col_j[storage_k] = a_kj;
}
/* a(i,j) = a(i,j) - [a(i,k)/a(k,k)]*a(k,j) */
/* a_kj = a(k,j), *kptr = - a(i,k)/a(k,k), *jptr = a(i,j) */
if (a_kj != ZERO) {
for (i=k+1, kptr=sub_diag_k, jptr=col_j+ROW(k+1,j,smu);
i <= last_row_k;
i++, kptr++, jptr++)
(*jptr) += a_kj * (*kptr);
}
}
}
/* set the last pivot row to be n-1 and check for a zero pivot */
*p = n-1;
if (a[n-1][smu] == ZERO) return(n);
/* return 0 to indicate success */
return(0);
}
int CVBBDPrecInit(void *cvode_mem, long int Nlocal,
long int mudq, long int mldq,
long int mukeep, long int mlkeep,
realtype dqrely,
CVLocalFn gloc, CVCommFn cfn)
{
CVodeMem cv_mem;
CVSpilsMem cvspils_mem;
CVBBDPrecData pdata;
long int muk, mlk, storage_mu;
int flag;
if (cvode_mem == NULL) {
cvProcessError(NULL, CVSPILS_MEM_NULL, "CVBBDPRE", "CVBBDPrecInit", 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", "CVBBDPrecInit", MSGBBD_LMEM_NULL);
return(CVSPILS_LMEM_NULL);
}
cvspils_mem = (CVSpilsMem) cv_mem->cv_lmem;
/* Test if the NVECTOR package is compatible with the BLOCK BAND preconditioner */
if(vec_tmpl->ops->nvgetarraypointer == NULL) {
cvProcessError(cv_mem, CVSPILS_ILL_INPUT, "CVBBDPRE", "CVBBDPrecInit", MSGBBD_BAD_NVECTOR);
return(CVSPILS_ILL_INPUT);
}
/* Allocate data memory */
pdata = NULL;
pdata = (CVBBDPrecData) malloc(sizeof *pdata);
if (pdata == NULL) {
cvProcessError(cv_mem, CVSPILS_MEM_FAIL, "CVBBDPRE", "CVBBDPrecInit", MSGBBD_MEM_FAIL);
return(CVSPILS_MEM_FAIL);
}
/* Set pointers to gloc and cfn; load half-bandwidths */
pdata->cvode_mem = cvode_mem;
pdata->gloc = gloc;
pdata->cfn = cfn;
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 saved Jacobian */
pdata->savedJ = NewBandMat(Nlocal, muk, mlk, muk);
if (pdata->savedJ == NULL) {
free(pdata); pdata = NULL;
cvProcessError(cv_mem, CVSPILS_MEM_FAIL, "CVBBDPRE", "CVBBDPrecInit", MSGBBD_MEM_FAIL);
return(CVSPILS_MEM_FAIL);
}
/* Allocate memory for preconditioner matrix */
storage_mu = SUNMIN(Nlocal-1, muk + mlk);
pdata->savedP = NULL;
pdata->savedP = NewBandMat(Nlocal, muk, mlk, storage_mu);
if (pdata->savedP == NULL) {
DestroyMat(pdata->savedJ);
free(pdata); pdata = NULL;
cvProcessError(cv_mem, CVSPILS_MEM_FAIL, "CVBBDPRE", "CVBBDPrecInit", MSGBBD_MEM_FAIL);
return(CVSPILS_MEM_FAIL);
}
/* Allocate memory for lpivots */
pdata->lpivots = NULL;
pdata->lpivots = NewLintArray(Nlocal);
if (pdata->lpivots == NULL) {
DestroyMat(pdata->savedP);
DestroyMat(pdata->savedJ);
free(pdata); pdata = NULL;
cvProcessError(cv_mem, CVSPILS_MEM_FAIL, "CVBBDPRE", "CVBBDPrecInit", MSGBBD_MEM_FAIL);
return(CVSPILS_MEM_FAIL);
}
/* Set pdata->dqrely based on input dqrely (0 implies default). */
pdata->dqrely = (dqrely > ZERO) ? dqrely : SUNRsqrt(uround);
/* Store Nlocal to be used in CVBBDPrecSetup */
pdata->n_local = Nlocal;
/* Set work space sizes and initialize nge */
pdata->rpwsize = Nlocal*(muk + 2*mlk + storage_mu + 2);
pdata->ipwsize = Nlocal;
pdata->nge = 0;
/* Overwrite the P_data field in the SPILS memory */
cvspils_mem->s_P_data = pdata;
/* Attach the pfree function */
cvspils_mem->s_pfree = CVBBDPrecFree;
/* Attach preconditioner solve and setup functions */
flag = CVSpilsSetPreconditioner(cvode_mem, CVBBDPrecSetup, CVBBDPrecSolve);
return(flag);
}
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);
}
int IDABand(void *ida_mem, long int Neq, long int mupper, long int mlower)
{
IDAMem IDA_mem;
IDADlsMem idadls_mem;
int flag;
/* Return immediately if ida_mem is NULL. */
if (ida_mem == NULL) {
IDAProcessError(NULL, IDADLS_MEM_NULL, "IDABAND", "IDABand", MSGD_IDAMEM_NULL);
return(IDADLS_MEM_NULL);
}
IDA_mem = (IDAMem) ida_mem;
/* Test if the NVECTOR package is compatible with the BAND solver */
if(vec_tmpl->ops->nvgetarraypointer == NULL) {
IDAProcessError(IDA_mem, IDADLS_ILL_INPUT, "IDABAND", "IDABand", MSGD_BAD_NVECTOR);
return(IDADLS_ILL_INPUT);
}
/* Test mlower and mupper for legality. */
if ((mlower < 0) || (mupper < 0) || (mlower >= Neq) || (mupper >= Neq)) {
IDAProcessError(IDA_mem, IDADLS_ILL_INPUT, "IDABAND", "IDABand", MSGD_BAD_SIZES);
return(IDADLS_ILL_INPUT);
}
if (lfree != NULL) flag = lfree((IDAMem) ida_mem);
/* Set five main function fields in ida_mem. */
linit = IDABandInit;
lsetup = IDABandSetup;
lsolve = IDABandSolve;
lperf = NULL;
lfree = IDABandFree;
/* Get memory for IDADlsMemRec. */
idadls_mem = NULL;
idadls_mem = (IDADlsMem) malloc(sizeof(struct IDADlsMemRec));
if (idadls_mem == NULL) {
IDAProcessError(IDA_mem, IDADLS_MEM_FAIL, "IDABAND", "IDABand", MSGD_MEM_FAIL);
return(IDADLS_MEM_FAIL);
}
/* Set matrix type */
mtype = SUNDIALS_BAND;
/* Set default Jacobian routine and Jacobian data */
jacDQ = TRUE;
bjac = NULL;
jacdata = NULL;
last_flag = IDADLS_SUCCESS;
setupNonNull = TRUE;
/* Store problem size */
neq = Neq;
idadls_mem->d_ml = mlower;
idadls_mem->d_mu = mupper;
/* Set extended upper half-bandwidth for JJ (required for pivoting). */
smu = SUNMIN(Neq-1, mupper + mlower);
/* Allocate memory for JJ and pivot array. */
JJ = NULL;
JJ = NewBandMat(Neq, mupper, mlower, smu);
if (JJ == NULL) {
IDAProcessError(IDA_mem, IDADLS_MEM_FAIL, "IDABAND", "IDABand", MSGD_MEM_FAIL);
free(idadls_mem); idadls_mem = NULL;
return(IDADLS_MEM_FAIL);
}
lpivots = NULL;
lpivots = NewLintArray(Neq);
if (lpivots == NULL) {
IDAProcessError(IDA_mem, IDADLS_MEM_FAIL, "IDABAND", "IDABand", MSGD_MEM_FAIL);
DestroyMat(JJ);
free(idadls_mem); idadls_mem = NULL;
return(IDADLS_MEM_FAIL);
}
/* Attach linear solver memory to the integrator memory */
lmem = idadls_mem;
return(IDADLS_SUCCESS);
}
/*---------------------------------------------------------------
IBBDDQJac
This routine generates a banded difference quotient approximation
to the local block of the Jacobian of G(t,y,y'). It assumes that
a band matrix of type SUNMatrix is stored column-wise, and that
elements within each column are contiguous.
All matrix elements are generated as difference quotients, by way
of calls to the user routine glocal. By virtue of the band
structure, the number of these calls is bandwidth + 1, where
bandwidth = mldq + mudq + 1. But the band matrix kept has
bandwidth = mlkeep + mukeep + 1. This routine also assumes that
the local elements of a vector are stored contiguously.
Return values are: 0 (success), > 0 (recoverable error),
or < 0 (nonrecoverable error).
----------------------------------------------------------------*/
static int IBBDDQJac(IBBDPrecData pdata, realtype tt, realtype cj,
N_Vector yy, N_Vector yp, N_Vector gref,
N_Vector ytemp, N_Vector yptemp, N_Vector gtemp)
{
IDAMem IDA_mem;
realtype inc, inc_inv;
int retval;
sunindextype group, i, j, width, ngroups, i1, i2;
realtype *ydata, *ypdata, *ytempdata, *yptempdata, *grefdata, *gtempdata;
realtype *cnsdata = NULL, *ewtdata;
realtype *col_j, conj, yj, ypj, ewtj;
IDA_mem = (IDAMem) pdata->ida_mem;
/* Initialize ytemp and yptemp. */
N_VScale(ONE, yy, ytemp);
N_VScale(ONE, yp, yptemp);
/* Obtain pointers as required to the data array of vectors. */
ydata = N_VGetArrayPointer(yy);
ypdata = N_VGetArrayPointer(yp);
gtempdata = N_VGetArrayPointer(gtemp);
ewtdata = N_VGetArrayPointer(IDA_mem->ida_ewt);
if (IDA_mem->ida_constraints != NULL)
cnsdata = N_VGetArrayPointer(IDA_mem->ida_constraints);
ytempdata = N_VGetArrayPointer(ytemp);
yptempdata= N_VGetArrayPointer(yptemp);
grefdata = N_VGetArrayPointer(gref);
/* Call gcomm and glocal to get base value of G(t,y,y'). */
if (pdata->gcomm != NULL) {
retval = pdata->gcomm(pdata->n_local, tt, yy, yp, IDA_mem->ida_user_data);
if (retval != 0) return(retval);
}
retval = pdata->glocal(pdata->n_local, tt, yy, yp, gref, IDA_mem->ida_user_data);
pdata->nge++;
if (retval != 0) return(retval);
/* Set bandwidth and number of column groups for band differencing. */
width = pdata->mldq + pdata->mudq + 1;
ngroups = SUNMIN(width, pdata->n_local);
/* Loop over groups. */
for(group = 1; group <= ngroups; group++) {
/* Loop over the components in this group. */
for(j = group-1; j < pdata->n_local; j += width) {
yj = ydata[j];
ypj = ypdata[j];
ewtj = ewtdata[j];
/* Set increment inc to yj based on rel_yy*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 = pdata->rel_yy *
SUNMAX(SUNRabs(yj), SUNMAX( SUNRabs(IDA_mem->ida_hh*ypj), ONE/ewtj));
if (IDA_mem->ida_hh*ypj < ZERO) inc = -inc;
inc = (yj + inc) - yj;
/* Adjust sign(inc) again if yj has an inequality constraint. */
if (IDA_mem->ida_constraints != NULL) {
conj = cnsdata[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. */
ytempdata[j] += inc;
yptempdata[j] += cj*inc;
}
/* Evaluate G with incremented y and yp arguments. */
retval = pdata->glocal(pdata->n_local, tt, ytemp, yptemp,
gtemp, IDA_mem->ida_user_data);
pdata->nge++;
if (retval != 0) return(retval);
/* Loop over components of the group again; restore ytemp and yptemp. */
for(j = group-1; j < pdata->n_local; j += width) {
yj = ytempdata[j] = ydata[j];
ypj = yptempdata[j] = ypdata[j];
ewtj = ewtdata[j];
/* Set increment inc as before .*/
inc = pdata->rel_yy *
SUNMAX(SUNRabs(yj), SUNMAX( SUNRabs(IDA_mem->ida_hh*ypj), ONE/ewtj));
if (IDA_mem->ida_hh*ypj < ZERO) inc = -inc;
inc = (yj + inc) - yj;
if (IDA_mem->ida_constraints != NULL) {
conj = cnsdata[j];
if (SUNRabs(conj) == ONE) {if ((yj+inc)*conj < ZERO) inc = -inc;}
else if (SUNRabs(conj) == TWO) {if ((yj+inc)*conj <= ZERO) inc = -inc;}
}
/* Form difference quotients and load into PP. */
inc_inv = ONE/inc;
col_j = SUNBandMatrix_Column(pdata->PP,j);
i1 = SUNMAX(0, j-pdata->mukeep);
i2 = SUNMIN(j + pdata->mlkeep, pdata->n_local-1);
for(i = i1; i <= i2; i++)
SM_COLUMN_ELEMENT_B(col_j,i,j) =
inc_inv * (gtempdata[i] - grefdata[i]);
}
}
return(0);
}
/*-----------------------------------------------------------------
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);
}
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);
}
static int CVBBDDQJac(CVBBDPrecData pdata, realtype t,
N_Vector y, N_Vector gy,
N_Vector ytemp, N_Vector gtemp)
{
CVodeMem cv_mem;
realtype gnorm, minInc, inc, inc_inv;
long int group, i, j, width, ngroups, i1, i2;
realtype *y_data, *ewt_data, *gy_data, *gtemp_data, *ytemp_data, *col_j;
int retval;
cv_mem = (CVodeMem) pdata->cvode_mem;
/* Load ytemp with y = predicted solution vector */
N_VScale(ONE, y, ytemp);
/* Call cfn and gloc to get base value of g(t,y) */
if (cfn != NULL) {
retval = cfn(Nlocal, t, y, user_data);
if (retval != 0) return(retval);
}
retval = gloc(Nlocal, t, ytemp, gy, user_data);
nge++;
if (retval != 0) return(retval);
/* Obtain pointers to the data for various vectors */
y_data = N_VGetArrayPointer(y);
gy_data = N_VGetArrayPointer(gy);
ewt_data = N_VGetArrayPointer(ewt);
ytemp_data = N_VGetArrayPointer(ytemp);
gtemp_data = N_VGetArrayPointer(gtemp);
/* Set minimum increment based on uround and norm of g */
gnorm = N_VWrmsNorm(gy, ewt);
minInc = (gnorm != ZERO) ?
(MIN_INC_MULT * SUNRabs(h) * uround * Nlocal * gnorm) : ONE;
/* 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 y_j in group */
for(j=group-1; j < Nlocal; j+=width) {
inc = SUNMAX(dqrely*SUNRabs(y_data[j]), minInc/ewt_data[j]);
ytemp_data[j] += inc;
}
/* Evaluate g with incremented y */
retval = gloc(Nlocal, t, ytemp, gtemp, user_data);
nge++;
if (retval != 0) return(retval);
/* Restore ytemp, then form and load difference quotients */
for (j=group-1; j < Nlocal; j+=width) {
ytemp_data[j] = y_data[j];
col_j = BAND_COL(savedJ,j);
inc = SUNMAX(dqrely*SUNRabs(y_data[j]), minInc/ewt_data[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 * (gtemp_data[i] - gy_data[i]);
}
}
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);
}
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);
}
