CAMLprim value c_bandmatrix_new_band_mat(value vdims)
{
CAMLparam1(vdims);
CAMLlocal1(vr);
long int n = Long_val(Field(vdims, RECORD_DLS_BANDMATRIX_DIMS_N));
long int mu = Long_val(Field(vdims, RECORD_DLS_BANDMATRIX_DIMS_MU));
long int smu = Long_val(Field(vdims, RECORD_DLS_BANDMATRIX_DIMS_SMU));
long int ml = Long_val(Field(vdims, RECORD_DLS_BANDMATRIX_DIMS_ML));
DlsMat a = NewBandMat(n, mu, ml, smu);
if (a == NULL)
caml_failwith("Could not create Band Matrix.");
CAMLreturn(c_dls_band_wrap(a, 1));
}
int IDABand(void *ida_mem, int Neq, int mupper, 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, "IDASBAND", "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, "IDASBAND", "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, "IDASBAND", "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, "IDASBAND", "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 = MIN(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, "IDASBAND", "IDABand", MSGD_MEM_FAIL);
free(idadls_mem); idadls_mem = NULL;
return(IDADLS_MEM_FAIL);
}
pivots = NULL;
pivots = NewIntArray(Neq);
if (pivots == NULL) {
IDAProcessError(IDA_mem, IDADLS_MEM_FAIL, "IDASBAND", "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);
}
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 CVBBDPrecInit(void *cvode_mem, int Nlocal,
int mudq, int mldq,
int mukeep, int mlkeep,
realtype dqrely,
CVLocalFn gloc, CVCommFn cfn)
{
CVodeMem cv_mem;
CVSpilsMem cvspils_mem;
CVBBDPrecData pdata;
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 = MIN(Nlocal-1, MAX(0,mudq));
pdata->mldq = MIN(Nlocal-1, MAX(0,mldq));
muk = MIN(Nlocal-1, MAX(0,mukeep));
mlk = MIN(Nlocal-1, MAX(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 = MIN(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 pivots */
pdata->pivots = NULL;
pdata->pivots = NewIntArray(Nlocal);
if (pdata->savedJ == 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 : RSqrt(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 CVBand(void *cvode_mem, int N, int mupper, int mlower)
{
CVodeMem cv_mem;
CVDlsMem cvdls_mem;
/* Return immediately if cvode_mem is NULL */
if (cvode_mem == NULL) {
cvProcessError(NULL, CVDLS_MEM_NULL, "CVSBAND", "CVBand", MSGD_CVMEM_NULL);
return(CVDLS_MEM_NULL);
}
cv_mem = (CVodeMem) cvode_mem;
/* Test if the NVECTOR package is compatible with the BAND solver */
if (vec_tmpl->ops->nvgetarraypointer == NULL) {
cvProcessError(cv_mem, CVDLS_ILL_INPUT, "CVSBAND", "CVBand", MSGD_BAD_NVECTOR);
return(CVDLS_ILL_INPUT);
}
if (lfree != NULL) lfree(cv_mem);
/* Set four main function fields in cv_mem */
linit = cvBandInit;
lsetup = cvBandSetup;
lsolve = cvBandSolve;
lfree = cvBandFree;
/* Get memory for CVDlsMemRec */
cvdls_mem = NULL;
cvdls_mem = (CVDlsMem) malloc(sizeof(struct CVDlsMemRec));
if (cvdls_mem == NULL) {
cvProcessError(cv_mem, CVDLS_MEM_FAIL, "CVSBAND", "CVBand", MSGD_MEM_FAIL);
return(CVDLS_MEM_FAIL);
}
/* Set matrix type */
mtype = SUNDIALS_BAND;
/* Initialize Jacobian-related data */
jacDQ = TRUE;
jac = NULL;
J_data = NULL;
last_flag = CVDLS_SUCCESS;
setupNonNull = TRUE;
/* Load problem dimension */
n = N;
/* Load half-bandwiths in cvdls_mem */
ml = mlower;
mu = mupper;
/* Test ml and mu for legality */
if ((ml < 0) || (mu < 0) || (ml >= N) || (mu >= N)) {
cvProcessError(cv_mem, CVDLS_ILL_INPUT, "CVSBAND", "CVBand", MSGD_BAD_SIZES);
return(CVDLS_ILL_INPUT);
}
/* Set extended upper half-bandwith for M (required for pivoting) */
smu = MIN(N-1, mu + ml);
/* Allocate memory for M, savedJ, and pivot arrays */
M = NULL;
M = NewBandMat(N, mu, ml, smu);
if (M == NULL) {
cvProcessError(cv_mem, CVDLS_MEM_FAIL, "CVSBAND", "CVBand", MSGD_MEM_FAIL);
free(cvdls_mem); cvdls_mem = NULL;
return(CVDLS_MEM_FAIL);
}
savedJ = NULL;
savedJ = NewBandMat(N, mu, ml, mu);
if (savedJ == NULL) {
cvProcessError(cv_mem, CVDLS_MEM_FAIL, "CVSBAND", "CVBand", MSGD_MEM_FAIL);
DestroyMat(M);
free(cvdls_mem); cvdls_mem = NULL;
return(CVDLS_MEM_FAIL);
}
pivots = NULL;
pivots = NewIntArray(N);
if (pivots == NULL) {
cvProcessError(cv_mem, CVDLS_MEM_FAIL, "CVSBAND", "CVBand", MSGD_MEM_FAIL);
DestroyMat(M);
DestroyMat(savedJ);
free(cvdls_mem); cvdls_mem = NULL;
return(CVDLS_MEM_FAIL);
}
/* Attach linear solver memory to integrator memory */
lmem = cvdls_mem;
return(CVDLS_SUCCESS);
}
void *CPBBDPrecAlloc(void *cpode_mem, int Nlocal,
int mudq, int mldq, int mukeep, int mlkeep,
realtype dqrely,
void *gloc, CPBBDCommFn cfn)
{
CPodeMem cp_mem;
CPBBDPrecData pdata;
N_Vector tmp4;
int muk, mlk, storage_mu;
if (cpode_mem == NULL) {
cpProcessError(NULL, 0, "CPBBDPRE", "CPBBDPrecAlloc", MSGBBDP_CPMEM_NULL);
return(NULL);
}
cp_mem = (CPodeMem) cpode_mem;
/* Test if the NVECTOR package is compatible with the BLOCK BAND preconditioner */
if(vec_tmpl->ops->nvgetarraypointer == NULL) {
cpProcessError(cp_mem, 0, "CPBBDPRE", "CPBBDPrecAlloc", MSGBBDP_BAD_NVECTOR);
return(NULL);
}
/* Allocate data memory */
pdata = NULL;
pdata = (CPBBDPrecData) malloc(sizeof *pdata);
if (pdata == NULL) {
cpProcessError(cp_mem, 0, "CPBBDPRE", "CPBBDPrecAlloc", MSGBBDP_MEM_FAIL);
return(NULL);
}
/* Set pointers to gloc and cfn; load half-bandwidths */
pdata->cpode_mem = cpode_mem;
switch (ode_type) {
case CP_EXPL:
pdata->glocE = (CPBBDLocalRhsFn) gloc;
pdata->glocI = NULL;
break;
case CP_IMPL:
pdata->glocI = (CPBBDLocalResFn) gloc;
pdata->glocE = NULL;
break;
}
pdata->cfn = cfn;
pdata->mudq = MIN(Nlocal-1, MAX(0,mudq));
pdata->mldq = MIN(Nlocal-1, MAX(0,mldq));
muk = MIN(Nlocal-1, MAX(0,mukeep));
mlk = MIN(Nlocal-1, MAX(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;
cpProcessError(cp_mem, 0, "CPBBDPRE", "CPBBDPrecAlloc", MSGBBDP_MEM_FAIL);
return(NULL);
}
/* Allocate memory for preconditioner matrix */
storage_mu = MIN(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;
cpProcessError(cp_mem, 0, "CPBBDPRE", "CPBBDPrecAlloc", MSGBBDP_MEM_FAIL);
return(NULL);
}
/* Allocate memory for pivots */
pdata->pivots = NULL;
pdata->pivots = NewIntArray(Nlocal);
if (pdata->savedJ == NULL) {
DestroyMat(pdata->savedP);
DestroyMat(pdata->savedJ);
free(pdata); pdata = NULL;
cpProcessError(cp_mem, 0, "CPBBDPRE", "CPBBDPrecAlloc", MSGBBDP_MEM_FAIL);
return(NULL);
}
/* Allocate tmp4 for use by cpBBDDQJacImpl */
tmp4 = NULL;
tmp4 = N_VClone(vec_tmpl);
if (tmp4 == NULL){
DestroyMat(pdata->savedP);
DestroyMat(pdata->savedJ);
DestroyArray(pdata->pivots);
free(pdata); pdata = NULL;
cpProcessError(cp_mem, 0, "CPBBDPRE", "CPBBDPrecAlloc", MSGBBDP_MEM_FAIL);
return(NULL);
}
pdata->tmp4 = tmp4;
/* Set pdata->dqrely based on input dqrely (0 implies default). */
pdata->dqrely = (dqrely > ZERO) ? dqrely : RSqrt(uround);
/* Store Nlocal to be used in cpBBDPrecSetupExpl and cpBBDPrecSetupImpl */
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;
return((void *)pdata);
}
/*
* -----------------------------------------------------------------
* IDALapackBand
* -----------------------------------------------------------------
* This routine initializes the memory record and sets various function
* fields specific to the band linear solver module. It first calls
* the existing lfree routine if this is not NULL. It then sets the
* ida_linit, ida_lsetup, ida_lsolve, and ida_lfree fields in (*ida_mem)
* to be idaLapackBandInit, idaLapackBandSetup, idaLapackBandSolve,
* and idaLapackBandFree, respectively. It allocates memory for a
* structure of type IDALapackBandMemRec and sets the ida_lmem field in
* (*ida_mem) to the address of this structure. It sets setupNonNull
* in (*ida_mem) to be TRUE, mu to be mupper, ml to be mlower, and
* the jacE and jacI field to NULL.
* Finally, it allocates memory for M and pivots.
* The IDALapackBand return value is IDADLS_SUCCESS = 0,
* IDADLS_MEM_FAIL = -1, or IDADLS_ILL_INPUT = -2.
*
* NOTE: The IDALAPACK linear solver assumes a serial implementation
* of the NVECTOR package. Therefore, IDALapackBand will first
* test for compatible a compatible N_Vector internal
* representation by checking that the function
* N_VGetArrayPointer exists.
* -----------------------------------------------------------------
*/
int IDALapackBand(void *ida_mem, int N, int mupper, int mlower)
{
IDAMem IDA_mem;
IDADlsMem idadls_mem;
/* Return immediately if ida_mem is NULL */
if (ida_mem == NULL) {
IDAProcessError(NULL, IDADLS_MEM_NULL, "IDALAPACK", "IDALapackBand", MSGD_IDAMEM_NULL);
return(IDADLS_MEM_NULL);
}
IDA_mem = (IDAMem) ida_mem;
/* Test if the NVECTOR package is compatible with the BAND solver */
if (tempv->ops->nvgetarraypointer == NULL) {
IDAProcessError(IDA_mem, IDADLS_ILL_INPUT, "IDALAPACK", "IDALapackBand", MSGD_BAD_NVECTOR);
return(IDADLS_ILL_INPUT);
}
if (lfree != NULL) lfree(IDA_mem);
/* Set four main function fields in IDA_mem */
linit = idaLapackBandInit;
lsetup = idaLapackBandSetup;
lsolve = idaLapackBandSolve;
lperf = NULL;
lfree = idaLapackBandFree;
/* Get memory for IDADlsMemRec */
idadls_mem = NULL;
idadls_mem = (IDADlsMem) malloc(sizeof(struct IDADlsMemRec));
if (idadls_mem == NULL) {
IDAProcessError(IDA_mem, IDADLS_MEM_FAIL, "IDALAPACK", "IDALapackBand", MSGD_MEM_FAIL);
return(IDADLS_MEM_FAIL);
}
/* Set matrix type */
mtype = SUNDIALS_BAND;
/* Set default Jacobian routine and Jacobian data */
jacDQ = TRUE;
bjac = NULL;
J_data = NULL;
last_flag = IDADLS_SUCCESS;
setupNonNull = TRUE;
/* Load problem dimension */
n = (long int) N;
/* Load half-bandwiths in idadls_mem */
ml = (long int) mlower;
mu = (long int) mupper;
/* Test ml and mu for legality */
if ((ml < 0) || (mu < 0) || (ml >= n) || (mu >= n)) {
IDAProcessError(IDA_mem, IDADLS_ILL_INPUT, "IDALAPACK", "IDALapackBand", MSGD_BAD_SIZES);
free(idadls_mem); idadls_mem = NULL;
return(IDADLS_ILL_INPUT);
}
/* Set extended upper half-bandwith for M (required for pivoting) */
smu = MIN(n-1, mu + ml);
/* Allocate memory for JJ and pivot arrays */
JJ = NULL;
pivots = NULL;
JJ = NewBandMat(n, mu, ml, smu);
if (JJ == NULL) {
IDAProcessError(IDA_mem, IDADLS_MEM_FAIL, "IDALAPACK", "IDALapackBand", MSGD_MEM_FAIL);
free(idadls_mem); idadls_mem = NULL;
return(IDADLS_MEM_FAIL);
}
pivots = NewIntArray(N);
if (pivots == NULL) {
IDAProcessError(IDA_mem, IDADLS_MEM_FAIL, "IDALAPACK", "IDALapackBand", MSGD_MEM_FAIL);
DestroyMat(JJ);
free(idadls_mem); idadls_mem = NULL;
return(IDADLS_MEM_FAIL);
}
/* Attach linear solver memory to integrator memory */
lmem = idadls_mem;
return(IDADLS_SUCCESS);
}
/*---------------------------------------------------------------
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);
}
int KINBand(void *kinmem, long int N, long int mupper, long int mlower)
{
KINMem kin_mem;
KINDlsMem kindls_mem;
/* Return immediately if kinmem is NULL */
if (kinmem == NULL) {
KINProcessError(NULL, KINDLS_MEM_NULL, "KINBAND", "KINBand", MSGD_KINMEM_NULL);
return(KINDLS_MEM_NULL);
}
kin_mem = (KINMem) kinmem;
/* Test if the NVECTOR package is compatible with the BAND solver */
if (vec_tmpl->ops->nvgetarraypointer == NULL) {
KINProcessError(kin_mem, KINDLS_ILL_INPUT, "KINBAND", "KINBand", MSGD_BAD_NVECTOR);
return(KINDLS_ILL_INPUT);
}
if (lfree != NULL) lfree(kin_mem);
/* Set four main function fields in kin_mem */
linit = kinBandInit;
lsetup = kinBandSetup;
lsolve = kinBandsolve;
lfree = kinBandFree;
/* Get memory for KINDlsMemRec */
kindls_mem = NULL;
kindls_mem = (KINDlsMem) malloc(sizeof(struct KINDlsMemRec));
if (kindls_mem == NULL) {
KINProcessError(kin_mem, KINDLS_MEM_FAIL, "KINBAND", "KINBand", MSGD_MEM_FAIL);
return(KINDLS_MEM_FAIL);
}
/* Set matrix type */
mtype = SUNDIALS_BAND;
/* Set default Jacobian routine and Jacobian data */
jacDQ = TRUE;
bjac = NULL;
J_data = NULL;
last_flag = KINDLS_SUCCESS;
setupNonNull = TRUE;
/* Load problem dimension */
n = N;
/* Load half-bandwiths in kindls_mem */
ml = mlower;
mu = mupper;
/* Test ml and mu for legality */
if ((ml < 0) || (mu < 0) || (ml >= N) || (mu >= N)) {
KINProcessError(kin_mem, KINDLS_MEM_FAIL, "KINBAND", "KINBand", MSGD_MEM_FAIL);
free(kindls_mem);
kindls_mem = NULL;
return(KINDLS_ILL_INPUT);
}
/* Set extended upper half-bandwith for M (required for pivoting) */
smu = MIN(N-1, mu + ml);
/* Allocate memory for J and pivot array */
J = NULL;
J = NewBandMat(N, mu, ml, smu);
if (J == NULL) {
KINProcessError(kin_mem, KINDLS_MEM_FAIL, "KINBAND", "KINBand", MSGD_MEM_FAIL);
free(kindls_mem);
kindls_mem = NULL;
return(KINDLS_MEM_FAIL);
}
lpivots = NULL;
lpivots = NewLintArray(N);
if (lpivots == NULL) {
KINProcessError(kin_mem, KINDLS_MEM_FAIL, "KINBAND", "KINBand", MSGD_MEM_FAIL);
DestroyMat(J);
free(kindls_mem);
kindls_mem = NULL;
return(KINDLS_MEM_FAIL);
}
/* This is a direct linear solver */
inexact_ls = FALSE;
/* Attach linear solver memory to integrator memory */
lmem = kindls_mem;
return(KINDLS_SUCCESS);
}
int CVBandPrecInit(void *cvode_mem, int N, int mu, int ml)
{
CVodeMem cv_mem;
CVSpilsMem cvspils_mem;
CVBandPrecData pdata;
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 = MIN(N-1, MAX(0,mu));
pdata->ml = mlp = MIN(N-1, MAX(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 = MIN(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->pivots = NULL;
pdata->pivots = NewIntArray(N);
if (pdata->savedJ == 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);
}
/*---------------------------------------------------------------
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);
}
/*
* -----------------------------------------------------------------
* CPLapackBand
* -----------------------------------------------------------------
* This routine initializes the memory record and sets various function
* fields specific to the band linear solver module. It first calls
* the existing lfree routine if this is not NULL. It then sets the
* cp_linit, cp_lsetup, cp_lsolve, and cp_lfree fields in (*cpode_mem)
* to be cpLapackBandInit, cpLapackBandSetup, cpLapackBandSolve,
* and cpLapackBandFree, respectively. It allocates memory for a
* structure of type CPLapackBandMemRec and sets the cp_lmem field in
* (*cpode_mem) to the address of this structure. It sets lsetup_exists
* in (*cpode_mem) to be TRUE, mu to be mupper, ml to be mlower, and
* the jacE and jacI field to NULL.
* Finally, it allocates memory for M, pivots, and (if needed) savedJ.
* The CPLapackBand return value is CPDIRECT_SUCCESS = 0,
* CPDIRECT_MEM_FAIL = -1, or CPDIRECT_ILL_INPUT = -2.
*
* NOTE: The CPLAPACK linear solver assumes a serial implementation
* of the NVECTOR package. Therefore, CPLapackBand will first
* test for compatible a compatible N_Vector internal
* representation by checking that the function
* N_VGetArrayPointer exists.
* -----------------------------------------------------------------
*/
int CPLapackBand(void *cpode_mem, int N, int mupper, int mlower)
{
CPodeMem cp_mem;
CPDlsMem cpdls_mem;
/* Return immediately if cpode_mem is NULL */
if (cpode_mem == NULL) {
cpProcessError(NULL, CPDIRECT_MEM_NULL, "CPLAPACK", "CPLapackBand", MSGD_CPMEM_NULL);
return(CPDIRECT_MEM_NULL);
}
cp_mem = (CPodeMem) cpode_mem;
/* Test if the NVECTOR package is compatible with the BAND solver */
if (tempv->ops->nvgetarraypointer == NULL) {
cpProcessError(cp_mem, CPDIRECT_ILL_INPUT, "CPLAPACK", "CPLapackBand", MSGD_BAD_NVECTOR);
return(CPDIRECT_ILL_INPUT);
}
if (lfree != NULL) lfree(cp_mem);
/* Set four main function fields in cp_mem */
linit = cpLapackBandInit;
lsetup = cpLapackBandSetup;
lsolve = cpLapackBandSolve;
lfree = cpLapackBandFree;
/* Get memory for CPDlsMemRec */
cpdls_mem = NULL;
cpdls_mem = (CPDlsMem) malloc(sizeof(CPDlsMemRec));
if (cpdls_mem == NULL) {
cpProcessError(cp_mem, CPDIRECT_MEM_FAIL, "CPLAPACK", "CPLapackBand", MSGD_MEM_FAIL);
return(CPDIRECT_MEM_FAIL);
}
/* Set matrix type */
mtype = SUNDIALS_BAND;
/* Set default Jacobian routine and Jacobian data */
bjacE = NULL;
bjacI = NULL;
J_data = NULL;
last_flag = CPDIRECT_SUCCESS;
lsetup_exists = TRUE;
/* Load problem dimension */
n = N;
/* Load half-bandwiths in cpdls_mem */
ml = mlower;
mu = mupper;
/* Test ml and mu for legality */
if ((ml < 0) || (mu < 0) || (ml >= N) || (mu >= N)) {
cpProcessError(cp_mem, CPDIRECT_ILL_INPUT, "CPLAPACK", "CPLapackBand", MSGD_BAD_SIZES);
return(CPDIRECT_ILL_INPUT);
}
/* Set extended upper half-bandwith for M (required for pivoting) */
smu = MIN(N-1, mu + ml);
/* Allocate memory for M, savedJ, and pivot arrays */
M = NULL;
pivots = NULL;
savedJ = NULL;
M = NewBandMat(N, mu, ml, smu);
if (M == NULL) {
cpProcessError(cp_mem, CPDIRECT_MEM_FAIL, "CPLAPACK", "CPLapackBand", MSGD_MEM_FAIL);
free(cpdls_mem);
return(CPDIRECT_MEM_FAIL);
}
pivots = NewIntArray(N);
if (pivots == NULL) {
cpProcessError(cp_mem, CPDIRECT_MEM_FAIL, "CPLAPACK", "CPLapackBand", MSGD_MEM_FAIL);
DestroyMat(M);
free(cpdls_mem);
return(CPDIRECT_MEM_FAIL);
}
if (ode_type == CP_EXPL) {
savedJ = NewBandMat(N, mu, ml, smu);
if (savedJ == NULL) {
cpProcessError(cp_mem, CPDIRECT_MEM_FAIL, "CPLAPACK", "CPLapackBand", MSGD_MEM_FAIL);
DestroyMat(M);
DestroyArray(pivots);
free(cpdls_mem);
return(CPDIRECT_MEM_FAIL);
}
}
/* Attach linear solver memory to integrator memory */
lmem = cpdls_mem;
return(CPDIRECT_SUCCESS);
}
sdBandMatrix::sdBandMatrix(long int N, long int bwUpper, long int bwLower)
{
alloc = true;
M = NewBandMat(N,bwUpper,bwLower, std::min(N-1, bwUpper+bwLower));
}
